Các bài tập Pascal cơ bản, KINH ĐIỂN, khó, RẤT KHÓ & RẤT THÚ VỊ
(Đặc biệt ở phần GRAPHIC và phần GRAPH THEORY )
PHẦN I- CÁC BÀI TOÁN CƠ BẢN.
A/ LẬP TRÌNH KHÔNG DÙNG CẤU TRÚC NÀO.
1-Chỉ được dùng phép nhân, tính a mũ 28 với không hơn 6 phép nhân (khi Test, bạn nên cho a=2)
{Tinh a mu 28 chi dung khong hon 6 phep nhan} Uses crt; var a,b:longint; Begin clrscr; Write('Nhap a='); Readln(a); a:=a*a;
a:=a*a; Writeln('a mu 4=',a);
b:=a; {luu a mu 4 vao b} a:=a*a*a; Writeln('a mu 12=',a); a:=a*a; Writeln('a mu 24=',a); a:=a*b; Writeln('a mu 28=',a); Readln End.
2- Cho sẵn xâu ký tự sau: Sách ToanA1 250000, Sách Ly 100000, Sách Anh van 150000, Sach Mach IC 80000.
Hãy in lên màn tổng số tiền bán các loại sách thuộc xâu nhập vào trên đây. HẠN CHẾ CỦA BÀI TOÁN: Không được dùng phép gán sau
Tongsotienbansach:=250000+100000+150000+80000 hoặc các phép gán tương tự khác để tính tổng tiền bán!
Uses crt; Const s='GiaiTich2 250000, Vatly1 100000, Anh2 150000, MachIC 80000'; Var so1,so2,so3,so4:longint;k1,k2,k3,k4:integer; Begin Clrscr; Writeln('Xau cho truoc:',s); val('250000',so1,k1); val('100000',so2,k2); val('150000',so3,k3); val('80000',so4,k4); Writeln('= = = = = = = = = = = = ='); Write('Tong so tien ban cac loai sach:',so1+so2+so3+so4); Readln; End. 3-Không dùng bất kỳ cấu trúc nào, hãy so sánh hai số đọc từ bàn phím vào. (Bài này kiểm tra sự hiểu biết của hs về cách dùng toán tử gán đồng thời với toán tử quan hệ trong một dòng lệnh).
2
Thầy Trần Thông Quế
Uses crt;
Var a,b:integer; check1,check2,check3:Boolean;
Begin clrscr;
Write('a,b:'); Readln(a,b);
check1:=a>b; check2:=a 0) Then
Nhuan:=False;
End;
Case thang Of
1,3,5,7,8,10,12:songay:=31;
4,6,9,11:songay:=30;
2:If nhuan Then
songay:=29
Else
songay:=28;
End;
Writeln;
Writeln('Thang ',thang:2,'/',nam:4,' co:',songay,' ngay');
Writeln;
Writeln('Bam phim de ket thuc');
Readln
End.
8 h 54 m 28/7/2017
3
Thầy Trần Thông Quế
5- Đọc từ bàn phím vào 4 số thực mà trị của chúng thuộc khoảng [-3,0, 3,0]. Tính trị trung bình cộng của
chúng.
Test Vào -3 2 1.85 -1.05; Ra: Tong=-0.20; Trung binh cong=-0.4
Uses crt;
Var s1,s2,s3,s4,tbc,t:Real; d:byte;
Begin clrscr;
Write('s1,s2,s3,s4=');readln(s1,s2,s3,s4);
tbc:=0;t:=0;d:=0;
If (s1>=-3.0) and (s1<=3.0) then
Begin
Inc(d);
t:=t+s1;
End;
If (s2>=-3.0) and (s2<=3.0) then
Begin
Inc(d);
t:=t+s2;
End;
If (s3>=-3.0) and (s3<=3.0) then
Begin
Inc(d);
t:=t+s3;
End;
If (s4>=-3.0) and (s4<=3.0) then
Begin
Inc(d);
t:=t+s4;
End;
tbc:=t/d;
Writeln('Tong cua cac so trong khoang [-3.0,3.0]=',t:0:2);
Write(' va Trung binh cong cua chung =',tbc:0:2);
Readln;
End.
6- Lập trình đọc từ bàn phím vào một năm dương lịch, in lên màn hình tên năm âm lịch ứng với năm dương
lịch vừa nhập vào.
Ví dụ. vào:2016, ra: Bính Thân.
Uses crt;
Var Year:integer;
Begin clrscr;
Write('Cho biet nam duong lich:'); Readln(Year);
Write('Nam ',year,' la nam am lich:');
Case (Year Mod 10) of
0:Write('Canh ');
1:Write('Tan ');
2:Write('Nham ');
3:Write('Quy ');
8 h 54 m 28/7/2017
4
Thầy Trần Thông Quế
4:Write('Giap ');
5:Write('At ');
6:Write('Binh ');
7:Write('Dinh ');
8:Write('Mau ');
9:Write('Ki ');
End;
Case (Year Mod 12) of
0:Write('Than');
1:Write('Dau');
2:Write('Tuat');
3:Write('Hoi');
4:Write('Ty');
5:Write('Suu');
6:Write('Dan');
7:Write('Mao');
8:Write('Thin');
9:Write('Ti');
10:Write('Ngo');
11:Write('Mui');
End;
Readln;
End.
7- Lập trình cho biết số La Mã tương ứng của số thập phân bất kỳ đọc từ bàn phím vào.
Ví dụ vào: 2017; ra:MMXVII.
Write('M');
Begin
Program ThapPhan_LaMa;
uses crt;
var n:integer; ans:char;
Begin clrscr;
Repeat
Write('Nhap so Thap phan can chuyen:'); Readln(n);
Write(n,' ---> Viet theo chu so La ma la:');
While n>=1000 do
Begin
n:=n-1000;
End;
If n>=900 then
Write('CM');
n:=n-900;
End;
If n>=500 then
Begin
Write('D');
n:=n-500;
8 h 54 m 28/7/2017
5
Thầy Trần Thông Quế
End;
If n>=400 then
Begin
Write('CD');
n:=n-400;
End;
If n>=100 then
Begin
Write('C');
n:=n-100;
eND;
If n>=90 then
Begin
Write('XC');
n:=n-90;
End;
If n>=50 then
Begin
Write('L');
n:=n-50;
End;
If n>=40 then
Begin
Write('XL');
n:=n-40;
End;
If n>=20 then
Begin
Write('XX');
n:=n-20;
End;
If n>=10 then
Begin
Write('X');
n:=n-10;
End;
If n=9 then
Begin
Write('IX');
n:=n-9;
End;
If n>=7 then
Begin
Write('VII');
n:=n-7;
End;
If n>=5 then
Begin
Write('V');
8 h 54 m 28/7/2017
6
Thầy Trần Thông Quế
n:=n-5;
End;
If n=4 then
Begin
Write('IV');
n:=n-4;
End;
If n=3 then
Begin
Write('III');
n:=n-3;
End;
If n=2 then
Begin
Write('II');
n:=n-2;
End;
If n=1 then
Begin
Write('I');
n:=n-1;
End; Writeln;
Writeln;
Write(' ANOTHER TEST (Y/N)?'); Readln(ans);
Until Ans In ['n','N'];
End.
8- (BÀI TOÁN NGƯỢC CỦA BÀI 7). Lập trình cho viết số Thập Phân tương ứng của số La Mã đọc từ bàn
phím vào.. Ví dụ. vào: MMXVII, ra: 2017.
(BÀI NÀY KHÓ HƠN BÀI TRÊN)
Program LaMa_ThapPhan;
Uses crt;
Var s:string;
Procedure Nhap;
Begin
Writeln;
Write('Nhap vao so Lama:'); Readln(s);
End;
Function GtriThphan(s:string; i:integer):Integer;
Var x:integer;
Function Val(c:char):Integer;
Begin
Case c of
'M','m':Val:=1000;
'D','d':Val:=500;
'C','c':Val:=100;
'L','l':Val:=50;
8 h 54 m 28/7/2017
7
Thầy Trần Thông Quế
'X','x':Val:=10;
'V','v':Val:=5;
'I','i':Val:=1;
Else Val:=0;
End;
End;
Begin
x:=val(s[i]);
If i=Length(s) Then GtriLama:=x
Else If x
8 h 54 m 28/7/2017
8
Thầy Trần Thông Quế
End;
Readln;
End.
10- Không dùng thuật toán xử lý mảng 2-chiều, chỉ dùng các biến đơn, lập trình in lên màn hình bảng ziczac
chứa 100 số tự nhiên đầu tiên (Bạn có làm được bài này trong 10 phút không?)
0 1 2 3 4 5 6 7 8 9
10 11 12 13 14 15 16 17 18 19
- - - - - - - - - - - - - - - - - - - - - -
90 91 92 93 94 95 96 97 98 99
KHÔNG THỂ CÓ CODE NÀO NGẮN HƠN CODE DƯỚI ĐÂY!
Uses crt;
Var i,j:Byte;
Begin clrscr;
For i:=0 to 9 do
begin
For j:=0 to 9 do
Write(10*i+j:4);
Writeln;
end;
Readln;
End.
11- Dùng ký tự '*', lập trình tạo tam giác cân rỗng. In kết quả lên màn hình. (Bạn có làm được bài này trong
10 phút không?)
Uses Crt;
Var chcao,i: Byte;
Begin clrscr;
Write('Nhap chieu cao tam giac:'); Readln(chcao);
Writeln('*':chcao);
For i:=2 to chcao-1 do
Writeln('*':chcao-i+1,'*':2*i-2);
For i:=1 to 2*chcao-1 do
Write('*');
Writeln;
Writeln;
Readln;
End.
12- Nhập một dãy số nguyên từ bàn phím vào, lập trình tìm trong dãy ấy bộ (không kể thứ tự) 3 số liên tiếp
có tổng bằng số M cho trước.
Uses Crt;
Var a:array[1..1000] of integer;
n,i,j,k,M:integer;
Begin clrscr;
Writeln;
8 h 54 m 28/7/2017
9
Thầy Trần Thông Quế
Write(#32:2,'M='); Readln(M);
Write('n='); Readln(n);
For i:=1 to n do
Begin
Write('a[',i,']='); Readln(a[i]);
End;
Writeln('Cac bo so trong day thoa man yeu cau bai toan la:');
For i:=1 to n do
For j:=1 to n-1 do
For k:=j+1 to n do
if (i<>j) and (i<>k) and (j<>k) and (a[i]+a[j]+a[k]=M) then
Writeln(a[i]:3,a[j]:3,a[k]:3)
Readln;
End.
13- Lập trình tìm tất cả các số hoàn hảo của số n tùy ý đọc từ bàn phím vào. Yêu cầu xuất kết quả theo Form
sau:
Chẳng hạn, Vào: 1200,
Ra:
Số hoàn hảo thứ nhất: 6
Và các ước của nó là: 1 2 3
= = = = = = = = = = = = = = = = =
Số hoàn hảo thứ hai: 28
Và các ước của nó là: 1 2 4 7 14
= = = = = = = = = = = = = = = = =
. . . . . . . . . . . . . . . . . .
Uses crt;
Var i,j,n,tong_uoc,dem:longint; tt:byte;
Begin clrscr;
Repeat
Write('Nhap so nguyen duong n:'); Readln(n);
dem:=0;
For i:=1 to n Do
Begin
tong_uoc:=0;
For j:=1 to i-1 Do
If(i MOD j=0) Then tong_uoc:=tong_uoc+j;
If tong_uoc=i Then
Begin
dem:=dem+1;
Writeln('* So hoan hao thu ', dem,' la:',i);
Write('* va cac uoc so cua no la:');
For j:=1 to i-1 Do
If (i MOD J=0) Then Write(j,' ');
Writeln;
Writeln('= = = = = = = = =');
Writeln;
8 h 54 m 28/7/2017
10
Thầy Trần Thông Quế
End;
End;
Write('More (1/0)?. Come On -> Press 1; Stop -> Press 0:');
Readln(tt);
Until tt=0;
End.
*14- Kiểm tra giả thiết Goldbach – Snhirenman: “Mọi số tự nhiên CHẴN lớn hơn 2 đều có thể biểu diễn
bằng TỔNG của HAI số NGUYÊN TỐ”.
(Giả thiết Christian Goldbach – nhà toán học Đức – Nửa đầu thế kỉ XVIII, năm 1742 trong thư gửi Euler,
Goldbach viết: “Mọi số lẻ bất kỳ đều viết được dưới dạng tổng của ba số nguyên tố “. Sau này mệnh đề đó
được gọi là bài toán Goldbach (hay giả thiết Goldbach)
Hơn 250 năm bài toán Goldbach vẫn chưa được chứng minh, và cho đến năm 1930, nhà toán học Nga L. G.
Snhirenman mới chỉ chứng minh trường hợp nhỏ của giả thiết: “Mọi số chẵn n ≥ 4 đều có thể biểu diễn
thành tổng của 2 số nguyên tố”).
Uses crt;
Var so1, so2, so3, so4: integer;
kt1, kt2: boolean; {kt=kiem tra}
hoi:char;
Begin clrscr;
Repeat
Write(‘Nhap so chan so1>2:’); Readln(so1);
so2:=2;
Repeat
so3:=so1-so2;
so4:=2;
While (so4<=sqrt(so2)) And (so2 Mod so4<>0) do
Inc(so4);
If so4>sqrt(so2) then kt1:=true Else kt1:=false;
so4:=2;
While (so4<=sqrt(so3)) And (so3 Mod so4<>0) do
Inc(so4);
If so4>sqrt(so3) then kt2:=true Else kt2:=false;
Inc(so2);
Until (so3<=2) Or (kt1 and kt2);
If kt1 and kt2 then Write(‘GIA THIET GOLDBACH DUNG.’)
Else Write(‘GIA THIET GOLDBACH SAI.’);
Writeln;
Write(‘Another test (y/n)?’); Readln(hoi);
Until hoi In [‘N’, ‘n’];
End.
*15- Tìm và liệt kê tất cả các số Mersenne nhỏ hơn một số tự nhiên N cho trước (với n>=3)-Các số nguyên
tố biểu diễn được dưới dạng 2n – 1 (n-số tự nhiên) gọi là số Mersenne-
uses Crt;
Var so, n, i, ntmin:longint;
8 h 54 m 28/7/2017
11
Thầy Trần Thông Quế
check, stop: Boolean; tt:Byte;
Begin clrscr;
Repeat
Write(‘Nhap n>=3:’); Readln(n);
stop:=false;
ntmin:=2;
Writeln(#32:20,’CAC SO MERSENNE:’);
While Not stop Do
Begin
i:=2;
While (i<=sqrt(ntmin)) And (ntmin MOD i<>0) Do
Inc(i);
If i>sqrt(ntmin) then check:=true Else check:=false;
If check then
Begin
so:=1;
For i:=1 to ntmin do so:=2*so;
Dec(so,1);
i:=2;
While (i<=sqrt(so)) And (so MOD i<>0) do Inc(i);
If i>sqrt(so) then check:=true
Else check:=false;
stop:=so>n;
If check and Not stop Then
Writeln(so);
End;
Inc(ntmin);
End;
Writeln;
Write(‘Another Test (1/0)?, Come on -) press 1; Stop -> press 0:’);
Readln(tt);
Until tt=0;
End.
16- Không dùng thuật toán đệ quy, lập trình tìm và in lên màn dãy FIBONACI với độ dài cho trước n.
Program Day_Fibo;
Uses crt;
Var i,n,f1,f2,fi,fi_1,fi_2:Integer;
Begin clrscr;
Write(‘Nhap do dai day Fibonaci n=’); Readln(n);
Writeln(‘ DAY FIBONACI UNG VOI DO DAI ‘,N,’ LA:’);
Writeln;
i:=1; f1:=1;f2:=1;
fi:=f1+f2;
Write(f1:3, f2:3);
For i:=3 to n Do
Begin
8 h 54 m 28/7/2017
12
Thầy Trần Thông Quế
Write(fi:5);
f1:=f2;
f2:=fi;
fi:=f1+f2;
End;
Readln;
End.
17- Lập trình (PHI ĐỆ QUY) tìm ước số chung lớn nhất của N số tùy ý đọc từ bàn phím vào.
Test. Vào: 72 40 24 48 56, Ra: 8
Uses Crt;
Var a:Array[1..100] of integer;
n,i,tt: Byte; d: Integer;
Begin Clrscr; {Có lẽ bạn nên dùng PHÁT SINH DỮ LIỆU NGẪU NHIÊN TỰ ĐỘNG, sẽ nhanh hơn!}
Repeat
{Randomize;}
Write(‘ Nhap so luong cac so hang n:’); Readln(n);
For i:=1 to n Do
Begin
Write(‘a[‘,i,’]=’); Readln(a[i]);
End; {a[i]:=Random(20);}
Writeln(‘Day so vua nhap:’);
For i:= 1 to n Do Write(a[i]:3);
Writeln;
Writeln(‘= = = = = = = = = = = = = = =’);
For i:=1 to n-1 do
Repeat
d:=a[i];
a[i]:=a[i+1] MOD a[i];
a[i+1]:=d;
Until a[i]=0;
Write(‘USC max cua ‘,n,’ so vua nhap la:’,a[n]); Writeln;
Write(‘More(1/0)? Continue - > 1, Stop -> 0:’); Readln(tt);
Until tt=0;
End.
18- Tìm nghiệm nguyên dương của phương trình sau:
a) 4x+3y-9z=n, với 0 ≤ x, y, z ≤ 50; n- đọc từ bàn phím vào.
Không áp đặt trước miền giá trị của x, y, z hãy tìm nghiệm nguyên dương của các phương trình sau:
b) x + y + z = n ; n- đọc từ bàn phím vào.
c) x2 + y2 = n; n- đọc từ bàn phím vào.
Bài a)
Uses Crt;
Var x,y,z,n,d:integer;
8 h 54 m 28/7/2017
13
Thầy Trần Thông Quế
Begin clrscr;
Write(‘Nhap n:’); Readln(n);
d:=0;
For x:=0 to 50 do
For y:=0 to 50 do
For z:=0 to 50 do
If ((4*x+3*y-9*z)=n) then
Begin
Writeln(x:4,y:4,z:4);
Inc(d);
If (d MOD 20)=0 then
Begin
Write(‘Go ENTER -> xem tiep.’);
Readln;
End;
End;
End.
Các bài còn lại làm tưong tự.
19- Lập trình tạo bảng ba cột GÓC SIN COS, tính giá trị hàm Sin, Cos ứng với góc
ở cột cận trái. (Vì có từ góc 0o đến 360o nên yêu cầu mỗi lần chỉ hiện lên màn 20 giá trị kết quả, để XEM
TIẾP: gõ phím ENTER.)
Uses Crt;
Var goc:word;
gocradian: Real;
Begin clrscr;
Writeln(#32:9,’BANG GIA TRI GOC, SIN, COS:’);
Writeln(‘ Nho an ENTER de xem tiep.’);
For goc:=1 To 360 Do
Begin
gocradian:=goc*pi/180;
Writeln(#32:24,goc,#32:5,sin(gocradian):0:4,#32:3,cos(gocradian):0:4);
If (goc MOD 20) = 0 then Readln;
End;
End.
B.2.2) CÁC LỆNH LẶP KHÔNG XÁC ĐỊNH (WHILE. . .DO; REPEAT…UNTIL)
Lập trình giải các bài toán sau:
20- Tính gần đúng với sai số 10^-6 (1/1000000): số Pi; sinx; cosx; e^x.
a) Tính gần đúng số PI.
8 h 54 m 28/7/2017
14
Thầy Trần Thông Quế
Program tinhgandung_So_Pi;
Uses Crt;
Const ss=1E-6
Var sp: Real; n, dau: integer;
Begin clrscr;
n:=0;
sp:=0;
While (1/(2*n+1))>=ss do
Begin
If n MOD 2 = 0 then dau:=1
Else dau:=-1;
sp:=sp+dau*(1/(2*n+1));
n:=n+1;
End;
Write(‘Gia tri gan dung cua so Pi=’,4*sp:8:4);
Readln;
End.
b) TÍNH GẦN ĐÚNG SINX BỞI CÔNG THỨC TRUY HỒI RÚT GỌN CÒN 1 SỐ HẠNG
Lời nhắc không thừa:
+ Đối số x trong các hàm sin, cos ở đây cần hiểu ngầm có đơn vị đo là Radian (Trong mọi Program
để nó như một hư số).
+ và có LỜI NHẮC QUAN TRỌNG HƠN: Hãy test program với bộ số sau:
x=0 hoặc x=3.1416 (= ) sinx=0; x=1.5708 (=/2) sinx=1; x=4.7124 (=3/2) sinx=-1
và trong đầu luôn có hình ảnh Vòng Tròn Đơn Vị:
Uses Crt;
Const ss=1E-6;
Var x,S,T: Real; n: Integer; hd:char;
Begin Clrscr;
Repeat
Write(‘Nhap vao cung x (Radian)cua ham Sin:’);
Readln(x);
S:=x; T:=x; n:=0;
While ABS(T)>=ss Do
Begin
n:=n+2;
T:=-T*SQR(x)/(n*(n+1));
S:=S+T;
End;
8 h 54 m 28/7/2017
15
Thầy Trần Thông Quế
Write(‘Sin(x)=’,S:0:6);
Writeln;
Write(‘More (y/n)? Come on -> Press y; Stop -> Press n:’);
Readln(hd);
Until hd In [‘n’,’N’];
End.
HAI HÀM CÒN LẠI LÀM TƯƠNG TỰ! ĐỂ Ý:
21- Phân tích một số tự nhiên ra các thừa số nguyên tố.
Program Thua_so_nguyen_to; {Repeat và While lồng nhau}
Uses crt;
Var n,i:longint;
Begin clrscr;
Write(‘n=’);Readln(n);
Writeln(‘Cac thua so nguyen to cua ‘,n,’ la:’);
Repeat
i:=2;
While (n Mod i<>0) AND (i
22- Giả sử dân số Việt Nam năm 2017 là 96 triệu dân và tỷ lệ bình quân tăng dân số hàng năm là 3/1000.
Tính xem SỚM NHẤT đến năm nào thì dân số nước ta đạt 110 triệu dân.
Uses Crt;
Const tyle=0.003;
Var ds:Real; nam: Integer;
Begin clrscr;
Write(‘Nhap dan so hien tai:’); Readln(ds);
nam:=2017;
While (ds<=110*1E+6) Do
Begin
Inc(nam);
ds:=ds*(1+tyle);
End;
Write(‘Som nhat den nam ‘,nam,’ dan so nuoc ta dat 110 trieu dan.’);
8 h 54 m 28/7/2017
16
Thầy Trần Thông Quế
Readln;
End.
23- Cho trước số nguyên dương n có nhiều hơn 1 chữ số. Đếm số chữ số của số đó và tính tổng của chúng.
Chẳng hạn, vào: 9876543, ra: 7 và 42
Uses crt;
Var n,dem,tong:Longint;
Begin clrscr;
Write(‘Nhap so nguyen duong nhieu hon 1 chu so:’);
Readln(n);
tong:=0; dem:=0;
While n>0 Do
Begin
Inc(dem);
tong:=tong+n MOD 10;
n:=n DIV 10;
End;
Writeln(‘Tong cac chu so cua so vua nhap:’,tong);
Writeln(‘So cac chu so cua so vua nhap=’,dem);
Readln;
End.
24- Thực hiện phép chia bằng phép trừ.
Program Chia_la_tru;
Uses crt;
Var Sobichia, Sochia,Thuong, du:Longint; hoi:char;
Begin clrscr;
REPEAT
Write(‘Nhap Sobichia:’) ; Readln(Sobichia);
Write(‘Nhap Sochia<=Sobichia:’) ; Readln(Sochia);
Thuong:=0;
While (Sochia<=Sobichia) Do
Begin
Sobichia:=Sobichia-sochia;
thuong:=thuong+1;
End;
du:=Sobichia;
Writeln(‘Thuong=’,Thuong);
Writeln(‘So du=’,du);
Writeln;
Write(‘Another Test (y/n)?:’); Readln(hoi);
UNTIL hoi In [‘n’,’N’];
End.
25- Lập trình đảo ngược một số nguyên dương (PHI ĐỆ QUY) cho trước có nhiều hơn 1 chữ số. Ví dụ vào
2017, ra: 7102.
8 h 54 m 28/7/2017
17
Thầy Trần Thông Quế
USES CRT;
Var sovng, n, dv:longint;
Begin clrscr;
Write(‘n=’); Readln(n);
sovng:=0;
While (n>0) do
Begin
dv:=n MOD 10;
sovng:=10*sovng+dv; {sovng=số viết ngược}
n:=n DIV 10;
End;
Write(‘So viet nguoc lai la:’,sovng);
Readln;
End.
26- Tìm ước số chung lớn nhất của hai số nguyên dương cho trước nhờ thuật toán Euclide:
26.1) Dùng phép trừ
26.2) Dùng phép chia
ĐÁP:
26.1)
Uses crt;
Var a,b,d:integer;
Begin clrscr;
Write(‘Nhap 2 so nguyen duong:’); Readln(a,b);
While (a-b<>0) Do
Begin
if a>b then a:=a-b
else b:=b-a;
End;
Write(‘Uscmax=’,b);
Readln;
End.
26.2)
Uses crt;
Var a,b,du:integer;
Begin clrscr;
Write(‘Nhap 2 so nguyen duong:’); Readln(a,b);
While (b<>0) Do
Begin
du:=a Mod b;
a:=b;
b:=du;
End;
Write(‘Uoc so chg max=’,a);
Readln;
End.
8 h 54 m 28/7/2017
18
Thầy Trần Thông Quế
*27- Đọc từ bàn phím vào một số nguyên dương N (N>1). Tìm chữ số lớn nhất trong số vừa nhập và vị trí
của nó trong số vừa nhập. Hiện kết quả lên màn.
Program Tim_Chuso_Max;
uses crt;
Var so,i,max,temp,vitri:longint;
BEGIN Clrscr;
write(‘Nhap so :’); readln(so);
writeln(‘Trong so ‘,so,’ vua nhap ‘);
max:=0;
i:=1;
while (so<>0) do
Begin
temp:=so mod 10;
if temp>max then
Begin
max:=temp;
vitri:=i;
End;
i:=i+1;
so := so div 10;
End;
Write(‘ thi chu so ‘, max,’ la chu so lon nhat va nam o vi tri thu ‘,vitri);
Write(‘ ke tu ben phai sang.’);
readln;
END.
*28- Cho trước số tự nhiên N (ví dụ 100). Tìm & hiện lên màn tất cả các cặp số nguyên tố sinh đôi mà giá
trị của chúng không quá N. ( Hai số nguyên tố sinh đôi là hai số hơn kém nhau 2 đơn vị)
Uses crt;
Var so1, so2, so3, so4, n, dem: longint;
kt1, kt2: boolean; {kt=kiem tra}
Begin clrscr;
Write(‘Nhap so tu nhien n:’); Readln(n);
Writeln(‘Cac cap so sinh doi < n:’);
For so1:=2 to n-2 do
Begin
so4:=2;
While (so4<=sqrt(so1)) And (so1 MOD so4<>0) do
Inc(so4);
If so4>sqrt(so1) then
Begin
so2:=so1;
so3:=so2+2;
so4:=2;
While (so4<=sqrt(so3)) And (so3 Mod so4<>0) do Inc(so4);
If so4>sqrt(so3) then
Begin
8 h 54 m 28/7/2017
19
Thầy Trần Thông Quế
Inc(dem);
Writeln(dem,’:’,’(‘,so2,’,’,so3,’)’);
End;
End;
End;
Readln;
End.
*29- Trên bàn có 26 viên sỏi. Người chơi với máy tính. Mỗi lần, mỗi đối thủ chỉ bốc không hơn 4 viên. Đối
thủ nào phải bốc viên sỏi cuối cùng là thua. Tìm một chiến thuật chơi để người đi trước nhưng luôn luôn
thua máy tính.
{WRITELN(TONG_SOI-(5*i));}
PROGRAM BOCSOI;
uses crt;
VAR
TONG_SOI,I,SOI_CON,N:INTEGER;ch:char;
BEGIN
REPEAT
clrscr;
I:=1;
TONG_SOI:=26;
REPEAT
WRITELN(‘LAN BOC THU ‘,I,’:’);
WRITE(‘ BAN BOC MAY VIEN (khong qua 4 vien): ‘);READLN(N);
WRITELN(‘ MAY BOC: ‘,5-N);{WRITELN(5-N);}
WRITELN(‘ SO SOI CON LAI:= ‘,TONG_SOI-(5*i));
SOI_CON:=TONG_SOI-(5*i);
I:=I+1;
UNTIL SOI_CON =1;
WRITELN(‘BAN PHAI BOC VIEN CUOI CUNG. BAN THUA ROI!’);
writeln;
write(‘ Tiep khong (c/k):’);readln(ch);
UNTIL (ch=’k’) OR (ch=’K’);
END.
*30- Tìm và in lên màn tất cả các cặp số thân thiện mà giá trị của chúng không quá 10000. (Hai số được gọi
là thân thiện nếu TỔNG CÁC ƯỚC CỦA SỐ LỚN BẰNG SỐ NHỎ: ví dụ 48 và 75 là cặp số thân thiện vì
các uớc của 75 là: 3 5 15 25 và tổng các ước này bằng 48!)
Uses Crt;
Var n1,n2,t,k: Integer; tt:Byte;
Begin Clrscr;
Repeat
Writeln(#32:20,’Cac cap so Than Thien <10000:’);
Writeln(#32:20,’= = = = = = = = = = = = = =’);
For n1:=1 to 10000 do
Begin
8 h 54 m 28/7/2017
20
Thầy Trần Thông Quế
t:=0;
k:=2;
While (k<=(n1 DIV 2)) And (t<=10000) do
Begin
If (N1 mod k=0) Then t:=t+k;
inc(k);
End;
If (t>0) and (t<=10000) Then
Begin
n2:=t; t:=0;
k:=2;
While (k<=(n2 Div 2)) And (t<=n1) do
Begin
If (n2 mod k=0) then t:=t+k;
Inc(k);
End;
If t=n1 then Writeln(#32:30,’(‘,n1,’,’,n2,’)’);
End;
End;
Writeln(‘DONE!’);
Write(‘More?(1/0),Continue -> 1, Stop -> 0:’); Readln(tt);
Until tt=0;
End.
*31- (LUỸ THỪA NHANH. INFORMATIC OLYMPIC MOSCOW 1980). Nhập cơ số a và mũ k. Tính ak
với hạn chế: Không được dùng công thức tính lũy thừa, cũng không được dùng liên tiếp k phép nhân ( vì k
cực lớn và mục tiêu đầu bài là tính NHANH!)
PROGRAM NANGNHANH_LUYTHUA;
Uses Crt;
VAR
a, b : Real;
k, n : integer; hoi: char;
BEGIN Clrscr;
Repeat
Write('a,k= '); Readln(a,k);
Write(a,' mu ',k,' = ');
b:=1;
While k>0 do
Begin
n:=k div 2;
If (n+nPress c; Stop->Press k:');
8 h 54 m 28/7/2017
21
Thầy Trần Thông Quế
Readln(hoi);
Until hoi='k';
END.
*32- (ĐẢO BIT. INFORMATIC OLYMPIC MOSCOW 1983)
Số nguyên m được viết trong hệ cơ số 2 theo trật tự ngược lại. Số nhận được viết trong hệ thập phân được
coi là giá trị của hàm B(m). Hãy tính giá trị hàm B(m) chẳng hạn với m=512 ; 513; 514;…; 1024.
PROGRAM DaoBit; {chay voi m=513}
VAR
m, b, k: integer;
BEGIN
k:=513;
m:=1;
Writeln(m);
While m<1024 do
begin
while m>=k do
begin
m:=m-k;
k:=k div 2;
end;
m:=m+k;
k:=513;
Writeln(m);
end;
Readln;
END.
33. (Hàm Euler Eul(n)). Cho trước số tự nhiên n. Hàm Eul(n) chứa tất cả các số tự nhiên nhỏ hơn n và
nguyên tố cùng nhau với n. Tính hàm Eul(n).
Uses Crt;
Var n, ham_Eul,i,a,b,r: integer;
Begin clrscr;
Write('Nhap n:'); Readln(n);
ham_Eul:=0;
For i:=1 to (n-1) do
Begin
a:=i;
b:=n;
While b<>0 do
Begin
r:= a MOD b;
a:=b;
b:=r;
End;
If a=1 then Inc(ham_Eul);
End;
Write('Gia tri ham Euler=:',ham_Eul);
8 h 54 m 28/7/2017
22
Thầy Trần Thông Quế
Readln;
End.
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
PHẦN II. LẬP TRÌNH THEO MODUL
Trong Pascal có hai Modul để ta lập trình Đơn Thể. Âý là:
* Procedure (Thủ Tục).
* (và) FUNCTION (Hàm)
Đặc biệt các em cần chú ý và nắm thật vững bản chất 3 khái niệm sau của lập trình Modul:
a-Biến toàn cục (Global Var.) và biến cục bộ (Locate Var.)
b-Các khái niệm về tham chiếu
c-Hai phương cách truyền data trong lập trình Modul của Pascal:
c1. Truyền theo Tham Trị (Transfer By Value Parameters)
c2. Truyền theo Tham Biến (Transfer By Variable Parameters)
Trước hết các bạn hãy “khai vị” 3 “món” sau ( 3 MÓN “KHAI VỊ” NÀY KIỂM TRA XEM CÁC BẠN CÓ
HIỂU ĐẾN TẬN NGỌN NGUỒN CÁC KHÁI NIỆM a); b) ; c); d) nêu trên không. Vì chỉ khi hiểu rõ thực
chất 4 khái niệm đó, bạn mới hòng lập trình đơn thể thạo):
Không RUN program, chỉ dùng bút ghi kết quả của 3 program sau đây lên giấy + giải thích tỉ mỉ kết quả!
BA BÀI “KHAI VỊ” NÀY KHÔNG DỄ ĐÂU! NHỚ: KHÔNG ĐƯỢC RUN PROGRAM NHÉ!!!
1. Program Transf_By_Val;
Uses Crt;
Var so1, so2:integer;
Procedure Transf_Val(x, y:integer);
Begin
Writeln(' Ben trong thu tuc:');
x:=x+15;
y:=y+15;
Writeln('X=',x);
Write('Y=',y);
End;
Begin {Main Prog.)
Writeln('Co che truyen data theo THAM TRI:');
Write('Nhap so thu nhat so1='); Readln(so1);
Write('Nhap so thu hai so2='); Readln(so2);
Transf_Val(so1, so2);
Writeln;
Writeln('Ben ngoai thu tuc(tuc la sau truyen Data):');
Writeln('Bay gio so thu 1 so1=',so1);
Writeln('Bay gio so thu 2 so2=',so2);
Writeln('Go ENTER de stop!');
8 h 54 m 28/7/2017
23
Thầy Trần Thông Quế
Readln;
End.
2. Program Transf_By_Vari_Para;
Uses Crt;
Var so1, so2:integer;
Procedure Transf_By_Vari_Para(Var x, y:integer);
Begin
Writeln('Trong than thu tuc:');
x:=x+15;
y:=y+15;
Writeln(' Tham so X=', x);
Writeln(' Tham so Y=', y);
End;
BEGIN {Main Prog.}
Writeln('Co che truyen Data theo THAM BIEN:');
Write('Nhap so thu nhat so1='); Readln(so1);
Write('Nhap so thu hai so2='); Readln(so2);
Writeln('Sau khi truyen Data (tucla ben ngoai thu tuc):');
Writeln('Bay gio so1=',so1);
Writeln('Bay gio so2=',so2);
Writeln;
Write(' Go ENTER de Stop!');
Readln;
END.
3. Program Obser_Transf_Data;
Uses Crt;
Var a, b: integer;
Procedure Obser(Var x, y:Integer);
Begin
Write(x:3, y:3);
x:=2;
x:=x+1;
y:=2*x;
End;
BEGIN {Main Prog.}
Clrscr;
a:=4; b:=5;
Write('Cac gia tri a, b:', a,'; ',b);
Writeln;
Obser(a,b);
Writeln('Cac gia tri a, b:',a,'; ',b);
Obser(b,a);
Writeln('Cac gia tri b, a:',b,'; ',a);
Readln;
END.
8 h 54 m 28/7/2017
24
Thầy Trần Thông Quế
4. Lập trình đơn thể (Bạn chọn FUNCTION hay PROCEDURE LÀ VIỆC CỦA BẠN. HÃY TỰ SUY
NGHĨ TRƯỚC LÚC XEM ĐÁP ÁN BÊN DƯỚI.) thực thi 3 phép tính cơ bản (Hợp, Hiệu, Giao) của hai
tập hợp cho trước. Hiện kết quả lên màn.
BÀI NÀY NGẮN, NHƯNG KHÁ HAY VÌ NÓ CHO BẠN NHIỀU HIỂU BIẾT: 1. CÁCH KHAI BÁO Ở
ĐẦU PROGRAM; Ở 2 MODUL: CÁCH THAM CHIẾU KHÁC NHAU (TẠI SAO?); CÁCH DÙNG CÁC
LỆNH Ở MODUL NHẬP VÀ MODUL INRA…
Uses Crt;
Type Kytu='!'..'}';
Tapkytu=Set of Kytu;
Var A,B,C,D,E: Tapkytu;
Procedure Nhap(Var x:Tapkytu);
Var kt: Char;
Begin
Read(kt);
While kt<>#13 Do
Begin
x:=x+[kt];
Read(kt);
End;
End;
Procedure Inra(Y: Tapkytu);
Var kt: Char;
Begin
For kt:='!' to '}' Do
If kt In Y then Write(kt:3);
End;
{main Prog.}
Begin clrscr;
A:=[]; B:=[]; C:=[]; D:=[]; E:=[];
Write('Nhap cac phan tu cua tap A (Ngung, go ENTER:'); Nhap(A);
Write('Nhap cac phan tu cua tap B (Ngung, go ENTER:'); Nhap(B);
C:=A+B;
D:=A*B;
E:=A-B;
Write('Hop cua 2 tap vua nhap C=A+B='); Inra(C); Writeln;
Write('Giao cua 2 tap vua nhap D=A*B='); Inra(D); Writeln;
Write('Hieu cua 2 tap vua nhap E=A-B='); Inra(E); Writeln;
Readln;
End.
*5. Đọc từ bàn phím vào số nguyên dương n. Viết một hàm kiểm tra xem số ấy có là số chính phương
không (Số bằng bình phương của số tự nhiên khác gọi là số chính phương).
Uses Crt;
Var n:longint; tt:byte;
Function chphuong_check(var k:longint):boolean;
Begin
If Sqrt(k)=Trunc(Sqrt(k)) then chphuong_check:=true
8 h 54 m 28/7/2017
25
Thầy Trần Thông Quế
Else chphuong_check:=false;
End;
Begin clrscr;
Repeat
Write('Nhap so nguyen n:'); Readln(n);
If chphuong_check(n) then Write(n,' la so chinh phuong.')
Else Write(n,' khong phai la so chin phuong.');
Writeln;
Write('More (1/0)?, Continue -> press 1, Stop -> press 0:');
Readln(tt);
Until tt=0;
End.
*6. Đọc từ bàn phím vào số nguyên dương n. Viết một hàm kiểm tra xem số ấy có là số hoàn hảo không (số
bằng tổng các ước của nó kể cả đơn vị, gọi là số hoàn hảo,. Chẳng hạn 28 là số hoàn hảo vì
28= 1 + 2 + 4 + 7 + 14).
Uses Crt;
Var n:longint;
Function Hhao_Check(var k:longint):Boolean;
Var i,sum:longint;
Begin
sum:=0;
For i:=1 to k DIV 2 do
If n MOD i=0 then sum:=sum+i;
If sum=n then Hhao_Check:=true
Else Hhao_Check:=false;
End;
Begin clrscr;
Write('n='); Readln(n);
If Hhao_Check(n) then Write(n,' la so hoan hao.')
Else Write(n,' khong la so hoan hao.');
Readln;
End.
CÓ THỂ BẠN KHÔNG ĐỂ Ý HOẶC KHÔNG HIỂU: Trong 2 bài 28 & 29, biến Toàn cục và Tham số
Thực sự là trùng nhau (n). Lời gọi hàm ở Main Program luôn luôn phải dùng BIẾN TOÀN CỤC HOẶC
THAM SỐ THỰC SỰ (NGHĨA LÀ: KHÔNG ĐƯỢC DÙNG BIẾN CỤC BỘ OR KHÔNG ĐƯỢC DÙNG
THAM SỐ HÌNH THỨC).
7. Đọc từ bàn phím vào số nguyên dương n. Viết một hàm kiểm tra xem số ấy có là số nguyên tố không.
USES CRT;
Var n ,d,i: Integer;
Function ktnt:Boolean;
Begin
d:=0;
For i:=2 to n-1 do
If n mod i=0 then d:=d+1;
8 h 54 m 28/7/2017
26
Thầy Trần Thông Quế
If(d=0) and (n>1) then ktnt:=True
Else ktnt:=False;
End;
BEGIN CLRSCR;
Write(#32:5,'Nhap n = '); Readln(n);
If ktnt then
Writeln(#32:9,n,' la so nguyen to.')
Else Writeln (#32:9,n,' khong phai la so nguyen to.');
Readln;
END.
(CÁC HÀM KIỂM TRA TRÊN ĐÂY, KHÔNG NHẤT THIẾT PHẢI CÓ KIỂU BOOLEAN. KIỂU CỦA
NÓ CÓ THỂ LÀ BYTE (THƯỜNG) HOẶC LÀ CHAR (ĐÃ CÓ LÚC NHÀO BẠN THỬ VỚI KIỂU
CHAR CHO NHỮNG HÀM CÓ CHỨC NĂNG KIỂM TRA CHƯA?)
8. Đọc từ bàn phím vào một số nguyên dương, kiểm tra xem số ấy có đối xứng không. Một số đọc xuôi, đọc
ngược đều như nhau là số đối xứng. Ví dụ 123454321.
CODE DƯỚI ĐÂY LÀ NGẮN NHẤT, KHÔNG THỂ NGẮN HƠN.
Uses crt;
var n,m,tam:longint; tt:byte;
Begin clrscr;
Repeat
Write('Nhap n:'); Readln(n);
m:=0; tam:=n;
While (tam>0) Do
Begin
m:=m*10+tam MOD 10;
tam:=tam DIV 10;
End;
If m=n then Write('So vua nhap la so Doi xung.')
Else Write('So vua nhap Khong la so Doi xung.');
Writeln;
Write('Another Test (1/0)?. Come on->Press 1; Stop-> Press 0:');
Readln(tt);
Until tt=0;
End.
**9. Lập trình biểu diễn một số nguyên dương bằng tổng của n số tự nhiên LIÊN TIẾP khác. Yêu cầu xuất:
Chẳng hạn: Vào 4, ra: 4 không biểu diễn được bằng tổng 2 số tự nhiên liên tiếp.
Vào 100, ra: 100=9+10+11+12+13+14+15+16
Số 100 biểu diễn được bằng tổng của 8 số tự nhiên liên tiếp.
Vào 5, ra: 5=2+3
Số 5 biểu diễn được bằng tổng của 2 số tự nhiên liên tiếp.
BÀI NÀY KHÁ KHÓ ĐỐI VỚI HS VÀ CẢ SINH VIÊN!
uses crt;
Const max=10000;
Var n,i,dem:Longint; a:array[1..max] of Longint;
8 h 54 m 28/7/2017
27
Thầy Trần Thông Quế
Function Check(m:Longint):boolean;
Var stop,kt:Boolean; kd,bd,t:Longint;
Begin
stop:=False;
kt:=False;
kd:=0;
While Not Stop do
Begin
bd:=kd;dem:=0;
t:=0;
If bd>=(m+1) DIV 2 then stop:=true
Else
Begin
While t
Var tt:Byte;
Begin clrscr;
Repeat
Repeat
Write('Nhap so duong n='); Readln(n);
If n<0 then Writeln(' Nhap lai n>=0');
Until n>=0;
If Check(n) then
Begin
Write(n,'=');
For i:=1 to dem-1 do
Write(a[i],'+');
Writeln(a[dem]);
Write('So ',n,' bieu dien duoc thanh');
Write(' tong cua ',dem,' so tu nhien lien tiep!');
End
Else
Begin
8 h 54 m 28/7/2017
28
Thầy Trần Thông Quế
Write('So ',n,' khong bieu dien duoc thanh');
Write(' tong cua >=2 so tu nhien lien tiep!');
End;
Writeln; Writeln;
Write('More (1/0)? Tiep: go 1; Ngung: go 0:');
Readln(tt);
Until tt=0;
End.
**10. Lập trình phân tích một số tự nhiên bất kỳ thành tổng các số nguyên tố để thu được TÍCH CỦA CÁC
SỐ HẠNG LÀ LỚN NHẤT.
Test1 vào: 8; ra: 3 3 2, tích các số hạng đạt max=18
Test2: Vào 23; ra: 3 3 3 3 3 3 3 2, tích các số hạng này đạt max=4374
Uses crt;
Const m=65;
Var pa_opt:Array[0..m] of Byte;
tic:Array[0..m] of longint;
j,s,p,k:longint; tt:Byte;
Procedure Innit;
Var k:longint;
Begin
For k:=0 to p do
Begin
tic[k]:=0; pa_opt[k]:=0;
End;
tic[0]:=1;
End;
Procedure Process;
Var j,k,s,ticmax:longint;
Begin
For j:=1 to p do
Begin
For k:=0 to p-j do
If (k=0) or (pa_opt[k]>0) then
Begin
s:=k+j;
ticmax:=tic[k]*j;
If ((pa_opt[s]=0) or (pa_opt[s]>0)) and (ticmax>tic[s]) then
Begin
tic[s]:=ticmax; pa_opt[s]:=j;
End;
End;
End;
End;
Begin clrscr;
Repeat
8 h 54 m 28/7/2017
29
Thầy Trần Thông Quế
Write('Nhap so nguyen duong p<100:'); Readln(p);
Innit;
Process;
s:=p;
Write('Phuong an phan tich so ',p,' thanh tong cac so ng_to de co tich max la:');
While s>0 Do
Begin
Write(pa_opt[s]:3); s:=s-pa_opt[s];
End;
Writeln;
Write('Ung voi ptich toi uu tren day, ta duoc tich max=',tic[p]:2);
Writeln; Writeln;
Writeln('* * * * * * * * * * * * * * ');
Write('Continue(1/0)?. Go 1->Tiep; go 0->ngung:');
Readln(tt);
Until tt=0;
End.
**11. (SỐ TAM TAM) Liệt kê tất cả các số Tam Tam và đếm số lượng các số TAM TAM đã liệt kê. (Các
số Tam Tam là những số có 3 chữ số mà số đảo ngược của nó nguyên tố với nó. Chẳng hạn số 974 nguyên
tố cùng 479 là hai số TAM TAM)
Uses crt;
Var dem, i:integer;
Function uscln(a,b:integer):integer;
var r:integer;
Begin
While b>0 do
Begin
r:=a MOd b; a:=b; b:=r;
End;
uscln:=a;
End;
Function daoso(x:integer):integer;
Var y:integer;
Begin
y:=0;
While x>0 do
Begin
y:=10*y+(x MOD 10);
x:=x DIV 10;
End;
daoso:=y;
End;
Procedure Tim;
Begin
dem:=0; writeln; Writeln;
Writeln(#32:18,'Cac so Tam tam thoa man d/kien dau bai:');
8 h 54 m 28/7/2017
30
Thầy Trần Thông Quế
Writeln; Writeln(#32:18,'- - - - - - - - - - - - - - - - - - - -');
For i:=101 to 999 do
if uscln(i,daoso(i))=1 Then
Begin
Inc(dem);
Write(i:4);
End;
Writeln; Writeln;
Write(#32:20,'Bang tren day co tong cong ',dem,' so Tam tam.');
End;
Begin clrscr;
Tim;
Readln;
End.
**12. Liệt kê tất cả các cặp số Lucasa. (Giới hạn: 1
CODE DƯỚI ĐÂY LÀ NGẮN NHẤT!
Uses crt;
Var n, i:longint; s1, s2:string; d: byte; hd:char;
Begin clrscr;
Repeat
d:=0;
Writeln(' Tim cac cap lucasa_number:');
Repeat
Write('Nhap can tren cua gioi han:'); Readln(n);
Until (n>1) and (n<2147483647);
Writeln('Cac cap Lucasa number <=',n,': ');
n:=Trunc(Sqrt(n));
For i:=1 to n do
If (i MOD 10 in [1, 5, 6]) then
Begin
Str(i,s1);
Str(i*i,s2);
If Copy(s2,Length(s2)-Length(s1)+1, Length(s1))=s1 Then
Begin
Inc(d);
Writeln('(',s1,',',s2,')');
End;
End;
Writeln('Tong cong co ',d,' cap LucasaNumbers.');
Write('Go ESc de tro lai chuong trinh!');
Until Readkey = #27;
End.
8 h 54 m 28/7/2017
31
Thầy Trần Thông Quế
**13. Liệt kê tất cả các số SIÊU NGUYÊN TỐ có không hơn 8 chữ số. (Các số SIÊU NGUYÊN TỐ dài L
là những số mà xóa đi k (k
Function NT(n:longint):boolean;
Var
i:longint;
Begin
If (n=0) or (n=1) then
NT:=False
Else
Begin
i:=2;
While (n mod i<>0) and (i<=sqrt(n)) do
i:=i+1;
If i> sqrt(n) then NT:=True
Else NT:=False;
End;
End;
BEGIN CLrscr;
Write('Nhap so chu so n (n<=8):');
Readln(n);
dem:=1;
a[dem]:=0;
For i:=1 to n do
Begin
kb:=0;
For k:=1 to dem do
For cs:=0 to 9 do
If NT(a[k]*10+cs) then
Begin
kb:=kb+1;
b[kb]:=a[k]*10+cs;
End;
dem:=kb;
For k:=1 to dem do
a[k]:=b[k];
End;
For k:=1 to dem do
Write(a[k]:10);
Writeln;
Writeln('Co tat ca ',dem,' so sieu nguyen to co ',n,' chu so.');
Readln;
END.
8 h 54 m 28/7/2017
32
Thầy Trần Thông Quế
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
PHẦN III- MẢNG (ARRAY)
(Bài khó: *; Bài rất khó: **)
II_1) MẢNG 1_CHIỀU. LẬP TRÌNH GIẢI CÁC BÀI TOÁN SAU:
1- Cho trước độ dài n của dãy số. Đọc từ bàn phím vào dãy n số tự nhiên. Tìm và in lên màn hình các số nguyên tố cùng nhau trong dãy.
Program songuyento_trongday;
uses crt;
var a:array[1..100] of integer;
i,n,j,dem:integer;
Begin
clrscr;
write(‘Nhap do dai cua day so: ‘); readln(n);
writeln(‘Nhap cac phan tu cua mang:’);
for i:=1 to n do
Begin
write(‘a[‘,i,’]=’);readln(A[i]);
End;
write(‘Day vua nhap la:’);
For i:=1 to n do write(‘ ‘,a[i]);
writeln;
writeln(‘= = = = = = = = = = = = = = = = =’);
write(‘Cac so nguyen to co trong mang la:’);
For i:=1 to n do
Begin
dem:=0;
for j:=2 to a[i]-1 do
Begin
If a[i] mod j=0 then dem:=dem+1;
End;
If dem=0 then write(‘ ‘,a[i]);
End;
readln;
End.
2- Cho trước độ dài n của dãy số. Đọc từ bàn phím vào dãy n số nguyên. Tìm và in lên màn dãy con dài
nhất gồm toàn số dương.
Chẳng hạn, Vào: 12 -4 6 3 -21 19 5 7 21 -9 2
Ra: 19 5 7 21
Program DayconDuongDainhat;
8 h 54 m 28/7/2017
33
Thầy Trần Thông Quế
Uses crt;
Var a:Array[1..1000] of Integer;
n,i,j,k,kmax,id:byte;
Begin
clrscr;
{ Randomize;}
write(‘Nhap do dai n (2<=n<=1000) cua day so: ‘); readln(n);
writeln(‘Nhap cac phan tu cua mang:’);
for i:=1 to n do
Begin
write(‘a[‘,i,’]=’);
readln(a[i]);
{a[i]:=Random(100);}
End;
clrscr;
writeln(‘Day vua nhap la:’);
For i:=1 to n do write(‘ ‘,a[i]);
writeln;
writeln(‘= = = = = = = = = = = = = = = = = = = = = = = = = =’);
kmax:=0;
For i:=1 to n do
Begin
j:=i+1;
While ((a[i]>0) and (a[j]>0)) Do
Inc(j);
k:=j-i;
if k>kmax then
Begin
kmax:=k;
id:=i;
End;
End;
Writeln(‘Day con gom cac so duong lien tiep dai nhat:’);
For i:=id to id+kmax-1 do Write(a[i]:4);
Readln;
End. 3- Hai bài dưới đây yêu cầu dùng THUẬT TOÁN PHI ĐỆ QUY:
a/ In lên màn hình tam giác ĐỀU Pascal.
b/ In lên màn hình tam giác VUÔNG Pascal.
(Tam giác Pascal là bảng số có hình tam giác chứa các hệ số của khai triển nhị thức Newton)
3.a)
Program Tg_vuong_Pascal;
uses crt;
Var a:array[1..16] of byte; i,j:byte;
Begin clrscr;
Writeln(‘Tam giac vuong Pascal co 16 dong:’);
Writeln;
8 h 54 m 28/7/2017
34
Thầy Trần Thông Quế
If (j=i) or (j=1) then a[j]:=1
Else a[j]:=a[j]+a[j-1];
For i:=1 to 16 do
Begin
For j:=i Downto 1 Do
For j:=1 to i do
Write(a[j]:4);
Writeln;
End;
Readln
End.
3.b)
Program InTamGiacPascal;
uses crt;
var hs:array[0..12] of integer; i,j:integer;
Begin ClrScr;
Write(‘Tam giac Pascal deu co 13 dong:’);
For i:=0 to 12 do
Begin
For j:=i DownTo 0 do
If (j=i) or (j=0) then hs[j]:=1
Else hs[j]:=hs[j]+hs[j-1];
Gotoxy((70-5*i) DIV 2,i+6);
For j:=0 to i do Write(hs[j]:5);
End;
Readln;
End.
*4- (INFORMATIC OLYMPIC MOSCOW 1985). Tìm tất cả các cách biểu diễn một số tự nhiên bằng
tổng của các số tự nhiên khác.
Ví dụ. Vào: 5
Ra : Cách thứ 1: 5=4+1
Cách thứ 2: 5=2+3
Cách thứ 3: 5=3+1+1
Cách thứ 4: 5=2+2+1
Cách thứ 5: 5=2+1+1+1
Cách thứ 6: 5=1+1+1+1+1+1
Số cách biểu diễn = 6
Program ptich_thanh_tong;
Uses crt;
Var n,d,l,i,sum:Integer; dem:longint; tt:char;
s,r:array[1..100] of integer;
Begin clrscr;
Repeat
Write(‘ Nhap n:’); Readln(n);
8 h 54 m 28/7/2017
35
Thầy Trần Thông Quế
Writeln(‘Cac phuong an bieu dien tong:’); Writeln;
dem:=0;
s[1]:=n; r[1]:=1; d:=1;
While s[1]>1 do
Begin
inc(dem); sum:=0;
If s[d]=1 Then
Begin
sum:=sum+r[d];
Dec(d);
end;
sum:=sum+s[d]; r[d]:=r[d]-1; L:=s[d]-1;
If r[d]<>0 then Inc(d);
s[d]:=L; r[d]:=sum DIV L; L:=Sum MOD L;
If L<>0 then
Begin
Inc(d); s[d]:=L; r[d]:=1;
End;
Write(‘ Cach thu ‘,dem,’:’,n,’=’);
For i:=1 to d Do
For L:=1 to r[i] Do Write(s[i],’+’);
Writeln; Writeln;
End;
Writeln(#32:5,’So cach bieu dien=’,dem); Writeln;
Write(‘Continue (y/n) ?, Go y->de tiep; go n hoac N de thoat:’);
Readln(tt); Writeln; Writeln;
Until tt IN [‘n’,’N’];
End. *5- INFORMATIC OLYMPIC MOSCOW 1987 (TẬP NỬA BỘI-HALF MULTI SET). Tập A các số tự nhiên định nghĩa như sau:
a- 1 A
b- K A thì 2K+1 A và 3K+1 A. Tìm và in lên màn n phần tử đầu tiên của tập A
(n<1000). Tập định nghĩa trên đây gọi là HALF MULTI SET.
Chẳng hạn với n=9 thì các phần tử đầu tiên của tập A là:
1 3 4 7 9 10 13 15 19
Program half_multi_Set;
Uses Crt;
Const max=100;
Var i,k2,k3,a2,a3,n: Integer; a:array[1..100] of integer;
Begin Clrscr;
Write(‘Nhap n:’); Readln(n);
k2:=1; k3:=1; a[1]:=1;
Write(1);
For i:=2 to n do
Begin
a2:=2*a[k2]+1; a3:=3*a[k3]+1;
8 h 54 m 28/7/2017
36
Thầy Trần Thông Quế
If a2<=a3 Then
Begin
a[i]:=a2;
k2:=k2+1;
End;
If a3<=a2 then
Begin
a[i]:=a3;
k3:=k3+1;
End;
Write(a[i]:4);
End;
Readln;
End.
**6- Cho trước dãy số nguyên có độ dài n (n đọc từ bàn phím vào). Tìm cách chia dãy ấy thành nhiều dãy
con có tổng bằng nhau.
{ Go ESC de ve Program}
Uses Crt;
const mn=60;
Var a,c:Array[1..mn] of word;
Procedure View(n:word);
Var i: word;
Begin
for i:=1 to n do
Write(a[i]:4);
Writeln;
End;
Function Min(a,b: word):word;
Begin
if a
8 h 54 m 28/7/2017
37
Thầy Trần Thông Quế
Function Check(tt, n, k: word):boolean;
Var t,s,i,m:word;
Begin
check:=False;
t:=tt Div k ;
If t*k <> tt then exit;
m:=1;
c[m]:=0;
s:=0;
For i:=1 to n do
Begin
s:=s+a[i];
If s>t then exit;
If s=t then
Begin
m:=m+1;c[m]:=i;
s:=0;
End;
End;
c[m]:=n;
check:=True;
End;
Procedure Result(tt, n, k:word);
Var s,i:word;
Begin
Writeln;
Write(‘Day a[1..’,n,’] co the chia thanh ‘,k,’ doan’);
Writeln(‘ co tong nhu nhau la=’,tt Div k);
s:=0;
If k=1 Then
Begin
For i:=1 to n do
s:=s+a[i];
Write(‘a[1..’,n,’]=’,s);
Exit;
End;
Writeln;
For i:=1 to k do
Begin
Writeln(‘Doan thu ‘,i,’: a[‘,c[i]+1,’..’,c[i+1],’]’);
If (i Mod 15 =0) then
If readkey=#27 then Exit;
End;
End;
Procedure Partion(n:word);
Var tt, k:word;
Begin
8 h 54 m 28/7/2017
38
Thầy Trần Thông Quế
tt:=0;
For k:=1 to n do tt:=tt+a[k];
For k:=n Downto 1 do
If check (tt,n,k) then
Begin
Result(tt,n,k);
Exit;
End;
End;
Procedure Test;
var n:word;
Begin
randomize;
Repeat
clrscr;
n:=random(mn)+1;
RandomGene(n Div (random(5)+1),n);
View(n);
Partion(n);
Until readkey=#27;
End;
7- IFORMATIC OLYMPIC MOSCOW 1986. Có k làng. Nếu ở làng i đặt trạm cấp cứu, thì xe cấp cứu đi
đến làng j theo tín hiệu gọi cần thời gian:
A[i,i] + A[i,j] ( 1<=i, j<=k, i = j )
Tìm số hiệu làng i để đặt trạm cấp cứu sao cho từ đó đi tới làng xa nhất (về thời gian) sẽ mất thời gian ít
nhất.
Mảng A[1..k,1..k] cho trước, trong đó tất cả phần tử A[i,j]>0 và có thể A[i,j] <>A[j,i].
Uses Crt;
Const kk=20;
Var i,j,k,i1:integer;
s, t: real;
a:Array[1..kk,1..kk] of real;
Begin clrscr;
Write(‘Nhap so lang:’); Readln(k);
For i:=1 to k do
For j:=1 to k do
Begin
Write(‘a[‘,i,’,’,j,’]=’); Readln(a[i,j]);
End;
For i:=1 to k do
Begin
s:=0;
for j:=1 to k do
If(i<>j) And (s
8 h 54 m 28/7/2017
39
Thầy Trần Thông Quế
s:=s+a[i,j];
If(i=1) Or (s
8 h 54 m 28/7/2017
40
Thầy Trần Thông Quế
for j:=1 to len-i do b:=b*2;
s:=S+b;
end;
end;
Write('Doi sang thap phan la: ',S);
Writeln;
Write('More(y/n)?'); Readln(dap);
Until dap In['n', 'N'];
End.
10- Tìm khoảng cách nhỏ nhất giữa các phần tử thuộc dãy số nguyên đã cho.
Program Khoangcachmin;
uses crt;
var a:array[2..1000] of integer;
i,n,dmin:integer; hoi:byte;
Begin clrscr;
Repeat
Randomize;
write('Nhap do dai n (n<=1000) cua day so: '); readln(n);
writeln('Nhap cac phan tu cua mang:');
For i:=2 to n do
a[i]:=Random(100);
clrscr;
writeln('Day vua nhap la:');
For i:=2 to n do write(' ',a[i]);
writeln;
writeln('= = = = = = = = = = = = = = = = = = = = = = = = = =');
dmin:=abs(a[3]-a[2]);
For i:=4 to n do
If (dmin>abs(a[i]-a[i-1])) then dmin:=abs(a[i]-a[i-1]);
Writeln('Khoang cach nho nhat giua cac phan tu trong day la:',dmin);
Write('Another Test (1/0)?. Continue->Press 1; Stop->Press 0:');
Writeln;
Readln(hoi);
Until hoi=0;
End.
III_2) MẢNG HAI CHIỀU (TÊN KHÁC: MA TRẬN)
(CHỦ ĐỀ NÀY KHÁ NHIỀU BÀI TẬP THÚ VỊ HOẶC ÍT QUEN THUỘC VỚI CÁC BẠN)
Khuyến cáo: Các bạn học sinh hãy chú ý điều sau:
CÁI KHÓ CỐT LÕI CỦA CÁC BÀI TOÁN TỪ 7 ĐẾN 11 đối với các bạn học sinh hay sinh viên
KHÔNG Ở THUẬT TOÁN TÌM KIẾM HAY TÍNH TOÁN (những thuật toán này quá dễ với các bạn) MÀ
Ở THUẬT TOÁN DUYỆT THEO CÁC INDEX (CÁC CHỈ SỐ ) CỦA MA TRẬN. Bởi vậy khuyến cáo
các bạn nên XEM+NGẪM+NHỚ KỸ CÁCH DUYỆT INDEX ở các bài toán đó.
8 h 54 m 28/7/2017
41
Thầy Trần Thông Quế
*11- Cho trước ma trận vuông cấp n. Lập trình làm
c- In lên màn ma trận tam giác dưới & ma trận tam giác trên.
d- Xem các phần tử thuộc đường chéo chính.
e- Xem các phần tử ở PHÍA TRÊN đường chéo chính.
f- TỔNG các phần tử ở PHÍA TRÊN đường chéo chính.
Program Bt_7;
Uses crt;
Var i,j,m,n,d,s,s1,s2,t:integer;
a:array[1..50,1..50] of integer;
Begin clrscr;
Randomize;
Write(‘Nhap so hang cot n cua ma tran vuong:’); Readln(n);
for i:=1 to n do
Begin
for j:=1 to n do a[i,j]:=Random(10);
End;
Writeln(‘Ma tran vua nhap:’);
For i:=1 to n do
Begin
For j:=1 to n do
Write(a[i,j]:3);
Writeln;
End;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘* * * * * * * * * * * * * * * * *’);
Writeln(‘Ma tran tam giac duoi:’);
For i:=1 to n do
Begin
For j:=1 to i do
write(a[i,j]:3);
writeln;
End;
Writeln(‘* * * * * * * * * * * * * * * * *’);
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘Ma tran tam giac tren:’);
For i:=1 to n do
Begin
For j:=i to n do
8 h 54 m 28/7/2017
42
Thầy Trần Thông Quế
Begin
Gotoxy(4*(j+1),3+i);
Write(a[i,j],’ ‘);
end;
Writeln;
end;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘ Cac phan tu thuoc duong cheo chinh:’);
for i:=1 to n do
Write(a[i,i]:4);
writeln;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘* * * * * * * * * * * * * * * * *’);
Writeln(‘ Cac phan tu nam PHIA tren duong cheo chinh:’);
for i:=1 to n do
Begin
for j:=i+1 to n do
Begin
Gotoxy(4*(j+1),3+i);
write(a[i,j],’ ‘);
writeln;
End;
End;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘* * * * * * * * * * * * * * * * *’);
t:=0;
for i:=1 to n do
Begin
For j:=i+1 to n do
t:=t+a[i,j];
End;
Write(‘Tong cac phan tu o PHIA tren duong cheo chinh:’,t);
Readln
End.
**12- Cho trước ma trận vuông cấp n. Lập trình làm các việc sau:
a/ In lên màn ma trận tam giác dưới đường chéo chính.
b/ Xem các phần tử thuộc đường chéo chính.
c/ Xem các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA TRÊN.
d/ Tính tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA TRÊN.
e/ Xem các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI.
f/ Tính tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI.
8 h 54 m 28/7/2017
43
Thầy Trần Thông Quế
TEST. Vào:
49 20 25 12
5 37 19 19
5 43 25 15
3 13 48 8
Ra:
a/ Ma trận tam giác dưới:
49
5 37
5 43 25
3 13 48 8
b/ Các phần tử thuộc đường chéo chính: 49 37 25 8
c/ Các phần tử thuộc đường // đường chéo chính sát ngay phía trên: 20 19 15
d/ Tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA TRÊN:
54
e/ Các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI:
5 43 48
f/ Tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI:
96
Program Bt_8;
Uses crt;
Var i,j,n,d,s,s1,s2,ln:integer;
a:array[1..20,1..20] of integer;
Begin clrscr;
Randomize;
s:=0;
Write('Nhap kich co ma tran vuong n='); Readln(n);
for i:=1 to n do
Begin
for j:=1 to n do a[i,j]:=Random(50);
End;
Writeln('Ma tra vua nhap:');
For i:=1 to n do
Begin
For j:=1 to n do
Write(a[i,j]:4);
Writeln;
End;
{ * * * * * * * * * * * * * * * *}
Writeln('Ma tran tam giac duoi:');
For i:=1 to n do
Begin
For j:=1 to i do
write(a[i,j]:4);
8 h 54 m 28/7/2017
44
Thầy Trần Thông Quế
writeln;
End;
Writeln('* * * * * * * * * * * * * * * * *');
Writeln(' Cac phan tu thuoc duong cheo chinh:');
for i:=1 to n do Write(a[i,i]:4); writeln;
Writeln('* * * * * * * * * * * * * * * * *');
s1:=0;
Writeln(' Cac phan tu thuoc duong // sat ngay PHIA TREN duong cheo chinh:');
For i:=1 to n-1 do
Write(#32:2,a[i,i+1]); Writeln;
Write('Tong cac phan tu thuoc duong // sat ngay PHIA TREN duong cheo chinh:');
For i:=1 to n-1 do
s1:=s1+a[i,i+1];
Write(s1:4); Writeln;
Writeln('* * * * * * * * * * * * * * * * *');
s2:=0;
Writeln(' Cac phan tu nam tren duong // sat ngay PHIA DUOI duong cheo chinh:');
For i:=2 to n do
Write(#32:2,a[i,i-1]); Writeln;
Write('Tong cac phan tu nam tren duong // sat ngay PHIA DUOI duong cheo chinh:');
For i:=2 to n do
s2:=s2+a[i,i-1];
Write(s2:4); Writeln;
Readln;
End.
**13- Cho ma trận vuông cấp n (n đọc từ bàn phím vào). Tìm: a/ Số lẻ lớn nhất DƯỚI ĐƯỜNG CHÉO PHỤ. b/ Tìm ít nhất một số trong ma trận lớn hơn số lẻ lớn nhất ấy+chỉ ra tọa độ của nó.
c/ Thống kê số lượng các số lớn hơn số lẻ lớn nhất đã tìm thấy trên đây.
TEST. Vào:
10 12 47 7
5 45 11 39
19 33 29 20
16 19 20 23
Ra: + Số LẺ Max dưới đường chéo phụ=39
+ Tồn tại phần tử lớn hơn số max ở hàng 1, cột 3
+ Tồn tại phần tử lớn hơn số max ở hàng 2, cột 2
+ Số phần tử lớn hơn max là: 2
Program Bt_9;
Uses Crt;
Type mt=array[1..50,1..50] of integer;
Var a:mt; n,i,j,max:byte;
8 h 54 m 28/7/2017
45
Thầy Trần Thông Quế
Procedure Input(Var a:mt; n:byte);
Var i,j:byte;
Begin
randomize;
For i:=1 to n do
For j:=1 to n do a[i,j]:=random(50);
{ Begin
Write('a[',i,',',j,']=');
readln(a[i,j]);
End; }
End;
Procedure View(a:mt; n:byte);
Var i,j:byte;
Begin
For i:=1 to n do
Begin
For j:=1 to n do
Write(a[i,j]:4);
Writeln;
End;
End;
Function Timmax(a:mt; n:byte):byte;
Var i,j,m:Byte;
Begin
max:=0;
For i:=1 to n do
For j:=1 to n do
If ((i+j)>(n+1)) And ((a[i,j] Mod 2)=1) then max:=a[i,j];
If max=0 then
Writeln('Khong co so le nao lon nhat duoi duong cheo phu.')
Else
Begin
For i:=1 to n do
For j:=1 to n do
If ((i+j)>(n+1)) And ((a[i,j] Mod 2)=1) And (max
8 h 54 m 28/7/2017
46
Thầy Trần Thông Quế
if ((i+j)<=n) And (a[i,j]>max) then
Begin
Inc(dem);
Writeln('Ton tai phan tu lon hon max o hang ',i,' cot ',j);
End;
If dem=0 Then write('Khong co phan tu nao > max.')
Else Write('So phan tu lon hon max la:',dem);
End;
Begin clrscr;
Write('Nhap kich co ma tran VUONG:'); Readln(n);
Input(a,n);
View(a,n);
max:=Timmax(a,n);
Maxindex(a,n,max);
Readln;
End.
*14-Cho ma trận vuông cấp n (n đọc từ bàn phím vào). Tìm:
+ Phần tử nhỏ nhất dưới đường chéo chính.
+ Nhập vào tọa độ của phần tử nằm trên đường song song với đường chéo phụ, rồi tính
tổng các phần tử trên đường // này và chứa điểm đó.
tử ấy và // với chéo phụ là 17 (=5+12)
TEST. Dùng matrix trên đây, ta có kết quả sau:
+ Min dưới đường chéo chính=16
+ Đọc vào tọa độ hàng 1, cột 2 ta được tổng các phần tử trên đường chứa phần
Program Bt_10;
Uses Crt;
Type mt=array[1..50,1..50] of byte;
Var a:mt; n,i,j,k,l,row,col,ans:byte;
min,s:integer;
Procedure Input(Var matrix:mt; ten:char; soh,soc:byte);
Var i,j:byte;
Begin
Randomize;
For i:=1 to soh do
For j:=1 to soc do {matrix[i,j]:=Random(10);}
Begin
Write(ten,'[',i,',',j,']='); Readln(a[i,j]);
End;
End;
Procedure View(matrix:mt; soh,soc:byte);
Var i,j:byte;
8 h 54 m 28/7/2017
47
Thầy Trần Thông Quế
Begin
For i:=1 to soh do
Begin
For j:=1 to soc do
Write(matrix[i,j]:3);
Writeln;
End;
End;
Begin Clrscr;
Repeat
Write('Nhap kich co n cua ma tran vuong:'); Readln(n);
Input(a,'a',n,n);
Writeln('Matrix vua nhap:');
Writeln;
View(a,n,n);
Writeln;
min:=a[2,1];
row:=2; col:=1;
For i:=1 to n do
For j:=1 to n do
If(i>j) And (min>a[i,j]) Then
Begin
Min:=a[i,j];
row:=i; col:=j;
End;
Writeln('Phan tu min o duoi duong cheo chinh:',min);
Write('Nhap chi so hang, cot can xu ly:'); Readln(k,l);
s:=0;
For i:=1 to n do
For j:=1 to n do
If (i+j=k+l) then S:=S+a[i,j];
Writeln('Tong cac phan tu tren duong // voi duong cheo phu va ');
Write('chua phan tu tren hang ',k,' cot ',l,' la:',S);
Writeln;
Write('Another Test (1/0)? More --> Press 1, Stop --> Press 0:');
Readln(Ans);
Until ans=0;
End.
*15- Lập trình tạo ma trận xoắn ốc. Lưu kết quả vào tệp Xoanoc.txt.
Program Mt_xoan;
Uses Crt;
var a:array[1..150,1..150]of word;
i,j,n,k:word;
f:text;
Procedure View;
Begin
8 h 54 m 28/7/2017
48
Thầy Trần Thông Quế
For j:=1 to n do
Begin
For i:=1 to n do
Write(f,a[i,j]:6);
Writeln(f);
End;
End;
Procedure Datso;
Begin
inc(k);
a[i,j]:=k;
End;
Begin clrscr;
Write('Nhap kich co ma tran n='); Readln(n);
Assign(f,'Xoanoc.txt'); Rewrite(f);
j:=1;
while k
1 2 3 8 7 9
2 3 1 5 4 6
3 1 2 2 3 1 }
*16- Cho trước ma trận vuông cấp n. Lập trình kiểm tra xem nó có phải là ma trận La Tinh không. Ma trận
mà tất cả các cột, hàng đều là hoán vị của n số gọi là ma trận LaTinh.
{ Test1: Test2:
Program Check_Mtran_LaTinh;
Uses Crt;
type a=Array[1..30,1..30] of Integer;
Var mt:a; i,j,n,d:Integer;
Function ktrahang(i:integer):Boolean;
Var j,k:integer; check:boolean;
Begin
ktrahang:=false;
For k:=1 to n do
8 h 54 m 28/7/2017
49
Thầy Trần Thông Quế
Begin
check:=false;
For j:=1 to n do
if k=mt[i,j] then check:=true;
If Not check then exit;
End;
ktrahang:=true;
End;
Function ktracot(j:integer):boolean;
var i,k:integer; check:boolean;
Begin
ktracot:=false;
For k:=1 to n do
Begin
check:=false;
For i:=1 to n do
If k=mt[i,j] then check:=true;
If Not check then Exit;
End;
ktracot:=true;
End;
Begin Clrscr;
Write('Nhap kich co ma tran vuong n='); Readln(n);
For i:=1 to n Do
For j:=1 to n Do
Begin
write('mt[',i,',',j,']=');readln(mt[i,j]);
End;
writeln('Ma tran vua nhap:');
For i:=1 to n do
Begin
For j:= 1 to n do
write(mt[i,j]:3);
writeln;
End;
writeln;
writeln('= = = = = = = = = = = = = = = = =');
d:=0;
For i:=1 to n Do
If (Not ktrahang(i)) Or (Not ktracot(i)) then
inc(d);
If d=0 then Write('La ma tran Latinh.')
Else Write('khong la ma tran Latinh.');
Readln;
End.
8 h 54 m 28/7/2017
50
Thầy Trần Thông Quế
17- Cho trước ma trận vuông cấp n. . Lập trình kiểm tra xem nó có phải là ma trận đối xứng không.
Một ma trận đối xứng là ma trận vuông A bằng chính ma trận chuyển vị của nó.
Mỗi phần tử của một ma trận đối xứng thì đối xứng qua đường chéo. Do vậy, nếu các phần tử được viết
dưới dạng A=a[i,j] thì với mọi i, j ta có: a[i, j]=a[j,i].
{Test1: 1 2 3 Test2: 9 5 7
2 4 -5 3 1 6
3 -5 6 8 4 2 }
Program Check_Symetr_ Matrix;
Uses Crt;
Type a=Array[1..30,1..30] of integer;
Var mt:a;i,j,n,d:integer; tt:byte;
Begin clrscr;
Repeat
Write(' Nhap kich thuoc ma tran vuong n:'); Readln(n);
for i:=1 to n do
for j:= 1 to n do
begin
write(' Nhap phan tu mt[',i,',',j,']=');
Readln(mt[i,j]);
end;
Writeln;
writeln('Ma tran vua nhap:');
Writeln;
for i:=1 to n do
begin
for j:= 1 to n do
write(mt[i,j]:3);
writeln;
end;
writeln;
d:=0;
for i:=1 to n do
for j:= 1 to n do
If mt[i,j]<>mt[j,i] Then Inc(d);
If d>0 Then Write('Ma tra vua nhap Khong Doi Xung.')
Else Write('Ma tran vua nhap Doi Xung.');
Writeln;
Write('More (1/0)?. More --> Press 1, Stop --> Press 0:');
Readln(tt);
Until tt=0;
End.
**18- Tạo ma phương (gọi khác: ma trận kỳ diệu-magic matrix-) bậc lẻ. Đó là ma trận mà tổng các số trên
các hàng bằng nhau = tổng các số trên các cột bằng nhau = tổng các sổ trên hai đường chéo bằng nhau . Ở
mức tổng quát, toán học mới chỉ chứng minh được: chỉ tạo được ma phương bậc LẺ.
8 h 54 m 28/7/2017
51
Thầy Trần Thông Quế
{Nhap xong data nho go ENTER de xem ket qua chay Program}
Program Magic_Matrix;
Uses crt, addcrt;
Const lim=11;
Type mt=array[1..lim,1..lim] of integer;
mtktr=array[1..lim,1..lim] of boolean;
Var matr:mt; mtcheck:mtktr; ok:boolean;
n,i,j,k:integer;
ch:char;
Procedure chinhtoado(Var i,j:integer; n:integer);
Begin
If i<1 then i:=n;
If i>n then i:=1;
If j<1 then j:=n;
If j>n then j:=1;
End;
Procedure datso(var matr:mt; Var mtcheck:mtktr; Var k:integer; i,j:integer);
Begin
matr[i,j]:=k;
mtcheck[i,j]:=false;
Inc(k);
End;
Procedure DrawTab(matr:mt; n:integer);
Var i,j:integer;
Begin
textbackground(lightred);
clrscr;
textcolor(lightcyan);
For j:=1 to 25 do
Begin
If(j<(13-n+1)) Or (j>(13+n+1)) then
For i:=1 to 80 do
Begin
gotoxy(i,j); write('$');
End
Else
For i:=1 to 80 do
If (i<(40-(5*n) Div 2-1)) or (i>(40+(5*n) Div 2+2)) then
Begin gotoxy(i,j); write('$'); End;
End;
FONT(40-(5*n) Div 2-2,13-n-1,40+(5*n) Div 2+3,13+n+1,14,1);
textcolor(white);
for i:=13-n+1 to 13+n-1 do
if (i Mod 2)=(13-n) Mod 2 then
Begin
8 h 54 m 28/7/2017
52
Thầy Trần Thông Quế
for j:=40-(5*n) Div 2 to 40+(5*n) div 2+1 do
if j Mod 5=(40-(5*n) Div 2) Mod 5 then
Begin
gotoxy(j,i); write('!');
End
Else
Begin
gotoxy(j,i); write('=');
End;
End
Else Begin
for j:=40-(5*n) Div 2 to 40+(5*n) Div 2+1 do
if j Mod 5=(40-(5*n) Div 2) Mod 5 then
Begin
gotoxy(j,i); write('!');
End;
End;
for j:=40-(5*n) Div 2 to 40+(5*n) Div 2+1 do
if j Mod 5=(40-(5*n) Div 2) Mod 5 then
Begin
gotoxy(j,13-n); write('=');
gotoxy(j,13+n); write('=');
End
else
Begin
gotoxy(j,13-n); write('=');
gotoxy(j,13+n); write('=');
End;
textcolor(yellow);
for i:=1 to n do
for j:=1 to n do
Begin
gotoxy((40-(5*n) Div 2+1)+5*(j-1),(13-n+1)+2*(i-1));
write(matr[i,j]:3);
End;
End;
Begin {Main}
clrscr;
ch:='t';
While ch In ['t','T'] Do
Begin
Khungkep(20,4,61,16,14);
gotoxy(31,5); write(' HINH VUONG KY AO.');
WINDOW(21,6,60,15);
writeln(#32:7,'-----------------------------');
writeln(#32:5,'Day la bai toan tao hinh vuong va');
writeln(#32:5,' cac con so dat trong no thoa:');
writeln(#32:5,' Tong cac so tren cac hang,');
8 h 54 m 28/7/2017
53
5 2 9
8 4 5 4 9 2 }
Thầy Trần Thông Quế
writeln(#32:5,' tren cac cot va tren duong cheo');
writeln(#32:5,' deu bang nhau. Den nay bai toan');
writeln(#32:5,' chi giai duoc voi cac hinh vuong ' );
writeln(#32:5,' co do dai canh la so le');
writeln;
write('Cho do dai canh:(n=3, 5, 7, 9, 11 ...):');
read(n);
setwin;
If (n Mod 2=0) or (n<3) or (n>lim) then n:=5;
for i:=1 to n do
for j:=1 to n do
mtcheck[i,j]:=true;
i:=1;
j:=n Div 2+1;
k:=1;
Repeat
datso(matr,mtcheck,k,i,j);
i:=i-1;
j:=j+1;
chinhtoado(i,j,n);
If mtcheck[i,j]=true then ok:=true
Else Begin
j:=j-1;
i:=i+1;
chinhtoado(i,j,n);
Inc(i);
if mtcheck[i,j]=true then ok:=true
else ok:=false;
End;
Until ok=false;
Drawtab(matr,n);
gotoxy(18, 25);
write('Go phom bat ky de thoat hay t, T de tiep tuc!');
Repeat Until Keypressed;
ch:=Readkey;
clrscr;
end;
End.
**19- Kiểm tra xem một ma trận vuông cấp n ( n LẺ) có là ma phương không?
{ Test 1: 3 7 1 Test 2: 8 1 6
3 5 7
Program Maphuong_Check;
Uses Crt;
Type mt=Array[1..30,1..30] of Integer;
var a:mt; i,j,n,s,s1,s2:integer;
8 h 54 m 28/7/2017
54
Thầy Trần Thông Quế
Function shang(i:integer):integer;
var j,s:integer;
Begin
S:=0;
For j:=1 to n do
s:=s+a[i,j];
shang:=s;
End;
Function Scot(j:integer):integer;
Var i,s:Integer;
Begin
s:=0;
For i:=1 to n do
s:=s+a[i,j];
scot:=s;
End;
Begin clrscr;
write(' Nhap kich thuoc n cua ma tran vuong:'); Readln(n);
for i:=1 to n do
for j:= 1 to n do
begin
write(' Nhap phan tu a[',i,',',j,']=');
Readln(a[i,j]);
end;
clrscr;
writeln('Ma tran vua nhap:');
for i:=1 to n do
begin
for j:= 1 to n do
write(a[i,j]:3);
writeln;
end;
s:=shang(1);
s1:=0; s2:=0;
For i:=1 to n Do
Begin
If (shang(i)<>s) Or (scot(i)<>s) Then
Begin
Write('Ma tra vua nhap khong phai ma phuong');
Readln;
Exit;
End;
s1:=s1+a[i,i];
s2:=s2+a[i,n+1-i];
8 h 54 m 28/7/2017
55
Thầy Trần Thông Quế
End;
If (s<>s1) Or (s<>s2) Then
Write('Ma tra vua nhap khong phai ma phuong')
Else Write('Ma tran vua nhap la ma phuong.');
Readln
End.
**20- Cho dãy các số nguyên có độ dài N. Tìm cách chia dãy đã cho thành các đoạn có tổng các phần tử
như nhau.
{Go ESC Thoat}
Uses Crt;
const mn=60;
Var a,c:Array[1..mn] of word;
Procedure View(n:word);
Var i: word;
Begin
for i:=1 to n do
Write(a[i]:4);
Writeln;
End;
Function Min(a,b: word):word;
Begin
if a tt then exit;
m:=1;
c[m]:=0;
8 h 54 m 28/7/2017
56
Thầy Trần Thông Quế
s:=0;
For i:=1 to n do
Begin
s:=s+a[i];
If s>t then exit;
If s=t then
Begin
m:=m+1;c[m]:=i;
s:=0;
End;
End;
c[m]:=n;
check:=True;
End;
Procedure Result(tt, n, k:word);
Var s,i:word;
Begin
Writeln;
Write('Day a[1..',n,'] co the chia thanh ',k,' doan');
Writeln(' co tong nhu nhau la=',tt Div k);
s:=0;
If k=1 Then
Begin
For i:=1 to n do
s:=s+a[i];
Write('a[1..',n,']=',s);
Exit;
End;
Writeln;
For i:=1 to k do
Begin
Writeln('Doan thu ',i,': a[',c[i]+1,'..',c[i+1],']');
If (i Mod 15 =0) then
If Readkey=#27 then Exit;
End;
End;
Procedure Partion(n:word);
Var tt, k:word;
Begin
tt:=0;
For k:=1 to n do tt:=tt+a[k];
For k:=n Downto 1 do
If check (tt,n,k) then
Begin
Result(tt,n,k);
Exit;
End;
8 h 54 m 28/7/2017
57
Thầy Trần Thông Quế
End;
Procedure Test;
var n:word;
Begin
randomize;
Repeat
clrscr;
n:=random(mn)+1;
RandomGene(n Div (random(5)+1),n);
View(n);
Partion(n);
Until readkey=#27;
End;
Begin Clrscr;
Test;
End.
21-(CHỌN SỐ Ở MỖI HÀNG MỖI CỘT) Cho trước ma trận vuông cấp n. Hãy chọn mỗi số ở mỗi hàng
(khác nhau), mỗi cột (khac nhau) sao cho tổng của chúng lớn nhất.
{ Test1: Test2: Test3:
3 4 4
7 9 6 4 3 4 5 241 164 180 20
3 5 8 6 7 8 9 162 81 102 96
8 6 9 1 9 7 4 169 197 80 153
1 3 5 7 11 26 214 223 }
Uses Crt;
Var a:Array[1..20, 1..20] of word;
b:Array[1..20] of Boolean;
x,ng:Array[1..20] of Byte;
r,n,i,dem:Byte;
max,sum:integer;
fi,fo:Text;
Procedure Doc;
Var i,j:word;
Begin
Assign(fi,'mang.in'); Reset(fi);
Readln(fi,n);
For i:=1 to n do
For j:=1 to n do
read(fi,a[i,j]);
Close(fi);
End;
Procedure Ghi;
Var i,j:word;
8 h 54 m 28/7/2017
58
Thầy Trần Thông Quế
Begin
Assign(fo,'mang.ou'); Rewrite(fo);
For i:=1 to n do
Begin
For j:=1 to n do
Write(fo,a[i,j]:4);
Writeln(fo);
End;
End;
Procedure Xuly;
Var i: Word;
Begin
If sum>max Then
Begin
max:=sum;
ng:=x;
End;
End;
Procedure Xuat;
var i:Word;
Begin
Writeln(fo,' Tong max cua cac phan tu da chon=',max);
Writeln(fo,'Va cac phan tu ay la:');
For i:=1 to n do
Write(fo,a[i,ng[i]]:4,'(',i,',',ng[i],')');
End;
Procedure Chon(i:word);
Var j:Word;
Begin
For j:=1 to n do
If b[j] Then
Begin
x[i]:=j;
sum:=sum+a[i,j];
b[j]:=false;
if i=n Then xuly else chon(i+1);
b[j]:=true;
sum:=sum-a[i,j];
End;
End;
Begin clrscr;
Doc;
Ghi;
max:=0; sum:=0;
For i:=1 to n Do
8 h 54 m 28/7/2017
59
Thầy Trần Thông Quế
b[i]:=true;
chon(1);
Xuat;
Close(fo);
Writeln('Done! Go ENTER -> ve Program; Go F3 -> Go MANG.OU: Xem kqua.');
Readln;
End.
PHẦN IV. XÂU KÝ TỰ (STRING)
(Trừ bài 1, không có bài nào dễ với học sinh, sinh viên)
Lập trình giải các bài toán sau:
1/(CHUẨN HÓA XÂU). Cho trước một xâu (dài < 256 ký tự) chứa các từ (Word). Giữa các từ của xâu có
nhiều hơn một dấu cách (ký tự trống). Hãy khử các dấu cách giữa các từ, chỉ GIỮ LẠI MỘT DẤU CÁCH
giữa chúng. Xâu như vậy gọi là xâu chuẩn.
(Từ là một xâu con không chứa dấu cách thuộc xâu đã cho mà nó được kết thúc bởi dấu cách SPACE, hoặc
dấu TAB.)
CODE.
ses crt;
var i:Byte; s:string;
Begin Clrscr;
Write('Nhap vao xau s co vai dau trong o giua cac tu:'); Readln(s);
While s=#32 do Delete(s,1,1);
While s[length(s)]=#32 do
Delete(s,length(s),1);
i:=1;
Repeat
If (s[i]=#32) and (s[i+1]=#32) then Delete(s,i,1)
Else Inc(i);
Until i>Length(s); {da xet het cac pt cua xau}
Write('Xau da khu trong :',s);
Readln;
End.
2/(VIẾT HOA KÝ TỰ ĐẦU CỦA TỪ) Cho trước một xâu gồm các từ mà chữ cái đầu của mỗi từ là chữ
thường. Hãy sửa các ký tự đầu của mỗi từ thành chữ HOA.
Vào: ton nu nguyet anh Ra: Ton Nu Nguyet Anh
CODE.
Uses Crt;
Const chuthg =['a'..'z']; {Khai bao hang xau}
Var xau:string; i,d:Byte;
Begin Clrscr;
Write(' Nhap xau:'); Readln(xau);
d:=length(xau);
8 h 54 m 28/7/2017
60
Thầy Trần Thông Quế
If xau[1] In chuthg Then xau[1]:=Upcase(xau[1]);
For i:=2 to d do
If (xau[i-1]=#32) and (xau[i] In chuthg) Then
xau[i]:=Upcase(xau[i]);
Write('Chu cai dau moi tu sua thanh chu hoa:',xau);
Readln;
End.
3/ (ĐỘ DÀI MAX CỦA XÂU CON CHUNG). Cho trước hai xâu s1 và s2. Tính độ dài max của xâu con
chung.
Vào: s1=xabcxxabcdxd; s2=aybcyabcdydy
Ra do dai max doan chung 2 xau=4
Uses Crt;
Var s1, s2:string;
Function lonnhat(a,b:integer):integer;
Begin
If (a>b) then lonnhat:=a
Else lonnhat:=b;
End;
Function DodaiMaxXauchung(Var x,y:string):integer;
Var m,n,i,j,v,t,kmax: integer;
a:array[1..255] of integer;
Begin
m:=length(x); n:=length(y);
kmax:=0;
Fillchar(a,sizeof(a),0);
For i:=1 to m do
Begin
v:=0;
For j:=1 to n do
Begin
t:=a[j];
If x[i]=y[j] then a[j]:=v+1
Else a[j]:=0;
kmax:=lonnhat(kmax,a[j]);
v:=t;
End;
End;
DodaiMaxXauchung:=kmax;
End;
Begin clrscr;
Write('xau s1='); Readln(s1);
Write('Xau s2='); Readln(s2);
Write('Do dai max cua doan chung thuoc 2 xau=',DodaiMaxXauchung(s1,s2));
Readln;
End.
8 h 54 m 28/7/2017
61
Xm: gồm m chữ cái X;
Thầy Trần Thông Quế
*4/ (ĐOẠN LẶP (ĐẦU BÀI LẤY TRONG “NHỮNG VIÊN NGỌC LẬP TRÌNH” CỦA JON BENTLEY-
BẢN DỊCH TIẾNG VIỆT: GIA VIỆT & MINH TRUNG. NXB THỐNG KÊ,11/2002)) Cho xâu s có độ dài
n. Xác định 2 số i, j thỏa mãn điều kiện 1 i < j n và k là số lớn nhất sao cho s[i] = s[j], s[i+1] = s[j+1], . .
., s[i+k-1] = s[j+k-1]. Hai đoạn bằng nhau trong s gồm k ký tự là s[i..i+k-1] và s[j..j+k-1] với i
62
Thầy Trần Thông Quế
Ví dụ. Vào: (AB3(C2D)2(C5D)0)2A3
Ra: ABBBCCDCCDABBBCCDCCDAAA
BẢNG DÒ VẾT CỦA PROGRAM:
n c m t GIẢI THÍCH
1 A 1 Viết A 1 lần
2 B 2 Viết B 2 lần
3 C 2 Viết C 2 lần
4 D 1 Viết D 1 lần
5 # 2 3 Không có ký tự để viết. Lặp 2 lần từ bước 3 đến bước 5
6 # 2 1 Không có ký tự để viết. Lặp 2 lần từ bước 1 đến bước 6
7 A 3 Viết A 3 lần.
CODE.
Uses Crt;
Const max=500;
chuso=['0'..'9']; chucai=['A'..'Z'];
Type mi1=Array[0..max] of integer;
mc1=Array[0..max] of char;
Var M,T,R,st: mi1; {M:so lan lap; T: tu;R: luu; st:Stack}
c:mc1; p:integer; {dinh stack} s:string;
v:integer; {index cua stack}
n: integer;
Procedure Incre_Index;
Begin
While (s[v]=#32) do
Inc(v);
End;
Function Napso:integer;
var so:integer;
Begin
so:=0;
Incre_Index;
If Not (s[v] in Chuso) then
Begin
Napso:=1;
Exit;
End;
While (s[v] In Chuso) do
Begin
so:=so*10+(Ord(s[v])-Ord('0'));
Inc(v);
End;
Napso:=so;
End;
8 h 54 m 28/7/2017
63
Thầy Trần Thông Quế
Procedure GanCnvaMn(ch:char);
Var so:integer;
Begin
Inc(v); so:=Napso;
If so=0 then Exit;
Inc(n);
C[n]:=ch; M[n]:=so;
End;
Procedure Chenngoac;
Begin
Inc(v);
Inc(p);
st[p]:=n+1;
End;
Procedure RutphantukhoiStack;
var tu, so: integer;
Begin
Inc(v); tu:=st[p];
Dec(p);
so:=Napso;
If (so=0) Then n:=tu-1;
If (so<2) Then Exit;
Inc(n);
C[n]:='#'; M[n]:=so; T[n]:=tu; R[n]:=so;
End;
Procedure Xulytiep;
Var i,j: integer;
Begin
Writeln('CAC BUOC KHAI TRIEN VA XAU KHAI TRIEN CUA XAU THU GON:');
For i:=1 to n do
Begin
Write(#13#10,i,'. ',C[i],#32,M[i],#32);
If C[i]='#' Then Write(T[i]);
Writeln;
End;
i:=1;
While (i<=n) Do
Begin
If (C[i]='#') Then
Begin
Dec(R[i]);
If (R[i]=0) Then
Begin
R[i]:=M[i];
Inc(i);
End
8 h 54 m 28/7/2017
64
Thầy Trần Thông Quế
Else i:=T[i];
End
Else
Begin
For j:=1 to M[i] Do
Write(C[i]);
Inc(i);
End;
End;
End;
Procedure Khaitrien(Var s:string);
Var i:integer;
Begin
s:=s+'#'; v:=1; p:=0;
While (s[v]<>'#') Do
Begin
If(s[v] In Chucai) Then GanCnvaMn(s[v])
Else If (s[v]='(') Then ChenNgoac
Else If (s[v]=')') Then RutphantukhoiStack
Else Inc(v);
End;
Writeln(s,':');
Xulytiep;
End;
Begin clrscr;
s:='(AB3(C2D)2(C5D)0)2A3';
Khaitrien(s);
Readln;
End.
*6/)(TỪ CHUẨN) Một từ loại M là dãy các chữ số có giá trị từ 1 đến M. Độ dài của từ là số lượng các chữ
số trong dãy. Từ loại M được gọi là từ chuẩn nếu nó không chứa hai đoạn con kề liền trong nó giống nhau.
Cho trước số nguyên N, tìm và ghi lên text file TUCHUAN.OU tất cả các từ chuẩn loại 3 dài N
(1<=N<=40000)
CODE.
Uses Crt;
Const mn=40;mn1=40000;
fo='tuchuan.ou';
Var v:Array[0..mn1] of byte;
n:integer;
f:text;
Function Bang(i,k:integer):Boolean;
Var j:integer;
Begin
Bang:=false;
For j:=0 to k-1 do
8 h 54 m 28/7/2017
65
Thầy Trần Thông Quế
If (v[i-j]<>v[i-k-j]) Then Exit;
Bang:=true;
End;
Function Chuan(i:integer):Boolean;
Var k:integer;
Begin
chuan:=false;
For k:=1 to (i DIV 2) do
If Bang(i,k) then Exit;
Chuan:=true;
End;
Function Tim(i:integer):Boolean;
Begin
Tim:=true;
While (v[i]<3) do
Begin
Inc(v[i]);
If chuan(i) then Exit;
End;
Tim:=False;
End;
Procedure Ketqua(d:integer);
Var i:integer;
Begin
If d=0 then Write(f,'Vo nghiem')
Else
Begin
Write(f,'Ngiem thu ',d,':');
For i:=1 to n Do
Write(f,v[i]);
Writeln(f);
End;
End;
Procedure Timtu(len:integer);
Var i:integer;
d:longint;
Begin
If(len<1) Or (len>mn) then Exit;
n:=len;
For i:=1 to n do v[i]:=0;
Assign(f,fo); Rewrite(f);
i:=1;
d:=0;
Repeat
If(i>n) then
8 h 54 m 28/7/2017
66
Thầy Trần Thông Quế
Begin
Inc(d);
Ketqua(d);
i:=n;
End;
If (i<1) then
Begin
If d=0 then Ketqua(0);
close(f);
Write('Done.');
Readln;
Exit;
End;
If Tim(i) Then Inc(i)
Else
Begin
v[i]:=0;
Dec(i);
End;
Until False;
End;
Procedure Test;
Begin
Clrscr;
Timtu(7);
End;
Begin {Main}
Test;
End.
7/ (DECODING BINARY-CODE) Cho mã nhị phân (Binary-code) của n chữ cái đầu tiên trong Alphabet
tiếng Anh. Biết rằng không có mã nào là khúc đầu của mã khác, và độ dài max của mỗi mã là 10. Lập trình
giải mã một đoạn cho trước.
Vào
5
0000
0001
0010
0011
110
0000000100010000
Ra
5
0000
0001
8 h 54 m 28/7/2017
67
Thầy Trần Thông Quế
0010
0011
110
14 E
16 A
17 B
18 C
19 D
CODE.
Uses crt;
Const fi='code.in'; fo='code.ou';
mn=2050;
Var a:Array[0..mn] of char; {mang tao Heap:cay ma}
Procedure giaima;
Var i,j,v,n:integer;
ch:char;
f,g:text;
x:string;
Begin
ch:='A';
Assign(f,fi); Reset(f);
Assign(g,fo); Rewrite(g);
Readln(f,n); Writeln(n,#13#10);
Fillchar(a,sizeof(a),0);
For i:=1 to n do
Begin
Readln(f,x); Writeln(x);
v:=1;
For j:=1 to length(x) do
If x[j]='0' Then v:=v*2
Else v:=v*2+1;
a[v]:=ch;
inc(ch);
End;
Writeln(#13#10);
For i:=1 to mn do
If(a[i]<>#0) then Writeln(i,#32,a[i]);
{Decoding}
While Not Eof(f) Do
Begin
Read(f,ch);
If (ch='0') or (ch='1') Then
Begin
v:=2*v;
If ch='1' Then v:=v+1;
If (a[v]<>#0) then
8 h 54 m 28/7/2017
68
Thầy Trần Thông Quế
Begin
Write(g,a[v]);
v:=1;
End;
End;
End;
Close(f); close(g);
End;
Begin clrscr;
giaima;
Writeln('DONE!');
Readln;
End.
8/ (CEASAR CODE) Trong mật mã học, mật mã Caesar, còn gọi là mật mã dịch chuyển, là một trong
những mật mã đơn giản và cổ nhất (nên hiện nay hầu không dùng). Mật mã này là một dạng của mật mã
thay thế, trong đó mỗi ký tự trong văn bản được thay thế bằng một ký tự cách nó một đoạn trong bảng chữ
cái để tạo thành bản mã. Vĩ dụ, nếu độ dịch là 3 (3 gọi là khóa mã), A sẽ được thay bằng D, Ă sẽ được thay
bằng C và cứ thế đến hết. Phương pháp được đặt tên theo Caesar, vị hoàng đế đã sử dụng nó thường xuyên
trong công việc.
Ví dụ:
Bản chữ cái chưa mã hóa (bản rõ): ABCDEFGHIJKLMNOPQRSTUVWXYZ
Bản chữ cái mật mã: DEFGHIJKLMNOPQRSTUVWXYZABC
Sau Ceasar, các nhà mật mã học, tổng quát mã này lên một chút: chọn K (số nguyên)
làm khóa mã và ký tự thứ I trong Alphabet được mã bởi ký tự thứ (I + K) MOD 27 với
0 <=I<=26.
Bài toán của chúng ta là: Cho trước từ điển gồm các từ khác nhau từng đôi một và không từ nào rỗng, chứa
các chữ cái hoa. Một văn bản S được mã hóa bởi mã Ceasar.
Hãy xác định khóa K để giải mã văn bản ấy (tức là cho biết bản rõ).
Dữ liệu vào lưu trên text file tên là CEASAR.IN, dòng thứ nhất ghi số từ N thuộc từ điển (N<=100); N dòng
tiếp theo ghi các từ của từ điển, mỗi từ có độ dài <= 20 và ghi trên một dòng. Dòng cuối cùng ghi văn bản S
có không quá 250 chữ cái đã được mã hóa bởi mã Ceasar nói trên. Lập trình chọn khóa K để khôi phục bản
rõ sao cho bản rõ chứa nhiều từ nhất của từ điển.
Dữ liệu ra lưu trên text file có tên CEASAR.OU mà dòng đầu ghi giá trị khóa K, dòng tiếp theo ghi bản rõ
của văn bản mã hóa S. Xem:
Vào. CEASAR.IN
7
HANOI
YES
PEDAGOGICAL
HELLO
UNIVERSITY
ITEM
HERO
IBOPJAQFEBHPHJDBMAVOJWFSTJUZAJJ bản mã
8 h 54 m 28/7/2017
69
Thầy Trần Thông Quế
CEASAR.OU
1
HANOI PEDAGOGICAL UNIVERSITY II
CODE.
Uses crt;
Const max=250; fi='Ceasar.In'; fo='Ceasar.Ou';
Type st21=String[21];
tudien=Array[1..max] Of st21;
Var td:tudien; ma,vb,kt,gm:string;
km,sl,slm:Byte; f:Text; n,k:Byte;
Procedure Init;
Var i:Byte;
begin
kt:=' ';
For i:=Ord('A') to Ord('Z') Do
kt:=kt+Char(i);
kt:=kt+kt;
Assign(f,'Ceasar.In'); Reset(f); Readln(f,n);
For i:=1 to n Do
Begin
Readln(f,td[i]); td[i]:=td[i]+' ';
End;
Readln(f,ma);
Close(f);
End;
Function Before(c:Char; k:Byte): Char;
Begin
Before:=kt[pos(c,kt)+27-k];
End;
Procedure Key_Find;
Var i,j:Byte;
Begin
km:=0; slm:=0;
For k:=1 to Length(ma) Do
Begin
vb[0]:=Succ(ma[0]);
For j:=1 to Length(ma) Do
vb[j]:=Before(ma[j],k); sl:=0;
For j:=1 to n Do
If pos(td[j],vb)>0 Then sl:=sl+1;
If sl>slm Then
Begin
slm:=sl; gm:=vb; km:=k;
End;
8 h 54 m 28/7/2017
70
Thầy Trần Thông Quế
End;
End;
Procedure Result;
Begin
Assign(f,'Ceasar.Ou'); Rewrite(f);
Writeln(f,km); Writeln(f,gm);
Close(f);
End;
Procedure Proccess;
Begin
Key_Find;
Result;
End;
Begin clrscr;
Init;
Proccess;
Write('Done!');
Readln;
End.
**9/ (BURROWS-WHEELER CODE, TẮT: BW-CODE, ĐỀ SƠ KHẢO OLYMPIC TIN HỌC QUỐC
TẾ).
Có nhiều phương pháp mã hoá thông tin được sử dụng rộng rãi để đảm bảo tính chất an toàn, bảo mật dữ
liệu. Ở vòng sơ loại thi tin học Quốc tế, có bài toán về mã BW đề cập tới một cách tiếp cận mới trong kỹ
thuật mã hóa và giải mã. Burrows Wheeler đề xuất phương pháp mật mã như sau: ví dụ ta cần mã hoá từ
BANANA, các bước tiến hành là:
Bước 1: Từ cần mã hoá được dịch chuyển vòng tròn và tạo thành một ma trận L*L ký tự, trong đó L là độ
dài của từ. Ta có:
BANANA
ANANAB
NANABA
ANABAN
NABANA
ABANAN
Bước 2: Sắp xếp lại các dòng của ma trận theo thứ tự từ điển:
ABANANANABANANANABBANANANABANANANABA
Bước 3: Tạo một xâu từ các ký tự CUỐI ở mỗi dòng, hiển thị xâu này và cho biết từ gốc là từ thứ mấy trong
ma trận nhận được ở bước 2 (tức là cần tạo cặp (st,d): st-xâu đã mã, 4: index của từ gốc trong xâu đã sắp từ
điển. Ta có (NNBAAA,4) là từ mã BURROWS WHEELER. Dưới đây là CODE.
Program BW_code;
Uses Crt;
Var n:integer;
8 h 54 m 28/7/2017
71
Thầy Trần Thông Quế
id:Array[0..256] of integer;
Procedure Doichoid(i,j:integer);
Var t:integer;
Begin
t:=id[i];
id[i]:=id[j];
id[j]:=t;
End;
Function So(Var s:string; i,j:integer):integer;
Var k: integer;
Begin
For k:=1 to n do
Begin
If (s[i]<>s[j]) Then
Begin
If s[i]
8 h 54 m 28/7/2017
72
Thầy Trần Thông Quế
If id[i]=1 then d:=i;
End;
End;
Procedure Bs(var u:string);
Var i,j:integer;
Begin
For i:=1 to n do id[i]:=i;
For i:=1 to n-1 do
For j:=n downto i+1 do
If u[id[j]]
8 h 54 m 28/7/2017
73
Thầy Trần Thông Quế
80
2 6
9 15
CODE.
Uses Crt;
Const fi='CNMAX.IN'; fo='CNMAX.OU';
mn=80; {Do dai toi dai cua xau ky tu}
Var f,g:Text;
ten:string[12];
m:Byte; {Chieu rong manh dat}
d:Longint; { Dem so dong}
x,y:String; {Theo thu tu: dong tren va dong duoi}
h:Array[0..mn] of Longint; { chieu cao ca cot}
dtmax:Longint; { Dien tich max}
axmax, cxmax:Longint; aymax, cymax:Byte; {Toa do diem a,c}
Procedure Ghi;
Begin
Assign(g,fo); Rewrite(g);
Writeln(g,dtmax);
Writeln(g,axmax,#32,aymax);
Writeln(g,cxmax,#32,cymax);
close(g);
end;
Function Dientich(i:Byte; Var c1,c2: Byte):Longint;
Begin
c1:=i;
While (y[c1-1]=y[i]) And (h[c1-1]>=h[i]) Do
Dec(c1);
c2:=i;
While (y[c2+1]=y[i]) And (h[c2+1]>=h[i]) Do
Inc(c2);
Dientich:=h[i]*(c2+1-c1);
End;
Procedure Run;
Var i,c1,c2:Byte; dt:Longint;
Begin
Write('Cho biet ten tep chua data vao:'); Readln(ten);
Assign(f,ten); Reset(f); Readln(f,m);
d:=0;
x:=#32;
For i:=1 to m Do x:=x+#32;
FillChar(h, sizeof(h),0);
While Not Eof(f) Do
Begin
8 h 54 m 28/7/2017
74
Thầy Trần Thông Quế
Readln(f,y);
Inc(d);
For i:=1 to m Do
If y[i]=x[i] then Inc(h[i]) Else h[i]:=1;
For i:=1 to m Do
Begin
dt:=Dientich(i,c1,c2);
If dt>dtmax Then
Begin
dtmax:=dt;
axmax:=d-h[i]+1; aymax:=c1;
cxmax:=d; cymax:=c2;
End;
End;
x:=y;
End;
Close(f);
Ghi;
End;
Procedure Xem;
Var g:Text; Line:String;
Begin
Writeln('KET QUA CHAY CHUONG TRINH:');
Writeln('* * * * * * * * * * * * *');
Writeln;
Assign(g,'CnMax.Ou'); Reset(g);
While Not SeekEof(g) Do
Begin
Readln(g,Line);
Writeln(#32:7,Line);
End;
Close(g);
End;
Begin clrscr;
Run;
Xem;
Readln
End.
**11/ OLYMPIC TIN HỌC QUỐC TẾ NĂM 2000 TẠI BẮC KINH (HỦY ĐI ÍT NHẤT CÁC KÝ TỰ ĐỂ
PHẦN CÒN LẠI CỦA XÂU VẪN LÀ PALINDROM)
Dãy ký tự s gọi là PALINDROM nếu đọc xuôi, đọc ngược nó đều như nhau. Cho trước s độ dài n gồm các
chữ cái hoa, thường (có phân biệt) và các chữ số. Cho biết cần xóa đi ít nhất bao nhiêu ký tự trong s để
phần còn lại của s cũng là một PALINDROM. Giả sử sau xóa các ký tự còn lại của s tự động xích lại gần
nhau.
YÊU CẦU: Dùng 3 cách: ĐẸ QUY; MỘT MẢNG 1-CHIỀU; 2 MẢNG 1-CHIỀU
8 h 54 m 28/7/2017
75
Thầy Trần Thông Quế
Test Vào: Palindr.vao
9 độ dài xâu s
baeadbadb
Ra: Palindr.ra
4 số ít nhất các ký tự cần xóa
CODE.
Uses Crt;
Const mn=51;
fi='Palindro.in';
Type mi1=Array[0..mn] of Integer;
mi2=Array[0..mn] of mi1;
mc1=Array[0..mn] of Char;
Var n:integer;
f:Text;
s:mc1;
d,v:mi1;
c:mi2;
Procedure Doc;
Var i:integer;
Begin
Assign(f,fi); Reset(f);
Read(f,n);
For i:=1 to n do Read(f,s[i]);
End;
Function max(a,b:Integer):Integer;
Begin
If (a>b) Then max:=a
Else max:=b;
End;
Function Dequy(i,j:integer):integer;
Begin
if (i>j) then Dequy:=0
Else If i=j Then dequy:=1
Else
If s[i]=s[j] Then Dequy:=Dequy(i+1,j-1)+2
Else
Dequy:=Max(Dequy(i,j-1), Dequy(i+1,j));
End;
Procedure Qhd2; {DunG 2 mang 1-chieu v va d}
Var i,j: Integer;
Begin
Fillchar(v,sizeof(v),0);
For j:=1 to n do
Begin
8 h 54 m 28/7/2017
76
Thầy Trần Thông Quế
d[j]:=1;
For i:=j-1 Downto 1 do
Begin
If s[i]=s[j] Then d[i]:=v[i+1]+2
Else d[i]:=Max(v[i],d[i+1])
End;
v:=d;
End;
Writeln(n-d[1])
End;
Procedure Qhd1; {Dung 1 mang 1-chieu}
Var i,j,t,tr:Integer;
Begin
For j:=1 to n do
Begin
Tr:=0;
d[j]:=1;
For i:=j-1 downto 1 do
Begin
t:=d[i];
If s[i]=s[j] then d[i]:=tr+2
else d[i]:=Max(d[i],d[i+1]);
tr:=t;
End;
End;
Write(n-d[1]);
End;
Procedure Test;
Begin
Doc;
Writeln('Dung Dequy: so it nhat cac ky tu can xoa=', n-Dequy(1,n));
Write('Dung 2 Mang 1 chieu:so it nhat ca ky tu can xoa=');
Qhd2;
Write('Dung 1 Mang mot chieu:so it nhat cac ky tu can xoa=');
Qhd1;
End;
Begin Clrscr;
Test;
Readln;
End.
12/ (OLYMPIC MOCKBA -TỪ ĐIỂN) Từ điển Dic gồm nhiều nhất 100 từ khác nhau đôi một. Mỗi từ có
độ dài tối đa là 50 và được viết trên một dòng. Cho trước xâu s có độ dài không quá 200 ký tự. Hãy cho biết
cần xóa khỏi s bao nhiêu ký tự để phần còn lại tạo thành một dãy liên tiếp các từ trong từ điển Dic, mỗi từ
có thể xuất hiện nhiều lần. Từ điển Dic được lưu trên text file Dic.in và kết qủa chạy program lưu tren text
file Dic.ou có cấu trúc và nội dung như dưới đây:
8 h 54 m 28/7/2017
77
Thầy Trần Thông Quế
Dic.in Dic.ou
6 5
abba
not
is
astra
saint
panama
saintpavnamtranasnotsaintabba
Dic.ou
5
Giải thích
*Số ký tự cần xóa=5
*Các ký tự đã xóa là: v, t, r, n, a (các chữ gạch chân): saintpavnamtranaisnotsaintabba
*Các từ ghép lại là: 5,6,3,2,5,1: saintpanamaisnotsaintabba
CODE.
Uses Crt;
const fi='dictio.in'; fo='dictio.ou';
Type st=string[60];
Var f,g:Text;
s:string[200];
w:Array[1..110] of st;
d:Array[0..205] of integer;
n, kq:integer;
Procedure Doc;
Var i:integer;
Begin
Assign(f,fi); Reset(f);
Readln(f,n);
For i:=1 to n do Readln(f,w[i]);
Readln(f,s);
Close(f);
End;
Procedure Ghi(v:integer);
Begin
Assign(g,fo); Rewrite(g);
Writeln(g,v);
Close(g);
End;
Function So(var w:st; i:integer):integer;
Var j:integer;
Begin
so:=0;
8 h 54 m 28/7/2017
78
Thầy Trần Thông Quế
j:=Length(w);
If j>i Then Exit;
If w[j]<>s[i] then Exit;
For I:=i Downto 1 do
If(s[i]=w[j]) Then
Begin
Dec(j);
If j=0 Then
Begin
So:=i; exit;
End;
End;
End;
Function min(a,b:integer):integer;
Begin
If(a0 then d[i]:=min(d[i],d[v-1]+i-v+1-length(w[j]));
End;
End;
Function Xuly:Integer;
var m,i:integer;
Begin
d[0]:=0;
m:=length(s);
For i:=1 to m do Tinh(i);
Xuly:=d[m];
End;
Begin Clrscr;
Doc;
kq:=Xuly;
Ghi(kq);
Writeln('So min cac chu cai can xoa de phan con lai la day lien tiep cac tu thuoc Tu dien=',kq ');
Readln;
End.
8 h 54 m 28/7/2017
79
Thầy Trần Thông Quế
PHẦN V. ĐỆ QUY & QUAY LUI
(RECURSION & BACKTRACKING)
VIẾT CÁC HÀM HOẶC THỦ TỤC ĐỆ QUY GIẢI CÁC BÀI TOÁN SAU:
1/ Tìm ước số chung lớn nhất (USCLN) của 2 số. Áp dụng để tìm USCLN của n số đọc từ bàn phím vào.
CODE:
Program uscln;
Uses crt;
Var i,n,uc,tt:Integer;
a:array[1..1000] of integer;
Function uscmax(x,y:integer):integer;
Begin
If (y=0) Then uscmax:=x
Else uscmax:=uscmax(y,x MOD y)
End;
Begin clrscr;
Randomize;
Repeat
Write('Ban can bao nhieu so?:'); Readln(n);
For i:=1 to n do a[i]:=Random(100);
{Begin
Writeln('So thu ',i,':');
Readln(a[i]);
End;}
Writeln('Day so vua nhap:');
For i:=1 to n do Write(a[i]:3);
i:=1;
Repeat
uc:=uscmax(uc,a[i]);
Inc(i);
Until i=n+1;
Writeln;
Write('Uoc so chung lon nhat cua ',n,' so vua nhap=',uc);
Writeln;
Write('More (1/0)?. More->go 1; Stop->go 0:'); Readln(tt);
Until tt=0;
End.
2/ (KHÔNG ĐƯỢC DÙNG MẢNG). Tìm USCLN của 5 số đọc từ bàn phím vào. (Bài này có vẻ khó hơn
bài trên với một số học sinh!)
CODE:
Program uso;
Uses crt;
Var a,b,c,d,e,uc1,uc2,uc3,uc1a,uc1b:integer;
8 h 54 m 28/7/2017
80
Thầy Trần Thông Quế
Function ucln(x,y:longint):longint;
Begin
if y=0 then ucln:=x
Else ucln:=ucln(y,x MOD y);
End;
Begin clrscr;
Write('Nhap 5 so a,b,c,d,e:'); Readln(a,b,c,d,e);
uc1:=ucln(a,b);
uc2:=ucln(c,d);
uc3:=ucln(e,uc2);
uc1a:=ucln(uc1,uc2);
uc1b:=ucln(uc1a,uc3);
Write('Usc lon nhat cua 5 so vua nhap:',ucln(a,b));
Readln;
End.
3/ Đảo ngược một số nguyên dương gồm n chữ số (n>=2) đọc từ bàn phím vào. Ví dụ 2017 đảo ngược
thành 7102
CODE:
Program Dao_so;
Uses crt;
Var n:longint;
Procedure Daoso(so:longint);
Var csdv,caccscl:integer;
Begin
If (so<10) then Write(so)
Else Begin
csdv:=so MOD 10; {xac dinh chu so hang don vi}
caccscl:=so DIV 10; {xac dinh cac chu so con lai}
Write(csdv);
Daoso(caccscl);
End;
End;
Begin clrscr;
Writeln;
Write('Nhap vao mot so nguyen duong:'); Readln(n);
Write('So ',n,' viet nguoc lai la:');
Daoso(n);
Readln;
End.
4/ (DÃY FIBONACCI NỔI TIẾNG). Hai bài thú vị về dãy này:
4.1- Tìm và in lên màn số Fibonacci thứ k.
CODE:
Program So_Fibonacci_thu_K;
USES CRT;
Var K:Longint; tt:Byte;
FUNCTION Fibo(m:Longint):Longint;
8 h 54 m 28/7/2017
81
Thầy Trần Thông Quế
Begin
If ((m=1) Or (m=2)) Then
Fibo:=1
Else
Fibo:=Fibo(m-1) + Fibo(m-2);
End;
BEGIN CLRSCR;
Repeat
Writeln('TIM SO FIBONACI THU K');
Writeln('---------------------');
Write('-Nhap so K= ');
Readln(K);
Writeln('So Fibonacci thu ',k,' = ',Fibo(K));
Writeln;
Write('More (1/0)?. Come on -> Press 1; Stop -> Press 0:');
Readln(tt);
Until tt=0;
END.
4.2- Cho trước độ dài n. Tìm và in lên màn dãy Fibonacci có độ dài n cho trước.
CODE:
Program Fibo;
Uses crt;
Var i,n: longint;
Function Fibona(i: longint): longint;
Begin
if (i<3) then fibona:=1
Else Fibona:=Fibona(i-1)+Fibona(i-2);
End;
Begin clrscr;
Write('n='); Readln(n);
Write('Day Fibonaci can tim ung voi do dai cho truoc ',n,' la:');
For i:= 1 to n do
Write(Fibona(i):6);
Readln
End.
5/ Dùng ĐỆ QUY, tìm cách và hiển thị các bước của cách ấy chuyển n đĩa có lỗ ở giữa (n đọc từ bàn phím
vào) từ cọc 1 sang cọc 2 được dùng cọc trung gian 3 trong quá trình chuyển. Luật chơi:
• Mỗi lần chỉ được chuyển 1 đĩa,
• Đĩa nhỏ ở trên đĩa lớn,
• Khi chuyển không được đặt đĩa trên bất cứ mặt bằng nào (mặt bàn, ghế, nền nhà . . .).
CODE:
Uses Crt;
var n, count:integer; hoi:char;
Procedure Move(n,c1,c2,c3: integer);
Begin
8 h 54 m 28/7/2017
82
Thầy Trần Thông Quế
If n=1 Then
Begin
Writeln('Chuyen dia tu coc ',C1,' sang coc ',C2);
Inc(count);
End
Else
Begin
Move(n-1,C1,C3,C2);
Move(1,C1,C2,C3);
Move(n-1,C2,C1,C3);
End;
End;
Begin clrscr;
Repeat
Write('Nhap so dia can chuyen:'); Readln(n);
count:=0;
Move(n,1,2,3);
Write('So lan chuyen dia=',count);
Writeln;
Writeln('= = = = = = = = = = = = = = ');
Write('Thu nua chu (c/k)? Tiep=>go c, ngung=> go k:');
Readln(hoi);
Until hoi IN ['k', 'K'];
End.
CHÚ Ý BỔ ÍCH: KHI TEST, CHỚ CÓ TEST VỚI SỐ ĐĨA LỚN, VÍ DỤ VỚI N=64. Dùng trị số này,
có chồng chất 100 lần tuổi thọ của bạn cũng không đủ thời gian chờ kết quả chạy chương trình (với N=64) !
6/ Liệt kê các hoán vị của N số đọc từ bàn phím vào và cho biết tổng số các hoán vị ấy. Yêu cầu: Mỗi lần
chỉ hiện lên màn 20 kết quả, xem tiếp gõ ENTER. Ví dụ vào N=6 thì tổng số hoán vị bằng 720.
Program HoanVinhodequy;
Uses crt;
Type chuoi=Array[1..20] of Integer;
Var a:chuoi; m,n,i,dem:integer;
Procedure Init;
Var i:Integer;
Begin
for i:=1 to n do a[i]:=i;
End;
Procedure Doicho(var x,y:integer);
var tg:integer;
Begin
tg:=x; x:=y;y:=tg;
End;
8 h 54 m 28/7/2017
83
Thầy Trần Thông Quế
Procedure Inra;
var i:integer;
Begin
Writeln; Inc(dem);
For i:=1 to n do
Write(a[i]:4);
If (dem MOD 20)=0 then Readln;
End;
Procedure Hoanvi(i:integer);
var j:integer;
Begin
If i=1 then Inra
Else
For j:=i downto 1 do
Begin
Doicho(a[i],a[j]);
Hoanvi(i-1);
Doicho(a[i],a[j]);
End;
End;
{Main Program}
Begin clrscr;
dem:=0;
Write('Nhap so luong so n can hoan vi:');readln(n);
Writeln(' Cac hoan vi cua ',n,' so: ');
Init;
Hoanvi(n);
Writeln; Writeln;
If dem<>0 then Write('Tong cong co ',dem,' hoan vi cua ',n,' so.');
Readln;
End.
7/Vẽ liên tiếp các hình vuông nội tiếp trong hình vuông đã cho, sao cho các đỉnh của hình vuông nội tiếp là
điểm giữa của các cạnh của hinh vuông ngoại tiếp nó.
KHUẾN CÁO ĐÁNG NGHE: Code đồ họa dưới đây (cũng như mọi Code đồ họa khác), đòi hỏi chạy ở
MODE FULL CREEN, mà các Windows từ VERSION 7 trở lên không hỗ trợ FULL CREEN. Nói vậy tức
là bạn chỉ chạy được các GRAPHIC PROGRAM trong WinXp.
CODE (Phải chạy trên nền WinXp)
uses crt, graph;
const w=400;
Var gd,gm:integer;
procedure hv(x1,y1,x2,y2,x3,y3,x4,y4, sb:integer);
Begin
setcolor(sb mod 15+1);
line(x1,y1,x2,y2);
line(x2,y2,x3,y3);
8 h 54 m 28/7/2017
84
Thầy Trần Thông Quế
line(x3,y3,x4,y4);
line(x4,y4,x1,y1);
If sb>0 then
hv((x1+x2) DIV 2, (y1+y2) DIV 2,(x2+x3) DIV 2,(y2+y3) DIV 2,
(x3+x4) DIV 2,(y3+y4) DIV 2,(x4+x1) DIV 2,(y4+y1)DIV 2,sb-1);
End;
Begin clrscr;
gd:=detect;
Initgraph(gd,gm,' ');
hv((getmaxX-w) DIV 2,(getmaxY-w) DIV 2,(getmaxX-w) DIV 2,
(getmaxY+w) DIV 2,
(getmaxX+w) DIV 2,(getmaxY+w) DIV 2,(getmaxX+w) DIV 2,
(getmaxY-w) DIV 2,16);
Readln;
closeGraph;
End.
8/ Viết các hàm đệ quy tính các tổng S sau:
8.1- Tính N!! . Sau đó dùng hàm đó để tính: S=1!!-2!!+…+(-1)k+1k!! (k<1000)
8.2- S=1+22+33+44. . .+nn
8.3- S=
có n dấu căn.
8.4- S=
*8.5- S(n)= trong đó x là số thực
GỢI Ý: Nếu như thoạt nhìn, không thấy quy luật dùng đệ quy ở biểu thức đã cho, thì hãy biến đổi toán học
nó sao cho xuất hiện biểu thức dùng được đệ quy.
Chẳng hạn bài 8.5 có vẻ khó nhất với các bạn. Ta biến đổi nó như sau:
a) Nhìn vào hệ thức (8.5) ta suy ra:
S(n-1) =
S(n-2) =
b) Tính hiệu S(n) – S(n-1) ta được S(n) = S(n-1) + (*)
8 h 54 m 28/7/2017
85
Thầy Trần Thông Quế
c) Tính hiệu S(n-1) – S(n-2) ta được (**)
Thế (**) vào (*) ta có ngay quy luật để thiết kế đệ quy tính S(n):
S(n) = S(n-1) + quy luật đệ quy đã hiện rõ!
Việc còn lại (viết code tính S(n)) là việc dễ đối với các bạn!
9- Liệt kê tất cả các dãy nhị phân dài n (n đọc từ bàn phím vào).
Uses Crt;
Var i,n:integer;
b:Array[1..100] of 0..1; tt:byte;
Procedure Result;
Var i: Integer;
Begin
For i:=1 to n Do Write(b[i]:2); Writeln;
End;
Procedure Try(i:Integer);
Var j:Integer;
Begin
For j:=0 to 1 do
Begin
b[i]:=j;
If i=n Then Result Else Try(i+1);
End;
End;
Begin clrscr;
Repeat
Write('Nhap n:'); Readln(n);
Try(1);
Writeln;
Write('Another Test (1/0)?. Come on -> Press 1, Stop -> Press 0:');
Readln(tt);
Until tt=0;
End.
*10- Điền các dấu “(“, “)” và 4 phép tính số học vào một biểu thức số học để tính đúng gía trị n cho trước.
Program Dien_dau_phep_tinh;
Uses crt;
8 h 54 m 28/7/2017
86
Thầy Trần Thông Quế
Var p,a:array[1..100] of char;
i,j,k,h,d:longint; n:real;hoi:char;
Procedure Inra;
Begin
Write('(((((');
For i:=1 to 6 do
Begin
If i=1 then Write(i,a[i]);
If i>1 then Write(i,')',a[i]);
End;
Writeln;
d:=d+1;
End;
Procedure Test(k:integer);
Var j,i1:integer; t:real;
Begin
For j:=1 to 4 do
Begin
a[k]:=p[j];
If k=5 then
Begin
t:=1;
For i1:=2 to 6 do
Begin
If a[i1-1]='-' then t:=t-i1;
If a[i1-1]='+' then t:=t+i1;
If a[i1-1]='*' then t:=t*i1;
If a[i1-1]='/' then t:=t/i1;
End;
If t=n then Inra;
End
Else Test(k+1);
End;
End;
Begin clrscr;
Repeat
Writeln;
Write('Nhap gia tri n can co='); Readln(n);
d:=0;
p[1]:='-';
p[2]:='+';
p[3]:='*';
p[4]:='/';
Test(1);
Writeln;
Writeln(' Co ',d,' cach dien cac phep tinh de bieu thuc da cho co gia tri bang so ',n:9:2);
8 h 54 m 28/7/2017
87
Thầy Trần Thông Quế
Write('Another Test (y/n)?'); Readln(hoi);
Until hoi In ['n','N'];
End.
11- Cho trước bộ số 1, 2, 3, 4. Liệt kê tất cả các số dài n lập nên từ bộ số đã cho.
CODE.
Uses Crt;
Var n:Byte;
a:Array[1..20] of Byte; Ans:Char;
Procedure Result_Print;
Var i:Byte;
Begin
For i:=1 to n Do
Write(a[i]);
End;
Procedure For_Recur(i:integer);
Var j:Byte;
Begin
For j:=1 to 4 do
Begin
a[i]:=j;
If i Press c; Stop-.Press k or K.');
Readln(Ans);
Until Ans In ['k', 'K'];
End.
**12- Nhập vào một dãy số có n phần tử (n cho trước). Phân hoạch dãy này thành các dãy con. Tìm ước số
chung lớn nhất của các số thuộc mỗi dãy con. In kết quả lên màn.
Program PhanHoach_Tap;
uses crt;
Type m=array[1..100] of integer;
Var c,a:m;
p:array[1..100] of Boolean;
z,i,n,dem:integer;
8 h 54 m 28/7/2017
88
Thầy Trần Thông Quế
Function uscln(a,b:integer):integer;
Begin
while a<>b do
begin
if a>b then a:=a-b
Else b:=b-a;
end;
uscln:=b;
end;
Procedure thu(k:integer);
var j,i1,us1,i,j1:integer;
Begin
for j:=z to n do
if p[j] then
Begin
c[k]:=a[j]; p[j]:=False;
If k>1 then
Begin
dem:=dem+1;
Writeln('* Tap con thu ',dem,' la:');
For i1:=1 to k do
write(c[i1]:4);Writeln;
us1:=c[1];
For j1:=2 to k do us1:=uscln(us1,c[j1]);
Write('Uoc so chung lon nhat cua ');
Writeln(' tap con thu ',dem,' la:',us1);
End;
If k<>n then
Begin
z:=j+1; Thu(k+1);
End;
p[j]:=true;
z:=j-1;
End;
End;
Begin clrscr;
Write('Vao n='); Readln(n);
For i:=1 to n do
Begin
Write('a[',i,']='); Readln(a[i]);
End;
dem:=0; z:=1;
For i:=1 to n do p[i]:=true;
Thu(1);
Writeln;
Writeln('Voi so n=',n,' vua nhap vao, so tap con =',dem);
8 h 54 m 28/7/2017
89
Thầy Trần Thông Quế
Readln { không có “;” cũng như có “;” }
End.
*13-Cho bộ 9 chữ cái a, b, c, d, e, f, g, h, i. Lập trình tạo các từ có từ 2 đến 4 chữ cái (trong đó có ít nhất 1
nguyên âm) thuộc bộ trên. Kết qủa lưu lên text file cactu.ou
Uses Crt;
Const chucai=['a','e','i'];
fo='cactu.ou';
Var c:ArrAy[1..5] Of Char;
yes:Boolean;
dem, n:longint;
f:text;
Procedure WriteTo;
Var i:integer;
Begin
{Inc(dem);}
For i:=1 to n Do Write(f,c[i],' ');
Writeln(f);
End;
Procedure Tim(i:Integer);
Var ch:char; nho:Boolean;
Begin
Nho:=yes;
For ch:='a' to 'i' do
Begin
c[i]:=ch;
If ch In chucai then yes:=True;
If (i=n) Then
Begin
If yes then WriteTo
End
Else
Tim(i+1);
yes:=nho;
End;
End;
Begin clrscr;
{Dem:=0;}
Assign(f,fo); Rewrite(f);
For n:=2 to 4 do
Begin
yes:=False;
Tim(1);
End;
{Writeln(f,'So tu da liet ke=',dem);}
8 h 54 m 28/7/2017
90
Thầy Trần Thông Quế
Close(f);
Write('Done!');
Readln;
End.
14/ Tìm cách xếp 8 quân xe lên bàn cờ tướng 8x8 để không quân nào ăn được nào. Yêu cầu: Mỗi lần xem
từng kết quả một. Xem tiếp gõ ENTER; Thoát gõ CTRL-ECS.
Uses Crt;
Const fo='tamxe.ou';
Var f:Text; d:word; line:string;
cx:Array[1..8] Of Boolean;
a:Array[1..8] of Byte;
Procedure WriteOnFile;
Var i:Byte;
Begin
Inc(d);
Writeln(f);
Write(f,'cachh thu ',d,':');
For i:=1 to 8 do Write(f,'[',i,',',a[i],']',';');
End;
Procedure Try(k:Byte);
Var i:Byte;
Begin
For i:=1 to 8 do
If cx[i] Then
Begin
a[k]:=i;
cx[i]:=False;
If k=8 then WriteOnFile Else Try(k+1);
cx[i]:=True;
End;
End;
Begin Clrscr;
d:=0;
FillChar(cx,sizeof(cx),True);
Assign(f,fo); Rewrite(f);
Try(1);
Reset(f);
While Not SeekEof(f) Do
Begin
Readln(f,line);
Writeln(#32:7,line);
If (d MOD 20)=0 Then Readln; {De xem tung dap so mot; Go CTRL-ESC: Thoat}
End;
Close(f);
8 h 54 m 28/7/2017
91
Thầy Trần Thông Quế
Readln;
End.
= = = = = = = = = = = = = = = = = =
PHẦN VI. BẢN GHI & TỆP (RECORD and FILES)
Lập trình làm các việc sau:
RECORD
1/Thực hiện các phép toán trên hai phân số.
Uses Crt;
Type phanso=Record
ts,ms:Integer;
End;
Var ps1,ps2,ps3:phanso; pheptoan,tiep: char;
err: Boolean;
Procedure Nhap(Var ps:phanso);
Begin
Write('Nhap tu:');Readln(ps.ts);
Write('Nhap mau:');Readln(ps.ms);
End;
Procedure Xuat(Var ps:phanso);
Begin
Write('(',ps.ts,'/',ps.ms,')');
End;
Procedure Cong(ps1,ps2:phanso; Var tps:phanso);
Begin
tps.ts:=ps1.ts*ps2.ms+ps1.ms*ps2.ts;
tps.ms:=ps1.ms*ps2.ms;
End;
Procedure Tru(ps1,ps2:phanso; Var tps:phanso);
Begin
tps.ts:=ps1.ts*ps2.ms-ps1.ms*ps2.ts;
8 h 54 m 28/7/2017
92
Thầy Trần Thông Quế
tps.ms:=ps1.ms*ps2.ms;
End;
Procedure Nhan(ps1,ps2:phanso; Var tic:phanso);
Begin
tic.ts:=ps1.ts*ps2.ts;
tic.ms:=ps1.ms*ps2.ms;
End;
Function Uscln(a,b:integer):integer;
Begin
While a<>b do
If a> b then a:=a-b
Else b:=b-a;
Uscln:=a;
End;
Procedure Rutgon(Var ps:phanso);
Var uc:integer;
Begin
uc:=Uscln(ps.ts,ps.ms);
ps.ts:=ps.ts DIV uc;
ps.ms:=ps.ms DIV uc;
End;
Procedure Doidau(Var ps:phanso);
Begin
ps.ts:=-ps.ts;
End;
Procedure Ngichdao(Var ps:phanso);
Var tam:integer;
Begin
tam:=ps.ts;
ps.ts:=ps.ms;
ps.ms:=tam;
End;
{Main Prog.}
Begin clrscr;
Repeat
8 h 54 m 28/7/2017
93
Thầy Trần Thông Quế
Write('Nhap ps thu nhat:'); Writeln;
Nhap(ps1);
Write('Nhap ky hieu phep toan:'); Readln(pheptoan);
err:=false;
If pheptoan In ['+','-','*',':'] Then
Begin
Writeln;
Write('Nhap ps thu hai:');
Writeln;
Nhap(ps2);
Write('Ket qua:');
Xuat(ps1);
Write(pheptoan);
xuat(ps2);
Write('=');
Case pheptoan of
'+':Begin Cong(ps1,ps2,ps3); Rutgon(ps3); End;
'-':Begin
Tru(ps1,ps2,ps3);
Doidau(ps2);
cong(ps1,ps2,ps3);
Rutgon(ps3);
End;
'*':Begin nhan(ps1,ps2,ps3);Rutgon(ps3); End;
':':If ps2.ts<>0 then
Begin
Ngichdao(ps2);
Nhan(ps1,ps2,ps3);
Rutgon(ps3);
End
Else err:=true;
End;
If Not err Then
Begin
Xuat(ps3);
Writeln;
Write('Go phim bat ky de tiep tuc cong viec!'); Readln;
Clrscr;
End
Else Write('Loi: khong chia duoc cho Zero!');
8 h 54 m 28/7/2017
94
Thầy Trần Thông Quế
Writeln;
End
Else Writeln('Program chua lam duoc phep toan nay!');
Write('More(y/n)?, tiep -> go y, ngung -> go n:');
Readln(tiep);
Until tiep='n';
End.
2/ Thực hiện các phép toán trên hai đa thức
Uses Crt;
Const max=20;
Type dathuc=record
bac:integer;
hso:Array[0..max] of real;
End;
Var a,b,c:dathuc; i:integer;
Procedure Nhap(kh:String; var p:dathuc);
Begin
Writeln; Writeln;
With p do
Begin
Repeat
Write('Nhap vao lan luot bac ',Chr(Ord(kh[1])+7),
' va cac he so cua da thuc ',kh,'=');
Readln(bac);
If bac>max Then
Write('Bac cua da thuc phai <=max)',max);
Until (Bac>=1) And (Bac<=max);
For i:=bac downto 0 Do
Begin Write(#32:3,'a[',i,']='); Readln(hso[i]); End;
End;
End;
Procedure PolyDisp(kyhieu:string; p:dathuc);
Begin
Write(kyhieu,'=');
With p do
Begin
For i:=bac downto 1 Do
8 h 54 m 28/7/2017
95
Thầy Trần Thông Quế
Begin
If hso[i]<>0 Then
Begin
If Frac(hso[i])=0 Then
Write(hso[i]:0:0,'.x')
Else Write(hso[i]:0:2,'.x');
If i>1 then Write('^',i);
End;
If hso[i-1]>0 Then Write('+');
End;
If hso[0]<>0 Then
If Frac(hso[0])=0 Then Write(hso[0]:0:0)
Else Write(hso[0]:0:2);
End;
Writeln;
End;
Procedure PolyAdd(p,q:dathuc; Var sum:dathuc); {cong da thuc}
Var i,j:integer;
Begin
If p.bac>q.bac Then sum.bac:=p.bac
Else sum.bac:=q.bac;
For i:=sum.bac downto 0 Do
sum.hso[i]:=p.hso[i]+q.hso[i];
Write('Tong cua 2 d/thuc f(x) va g(x) la:');
Polydisp('S(x)',sum);
End;
Procedure PolySubt(p,q:dathuc; Var h:dathuc); {tru da thuc}
Var i,j:integer;
Begin
If p.bac>q.bac Then h.bac:=p.bac
Else h.bac:=q.bac;
For i:=h.bac downto 0 Do
h.hso[i]:=p.hso[i]-q.hso[i];
Write('Hieu cua 2 d/thuc f(x) va g(x) la:');
Polydisp('H(x)',h);
End;
Procedure PolyFact(p,q:dathuc; Var tic:dathuc); {nhan da thuc}
Var i,j:integer;
Begin
8 h 54 m 28/7/2017
96
Thầy Trần Thông Quế
tic.bac:=p.bac+q.bac;
For i:=0 to tic.bac do tic.hso[i]:=0;
For i:=p.bac downto 0 Do
For j:=q.bac downto 0 Do
tic.hso[i+j]:=tic.hso[i+j]+p.hso[i]*q.hso[j];
Write('Tich cua 2 dthuc f(x) va g(x) la:');
Polydisp('T(x)',tic);
End;
Procedure PolyDivi(p,q:dathuc; Var thg:dathuc); {chia da thuc}
Var i,j,m:integer; du:dathuc;
Begin
m:=p.bac-q.bac;
If m<0 Then
Begin
Write('Khong chia duoc!');
Readln;
Exit;
End;
For i:=0 to m Do thg.hso[i]:=0;
thg.bac:=m;
For i:=m Downto 0 Do
Begin
thg.hso[i]:=p.hso[p.bac]/q.hso[q.bac];
For j:=q.bac downto 0 Do
p.hso[p.bac-q.bac+j]:=p.hso[p.bac-q.bac+j]-thg.hso[i]*q.hso[j];
p.bac:=p.bac-1;
End;
du:=p;
While (du.hso[du.bac]=0) and (du.bac>0) Do
du.bac:=du.bac-1;
Write('Thuong cua 2 dthuc f(x) va g(x) la:');
PolyDisp('Th(x)',thg);
If (du.bac=0) then Write('2 dthuc da cho chia het nhau!')
Else Polydisp('Da thuc du',du);
End;
{Main Prog}
Begin clrscr;
Nhap('f(x)',a);
Nhap('g(x)',b);
Writeln('Cac da thuc vua nhap:');
PolyDisp('f(x)',a);
8 h 54 m 28/7/2017
97
Thầy Trần Thông Quế
PolyDisp('g(x)',b);
Writeln;
PolyAdd(a,b,c);
Writeln;
PolySubt(a,b,c);
Writeln;
PolyFact(a,b,c);
Writeln;
PolyDivi(a,b,c);
Readln;
End.
3/Thực hiện các phép toán trên hai số phức. (Với nhiều học sinh, phép tính chia hai số phức
là khó nhất!)
Uses Crt;
Type complex=Record
thuc,ao:Real;
End;
Var a,b,c: complex;
Procedure Input(kt: Char; Var x: complex);
Begin
Writeln('Nhap so phuc ',kt,':');
Write('Phan thuc:'); Readln(x.thuc);
Write('Phan ao:'); Readln(x.ao);
End;
Procedure WriteCompl(x:complex);
Begin
Write('(');
If Frac(x.thuc)=0 then Write(x.thuc:0:0)
Else Write(x.thuc:0:2); Write(';');
If Frac(x.ao)=0 then Write(x.ao:0:0)
Else Write(x.ao:0:2); Write(')');
End;
Procedure Add(x,y:complex; Var z:complex);
Begin
z.thuc:=x.thuc+y.thuc;
z.ao:=x.ao+y.ao;
8 h 54 m 28/7/2017
98
Thầy Trần Thông Quế
End;
Procedure Sub(x,y:complex; Var z:complex);
Begin
z.thuc:=x.thuc-y.thuc;
z.ao:=x.ao-y.ao;
End;
Procedure Multip(x,y:complex; Var z:complex);
Begin
z.thuc:=x.thuc*y.thuc-x.ao*y.ao;
z.ao:=x.thuc*y.ao+x.ao*y.thuc;
End;
Procedure Divi(x,y:complex; Var z:complex);
Begin
z.thuc:=(x.thuc*y.thuc+x.ao*y.ao)/(sqr(y.thuc)+sqr(y.ao));
z.ao:=(x.ao*y.thuc-x.thuc*y.ao)/(sqr(y.thuc)+sqr(y.ao));
End;
Begin clrscr;
Input('A',a);
Input('B',b);
clrscr;
Writeln('Hai so phuc vua nhap la:');
Writeln;
Write('So phuc A:'); WriteCompl(a); Writeln;
Write('So phuc b:'); WriteCompl(b); Writeln;
Add(a,b,c);
Write('Tong 2 so phuc vua nhap='); WriteCompl(c); Writeln;
sub(a,b,c);
Write('Hieu 2 so phuc vua nhap='); WriteCompl(c); Writeln;
Multip(a,b,c);
Write('Tich 2 so phuc vua nhap='); WriteCompl(c); Writeln;
Divi(a,b,c);
Write('Thuong cua 2 so phuc vua nhap='); WriteCompl(c);
Readln;
End.
FILES
8 h 54 m 28/7/2017
99
Thầy Trần Thông Quế
4/ Các thông tin Check In của khách tại sân bay Nội Bài được lưu trong text file tên là
KHACHBAY.VAO có cấu trúc sau: Dòng đầu ghi số khách bay, các dòng tiếp theo ghi
trọng lượng của từng đồ xách tay (túi, hộp, balô …) của mỗi khách. Dữ liệu ra gồm hai text
file:
file TRONGLUONG.RA ghi tổng trọng lượng các đồ xách tay của mỗi khách bay;
file HUYBAY.RA ghi số thứ tự của những khách bay bị hủy chuyến bay nếu tổng trọng
lượng các đồ xách tay của người này 20 KG HOẶC số đồ xách tay nhiều hơn 5.
Dưới đây là một ví dụ về 3 files như vậy:
KHACHBAY.VAO
5
19.5
2.5 1.5 2 3.25 1 3 (Trên mỗi dòng các số cách nhau ít nhất một ký tự trống)
6.25 2.5 7
12 6.5 4 10 7.5
2 6 8
TRONGLUONG.RA
19.50
13.25
15.75
40.00
16.00
HUYBAY.RA
2 → khách này có số đồ xách tay >5
4
Uses Crt;
Var tepvao,tepra,tephuy: Text;
sum,w: Real; n,i,k:Byte;
Begin Clrscr;
Assign(tepvao,'khachbay.vao'); Reset(tepvao);
Readln(tepvao,n);
Assign(tepra,'trgluong.ra'); Rewrite(tepra);
Assign(tephuy,'huybay.ra'); Rewrite(tephuy);
For i:=1 to n do
Begin
sum:=0; k:=0;
While Not(SeekEoln(tepvao)) Do
Begin
Read(tepvao,w);
8 h 54 m 28/7/2017
100
Thầy Trần Thông Quế
sum:=sum+w;
k:=k+1;
End;
Writeln(tepra,sum);
If (sum>20) Or (k>7) Then Writeln(tephuy,i);
Readln(tepvao);
End;
Close(tepvao);
Close(tepra);
Close(tephuy);
Assign(tepra,'trgluong.ra'); Reset(tepra);
Writeln('Noi dung cua file trgluong.ra ghi tong trongluong');
Writeln(' cac kien hang cua tung khach hang:');
Writeln;
While Not(SeekEof(tepra)) do
Begin
Readln(tepra,sum);
Writeln(sum:0:2);
End;
Close(tepra);
Writeln;
Assign(tephuy,'huybay.ra'); Reset(tephuy);
Writeln('Noi dung tep huybay.ra ghi so thu tu cac khach bi huy bay:');
Writeln;
While Not(SeekEof(tephuy)) do
Begin
Readln(tephuy,i);
Writeln(i);
End;
Close(tephuy);
Readln;
End.
5/ Các số nguyên (gồm cả số dương lẫn số âm) được lưu trên text file SONGUYEN.DAT,
Hãy cất các số dương lên file POSI.DAT, cất các số âm lên fie NEGA.DAT. Hiển thị nội
dung hai file này lên màn hình.
Program PosiNegaFile;
Uses Crt;
Var f1,f2,f3: file Of Integer;
i,n,x:integer;
8 h 54 m 28/7/2017
101
Thầy Trần Thông Quế
Begin clrscr;
{$I-} Assign(f1,'Songuyen.dat'); Rewrite(f1); {$I+}
Write('Cho so luong cac so nguyen:'); Readln(n);
For i:=1 to n do
Begin
Write('So thu ',i,':');
Readln(x);
Write(f1,x);
End;
Close(f1);
Write(#10#13,'Da nhap xong ',n,' so nguyen len file songuyen.dat');
Writeln('Press Any Key to Continue...');
Repeat Until KeyPressed;
Readkey;
Clrscr;
{$I-} Assign(f1,'Songuyen.dat');
Assign(f2,'Posi.dat');
Assign(f3,'Nega.dat');
Reset(f1);
Rewrite(f2);
Rewrite(f3);
{$I+}
{Ghi cac so Duong len File f2, ghi cac so am len file f3}
While Not EOF(f1) Do
Begin
Read(f1,x);
If (x>=0) Then Write(f2,x)
Else Write(f3,x);
End;
Close(f1); Close(f2); Close(f3);
{Doc Data cua file f2}
Assign(f2,'Posi.dat'); Reset(f2);
Writeln('Data tren file Posi.dat:');
While Not EOF(f2) Do
Begin
Read(f2,x);
Write(x:3);
End;
Close(f2);
Writeln;
{ Doc Data tren file f3}
Assign(f3,'Nega.dat'); Reset(f3);
8 h 54 m 28/7/2017
102
Thầy Trần Thông Quế
Writeln('Data tren file Nega.dat:');
While Not EOF(f3) Do
Begin
Read(f3,x);
Write(x:3);
End;
Close(f3);
Write(#10#13,' Press Any Key to continue...');
Repeat until KeyPressed;
End.
6/Text file Num1.txt chứa một số số nguyên; text file Num2.txt cũng chứa một số số nguyên.
Hai files này có vài số như nhau. Tìm và “nhặt” các số có mặt ở cả hai file trên và
lưu chúng lên file Ketqua.txt. Hiện nội dung file Ketqua.txt lên màn hình.
Uses Crt;
Var f1,f2,f3: Text;
m,n,i,j,x:Integer;
a1,a2:Array[1..100] of Integer;
Begin clrscr;
{$I-}
Assign(f1,'Num1.txt');
Assign(f2,'Num2.txt');
Rewrite(f1);
Rewrite(f2);
{$I+}
Write('Cho so cac so trong file Num1.txt:'); Readln(m);
Writeln(f1,m);
For i:=1 to m do
Begin
Write('So thu ',i,':');
Readln(x);
Writeln(f1,x:3);
End;
Close(f1);
Write('Cho so cac so trong file Num2.txt:'); Readln(n);
Writeln(f2,n);
For i:=1 to n do
Begin
Write('So thu ',i,':');
Readln(x);
Writeln(f2,x:3);
8 h 54 m 28/7/2017
103
Thầy Trần Thông Quế
End;
Close(f2);
{$I-}
Assign(f1,'Num1.txt');
Assign(f2,'Num2.txt');
Assign(f3,'Ketqua.txt');
Reset(f1);
Reset(f2);
Rewrite(f3);
{$I+}
{Doc Data tren file f1 vao mang a1 (tuc vao Ram)}
Readln(f1,m);
For i:=1 to m do
Readln(f1,a1[i]);
{Doc Data tren file f2 vao mang a2 (tuc vao Ram)}
Readln(f2,n);
For j:=1 to n do
Readln(f2,a2[j]);
Writeln;
Writeln('CAC SO CO MAT O CA 2 FILE:');
Writeln;
For i:=1 to m do
For j:=1 to n do
Begin
If a1[i]=a2[j] Then
Begin
Writeln(f3,a1[i]:3);
Writeln(a1[i]:3);
End;
End;
Close(f1);
Close(f2);
Close(f3);
Write(#10#13,'GO PHIM BAT KY DE TIEP...');
Repeat Until KeyPressed;
End.
= = = = = = = = = = = = = = = = = = =
8 h 54 m 28/7/2017
104
Thầy Trần Thông Quế
PHẦN VII. ĐỒ HỌA (GRAPHIC)
(Ít nhất cũng có 5 bài khá thú vị với những người mê lập trình:
đó là các bài: In lịch; Vẽ đồng hồ; Kính vạn hoa; Tìm MỘT nghiệm của bài
toán Đặt Hậu; Tìm TẤT CẢ NGHIỆM có thể
cho bài toán Đặt Hậu)
Lời khuyên hữu ích: TẤT CẢ CÁC BÀI TOÁN GRAPHIC VÀ GRAPH DÙNG GRAPHIC ĐỀU PHẢI
CHẠY TRONG CÁC PHIÊN BẢN WINDOW CÓ HỖ TRỢ FULL SCREEN MODE. ĐẾN CHẾT
CŨNG ĐỪNG QUÊN LỜI DẶN NÀY!!!
Lập trình Đồ họa thực thi các bài toán sau:
1/ Vẽ cột phát sóng và các vòng sóng truyền lan.
Uses Crt, Graph;
Var Gd, Gm: Integer; r:word;
Begin clrscr;
Gd:=Detect; InitGraph(Gd,Gm,'D:\BP\BGI');
r:=15;
Repeat
SetColor(4);
MoveTo(300,200);
LineTo(320,440);
LineTo(280,440);
LineTo(300,200);
Rectangle(280,440,320,470);
SetColor(15);
Circle(300,200,r);
Delay(100);
If r>GetmaxY/2 then ClearDevice;
If r<=GetmaxY/2 then r:=r+30
Else r:=15;
Until KeyPressed;
CloseGraph;
End.
2/ Vẽ các vòng tròn đồng tâm đổi màu liên tục.
Uses Crt,Graph;
Var i,j,Gd,Gm,xt,yt,yc:Integer;
r:Word; hoi:char;
Begin clrscr;
Gd:=Detect; InitGraph(Gd,Gm,'D:\BP\BGI');
8 h 54 m 28/7/2017
105
Thầy Trần Thông Quế
If GraphResult<>0 Then
Begin
Write('Loi do hoa.');
Halt;
End
Else
Begin
xt:=getMaxX Div 2;
yt:=GetMaxY Div 2;
yc:=GetMaxY Div 30;
End;
Repeat
SetBkColor(Black);
SetColor(15);
Rectangle(1,1,200,15);
SetColor(12);
OutTextXY(12,5,'PRESS ANY KEY TO STOP.');
R:=1;
For i:=1 to 15 do
Begin
SetColor(Random(16));
For j:=1 to yc do
Circle(xt,yt,r+j);
Inc(r,yc);
End;
Until KeyPressed;
CloseGraph;
End.
3/ Vẽ đồ thị hàm sinx (hoặc cosx: Tùy!).Yêu cầu: chương trình ngắn nhất có thể.
uses crt,graph;
var mh, mot,maxx,maxy, xtam,ytam:integer;
x, y:real;
Function F(x:real):real;
Begin
F:=sin(x);
End;
Begin clrscr;
mh:=Detect; InitGraph(mh,mot,'..\BGI');
SetBkColor(Cyan);
If GraphResult<>GrOk then Halt
Else
Begin
maxx:=Getmaxx;maxy:=Getmaxy;
xtam:=maxx DIV 2;
ytam:=maxy DIV 2;
Setcolor(White);
8 h 54 m 28/7/2017
106
Thầy Trần Thông Quế
Line(0,ytam,maxx-5,ytam);
OutTextxy(maxx-10,ytam-3,'>');
Line(xtam,5,xtam,maxy);
OutTextxy(xtam-3,5,'>');
OutTextxy(xtam-10,ytam+10,'O');
X:=-4*Pi;
Repeat
y:=Round(F(x)*40);
PutPixel(Round(20*x)+xtam,ytam-Round(y),Red);
x:=x+0.001;
Until x>4*Pi;
Readln;
closegraph;
End;
End.
*4/ In lịch dương có khuôn dạng tương tự lịch tờ to treo tường.
PROGRAM InLich;
Uses Crt,Graph,Dos;
Label 1;
Var n,m,y: integer;
Function NumDays(m: integer): Integer; {Ham tra ve so ngay trong thang}
Begin
case m of
4,6,9,11:NumDays:=30;
2:if (m mod 4)<>0 then NumDays:=28 else
begin
if (m mod 100)<>0 then NumDays:=29 else
begin
if (m mod 400)<>0 then NumDays:=28 else NumDays:=29
end
end
else Numdays:=31
end;
End;
{Ham tra ve so thu tu cua thu trong tuan ung voi ngay mong 1 cua thang}
function FirstDay(m,y:word): word;
var d,y1,m1,d1,dow1,dow: word;
Begin
d:=1;
GetDate(y1,m1,d1,dow1);
setdate(y,m,d);
GetDate(y,m,d,dow);
FirstDay:=dow;
setdate(y1,m1,d1);
8 h 54 m 28/7/2017
107
Thầy Trần Thông Quế
End;
Procedure In_lich(m,y: integer);
var i,j,k,n,rows,cols,gd,gm: integer;
Begin
k:=FirstDay(m,y);
n:=numDays(m);
Cols:=7;
Rows:= (n+k) DIV 7;
if (n+k) MOD 7 <> 0 then Rows:= Rows + 1;
Writeln;
textmode(c80);
textcolor(12);
Writeln(#32:16,'LICH THANG ',m,' - NAM ',y);
writeln(#32:16,'-------------------------');
writeln;
textcolor(lightmagenta);
Write('SUN':8);
textcolor(lightgreen);
Write('MON':8,'TUE':8,'WED':8,'THU':8,'FRI':8);
textcolor(lightblue);
Writeln('SAT':8);
Writeln;
For i:=1 to n+k do
Begin
If i<=k then Write(#32:8)
Else
Write(i-k:8); textcolor(yellow);
If i MOD 7 = 0 then Writeln;
End;
End;
BEGIN
1:clrscr;
Write('Nhap thang,nam (nam co 4 chu so):');
readln(m,y);
In_lich(m,y);
Writeln(#10#13);
textcolor(lightmagenta);
Write('Nhan phim bat ky de tiep tuc. Nhan "k" de ket thuc...');
if readkey<> 'k' then goto 1;
END.
Cách kiểm tra kết quả chạy program xem có CHÍNH XÁC KHÔNG: Gỉa sử nhập dữ liệu là tháng 7 năm
2017 thì LƯU Ý: Ra SAT ứng với ngày 8, SUN ứng với ngày 9 là prog. chạy chính xác. TỐT NHẤT NÊN
SO VỚI LỊCH BỎ TÚI của nhà xuất bản uy tín.
8 h 54 m 28/7/2017
108
Thầy Trần Thông Quế
*5/ Tạo lập bảng mã ASCII mở rộng. Yêu cầu: gõ PgDn để xem tiếp. Gõ phím bất kỳ để thoát.
Program AsciiTable;
Uses Crt, Addcrt;
Label 1;
Const Hexa:Array[0..15] of Char='0123456789ABCDEF';
Type St=String[3];
Var i,j,x,m,n,y,e:Integer;
ch:Char;
Procedure Box(x1,x2,y1,y2:Byte);
Var i:Byte;
Begin
If (x1<0)Or (y1<0) Or (x2>80) Or (y2>25) Or (x1>x2) Or (y1>y2) Then exit;
Textcolor(0);
GotoXY(x1,y1); Write('I');
GotoXY(x2,y1); Write(';');
GotoXY(x1,y2); Write('H');
GotoXY(x2,y2); Write('<');
For i:=(x1+1) to (x2-1) Do
Begin
GotoXY(i,y1);
Write('M');
End;
For i:=(x1+1) to (x2-1) Do
Begin
GotoXY(i,y2);
Write('M');
End;
For i:=(y1+1) to (y2-1) Do
Begin
GotoXY(x1,i);
Write(':');
End;
For i:=(y1+1) to (y2-1) Do
Begin
GotoXY(x2,i);
Write(':');
End;
End;
Procedure Color(x1,x2,y1,y2:Byte);
Begin
Tomau(x1,y1,x2,y2,3);
Box(x1+1,y1+1,x2-1,y2-1);
Tomau(x1+2,y1+2,x2-2,y2-2,3);
End;
Function Doi(i1:Byte):St;
8 h 54 m 28/7/2017
109
Thầy Trần Thông Quế
Begin
Doi:=Hexa[i1 Shr 4]+Hexa[i1 And $0F];
End;
Begin {Main}
TextBackGround(3);
clrscr;
Cursor(1);
Khungdon(2,2,79,24,15);TextC(14,9); Writexy(35,2,' TABLE ASCII ');
TextC(1,15);
WriteXY(50,3,'Wroten By TRAN THONG QUE'); TextC(4,3);
Window(2,4,79,24);
x:=1; y:=1;
While (x<=72) Do
Begin
Khungdon(x+2,y,x+8,y+2,15);
Khungdon(x+2,y+2,x+8,y+19,15);
x:=x+6;
End;
i:=3;
While (i<=79) Do
Begin
GotoXY(i,3); Write(#197);
i:=i+6;
End;
WriteXY(3,3,'C'); WriteXY(75,3,'D');
i:=9;
While (i<=79) Do
Begin
WriteXY(i,1,'B');
i:=i+6;
End;
WriteXY(75,1,'Y');
i:=9;
While (i<=79) Do
Begin
WriteXY(i,20,'A');
i:=i+6;
End;
WriteXY(75,20,'Y');
TextC(1,3); x:=5;
For i:=1 to 4 Do Begin WriteXY(x,2,'Deci'); x:=x+18; End; x:=11;
For i:=1 to 4 Do Begin WriteXY(x,2,'Hexa'); x:=x+18; End; x:=17;
For i:=1 to 4 Do Begin WriteXY(x,2,'Char'); x:=x+18; End;
Repeat
m:=64; n:=16;
Window(4,4,76,24);
y:=2; i:=4; j:=1; e:=4;
Repeat
8 h 54 m 28/7/2017
110
Thầy Trần Thông Quế
While (i<=m) And (j<=n) Do
Begin
TextC(e,3); WriteXY(15,10,' ');
WriteXY(15,11,' '); WriteXY(15,13,' ');
WriteXY(15,16,' ');
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
If (j<>7) Then
Begin
GotoXY(y+12,i); Write(chr(j):3);
End;
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Until n=80;
SetWin;
WriteXY(40,24,'PgDn->Continue; Other Key->Quit.');
ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
m:=128; n:=80;
Window(4,4,76,24);
y:=2;i:=4; j:=65; e:=4;
Repeat
While (i<=m) And(j<=n) Do
Begin
TextC(e,3);
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
GotoXY(y+12,i); Write(chr(j):3);
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Until n=144;
Setwin;
Write(40,24,'PgDn->Continue; Other key->Quit.'); ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
m:=192; n:=144;
Window(4,4,76,24);
y:=2; i:=4; j:=129; e:=4;
Repeat
While (i<=m) And (j<=n) do
Begin
TextC(e,3);
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
GotoXY(y+12,i); Write(chr(j):3);
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
8 h 54 m 28/7/2017
111
Thầy Trần Thông Quế
Until n=208;
Setwin;
Write(40,24,'PgDn->Continue; Other key->Quit.'); ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
m:=256; n:=208;
Window(4,4,76,24);
y:=2; i:=4; j:=193; e:=4;
Repeat
While (i<=m) And (j<=n) Do
Begin
TextC(e,3);
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
GotoXY(y+12,i); Write(chr(j):3);
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Until n=272;
Setwin;
Write(40,24,'PgDn->Continue; Other key->Quit.'); ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
Until ch=#27;
Setwin;
1:TextC(15,0); Clrscr;
End.
**6/Tạo trò chơi bắn vịt trời đang bay. Gõ ký tự “d” bắn; Gõ , : di chuyển “súng”; Gõ: Esc: ra.
**7/ Tạo “Kính vạn hoa”. Yêu cầu: Gõ ESC: Thoát; Gõ phím bất kỳ: Tiếp tục.
PROGRAM VANHOA;
USES crt,graph;
const
dong=1; lim=3;
TYPE
BASEARRAY=ARRAY[1..100] OF real;
Var
ordrePoly,khoang:integer;
number:byte;
f1,f2,f3,f4:integer;
c1,c2,c3,c4:integer;
GraphDriver,graphMode:integer;
xp1,yp1,xp2,yp2:real;
xtl,ytl:real;
MaxX,MaxY:integer;
XgFen,xdFen,YbFen,YhFen:real;
XgClot,XdClot,YbClot,YhClot:integer;
mangX,mangY:basearray;
i:integer;
8 h 54 m 28/7/2017
112
Thầy Trần Thông Quế
Sotg,kc,lap:byte;
ch:char;k:integer;
PROCEDURE KTDOHOA;
VAR
errorCode:integer;
somau:byte;
Begin
graphDriver:=detect;
initgraph(graphdriver,graphMode,'D:\bp\bgi');
ErrorCode:=graphResult;
If errorCode<> grOK then
begin
writeln('LOI DO HOA ',graphErrorMsg(ErrorCode));
halt(1);
end;
MaxX:=getMaxx;
MaxY:=getMaxY;
end;
PROCEDURE CUASO(f1,f2,f3,f4:real);
BEGIN
Xgfen:=f1;
XdFen:=f2;
ybFen:=f3;
yhFen:=f4;
END;
PROCEDURE TAMNHIN(C1,C2,C3,C4:INTEGER);
BEGIN
XgClot:=c1;
XdClot:=c2;
YbClot:=c3;
YhClot:=c4;
Xtl:=(XdClot-XgClot)/(XdFen-XgFen);
Ytl:=(YhClot-YbClot)/(YhFen-YbFen);
Setviewport(xgClot,maxY-YhClot,xdClot,maxY-YbClot,ClipOn);
END;
PROCEDURE CAT(x1,y1,x2,y2:real);
type
muc=(l,r,low,h);
code=set of muc;
Var
c,c1,c2:code;
x,y:real;
xx1,yy1:integer;
xx2,yy2:integer;
8 h 54 m 28/7/2017
113
Thầy Trần Thông Quế
PROCEDURE BINARY(X,Y:REAL;VAR C:CODE);
Begin
c:=[];
If xxdfen then c:=[r];
If yYhFen then c:=c+[h]
End;
BEGIN
binary(x1,y1,c1);
binary(x2,y2,c2);
WHILE (c1<>[] ) or (c2<>[])do
BEGIN
if (c1*c2)<>[] then exit;
if c=[] then c:=c2 else c:=c1;
if l in c then
begin
x:=xgFen;
y:=y1+(y2-y1)*(xgFen-x1)/(x2-x1)
end
else if r in c then
begin
x:=xdFen;
y:=y1+(y2-y1)*(xdFen-x1)/(x2-x1)
end
else if low in c then
begin
y:=ybFen;
x:=x1+(x2-x1)*(ybFen-y1)/(y2-y1)
end
else if h in c then
begin
y:=yhFen;
x:=x1+(x2-x1)*(yhFen-y1)/(y2-y1)
end;
IF c=c1 then
Begin
x1:=x;
y1:=y;
binary(x,y,c1);
END
Else
Begin
x2:=x;
y2:=y;
binary(x,y,c2);
8 h 54 m 28/7/2017
114
Thầy Trần Thông Quế
End;
END ;
xx1:=round((x1-xgFen)*Xtl);
yy1:=round((yhfen-y1)*Ytl);
xx2:=round((x2-xgFen)*Xtl);
yy2:=round((yhfen-y2)*Ytl);
MoveTo(xx1,yy1);
Lineto(xx2,yy2);
END;
PROCEDURE VETOI(x,y:real);
BEGIN
xp2:=x;
yp2:=y;
cat(xp1,yp1,xp2,yp2);
xp1:=xp2;
yp1:=yp2;
END;
PROCEDURE DATBUT(x,y:real);
BEGIN
xp1:=x;
yp1:=y;
vetoi(x,y);
END;
PROCEDURE NHAPSOLIEU;
Begin
TextBackGround(blue);
ClrScr;
Writeln(' KINH VAN HOA ');
Write(' Cho so Tam giac ' );
Textcolor(white);
Write('( An 0 de thoat ) : ');
readln(Sotg);
If sotg<>0 then
Begin
writeln;
write(' Cho so khoang chia : ');
readln(kc);
writeln;
write(' Cho so lan Lap : ');
readln(Lap);
end;
END;
PROCEDURE DAGIAC(MANGX,MANGY:BASEARRAY;LIM:INTEGER;MODE:
INTEGER);
Var
8 h 54 m 28/7/2017
115
Thầy Trần Thông Quế
i:integer;
Begin
datbut(mangx[1],mangy[1]);
For i:=2 to lim do vetoi(mangx[i],mangy[i]);
If mode=dong then vetoi(mangx[1],mangy[1]);
End;
PROCEDURE VEDAGIAC(MANGX,MANGY:BASEARRAY;LIM:INTEGER;MODE:
INTEGER;color:byte);
Begin
setcolor(color);
dagiac(MANGx,mangy,lim,mode);
End;
PROCEDURE VE(SoTg,kc,lap:byte);
Var
angle,hs:real;
i,j,sogoc:byte;
tg:byte;
Begin
hs:=2*pi/Sotg;
For Sogoc:=1 to sotg do
Begin
mangx[1]:=0;mangy[1]:=0;
angle:=(sogoc-1)*hs;
mangx[2]:=cos(angle);
mangy[2]:=sin(angle);
angle:=Sogoc*hs;
mangx[3]:=cos(angle);
mangy[3]:=sin(angle);
mangx[4]:=0;mangy[4]:=0;
For i:=1 to lap do
Begin
Vedagiac(mangx,mangy,lim,dong,white);
If odd(sogoc) then
Begin
For j:=lim+1 downto 2 do
Begin
mangx[j]:=mangx[j]+(mangx[j-1]-mangx[j])/kc;
mangy[j]:=mangy[j]+(mangy[j-1]-mangy[j])/kc;
End;
Mangx[1]:= Mangx[lim+1];
Mangy[1]:=Mangy[lim+1];
End
Else
Begin
For j:=1 to lim do
Begin
8 h 54 m 28/7/2017
116
Thầy Trần Thông Quế
mangx[j]:=mangx[j]+(mangx[j+1]-mangx[j])/kc;
mangy[j]:=mangy[j]+(mangy[j+1]-mangy[j])/kc;
End;
Mangx[lim+1]:= Mangx[1];
Mangy[lim+1]:=Mangy[1];
End;
end;{cua lap}
end;{for ngoai cung}
End;{cua ve}
(**************************************************************)
BEGIN
nhapSolieu;
Repeat
ktdohoa;
CuaSo(-1,1 ,-1,1);
TamNhin(160,maxx-160,75,maxy-75);
Ve(sotg,kc,lap);
TamNhin(0,maxx,0,maxy);
rectangle(1,1,maxx-1,maxy-1);
rectangle(5,5,maxx-5,maxy-5);
setcolor(yellow);
settextjustify(1,1);
settextstyle(1,0,4);
outtextxy(maxx div 2,20,' VE KINH VAN HOA ');
outtextxy(maxx div 2,45,' ************************ ');
settextstyle(1,0,1);
setcolor(lightblue);
outtextxy(maxx div 2,maxy-20,' Go ESC de thoat, Go phim BAT KY de tiep tuc !');
settextstyle(2,1,8);
outtextxy(20,maxy div 2,'Thay: TRAN THONG QUE');
outtextxy(maxx-24,maxy div 2,'COPYRIGHT (C) 1994');
repeat until KeyPressed;
ch:=readkey;
if ch=#27 then
begin
cleardevice;
closegraph;
halt;
end;
closeGraph;
nhapsolieu;
Until ( Sotg=0);
END.
CÁC BÀI 7, 8, 10, 11 RẤT KHÓ CẢ VỀ MẶT THUẬT TOÁN VÀ CẢ VỀ KỸ NĂNG LẬP TRÌNH!!!
8 h 54 m 28/7/2017
117
Thầy Trần Thông Quế
**7/ Tạo đồng hồ có 3 kim+tiếng tích tắc kêu theo nhịp chạy của kim giây.
Và thêm các yêu cầu sau:
a- Dòng trên cùng phía phải màn hình có dòng chũ: “Gõ phím bất kỳ để
đổi màu đồng hồ và nền màn hình.
b- Dòng cuối cùng phía trái màn hình hiện thời gian hiện hành.
c- Dòng cuối cùng phía phải màn hình hiện ngày tháng năm hiện thời.
d- Kim giờ và kim phút có dạng hình tứ giác. (giả hình thoi- Quasi Lozenge)
program Draw_Clock;
uses crt,GRAPH,dos;
const
color:array[0..15] of byte=(8,7,3,15,6,14,10,4,2,9,1,12,5,0,13,11);
var
m,co:byte;
col:set of 0..15;
r,xt,yt:word;
e:char;
st:string[10];st1,st2,st3:string[4];
{--------------------------------------------------------------}
procedure init;
var gd,gm:integer;
begin
gd:=0;
initgraph(gd,gm,'..\bgi');
if graphresult<>0 then halt;m:=1;e:=#2;
end;
{--------------------------------------------------------------}
procedure draw_frame;
const
number:array[1..12] of
string[2]=('1','2','3','4','5','6','7','8','9','10','11','12');
dayofweek:array[0..6]of string[3]=('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
var
i,x,y,year,month,day,day_of_week:word;
begin
xt:=getmaxx div 2;yt:=getmaxy div 2;
r:=yt-10;
settextjustify(1,1);
{ve duong vien ngoai cung:}
setcolor(color[13]);
setlinestyle(0,0,3);
rectangle(1,1,getmaxx,getmaxy);
rectangle(3,3,getmaxx-2,getmaxy-2);
{ve duong tron bao dong ho:}
for i:= 0 to 6 do circle(xt,yt,r+3-i);
{to mau nau khoang trong:}
8 h 54 m 28/7/2017
118
Thầy Trần Thông Quế
m:=(m mod 2)+1;
if odd(m) then co:=1 else co:=1+(color[13] mod 11);
setfillstyle(co,color[4]);
floodfill(xt+r-20,yt+r-20,color[13]);
setfillstyle(1,color[3]);
floodfill(xt,yt,color[13]);
setcolor(color[1]);
setlinestyle(0,0,3);
rectangle(1,1,getmaxx,getmaxy);
rectangle(3,3,getmaxx-2,getmaxy-2);
setfillstyle(1,color[1]);
bar(0,getmaxy-15,getmaxx,getmaxy);
setfillstyle(solidfill,color[13]);
bar(80,getmaxy-15,getmaxx-80,getmaxy);
{hien ngay thang nam o dong duoi cung phai man hinh:}
setfillstyle(solidfill,color[8]);
bar(8,getmaxy-50,170,getmaxy-20);
bar(getmaxx-170,getmaxy-50,getmaxx-8,getmaxy-20);
setfillstyle(1,color[11]);
bar(getmaxx-150,60,getmaxx-10,70);
getdate(year,month,day,day_of_week);
str(day,st1);
str(month,st2);
str(year,st3);
if day<10 then st1:='0'+st1;
if month<10 then st2:='0'+st2;
{settextstyle(4,0,6);
setcolor(color[5]);
outtextxy(getmaxx-80,25,st3);
settextstyle(4,0,4);
setcolor(color[6]);
outtextxy(120,20,' Happy New Year !'); }
settextstyle(0,0,2);
setcolor(color[7]);
for i:=0 to 1 do outtextxy(40+30*i,60,chr(i+3));
setcolor(color[15]);
for i:=2 to 3 do outtextxy(40+30*i,60,chr(i+3));
st:=' ';st:=dayofweek[day_of_week]+','+st1+'.'+st2;
settextstyle(0,0,2);
setcolor(color[9]);
outtextxy(getmaxx-90,getmaxy-35,st);
settextstyle(2,0,1);
setusercharsize(2,3,1,1);
setcolor(color[10]);
outtextxy(getmaxx-80,63,' * Press any key to change color...');
{trang tri ben trong dong ho:}
settextstyle(0,0,1);
setcolor(color[11]);
for i:=1 to 60 do
8 h 54 m 28/7/2017
119
Thầy Trần Thông Quế
begin
x:=xt+round((r-20)*sin(i*pi/30));
y:=yt-round((r-20)*cos(i*pi/30));
if(i mod 5)<>0 then outtextxy(x,y,chr(1))
end;
settextstyle(0,0,2);
for i:=1 to 12 do
begin
x:=xt+round((r-50)*sin(i*pi/6));
y:=yt-round((r-50)*cos(i*pi/6));
setcolor(color[12]);
outtextxy(x,y,number[i]);
x:=xt+round((r-20)*sin(i*pi/6));
y:=yt-round((r-20)*cos(i*pi/6));
setcolor(color[10]);
outtextxy(x,y,chr(2)); {chr(2)=" "}
end;
{setcolor(color[14]);
outtextxy(xt,yt+100,' CHA DE PASCAL! ');
outtextxy(xt,yt-100,'');
outtextxy(xt,yt-105,' NIKLAUS WIRTH '); }
setcolor(color[2]);
settextstyle(0,0,3);
outtextxy(xt,yt,chr(3)); {chr(3):hinh trai tim}
end;
{------------------------------------------------------}
procedure draw_index(r:word;goc:real;color:byte);
var
x,y,a,b,c:real;
d:array[1..5]of pointtype; {toa do 4 dinh tu giac}
begin
{if goc>=2*pi then goc:=goc-2*pi;}
x:=xt+r*sin(goc);
y:=yt-r*cos(goc);
setcolor(color);
if r>yt-35 then
begin {kim giay}
setlinestyle(0,0,2);
line( xt,yt,round(x),round(y));
setlinestyle(0,0,3);
line(xt,yt,round(xt-r/5*sin(goc)),round(yt+r/5*cos(goc)));
end
else
begin
{ve kim gio hoac kim phut duoi dang hinh tu giac co 4 dinh
toa do 4 dinh chua trong mang d:}
8 h 54 m 28/7/2017
120
Thầy Trần Thông Quế
d[1].x:=xt;d[1].y:=yt;
a:=(4*xt+x)/5;b:=(4*yt+y)/5;c:=(x-xt)/(yt-y+0.000001);
d[2].x:=round(a-sqrt((100+(r mod (yt-40)))/(1+sqr(c))));
d[2].y:=round(b+c*((a-sqrt((100+(r mod (yt-40)))/(1+sqr(c))))-a));
d[3].x:=round(x);
d[3].y:=round(y);
d[4].x:=round(a+sqrt((100+(r mod (yt-40)))/(1+sqr(c))));
d[4].y:=round(b+c*((a+sqrt((100+(r mod (yt-40)))/(1+sqr(c))))-a));
d[5].x:=xt;
d[5].y:=yt;
drawpoly(5,d); {ve hinh tu giac}
end;
end;
{-------------------------------------------------------}
procedure run;
const
a:array[1..2] of string=('SEE YOU GAIN','!');
var
h,m,s,se,ok:word;
goch,gocm,gocs,g:real;
i,j,k:integer;
nb:boolean;
{------------------------------------------------------}
procedure tinhgoc;
begin
goch:=pi*((h mod 12)/6+m/360+s/4320);
gocm:=pi*(m/30+s/1800);
gocs:=pi*s/30;
if (s=59)and odd(m) then e:='a';
ok:=s;
end;
{-----------------------------------------------------}
procedure draw;
begin
draw_index(r-80,goch,color[11]);
draw_index(r-30,gocm,color[12]);
draw_index(r-20,gocs,color[14]);
end;
{phan phu}
{-----------------------------------------------------}
procedure change;
begin
i:=(i mod k)+1;if i=1 then j:=(j mod 4)+1;
case j of
1:k:=179;
2:k:=186;
3:k:=191;
4:k:=196
end;
8 h 54 m 28/7/2017
121
Thầy Trần Thông Quế
end; {het phan phu}
Begin
setwritemode(xorput);
gettime(h,m,s,se);
tinhgoc;
draw;
{hien gio o dong duoi cung ben trai man hinh:}
str(h,st1);
str(m,st2);
str(s,st3);st:=' ';
if m<10 then st2:='0'+st2;
if s<10 then st3:='0'+st3;
st:=' ';
st:=st1+':'+st2+':'+st3;
settextstyle(0,0,2);
setcolor(color[9]);
outtextxy(90,getmaxy-35,st);
i:=0;
j:=0;
k:=179;
nb:=false;
repeat
gettime(h,m,s,se);
if ok<>s then
begin
if((m=59)and(s>(58-h)))or((m=29)and(s=59))then nb:=true;
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
settextstyle(0,0,2);
setcolor(color[8]);
outtextxy(90,getmaxy-35,st);
draw;tinhgoc;
{phan phu:co the bo di:}
if (s mod 5)=0 then
begin
if gocs>=2*pi then gocs:=gocs-2*pi;setfillstyle(solidfill,color[2]);
floodfill(round(xt+(r-20)*sin(gocs)),round(yt-(r-20)*cos(gocs)),color[10]);
end;
if ((s-1) mod 5)=0 then
begin
g:=pi*(s-1)/30;
if g>=2*pi then g:=g-2*pi;setfillstyle(solidfill,color[3]);
floodfill(round(xt+(r-20)*sin(g)),round(yt-(r-20)*cos(g)),color[10]);
end;
{het phan phu}
draw;
str(h,st1);str(m,st2);str(s,st3);st:=' ';
if m<10 then st2:='0'+st2;if s<10 then st3:='0'+st3;
8 h 54 m 28/7/2017
122
Thầy Trần Thông Quế
Begin
st:=' ';
st:=st1+':'+st2+':'+st3;
settextstyle(0,0,2);
setcolor(color[9]);
outtextxy(90,getmaxy-35,st);
settextstyle(0,0,1);
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
if nb then
begin
sound(2700);
delay(1000);
nosound;
delay(1000);
sound(2700);
delay(1000);
nosound;
end
else
sound(2700);
delay(750);
nosound;
delay(750);
End;
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
if nb then
Begin delay(750);
sound(2700);
delay(100);
nosound;
delay(750);
End
else
delay(1000);
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
if nb then
Begin
8 h 54 m 28/7/2017
123
Thầy Trần Thông Quế
nosound;
delay(80);
Begin sound(2700);
delay(1000);
nosound;
delay(1000);
sound(2700);delay(120);
End
else
End;
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
Outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
delay(200);
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
delay(150);nb:=false;
end; while keypressed do e:=readkey;
until e<>#2;
if e<>#27 then e:=#2;
End;
{------------------------------------------------------}
procedure set_color;
var i:byte;
begin
randomize;
col:=[];
for i:=0 to 15 do
begin
repeat
color[i]:=random(16);
if (i>=11) and (i<=14) then
if (color[i]=0) and not(0 in col) then color[i]:=color[i-1];
until not(color[i] in col);
col:=col+[color[i]]
end;
end;
{------------------------------------------------------}
procedure maker;
begin
clrscr;
gotoxy(30,17); TEXTCOLOR(YELLOW);
write('Press any key to continue...');
window(20,10,60,15);
8 h 54 m 28/7/2017
124
Thầy Trần Thông Quế
textbackground(lightgray);
clrscr;
textcolor(blue);
writeln;
writeln(' THAY TRAN-THONG-QUE ');
writeln;
writeln(' * * * * * * * * * ');
textcolor(lightgray);
e:=readkey;
end;
begin
maker;
init;
repeat
graphdefaults;
cleardevice;
draw_frame;
run;
set_color;
until e=#27;
closegraph;
end.
**8/ Đồ họa hóa bài toán Tháp Hà Nội (Hanoi Tower Problem): Chuyển n đĩa (chỉ nên test với n=3 or n=4)
có lỗ ở giữa từ cọc 1 sang cọc 2 được dùng cọc trung gian. Luật chơi:
a- Mỗi lần chỉ chuyển 1 đĩa,
b- Trong lúc chuyển không được đặt đĩa (nghỉ) trên bất cứ chỗ nào (mặt bàn, ghế, sàn nhà…),
c- Đĩa to nằm trên đĩa bé.
Uses Crt,Graph;
Type coc=1..3;
Const n=3; yorg=20;xorg:Array[coc] of integer=(13,40,67);
time=5000; time2=4000;
Var dk:Array[1..n,coc] of Integer;
docao:Array[coc] of integer;
i:integer;
Procedure tre(T:integer);
Begin
GotoXY(43,4);
Delay(T);
End;
Procedure MoveUp(c1,c2:Integer);
Var i,j,x:Integer;
Begin
For j:=1 to 4 Do
Begin
8 h 54 m 28/7/2017
125
Thầy Trần Thông Quế
X:=xorg[c1]-dk[docao[c1],c1];
GotoXY(X,YORG-n-j-1);
For i:=1 to 2*dk[docao[c1],c1]+1 do Write(#219);
tre(time);
GotoXY(X,Yorg-n-j-1);
For i:=1 to 2*dk[docao[c1],c1]+1 do Write(#32);
tre(time);
End;
End;
Procedure MoveDown(c1,c2:integer);
Var i,j,x:Integer;
Begin
For j:=4 Downto 1 Do
Begin
x:=XORG[c2]-DK[docao[c1],c1];
GotoXY(X,YORG-n-j-1);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#219);
tre(time);
GotoXY(X,YORG-n-j-1);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#32);
tre(time);
End;
End;
Procedure MoveRight(c1,c2:integer);
Var i,j,x,xx:integer;
Begin
x:=XORG[c1];
While x<=XORG[c2] Do
Begin
xx:=XORG[c1]-DK[docao[c1],c1]+x-XORG[c1];
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#219);
tre(time2);
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#32);
tre(time2);
X:=X+2;
End;
End;
Procedure MoveLeft(c1,c2:Integer);
Var i,j,x,xx:integer;
Begin
x:=XORG[c1];
While x>=XORG[c2] Do
Begin
8 h 54 m 28/7/2017
126
Thầy Trần Thông Quế
xx:=XORG[c1]-DK[docao[c1],c1]+x-XORG[c1];
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#219);
tre(time2);
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#32);
tre(time2);
X:=X-2;
End;
End;
Procedure Move(n,c1,c2,c3:integer);
Var x:integer;
Begin
If n=1 Then
Begin
x:=XORG[c1]-Dk[docao[c1],c1];
GotoXY(x,YORG-docao[c1]+1);
For i:=1 to 2*DK[docao[c1],c1]+1 do
Begin
If docao[c1]=1 Then
Begin
Write('-');
If i=DK[docao[c1],c1] Then Write(#193);
End
Else Write(#32);
End;
GotoXY(XORG[c1],YORG - docao[c1]+1);
Write(#179); tre(time);
MoveUp(c1,c2);
If c2>c1 then MoveRight(c1,c2)
Else MoveLeft(c1,c2);
MoveDown(c1,c2);
docao[c2]:=docao[c2]+1;
DK[docao[c2],c2]:=DK[docao[c1],c1];
Dk[docao[c1],c1]:=0;
docao[c1]:=docao[c1]-1;
x:=XORG[c2]-DK[docao[c2],c2];
GotoXY(x,YORG-docao[c2]+1);
For i:=1 to 2*DK[docao[c2],c2]+1 do Write(#219);
Delay(200);
End
Else
Begin
Move(n-1,c1,c3,c2);
Move(1,c1,c2,c3);
Move(n-1,c3,c2,c1);
End;
End;
{Main prog.}
8 h 54 m 28/7/2017
127
Thầy Trần Thông Quế
Begin Clrscr;
GotoXY(35,4); Write('BAI TOAN THAP HA NOI.');
GotoXY(4,YORG-n+4);
GotoXY(XORG[1],YORG-n); Write(#179);
GotoXY(XORG[1]-1,YORG-n+1); Write(#219#219#219);
GotoXY(XORG[1]-2,YORG-n+2); Write(#219#219#219#219#219);
GotoXY(XORG[1]-3,YORG-n+3); Write(#219#219#219#219#219#219#219);
GotoXY(XORG[1]-4,YORG-n+4); Write(#219#219#219#219#219#219#219#219#219);
For i:=0 to n Do
Begin
GotoXY(XORG[2],YORG-n+I);
Write(#179);
End;
For I:=0 to n do
Begin
GotoXY(XORG[3],YORG-n+I);
Write(#179);
End;
docao[1]:=n; docao[2]:=0; docao[3]:=0;
For I:=1 to n do DK[I,1]:=n-I+1;
For I:=1 to n do DK[I,2]:=0;
For I:=1 to n do DK[I,3]:=0;
GotoXY(22,24); Write('Press Ctrl_C to Stop.');
GotoXY(43,4);
Repeat
Delay(500); Move(n,1,2,3);
Delay(500); Move(n,2,3,1);
Delay(500); Move(n,3,1,2);
Until KeyPressed;
End.
*9/ (MỘT TRONG SỐ CÁC ĐỀ OLYMPIC TIN HỌC CỦA HỌC SINH THCS 4/1994)
Vẽ hai đường tròn. Xét các vị trí tương quan giữa chúng. Và tính diện tích phần mặt phẳng giới hạn bởi 2
đường tròn khi chúng ở trong nhau hoặc tiếp súc trong với nhau. Hiển thị các kết qủa tính diện tích.
BẢNG TEST
CÁC TEST Vị trí tương quan giữa hai vòng tròn Tọa độ tâm & bán kính vòng tròn
R
Y
X
Hai vòng tròn rời nhau
Hai vòng tròn cắt nhau
Hai vòng tròn tiếp xúc ngoài Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2 200
50
200
270
200
350 200
50
200
130
200
200 100
30
100
40
100
50
8 h 54 m 28/7/2017
128
Thầy Trần Thông Quế
Hai vòng tròn trùng khít nhau
100
100
100 Vòng tròn tròn bé nằm trọn trong vòng
60 tròn to. Dt còn lại của vòng to=2016
100 Vòng tròn bé đồng tâm với vòng tròn to
80 Dt còn lại của vòng to=11310
100 Vòng tròn bé tiếp xúc trong phải với
vòng tròn to. Dt còn lại . . . =23562
50
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2 200
200
200
220
200
200
200
250
200
200 200
200
200
220
200
200
200
200
200
170 100 Vòng tròn bé tiếp xúc trong phía trên với
Vòng tròn to. Dt còn lại . . .=16022
70
Uses Crt, graph;
Const maxx=639; maxy=449;
Var x1,x2,y1,y2,r1,r2:Integer;
Procedure Khung(x1,x2,y1,y2:Integer);
Var i,j: Integer;
Begin
TextBackGround(Blue); TextColor(LightGray);
Gotoxy(x1,y1); Write(#218);
For i:=x1+1 to x2-1 do Write(#196);
Write(#191);
For j:=y1+1 to y2-1 do
Begin
Gotoxy(x1,j); Write(#179);
For i:=x1+1 to x2-1 do Write(' ');
Write(#179);
End;
Gotoxy(x1,y2); Write(#192);
For i:=x1+1 to x2-1 do Write(#196);
Write(#217);
End;
Function Doc(min,max:Integer):Integer;
Var n:Integer; {min0) Or (n<=min) Or (n>=max) Then
8 h 54 m 28/7/2017
129
Thầy Trần Thông Quế
Begin
Sound(1200);
Delay(100);
Nosound;
End;
Until (IoResult=0) And (n>min) And (nGrOk then
Begin
Gotoxy(11,11);
Sound(1200); Delay(100); Nosound;
8 h 54 m 28/7/2017
130
Thầy Trần Thông Quế
Writeln('Khong khoi dong duoc do hoa.');
Run:=False; Exit;
End;
SetBkColor(Blue); SetColor(LightRed);
SetFillStyle(1,LightGray);
Bar(1,1,maxx-1,maxy-1);
Rectangle(0,0,maxx,maxy);
SetColor(Yellow);
Circle(x1,y1,r1); Circle(x2,y2,r2);
i:=Sqrt((Longint(x1)-x2)*(x1-x2)+(Longint(y1)-y2)*(y1-y2));
If (x1=y1) And (x2=y2) And (r1=r2) Then
Begin
SetColor(White);
OutTextxy(10,450,'Hai vong tron trung khit nhau.')
End
Else If(r1>=r2+i) Then
Begin
SetColor(White);
OutTextxy(10,450,'Vong tron 2 nam trong vong tron 1.');
Str(Pi*(Longint(r1)*r1-Longint(r2)*r2):0:2,s);
OutTextxy(10,460,'Dien tich phan trong la:');
SetColor(LightRed); OutTextxy(10+26*8,460,s);
SetFillStyle(3,LightGray);
If x2+r2=x1+r1 Then FloodFill(x1,y1-r1+1,Yellow)
Else FloodFill(x1,y1+r1-1,Yellow)
End
Else If(r2>=r1+i) Then
Begin
SetColor(White);
OutTextxy(10,450,'Vong tron 1 nam trong vong tron 2.');
Str(Pi*(Longint(r2)*r2-Longint(r1)*r1):0:2,s);
OutTextxy(10,460,'Dien tich phan trong la:');
SetColor(LightRed); OutTextxy(10+26*8,460,s);
SetFillStyle(3,LightGray);
If y1+r1=y2+r2 Then FloodFill(x2,y2-r2+1,Yellow)
Else FloodFill(x2,y2+r2-1,Yellow);
End;
SetColor(LightGray);
OutTextxy(10,470,'Nhan Rnter -> Stop.');
Sound(1500); Delay(100); Nosound;
Repeat ch:=Readkey Until ch=#13;
CloseGraph;
Run:=True;
End;
Function Done:Boolean;
Var ch:char;
Begin
Khung(20,15,60,17); Window(21,16,59,16);
8 h 54 m 28/7/2017
131
Thầy Trần Thông Quế
TextColor(LightGray);
Write('More (y/n)?');
Repeat ch:=Readkey Until ch In ['y','Y','n','N'];
TextColor(LightRed);
Write(ch);
Window(1,1,80,25);
If ch In ['n','N'] Then Done:=true
Else Done:=False;
End;
Begin
Repeat
Init;
If not Run then Halt;
Until Done;
End.
**10- (TÌM 1 LỜI GIẢI CHO BÀI TOÁN 8 HẬU TRÊN BÀN CỜ VUA 8X8). Tìm MỘT nghiệm cho bài
toán: Đặt 8 hậu trên bàn cờ vua 8x8 sao cho không con nào ăn được con nào.
Program Tim_Mot_Loi_Giai_Cho_Bai_8_Hau;
Uses crt,graph;
Const dl=200;
Var
p:pointer;
found:boolean;
a:array[1..8] of boolean;
b:array[2..16] of boolean;
c:array[-7..7]of boolean;
h:array[1..8] of Integer;
Procedure Initgr;
Var gd,gm:integer;
Begin
gd:=detect;
initgraph(gd,gm,'..\bgi');
if graphresult<>grok then
begin
write('Loi Do Hoa ! Go Enter Ket Thuc');
readln;
halt(1)
end
End;
Procedure Demo;
Begin
settextstyle(1,0,3);
setbkcolor(green);
setcolor(blue);
8 h 54 m 28/7/2017
132
Thầy Trần Thông Quế
outtextxy(425,30,'Tim Mot Loi Giai');
settextstyle(1,0,4);
setcolor(white);
outtextxy(425,90,'Cho Bai Toan');
setcolor(red);
settextstyle(4,0,7);
outtextxy(440,160,'8 Hau');
setcolor(blue);
settextstyle(1,0,3);
outtextxy(440,410,'Ha Noi - 2005');
setcolor(white);
settextstyle(3,0,1);
outtextxy(425,440,' Thay Tran-Hong-Que');
End;
Procedure Draw(i,j:integer);
Begin
if (i+j)mod 2=0 then
begin
setfillstyle(1,7);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end
else
begin
setfillstyle(1,white);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end;
End;
Procedure Draw_Queen(i,j:integer);
Var size:integer;
Begin
setfillstyle(1,3);
setcolor(red);
bar(i,j,i+50,j+55);
ellipse(i+25,j+35,0,360,10,5);
line(i+25-10,j+35,i+25-20,j+35-20);
line(i+25+10,j+35,i+25+20,j+35-20);
line(i+25-10-10,j+35-20,i+25+20,j+35-20);
circle(i+25-10-10+5,j+35-20-3,3);
circle(i+25-10-10+5+10,j+35-20-3,3);
circle(i+25-10-10+5+20,j+35-20-3,3);
circle(i+25-10-10+5+30,j+35-20-3,3);
setfillstyle(1,4);
floodfill(i+25,j+35-10,4);
setfillstyle(1,8);
floodfill(i+25-10-10+5,j+35-20-3,4);
floodfill(i+25-10-10+5+10,j+35-20-3,4);
floodfill(i+25-10-10+5+10+10,j+35-20-3,4);
8 h 54 m 28/7/2017
133
Thầy Trần Thông Quế
floodfill(i+25-10-10+5+10+10+10,j+35-20-3,4);
size:=Imagesize(i+1,j+1,i+51,j+51);
getmem(p,size);
getimage(i+2,j+2,i+50-2,j+50-2,p^);
End;
Procedure Put_Queen(i,j:integer);
Begin
Putimage(i+2,j+2,P^,Xorput);
End;
Procedure Table;
Var m,n:integer;
Begin
setviewport(0,0,getmaxx,getmaxy,false);
for m:=1 to 8 do
for n:=1 to 8 do
Draw(m,n);
Demo;
Draw_Queen(10,getmaxy-65);Put_Queen(10,getmaxy-65);
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
End;
Procedure Result;
Var s:string[2];
i:integer;
Begin
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
settextstyle(1,0,3);
setcolor(white);
for i:=1 to 8 do
begin
str(h[i],s);
outtextxy(28+(i-1)*50,getmaxy-50,s);
end;
End;
Procedure Try(i:integer;Var q:boolean);
Var j:integer;
Begin
j:=0;
8 h 54 m 28/7/2017
134
Thầy Trần Thông Quế
repeat
q:=false; inc(j);
if a[j] and b[i+j] and c[i-j] then
begin
h[i]:=j;
Put_Queen((i-1)*50+10,(j-1)*50+10);
sound(150);delay(dl);nosound;
a[j]:=false;b[i+j]:=false;c[i-j]:=false;
if i<8 then
begin
Try(i+1,q);
if not q then
begin
a[j]:=True;b[i+j]:=true;c[i-j]:=true;
Put_Queen((i-1)*50+10,(j-1)*50+10);
sound(350);delay(dl);nosound;
end;
end
else q:=true;
end;
until q or(j=8);
End;
Procedure Search;
Var i:integer;ch:char;
Begin
for i:=1 to 8 do a[i]:=true;
for i:=2 to 16 do b[i]:=true;
for i:=-7 to 7 do c[i]:=true;
Try(1,found);
if found then Result;
setcolor(white);
settextstyle(2,0,7);
outtextxy(430,300,'Go Esc Ket Thuc !');
repeat ch:=readkey until ch=#27;
End;
BEGIN
Initgr;
Table;
Search;
Closegraph;
END.
**11- (TÌM TẤT CẢ CÁC NGHIỆM CÓ THỂ CÓ CỦA BÀI TOÁN ĐẶT 8 HẬU TRÊN BÀN CỜ VUA
8X8). Tìm TẤT CẢ CÁC NGHIỆM có thể cho bài toán “Hậu”: Tìm cách đặt 8 hậu trên bàn cờ vua 8x8 sao
cho không con nào ăn được con nào. Gõ lần lượt một phím bất kỳ để xem từng nghiệm. Gõ ESC để ra.
Program Tim_Tat_Ca_Loi_Giai_Xep_8_Hau;
8 h 54 m 28/7/2017
135
Thầy Trần Thông Quế
Uses crt,graph;
Const Mc:Array [1..210,1..2] of Word =
((1046,24),(1046,12),(1174,12),(1244,24),
(1046,24),(1244,24),(1046,24),(1244,24),
(1174,24),(934,24),(934,12),(1046,12),
(1174,24),(934,24),(1174,24),(934,24),
(1174,24),(1046,24),(880,24),(880,12),
(934,12),(1046,24),(880,24),(1046,24),
(934,24),(880,24),(934,24),(784,96),
(1046,24),(1046,12),(1174,12),(1244,24),
(1046,24),(1244,24),(1046,24),(1244,24),
(1174,24),(934,24),(934,12),(1046,12),
(1174,24),(934,24),(1174,24),(934,24),
(1174,24),(1046,24),(880,24),(880,12),
(934,12),(1046,24),(1244,24),(1174,24),
(742,24),(784,24),(36000,24),(36000,48),
(36000,24),(1174,24),(1174,48),(1046,24),
(1174,24),(784,72),(784,24),(1174,48),
(1398,24),(1244,24),(1174,72),(1046,24),
(1174,48),(934,24),(784,24),(880,72),
(880,24),(934,48),(784,24),(880,24),
(588,72),(1174,24),(1174,48),(1046,24),
(1174,24),(784,72),(588,24),(588,48),
(784,24),(934,24),(880,72),(880,24),
(934,48),(742,24),(880,24),(588,72),
(588,24),(1046,48),(1046,24),(934,24),
(934,96),(36000,48),(36000,24),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
(784,24),(1174,48),(1398,24),(1244,24),
(1174,72),(1046,24),(1174,48),(934,24),
(784,24),(880,72),(880,24),(934,48),
(784,24),(880,24),(588,72),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
(588,24),(588,48),(784,24),(934,24),
(880,72),(880,24),(934,48),(742,24),
(784,24),(880,72),(1046,24),(1046,24),
(1174,24),(742,24),(880,24),(784,96),
(784,48),(880,72),(784,24),(880,48),
(588,24),(588,24),(522,72),(934,24),
(880,48),(588,24),(784,24),(880,72),
(880,24),(1046,48),(1174,24),(1244,24),
(1174,96),(36000,48),(1398,24),(1244,24),
(1174,72),(934,24),(934,48),(1046,24),
(1174,24),(1174,72),(880,24),(934,48),
(784,24),(880,24),(588,48),(36000,48),
(1046,32),(934,32),(880,32),(784,48),
(36000,24),(36000,48),(36000,24),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
8 h 54 m 28/7/2017
136
Thầy Trần Thông Quế
(784,24),(1174,48),(1398,24),(1244,24),
(1174,72),(1046,24),(1174,48),(934,24),
(784,24),(880,72),(880,24),(934,48),
(784,24),(880,24),(588,72),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
(588,24),(588,48),(784,24),(934,24),
(880,72),(880,24));
Var
p:pointer;
t,g:integer;
ch:char;
stop:boolean;
a:array[1..8] of boolean;
b:array[2..16] of boolean;
c:array[-7..7]of boolean;
h:array[1..8] of Integer;
Procedure Initgr;
Var gd,gm:integer;
Begin
gd:=detect;
initgraph(gd,gm,'..\bgi');
if graphresult<>grok then
begin
write('Loi Do Hoa ! Go Enter Ket Thuc');
readln;
halt(1)
end
End;
Procedure Demo;
Begin
settextstyle(1,0,2);
setbkcolor(green);
setcolor(blue);
outtextxy(425,30,'Tim Tat Ca Loi Giai');
settextstyle(1,0,4);
setcolor(white);
outtextxy(425,60,'Cho Bai Toan');
setcolor(red);
settextstyle(4,0,7);
outtextxy(440,100,'8 Hau');
setcolor(Blue);
settextstyle(1,0,3);
outtextxy(440,370,'Ha Noi - 2002');
setcolor(Magenta);
settextstyle(3,0,1);
outtextxy(425,410,' Thay Tran-hong-Que');
setcolor(red);
8 h 54 m 28/7/2017
137
Thầy Trần Thông Quế
outtextxy(425,440,' Hoi Tin hoc Viet nam');
End;
Procedure Draw(i,j:integer);
Begin
if (i+j)mod 2=0 then
begin
setfillstyle(1,7);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end
else
begin
setfillstyle(1,white);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end;
End;
Procedure Draw_Queen(i,j:integer);
Var size:integer;
Begin
setfillstyle(1,3);
setcolor(red);
bar(i,j,i+50,j+55);
ellipse(i+25,j+35,0,360,10,5);
line(i+25-10,j+35,i+25-20,j+35-20);
line(i+25+10,j+35,i+25+20,j+35-20);
line(i+25-10-10,j+35-20,i+25+20,j+35-20);
circle(i+25-10-10+5,j+35-20-3,3);
circle(i+25-10-10+5+10,j+35-20-3,3);
circle(i+25-10-10+5+20,j+35-20-3,3);
circle(i+25-10-10+5+30,j+35-20-3,3);
setfillstyle(1,4);
floodfill(i+25,j+35-10,4);
setfillstyle(1,8);
floodfill(i+25-10-10+5,j+35-20-3,4);
floodfill(i+25-10-10+5+10,j+35-20-3,4);
floodfill(i+25-10-10+5+10+10,j+35-20-3,4);
floodfill(i+25-10-10+5+10+10+10,j+35-20-3,4);
size:=Imagesize(i+1,j+1,i+51,j+51);
getmem(p,size);
getimage(i+2,j+2,i+50-2,j+50-2,p^);
End;
Procedure Put_Queen(i,j:integer);
Begin
Putimage(i+2,j+2,P^,Xorput);
End;
{===============================}
Procedure Table;
8 h 54 m 28/7/2017
138
Thầy Trần Thông Quế
Var m,n:integer;
Begin
setviewport(0,0,getmaxx,getmaxy,false);
for m:=1 to 8 do
for n:=1 to 8 do
Draw(m,n);
Demo;
Draw_Queen(10,getmaxy-65);Put_Queen(10,getmaxy-65);
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
End;
Procedure Result;
Var s:string[2];
i:integer;
Begin
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
settextstyle(1,0,3);
setcolor(white);
for i:=1 to 8 do
begin
str(h[i],s);
outtextxy(28+(i-1)*50,getmaxy-50,s);
end;
End;
Procedure Wait;
Begin
inc(t);
Result;
setcolor(yellow);
settextstyle(2,0,6);
outtextxy(430,200,'Go Phim Esc De Ngung !');
setcolor(white);
settextstyle(2,0,5);
outtextxy(420,230,'Go Phim Bat Ky De Tiep Tuc...');
while keypressed do ch:=readkey;
repeat until keypressed;
ch:=readkey;
if ch=#27 then stop:=true;
End;
8 h 54 m 28/7/2017
139
Thầy Trần Thông Quế
Procedure Music;
Begin
sound(Mc[g][1]);
delay(mc[g][2]*8);{ delay(20000);}
nosound;
if g=210 then g:=1 else inc(g)
End;
Procedure Try(i:integer);
Var j:integer;
Begin
j:=0;
repeat
inc(j);
if a[j] and b[i+j] and c[i-j] then
begin
h[i]:=j;
Put_Queen((i-1)*50+10,(j-1)*50+10);
Music;
a[j]:=false;b[i+j]:=false;c[i-j]:=false;
if i<8 then Try(i+1)
else Wait;
a[j]:=True;b[i+j]:=true;c[i-j]:=true;
Put_Queen((i-1)*50+10,(j-1)*50+10);
Music;
end;
until (j=8) or stop;
End;
Procedure Search;
Var i:integer;
s:string[30];
Begin
t:=0;g:=1;
stop:=false;
for i:=1 to 8 do a[i]:=true;
for i:=2 to 16 do b[i]:=true;
for i:=-7 to 7 do c[i]:=true;
Try(1);
str(t,s);
if stop then
s:='Da Tim Duoc '+s+' Loi Giai'
else
s:='Tong So Co '+s+' Loi Giai';
setcolor(red);
settextstyle(2,0,6);
outtextxy(418,280,s);
setcolor(white);
settextstyle(2,0,7);
8 h 54 m 28/7/2017
140
Thầy Trần Thông Quế
outtextxy(430,310,'Go Esc Ket Thuc !');
repeat ch:=readkey until ch=#27;
End;
BEGIN
Initgr;
Table;
Search;
Closegraph;
END.
= = = = = = = = = = = = = = = = = = = = = =
PHẦN VIII. GRAPH THEORY & APPLICATIONS
VIII.1-TÌM KIẾM TRÊN ĐỒ THỊ (tên khác: DUYỆT ĐỒ THỊ); TÔ
MÀU ĐỒ THỊ; TÌM MIỀN LIÊN THÔNG CỦA ĐT.
(Nếu quên OR lơ mơ về lý thuyết một vấn đề nào đó, các bạn nên đến thư viện – để mất ít tiền nhất- xem
quyển: LÝ THUYÊT ĐỒ THỊ, nxb GIÁO DỤC 2012. Tác giả: Trần Thông Quế)
A/ CÁC THUẬT TOÁN TÌM KIẾM (DUYỆT) TRÊN ĐỒ THỊ.
1-Hãy cài đặt trực quan (đồ họa hóa code) hai thuật toán DBF và BFS trên cùng một bản Code (BÀI CƠ
BẢN NHƯNG KHÔNG DỄ!).
Yêu cầu: * Gõ ENTER để chuyển từ thuật toán DFS sang BFS và ngược lại,
* Gõ ESC để thoát
CODE:
PROGRAM DFS_BFS_SEARCH;
USES CRT,GRAPH;
CONST R=15;DL=500;N=8;VC=100; {KHONG CO DUONG DI THI DAT VO CUC VC=100}
C:ARRAY[1..8] OF INTEGER=(150,330,450,450,330,150,30,30);
D:ARRAY[1..8] OF INTEGER=(30,30,150,330,450,450,330,150);
CL:ARRAY[0..3] OF WORD=(BLUE,YELLOW,WHITE,WHITE);
NL:ARRAY[0..3] OF WORD=(YELLOW,BLUE,RED,BLACK);
TYPE CSD=0..VC;
AR=ARRAY[CSD] OF CSD;
QUEUE=RECORD
REAR:CSD;
ELEMENT:AR;
END;
VAR G:ARRAY[CSD,CSD] OF BOOLEAN;
8 h 54 m 28/7/2017
141
Thầy Trần Thông Quế
I,J,K,U:CSD;
P:AR;
(*-----------------------------------------------------------*)
PROCEDURE INITGR; { KHOI TAO DO HOA}
VAR GD,GM:INTEGER;
BEGIN
GD:=DETECT;
INITGRAPH(GD,GM,'..\BGI');
IF (GRAPHRESULT<> GROK) THEN
BEGIN
WRITELN('LOI KHOI TAO DO HOA, GO ENTER KET THUC !');
READLN;
HALT(1)
END
END;
(*-----------------------------------------------------*)
PROCEDURE ADD(X:CSD;VAR Q:QUEUE); {THEM PHAN TU TU DUOI HANG DOI}
BEGIN
WITH Q DO
BEGIN
REAR:=REAR+1;
ELEMENT[REAR]:=X
END;
END;
(*-----------------------------------------------------*)
PROCEDURE DELETE(VAR Q:QUEUE;VAR X:CSD); {BOT PHAN TU KHOI HANG DOI}
VAR K:CSD;
BEGIN
WITH Q DO
BEGIN
X:=ELEMENT[1];
FOR K:=1 TO REAR-1 DO ELEMENT[K]:=ELEMENT[K+1];
REAR:=REAR-1
END;
END;
(*-----------------------------------------------------*)
PROCEDURE VENUT(U:CSD;M1,M2:WORD); {VE CAC DINH DO THI}
VAR ST:STRING[3];
BEGIN
SETFILLSTYLE(1,M2);
SETCOLOR(M1);
FILLELLIPSE(C[U],D[U],R,R);
STR(U,ST);
OUTTEXTXY(C[U]-2,D[U]-2,ST);
END;
(*-------------------------------*)
8 h 54 m 28/7/2017
142
Thầy Trần Thông Quế
PROCEDURE LINK(X,Y:CSD;M:WORD);
BEGIN
SETCOLOR(M);
LINE(C[X],D[X],C[Y],D[Y]);
END;
(*-------------------------------*)
PROCEDURE DATA_AUTO_CREA; {TU DONG TAO DU LIEU NGAU NHIEN CHO PROG.}
BEGIN
RANDOMIZE;
FOR I:=1 TO N DO
BEGIN
G[I,I]:=FALSE;
FOR J:=I+1 TO N DO
BEGIN
G[I,J]:=RANDOM(3)=1;
G[J,I]:=G[I,J]
END;
END;
FOR I:=1 TO N DO
BEGIN
J:=0;
REPEAT
J:=J+1
UNTIL G[I,J] OR (J=N);
IF (J=N) AND (NOT G[I,N]) THEN
BEGIN
J:=1+RANDOM(N);
IF J=I THEN IF I
8 h 54 m 28/7/2017
143
Thầy Trần Thông Quế
BEGIN
SETBKCOLOR(BLUE);CLEARDEVICE;
SETFILLSTYLE(1,DARKGRAY);
BAR(0,0,GETMAXY,GETMAXY);
FOR I:=1 TO N DO
FOR J:=1 TO N DO IF G[I,J] THEN LINK(I,J,NL[0]);
LINE(C[I],D[I],C[J],D[J]);
FOR I:=1 TO N DO VENUT(I,CL[0],NL[0]);
END;
(*--------------------------------------------------*)
PROCEDURE VE_GR_BFS(U:CSD); {HIEN THI DO THI DE DUYET THEO BE RONG}
VAR Q:QUEUE;
BEGIN
VENUT(U,CL[K],NL[K]);
P[U]:=0;
Q.REAR:=0;
ADD(U,Q);
WHILE Q.REAR<>0 DO
BEGIN
DELETE(Q,I);
FOR J:=1 TO N DO
IF G[I,J] THEN
IF P[J]=VC THEN
BEGIN
P[J]:=I;
LINK(I,J,NL[K]);
VENUT(J,CL[K],NL[K]);
VENUT(I,CL[K],NL[K]);
ADD(J,Q);
DELAY(DL);
END;
END;
END;
(*--------------------------*)
PROCEDURE BFS; {DUYET THEO CHIEU RONG}
BEGIN
FOR U:=1 TO N DO P[U]:=VC;
K:=0;
FOR U:=1 TO N DO IF P[U]=VC THEN
BEGIN
K:=(K+1) MOD 4;
VE_GR_BFS(U);DELAY(DL)
END;
END;
(*--------------------*)
PROCEDURE VE_DT_DFS(U:CSD); {HIEN THI DO THI DE DUYET THEO CHIEU SAU}
8 h 54 m 28/7/2017
144
Thầy Trần Thông Quế
VAR T:CSD;
BEGIN
I:=I+1;
P[U]:=I;
FOR T:=1 TO N DO
IF G[U,T] THEN
IF P[T]=0 THEN
BEGIN
LINK(U,T,NL[K]);
VENUT(U,CL[K],NL[K]);
VENUT(T,CL[K],NL[K]);
DELAY(DL);
VE_DT_DFS(T);
END;
END;
(*-----------------------------*)
PROCEDURE DFS; {DUYET THEO CHIEU SAU}
BEGIN
FOR I:=1 TO N DO P[I]:=0;
I:=0;
FOR U:=1 TO N DO IF P[U]=0 THEN
BEGIN
K:=(K+1) MOD 4;
VENUT(U,CL[K],NL[K]);
VE_DT_DFS(U);DELAY(DL)
END;
END;
(*-----------------------------------*)
PROCEDURE PROC_CALL_PROC; {THU TUC GOI CAC THU TUC DUYET}
VAR KT:CHAR;
BEGIN
IF KEYPRESSED THEN
REPEAT KT:=READKEY UNTIL NOT KEYPRESSED;
REPEAT
DATA_AUTO_CREA;
PRINT_GRAPH;
DEMO('Theo Be Rong');
KT:=READKEY;
IF KT=#27 THEN EXIT;
BFS;
KT:=READKEY;
IF KT=#27 THEN EXIT;
PRINT_GRAPH;
DEMO('Theo Do Sau');
KT:=READKEY;
IF KT=#27 THEN EXIT;
8 h 54 m 28/7/2017
145
Thầy Trần Thông Quế
DFS;
KT:=READKEY;
UNTIL (KT=#27);
END;
(*-----------------------------------*)
BEGIN (* CHUONG TRINH CHINH *)
CLRSCR;
INITGR;
PROC_CALL_PROC;
CLOSEGRAPH;
END.
Thử một bài duy nhất ở mức TRÊN CƠ BẢN về duyệt theo BFS:
2-(IOI-1996: THI OLYMPIC TIN HỌC QUỐC TẾ 1996) Tiếp theo thành tựu khối lập phương kỳ diệu, ông
Rubik phát minh dạng cải biên phẳng của khối này và ông gọi đó là các ô vuông kỳ diệu. Đó là một bảng 8
ô vuông có kích thước như nhau được tô màu khác nhau.
1 2 3 4
8 7 6 5
Các màu tô được ký hiệu bởi 8 số nguyên dương đàu tiên (xem hình ngay trên) viết lần lượt theo chiều kim
đồng hồ, bắt đầu từ ô góc trên cùng trái và kết thúc ở ô góc dưới cùng trái.
Một cấu hình như trên gọi là cấu hình ban đầu. Ta thực hiện 3 phép biến đổi cơ bản ký hiệu là ‘A’, ‘B’, ‘C’
để tác động lên cấu hình của bảng, trong đó:
• ‘A’: Đổi chỗ dòng trên và dòng dưới
• ‘B’: Thực hiện phép hoán vị theo chiều sang phải vòng quanh bảng.
• ‘C’: Quay theo chiều kim đồng hồ 4 ô ở giữa
Mọi cấu hình đều có thể được tác động bởi 3 phép biến đổi cơ bản nói trên. Và tác động của 3 phép biến đổi
cơ bản ấy mô tả bởi hình dưới đây: (Ở MỖI BỘ DATA DƯỚI ĐÂY CÁC SỐ TRÊN CÙNG VÀ DƯỚI
CÙNG LÀ VỊ TRÍ CÁC Ô CỦA BẢNG)
BẢNG 1 1 2 3 4 INDEX của các ô
1 2 3 4
8 7 6 5
8 7 6 5 INDEX của các ô
BẢNG 2
4 1 2 3
6 7 8
5
8 h 54 m 28/7/2017
146
Thầy Trần Thông Quế
BẢNG 3 1 7 2 4
8 6 3 5
Các số ghi ở ngoài bảng chỉ vị trí các ô của bảng. Nếu một ô ở vị trí p chứa số i thì có nghĩa là sau khi làm
phép biến đổi tương ứng, ô vuông mà vị trí trước lúc biến đổi của nó là i sẽ được chuyển đến vị trí p.
a) Hãy viết program tìm dãy các phép biến đổi để đưa cấu hình ban đầu về một cấu hình đích cho trước.
b) Bạn sẽ được thêm 2 điểm nếu số phép biến đổi của bạn không quá 300
* Dữ liệu vào cất trên text file Data.in gồm:
- Một dòng duy nhất chứa 8 số nguyên mô tả cấu hình đích.
* Kết quả ghi lên text file Data.ou:
-Dòng đầu tiên ghi số các phép biến đổi L
- Tại L dòng tiếp theo ghi ký hiệu các phép biến đổi đã nói trên theo TRÌNH TỰ mà program của bạn đã
thực hiện
MỘT VÍ DỤ CỤ THỂ CỦA BÀI TOÁN NÀY CHO DƯỚI ĐÂY
Data.In
2 6 8 4 5 7 3 1
Data.Ou
7
B
C
A
B
C
C
B
Program MagicSquare; {BAI NAY DUYET DO THI THEO BFS)
Uses crt;
Const kt=8; m=40320; fi='Data.In'; fo='Data.Ou';
Type Bd=array[1..kt] of 1..kt; Ht=array[1..kt] of 1..kt;
Const thuan:Array['A'..'C'] Of Bd=((8,7,6,5,4,3,2,1),(4,1,2,3,6,7,8,5),
(1,7,2,4,5,3,6,8)); {Cac b_doi co ban}
nguoc:Array['A'..'C'] of Bd=((8,7,6,5,4,3,2,1),(2,3,4,1,8,5,6,7),
(1,3,6,4,5,7,2,8)); {Nguoc cua b_doi}
dau:Ht=(1,2,3,4,5,6,7,8); {Trang thai ban dau}
Var dic:Ht; {Bien luu trang thai dich}
s:String; {Day cac b_doi dua tr_thai dau den tr_thai dich}
fact:Array[0..kt] of Longint; {mang luu tu 0! den 8!}
last:Array[0..m] of Char; {last[sh(dic)] la ky tu cuoi cung cua day cac}
{b_doi dua trang thai dau ve trang thai dich}
{Neu last[sh(dic)]=' ' thi dich cung rong (tuc dich khong duoc sinh}
Procedure Nhap;
Var tepvao:text; i:word;
Begin
8 h 54 m 28/7/2017
147
Thầy Trần Thông Quế
Assign(tepvao,fi); Reset(tepvao);
For i:=1 to kt Do Read(tepvao,dic[i]);
Close(tepvao);
End; {Het nhap lieu}
Procedure Facto; {Tinh giai thua}
Var i:word;
Begin
fact[1]:=1; fact[0]:=1;
For i:=2 to kt Do
fact[i]:=i*fact[i-1];
End;
Function sh(p:Ht):Word; {ham sh de tinh so hieu cua mot hoan vi bat ky}
Var res, L, i,j:Word;
Begin
res:=0;
For i:=1 to kt Do
Begin
L:=0; {L- so cac phan tu cua p o cac vi tri tu 1->i-1 nhỏ hơn p[i]}
For j:=1 to i-1 Do
If p[j]dic[i] then
Begin
8 h 54 m 28/7/2017
148
Thầy Trần Thông Quế
bang:=false;
exit;
End;
End;
Procedure sinh; {Tao day cac b_doi tu tr_thai dau de dat tr_thai dich}
{last[sh(dic)] la phep b_doi cuoi cung cua day}
Const qs=700; {kich thuoc danh sach}
Var hdoi:Array[0..qs-1] of ht; {Khai bao hang doi chua cac b_doi}
notfound:Boolean;
head, tail, i, rankq:Word;
r, s:Ht; x:Char;
Begin
For i:=0 to m Do last[i]:=' '; {khoi tri}
last[0]:='.';
head:=0; tail:=1;
hdoi[0]:=dau;
notfound:=true;
While notfound Do
Begin
r:=hdoi[head]; Inc(head);
If head=qs Then head:=0;
For x:='A' to 'C' Do
Begin
App(r, x, s);
rankq:=sh(s);
If last[rankq]=' ' Then
Begin
last[rankq]:=x;
If bang(dic,s) Then
Begin
notfound:=false;
break;
End;
hdoi[tail]:=s;
Inc(tail);
If tail=qs Then tail:=0;
End;
End;
End;
End; {ket thuc thu tuc sinh}
Procedure tim; {kien tao cac phep bien doi}
Var rankq:Word; x:Char; p,q:Ht;
Begin
q:=dic; rankq:=sh(q); s:=' ';
While rankq<>0 do
Begin
8 h 54 m 28/7/2017
149
Thầy Trần Thông Quế
x:=last[rankq];
s:=x+s;
bd_nguoc(q,x,p);
q:=p;
rankq:=sh(q);
End;
End;
Procedure Xuat;
Var tepra:text; L,i:word;
Begin
Assign(tepra,fo); rewrite(tepra);
L:=length(s);
Writeln(tepra, L-1);
For i:=1 to L do Writeln(tepra, s[i]);
Close(tepra);
End;
Begin {Main Prog.}
clrscr;
Nhap;
Facto;
Sinh;
Tim;
Xuat;
Writeln('Done!');
readln;
End.
B/ CÁC THUẬT TOÁN TÌM CÁC MIỀN LIÊN THÔNG TRÊN ĐỒ THỊ
B.1) TÌM MIỀN LIÊN THÔNG TRÊN ĐỒ THỊ VÔ HƯỚNG
3- Cài đặt thuật toán tìm & liệt kê các thành phần (miền) liên thông của một đồ thị vô hướng. Biết rằng cấu
trúc của đồ thị vô hướng được biểu diễn bởi danh sách liệt kê cạnh như sau (Ds này lưu trên Text File
LTHG.IN):
13 10
1 2
1 3
2 3
4 5
4 7
5 6
8 9
10 12
11 12
12 13
Kết quả lưu trên file Xuat.kq
CODE: Để đạt được mục tiêu đề bài ta duyệt đồ thị Đệ quy theo DFS
8 h 54 m 28/7/2017
150
Thầy Trần Thông Quế
Program Dem_so_thp_lthong;
uses crt;
const max=50;
fi='lthg.in'; fo='xuat.kq'; {Du lieu vao la Ds liet ke canh!}
type m1=Array[0..max] of integer;
m2=Array[1..max,1..max] of byte;
var a:m2; {ma tran danh sach liet ke canh}
n:integer;
v:m1;
sm:integer; {so mien lien thong}
Procedure Nhap;
var f:text; i,j:integer;
Begin
Assign(f,fi); Reset(f);
Read(f,n);
FillChar(a,sizeof(a),0); {khoi tri cho mang a}
While not seekeof(f) do {tao ma tran luu dinh dau va cuoi cua moi canh}
Begin
Read(f,i);
While not seekeoln(f) do
Begin
Read(f,j);
a[i,j]:=1;
a[j,i]:=1;
End;
Readln(f);
End;
Close(f);
End;
Procedure DFS(i:integer);
Var j:integer;
Begin
For j:=1 to n do
If v[j]=0 then {neu j chua thuoc mien lien thong nao thi}
If a[i,j]=1 then {neu j ke voi i thi }
Begin
v[j]:=sm; {ghi nho dinh j cung mien lth sm voi i}
DFS(j); {duyet tiep do thi theo chieu sau tu dinh j}
End;
End;
Procedure Xuly;
Var s:integer;
Begin
FillChar(v,sizeof(v),0);
sm:=0;
For s:=1 to n do
8 h 54 m 28/7/2017
151
Thầy Trần Thông Quế
If v[s]=0 then
Begin
Inc(sm); {danh so cho mien lth moi}
v[s]:=sm; {s la dinh dau tien phat hien thuoc mien lth moi}
DFS(s); {Duyet dthi tim tat ca cac dinh lth voi s}
End;
End;
Procedure ghikq;
var f:text; i,j:integer;
Begin
Assign(f,fo); Rewrite(f);
Writeln(f,'So mien lien thong la:',sm);
For i:=1 to sm do
Begin
For j:=1 to n do
If v[j]=i then
Write(f,j,' ');
Writeln(f,'<-- Day la cac dinh o mien Lt thu ',i);
End;
close(f);
End;
Procedure Inkq;
var f:text; line:string[50];
Begin
Assign(f,fo); Reset(f);
While not seekeof(f) Do
Begin
Readln(f,line);
Writeln(line);
End;
Close(f);
End;
Begin clrscr;
Nhap;
Xuly;
Ghikq;
Inkq;
Writeln;
Write('Go ENTER de thoat!');
Readln;
End.
8 h 54 m 28/7/2017
152
Thầy Trần Thông Quế
B.2) TÌM MIỀN LIÊN THÔNG MẠNH TRÊN ĐỒ THỊ CÓ HƯỚNG (THỰC
CHẤT LÀ CÀI ĐẶT THUẬT TOÁN TARJAN)
4/ Cài đặt thuật toán tìm & liệt kê các miền liên thông MẠNH của đồ thị có hướng (thuật toán TARJAN).
Biết rằng đồ thị có hướng này được biểu diễn bởi ds cung sau đây (và ds này lưu trên text file
LTH_MANH.IN):
11 15
1 2
1 8
2 3
3 4
4 2
4 5
5 6
6 7
7 5
8 9
9 4
9 10
10 8
10 11
11 9
Kết quả lưu trên file LTH_MAMH.OU
CODE: (Về duyệt đồ thị, bài này cũng dùng DFS)
Program Tarjan_Alg;
Uses crt;
Const fi='LTH_MANH.IN'; fo='LTH_MANH.OU';
Type lk=^nut;
nut=record
s:word;
next:lk;
End;
cay=array[0..200] of lk;
m1=array[0..200] of word;
Var sv,id,m,n,top:word; {m:so dinh; n:so canh}
Num,Low,p,s:m1; dsk:cay;
f:Text;
Procedure Nhap;
Var i,u,v: word; t:lk;
Begin
Assign(f,fi); Reset(f);
Readln(f,m,n); {doc so dinh m, so canh n tu tep vao cac bien nho m,n}
For i:=1 to n Do
Begin
Readln(f,u,v);
New(t);
8 h 54 m 28/7/2017
153
Thầy Trần Thông Quế
t^.s:=v;
t^.next:=dsk[u];
dsk[u]:=t;
End;
Close(f);
End;
Function min(u,v:word):word;
Begin
If u
Procedure DFS(i:word);
Var j:word; t:lk;
Begin
Inc(id);
Num[i]:=id;
Low[i]:=Num[i];
t:=dsk[i];
Inc(top);
s[top]:=i;
While Not (t=Nil) Do
Begin
j:=t^.s;
If p[j]=0 then
If Num[j]=0 then
Begin
DFS(j);
Low[i]:=min(Low[i], Low[j]);
End
Else Low[i]:=min(Low[i], Num[j]);
t:=t^.next;
End;
If Low[i]=Num[i] then
Begin
Inc(sv);
Repeat
j:=s[top]; {lay 1 phan tu ra khoi Stack tai dinh, luu vao j}
dec(top); {Khi do so phan tu o Stack giam di mot}
p[j]:=sv;
Until i=j;
End;
End;
Procedure Visit;
var i:word;
Begin
For i:=1 to m do
8 h 54 m 28/7/2017
154
Thầy Trần Thông Quế
If Num[i]=0 then DFS(i);
End;
Procedure Xuat;
Var i,j:word;
Begin
Assign(f,fo); Rewrite(f);
Writeln;Writeln;
Writeln(f,'So mien lien thong la:',sv);
For i:=1 to sv Do
Begin
For j:=1 to m Do
If p[j]=i then write(f,j,' ');
Writeln(f,'-> Cac dinh thuoc mien lien thong thu ',i,'.');
End;
Close(f);
end;
Procedure Inkq;
Var f:Text;line:String;
Begin
Assign(f,fo); Reset(f);
While Not SeekEof(f) Do
Begin
Readln(f,line);
Writeln(line);
End;
Close(f);
End;
{ Main Program }
Begin clrscr;
Nhap;
Visit;
Xuat;
Inkq;
Readln;
End.
B.3) BÀI TOÁN TÔ MÀU ĐỒ THỊ
5- Hãy dùng số màu ít nhất để tô màu đồ thị có N đỉnh, sao cho hai đỉnh BẤT KỲ KỀ NHAU phải được tô
bằng màu KHÁC NHAU.
Yêu cầu:
1-Đồ họa hóa Code
2-Cấu trúc đồ thị tự động thay đổi nhờ nhấn phím ENTER; nhấn ESC để thoát.
CODE:
PROGRAM COLOR_GRAPH;
8 h 54 m 28/7/2017
155
Thầy Trần Thông Quế
USES CRT,GRAPH;
CONST R=15;DL=500;VC=100;N=8;
C:ARRAY[1..8] OF INTEGER=(150,330,450,450,330,150,30,30);
D:ARRAY[1..8] OF INTEGER=(30,30,150,330,450,450,330,150);
CL:ARRAY[0..4] OF WORD=(WHITE,RED,YELLOW,BLUE,GREEN);
TYPE CSD=0..VC;
VAR G:ARRAY[CSD,CSD] OF BOOLEAN;
V,V0,V1:SET OF CSD;
I,J,K:CSD;
(*------------------------------------------------------------*)
PROCEDURE INITGR;
VAR GD,GM:INTEGER;
BEGIN
GD:=DETECT;
INITGRAPH(GD,GM,'..\BGI');
IF (GRAPHRESULT<> GROK) THEN
BEGIN
WRITELN('LOI KHOI TAO DO HOA, GO ENTER KET THUC !');
READLN;
HALT(1)
END
END;
(*-----------------------------------------------------*)
PROCEDURE VENUT(U:CSD;M:WORD);
BEGIN
SETFILLSTYLE(1,M);SETCOLOR(M);
FILLELLIPSE(C[U],D[U],R,R);
END;
(*-------------------------------*)
PROCEDURE LINK(X,Y:CSD;M:WORD);
BEGIN
SETCOLOR(M);
LINE(C[X],D[X],C[Y],D[Y]);
END;
(*-------------------------------*)
PROCEDURE INIT_GRAPH;
BEGIN
RANDOMIZE;
FOR I:=1 TO N DO
BEGIN
G[I,I]:=FALSE;
FOR J:=I+1 TO N DO
BEGIN
G[I,J]:=RANDOM(3)=1;
G[J,I]:=G[I,J]
END;
8 h 54 m 28/7/2017
156
Thầy Trần Thông Quế
END;
FOR I:=1 TO N DO
BEGIN
J:=0;
REPEAT
J:=J+1
UNTIL G[I,J] OR (J=N);
IF (J=N) AND (NOT G[I,N]) THEN
BEGIN
J:=RANDOM(N)+1;
IF J=I THEN IF I[] DO
BEGIN
K:=K+1; I:=0;
REPEAT I:=I+1 UNTIL I IN V0;
VENUT(I,CL[K]); DELAY(DL);
8 h 54 m 28/7/2017
157
Thầy Trần Thông Quế
V1:=[I];
FOR I:=1 TO N DO
IF I IN V0 THEN
BEGIN
J:=0;
REPEAT
J:=J+1;
CHECK:=G[I,J] AND (J IN V1);
UNTIL CHECK OR (J=N);
IF NOT CHECK THEN
BEGIN
VENUT(I,CL[K]); DELAY(DL);
V1:=V1+[I];
END;
END;
V0:=V0-V1;
END;
END;
(*---------------------------------------*)
PROCEDURE PROC_CALL_PROC; {THU TUC GOI CAC THU TUC}
VAR KT:CHAR;
BEGIN
IF KEYPRESSED THEN
REPEAT KT:=READKEY UNTIL NOT KEYPRESSED;
REPEAT
INIT_GRAPH;
PRINT_GRAPH;
MENU_PRINT;
COLORING;
KT:=READKEY;
UNTIL (KT=#27);
END;
(*--------------------------------------*)
BEGIN (* CHUONG TRINH CHINH *)
CLRSCR;
INITGR;
V:=[];
FOR I:=1 TO N DO V:=V+[I];
PROC_CALL_PROC;
CLOSEGRAPH;
END.
8 h 54 m 28/7/2017
158
Thầy Trần Thông Quế
VIII-2/ ĐỒ THỊ EULER & ĐỒ THỊ HAMILTON
A) ĐỒ THỊ EULER
6- Liệt kê các đường đi Euler trên đồ thị vô hướng được biểu diễn bởi ma trận kề dưới đây:
9 Số đỉnh của đồ thị (Bắt buộc phải có dữ liệu này!)
0 1 1 0 0 0 0 0 0
1 0 1 0 0 0 0 0 0
1 1 0 1 0 1 0 0 0
0 0 1 0 1 0 0 0 0
0 0 0 1 0 1 0 1 1
0 0 1 0 1 0 1 1 0
0 0 0 0 0 1 0 1 0
0 0 0 0 1 1 1 0 1
0 0 0 0 1 0 0 1 0
CODE:
Program Duongdi_Euler;
uses crt;
Label L1;
Const max=30;
Type mg1=array[1..max,1..max] of byte;
mg2=array[1..max] of boolean;
mg3=array[1..max] of integer;
Var c:mg1; check:mg2; i,j,u,n,dem1,dem:integer;
f:text; tf:string[12];
Function l_thg(u,v:integer; ktra:mg2):integer;
var i,j,d,k,l:integer; p:mg3;
Begin
c[u,v]:=0; c[v,u]:=0;
For i:=1 to n do p[i]:=0;
d:=0;
For i:=1 to n do
Begin
If (p[i]=0) and ktra[i] then
Begin
Inc(d); p[i]:=d;
for j:=1 to n do
for L:=1 to n do
If (p[j]=0) and ktra[j] and (p[L]=d) and (c[L,j]=1) then
p[j]:=d;
End;
End;
c[u,v]:=1; c[v,u]:=1;
L_thg:=d;
End;
8 h 54 m 28/7/2017
159
Thầy Trần Thông Quế
{Main Prog.}
Begin clrscr;
Write('Nhap ten tep du lieu:'); readln(tf);
Assign(f,tf); Reset(f);
Readln(f,n);
For i:=1 to n do
For j:=1 to n do Read(f,c[i,j]);
Close(f);
Write('Cho biet dinh xuat phat:'); Readln(u);
Writeln('Duong di Euler tim duoc:'); Writeln;
dem:=0;
For j:=1 to n do check[j]:=true;
L1:dem1:=0;
For j:=1 to n do
If c[u,j]=1 then Inc(dem1);
dem:=dem+1;
If dem1=1 then
Begin
For j:=1 to n do If c[u,j]=1 then
Begin
check[u]:=false;
c[u,j]:=0; c[j,u]:=0;
Writeln('Di qua canh thu ',dem,' dung 1 lan la tu:',u,'->',j);
u:=j;
Goto L1;
End;
End
Else
Begin
For j:=1 to n do
If c[u,j]=1 then
Begin
If L_thg(u,j,check)=1 then
Begin
c[u,j]:=0; c[j,u]:=0;
Writeln('Di qua canh thu ',dem,' dung 1 lan la tu:',u,'->',j);
u:=j;
Goto L1;
End
End
End;
Readln;
End.
7- Tìm và hiển thị chu trình EULER trên đồ thị biểu diễn bởi danh sách liệt kê cạnh. Yêu cầu: Program phải
chạy được cả với đồ thị vô hướng và đồ thị có hướng (đồ thị vô hướng: gõ 0; đồ thị có hướng: gõ 1).
Test1: Dùng file vào DTEUL.IN
8 h 54 m 28/7/2017
160
Thầy Trần Thông Quế
4 5 -> 4 đỉnh; 5 cạnh (Bắt buộc phải có hai data này!)
1 2
1 4
2 3
2 4
3 4
Test 2: Dùng file vào EU1.IN
5 6
1 2
1 5
2 5
3 4
3 5
4 5
B) ĐỒ THỊ HAMILTON
8- Tìm và hiển thị đường đi Hamilton trên đồ thị vô hướng được biểu diễn bởi danh sách liệt kê cạnh.
Test1: Dùng file vào DTEUL.IN
4 5
1 2
1 4
2 3
2 4
3 4
Test 2: Dùng file vào EU1.IN
5 6
1 2
1 5
2 5
3 4
3 5
4 5
9/ (Bài này bạn thử test với ma trận kề của đồ thị) Tìm và liệt kê chu trình Hamilton trên đồ thị được biểu
diễn bởi ma trận kề dưới đây.
8
0 1 1 1 0 0 0 0
1 0 0 0 1 0 0 0
1 0 0 1 1 0 0 0
1 0 1 0 0 1 1 0
0 1 1 0 0 1 0 1
0 0 0 1 1 0 1 0
0 0 0 1 0 1 0 1
0 0 0 0 1 0 1 0
8 h 54 m 28/7/2017
161
Thầy Trần Thông Quế
CODE:
Program Chutrinh_Hamilton;
Uses crt;
Var i,j,n:Integer;
c:Array[1..20,1..20] of byte;
p:Array[1..20] of byte;
b:array[1..20] of boolean;
d:Word; f1,f2:Text;
Procedure Xuly;
Label l1;
Var t:integer; ktra:boolean;
Begin
ktra:=true;
For t:=1 to n-1 Do
If c[p[t],p[t+1]]=0 then
Begin
ktra:=False;
goto L1;
End;
If c[p[n],p[1]]=0 then ktra:=False;
L1:If ktra then
Begin
d:=d+1;
Write(f2,'Chu trinh Hamilton thu ',d,' la:');
For t:=1 to n Do Write(f2,p[t]:3);
Writeln(f2);
End;
End;
Procedure test(k:integer);
Var i1,j:integer;
Begin
For j:=1 to n do
If b[j] then
Begin
p[k]:=j; b[j]:=False;
If k=n then xuly Else test(k+1);
b[j]:=True;
End;
End;
{Main Prog.}
Begin clrscr;
Assign(f1,'CtHamil.Inp'); Reset(f1);
Assign(f2,'CtHamil.Out'); Rewrite(f2);
Readln(f1,n);
For i:=1 to n do
For j:=1 to n do Read(f1,c[i,j]);
8 h 54 m 28/7/2017
162
Thầy Trần Thông Quế
Close(f1);
For i:=1 to n do b[i]:=True; d:=0;
Test(1);
Close(f2);
Writeln('DONE!');
Writeln('Go Enter de quay ve chuong trinh!');
Writeln('De xem ket qua, go phim F3, go CtHamil.Out, roi ENTER.');
Readln;
End.
10/ CHU TRÌNH HAMILTON TRÊN ĐỒ THỊ CÓ TRỌNG SỐ: Bài toán KINH ĐIỂN nổi tiếng:
TRAVELLING SALESMAN PROBLEM. Không hề ảnh hưởng đến nội dung và cách giải bài toán, ta gọi
bài toán này là bài toán NGƯỜI DU LỊCH.
Một nước có N địa điểm du lịch được đánh số từ 1 đến N. Giữa hai địa điểm bất kỳ có thể có đường đi hoặc
không. Giữa hai địa diểm i, j có đường đi thì giá đi (bằng ô tô chẳng hạn) du lịch giữa chúng là những số
nguyên C(i,j)>0. Nói chung C(i, j) khác C(j, i). Khách du lịch xuất phát từ địa điểm k ,muốn tham quan tất
cả các địa điểm, mỗi địa điểm đúng 1 lần, rồi quay về k (k
6
0 3 0 4 0 0
3 0 4 0 2 0
0 4 0 0 1 1
4 0 0 0 1 5
0 2 1 1 0 5
0 0 1 5 5 0
1 6
CODE:
Program Nguoi_Dulich; { chu trinh Hamilton tren do thi co trong so}
Uses crt;
Const sd=10;
fi='HMT.VAO'; fo='HMT.RA';
Type m1=Array[1..sd,1..sd] of Integer;
m2=Array[1..sd] of Integer;
m3=Array[1..sd] of Boolean;
Var c:m1;
a,x:m2;
d:m3;
n,cmin,sum,maxsum,dem:Integer;
Procedure Nhap;
Var f:text; x,i,j:Integer;
Begin
Assign(f,fi); Reset(f);
Readln(f,n);
cmin:=maxint;
For i:=1 to n do
8 h 54 m 28/7/2017
163
Thầy Trần Thông Quế
Begin
For j:=1 to n do
Begin
Read(f,c[i,j]);
If c[i,j]>0 then
If (c[i,j]j) Then
cmin:=c[i,j];
End;
Readln(f);
End;
Close(f);
End;
Procedure Tim_Chiphi_Min;
Begin
If sum+c[a[n],a[1]]n Then
Begin
If c[a[n],a[1]]>0 Then Tim_Chiphi_Min;
End
Else
For j:=1 to n Do
If d[j] Then
If c[a[i-1],j]>0 then
Begin
a[i]:=j;
d[j]:=False;
sum:=sum+c[a[i-1],j];
If sum+(n-i+1)*cmin0 then
8 h 54 m 28/7/2017
164
Thầy Trần Thông Quế
Begin
Writeln(g,'Tong chi phi cua hanh trinh DU LICH=',maxsum);
Write(g,'Tour du lich KHEP KIN co chi phi min ma khach da di la:');
For i:=1 to n do Write(g,x[i],' ');
Writeln(g,x[1]);
End
Else
Writeln(g,0);
End;
Procedure Init; {Khoi tri cho cac bien}
Var i,j:integer;
Begin
For i:=1 to n do d[i]:=True;
maxsum:=maxint;
sum:=0;
a[1]:=1;
d[1]:=false;
dem:=0;
End;
Begin clrscr;
Nhap;
Init;
Assign(g,fo); Rewrite(g);
Try(2);
Xuat; Writeln;
Writeln(#32:7,'XONG! GO ENTER->GO PHIM F3->GO HMT.RA->ENTER: DE XEM KET QUA.');
Readln;
Close(g);
End.
= = = = = = = = = = = = = = = =
VIII-3/ CÁC THUẬT TOÁN TÌM ĐƯỜNG ĐI
NGẮN NHẤT TRÊN ĐỒ THỊ.
VIII-3.1) THUẬT TOÁN DIJKSTRA: Tìm đường ngắn nhất từ một điểm đến các điểm
còn lại trên đồ thị.
1- Một đồ thị vô hướng CÓ TRỌNG SỐ được biểu diễn bởi danh sách liệt kê cạnh dưới
đây (Lưu trên text file DATA.VAO có cấu trúc dưới đây). Lập trình tìm và hiển thị
đường ngắn nhất từ đỉnh cho trước bất kỳ đến đỉnh đích tùy chọn trên đồ thị ấy.
5 9 5 đỉnh, 9 cung: bắt buộc phải ghi ở đây
1 2 1
8 h 54 m 28/7/2017
165
Thầy Trần Thông Quế
1 5 9
2 3 2
2 4 5
3 4 1
3 5 2
4 3 7
5 2 8
5 4 10
CODE:
{Chuong trinh nay Test tren tep DATA.VAO}
Program Min_Path;
Uses crt;
Const max=50;
Type contro=^ct;
ct=record
bd:byte; {Dinh bat dau}
lk:contro;
End;
Var n,m,xp,dich:integer;
tt:boolean;
v,dau,cuoi,len:Array[1..max] of integer;
FileName:String;
Procedure Data_Inp(Filename:String);
Var i:byte; f:Text;
Begin
Assign(f,FileName); Reset(f);
Readln(f,n,m);
For i:=1 to m do Readln(f,dau[i],cuoi[i],len[i]);
Close(f);
Writeln('Do thi dang xet co ',n,' dinh va ',m,' cung');
For i:=1 to m do
Writeln('Canh ',dau[i],'-->',cuoi[i],' co trong so=',len[i]);
End;
Function MemCheck(x:byte):contro;
Var p:contro;
Begin
New(p);
If p=Nil Then
8 h 54 m 28/7/2017
166
Thầy Trần Thông Quế
Begin
Writeln('Thieu bo nho!'); Halt;
Readln;
End;
p^.bd:=x;
MemCheck:=p;
End;
Procedure PathMin_Find;
Var ds,p:contro; i,d,x:byte;
Begin
x:=dich; ds:=Nil; d:=v[x];
While (x<>xp) Do
For i:=1 to m do
If cuoi[i]=x Then
If (v[dau[i]]<>-1) and (v[dau[i]]+len[i]=v[x]) Then
Begin
v[x]:=-1;
x:=dau[i];
p:=MemCheck(x);
p^.lk:=ds; ds:=p;
Break;
End;
p:=ds;
While p<>Nil Do
Begin
Write(p^.bd,'-->'); p:=p^.Lk;
End;
Writeln(dich,' voi do dai min=',d);
End;
Procedure Init;
Var i:Byte;
Begin
For i:=1 to n do v[i]:=-1;
End;
Procedure LastProces;
Var tt:boolean; j,x,y:byte;
Begin
tt:=True;
While tt Do
8 h 54 m 28/7/2017
167
Thầy Trần Thông Quế
Begin
tt:=False;
For j:=1 to m do
Begin
x:=dau[j]; y:=cuoi[j];
If v[x]<>-1 Then
Begin
If (v[y]=-1) Or (v[x]+len[j]
8 h 54 m 28/7/2017
168
Thầy Trần Thông Quế
VIII-3.2) THUẬT TOÁN FORD-BELLMAN: Tìm đường ngắn nhất giữa mọi CẶP
đỉnh tùy ý trên đồ thị KHÔNG CÓ CHU TRÌNH ÂM.
2-CÀI ĐẶT FORD-BELLMAN ALGORITHM
(Tổ chức dư liệu VÀO: Bạn hãy tự vẽ bịa ra một đồ thị có trọng số, rồi bạn lập MA
TRẬN KỀ CHO nó. Code của bạn sẽ Test trên ma trận đó. Khi tạo đồ thị nhớ kiểm tra
bảo đảm nó không có chu trình ÂM)
CODE:
Program Ford_Bell_Algo;
Uses Crt;
Const fi='sl.vao'; fo='sl.ra'; max=100;
vocuc=100*50*maxint; {=163835000}
Type m1=array[1..max,1..max] of longint;
m2=array[1..max] of longint;
m3=array[1..max] of byte;
Var a:m1;v:m2; t:m3;
m:integer; n,x,y:byte;
Procedure Input;
Var f:Text; k,w:integer;
i,j:byte;
Begin
assign(f,fi); reset(f);
Fillchar(a,sizeof(a),0); Readln(f,n,m,x,y);
For k:=1 to m do
Begin
Readln(f,i,j,w);
a[i,j]:=w; a[j,i]:=w;
End;
close(f);
End;
Procedure init;
var i,j:byte;
Begin
For i:=1 to n do
For j:=1 to n do
If a[i,j]=0 then a[i,j]:=vocuc;
For i:=1 to n do v[i]:=a[x,i]; v[x]:=0;
FillChar(t,sizeof(t),0);
End;
8 h 54 m 28/7/2017
169
Thầy Trần Thông Quế
Procedure Ford_Bellman;
Var i,j,k:byte; stop:boolean;
Begin
for k:=1 to n-1 do
Begin
stop:=true;
For i:=1 to n do
For j:=1 to n do
If j<>x then
If v[j]>v[i]+a[i,j] then
Begin
v[j]:=v[i]+a[i,j];
t[j]:=i;
stop:=false;
End;
If stop then break;
End;
End;
Procedure Xuat;
var f:text; kq:m3; i,j:byte;
Begin
Assign(f,fo); Rewrite(f);
If v[y]=vocuc then
Begin
Writeln(f,-1);
close(f);
halt;
End;
Writeln(f,v[y]);
i:=y;
j:=0;
Repeat
Inc(j);
kq[j]:=i;
i:=t[i];
Until i=0;
Assign(f,fo); Reset(f);
While Not SeekEof(f) Do
For i:=j Downto 1 do Writeln(f,kq[i]);
close(f);
End;
8 h 54 m 28/7/2017
170
Thầy Trần Thông Quế
Begin clrscr;
input;
init;
Ford_Bellman;
xuat;
Write('DONE!');
readln
End.
VIII.-3.3) THUẬT TOÁN FLOYD-WARSHALL: Tìm đường ngắn nhất giữa mọi
cặp đỉnh thông qua các đỉnh TRUNG GIAN trên đồ thị có trọng số.
3-ĐỒ HỌA HÓA code cho thuật toán trên. Yêu cầu:
a) Gõ ENTER để thay đổi cấu trúc đồ thị,
b) Gõ SPCE: tìm tiếp,
c) Gõ ESC: Thoát.
CODE:
Program Floyd_Warshall_Alg;
uses crt,graph;
const r=15;dl=500;n=5;vc=200;vocuc=10000;
c:array[1..5]of integer =(240,460,350,130,20);
d:array[1..5] of integer=(20,240,460,460,240);
ec:array[1..10] of integer =(350,276,204,130,405,295,240,240,185,75);
ed:array[1..10] of integer=(130,166,166,130,360,360,240,460,360,360);
var g,p,a:array[1..n,1..n] of integer;
dau,cuoi:integer;
Procedure initgr;
var gd,gm:integer;
begin
gd:=detect;
initgraph(gd,gm,'..\bgi');
if (graphresult<>grok) then
begin
writeln('Loi khoi tao do hoa,go enter ket thuc!');
readln;
halt(1);
end
end;
8 h 54 m 28/7/2017
171
Thầy Trần Thông Quế
Procedure venut(u,m1,m2:integer);
var st:string[3];
begin
setfillstyle(1,m2);
setcolor(m1);
fillellipse(c[u],d[u],r,r);
str(u,st);
outtextxy(c[u]-2,d[u]-2,st);
end;
Procedure link(x,y,m1,m2:integer);
var t:integer;st:string[3];
begin
setcolor(m2);
line(c[x],d[x],c[y],d[y]);
t:=y-x +((x-1)*(2*n-x)) div 2;
str(g[x,y],st);
setcolor(m1);
outtextxy(ec[t],ed[t],st);
end;
Procedure init_graph;
var i,j:integer;
begin
randomize;
for i:=1 to n do
begin
g[i,i]:=0;
for j:= i+1 to n do
begin
if random(2) = 1 then g[i,j]:=10 +random(vc-10)
else g[i,j]:=vocuc;
g[j,i]:=g[i,j];
end;
end;
for i:= 1 to n do
begin
j:=0;
repeat
j:=j+1;
until((g[i,j]>0) and (g[i,j]
172
Thầy Trần Thông Quế
begin
j:=1+random(n);
if j=i then if i
173
Thầy Trần Thông Quế
bar(0,0,getmaxy,getmaxy);
for i:= 1 to n do
begin
for j:= 1 to n do
if (g[i,j]>0) and(g[i,j]
174
Thầy Trần Thông Quế
end;
end;
Procedure Thbao_kq;
var st:string[20];
Begin
if a[dau,cuoi]=vocuc then st:='Khong co duong di!'
else
begin
str(a[dau,cuoi],st);
st:='Duong di min='+st;
Timdequy(dau,cuoi);
end;
setcolor(red);
outtextxy(490,210,st);
End;
Procedure Thutuc_goi_thutuc;
Var k:char;
Begin
if keypressed then
repeat
k:=readkey
until not keypressed;
repeat
init_graph;
floyd;
repeat
print_graph;
demo;
Thbao_kq;
k:=readkey;
until (k=#27) or (k=#13);
until(k=#27);
End;
Begin clrscr;
initgr;
Thutuc_goi_thutuc;
closegraph;
End.
8 h 54 m 28/7/2017
175
Thầy Trần Thông Quế
BỐN BÀI TỰ LUYỆN (TL) CHO CÁC BẠN ÁP DỤNG ALGORITHMS TRÊN
ĐÂY:
TL1/ Trong một mạng lưới giao thông có n thành phố và m hành trình tàu đi trong n
thành phố đó. Thời gian đi từ thành phố i đến thành phố j là t ij. Mỗi hành trình i
xuất phát tại thành phố si1 vào thời điểm ti, đi qua một dãy các thành phố si2, si3,...,
sik. Tại mỗi thành phố tàu sẽ dừng lại để hành khách lên hoặc xuống tàu. Một người
xuất phát ở thành phố s tại thời điểm t muốn đi tới thành phố d.
a) Hãy tìm lộ trình sao cho người đó đến d sớm nhất.
b) Hãy tìm lộ trình với số lần chuyển tàu ít nhất.
Dữ liệu vào lưu trên text file với tên TauHoa.Vao gồm các đại lượng n, m, s, t, d, số
hành trình và ma trận tij. Dữ liệu ra lưu trên text file với tên TauHoa.Ra gồm thời gian
đến d sớm nhất và số lần chuyển tàu ít nhất.
TL2/ Một toà nhà cao tầng có n thang máy. Mỗi thang máy nối liền đúng 2 tầng với nhau
và không dừng lại ở những tầng nằm giữa 2 tầng này. Vận tốc của các thang máy là
như nhau: 5 giây qua một tầng.
Thời điểm bắt đầu, mỗi thang máy đều ở tầng thấp và chúng cùng bắt đầu di
chuyển lên tầng trên. Sau khi tới tầng trên, ngay lập tức lại chuyển xuống tầng dưới,
rồi lại lên tầng trên, và cứ lặp lại như thế ...
An đang ở tầng 1 (tầng thấp nhất) và muốn nhanh chóng lên tầng trên cùng của toà
nhà. Anh ta thay đổi thang máy chỉ trên những tầng chung của 2 thang máy và nếu thang
máy kia tại thời điểm này cũng tới tầng này thì việc chuyển thang máy khi đó coi như
không tốn thời gian. Hãy lập trình tính thời gian ít nhất để An có thể lên tới tầng trên
cùng của toà nhà.
Dữ liệu vào cất trên text file với tên Lift.In gồm:
Dòng đầu tiên chứa 2 số nguyên dương K, N cách nhau ít nhất một dấu cách, là
số tầng và số thang máy của toà nhà (2 K 1000; 1 N 50000).
Trên mỗi một N dòng tiếp theo ghi 2 số nguyên dương A, B (cách nhau một
dấu cách) mô tả một thang máy di chuyển giữa 2 tầng A, B (1 A < B K).
Chú ý:
— Không có 2 thang máy nào khác nhau mà lại cùng di chuyển giữa 2 tầng như
nhau.
— Dữ liệu vào đảm bảo luôn luôn tồn tại nghiệm.
Kết quả ghi lên text file với tên Lift.Ou gồm: chỉ một dòng ghi thời gian ít nhất
mà An có thể di chuyển lên tầng trên cùng của toà nhà. Ví dụ: Xem 2 bộ dữ liệu
dưới đây:
8 h 54 m 28/7/2017
176
Thầy Trần Thông Quế
Lift1.In
10 4
1 5
5 10
5 7
7 10
45
Lift1.Ou
Lift2.In Lift2.Ou
20 5 150
1 7
7 20
4 7
4 10
10 20
TL3/ Cho số nguyên k (0 < k 255) và n xâu ký tự có cùng độ dài L chỉ gồm các chữ
cái thường (0 < n 100) và (0 < L 255) là S1, S2,..., Sn. đôi một khác nhau. Hãy
tìm xâu Smin nhỏ nhất thoả mãn tính chất sau: tồn tại k vị trí khác nhau trong xâu
Smin là các vị trí xuất hiện của một trong các xâu S 1, S2,..., Sn. Ta gọi p là vị trí xuất
hiện của xâu S trong Smin nếu giá trị của hàm Copy(Smin, p, L) = S.
Dữ liệu vào cất trên text file với tên Str.In gồm :
Dòng đầu ghi n, L, k :
n dòng tiếp theo, dòng thứ i ghi xâu Si:
Kết quả ghi lên text file với tên
Str.Ou gồm :
Dòng đầu tiên ghi độ dài nhỏ nhất:
Dòng thứ 2 ghi xâu Smin thoả điều
kiện đầu bài (xem 2 file bên).
k dòng tiếp theo, mỗi dòng ghi 2 số u, p cho biết sự xuất hiện của xâu S u tại p
trong xâu Smin. Một ví dụ cụ thể cho dưới đây:
Str.In Str.Ou
2 10 2 17
aaaaaaaxyz aaaaaaaxyzabcdefg
xyzabcdefg 1 1
2 8
8 h 54 m 28/7/2017
177
Thầy Trần Thông Quế
TL4/ Một bãi tập kết rác hình chữ nhật được kẻ ô vuông. Các túi rác
có khối lượng là một số nguyên (hay số thực thì cũng chẳng ảnh hưởng gì đến cách giải
bài toán!) đặt tại mỗi ô vuông. Một robot đi từ ô góc trên cùng trái đến góc duới cùng
phải của bãi rác để gom rác theo luật sau: robot chỉ đi xuống hoặc sang phải theo các
cạnh của ô vuông. Viết code tìm một chiến thuật để robot gom được khối luợng rác lớn
nhất.
VIII-4. CÂY KHUNG (SPANNING TREE) & BÀI TOÁN TÌM CÂY
KHUNG NGẮN NHẤT (SPANNING TREE MIN) TRÊN ĐỒ THỊ.
Ôn một chút lý thuyết:
A) CÂY KHUNG LÀ GÌ? Cho đồ thị vô hướng, liên thông G = {V, E} có N ĐỈNH
(N > 1). Mọi đồ thị con H = {W, F} có N 1 cạnh ( W V, F E) gọi là CÂY
KHUNG của đồ thị G.
B) CÂY KHUNG MIN LÀ GÌ? Cho đồ thị vô hướng có TRỌNG SỐ không âm, liên
thông G = {V, E} có N đỉnh (N > 1), cây khung NGẮN NHẤT (CKMIN) của đồ thị G
là cây khung có tổng trọng số trên tất cả các cạnh của nó là nhỏ nhất.
C) BÀI TOÁN TÌM CKMIN: Cho đồ thị G vô hướng, liên thông và có trọng số không
âm. Hãy tìm cây khung ngắn nhất của G.
Đến nay có 2 thuật toán giải bài này: thuật toán KRUSCAL & thuật toán PRIM.
5- CÀI ĐẶT THUẬT TOÁN KRUSCAL
a) Tổ chức Data: Cấu trúc của đồ thị cho trước được biểu diễn bởi danh sách liệt kê
cạnh dưới đây (các số cách nhau một ký tự trống):
9 14 9: số đỉnh; 14: số cạnh
1 2 4
1 8 8
2 3 6
2 8 11
3 4 7
3 6 4
3 9 2
4 5 9
4 6 14
8 h 54 m 28/7/2017
178
Thầy Trần Thông Quế
5 6 10
6 7 2
7 8 1
7 9 6
8 9 7
b) CODE:
Program Krusal_Alg;
Uses crt;
Const fi='KRUSCAL.IN'; fo='KRUSCAL.OU'; ln=50;
Type bg=Record
x,y:byte; {x-ding dau, y-dinh cuoi cua canh}
c:integer; {c la trong so tren cac canh cua do thi}
End;
Var m,t:longint; n,count:Integer; {t- de luu tong trong so cua CKmin}
g:text; {count-dem so canh cua CKmin}
a:Array[1..ln*ln DIV 2] of bg;
b:Array[1..ln] of integer;
line:string[4];
Procedure doc; {ct con nhap du lieu vao ct}
Var f:text; i:Integer;
Begin
Assign(f,fi); Reset(f);
Readln(f,n,m);
For i:=1 to m Do
Readln(f,a[i].x,a[i].y,a[i].c);
close(f);
End;
Procedure Saptang;
Var i,j:integer; c:bg;
Begin
For i:=1 to m-1 do
For j:=i+1 to m do
If a[i].c>a[j].c then {dung c lam bien trung gian luon}
Begin c:=a[j];a[j]:=a[i]; a[i]:=c; End;
End;
Function Root(x:integer):Integer; {xac dinh dinh goc la dinh x cho cay}
8 h 54 m 28/7/2017
179
Thầy Trần Thông Quế
Var i:integer;
Begin
i:=x;
While b[i]>0 Do i:=b[i];
Root:=i;
End;
Procedure Hopnhat(x,y:integer); {Hop nhat cac dinh o 2 mien biet lap}
Var tg:integer;
Begin
tg:=b[x]+b[y];
If b[x]>b[y] Then
Begin
b[x]:=y;
b[y]:=tg;
End
Else
Begin
b[y]:=x;
b[x]:=tg;
End;
End;
Procedure Ck_crea; {kien tao dan dan cay khung min}
Var f:Text; i:longint; x,y,t1,t2:Integer;
Begin
t:=0; count:=0;
Doc;
Saptang;
For i:=1 to n Do b[i]:=-1;
For i:=1 to m Do
Begin
If count=n-1 Then Exit;
x:=a[i].x;
y:=a[i].y;
t1:=Root(x);
t2:=Root(y);
If t1<>t2 Then
Begin
Hopnhat(t1,t2);
Writeln(g,x,' ',y);
8 h 54 m 28/7/2017
180
Thầy Trần Thông Quế
Inc(count);
t:=t+a[i].c;
End;
End;
End;
Begin clrscr;
Assign(g,fo); Rewrite(g);
Ck_crea; Writeln;
Writeln('Tap hop cac canh cua Cay_khung_min dang xet:');
{Write(g,t);}
Close(g);
Reset(g);
While Not SeekEof(g) Do
Begin
Readln(g,line);
Writeln(line);
End;
Writeln;
Writeln('Va tong trong so cua cay_khung_min nay=',t);
Readln
End.
6) CÀI ĐẶT THUẬT TOÁN PRIM
a-Tổ chức dữ liệu:
Cấu trúc của đồ thị cho trước được biểu diễn bởi danh sách liệt kê cạnh dưới đây:
và lưu tren text file PRIM.IN (các số trên mỗi dòng cách nhau một ký tự trống):
9 14 9: số đỉnh; 14: số cạnh
1 2 4
1 8 8
2 3 6
2 8 11
3 4 7
3 6 4
3 9 2
4 5 9
4 6 14
5 6 10
6 7 2
7 8 1
8 h 54 m 28/7/2017
181
Thầy Trần Thông Quế
7 9 6
8 9 7
b- CODE:
Program Prim_Algol;
Uses crt;
Const Ln=50; fi='PRIM.IN'; {fi=Tep luu data vao}
fo='Ra.kq'; { Tep ghi ket qua cua chuong trinh}
Type m1=Array[1..Ln,1..Ln] of integer;
m2=Array[1..Ln] of integer;
Var a:m1; {mang ghi nho trong so cua do thi}
d:m2; {mang ghi nho dinh da nap vao cay khung nho nhat}
d1,d2:m2; {mang ghi nho cac canh cua cay khung nho nhat}
n,tong:Integer;
Procedure Doc;
Var f:text; i,j,x:Integer;
Begin
Assign(f,fi); Reset(f); Readln(f,n);
While Not SeekEof(f) Do
Begin
Readln(f,i,j,x);
a[i,j]:=x;
a[j,i]:=x;
End;
Close(f);
End;
Procedure Timcanhmin(Var i,j:Integer);
Var x,y,wmin:Integer; {wmin: trong so nho nhat}
Begin
wmin:=Maxint;
For x:=1 to n Do
If d[x]=1 Then
For y:=1 to n Do
If d[y]=0 then
If (a[x,y]>0) and (a[x,y]
8 h 54 m 28/7/2017
182
Thầy Trần Thông Quế
End;
End;
Procedure TtPrim;
Var i,j,k:Integer;
Begin
For i:=1 to n Do d[i]:=0;
d[1]:=1;
For k:=1 to n-1 do
Begin
Timcanhmin(i,j);
d[j]:=1; {danh dau dinh j da duoc nap vao cay khung}
d1[k]:=i; {luu dinh dau cua canh da nap vao cay khung}
d2[k]:=j; {luu dinh cuoi cua canh da nap vao cay khung}
End;
End;
Procedure ghi;
Var f:Text; i:integer;
Begin
Assign(f,fo); Rewrite(f);
tong:=0;
For i:=1 to n-1 do
Begin
Writeln(f,d1[i],' ',d2[i]);
tong:=tong+a[d1[i],d2[i]];
End;
Writeln(f,'Tg trg_so=',tong);
Close(f);
End;
Procedure Xem_kq;
Var f:Text; line:string[12];
Begin
Writeln(#32:20,'KET QUA CHAY CHUONG TRINH:');
Writeln('Tap cac canh cua Ck_min va tong trong so cua no (dong cuoi):');
Writeln;
Assign(f,'Ra.kq'); Reset(f);
While Not SeekEof(f) Do
Begin
Readln(f,line);
Writeln(#32:7,line);
8 h 54 m 28/7/2017
183
Thầy Trần Thông Quế
End;
close(f);
End;
Begin clrscr;
Doc;
TtPrim;
Ghi;
Xem_kq;
Readln;
End.
BÀI TỰ LUYỆN CHO CÁC BẠN (Thực chất là tìm CKMIN)
TL1/ Một thành phố cần trải nhựa mạng giao thông có N nút giao thông cho bởi đồ thị bạn tự vẽ
(dễ thôi). Trọng số của các cạnh đồ thị này biểu diễn độ dài các con đường. Cần
phải trải nhựa những con đường nào để vẫn có đường đi được trải nhựa giữa hai
nút giao thông bất kỳ mà ĐỘ DÀI ĐƯỢC TRẢI NHỰA LÀ NGẮN NHẤT.
TL2/ Giả sử mạng truyền dữ liệu giữa các trung tâm máy tính ở một số tỉnh miền Bắc cho bởi
đồ thị bạn tự vẽ. Trọng số ghi trên các cạnh của đồ thị này biểu thị CHI PHÍ xây dựng
đường truyền dữ liệu. Viết code để sao cho chi phí thiết đặt mạng truyền dữ liệu là ÍT
NHẤT mà vẫn đảm bảo truyền dữ liệu được giữa 2 trung tâm BẤT KỲ thuộc mạng. (Đơn
vị tiền chi phí: Triệu).
TL3/ Có n phòng làm việc của một công ty được nối tiếp với nhau bằng hệ thống dây điện.
Sơ đồ nối dây của mạng điện này biểu diễn bởi ma trận A[i, j], trong đó A[i, j] là độ
dài dây điện nối giữa phòng i với phòng j.
Nếu không có dây điện nối giữa phòng i với phòng j thì A[i, j] = 0. Hiện tại n
phòng này đều có đường dây điện nối tới nhưng quá thừa nên lãng phí. Hãy tìm
tổng độ dài ngắn nhất của hệ thống dây điện cần sửa lại cách nối điện sao cho n
phòng của công ty đều có điện.
Dữ liệu vào cất trên text file với tên E_line.In. Dòng đầu tiên là số phòng n; n
dòng kế tiếp mô tả ma trận A[i, j], mỗi dòng n số cách nhau ít nhất một ký tự trống.
Kết quả cất trên text file với tên E_line.Ou mà dòng đầu là tổng độ dài dây điện
dùng cho công ty; các dòng sau mỗi dòng ghi 2 số u i và vj biểu thị có đường dây
nối phòng ui với phòng vi (i = 1, 2, 3, ...)
Một trường hợp cụ thể của bài toán này với file vào và xuất dữ liệu cho dưới
đây:
4 5
E_line.In E_line.Ou
8 h 54 m 28/7/2017
3 4
1 4
2 4
184
Thầy Trần Thông Quế
0 3 4 2
3 0 3 2
4 3 0 1
2 2 1 0
= = = = = = = = = = = = = = = = = =
PHẦN IX. ĐỒ THỊ HAI PHÍA
(ÁP DỤNG GIẢI VÀI BÀI TOÁN TÌM CẶP GHÉP CỰC ĐẠI VÀ LẬP LỊCH TỐI ƯU)
A-ÔN MỘT VÀI KHÁI NIỆM CƠ BẢN ĐỂ LÀM TOÁN
1/ Thế nào là đồ thị hai phía?
Cho tập đỉnh V1 và tập đỉnh V2 thỏa mãn:
V1 Giao V2 = Rỗng (a)
V1 Hợp V2 = V (b)
và tập cạnh E gồm các cạnh e = (v1, v2) mà
v1 Thuộc V1, v2 Thuộc V2 (c)
Tập G = {V,E} với V, E thỏa các điều kiện a, b, c ở trên gọi là đồ thị HAI PHÍA (đồ thị hai phía cũng được
ký hiệu là G{V1, V2, E}).
2/ Hai dạng bài toán về cặp ghép trên đồ thị hai phía:
2.1) Trước hết cần định nghĩa khái niệm cặp ghép:
Ta gọi tập PAI gồm các cạnh thuộc E và không có đỉnh nào chung là cặp ghép. Số cạnh của PAI là lực
lượng của cặp ghép và ký hiệu PAI.
2.2) Tiếp theo là định nghĩa khái niệm cặp ghép đầy đủ:
Nếu tập V1 và V2 đều có N đỉnh và PAI = N thì PAI gọi là cặp ghép ĐẦY ĐỦ. Hai dạng bài toán về cặp
ghép:
2.3) Dạng 1
Đây là bài toán tìm tập PAI có lực lượng |PAI| cực đại. Bài toán tìm cặp ghép đầy đủ là trường hợp riêng
của bài toán này.
2.4) Dạng 2 (CẶP GHÉP CỰC ĐẠI)
Tìm cặp ghép có TỔNG TRỌNG SỐ LỚN NHẤT (GỌI TẮT LÀ CẶP GHÉP CỰC ĐẠI, viêt tắt: Cặp ghép
Max) trên các cạnh thuộc tập PAI. Một số các bài toán XẾP LỊCH thuộc dạng này.
Để giải hai dạng bài toán trên ta có các thuật toán cơ bản sau:
a-Thuật toán cơ bản dựa vào đồ thị hai phía, dây chuyền (luồng) và sửa nhãn để tìm cặp ghép Max,
b-Đệ quy – Quay lui,
c-Quy hoạch động,
d-Sắp xếp Topo,
e-Thuật toán Jonson,
f-Thuật toán Heristic,
g-Thuật toán Hunggari,
g-Thuật toán làm Mịn dần kết quả.
8 h 54 m 28/7/2017
185
Thầy Trần Thông Quế
DƯỚI ĐÂY CHỈ CÓ ĐIỀU KIỆN NÊU VÀI BÀI TOÁN ÁP DỤNG MỘT
SỐ TRONG CÁC THUẬT TOÁN TRÊN. (Các bạn có thể tham khảo chi tiết ở
quyển LÝ THUYẾT ĐỒ THỊ, NXB Giáo Dục, 2012, Tác giả: Trần Thông Quế).
B-LẬP TRÌNH GIẢI CÁC BÀI TOÁN CẶP GHÉP SAU:
1/ Bài toán 1.
Một lớp học sinh gồm N người (đánh số thứ tự từ 1 đến N và N 1000) đi cắm trại tham gia trò chơi như
sau: mỗi em nam ghép cặp với một em nữ (và ngược lại mỗi em nữ ghép cặp với một em nam). Người ta
dùng một tham số nguyên dương w để đánh giá độ ăn ý của các cặp ghép đó. Yêu cầu tìm những cặp ghép
cho tổng độ ăn ý lớn nhất.
Dữ liệu vào cất trên text file với tên Ghepcap.In gồm:
* Dòng 1 là số N.
* Các dòng tiếp theo mỗi dòng gồm 3 số x, y, w với ý nghĩa : x là số hiệu của nam sinh, y số hiệu của nữ
sinh, w là độ ăn ý của 2 bạn đã ghép cặp với nhau.
Kết quả ghi lên text file với tên Ghepcap.Ou gồm:
* Dòng đầu chứa một số nguyên dương là tổng độ ăn ý lớn nhất của các cặp ghép.
* Các dòng tiếp theo mỗi dòng ghi 3 số x, y, w.
Một ví dụ cụ thể là:
Ghepcap.In
4
1 2 2
1 3 1
4 2 3
4 3 1
Ghepcap.Ou
4
1 3 1
4 2 3
1) CODE1. (Phuong an 1: Dung de quy quay lui de tim cap ghep CUC DAI)
Program GhepNamNu;
Uses crt;
Const fi='Ghepcap.In';
fo='Ghepcap.Ou';
min=-10000;
Var f:text; n:integer;
Test,Free: array[1..100] of boolean;
A: array[1..100,1..100] of integer;
Trace,besttr: array[1..100] of integer;
nho:integer;
Procedure Nhap;
Var i,j1,j2,j3:integer;
Begin
assign(f,fi); reset(f); readln(f,n);
for i:=1 to n do for j1:=1 to n do a[i,j1]:=min;
for i:=1 to n do begin test[i]:=true; free[i]:=true; end;
for i:=1 to n do
Begin
readln(f,j1,j2,j3);
8 h 54 m 28/7/2017
186
Thầy Trần Thông Quế
A[j1,j2]:=j3;
A[j2,j1]:=j3;
test[j2]:=false;
End;
close(f);
nho:=0;
End;
Procedure Tichluy;
Var tong, i:integer;
Begin
tong:=0;
for i:=1 to n do if test[i] then tong:=tong+a[i,trace[i]];
if tong>nho then
Begin
nho:=tong;
besttr:=trace;
End;
End;
Procedure Try(i:integer); {de quy quay lui}
Var j, k:integer; ok:boolean;
Begin
if not free[i] then try(i+1) else
for j:=1 to n do if i<>j then if free[j] then
Begin
free[j]:=false;
free[i]:=false;
trace[i]:=j;
trace[j]:=i;
ok:=true;
for k:=1 to n do if free[k] then ok:=false;
if ok then Tichluy else try(i+1);
free[j]:=true;
free[i]:=true;
End
End;
Procedure Xuat;
Var i:integer;
Begin
Assign(f,fo); Rewrite(f);
writeln(f,nho);
for i:=1 to n do if test[i] then
writeln(f,i,' ',besttr[i],' ',a[i,besttr[i]]);
close(f);
End;
Procedure Xem;
Var f:text; line:string;
Begin
Assign(f,fo); Reset(f);
8 h 54 m 28/7/2017
187
Thầy Trần Thông Quế
Writeln(#32:12,'KET QUA PROGRAM:');
Writeln;
While not (seekeof(f)) do
Begin
Readln(f,line);
Writeln(#32:7,line);
End;
Close(f);
End;
{Main Prog.}
Begin clrscr;
Nhap;
Try(1);
Xuat;
Xem;
Write('Done!');
Readln;
End.
2) CODE2 (DÙNG THUẬT TOÁN KRUSCAL ĐỂ TÌM CẶP GHÉP MAX )
Program Ghepcap;
Uses Crt;
Const Const fi='Ghepcap.In';
fo='Ghepcap.Ou';
max=10000;
Var Tree:array[1..100] of integer;
canh:array[1..100,1..2] of integer;
a:array[1..100,1..100] of integer;
f:text;
N:integer;
trongso:integer;
test: array[1..100] of boolean;
Procedure Nhap;
Var i,j,u,v:integer;
Begin
assign(f,fi);
reset(f);
read(f,n);
readln(f);
for i:=1 to n do test[i]:=true;
for i:=1 to n do
for j:=1 to n do a[i,j]:=0;
for i:=1 to n do
begin
readln(f,u,v,a[u,v]);
test[v]:=false;
a[v,u]:=a[u,v];
end;
close(f);
8 h 54 m 28/7/2017
188
Thầy Trần Thông Quế
for i:=1 to n do tree[i]:=i;
for i:=1 to n do
for j:=1 to n do
if a[i,j]=0 then
if (test[i] and test[j]) then
a[i,j]:=max
else if (not test[i] and not test[j]) then
a[i,j]:=-10000;
trongso:=0;
end;
Procedure Timmax(var u,v:integer);
Var temp:integer;
i,j:integer;
max:integer;
Begin
max:=-maxint;
for i:=1 to n-1 do
for j:=i+1 to n do
if tree[i]<>tree[j] then
if max
Procedure Ghepcap(ok,u,v:integer);
var i,tam:integer;
Begin
if a[u,v]<>max then
trongso:=trongso+a[u,v];
canh[ok,1]:=u;
canh[ok,2]:=v;
tam:=tree[v];
for i:=1 to n do
if tree[i]=tam then tree[i]:=tree[u];
end;
Procedure Creat;
Var ok,u,v:integer;
Begin
for ok:=1 to n-1 do
begin
Timmax(u,v);
Ghepcap(ok,u,v);
end;
end;
Procedure Print;
Var i:integer;
8 h 54 m 28/7/2017
189
Thầy Trần Thông Quế
Begin
Assign(f,fo);
rewrite(f);
writeln(f,trongso);
for i:=1 to n-1 do
if a[canh[i,1],canh[i,2]]<>max then
writeln(f,canh[i,1]:2,canh[i,2]:2,a[canh[i,1],canh[i,2]]:2);
close(f);
end;
{Main Prog.}
Begin clrscr;
Nhap;
Creat;
PRINT;
Write('Done!');
ENd.
2/ Bài toán 2
Có n lọ hoa và k bó hoa được đánh số thứ tự từ nhỏ tới lớn. Cần cắm k bó hoa vào n lọ sao cho hoa có số
thứ tự nhỏ phải đứng trước hoa có số thứ tự lớn. Giá trị thẩm mỹ khi cắm bó hoa i vào lọ j là v(i, j). Hãy tìm
một cách cắm hoa sao cho tổng giá trị thẩm mỹ là lớn nhất. Biết rằng mỗi bó hoa chỉ được cắm vào một lọ
và mỗi lọ chỉ cắm một bó hoa.
Dữ liệu vào cất trên text file với tên Camhoa.In gồm :
*Dòng 1: ghi 2 số n và k.
* k dòng tiếp theo mỗi dòng ghi n số nguyên dương với số ở hàng i cột j biểu thị giá trị thẩm mỹ bó hoa i
cắm vào lọ j.
Kết quả ghi lên text file với tên Camhoa.Ou gồm :
*Dòng đầu: In tổng giá trị thẩm mỹ lớn nhất:
* k dòng tiếp theo mỗi dòng ghi 2 số i, j biểu thị bó hoa i cắm vào lọ j. Một trường hợp cụ thể của bài toán
ghi ở bên phải các dòng này.
Camhoa.In
4 3
7 8 9 10
10 9 8 7
5 6 7 8
Camhoa.Ou
24
1 1
2 2
3 4
Để giải bài này ta dùng QUY HOẠCH ĐỘNG
a- DIỄN TẢ THUẬT TOÁN BẰNG NGÔN NGỮ TỰ NHIÊN: Dữ liệu của bài toán có thể biểu diễn nhờ
đồ thị 2 phía: một phía là k bó hoa, một phía là n lọ hoa và yêu cầu ghép cặp (có 2 điều kiện). Ta dùng mảng
2 chiều L[i, j] để lưu tổng giá trị thẩm mỹ lớn nhất khi ghép (cắm) bó hoa i với (vào) lọ j. Bài toán yêu cầu
khi ghép phải đảm bảo: bó hoa có số thứ tự bé phải đứng trước bó hoa có số thứ tự lớn, nên mảng L xác
định như sau:
* Nếu i > j thì không có cách ghép cặp.
8 h 54 m 28/7/2017
190
Thầy Trần Thông Quế
* Nếu i = j thì L[i, j] = v[1, 1] + v[2, 2] + ... + v[i, i].
* Nếu i < j thì L[i, j] = Max(L[i—1,j —1] + v[i, j], L[i, j — 1]).
b-CODE (QUY HOẠCH ĐỘNG)
Program CAMHOA;
Uses Crt;
Const max=100;
Var v:Array[1..max,1..max] of integer;
L:Array[0..max,0..max] of longint;
cap:Array[1..max] of integer;
n, k:integer; f:text;
Procedure Doc;
Var i,j:integer;
Begin
Assign(f,'Bt2.In'); Reset(f);
Readln(f,n,k);
For i:=1 to k do
For j:=1 to n do Read(f,v[i,j]);
close(f);
End;
Function Lonnhat(x,y:integer):integer;
Begin
If (x>y) Then Lonnhat:=x else Lonnhat:=y;
End;
Function Thamymax(i:integer):integer;
Var j, s:integer;
Begin
s:=0;
For j:=1 to i do
s:=s+v[j,j];
thamymax:=s;
End;
Procedure Xuly;
Var i,j:Integer;
Begin
For i:=1 to max do
For j:=1 to max do L[i,j]:=-maxint;
For i:=1 to k do
For j:=1 to n do
If i=j Then L[i,j]:=ThamyMax(i)
Else If i
Procedure Xuat;
Var i,j,d:integer;
Begin
Assign(f,'Camhoa.ou'); Rewrite(f);
Writeln(f,'Tong max cua do tham my:',L[k,n]);
8 h 54 m 28/7/2017
191
Thầy Trần Thông Quế
i:=k; j:=n; d:=0;
While (i>0) And (j>0) do
If (L[i,j]=L[i,j-1]) And (v[i,j]>0) Then
Begin
Cap[i]:=j-1;
Dec(j);
End
Else Begin cap[i]:=j; dec(i); dec(j) End;
For i:=1 to k do
Writeln(f,'Bo hoa thu ',i,' cam vao lo ',cap[i]);
Close(f);
End;
Procedure Xem;
Var f:text; line:string;
Begin
Assign(f,'Camhoa.ou'); Reset(f);
Writeln(#32:13,'KET QUA PROGRAM:');
Writeln;
While not (seekeof(f)) do
Begin
Readln(f,line);
Writeln(#32:7,line);
End;
close(f);
End;
{Main Prog.}
Begin clrscr;
Doc;
Xuly;
Xuat;
Xem;
Write('Done!');
Readln;
End.
3/Bài toán 3. Một sản phẩm có N chi tiết, mỗi chi tiết phải lần lượt gia công trên hai máy A, B (A trước,
B sau). Thời gian để gia công chi tiết trên máy A là Ai, trên máy B là Bi (i = 1,2,...,N). Hãy lập lịch hoàn
thành các chi tiết với thời gian ít nhất.
Dữ liệu vào cất trên text file với tên Bt3.In gồm :
*Dòng đầu tiên ghi số n.
*N dòng tiếp theo, dòng i + 1 là số ai và bi.
Kết quả ghi lên text file với tên Bt3.Ou gồm :
* Dòng đầu ghi thời gian ít nhất gia công các chi tiết.
*Dòng thứ hai ghi số hiệu các việc đã thực hiện theo lịch tối ưu.
Ví dụ:
Bt3.In
5
3 3
4 3
8 h 54 m 28/7/2017
192
Thầy Trần Thông Quế
6 2
5 7
6 3
Bt3.Ou
26
1 4 2 5 3
ĐỂ GIẢI BÀI NÀY TA DÙNG THUẬT TOÁN JONSON
CODE THAM KHẢO (CHƯA TEST)
Program Johnson_Algo ;
Uses Crt ;
Const ln=100; f1=’Bt3.In’; fo=’Bt3.Ou’;
Type m1=Array[1..2, 1..ln] of Real;
kq=Array[1..ln] of Byte;
mdx=Array[1..ln] of Boolean;
Var a:m1; {a[1,j] luu thoi gian chi tiet j tren may A; A[2,j] luu thoi gian chi tiet j tren may B}
resul:kq; {ket qua xep lich}
dx:mdx; {danh dau chi tiet da lam}
n :Byte ;
f :Text ;
Procedure Nhap;
Begin
{Đọc số N và các giá trị A[2,n] vào chương trình, các con tự làm (XEM LẠI PHẦN RECORD & FILE!)}
End ;
Function ChitietMin(var may :Byte) :Byte ;
Var Lmin:integer; chitiet:byte;
Begin
Lmin:=Maxint;
For i:=1 to 2 Do
For j:=n Downto 1 Do
If Not dx[j] then
If a[i,j]
193
Thầy Trần Thông Quế
Resul[dau]:=chitiet;
dx[chitiet]:=True;
End;
Until dau=cuoi-1;
End;
Procedure HienThi;
Begin
{Ghi mang ket qua len file Bt4.Ou theo dung yeu cau o de ra. các con tự làm} End;
Function max2(a,b:Real):Real;
Begin
{Ham xac dinh so lon hon trong 2 so a, b cho truoc. Các con tự làm}
End;
Function Tinh;
Var i,j :Byte; t1, t2:Real;
Begin
t1:=0; t2:=0;
For i:=1 to n Do
Begin
t1:=t1+a[1, resul[i]];
t2:=max2(t1,t2)+a[2,resul[i]] ;
End ;
Writeln(f, t2 :0 :0) ;
End ;
{Main Prog.}
Begin Clrscr;
Nhap;
Johnson_algo;
Assign(f,fo); Rewrite(f);
Tinh;
HienThi;
Write(‘Done!’);
Readln;
End.
4/Bài toán 4 Có N việc. Việc thứ i hoàn thành trong thời gian ti. Các việc này được thực hiện trên M
máy (có công suất như nhau và mỗi máy đều có thể thực hiện được bất cứ việc nào trong N việc), mỗi việc
được thực hiện liên tục trên một máy cho đến khi xong. Hãy lập lịch để các máy thực hiện đủ N việc sao
cho tổng thời gian hoàn thành các việc càng ít càng tốt.
Dữ liệu vào cất trên text file với tên Bt4.In gồm:
Dòng đầu ghi 2 số N, M.
Dòng 2 ghi N số t1, t2,...,tN
Kết quả ghi lên text file với tên Bt4.Ou gồm:
Dòng đầu ghi tổng thời gian hoàn thành N việc.
M dòng sau: tại dòng i + 1 ghi số hiệu các việc thực hiện trên máy i.
Một ví dụ cụ thể của bài toán là ta có 3 máy M1, M2, M3 và 6 việc với thời gian hoàn thành tương ứng là t1
= 2, t2 = 5, t3 = 8, t4 = 1, t5 = 5, t6 = 1 với các file trên đây là:
Bt4.In
8 h 54 m 28/7/2017
194
Thầy Trần Thông Quế
6 3
2 5 8 1 5 1
Bt4.Ou
8
3
2 1 4
5 6
BÀI NÀY DÙNG THUẬT TOÁN HEURISTIC (CÁC CON CẦN VẼ BIỂU ĐỒ ĐỂ HIỂU RÕ CÁC LẬP
LUẬN SAU)
a-Diễn đạt thuật toán bằng ngôn ngữ tự nhiên (hãy tự vẽ biểu đồ để dễ hiểu thuật toán hơn)
*Tại thời điểm t = 0, thực hiện việc V2 trên máy M1, V5 trên máy M2 và V1, trên máy M3.
*Tại t = 2 việc V1 được hoàn thành, liền đó trên máy M3 thực hiện tiếp việc V4. Trong thời gian này 2 máy
M1 và M2 vẫn đang thực hiện công việc của mình ...
*Ta thấy thời gian hoàn thành cả 6 việc là 12 và các máy M1, M2 có quá nhiều thời gian nhàn rỗi. Phương
án trên đây là một phương án tồi.
Để cải thiện nghiệm của bài toán này ta thử một phương án 2 dưới đây:
+ Xếp các việc theo thứ tự giảm dần của thời gian
+ Lần lượt xếp các việc theo thứ tự ấy vào các máy còn nhiều thời gian rảnh nhất.
Như vậy thời gian hoàn thành cả 6 việc ở phương án P2 là 8. Nghiệm này đã tốt hơn nghiệm của phương án
P1: Mọi việc hoàn thành sớm hơn phương án P1 bốn đơn vị thời gian (các bạn hãy hình dung nếu đơn vị
thời gian là tháng thì kế hoạch sản xuất đã về đích trước 4 tháng — đó là khoảng thời gian rất đáng kể trong
sản xuất) và thời gian rảnh của máy M1 là ít nhất.
DÙNG HEURISTIC METHOD
b- Code. (CHƯA TEST)
Ues Crt;
Cosnt ln=1000; fi=’Bt4.In]; fo=’Bt4.Ou’;
Type m1=Array[1..ln] of Longint;
Var t:m1; {t[i]: thoi gian lam viec i; i=1..n}
id:m1; {id[i]: so hieu cua cong viec i}
phan cong may j lam viec i}p:m1; {p[i]:=j
n,m:Integer; {n: So luong cong viec ; m: so luong may}
maxt:Longint {Thoi gian cua may co thoi gian da gia cong lon nhat}
may:m1; {may[i]: Thoi gian da lam (da thuc hien gia cong) cua may i}
Procedure Nhap;
Var i:Integer;
Begin
{Doc cac data n,m vao mang t tu file Bt4.In roi lam lenh sau, }
{ con tu lam. }
For i:=1 to n do id[i]:=i;
End;
Procedure Sort(var a:m1);
Var i, j, c:integer;
Begin
{Sap xep giam mang t theo thoi gian va xep ca mang id. Vi de nen cac con tu lam}
End;
8 h 54 m 28/7/2017
195
Thầy Trần Thông Quế
Function Tim_May_min:Integer;
Begin
{Tim may co thoi gian lam nho nhat. Vi de nen cac con tu lam }
End;
Procedure Ghi;
Var f: Text; i, j: Integer; sum: Longint;
Begin
Assign(f,fo); Rewrite(f);
Writeln(f, maxt);
For j:=1 to m Do
Begin
sum:=0;
For i:=1 to n Do
If p[i]:=j then
Begin
Writeln(f, id[i]:4) ; {In ra so hieu cua may i}
sum:=sum+t[i];
End;
Writeln(f,’ Tong thoi gian da lam cua may ‘, j ,’:’, sum);
End;
Close(f);
End;
Procedure Phancong;
Var i,j,Lj:Integer; Ok: Boolean;
Begin
FillChar(may, sizeof(may), 0);
FillChar(p ,sizeof(p), 0);
i:=0; maxt:=-maxint;
For j:=1 to m do {giao m viec dau cho m may}
Begin
Inc(i);
may[j]:=t[i];
p[i]:=j;
If t[i]>maxt then maxt:=t[i];
End;
Inc(i);
While i<=n Do
Begin
Ok:=False;
For j:=1 to m do
Begin
If i>n then Break;
If may[j]+t[i]<=maxt then
Begin
ok:=true;
may[j]:=may[j]+t[i];
p[i]:=j; {Giao viec i cho may j}
Inc(i);
8 h 54 m 28/7/2017
196
Thầy Trần Thông Quế
End;
End;
If not ok then
If i<=n then
Begin
j:=Tim_May_min ;
may[j]:=may[j]+t[i];
p[i]:=j; {Giao viec moi cho may j da co thoi gian lam it nhat}
If may[j]> maxt the maxt:=may[j];
End;
End;
End;
{ Main Prog.}
Begin clrscr;
Nhap;
Sort(t);
Phancong;
Ghi;
Write(‘Done!’);
Readln;
End.
MỘT VÀI BÀI ĐỂ CÁC BẠN TỰ LUYỆN
LT1. Một xí nghiệp có N công nhân và dây chuyền sản xuất có M máy (M < N).. Nếu giao máy i cho công
nhân j làm thì sẽ đạt lợi nhuận là C[i, j]. Hãy tìm cách bố trí công nhân và máy sao cho không quá một công
nhân đứng một máy và mỗi máy không có nhiều hơn một công nhân để tổng lợi nhuận lớn nhất.
LT2. Có N việc, mỗi việc i phải làm trước một số việc nào đó trong N việc này. Hãy lập lịch thực hiện đủ N
việc đã cho.
Dữ liệu vào cất trên text file với tên Lt2.In gồm :
* Dòng đầu ghi số nguyên dương N.
* Các dòng kế sau ghi các số biểu thị thứ tự bộ phận: đầu dòng là số i, kế sau là các số Ji1, Ji2,,..., Jis có
nghĩa là việc i phải làm trước các việc Ji1, Ji2,..., Jis.
Kết quả ghi lên text file với tên Lt2.Ou chỉ có một dòng ghi số hiệu các việc đã lần lượt được thực hiện.
Lt2.In
10
1 2 3
2 4 10
3 5
4 6 8
Lt2.Ou
1 2 7 9 4 6 3 5 8 10
LT3. Có N việc. Với mỗi việc cho biết tiền công phải trả cho người làm thuê, thời gian để hoàn thành việc,
thời điểm kết thúc việc. Hãy xếp lịch sao cho người làm thuê thu được nhiều tiền công nhất.
Dữ liệu vào cất trên text file với tên Lt3.In gồm :
* Dòng đầu là số nguyên dương N.
** N dòng sau, dòng i + 1 ghi 3 số: thời gian hoàn thành công việc t, thời điểm kết thúc công việc k và tiền
công tc.
Kết quả ghi lên text file với tên Lt3.Ou gồm :
8 h 54 m 28/7/2017
197
Thầy Trần Thông Quế
* Dòng đầu là tổng tiền công lớn nhất.
* Các dòng tiếp theo mỗi dòng ghi 4 số: số hiệu công việc i, thời điểm bắt đầu
công việc t1, thời điểm kết thúc công việc t2, tiền công tc.
Thuật toán :
* Xếp tăng bộ dữ liệu theo khoá là thời điểm cuối cùng phải kết thúc công việc.
Lt3.In
10
1 4 89
5 5 86
4 11 83
5 7 84
1 2 25
3 11 61
6 11 33
4 7 28
3 10 1
5 14 71
Lt3.Ou
329
5 0 1 25
1 1 2 89
3 2 6 83
6 6 9 81
10 9 14 71
LT4- Có N việc đánh số từ 1 đến N cần được bố trí thực hiện trên một máy. Biết:
* pi là thời gian để hoàn thành việc i.
* di là thời điểm cuối cùng phải kết thúc việc i.
* hi là hệ số thưởng phạt của việc i.
ti). Thời điểm bắt đầu thực hiện các việc là 0, hãy lập trình tự thực hiện N việc sao cho tổng giá trị thưởng
phạt của tất cả các việc là lớn nhất.Mỗi việc phải thực hiện liên tục từ lúc bắt đầu cho tới lúc kết thúc,
không cho phép ngắt quãng. Coi như thời gian chuyển từ việc này sang việc khác bằng 0. Giả sử ti là thời
điểm hoàn thành việc i, khi đó giá trị thưởng, phạt việc i là hix(di
Dữ liệu vào cất trên text file với tên Bt8.In gồm:
*Dòng đầu ghi số nguyên dương N (N < 2001)
* Dòng 2 ghi N số nguyên dương p1,...,pN.
* Dòng 3 ghi N số nguyên dương d1,...,dN.
* Dòng 4 ghi N số nguyên dương h1,...,hN.
Kết quả ghi lên text file với tên Bt8.Ou gồm :
* Dòng đầu ghi giá trị thưởng phạt lớn nhất tìm được.
* Dòng 2 ghi N số là trình tự thực hiện các việc.
Ví dụ:
Test_1
Lt4.In
5
2 2 3 4 3
3 2 10 11 9
1 2 2 1 3
8 h 54 m 28/7/2017
198
Thầy Trần Thông Quế
Lt4.Ou
6
2 5 3 1 4
Test_2
Lt4_2.In
4
1 2 3 4
3 2 1 3
1 2 1 2
Lt4_2.ou
-17
1 2 3 4
Mọi ý kiến đóng góp gửi về MailBox của thầy là: quethongtran@yahoo.com
8 h 54 m 28/7/2017
199
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
200
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
201
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
202
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
203
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
204
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
205
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
206
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
207
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
208
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
209
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
210
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
211
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
212
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
213
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
214
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
8 h 54 m 28/7/2017
3
Thầy Trần Thông Quế 5- Đọc từ bàn phím vào 4 số thực mà trị của chúng thuộc khoảng [-3,0, 3,0]. Tính trị trung bình cộng của chúng.
Test Vào -3 2 1.85 -1.05; Ra: Tong=-0.20; Trung binh cong=-0.4
Uses crt; Var s1,s2,s3,s4,tbc,t:Real; d:byte; Begin clrscr; Write('s1,s2,s3,s4=');readln(s1,s2,s3,s4); tbc:=0;t:=0;d:=0; If (s1>=-3.0) and (s1<=3.0) then Begin Inc(d); t:=t+s1; End; If (s2>=-3.0) and (s2<=3.0) then Begin Inc(d); t:=t+s2; End; If (s3>=-3.0) and (s3<=3.0) then Begin Inc(d); t:=t+s3; End; If (s4>=-3.0) and (s4<=3.0) then Begin Inc(d); t:=t+s4; End; tbc:=t/d; Writeln('Tong cua cac so trong khoang [-3.0,3.0]=',t:0:2); Write(' va Trung binh cong cua chung =',tbc:0:2); Readln; End.
6- Lập trình đọc từ bàn phím vào một năm dương lịch, in lên màn hình tên năm âm lịch ứng với năm dương lịch vừa nhập vào. Ví dụ. vào:2016, ra: Bính Thân.
Uses crt; Var Year:integer; Begin clrscr; Write('Cho biet nam duong lich:'); Readln(Year); Write('Nam ',year,' la nam am lich:'); Case (Year Mod 10) of 0:Write('Canh '); 1:Write('Tan '); 2:Write('Nham '); 3:Write('Quy ');
8 h 54 m 28/7/2017
4
Thầy Trần Thông Quế 4:Write('Giap '); 5:Write('At '); 6:Write('Binh '); 7:Write('Dinh '); 8:Write('Mau '); 9:Write('Ki '); End; Case (Year Mod 12) of 0:Write('Than'); 1:Write('Dau'); 2:Write('Tuat'); 3:Write('Hoi'); 4:Write('Ty'); 5:Write('Suu'); 6:Write('Dan'); 7:Write('Mao'); 8:Write('Thin'); 9:Write('Ti'); 10:Write('Ngo'); 11:Write('Mui'); End; Readln; End.
7- Lập trình cho biết số La Mã tương ứng của số thập phân bất kỳ đọc từ bàn phím vào.
Ví dụ vào: 2017; ra:MMXVII.
Write('M');
Begin
Program ThapPhan_LaMa; uses crt; var n:integer; ans:char; Begin clrscr; Repeat Write('Nhap so Thap phan can chuyen:'); Readln(n); Write(n,' ---> Viet theo chu so La ma la:'); While n>=1000 do Begin n:=n-1000; End; If n>=900 then Write('CM'); n:=n-900; End; If n>=500 then Begin Write('D'); n:=n-500; 8 h 54 m 28/7/2017
5
Thầy Trần Thông Quế End; If n>=400 then Begin Write('CD'); n:=n-400; End; If n>=100 then Begin Write('C'); n:=n-100; eND; If n>=90 then Begin Write('XC'); n:=n-90; End; If n>=50 then Begin Write('L'); n:=n-50; End; If n>=40 then Begin Write('XL'); n:=n-40; End; If n>=20 then Begin Write('XX'); n:=n-20; End; If n>=10 then Begin Write('X'); n:=n-10; End; If n=9 then Begin Write('IX'); n:=n-9; End; If n>=7 then Begin Write('VII'); n:=n-7; End; If n>=5 then Begin Write('V');
8 h 54 m 28/7/2017
6
Thầy Trần Thông Quế n:=n-5; End; If n=4 then Begin Write('IV'); n:=n-4; End; If n=3 then Begin Write('III'); n:=n-3; End; If n=2 then Begin Write('II'); n:=n-2; End; If n=1 then Begin Write('I'); n:=n-1; End; Writeln; Writeln; Write(' ANOTHER TEST (Y/N)?'); Readln(ans); Until Ans In ['n','N']; End.
8- (BÀI TOÁN NGƯỢC CỦA BÀI 7). Lập trình cho viết số Thập Phân tương ứng của số La Mã đọc từ bàn phím vào.. Ví dụ. vào: MMXVII, ra: 2017.
(BÀI NÀY KHÓ HƠN BÀI TRÊN)
Program LaMa_ThapPhan; Uses crt; Var s:string; Procedure Nhap; Begin Writeln; Write('Nhap vao so Lama:'); Readln(s); End; Function GtriThphan(s:string; i:integer):Integer; Var x:integer; Function Val(c:char):Integer; Begin Case c of 'M','m':Val:=1000; 'D','d':Val:=500; 'C','c':Val:=100; 'L','l':Val:=50; 8 h 54 m 28/7/2017
7
Thầy Trần Thông Quế
'X','x':Val:=10;
'V','v':Val:=5;
'I','i':Val:=1;
Else Val:=0;
End;
End;
Begin
x:=val(s[i]);
If i=Length(s) Then GtriLama:=x
Else If x
8 h 54 m 28/7/2017
8
Thầy Trần Thông Quế
End;
Readln;
End.
10- Không dùng thuật toán xử lý mảng 2-chiều, chỉ dùng các biến đơn, lập trình in lên màn hình bảng ziczac
chứa 100 số tự nhiên đầu tiên (Bạn có làm được bài này trong 10 phút không?)
0 1 2 3 4 5 6 7 8 9
10 11 12 13 14 15 16 17 18 19
- - - - - - - - - - - - - - - - - - - - - -
90 91 92 93 94 95 96 97 98 99
KHÔNG THỂ CÓ CODE NÀO NGẮN HƠN CODE DƯỚI ĐÂY!
Uses crt;
Var i,j:Byte;
Begin clrscr;
For i:=0 to 9 do
begin
For j:=0 to 9 do
Write(10*i+j:4);
Writeln;
end;
Readln;
End.
11- Dùng ký tự '*', lập trình tạo tam giác cân rỗng. In kết quả lên màn hình. (Bạn có làm được bài này trong
10 phút không?)
Uses Crt;
Var chcao,i: Byte;
Begin clrscr;
Write('Nhap chieu cao tam giac:'); Readln(chcao);
Writeln('*':chcao);
For i:=2 to chcao-1 do
Writeln('*':chcao-i+1,'*':2*i-2);
For i:=1 to 2*chcao-1 do
Write('*');
Writeln;
Writeln;
Readln;
End.
12- Nhập một dãy số nguyên từ bàn phím vào, lập trình tìm trong dãy ấy bộ (không kể thứ tự) 3 số liên tiếp
có tổng bằng số M cho trước.
Uses Crt;
Var a:array[1..1000] of integer;
n,i,j,k,M:integer;
Begin clrscr;
Writeln;
8 h 54 m 28/7/2017
9
Thầy Trần Thông Quế
Write(#32:2,'M='); Readln(M);
Write('n='); Readln(n);
For i:=1 to n do
Begin
Write('a[',i,']='); Readln(a[i]);
End;
Writeln('Cac bo so trong day thoa man yeu cau bai toan la:');
For i:=1 to n do
For j:=1 to n-1 do
For k:=j+1 to n do
if (i<>j) and (i<>k) and (j<>k) and (a[i]+a[j]+a[k]=M) then
Writeln(a[i]:3,a[j]:3,a[k]:3)
Readln;
End.
13- Lập trình tìm tất cả các số hoàn hảo của số n tùy ý đọc từ bàn phím vào. Yêu cầu xuất kết quả theo Form
sau:
Chẳng hạn, Vào: 1200,
Ra:
Số hoàn hảo thứ nhất: 6
Và các ước của nó là: 1 2 3
= = = = = = = = = = = = = = = = =
Số hoàn hảo thứ hai: 28
Và các ước của nó là: 1 2 4 7 14
= = = = = = = = = = = = = = = = =
. . . . . . . . . . . . . . . . . .
Uses crt;
Var i,j,n,tong_uoc,dem:longint; tt:byte;
Begin clrscr;
Repeat
Write('Nhap so nguyen duong n:'); Readln(n);
dem:=0;
For i:=1 to n Do
Begin
tong_uoc:=0;
For j:=1 to i-1 Do
If(i MOD j=0) Then tong_uoc:=tong_uoc+j;
If tong_uoc=i Then
Begin
dem:=dem+1;
Writeln('* So hoan hao thu ', dem,' la:',i);
Write('* va cac uoc so cua no la:');
For j:=1 to i-1 Do
If (i MOD J=0) Then Write(j,' ');
Writeln;
Writeln('= = = = = = = = =');
Writeln;
8 h 54 m 28/7/2017
10
Thầy Trần Thông Quế
End;
End;
Write('More (1/0)?. Come On -> Press 1; Stop -> Press 0:');
Readln(tt);
Until tt=0;
End.
*14- Kiểm tra giả thiết Goldbach – Snhirenman: “Mọi số tự nhiên CHẴN lớn hơn 2 đều có thể biểu diễn
bằng TỔNG của HAI số NGUYÊN TỐ”.
(Giả thiết Christian Goldbach – nhà toán học Đức – Nửa đầu thế kỉ XVIII, năm 1742 trong thư gửi Euler,
Goldbach viết: “Mọi số lẻ bất kỳ đều viết được dưới dạng tổng của ba số nguyên tố “. Sau này mệnh đề đó
được gọi là bài toán Goldbach (hay giả thiết Goldbach)
Hơn 250 năm bài toán Goldbach vẫn chưa được chứng minh, và cho đến năm 1930, nhà toán học Nga L. G.
Snhirenman mới chỉ chứng minh trường hợp nhỏ của giả thiết: “Mọi số chẵn n ≥ 4 đều có thể biểu diễn
thành tổng của 2 số nguyên tố”).
Uses crt;
Var so1, so2, so3, so4: integer;
kt1, kt2: boolean; {kt=kiem tra}
hoi:char;
Begin clrscr;
Repeat
Write(‘Nhap so chan so1>2:’); Readln(so1);
so2:=2;
Repeat
so3:=so1-so2;
so4:=2;
While (so4<=sqrt(so2)) And (so2 Mod so4<>0) do
Inc(so4);
If so4>sqrt(so2) then kt1:=true Else kt1:=false;
so4:=2;
While (so4<=sqrt(so3)) And (so3 Mod so4<>0) do
Inc(so4);
If so4>sqrt(so3) then kt2:=true Else kt2:=false;
Inc(so2);
Until (so3<=2) Or (kt1 and kt2);
If kt1 and kt2 then Write(‘GIA THIET GOLDBACH DUNG.’)
Else Write(‘GIA THIET GOLDBACH SAI.’);
Writeln;
Write(‘Another test (y/n)?’); Readln(hoi);
Until hoi In [‘N’, ‘n’];
End.
*15- Tìm và liệt kê tất cả các số Mersenne nhỏ hơn một số tự nhiên N cho trước (với n>=3)-Các số nguyên
tố biểu diễn được dưới dạng 2n – 1 (n-số tự nhiên) gọi là số Mersenne-
uses Crt;
Var so, n, i, ntmin:longint;
8 h 54 m 28/7/2017
11
Thầy Trần Thông Quế
check, stop: Boolean; tt:Byte;
Begin clrscr;
Repeat
Write(‘Nhap n>=3:’); Readln(n);
stop:=false;
ntmin:=2;
Writeln(#32:20,’CAC SO MERSENNE:’);
While Not stop Do
Begin
i:=2;
While (i<=sqrt(ntmin)) And (ntmin MOD i<>0) Do
Inc(i);
If i>sqrt(ntmin) then check:=true Else check:=false;
If check then
Begin
so:=1;
For i:=1 to ntmin do so:=2*so;
Dec(so,1);
i:=2;
While (i<=sqrt(so)) And (so MOD i<>0) do Inc(i);
If i>sqrt(so) then check:=true
Else check:=false;
stop:=so>n;
If check and Not stop Then
Writeln(so);
End;
Inc(ntmin);
End;
Writeln;
Write(‘Another Test (1/0)?, Come on -) press 1; Stop -> press 0:’);
Readln(tt);
Until tt=0;
End.
16- Không dùng thuật toán đệ quy, lập trình tìm và in lên màn dãy FIBONACI với độ dài cho trước n.
Program Day_Fibo;
Uses crt;
Var i,n,f1,f2,fi,fi_1,fi_2:Integer;
Begin clrscr;
Write(‘Nhap do dai day Fibonaci n=’); Readln(n);
Writeln(‘ DAY FIBONACI UNG VOI DO DAI ‘,N,’ LA:’);
Writeln;
i:=1; f1:=1;f2:=1;
fi:=f1+f2;
Write(f1:3, f2:3);
For i:=3 to n Do
Begin
8 h 54 m 28/7/2017
12
Thầy Trần Thông Quế
Write(fi:5);
f1:=f2;
f2:=fi;
fi:=f1+f2;
End;
Readln;
End.
17- Lập trình (PHI ĐỆ QUY) tìm ước số chung lớn nhất của N số tùy ý đọc từ bàn phím vào.
Test. Vào: 72 40 24 48 56, Ra: 8
Uses Crt;
Var a:Array[1..100] of integer;
n,i,tt: Byte; d: Integer;
Begin Clrscr; {Có lẽ bạn nên dùng PHÁT SINH DỮ LIỆU NGẪU NHIÊN TỰ ĐỘNG, sẽ nhanh hơn!}
Repeat
{Randomize;}
Write(‘ Nhap so luong cac so hang n:’); Readln(n);
For i:=1 to n Do
Begin
Write(‘a[‘,i,’]=’); Readln(a[i]);
End; {a[i]:=Random(20);}
Writeln(‘Day so vua nhap:’);
For i:= 1 to n Do Write(a[i]:3);
Writeln;
Writeln(‘= = = = = = = = = = = = = = =’);
For i:=1 to n-1 do
Repeat
d:=a[i];
a[i]:=a[i+1] MOD a[i];
a[i+1]:=d;
Until a[i]=0;
Write(‘USC max cua ‘,n,’ so vua nhap la:’,a[n]); Writeln;
Write(‘More(1/0)? Continue - > 1, Stop -> 0:’); Readln(tt);
Until tt=0;
End.
18- Tìm nghiệm nguyên dương của phương trình sau:
a) 4x+3y-9z=n, với 0 ≤ x, y, z ≤ 50; n- đọc từ bàn phím vào.
Không áp đặt trước miền giá trị của x, y, z hãy tìm nghiệm nguyên dương của các phương trình sau:
b) x + y + z = n ; n- đọc từ bàn phím vào.
c) x2 + y2 = n; n- đọc từ bàn phím vào.
Bài a)
Uses Crt;
Var x,y,z,n,d:integer;
8 h 54 m 28/7/2017
13
Thầy Trần Thông Quế
Begin clrscr;
Write(‘Nhap n:’); Readln(n);
d:=0;
For x:=0 to 50 do
For y:=0 to 50 do
For z:=0 to 50 do
If ((4*x+3*y-9*z)=n) then
Begin
Writeln(x:4,y:4,z:4);
Inc(d);
If (d MOD 20)=0 then
Begin
Write(‘Go ENTER -> xem tiep.’);
Readln;
End;
End;
End.
Các bài còn lại làm tưong tự.
19- Lập trình tạo bảng ba cột GÓC SIN COS, tính giá trị hàm Sin, Cos ứng với góc
ở cột cận trái. (Vì có từ góc 0o đến 360o nên yêu cầu mỗi lần chỉ hiện lên màn 20 giá trị kết quả, để XEM
TIẾP: gõ phím ENTER.)
Uses Crt;
Var goc:word;
gocradian: Real;
Begin clrscr;
Writeln(#32:9,’BANG GIA TRI GOC, SIN, COS:’);
Writeln(‘ Nho an ENTER de xem tiep.’);
For goc:=1 To 360 Do
Begin
gocradian:=goc*pi/180;
Writeln(#32:24,goc,#32:5,sin(gocradian):0:4,#32:3,cos(gocradian):0:4);
If (goc MOD 20) = 0 then Readln;
End;
End.
B.2.2) CÁC LỆNH LẶP KHÔNG XÁC ĐỊNH (WHILE. . .DO; REPEAT…UNTIL)
Lập trình giải các bài toán sau:
20- Tính gần đúng với sai số 10^-6 (1/1000000): số Pi; sinx; cosx; e^x.
a) Tính gần đúng số PI.
8 h 54 m 28/7/2017
14
Thầy Trần Thông Quế
Program tinhgandung_So_Pi;
Uses Crt;
Const ss=1E-6
Var sp: Real; n, dau: integer;
Begin clrscr;
n:=0;
sp:=0;
While (1/(2*n+1))>=ss do
Begin
If n MOD 2 = 0 then dau:=1
Else dau:=-1;
sp:=sp+dau*(1/(2*n+1));
n:=n+1;
End;
Write(‘Gia tri gan dung cua so Pi=’,4*sp:8:4);
Readln;
End.
b) TÍNH GẦN ĐÚNG SINX BỞI CÔNG THỨC TRUY HỒI RÚT GỌN CÒN 1 SỐ HẠNG
Lời nhắc không thừa:
+ Đối số x trong các hàm sin, cos ở đây cần hiểu ngầm có đơn vị đo là Radian (Trong mọi Program
để nó như một hư số).
+ và có LỜI NHẮC QUAN TRỌNG HƠN: Hãy test program với bộ số sau:
x=0 hoặc x=3.1416 (= ) sinx=0; x=1.5708 (=/2) sinx=1; x=4.7124 (=3/2) sinx=-1
và trong đầu luôn có hình ảnh Vòng Tròn Đơn Vị:
Uses Crt;
Const ss=1E-6;
Var x,S,T: Real; n: Integer; hd:char;
Begin Clrscr;
Repeat
Write(‘Nhap vao cung x (Radian)cua ham Sin:’);
Readln(x);
S:=x; T:=x; n:=0;
While ABS(T)>=ss Do
Begin
n:=n+2;
T:=-T*SQR(x)/(n*(n+1));
S:=S+T;
End;
8 h 54 m 28/7/2017
15
Thầy Trần Thông Quế
Write(‘Sin(x)=’,S:0:6);
Writeln;
Write(‘More (y/n)? Come on -> Press y; Stop -> Press n:’);
Readln(hd);
Until hd In [‘n’,’N’];
End.
HAI HÀM CÒN LẠI LÀM TƯƠNG TỰ! ĐỂ Ý:
21- Phân tích một số tự nhiên ra các thừa số nguyên tố.
Program Thua_so_nguyen_to; {Repeat và While lồng nhau}
Uses crt;
Var n,i:longint;
Begin clrscr;
Write(‘n=’);Readln(n);
Writeln(‘Cac thua so nguyen to cua ‘,n,’ la:’);
Repeat
i:=2;
While (n Mod i<>0) AND (i
22- Giả sử dân số Việt Nam năm 2017 là 96 triệu dân và tỷ lệ bình quân tăng dân số hàng năm là 3/1000.
Tính xem SỚM NHẤT đến năm nào thì dân số nước ta đạt 110 triệu dân.
Uses Crt;
Const tyle=0.003;
Var ds:Real; nam: Integer;
Begin clrscr;
Write(‘Nhap dan so hien tai:’); Readln(ds);
nam:=2017;
While (ds<=110*1E+6) Do
Begin
Inc(nam);
ds:=ds*(1+tyle);
End;
Write(‘Som nhat den nam ‘,nam,’ dan so nuoc ta dat 110 trieu dan.’);
8 h 54 m 28/7/2017
16
Thầy Trần Thông Quế
Readln;
End.
23- Cho trước số nguyên dương n có nhiều hơn 1 chữ số. Đếm số chữ số của số đó và tính tổng của chúng.
Chẳng hạn, vào: 9876543, ra: 7 và 42
Uses crt;
Var n,dem,tong:Longint;
Begin clrscr;
Write(‘Nhap so nguyen duong nhieu hon 1 chu so:’);
Readln(n);
tong:=0; dem:=0;
While n>0 Do
Begin
Inc(dem);
tong:=tong+n MOD 10;
n:=n DIV 10;
End;
Writeln(‘Tong cac chu so cua so vua nhap:’,tong);
Writeln(‘So cac chu so cua so vua nhap=’,dem);
Readln;
End.
24- Thực hiện phép chia bằng phép trừ.
Program Chia_la_tru;
Uses crt;
Var Sobichia, Sochia,Thuong, du:Longint; hoi:char;
Begin clrscr;
REPEAT
Write(‘Nhap Sobichia:’) ; Readln(Sobichia);
Write(‘Nhap Sochia<=Sobichia:’) ; Readln(Sochia);
Thuong:=0;
While (Sochia<=Sobichia) Do
Begin
Sobichia:=Sobichia-sochia;
thuong:=thuong+1;
End;
du:=Sobichia;
Writeln(‘Thuong=’,Thuong);
Writeln(‘So du=’,du);
Writeln;
Write(‘Another Test (y/n)?:’); Readln(hoi);
UNTIL hoi In [‘n’,’N’];
End.
25- Lập trình đảo ngược một số nguyên dương (PHI ĐỆ QUY) cho trước có nhiều hơn 1 chữ số. Ví dụ vào
2017, ra: 7102.
8 h 54 m 28/7/2017
17
Thầy Trần Thông Quế
USES CRT;
Var sovng, n, dv:longint;
Begin clrscr;
Write(‘n=’); Readln(n);
sovng:=0;
While (n>0) do
Begin
dv:=n MOD 10;
sovng:=10*sovng+dv; {sovng=số viết ngược}
n:=n DIV 10;
End;
Write(‘So viet nguoc lai la:’,sovng);
Readln;
End.
26- Tìm ước số chung lớn nhất của hai số nguyên dương cho trước nhờ thuật toán Euclide:
26.1) Dùng phép trừ
26.2) Dùng phép chia
ĐÁP:
26.1)
Uses crt;
Var a,b,d:integer;
Begin clrscr;
Write(‘Nhap 2 so nguyen duong:’); Readln(a,b);
While (a-b<>0) Do
Begin
if a>b then a:=a-b
else b:=b-a;
End;
Write(‘Uscmax=’,b);
Readln;
End.
26.2)
Uses crt;
Var a,b,du:integer;
Begin clrscr;
Write(‘Nhap 2 so nguyen duong:’); Readln(a,b);
While (b<>0) Do
Begin
du:=a Mod b;
a:=b;
b:=du;
End;
Write(‘Uoc so chg max=’,a);
Readln;
End.
8 h 54 m 28/7/2017
18
Thầy Trần Thông Quế
*27- Đọc từ bàn phím vào một số nguyên dương N (N>1). Tìm chữ số lớn nhất trong số vừa nhập và vị trí
của nó trong số vừa nhập. Hiện kết quả lên màn.
Program Tim_Chuso_Max;
uses crt;
Var so,i,max,temp,vitri:longint;
BEGIN Clrscr;
write(‘Nhap so :’); readln(so);
writeln(‘Trong so ‘,so,’ vua nhap ‘);
max:=0;
i:=1;
while (so<>0) do
Begin
temp:=so mod 10;
if temp>max then
Begin
max:=temp;
vitri:=i;
End;
i:=i+1;
so := so div 10;
End;
Write(‘ thi chu so ‘, max,’ la chu so lon nhat va nam o vi tri thu ‘,vitri);
Write(‘ ke tu ben phai sang.’);
readln;
END.
*28- Cho trước số tự nhiên N (ví dụ 100). Tìm & hiện lên màn tất cả các cặp số nguyên tố sinh đôi mà giá
trị của chúng không quá N. ( Hai số nguyên tố sinh đôi là hai số hơn kém nhau 2 đơn vị)
Uses crt;
Var so1, so2, so3, so4, n, dem: longint;
kt1, kt2: boolean; {kt=kiem tra}
Begin clrscr;
Write(‘Nhap so tu nhien n:’); Readln(n);
Writeln(‘Cac cap so sinh doi < n:’);
For so1:=2 to n-2 do
Begin
so4:=2;
While (so4<=sqrt(so1)) And (so1 MOD so4<>0) do
Inc(so4);
If so4>sqrt(so1) then
Begin
so2:=so1;
so3:=so2+2;
so4:=2;
While (so4<=sqrt(so3)) And (so3 Mod so4<>0) do Inc(so4);
If so4>sqrt(so3) then
Begin
8 h 54 m 28/7/2017
19
Thầy Trần Thông Quế
Inc(dem);
Writeln(dem,’:’,’(‘,so2,’,’,so3,’)’);
End;
End;
End;
Readln;
End.
*29- Trên bàn có 26 viên sỏi. Người chơi với máy tính. Mỗi lần, mỗi đối thủ chỉ bốc không hơn 4 viên. Đối
thủ nào phải bốc viên sỏi cuối cùng là thua. Tìm một chiến thuật chơi để người đi trước nhưng luôn luôn
thua máy tính.
{WRITELN(TONG_SOI-(5*i));}
PROGRAM BOCSOI;
uses crt;
VAR
TONG_SOI,I,SOI_CON,N:INTEGER;ch:char;
BEGIN
REPEAT
clrscr;
I:=1;
TONG_SOI:=26;
REPEAT
WRITELN(‘LAN BOC THU ‘,I,’:’);
WRITE(‘ BAN BOC MAY VIEN (khong qua 4 vien): ‘);READLN(N);
WRITELN(‘ MAY BOC: ‘,5-N);{WRITELN(5-N);}
WRITELN(‘ SO SOI CON LAI:= ‘,TONG_SOI-(5*i));
SOI_CON:=TONG_SOI-(5*i);
I:=I+1;
UNTIL SOI_CON =1;
WRITELN(‘BAN PHAI BOC VIEN CUOI CUNG. BAN THUA ROI!’);
writeln;
write(‘ Tiep khong (c/k):’);readln(ch);
UNTIL (ch=’k’) OR (ch=’K’);
END.
*30- Tìm và in lên màn tất cả các cặp số thân thiện mà giá trị của chúng không quá 10000. (Hai số được gọi
là thân thiện nếu TỔNG CÁC ƯỚC CỦA SỐ LỚN BẰNG SỐ NHỎ: ví dụ 48 và 75 là cặp số thân thiện vì
các uớc của 75 là: 3 5 15 25 và tổng các ước này bằng 48!)
Uses Crt;
Var n1,n2,t,k: Integer; tt:Byte;
Begin Clrscr;
Repeat
Writeln(#32:20,’Cac cap so Than Thien <10000:’);
Writeln(#32:20,’= = = = = = = = = = = = = =’);
For n1:=1 to 10000 do
Begin
8 h 54 m 28/7/2017
20
Thầy Trần Thông Quế
t:=0;
k:=2;
While (k<=(n1 DIV 2)) And (t<=10000) do
Begin
If (N1 mod k=0) Then t:=t+k;
inc(k);
End;
If (t>0) and (t<=10000) Then
Begin
n2:=t; t:=0;
k:=2;
While (k<=(n2 Div 2)) And (t<=n1) do
Begin
If (n2 mod k=0) then t:=t+k;
Inc(k);
End;
If t=n1 then Writeln(#32:30,’(‘,n1,’,’,n2,’)’);
End;
End;
Writeln(‘DONE!’);
Write(‘More?(1/0),Continue -> 1, Stop -> 0:’); Readln(tt);
Until tt=0;
End.
*31- (LUỸ THỪA NHANH. INFORMATIC OLYMPIC MOSCOW 1980). Nhập cơ số a và mũ k. Tính ak
với hạn chế: Không được dùng công thức tính lũy thừa, cũng không được dùng liên tiếp k phép nhân ( vì k
cực lớn và mục tiêu đầu bài là tính NHANH!)
PROGRAM NANGNHANH_LUYTHUA;
Uses Crt;
VAR
a, b : Real;
k, n : integer; hoi: char;
BEGIN Clrscr;
Repeat
Write('a,k= '); Readln(a,k);
Write(a,' mu ',k,' = ');
b:=1;
While k>0 do
Begin
n:=k div 2;
If (n+nPress c; Stop->Press k:');
8 h 54 m 28/7/2017
21
Thầy Trần Thông Quế
Readln(hoi);
Until hoi='k';
END.
*32- (ĐẢO BIT. INFORMATIC OLYMPIC MOSCOW 1983)
Số nguyên m được viết trong hệ cơ số 2 theo trật tự ngược lại. Số nhận được viết trong hệ thập phân được
coi là giá trị của hàm B(m). Hãy tính giá trị hàm B(m) chẳng hạn với m=512 ; 513; 514;…; 1024.
PROGRAM DaoBit; {chay voi m=513}
VAR
m, b, k: integer;
BEGIN
k:=513;
m:=1;
Writeln(m);
While m<1024 do
begin
while m>=k do
begin
m:=m-k;
k:=k div 2;
end;
m:=m+k;
k:=513;
Writeln(m);
end;
Readln;
END.
33. (Hàm Euler Eul(n)). Cho trước số tự nhiên n. Hàm Eul(n) chứa tất cả các số tự nhiên nhỏ hơn n và
nguyên tố cùng nhau với n. Tính hàm Eul(n).
Uses Crt;
Var n, ham_Eul,i,a,b,r: integer;
Begin clrscr;
Write('Nhap n:'); Readln(n);
ham_Eul:=0;
For i:=1 to (n-1) do
Begin
a:=i;
b:=n;
While b<>0 do
Begin
r:= a MOD b;
a:=b;
b:=r;
End;
If a=1 then Inc(ham_Eul);
End;
Write('Gia tri ham Euler=:',ham_Eul);
8 h 54 m 28/7/2017
22
Thầy Trần Thông Quế
Readln;
End.
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
PHẦN II. LẬP TRÌNH THEO MODUL
Trong Pascal có hai Modul để ta lập trình Đơn Thể. Âý là:
* Procedure (Thủ Tục).
* (và) FUNCTION (Hàm)
Đặc biệt các em cần chú ý và nắm thật vững bản chất 3 khái niệm sau của lập trình Modul:
a-Biến toàn cục (Global Var.) và biến cục bộ (Locate Var.)
b-Các khái niệm về tham chiếu
c-Hai phương cách truyền data trong lập trình Modul của Pascal:
c1. Truyền theo Tham Trị (Transfer By Value Parameters)
c2. Truyền theo Tham Biến (Transfer By Variable Parameters)
Trước hết các bạn hãy “khai vị” 3 “món” sau ( 3 MÓN “KHAI VỊ” NÀY KIỂM TRA XEM CÁC BẠN CÓ
HIỂU ĐẾN TẬN NGỌN NGUỒN CÁC KHÁI NIỆM a); b) ; c); d) nêu trên không. Vì chỉ khi hiểu rõ thực
chất 4 khái niệm đó, bạn mới hòng lập trình đơn thể thạo):
Không RUN program, chỉ dùng bút ghi kết quả của 3 program sau đây lên giấy + giải thích tỉ mỉ kết quả!
BA BÀI “KHAI VỊ” NÀY KHÔNG DỄ ĐÂU! NHỚ: KHÔNG ĐƯỢC RUN PROGRAM NHÉ!!!
1. Program Transf_By_Val;
Uses Crt;
Var so1, so2:integer;
Procedure Transf_Val(x, y:integer);
Begin
Writeln(' Ben trong thu tuc:');
x:=x+15;
y:=y+15;
Writeln('X=',x);
Write('Y=',y);
End;
Begin {Main Prog.)
Writeln('Co che truyen data theo THAM TRI:');
Write('Nhap so thu nhat so1='); Readln(so1);
Write('Nhap so thu hai so2='); Readln(so2);
Transf_Val(so1, so2);
Writeln;
Writeln('Ben ngoai thu tuc(tuc la sau truyen Data):');
Writeln('Bay gio so thu 1 so1=',so1);
Writeln('Bay gio so thu 2 so2=',so2);
Writeln('Go ENTER de stop!');
8 h 54 m 28/7/2017
23
Thầy Trần Thông Quế
Readln;
End.
2. Program Transf_By_Vari_Para;
Uses Crt;
Var so1, so2:integer;
Procedure Transf_By_Vari_Para(Var x, y:integer);
Begin
Writeln('Trong than thu tuc:');
x:=x+15;
y:=y+15;
Writeln(' Tham so X=', x);
Writeln(' Tham so Y=', y);
End;
BEGIN {Main Prog.}
Writeln('Co che truyen Data theo THAM BIEN:');
Write('Nhap so thu nhat so1='); Readln(so1);
Write('Nhap so thu hai so2='); Readln(so2);
Writeln('Sau khi truyen Data (tucla ben ngoai thu tuc):');
Writeln('Bay gio so1=',so1);
Writeln('Bay gio so2=',so2);
Writeln;
Write(' Go ENTER de Stop!');
Readln;
END.
3. Program Obser_Transf_Data;
Uses Crt;
Var a, b: integer;
Procedure Obser(Var x, y:Integer);
Begin
Write(x:3, y:3);
x:=2;
x:=x+1;
y:=2*x;
End;
BEGIN {Main Prog.}
Clrscr;
a:=4; b:=5;
Write('Cac gia tri a, b:', a,'; ',b);
Writeln;
Obser(a,b);
Writeln('Cac gia tri a, b:',a,'; ',b);
Obser(b,a);
Writeln('Cac gia tri b, a:',b,'; ',a);
Readln;
END.
8 h 54 m 28/7/2017
24
Thầy Trần Thông Quế
4. Lập trình đơn thể (Bạn chọn FUNCTION hay PROCEDURE LÀ VIỆC CỦA BẠN. HÃY TỰ SUY
NGHĨ TRƯỚC LÚC XEM ĐÁP ÁN BÊN DƯỚI.) thực thi 3 phép tính cơ bản (Hợp, Hiệu, Giao) của hai
tập hợp cho trước. Hiện kết quả lên màn.
BÀI NÀY NGẮN, NHƯNG KHÁ HAY VÌ NÓ CHO BẠN NHIỀU HIỂU BIẾT: 1. CÁCH KHAI BÁO Ở
ĐẦU PROGRAM; Ở 2 MODUL: CÁCH THAM CHIẾU KHÁC NHAU (TẠI SAO?); CÁCH DÙNG CÁC
LỆNH Ở MODUL NHẬP VÀ MODUL INRA…
Uses Crt;
Type Kytu='!'..'}';
Tapkytu=Set of Kytu;
Var A,B,C,D,E: Tapkytu;
Procedure Nhap(Var x:Tapkytu);
Var kt: Char;
Begin
Read(kt);
While kt<>#13 Do
Begin
x:=x+[kt];
Read(kt);
End;
End;
Procedure Inra(Y: Tapkytu);
Var kt: Char;
Begin
For kt:='!' to '}' Do
If kt In Y then Write(kt:3);
End;
{main Prog.}
Begin clrscr;
A:=[]; B:=[]; C:=[]; D:=[]; E:=[];
Write('Nhap cac phan tu cua tap A (Ngung, go ENTER:'); Nhap(A);
Write('Nhap cac phan tu cua tap B (Ngung, go ENTER:'); Nhap(B);
C:=A+B;
D:=A*B;
E:=A-B;
Write('Hop cua 2 tap vua nhap C=A+B='); Inra(C); Writeln;
Write('Giao cua 2 tap vua nhap D=A*B='); Inra(D); Writeln;
Write('Hieu cua 2 tap vua nhap E=A-B='); Inra(E); Writeln;
Readln;
End.
*5. Đọc từ bàn phím vào số nguyên dương n. Viết một hàm kiểm tra xem số ấy có là số chính phương
không (Số bằng bình phương của số tự nhiên khác gọi là số chính phương).
Uses Crt;
Var n:longint; tt:byte;
Function chphuong_check(var k:longint):boolean;
Begin
If Sqrt(k)=Trunc(Sqrt(k)) then chphuong_check:=true
8 h 54 m 28/7/2017
25
Thầy Trần Thông Quế
Else chphuong_check:=false;
End;
Begin clrscr;
Repeat
Write('Nhap so nguyen n:'); Readln(n);
If chphuong_check(n) then Write(n,' la so chinh phuong.')
Else Write(n,' khong phai la so chin phuong.');
Writeln;
Write('More (1/0)?, Continue -> press 1, Stop -> press 0:');
Readln(tt);
Until tt=0;
End.
*6. Đọc từ bàn phím vào số nguyên dương n. Viết một hàm kiểm tra xem số ấy có là số hoàn hảo không (số
bằng tổng các ước của nó kể cả đơn vị, gọi là số hoàn hảo,. Chẳng hạn 28 là số hoàn hảo vì
28= 1 + 2 + 4 + 7 + 14).
Uses Crt;
Var n:longint;
Function Hhao_Check(var k:longint):Boolean;
Var i,sum:longint;
Begin
sum:=0;
For i:=1 to k DIV 2 do
If n MOD i=0 then sum:=sum+i;
If sum=n then Hhao_Check:=true
Else Hhao_Check:=false;
End;
Begin clrscr;
Write('n='); Readln(n);
If Hhao_Check(n) then Write(n,' la so hoan hao.')
Else Write(n,' khong la so hoan hao.');
Readln;
End.
CÓ THỂ BẠN KHÔNG ĐỂ Ý HOẶC KHÔNG HIỂU: Trong 2 bài 28 & 29, biến Toàn cục và Tham số
Thực sự là trùng nhau (n). Lời gọi hàm ở Main Program luôn luôn phải dùng BIẾN TOÀN CỤC HOẶC
THAM SỐ THỰC SỰ (NGHĨA LÀ: KHÔNG ĐƯỢC DÙNG BIẾN CỤC BỘ OR KHÔNG ĐƯỢC DÙNG
THAM SỐ HÌNH THỨC).
7. Đọc từ bàn phím vào số nguyên dương n. Viết một hàm kiểm tra xem số ấy có là số nguyên tố không.
USES CRT;
Var n ,d,i: Integer;
Function ktnt:Boolean;
Begin
d:=0;
For i:=2 to n-1 do
If n mod i=0 then d:=d+1;
8 h 54 m 28/7/2017
26
Thầy Trần Thông Quế
If(d=0) and (n>1) then ktnt:=True
Else ktnt:=False;
End;
BEGIN CLRSCR;
Write(#32:5,'Nhap n = '); Readln(n);
If ktnt then
Writeln(#32:9,n,' la so nguyen to.')
Else Writeln (#32:9,n,' khong phai la so nguyen to.');
Readln;
END.
(CÁC HÀM KIỂM TRA TRÊN ĐÂY, KHÔNG NHẤT THIẾT PHẢI CÓ KIỂU BOOLEAN. KIỂU CỦA
NÓ CÓ THỂ LÀ BYTE (THƯỜNG) HOẶC LÀ CHAR (ĐÃ CÓ LÚC NHÀO BẠN THỬ VỚI KIỂU
CHAR CHO NHỮNG HÀM CÓ CHỨC NĂNG KIỂM TRA CHƯA?)
8. Đọc từ bàn phím vào một số nguyên dương, kiểm tra xem số ấy có đối xứng không. Một số đọc xuôi, đọc
ngược đều như nhau là số đối xứng. Ví dụ 123454321.
CODE DƯỚI ĐÂY LÀ NGẮN NHẤT, KHÔNG THỂ NGẮN HƠN.
Uses crt;
var n,m,tam:longint; tt:byte;
Begin clrscr;
Repeat
Write('Nhap n:'); Readln(n);
m:=0; tam:=n;
While (tam>0) Do
Begin
m:=m*10+tam MOD 10;
tam:=tam DIV 10;
End;
If m=n then Write('So vua nhap la so Doi xung.')
Else Write('So vua nhap Khong la so Doi xung.');
Writeln;
Write('Another Test (1/0)?. Come on->Press 1; Stop-> Press 0:');
Readln(tt);
Until tt=0;
End.
**9. Lập trình biểu diễn một số nguyên dương bằng tổng của n số tự nhiên LIÊN TIẾP khác. Yêu cầu xuất:
Chẳng hạn: Vào 4, ra: 4 không biểu diễn được bằng tổng 2 số tự nhiên liên tiếp.
Vào 100, ra: 100=9+10+11+12+13+14+15+16
Số 100 biểu diễn được bằng tổng của 8 số tự nhiên liên tiếp.
Vào 5, ra: 5=2+3
Số 5 biểu diễn được bằng tổng của 2 số tự nhiên liên tiếp.
BÀI NÀY KHÁ KHÓ ĐỐI VỚI HS VÀ CẢ SINH VIÊN!
uses crt;
Const max=10000;
Var n,i,dem:Longint; a:array[1..max] of Longint;
8 h 54 m 28/7/2017
27
Thầy Trần Thông Quế
Function Check(m:Longint):boolean;
Var stop,kt:Boolean; kd,bd,t:Longint;
Begin
stop:=False;
kt:=False;
kd:=0;
While Not Stop do
Begin
bd:=kd;dem:=0;
t:=0;
If bd>=(m+1) DIV 2 then stop:=true
Else
Begin
While t
Var tt:Byte;
Begin clrscr;
Repeat
Repeat
Write('Nhap so duong n='); Readln(n);
If n<0 then Writeln(' Nhap lai n>=0');
Until n>=0;
If Check(n) then
Begin
Write(n,'=');
For i:=1 to dem-1 do
Write(a[i],'+');
Writeln(a[dem]);
Write('So ',n,' bieu dien duoc thanh');
Write(' tong cua ',dem,' so tu nhien lien tiep!');
End
Else
Begin
8 h 54 m 28/7/2017
28
Thầy Trần Thông Quế
Write('So ',n,' khong bieu dien duoc thanh');
Write(' tong cua >=2 so tu nhien lien tiep!');
End;
Writeln; Writeln;
Write('More (1/0)? Tiep: go 1; Ngung: go 0:');
Readln(tt);
Until tt=0;
End.
**10. Lập trình phân tích một số tự nhiên bất kỳ thành tổng các số nguyên tố để thu được TÍCH CỦA CÁC
SỐ HẠNG LÀ LỚN NHẤT.
Test1 vào: 8; ra: 3 3 2, tích các số hạng đạt max=18
Test2: Vào 23; ra: 3 3 3 3 3 3 3 2, tích các số hạng này đạt max=4374
Uses crt;
Const m=65;
Var pa_opt:Array[0..m] of Byte;
tic:Array[0..m] of longint;
j,s,p,k:longint; tt:Byte;
Procedure Innit;
Var k:longint;
Begin
For k:=0 to p do
Begin
tic[k]:=0; pa_opt[k]:=0;
End;
tic[0]:=1;
End;
Procedure Process;
Var j,k,s,ticmax:longint;
Begin
For j:=1 to p do
Begin
For k:=0 to p-j do
If (k=0) or (pa_opt[k]>0) then
Begin
s:=k+j;
ticmax:=tic[k]*j;
If ((pa_opt[s]=0) or (pa_opt[s]>0)) and (ticmax>tic[s]) then
Begin
tic[s]:=ticmax; pa_opt[s]:=j;
End;
End;
End;
End;
Begin clrscr;
Repeat
8 h 54 m 28/7/2017
29
Thầy Trần Thông Quế
Write('Nhap so nguyen duong p<100:'); Readln(p);
Innit;
Process;
s:=p;
Write('Phuong an phan tich so ',p,' thanh tong cac so ng_to de co tich max la:');
While s>0 Do
Begin
Write(pa_opt[s]:3); s:=s-pa_opt[s];
End;
Writeln;
Write('Ung voi ptich toi uu tren day, ta duoc tich max=',tic[p]:2);
Writeln; Writeln;
Writeln('* * * * * * * * * * * * * * ');
Write('Continue(1/0)?. Go 1->Tiep; go 0->ngung:');
Readln(tt);
Until tt=0;
End.
**11. (SỐ TAM TAM) Liệt kê tất cả các số Tam Tam và đếm số lượng các số TAM TAM đã liệt kê. (Các
số Tam Tam là những số có 3 chữ số mà số đảo ngược của nó nguyên tố với nó. Chẳng hạn số 974 nguyên
tố cùng 479 là hai số TAM TAM)
Uses crt;
Var dem, i:integer;
Function uscln(a,b:integer):integer;
var r:integer;
Begin
While b>0 do
Begin
r:=a MOd b; a:=b; b:=r;
End;
uscln:=a;
End;
Function daoso(x:integer):integer;
Var y:integer;
Begin
y:=0;
While x>0 do
Begin
y:=10*y+(x MOD 10);
x:=x DIV 10;
End;
daoso:=y;
End;
Procedure Tim;
Begin
dem:=0; writeln; Writeln;
Writeln(#32:18,'Cac so Tam tam thoa man d/kien dau bai:');
8 h 54 m 28/7/2017
30
Thầy Trần Thông Quế
Writeln; Writeln(#32:18,'- - - - - - - - - - - - - - - - - - - -');
For i:=101 to 999 do
if uscln(i,daoso(i))=1 Then
Begin
Inc(dem);
Write(i:4);
End;
Writeln; Writeln;
Write(#32:20,'Bang tren day co tong cong ',dem,' so Tam tam.');
End;
Begin clrscr;
Tim;
Readln;
End.
**12. Liệt kê tất cả các cặp số Lucasa. (Giới hạn: 1
CODE DƯỚI ĐÂY LÀ NGẮN NHẤT!
Uses crt;
Var n, i:longint; s1, s2:string; d: byte; hd:char;
Begin clrscr;
Repeat
d:=0;
Writeln(' Tim cac cap lucasa_number:');
Repeat
Write('Nhap can tren cua gioi han:'); Readln(n);
Until (n>1) and (n<2147483647);
Writeln('Cac cap Lucasa number <=',n,': ');
n:=Trunc(Sqrt(n));
For i:=1 to n do
If (i MOD 10 in [1, 5, 6]) then
Begin
Str(i,s1);
Str(i*i,s2);
If Copy(s2,Length(s2)-Length(s1)+1, Length(s1))=s1 Then
Begin
Inc(d);
Writeln('(',s1,',',s2,')');
End;
End;
Writeln('Tong cong co ',d,' cap LucasaNumbers.');
Write('Go ESc de tro lai chuong trinh!');
Until Readkey = #27;
End.
8 h 54 m 28/7/2017
31
Thầy Trần Thông Quế
**13. Liệt kê tất cả các số SIÊU NGUYÊN TỐ có không hơn 8 chữ số. (Các số SIÊU NGUYÊN TỐ dài L
là những số mà xóa đi k (k
Function NT(n:longint):boolean;
Var
i:longint;
Begin
If (n=0) or (n=1) then
NT:=False
Else
Begin
i:=2;
While (n mod i<>0) and (i<=sqrt(n)) do
i:=i+1;
If i> sqrt(n) then NT:=True
Else NT:=False;
End;
End;
BEGIN CLrscr;
Write('Nhap so chu so n (n<=8):');
Readln(n);
dem:=1;
a[dem]:=0;
For i:=1 to n do
Begin
kb:=0;
For k:=1 to dem do
For cs:=0 to 9 do
If NT(a[k]*10+cs) then
Begin
kb:=kb+1;
b[kb]:=a[k]*10+cs;
End;
dem:=kb;
For k:=1 to dem do
a[k]:=b[k];
End;
For k:=1 to dem do
Write(a[k]:10);
Writeln;
Writeln('Co tat ca ',dem,' so sieu nguyen to co ',n,' chu so.');
Readln;
END.
8 h 54 m 28/7/2017
32
Thầy Trần Thông Quế
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
PHẦN III- MẢNG (ARRAY)
(Bài khó: *; Bài rất khó: **)
II_1) MẢNG 1_CHIỀU. LẬP TRÌNH GIẢI CÁC BÀI TOÁN SAU:
1- Cho trước độ dài n của dãy số. Đọc từ bàn phím vào dãy n số tự nhiên. Tìm và in lên màn hình các số nguyên tố cùng nhau trong dãy.
Program songuyento_trongday;
uses crt;
var a:array[1..100] of integer;
i,n,j,dem:integer;
Begin
clrscr;
write(‘Nhap do dai cua day so: ‘); readln(n);
writeln(‘Nhap cac phan tu cua mang:’);
for i:=1 to n do
Begin
write(‘a[‘,i,’]=’);readln(A[i]);
End;
write(‘Day vua nhap la:’);
For i:=1 to n do write(‘ ‘,a[i]);
writeln;
writeln(‘= = = = = = = = = = = = = = = = =’);
write(‘Cac so nguyen to co trong mang la:’);
For i:=1 to n do
Begin
dem:=0;
for j:=2 to a[i]-1 do
Begin
If a[i] mod j=0 then dem:=dem+1;
End;
If dem=0 then write(‘ ‘,a[i]);
End;
readln;
End.
2- Cho trước độ dài n của dãy số. Đọc từ bàn phím vào dãy n số nguyên. Tìm và in lên màn dãy con dài
nhất gồm toàn số dương.
Chẳng hạn, Vào: 12 -4 6 3 -21 19 5 7 21 -9 2
Ra: 19 5 7 21
Program DayconDuongDainhat;
8 h 54 m 28/7/2017
33
Thầy Trần Thông Quế
Uses crt;
Var a:Array[1..1000] of Integer;
n,i,j,k,kmax,id:byte;
Begin
clrscr;
{ Randomize;}
write(‘Nhap do dai n (2<=n<=1000) cua day so: ‘); readln(n);
writeln(‘Nhap cac phan tu cua mang:’);
for i:=1 to n do
Begin
write(‘a[‘,i,’]=’);
readln(a[i]);
{a[i]:=Random(100);}
End;
clrscr;
writeln(‘Day vua nhap la:’);
For i:=1 to n do write(‘ ‘,a[i]);
writeln;
writeln(‘= = = = = = = = = = = = = = = = = = = = = = = = = =’);
kmax:=0;
For i:=1 to n do
Begin
j:=i+1;
While ((a[i]>0) and (a[j]>0)) Do
Inc(j);
k:=j-i;
if k>kmax then
Begin
kmax:=k;
id:=i;
End;
End;
Writeln(‘Day con gom cac so duong lien tiep dai nhat:’);
For i:=id to id+kmax-1 do Write(a[i]:4);
Readln;
End. 3- Hai bài dưới đây yêu cầu dùng THUẬT TOÁN PHI ĐỆ QUY:
a/ In lên màn hình tam giác ĐỀU Pascal.
b/ In lên màn hình tam giác VUÔNG Pascal.
(Tam giác Pascal là bảng số có hình tam giác chứa các hệ số của khai triển nhị thức Newton)
3.a)
Program Tg_vuong_Pascal;
uses crt;
Var a:array[1..16] of byte; i,j:byte;
Begin clrscr;
Writeln(‘Tam giac vuong Pascal co 16 dong:’);
Writeln;
8 h 54 m 28/7/2017
34
Thầy Trần Thông Quế
If (j=i) or (j=1) then a[j]:=1
Else a[j]:=a[j]+a[j-1];
For i:=1 to 16 do
Begin
For j:=i Downto 1 Do
For j:=1 to i do
Write(a[j]:4);
Writeln;
End;
Readln
End.
3.b)
Program InTamGiacPascal;
uses crt;
var hs:array[0..12] of integer; i,j:integer;
Begin ClrScr;
Write(‘Tam giac Pascal deu co 13 dong:’);
For i:=0 to 12 do
Begin
For j:=i DownTo 0 do
If (j=i) or (j=0) then hs[j]:=1
Else hs[j]:=hs[j]+hs[j-1];
Gotoxy((70-5*i) DIV 2,i+6);
For j:=0 to i do Write(hs[j]:5);
End;
Readln;
End.
*4- (INFORMATIC OLYMPIC MOSCOW 1985). Tìm tất cả các cách biểu diễn một số tự nhiên bằng
tổng của các số tự nhiên khác.
Ví dụ. Vào: 5
Ra : Cách thứ 1: 5=4+1
Cách thứ 2: 5=2+3
Cách thứ 3: 5=3+1+1
Cách thứ 4: 5=2+2+1
Cách thứ 5: 5=2+1+1+1
Cách thứ 6: 5=1+1+1+1+1+1
Số cách biểu diễn = 6
Program ptich_thanh_tong;
Uses crt;
Var n,d,l,i,sum:Integer; dem:longint; tt:char;
s,r:array[1..100] of integer;
Begin clrscr;
Repeat
Write(‘ Nhap n:’); Readln(n);
8 h 54 m 28/7/2017
35
Thầy Trần Thông Quế
Writeln(‘Cac phuong an bieu dien tong:’); Writeln;
dem:=0;
s[1]:=n; r[1]:=1; d:=1;
While s[1]>1 do
Begin
inc(dem); sum:=0;
If s[d]=1 Then
Begin
sum:=sum+r[d];
Dec(d);
end;
sum:=sum+s[d]; r[d]:=r[d]-1; L:=s[d]-1;
If r[d]<>0 then Inc(d);
s[d]:=L; r[d]:=sum DIV L; L:=Sum MOD L;
If L<>0 then
Begin
Inc(d); s[d]:=L; r[d]:=1;
End;
Write(‘ Cach thu ‘,dem,’:’,n,’=’);
For i:=1 to d Do
For L:=1 to r[i] Do Write(s[i],’+’);
Writeln; Writeln;
End;
Writeln(#32:5,’So cach bieu dien=’,dem); Writeln;
Write(‘Continue (y/n) ?, Go y->de tiep; go n hoac N de thoat:’);
Readln(tt); Writeln; Writeln;
Until tt IN [‘n’,’N’];
End. *5- INFORMATIC OLYMPIC MOSCOW 1987 (TẬP NỬA BỘI-HALF MULTI SET). Tập A các số tự nhiên định nghĩa như sau:
a- 1 A
b- K A thì 2K+1 A và 3K+1 A. Tìm và in lên màn n phần tử đầu tiên của tập A
(n<1000). Tập định nghĩa trên đây gọi là HALF MULTI SET.
Chẳng hạn với n=9 thì các phần tử đầu tiên của tập A là:
1 3 4 7 9 10 13 15 19
Program half_multi_Set;
Uses Crt;
Const max=100;
Var i,k2,k3,a2,a3,n: Integer; a:array[1..100] of integer;
Begin Clrscr;
Write(‘Nhap n:’); Readln(n);
k2:=1; k3:=1; a[1]:=1;
Write(1);
For i:=2 to n do
Begin
a2:=2*a[k2]+1; a3:=3*a[k3]+1;
8 h 54 m 28/7/2017
36
Thầy Trần Thông Quế
If a2<=a3 Then
Begin
a[i]:=a2;
k2:=k2+1;
End;
If a3<=a2 then
Begin
a[i]:=a3;
k3:=k3+1;
End;
Write(a[i]:4);
End;
Readln;
End.
**6- Cho trước dãy số nguyên có độ dài n (n đọc từ bàn phím vào). Tìm cách chia dãy ấy thành nhiều dãy
con có tổng bằng nhau.
{ Go ESC de ve Program}
Uses Crt;
const mn=60;
Var a,c:Array[1..mn] of word;
Procedure View(n:word);
Var i: word;
Begin
for i:=1 to n do
Write(a[i]:4);
Writeln;
End;
Function Min(a,b: word):word;
Begin
if a
8 h 54 m 28/7/2017
37
Thầy Trần Thông Quế
Function Check(tt, n, k: word):boolean;
Var t,s,i,m:word;
Begin
check:=False;
t:=tt Div k ;
If t*k <> tt then exit;
m:=1;
c[m]:=0;
s:=0;
For i:=1 to n do
Begin
s:=s+a[i];
If s>t then exit;
If s=t then
Begin
m:=m+1;c[m]:=i;
s:=0;
End;
End;
c[m]:=n;
check:=True;
End;
Procedure Result(tt, n, k:word);
Var s,i:word;
Begin
Writeln;
Write(‘Day a[1..’,n,’] co the chia thanh ‘,k,’ doan’);
Writeln(‘ co tong nhu nhau la=’,tt Div k);
s:=0;
If k=1 Then
Begin
For i:=1 to n do
s:=s+a[i];
Write(‘a[1..’,n,’]=’,s);
Exit;
End;
Writeln;
For i:=1 to k do
Begin
Writeln(‘Doan thu ‘,i,’: a[‘,c[i]+1,’..’,c[i+1],’]’);
If (i Mod 15 =0) then
If readkey=#27 then Exit;
End;
End;
Procedure Partion(n:word);
Var tt, k:word;
Begin
8 h 54 m 28/7/2017
38
Thầy Trần Thông Quế
tt:=0;
For k:=1 to n do tt:=tt+a[k];
For k:=n Downto 1 do
If check (tt,n,k) then
Begin
Result(tt,n,k);
Exit;
End;
End;
Procedure Test;
var n:word;
Begin
randomize;
Repeat
clrscr;
n:=random(mn)+1;
RandomGene(n Div (random(5)+1),n);
View(n);
Partion(n);
Until readkey=#27;
End;
7- IFORMATIC OLYMPIC MOSCOW 1986. Có k làng. Nếu ở làng i đặt trạm cấp cứu, thì xe cấp cứu đi
đến làng j theo tín hiệu gọi cần thời gian:
A[i,i] + A[i,j] ( 1<=i, j<=k, i = j )
Tìm số hiệu làng i để đặt trạm cấp cứu sao cho từ đó đi tới làng xa nhất (về thời gian) sẽ mất thời gian ít
nhất.
Mảng A[1..k,1..k] cho trước, trong đó tất cả phần tử A[i,j]>0 và có thể A[i,j] <>A[j,i].
Uses Crt;
Const kk=20;
Var i,j,k,i1:integer;
s, t: real;
a:Array[1..kk,1..kk] of real;
Begin clrscr;
Write(‘Nhap so lang:’); Readln(k);
For i:=1 to k do
For j:=1 to k do
Begin
Write(‘a[‘,i,’,’,j,’]=’); Readln(a[i,j]);
End;
For i:=1 to k do
Begin
s:=0;
for j:=1 to k do
If(i<>j) And (s
8 h 54 m 28/7/2017
39
Thầy Trần Thông Quế
s:=s+a[i,j];
If(i=1) Or (s
8 h 54 m 28/7/2017
40
Thầy Trần Thông Quế
for j:=1 to len-i do b:=b*2;
s:=S+b;
end;
end;
Write('Doi sang thap phan la: ',S);
Writeln;
Write('More(y/n)?'); Readln(dap);
Until dap In['n', 'N'];
End.
10- Tìm khoảng cách nhỏ nhất giữa các phần tử thuộc dãy số nguyên đã cho.
Program Khoangcachmin;
uses crt;
var a:array[2..1000] of integer;
i,n,dmin:integer; hoi:byte;
Begin clrscr;
Repeat
Randomize;
write('Nhap do dai n (n<=1000) cua day so: '); readln(n);
writeln('Nhap cac phan tu cua mang:');
For i:=2 to n do
a[i]:=Random(100);
clrscr;
writeln('Day vua nhap la:');
For i:=2 to n do write(' ',a[i]);
writeln;
writeln('= = = = = = = = = = = = = = = = = = = = = = = = = =');
dmin:=abs(a[3]-a[2]);
For i:=4 to n do
If (dmin>abs(a[i]-a[i-1])) then dmin:=abs(a[i]-a[i-1]);
Writeln('Khoang cach nho nhat giua cac phan tu trong day la:',dmin);
Write('Another Test (1/0)?. Continue->Press 1; Stop->Press 0:');
Writeln;
Readln(hoi);
Until hoi=0;
End.
III_2) MẢNG HAI CHIỀU (TÊN KHÁC: MA TRẬN)
(CHỦ ĐỀ NÀY KHÁ NHIỀU BÀI TẬP THÚ VỊ HOẶC ÍT QUEN THUỘC VỚI CÁC BẠN)
Khuyến cáo: Các bạn học sinh hãy chú ý điều sau:
CÁI KHÓ CỐT LÕI CỦA CÁC BÀI TOÁN TỪ 7 ĐẾN 11 đối với các bạn học sinh hay sinh viên
KHÔNG Ở THUẬT TOÁN TÌM KIẾM HAY TÍNH TOÁN (những thuật toán này quá dễ với các bạn) MÀ
Ở THUẬT TOÁN DUYỆT THEO CÁC INDEX (CÁC CHỈ SỐ ) CỦA MA TRẬN. Bởi vậy khuyến cáo
các bạn nên XEM+NGẪM+NHỚ KỸ CÁCH DUYỆT INDEX ở các bài toán đó.
8 h 54 m 28/7/2017
41
Thầy Trần Thông Quế
*11- Cho trước ma trận vuông cấp n. Lập trình làm
c- In lên màn ma trận tam giác dưới & ma trận tam giác trên.
d- Xem các phần tử thuộc đường chéo chính.
e- Xem các phần tử ở PHÍA TRÊN đường chéo chính.
f- TỔNG các phần tử ở PHÍA TRÊN đường chéo chính.
Program Bt_7;
Uses crt;
Var i,j,m,n,d,s,s1,s2,t:integer;
a:array[1..50,1..50] of integer;
Begin clrscr;
Randomize;
Write(‘Nhap so hang cot n cua ma tran vuong:’); Readln(n);
for i:=1 to n do
Begin
for j:=1 to n do a[i,j]:=Random(10);
End;
Writeln(‘Ma tran vua nhap:’);
For i:=1 to n do
Begin
For j:=1 to n do
Write(a[i,j]:3);
Writeln;
End;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘* * * * * * * * * * * * * * * * *’);
Writeln(‘Ma tran tam giac duoi:’);
For i:=1 to n do
Begin
For j:=1 to i do
write(a[i,j]:3);
writeln;
End;
Writeln(‘* * * * * * * * * * * * * * * * *’);
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘Ma tran tam giac tren:’);
For i:=1 to n do
Begin
For j:=i to n do
8 h 54 m 28/7/2017
42
Thầy Trần Thông Quế
Begin
Gotoxy(4*(j+1),3+i);
Write(a[i,j],’ ‘);
end;
Writeln;
end;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘ Cac phan tu thuoc duong cheo chinh:’);
for i:=1 to n do
Write(a[i,i]:4);
writeln;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘* * * * * * * * * * * * * * * * *’);
Writeln(‘ Cac phan tu nam PHIA tren duong cheo chinh:’);
for i:=1 to n do
Begin
for j:=i+1 to n do
Begin
Gotoxy(4*(j+1),3+i);
write(a[i,j],’ ‘);
writeln;
End;
End;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘* * * * * * * * * * * * * * * * *’);
t:=0;
for i:=1 to n do
Begin
For j:=i+1 to n do
t:=t+a[i,j];
End;
Write(‘Tong cac phan tu o PHIA tren duong cheo chinh:’,t);
Readln
End.
**12- Cho trước ma trận vuông cấp n. Lập trình làm các việc sau:
a/ In lên màn ma trận tam giác dưới đường chéo chính.
b/ Xem các phần tử thuộc đường chéo chính.
c/ Xem các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA TRÊN.
d/ Tính tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA TRÊN.
e/ Xem các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI.
f/ Tính tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI.
8 h 54 m 28/7/2017
43
Thầy Trần Thông Quế
TEST. Vào:
49 20 25 12
5 37 19 19
5 43 25 15
3 13 48 8
Ra:
a/ Ma trận tam giác dưới:
49
5 37
5 43 25
3 13 48 8
b/ Các phần tử thuộc đường chéo chính: 49 37 25 8
c/ Các phần tử thuộc đường // đường chéo chính sát ngay phía trên: 20 19 15
d/ Tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA TRÊN:
54
e/ Các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI:
5 43 48
f/ Tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI:
96
Program Bt_8;
Uses crt;
Var i,j,n,d,s,s1,s2,ln:integer;
a:array[1..20,1..20] of integer;
Begin clrscr;
Randomize;
s:=0;
Write('Nhap kich co ma tran vuong n='); Readln(n);
for i:=1 to n do
Begin
for j:=1 to n do a[i,j]:=Random(50);
End;
Writeln('Ma tra vua nhap:');
For i:=1 to n do
Begin
For j:=1 to n do
Write(a[i,j]:4);
Writeln;
End;
{ * * * * * * * * * * * * * * * *}
Writeln('Ma tran tam giac duoi:');
For i:=1 to n do
Begin
For j:=1 to i do
write(a[i,j]:4);
8 h 54 m 28/7/2017
44
Thầy Trần Thông Quế
writeln;
End;
Writeln('* * * * * * * * * * * * * * * * *');
Writeln(' Cac phan tu thuoc duong cheo chinh:');
for i:=1 to n do Write(a[i,i]:4); writeln;
Writeln('* * * * * * * * * * * * * * * * *');
s1:=0;
Writeln(' Cac phan tu thuoc duong // sat ngay PHIA TREN duong cheo chinh:');
For i:=1 to n-1 do
Write(#32:2,a[i,i+1]); Writeln;
Write('Tong cac phan tu thuoc duong // sat ngay PHIA TREN duong cheo chinh:');
For i:=1 to n-1 do
s1:=s1+a[i,i+1];
Write(s1:4); Writeln;
Writeln('* * * * * * * * * * * * * * * * *');
s2:=0;
Writeln(' Cac phan tu nam tren duong // sat ngay PHIA DUOI duong cheo chinh:');
For i:=2 to n do
Write(#32:2,a[i,i-1]); Writeln;
Write('Tong cac phan tu nam tren duong // sat ngay PHIA DUOI duong cheo chinh:');
For i:=2 to n do
s2:=s2+a[i,i-1];
Write(s2:4); Writeln;
Readln;
End.
**13- Cho ma trận vuông cấp n (n đọc từ bàn phím vào). Tìm: a/ Số lẻ lớn nhất DƯỚI ĐƯỜNG CHÉO PHỤ. b/ Tìm ít nhất một số trong ma trận lớn hơn số lẻ lớn nhất ấy+chỉ ra tọa độ của nó.
c/ Thống kê số lượng các số lớn hơn số lẻ lớn nhất đã tìm thấy trên đây.
TEST. Vào:
10 12 47 7
5 45 11 39
19 33 29 20
16 19 20 23
Ra: + Số LẺ Max dưới đường chéo phụ=39
+ Tồn tại phần tử lớn hơn số max ở hàng 1, cột 3
+ Tồn tại phần tử lớn hơn số max ở hàng 2, cột 2
+ Số phần tử lớn hơn max là: 2
Program Bt_9;
Uses Crt;
Type mt=array[1..50,1..50] of integer;
Var a:mt; n,i,j,max:byte;
8 h 54 m 28/7/2017
45
Thầy Trần Thông Quế
Procedure Input(Var a:mt; n:byte);
Var i,j:byte;
Begin
randomize;
For i:=1 to n do
For j:=1 to n do a[i,j]:=random(50);
{ Begin
Write('a[',i,',',j,']=');
readln(a[i,j]);
End; }
End;
Procedure View(a:mt; n:byte);
Var i,j:byte;
Begin
For i:=1 to n do
Begin
For j:=1 to n do
Write(a[i,j]:4);
Writeln;
End;
End;
Function Timmax(a:mt; n:byte):byte;
Var i,j,m:Byte;
Begin
max:=0;
For i:=1 to n do
For j:=1 to n do
If ((i+j)>(n+1)) And ((a[i,j] Mod 2)=1) then max:=a[i,j];
If max=0 then
Writeln('Khong co so le nao lon nhat duoi duong cheo phu.')
Else
Begin
For i:=1 to n do
For j:=1 to n do
If ((i+j)>(n+1)) And ((a[i,j] Mod 2)=1) And (max
8 h 54 m 28/7/2017
46
Thầy Trần Thông Quế
if ((i+j)<=n) And (a[i,j]>max) then
Begin
Inc(dem);
Writeln('Ton tai phan tu lon hon max o hang ',i,' cot ',j);
End;
If dem=0 Then write('Khong co phan tu nao > max.')
Else Write('So phan tu lon hon max la:',dem);
End;
Begin clrscr;
Write('Nhap kich co ma tran VUONG:'); Readln(n);
Input(a,n);
View(a,n);
max:=Timmax(a,n);
Maxindex(a,n,max);
Readln;
End.
*14-Cho ma trận vuông cấp n (n đọc từ bàn phím vào). Tìm:
+ Phần tử nhỏ nhất dưới đường chéo chính.
+ Nhập vào tọa độ của phần tử nằm trên đường song song với đường chéo phụ, rồi tính
tổng các phần tử trên đường // này và chứa điểm đó.
tử ấy và // với chéo phụ là 17 (=5+12)
TEST. Dùng matrix trên đây, ta có kết quả sau:
+ Min dưới đường chéo chính=16
+ Đọc vào tọa độ hàng 1, cột 2 ta được tổng các phần tử trên đường chứa phần
Program Bt_10;
Uses Crt;
Type mt=array[1..50,1..50] of byte;
Var a:mt; n,i,j,k,l,row,col,ans:byte;
min,s:integer;
Procedure Input(Var matrix:mt; ten:char; soh,soc:byte);
Var i,j:byte;
Begin
Randomize;
For i:=1 to soh do
For j:=1 to soc do {matrix[i,j]:=Random(10);}
Begin
Write(ten,'[',i,',',j,']='); Readln(a[i,j]);
End;
End;
Procedure View(matrix:mt; soh,soc:byte);
Var i,j:byte;
8 h 54 m 28/7/2017
47
Thầy Trần Thông Quế
Begin
For i:=1 to soh do
Begin
For j:=1 to soc do
Write(matrix[i,j]:3);
Writeln;
End;
End;
Begin Clrscr;
Repeat
Write('Nhap kich co n cua ma tran vuong:'); Readln(n);
Input(a,'a',n,n);
Writeln('Matrix vua nhap:');
Writeln;
View(a,n,n);
Writeln;
min:=a[2,1];
row:=2; col:=1;
For i:=1 to n do
For j:=1 to n do
If(i>j) And (min>a[i,j]) Then
Begin
Min:=a[i,j];
row:=i; col:=j;
End;
Writeln('Phan tu min o duoi duong cheo chinh:',min);
Write('Nhap chi so hang, cot can xu ly:'); Readln(k,l);
s:=0;
For i:=1 to n do
For j:=1 to n do
If (i+j=k+l) then S:=S+a[i,j];
Writeln('Tong cac phan tu tren duong // voi duong cheo phu va ');
Write('chua phan tu tren hang ',k,' cot ',l,' la:',S);
Writeln;
Write('Another Test (1/0)? More --> Press 1, Stop --> Press 0:');
Readln(Ans);
Until ans=0;
End.
*15- Lập trình tạo ma trận xoắn ốc. Lưu kết quả vào tệp Xoanoc.txt.
Program Mt_xoan;
Uses Crt;
var a:array[1..150,1..150]of word;
i,j,n,k:word;
f:text;
Procedure View;
Begin
8 h 54 m 28/7/2017
48
Thầy Trần Thông Quế
For j:=1 to n do
Begin
For i:=1 to n do
Write(f,a[i,j]:6);
Writeln(f);
End;
End;
Procedure Datso;
Begin
inc(k);
a[i,j]:=k;
End;
Begin clrscr;
Write('Nhap kich co ma tran n='); Readln(n);
Assign(f,'Xoanoc.txt'); Rewrite(f);
j:=1;
while k
1 2 3 8 7 9
2 3 1 5 4 6
3 1 2 2 3 1 }
*16- Cho trước ma trận vuông cấp n. Lập trình kiểm tra xem nó có phải là ma trận La Tinh không. Ma trận
mà tất cả các cột, hàng đều là hoán vị của n số gọi là ma trận LaTinh.
{ Test1: Test2:
Program Check_Mtran_LaTinh;
Uses Crt;
type a=Array[1..30,1..30] of Integer;
Var mt:a; i,j,n,d:Integer;
Function ktrahang(i:integer):Boolean;
Var j,k:integer; check:boolean;
Begin
ktrahang:=false;
For k:=1 to n do
8 h 54 m 28/7/2017
49
Thầy Trần Thông Quế
Begin
check:=false;
For j:=1 to n do
if k=mt[i,j] then check:=true;
If Not check then exit;
End;
ktrahang:=true;
End;
Function ktracot(j:integer):boolean;
var i,k:integer; check:boolean;
Begin
ktracot:=false;
For k:=1 to n do
Begin
check:=false;
For i:=1 to n do
If k=mt[i,j] then check:=true;
If Not check then Exit;
End;
ktracot:=true;
End;
Begin Clrscr;
Write('Nhap kich co ma tran vuong n='); Readln(n);
For i:=1 to n Do
For j:=1 to n Do
Begin
write('mt[',i,',',j,']=');readln(mt[i,j]);
End;
writeln('Ma tran vua nhap:');
For i:=1 to n do
Begin
For j:= 1 to n do
write(mt[i,j]:3);
writeln;
End;
writeln;
writeln('= = = = = = = = = = = = = = = = =');
d:=0;
For i:=1 to n Do
If (Not ktrahang(i)) Or (Not ktracot(i)) then
inc(d);
If d=0 then Write('La ma tran Latinh.')
Else Write('khong la ma tran Latinh.');
Readln;
End.
8 h 54 m 28/7/2017
50
Thầy Trần Thông Quế
17- Cho trước ma trận vuông cấp n. . Lập trình kiểm tra xem nó có phải là ma trận đối xứng không.
Một ma trận đối xứng là ma trận vuông A bằng chính ma trận chuyển vị của nó.
Mỗi phần tử của một ma trận đối xứng thì đối xứng qua đường chéo. Do vậy, nếu các phần tử được viết
dưới dạng A=a[i,j] thì với mọi i, j ta có: a[i, j]=a[j,i].
{Test1: 1 2 3 Test2: 9 5 7
2 4 -5 3 1 6
3 -5 6 8 4 2 }
Program Check_Symetr_ Matrix;
Uses Crt;
Type a=Array[1..30,1..30] of integer;
Var mt:a;i,j,n,d:integer; tt:byte;
Begin clrscr;
Repeat
Write(' Nhap kich thuoc ma tran vuong n:'); Readln(n);
for i:=1 to n do
for j:= 1 to n do
begin
write(' Nhap phan tu mt[',i,',',j,']=');
Readln(mt[i,j]);
end;
Writeln;
writeln('Ma tran vua nhap:');
Writeln;
for i:=1 to n do
begin
for j:= 1 to n do
write(mt[i,j]:3);
writeln;
end;
writeln;
d:=0;
for i:=1 to n do
for j:= 1 to n do
If mt[i,j]<>mt[j,i] Then Inc(d);
If d>0 Then Write('Ma tra vua nhap Khong Doi Xung.')
Else Write('Ma tran vua nhap Doi Xung.');
Writeln;
Write('More (1/0)?. More --> Press 1, Stop --> Press 0:');
Readln(tt);
Until tt=0;
End.
**18- Tạo ma phương (gọi khác: ma trận kỳ diệu-magic matrix-) bậc lẻ. Đó là ma trận mà tổng các số trên
các hàng bằng nhau = tổng các số trên các cột bằng nhau = tổng các sổ trên hai đường chéo bằng nhau . Ở
mức tổng quát, toán học mới chỉ chứng minh được: chỉ tạo được ma phương bậc LẺ.
8 h 54 m 28/7/2017
51
Thầy Trần Thông Quế
{Nhap xong data nho go ENTER de xem ket qua chay Program}
Program Magic_Matrix;
Uses crt, addcrt;
Const lim=11;
Type mt=array[1..lim,1..lim] of integer;
mtktr=array[1..lim,1..lim] of boolean;
Var matr:mt; mtcheck:mtktr; ok:boolean;
n,i,j,k:integer;
ch:char;
Procedure chinhtoado(Var i,j:integer; n:integer);
Begin
If i<1 then i:=n;
If i>n then i:=1;
If j<1 then j:=n;
If j>n then j:=1;
End;
Procedure datso(var matr:mt; Var mtcheck:mtktr; Var k:integer; i,j:integer);
Begin
matr[i,j]:=k;
mtcheck[i,j]:=false;
Inc(k);
End;
Procedure DrawTab(matr:mt; n:integer);
Var i,j:integer;
Begin
textbackground(lightred);
clrscr;
textcolor(lightcyan);
For j:=1 to 25 do
Begin
If(j<(13-n+1)) Or (j>(13+n+1)) then
For i:=1 to 80 do
Begin
gotoxy(i,j); write('$');
End
Else
For i:=1 to 80 do
If (i<(40-(5*n) Div 2-1)) or (i>(40+(5*n) Div 2+2)) then
Begin gotoxy(i,j); write('$'); End;
End;
FONT(40-(5*n) Div 2-2,13-n-1,40+(5*n) Div 2+3,13+n+1,14,1);
textcolor(white);
for i:=13-n+1 to 13+n-1 do
if (i Mod 2)=(13-n) Mod 2 then
Begin
8 h 54 m 28/7/2017
52
Thầy Trần Thông Quế
for j:=40-(5*n) Div 2 to 40+(5*n) div 2+1 do
if j Mod 5=(40-(5*n) Div 2) Mod 5 then
Begin
gotoxy(j,i); write('!');
End
Else
Begin
gotoxy(j,i); write('=');
End;
End
Else Begin
for j:=40-(5*n) Div 2 to 40+(5*n) Div 2+1 do
if j Mod 5=(40-(5*n) Div 2) Mod 5 then
Begin
gotoxy(j,i); write('!');
End;
End;
for j:=40-(5*n) Div 2 to 40+(5*n) Div 2+1 do
if j Mod 5=(40-(5*n) Div 2) Mod 5 then
Begin
gotoxy(j,13-n); write('=');
gotoxy(j,13+n); write('=');
End
else
Begin
gotoxy(j,13-n); write('=');
gotoxy(j,13+n); write('=');
End;
textcolor(yellow);
for i:=1 to n do
for j:=1 to n do
Begin
gotoxy((40-(5*n) Div 2+1)+5*(j-1),(13-n+1)+2*(i-1));
write(matr[i,j]:3);
End;
End;
Begin {Main}
clrscr;
ch:='t';
While ch In ['t','T'] Do
Begin
Khungkep(20,4,61,16,14);
gotoxy(31,5); write(' HINH VUONG KY AO.');
WINDOW(21,6,60,15);
writeln(#32:7,'-----------------------------');
writeln(#32:5,'Day la bai toan tao hinh vuong va');
writeln(#32:5,' cac con so dat trong no thoa:');
writeln(#32:5,' Tong cac so tren cac hang,');
8 h 54 m 28/7/2017
53
5 2 9
8 4 5 4 9 2 }
Thầy Trần Thông Quế
writeln(#32:5,' tren cac cot va tren duong cheo');
writeln(#32:5,' deu bang nhau. Den nay bai toan');
writeln(#32:5,' chi giai duoc voi cac hinh vuong ' );
writeln(#32:5,' co do dai canh la so le');
writeln;
write('Cho do dai canh:(n=3, 5, 7, 9, 11 ...):');
read(n);
setwin;
If (n Mod 2=0) or (n<3) or (n>lim) then n:=5;
for i:=1 to n do
for j:=1 to n do
mtcheck[i,j]:=true;
i:=1;
j:=n Div 2+1;
k:=1;
Repeat
datso(matr,mtcheck,k,i,j);
i:=i-1;
j:=j+1;
chinhtoado(i,j,n);
If mtcheck[i,j]=true then ok:=true
Else Begin
j:=j-1;
i:=i+1;
chinhtoado(i,j,n);
Inc(i);
if mtcheck[i,j]=true then ok:=true
else ok:=false;
End;
Until ok=false;
Drawtab(matr,n);
gotoxy(18, 25);
write('Go phom bat ky de thoat hay t, T de tiep tuc!');
Repeat Until Keypressed;
ch:=Readkey;
clrscr;
end;
End.
**19- Kiểm tra xem một ma trận vuông cấp n ( n LẺ) có là ma phương không?
{ Test 1: 3 7 1 Test 2: 8 1 6
3 5 7
Program Maphuong_Check;
Uses Crt;
Type mt=Array[1..30,1..30] of Integer;
var a:mt; i,j,n,s,s1,s2:integer;
8 h 54 m 28/7/2017
54
Thầy Trần Thông Quế
Function shang(i:integer):integer;
var j,s:integer;
Begin
S:=0;
For j:=1 to n do
s:=s+a[i,j];
shang:=s;
End;
Function Scot(j:integer):integer;
Var i,s:Integer;
Begin
s:=0;
For i:=1 to n do
s:=s+a[i,j];
scot:=s;
End;
Begin clrscr;
write(' Nhap kich thuoc n cua ma tran vuong:'); Readln(n);
for i:=1 to n do
for j:= 1 to n do
begin
write(' Nhap phan tu a[',i,',',j,']=');
Readln(a[i,j]);
end;
clrscr;
writeln('Ma tran vua nhap:');
for i:=1 to n do
begin
for j:= 1 to n do
write(a[i,j]:3);
writeln;
end;
s:=shang(1);
s1:=0; s2:=0;
For i:=1 to n Do
Begin
If (shang(i)<>s) Or (scot(i)<>s) Then
Begin
Write('Ma tra vua nhap khong phai ma phuong');
Readln;
Exit;
End;
s1:=s1+a[i,i];
s2:=s2+a[i,n+1-i];
8 h 54 m 28/7/2017
55
Thầy Trần Thông Quế
End;
If (s<>s1) Or (s<>s2) Then
Write('Ma tra vua nhap khong phai ma phuong')
Else Write('Ma tran vua nhap la ma phuong.');
Readln
End.
**20- Cho dãy các số nguyên có độ dài N. Tìm cách chia dãy đã cho thành các đoạn có tổng các phần tử
như nhau.
{Go ESC Thoat}
Uses Crt;
const mn=60;
Var a,c:Array[1..mn] of word;
Procedure View(n:word);
Var i: word;
Begin
for i:=1 to n do
Write(a[i]:4);
Writeln;
End;
Function Min(a,b: word):word;
Begin
if a tt then exit;
m:=1;
c[m]:=0;
8 h 54 m 28/7/2017
56
Thầy Trần Thông Quế
s:=0;
For i:=1 to n do
Begin
s:=s+a[i];
If s>t then exit;
If s=t then
Begin
m:=m+1;c[m]:=i;
s:=0;
End;
End;
c[m]:=n;
check:=True;
End;
Procedure Result(tt, n, k:word);
Var s,i:word;
Begin
Writeln;
Write('Day a[1..',n,'] co the chia thanh ',k,' doan');
Writeln(' co tong nhu nhau la=',tt Div k);
s:=0;
If k=1 Then
Begin
For i:=1 to n do
s:=s+a[i];
Write('a[1..',n,']=',s);
Exit;
End;
Writeln;
For i:=1 to k do
Begin
Writeln('Doan thu ',i,': a[',c[i]+1,'..',c[i+1],']');
If (i Mod 15 =0) then
If Readkey=#27 then Exit;
End;
End;
Procedure Partion(n:word);
Var tt, k:word;
Begin
tt:=0;
For k:=1 to n do tt:=tt+a[k];
For k:=n Downto 1 do
If check (tt,n,k) then
Begin
Result(tt,n,k);
Exit;
End;
8 h 54 m 28/7/2017
57
Thầy Trần Thông Quế
End;
Procedure Test;
var n:word;
Begin
randomize;
Repeat
clrscr;
n:=random(mn)+1;
RandomGene(n Div (random(5)+1),n);
View(n);
Partion(n);
Until readkey=#27;
End;
Begin Clrscr;
Test;
End.
21-(CHỌN SỐ Ở MỖI HÀNG MỖI CỘT) Cho trước ma trận vuông cấp n. Hãy chọn mỗi số ở mỗi hàng
(khác nhau), mỗi cột (khac nhau) sao cho tổng của chúng lớn nhất.
{ Test1: Test2: Test3:
3 4 4
7 9 6 4 3 4 5 241 164 180 20
3 5 8 6 7 8 9 162 81 102 96
8 6 9 1 9 7 4 169 197 80 153
1 3 5 7 11 26 214 223 }
Uses Crt;
Var a:Array[1..20, 1..20] of word;
b:Array[1..20] of Boolean;
x,ng:Array[1..20] of Byte;
r,n,i,dem:Byte;
max,sum:integer;
fi,fo:Text;
Procedure Doc;
Var i,j:word;
Begin
Assign(fi,'mang.in'); Reset(fi);
Readln(fi,n);
For i:=1 to n do
For j:=1 to n do
read(fi,a[i,j]);
Close(fi);
End;
Procedure Ghi;
Var i,j:word;
8 h 54 m 28/7/2017
58
Thầy Trần Thông Quế
Begin
Assign(fo,'mang.ou'); Rewrite(fo);
For i:=1 to n do
Begin
For j:=1 to n do
Write(fo,a[i,j]:4);
Writeln(fo);
End;
End;
Procedure Xuly;
Var i: Word;
Begin
If sum>max Then
Begin
max:=sum;
ng:=x;
End;
End;
Procedure Xuat;
var i:Word;
Begin
Writeln(fo,' Tong max cua cac phan tu da chon=',max);
Writeln(fo,'Va cac phan tu ay la:');
For i:=1 to n do
Write(fo,a[i,ng[i]]:4,'(',i,',',ng[i],')');
End;
Procedure Chon(i:word);
Var j:Word;
Begin
For j:=1 to n do
If b[j] Then
Begin
x[i]:=j;
sum:=sum+a[i,j];
b[j]:=false;
if i=n Then xuly else chon(i+1);
b[j]:=true;
sum:=sum-a[i,j];
End;
End;
Begin clrscr;
Doc;
Ghi;
max:=0; sum:=0;
For i:=1 to n Do
8 h 54 m 28/7/2017
59
Thầy Trần Thông Quế
b[i]:=true;
chon(1);
Xuat;
Close(fo);
Writeln('Done! Go ENTER -> ve Program; Go F3 -> Go MANG.OU: Xem kqua.');
Readln;
End.
PHẦN IV. XÂU KÝ TỰ (STRING)
(Trừ bài 1, không có bài nào dễ với học sinh, sinh viên)
Lập trình giải các bài toán sau:
1/(CHUẨN HÓA XÂU). Cho trước một xâu (dài < 256 ký tự) chứa các từ (Word). Giữa các từ của xâu có
nhiều hơn một dấu cách (ký tự trống). Hãy khử các dấu cách giữa các từ, chỉ GIỮ LẠI MỘT DẤU CÁCH
giữa chúng. Xâu như vậy gọi là xâu chuẩn.
(Từ là một xâu con không chứa dấu cách thuộc xâu đã cho mà nó được kết thúc bởi dấu cách SPACE, hoặc
dấu TAB.)
CODE.
ses crt;
var i:Byte; s:string;
Begin Clrscr;
Write('Nhap vao xau s co vai dau trong o giua cac tu:'); Readln(s);
While s=#32 do Delete(s,1,1);
While s[length(s)]=#32 do
Delete(s,length(s),1);
i:=1;
Repeat
If (s[i]=#32) and (s[i+1]=#32) then Delete(s,i,1)
Else Inc(i);
Until i>Length(s); {da xet het cac pt cua xau}
Write('Xau da khu trong :',s);
Readln;
End.
2/(VIẾT HOA KÝ TỰ ĐẦU CỦA TỪ) Cho trước một xâu gồm các từ mà chữ cái đầu của mỗi từ là chữ
thường. Hãy sửa các ký tự đầu của mỗi từ thành chữ HOA.
Vào: ton nu nguyet anh Ra: Ton Nu Nguyet Anh
CODE.
Uses Crt;
Const chuthg =['a'..'z']; {Khai bao hang xau}
Var xau:string; i,d:Byte;
Begin Clrscr;
Write(' Nhap xau:'); Readln(xau);
d:=length(xau);
8 h 54 m 28/7/2017
60
Thầy Trần Thông Quế
If xau[1] In chuthg Then xau[1]:=Upcase(xau[1]);
For i:=2 to d do
If (xau[i-1]=#32) and (xau[i] In chuthg) Then
xau[i]:=Upcase(xau[i]);
Write('Chu cai dau moi tu sua thanh chu hoa:',xau);
Readln;
End.
3/ (ĐỘ DÀI MAX CỦA XÂU CON CHUNG). Cho trước hai xâu s1 và s2. Tính độ dài max của xâu con
chung.
Vào: s1=xabcxxabcdxd; s2=aybcyabcdydy
Ra do dai max doan chung 2 xau=4
Uses Crt;
Var s1, s2:string;
Function lonnhat(a,b:integer):integer;
Begin
If (a>b) then lonnhat:=a
Else lonnhat:=b;
End;
Function DodaiMaxXauchung(Var x,y:string):integer;
Var m,n,i,j,v,t,kmax: integer;
a:array[1..255] of integer;
Begin
m:=length(x); n:=length(y);
kmax:=0;
Fillchar(a,sizeof(a),0);
For i:=1 to m do
Begin
v:=0;
For j:=1 to n do
Begin
t:=a[j];
If x[i]=y[j] then a[j]:=v+1
Else a[j]:=0;
kmax:=lonnhat(kmax,a[j]);
v:=t;
End;
End;
DodaiMaxXauchung:=kmax;
End;
Begin clrscr;
Write('xau s1='); Readln(s1);
Write('Xau s2='); Readln(s2);
Write('Do dai max cua doan chung thuoc 2 xau=',DodaiMaxXauchung(s1,s2));
Readln;
End.
8 h 54 m 28/7/2017
61
Xm: gồm m chữ cái X;
Thầy Trần Thông Quế
*4/ (ĐOẠN LẶP (ĐẦU BÀI LẤY TRONG “NHỮNG VIÊN NGỌC LẬP TRÌNH” CỦA JON BENTLEY-
BẢN DỊCH TIẾNG VIỆT: GIA VIỆT & MINH TRUNG. NXB THỐNG KÊ,11/2002)) Cho xâu s có độ dài
n. Xác định 2 số i, j thỏa mãn điều kiện 1 i < j n và k là số lớn nhất sao cho s[i] = s[j], s[i+1] = s[j+1], . .
., s[i+k-1] = s[j+k-1]. Hai đoạn bằng nhau trong s gồm k ký tự là s[i..i+k-1] và s[j..j+k-1] với i
62
Thầy Trần Thông Quế
Ví dụ. Vào: (AB3(C2D)2(C5D)0)2A3
Ra: ABBBCCDCCDABBBCCDCCDAAA
BẢNG DÒ VẾT CỦA PROGRAM:
n c m t GIẢI THÍCH
1 A 1 Viết A 1 lần
2 B 2 Viết B 2 lần
3 C 2 Viết C 2 lần
4 D 1 Viết D 1 lần
5 # 2 3 Không có ký tự để viết. Lặp 2 lần từ bước 3 đến bước 5
6 # 2 1 Không có ký tự để viết. Lặp 2 lần từ bước 1 đến bước 6
7 A 3 Viết A 3 lần.
CODE.
Uses Crt;
Const max=500;
chuso=['0'..'9']; chucai=['A'..'Z'];
Type mi1=Array[0..max] of integer;
mc1=Array[0..max] of char;
Var M,T,R,st: mi1; {M:so lan lap; T: tu;R: luu; st:Stack}
c:mc1; p:integer; {dinh stack} s:string;
v:integer; {index cua stack}
n: integer;
Procedure Incre_Index;
Begin
While (s[v]=#32) do
Inc(v);
End;
Function Napso:integer;
var so:integer;
Begin
so:=0;
Incre_Index;
If Not (s[v] in Chuso) then
Begin
Napso:=1;
Exit;
End;
While (s[v] In Chuso) do
Begin
so:=so*10+(Ord(s[v])-Ord('0'));
Inc(v);
End;
Napso:=so;
End;
8 h 54 m 28/7/2017
63
Thầy Trần Thông Quế
Procedure GanCnvaMn(ch:char);
Var so:integer;
Begin
Inc(v); so:=Napso;
If so=0 then Exit;
Inc(n);
C[n]:=ch; M[n]:=so;
End;
Procedure Chenngoac;
Begin
Inc(v);
Inc(p);
st[p]:=n+1;
End;
Procedure RutphantukhoiStack;
var tu, so: integer;
Begin
Inc(v); tu:=st[p];
Dec(p);
so:=Napso;
If (so=0) Then n:=tu-1;
If (so<2) Then Exit;
Inc(n);
C[n]:='#'; M[n]:=so; T[n]:=tu; R[n]:=so;
End;
Procedure Xulytiep;
Var i,j: integer;
Begin
Writeln('CAC BUOC KHAI TRIEN VA XAU KHAI TRIEN CUA XAU THU GON:');
For i:=1 to n do
Begin
Write(#13#10,i,'. ',C[i],#32,M[i],#32);
If C[i]='#' Then Write(T[i]);
Writeln;
End;
i:=1;
While (i<=n) Do
Begin
If (C[i]='#') Then
Begin
Dec(R[i]);
If (R[i]=0) Then
Begin
R[i]:=M[i];
Inc(i);
End
8 h 54 m 28/7/2017
64
Thầy Trần Thông Quế
Else i:=T[i];
End
Else
Begin
For j:=1 to M[i] Do
Write(C[i]);
Inc(i);
End;
End;
End;
Procedure Khaitrien(Var s:string);
Var i:integer;
Begin
s:=s+'#'; v:=1; p:=0;
While (s[v]<>'#') Do
Begin
If(s[v] In Chucai) Then GanCnvaMn(s[v])
Else If (s[v]='(') Then ChenNgoac
Else If (s[v]=')') Then RutphantukhoiStack
Else Inc(v);
End;
Writeln(s,':');
Xulytiep;
End;
Begin clrscr;
s:='(AB3(C2D)2(C5D)0)2A3';
Khaitrien(s);
Readln;
End.
*6/)(TỪ CHUẨN) Một từ loại M là dãy các chữ số có giá trị từ 1 đến M. Độ dài của từ là số lượng các chữ
số trong dãy. Từ loại M được gọi là từ chuẩn nếu nó không chứa hai đoạn con kề liền trong nó giống nhau.
Cho trước số nguyên N, tìm và ghi lên text file TUCHUAN.OU tất cả các từ chuẩn loại 3 dài N
(1<=N<=40000)
CODE.
Uses Crt;
Const mn=40;mn1=40000;
fo='tuchuan.ou';
Var v:Array[0..mn1] of byte;
n:integer;
f:text;
Function Bang(i,k:integer):Boolean;
Var j:integer;
Begin
Bang:=false;
For j:=0 to k-1 do
8 h 54 m 28/7/2017
65
Thầy Trần Thông Quế
If (v[i-j]<>v[i-k-j]) Then Exit;
Bang:=true;
End;
Function Chuan(i:integer):Boolean;
Var k:integer;
Begin
chuan:=false;
For k:=1 to (i DIV 2) do
If Bang(i,k) then Exit;
Chuan:=true;
End;
Function Tim(i:integer):Boolean;
Begin
Tim:=true;
While (v[i]<3) do
Begin
Inc(v[i]);
If chuan(i) then Exit;
End;
Tim:=False;
End;
Procedure Ketqua(d:integer);
Var i:integer;
Begin
If d=0 then Write(f,'Vo nghiem')
Else
Begin
Write(f,'Ngiem thu ',d,':');
For i:=1 to n Do
Write(f,v[i]);
Writeln(f);
End;
End;
Procedure Timtu(len:integer);
Var i:integer;
d:longint;
Begin
If(len<1) Or (len>mn) then Exit;
n:=len;
For i:=1 to n do v[i]:=0;
Assign(f,fo); Rewrite(f);
i:=1;
d:=0;
Repeat
If(i>n) then
8 h 54 m 28/7/2017
66
Thầy Trần Thông Quế
Begin
Inc(d);
Ketqua(d);
i:=n;
End;
If (i<1) then
Begin
If d=0 then Ketqua(0);
close(f);
Write('Done.');
Readln;
Exit;
End;
If Tim(i) Then Inc(i)
Else
Begin
v[i]:=0;
Dec(i);
End;
Until False;
End;
Procedure Test;
Begin
Clrscr;
Timtu(7);
End;
Begin {Main}
Test;
End.
7/ (DECODING BINARY-CODE) Cho mã nhị phân (Binary-code) của n chữ cái đầu tiên trong Alphabet
tiếng Anh. Biết rằng không có mã nào là khúc đầu của mã khác, và độ dài max của mỗi mã là 10. Lập trình
giải mã một đoạn cho trước.
Vào
5
0000
0001
0010
0011
110
0000000100010000
Ra
5
0000
0001
8 h 54 m 28/7/2017
67
Thầy Trần Thông Quế
0010
0011
110
14 E
16 A
17 B
18 C
19 D
CODE.
Uses crt;
Const fi='code.in'; fo='code.ou';
mn=2050;
Var a:Array[0..mn] of char; {mang tao Heap:cay ma}
Procedure giaima;
Var i,j,v,n:integer;
ch:char;
f,g:text;
x:string;
Begin
ch:='A';
Assign(f,fi); Reset(f);
Assign(g,fo); Rewrite(g);
Readln(f,n); Writeln(n,#13#10);
Fillchar(a,sizeof(a),0);
For i:=1 to n do
Begin
Readln(f,x); Writeln(x);
v:=1;
For j:=1 to length(x) do
If x[j]='0' Then v:=v*2
Else v:=v*2+1;
a[v]:=ch;
inc(ch);
End;
Writeln(#13#10);
For i:=1 to mn do
If(a[i]<>#0) then Writeln(i,#32,a[i]);
{Decoding}
While Not Eof(f) Do
Begin
Read(f,ch);
If (ch='0') or (ch='1') Then
Begin
v:=2*v;
If ch='1' Then v:=v+1;
If (a[v]<>#0) then
8 h 54 m 28/7/2017
68
Thầy Trần Thông Quế
Begin
Write(g,a[v]);
v:=1;
End;
End;
End;
Close(f); close(g);
End;
Begin clrscr;
giaima;
Writeln('DONE!');
Readln;
End.
8/ (CEASAR CODE) Trong mật mã học, mật mã Caesar, còn gọi là mật mã dịch chuyển, là một trong
những mật mã đơn giản và cổ nhất (nên hiện nay hầu không dùng). Mật mã này là một dạng của mật mã
thay thế, trong đó mỗi ký tự trong văn bản được thay thế bằng một ký tự cách nó một đoạn trong bảng chữ
cái để tạo thành bản mã. Vĩ dụ, nếu độ dịch là 3 (3 gọi là khóa mã), A sẽ được thay bằng D, Ă sẽ được thay
bằng C và cứ thế đến hết. Phương pháp được đặt tên theo Caesar, vị hoàng đế đã sử dụng nó thường xuyên
trong công việc.
Ví dụ:
Bản chữ cái chưa mã hóa (bản rõ): ABCDEFGHIJKLMNOPQRSTUVWXYZ
Bản chữ cái mật mã: DEFGHIJKLMNOPQRSTUVWXYZABC
Sau Ceasar, các nhà mật mã học, tổng quát mã này lên một chút: chọn K (số nguyên)
làm khóa mã và ký tự thứ I trong Alphabet được mã bởi ký tự thứ (I + K) MOD 27 với
0 <=I<=26.
Bài toán của chúng ta là: Cho trước từ điển gồm các từ khác nhau từng đôi một và không từ nào rỗng, chứa
các chữ cái hoa. Một văn bản S được mã hóa bởi mã Ceasar.
Hãy xác định khóa K để giải mã văn bản ấy (tức là cho biết bản rõ).
Dữ liệu vào lưu trên text file tên là CEASAR.IN, dòng thứ nhất ghi số từ N thuộc từ điển (N<=100); N dòng
tiếp theo ghi các từ của từ điển, mỗi từ có độ dài <= 20 và ghi trên một dòng. Dòng cuối cùng ghi văn bản S
có không quá 250 chữ cái đã được mã hóa bởi mã Ceasar nói trên. Lập trình chọn khóa K để khôi phục bản
rõ sao cho bản rõ chứa nhiều từ nhất của từ điển.
Dữ liệu ra lưu trên text file có tên CEASAR.OU mà dòng đầu ghi giá trị khóa K, dòng tiếp theo ghi bản rõ
của văn bản mã hóa S. Xem:
Vào. CEASAR.IN
7
HANOI
YES
PEDAGOGICAL
HELLO
UNIVERSITY
ITEM
HERO
IBOPJAQFEBHPHJDBMAVOJWFSTJUZAJJ bản mã
8 h 54 m 28/7/2017
69
Thầy Trần Thông Quế
CEASAR.OU
1
HANOI PEDAGOGICAL UNIVERSITY II
CODE.
Uses crt;
Const max=250; fi='Ceasar.In'; fo='Ceasar.Ou';
Type st21=String[21];
tudien=Array[1..max] Of st21;
Var td:tudien; ma,vb,kt,gm:string;
km,sl,slm:Byte; f:Text; n,k:Byte;
Procedure Init;
Var i:Byte;
begin
kt:=' ';
For i:=Ord('A') to Ord('Z') Do
kt:=kt+Char(i);
kt:=kt+kt;
Assign(f,'Ceasar.In'); Reset(f); Readln(f,n);
For i:=1 to n Do
Begin
Readln(f,td[i]); td[i]:=td[i]+' ';
End;
Readln(f,ma);
Close(f);
End;
Function Before(c:Char; k:Byte): Char;
Begin
Before:=kt[pos(c,kt)+27-k];
End;
Procedure Key_Find;
Var i,j:Byte;
Begin
km:=0; slm:=0;
For k:=1 to Length(ma) Do
Begin
vb[0]:=Succ(ma[0]);
For j:=1 to Length(ma) Do
vb[j]:=Before(ma[j],k); sl:=0;
For j:=1 to n Do
If pos(td[j],vb)>0 Then sl:=sl+1;
If sl>slm Then
Begin
slm:=sl; gm:=vb; km:=k;
End;
8 h 54 m 28/7/2017
70
Thầy Trần Thông Quế
End;
End;
Procedure Result;
Begin
Assign(f,'Ceasar.Ou'); Rewrite(f);
Writeln(f,km); Writeln(f,gm);
Close(f);
End;
Procedure Proccess;
Begin
Key_Find;
Result;
End;
Begin clrscr;
Init;
Proccess;
Write('Done!');
Readln;
End.
**9/ (BURROWS-WHEELER CODE, TẮT: BW-CODE, ĐỀ SƠ KHẢO OLYMPIC TIN HỌC QUỐC
TẾ).
Có nhiều phương pháp mã hoá thông tin được sử dụng rộng rãi để đảm bảo tính chất an toàn, bảo mật dữ
liệu. Ở vòng sơ loại thi tin học Quốc tế, có bài toán về mã BW đề cập tới một cách tiếp cận mới trong kỹ
thuật mã hóa và giải mã. Burrows Wheeler đề xuất phương pháp mật mã như sau: ví dụ ta cần mã hoá từ
BANANA, các bước tiến hành là:
Bước 1: Từ cần mã hoá được dịch chuyển vòng tròn và tạo thành một ma trận L*L ký tự, trong đó L là độ
dài của từ. Ta có:
BANANA
ANANAB
NANABA
ANABAN
NABANA
ABANAN
Bước 2: Sắp xếp lại các dòng của ma trận theo thứ tự từ điển:
ABANANANABANANANABBANANANABANANANABA
Bước 3: Tạo một xâu từ các ký tự CUỐI ở mỗi dòng, hiển thị xâu này và cho biết từ gốc là từ thứ mấy trong
ma trận nhận được ở bước 2 (tức là cần tạo cặp (st,d): st-xâu đã mã, 4: index của từ gốc trong xâu đã sắp từ
điển. Ta có (NNBAAA,4) là từ mã BURROWS WHEELER. Dưới đây là CODE.
Program BW_code;
Uses Crt;
Var n:integer;
8 h 54 m 28/7/2017
71
Thầy Trần Thông Quế
id:Array[0..256] of integer;
Procedure Doichoid(i,j:integer);
Var t:integer;
Begin
t:=id[i];
id[i]:=id[j];
id[j]:=t;
End;
Function So(Var s:string; i,j:integer):integer;
Var k: integer;
Begin
For k:=1 to n do
Begin
If (s[i]<>s[j]) Then
Begin
If s[i]
8 h 54 m 28/7/2017
72
Thầy Trần Thông Quế
If id[i]=1 then d:=i;
End;
End;
Procedure Bs(var u:string);
Var i,j:integer;
Begin
For i:=1 to n do id[i]:=i;
For i:=1 to n-1 do
For j:=n downto i+1 do
If u[id[j]]
8 h 54 m 28/7/2017
73
Thầy Trần Thông Quế
80
2 6
9 15
CODE.
Uses Crt;
Const fi='CNMAX.IN'; fo='CNMAX.OU';
mn=80; {Do dai toi dai cua xau ky tu}
Var f,g:Text;
ten:string[12];
m:Byte; {Chieu rong manh dat}
d:Longint; { Dem so dong}
x,y:String; {Theo thu tu: dong tren va dong duoi}
h:Array[0..mn] of Longint; { chieu cao ca cot}
dtmax:Longint; { Dien tich max}
axmax, cxmax:Longint; aymax, cymax:Byte; {Toa do diem a,c}
Procedure Ghi;
Begin
Assign(g,fo); Rewrite(g);
Writeln(g,dtmax);
Writeln(g,axmax,#32,aymax);
Writeln(g,cxmax,#32,cymax);
close(g);
end;
Function Dientich(i:Byte; Var c1,c2: Byte):Longint;
Begin
c1:=i;
While (y[c1-1]=y[i]) And (h[c1-1]>=h[i]) Do
Dec(c1);
c2:=i;
While (y[c2+1]=y[i]) And (h[c2+1]>=h[i]) Do
Inc(c2);
Dientich:=h[i]*(c2+1-c1);
End;
Procedure Run;
Var i,c1,c2:Byte; dt:Longint;
Begin
Write('Cho biet ten tep chua data vao:'); Readln(ten);
Assign(f,ten); Reset(f); Readln(f,m);
d:=0;
x:=#32;
For i:=1 to m Do x:=x+#32;
FillChar(h, sizeof(h),0);
While Not Eof(f) Do
Begin
8 h 54 m 28/7/2017
74
Thầy Trần Thông Quế
Readln(f,y);
Inc(d);
For i:=1 to m Do
If y[i]=x[i] then Inc(h[i]) Else h[i]:=1;
For i:=1 to m Do
Begin
dt:=Dientich(i,c1,c2);
If dt>dtmax Then
Begin
dtmax:=dt;
axmax:=d-h[i]+1; aymax:=c1;
cxmax:=d; cymax:=c2;
End;
End;
x:=y;
End;
Close(f);
Ghi;
End;
Procedure Xem;
Var g:Text; Line:String;
Begin
Writeln('KET QUA CHAY CHUONG TRINH:');
Writeln('* * * * * * * * * * * * *');
Writeln;
Assign(g,'CnMax.Ou'); Reset(g);
While Not SeekEof(g) Do
Begin
Readln(g,Line);
Writeln(#32:7,Line);
End;
Close(g);
End;
Begin clrscr;
Run;
Xem;
Readln
End.
**11/ OLYMPIC TIN HỌC QUỐC TẾ NĂM 2000 TẠI BẮC KINH (HỦY ĐI ÍT NHẤT CÁC KÝ TỰ ĐỂ
PHẦN CÒN LẠI CỦA XÂU VẪN LÀ PALINDROM)
Dãy ký tự s gọi là PALINDROM nếu đọc xuôi, đọc ngược nó đều như nhau. Cho trước s độ dài n gồm các
chữ cái hoa, thường (có phân biệt) và các chữ số. Cho biết cần xóa đi ít nhất bao nhiêu ký tự trong s để
phần còn lại của s cũng là một PALINDROM. Giả sử sau xóa các ký tự còn lại của s tự động xích lại gần
nhau.
YÊU CẦU: Dùng 3 cách: ĐẸ QUY; MỘT MẢNG 1-CHIỀU; 2 MẢNG 1-CHIỀU
8 h 54 m 28/7/2017
75
Thầy Trần Thông Quế
Test Vào: Palindr.vao
9 độ dài xâu s
baeadbadb
Ra: Palindr.ra
4 số ít nhất các ký tự cần xóa
CODE.
Uses Crt;
Const mn=51;
fi='Palindro.in';
Type mi1=Array[0..mn] of Integer;
mi2=Array[0..mn] of mi1;
mc1=Array[0..mn] of Char;
Var n:integer;
f:Text;
s:mc1;
d,v:mi1;
c:mi2;
Procedure Doc;
Var i:integer;
Begin
Assign(f,fi); Reset(f);
Read(f,n);
For i:=1 to n do Read(f,s[i]);
End;
Function max(a,b:Integer):Integer;
Begin
If (a>b) Then max:=a
Else max:=b;
End;
Function Dequy(i,j:integer):integer;
Begin
if (i>j) then Dequy:=0
Else If i=j Then dequy:=1
Else
If s[i]=s[j] Then Dequy:=Dequy(i+1,j-1)+2
Else
Dequy:=Max(Dequy(i,j-1), Dequy(i+1,j));
End;
Procedure Qhd2; {DunG 2 mang 1-chieu v va d}
Var i,j: Integer;
Begin
Fillchar(v,sizeof(v),0);
For j:=1 to n do
Begin
8 h 54 m 28/7/2017
76
Thầy Trần Thông Quế
d[j]:=1;
For i:=j-1 Downto 1 do
Begin
If s[i]=s[j] Then d[i]:=v[i+1]+2
Else d[i]:=Max(v[i],d[i+1])
End;
v:=d;
End;
Writeln(n-d[1])
End;
Procedure Qhd1; {Dung 1 mang 1-chieu}
Var i,j,t,tr:Integer;
Begin
For j:=1 to n do
Begin
Tr:=0;
d[j]:=1;
For i:=j-1 downto 1 do
Begin
t:=d[i];
If s[i]=s[j] then d[i]:=tr+2
else d[i]:=Max(d[i],d[i+1]);
tr:=t;
End;
End;
Write(n-d[1]);
End;
Procedure Test;
Begin
Doc;
Writeln('Dung Dequy: so it nhat cac ky tu can xoa=', n-Dequy(1,n));
Write('Dung 2 Mang 1 chieu:so it nhat ca ky tu can xoa=');
Qhd2;
Write('Dung 1 Mang mot chieu:so it nhat cac ky tu can xoa=');
Qhd1;
End;
Begin Clrscr;
Test;
Readln;
End.
12/ (OLYMPIC MOCKBA -TỪ ĐIỂN) Từ điển Dic gồm nhiều nhất 100 từ khác nhau đôi một. Mỗi từ có
độ dài tối đa là 50 và được viết trên một dòng. Cho trước xâu s có độ dài không quá 200 ký tự. Hãy cho biết
cần xóa khỏi s bao nhiêu ký tự để phần còn lại tạo thành một dãy liên tiếp các từ trong từ điển Dic, mỗi từ
có thể xuất hiện nhiều lần. Từ điển Dic được lưu trên text file Dic.in và kết qủa chạy program lưu tren text
file Dic.ou có cấu trúc và nội dung như dưới đây:
8 h 54 m 28/7/2017
77
Thầy Trần Thông Quế
Dic.in Dic.ou
6 5
abba
not
is
astra
saint
panama
saintpavnamtranasnotsaintabba
Dic.ou
5
Giải thích
*Số ký tự cần xóa=5
*Các ký tự đã xóa là: v, t, r, n, a (các chữ gạch chân): saintpavnamtranaisnotsaintabba
*Các từ ghép lại là: 5,6,3,2,5,1: saintpanamaisnotsaintabba
CODE.
Uses Crt;
const fi='dictio.in'; fo='dictio.ou';
Type st=string[60];
Var f,g:Text;
s:string[200];
w:Array[1..110] of st;
d:Array[0..205] of integer;
n, kq:integer;
Procedure Doc;
Var i:integer;
Begin
Assign(f,fi); Reset(f);
Readln(f,n);
For i:=1 to n do Readln(f,w[i]);
Readln(f,s);
Close(f);
End;
Procedure Ghi(v:integer);
Begin
Assign(g,fo); Rewrite(g);
Writeln(g,v);
Close(g);
End;
Function So(var w:st; i:integer):integer;
Var j:integer;
Begin
so:=0;
8 h 54 m 28/7/2017
78
Thầy Trần Thông Quế
j:=Length(w);
If j>i Then Exit;
If w[j]<>s[i] then Exit;
For I:=i Downto 1 do
If(s[i]=w[j]) Then
Begin
Dec(j);
If j=0 Then
Begin
So:=i; exit;
End;
End;
End;
Function min(a,b:integer):integer;
Begin
If(a0 then d[i]:=min(d[i],d[v-1]+i-v+1-length(w[j]));
End;
End;
Function Xuly:Integer;
var m,i:integer;
Begin
d[0]:=0;
m:=length(s);
For i:=1 to m do Tinh(i);
Xuly:=d[m];
End;
Begin Clrscr;
Doc;
kq:=Xuly;
Ghi(kq);
Writeln('So min cac chu cai can xoa de phan con lai la day lien tiep cac tu thuoc Tu dien=',kq ');
Readln;
End.
8 h 54 m 28/7/2017
79
Thầy Trần Thông Quế
PHẦN V. ĐỆ QUY & QUAY LUI
(RECURSION & BACKTRACKING)
VIẾT CÁC HÀM HOẶC THỦ TỤC ĐỆ QUY GIẢI CÁC BÀI TOÁN SAU:
1/ Tìm ước số chung lớn nhất (USCLN) của 2 số. Áp dụng để tìm USCLN của n số đọc từ bàn phím vào.
CODE:
Program uscln;
Uses crt;
Var i,n,uc,tt:Integer;
a:array[1..1000] of integer;
Function uscmax(x,y:integer):integer;
Begin
If (y=0) Then uscmax:=x
Else uscmax:=uscmax(y,x MOD y)
End;
Begin clrscr;
Randomize;
Repeat
Write('Ban can bao nhieu so?:'); Readln(n);
For i:=1 to n do a[i]:=Random(100);
{Begin
Writeln('So thu ',i,':');
Readln(a[i]);
End;}
Writeln('Day so vua nhap:');
For i:=1 to n do Write(a[i]:3);
i:=1;
Repeat
uc:=uscmax(uc,a[i]);
Inc(i);
Until i=n+1;
Writeln;
Write('Uoc so chung lon nhat cua ',n,' so vua nhap=',uc);
Writeln;
Write('More (1/0)?. More->go 1; Stop->go 0:'); Readln(tt);
Until tt=0;
End.
2/ (KHÔNG ĐƯỢC DÙNG MẢNG). Tìm USCLN của 5 số đọc từ bàn phím vào. (Bài này có vẻ khó hơn
bài trên với một số học sinh!)
CODE:
Program uso;
Uses crt;
Var a,b,c,d,e,uc1,uc2,uc3,uc1a,uc1b:integer;
8 h 54 m 28/7/2017
80
Thầy Trần Thông Quế
Function ucln(x,y:longint):longint;
Begin
if y=0 then ucln:=x
Else ucln:=ucln(y,x MOD y);
End;
Begin clrscr;
Write('Nhap 5 so a,b,c,d,e:'); Readln(a,b,c,d,e);
uc1:=ucln(a,b);
uc2:=ucln(c,d);
uc3:=ucln(e,uc2);
uc1a:=ucln(uc1,uc2);
uc1b:=ucln(uc1a,uc3);
Write('Usc lon nhat cua 5 so vua nhap:',ucln(a,b));
Readln;
End.
3/ Đảo ngược một số nguyên dương gồm n chữ số (n>=2) đọc từ bàn phím vào. Ví dụ 2017 đảo ngược
thành 7102
CODE:
Program Dao_so;
Uses crt;
Var n:longint;
Procedure Daoso(so:longint);
Var csdv,caccscl:integer;
Begin
If (so<10) then Write(so)
Else Begin
csdv:=so MOD 10; {xac dinh chu so hang don vi}
caccscl:=so DIV 10; {xac dinh cac chu so con lai}
Write(csdv);
Daoso(caccscl);
End;
End;
Begin clrscr;
Writeln;
Write('Nhap vao mot so nguyen duong:'); Readln(n);
Write('So ',n,' viet nguoc lai la:');
Daoso(n);
Readln;
End.
4/ (DÃY FIBONACCI NỔI TIẾNG). Hai bài thú vị về dãy này:
4.1- Tìm và in lên màn số Fibonacci thứ k.
CODE:
Program So_Fibonacci_thu_K;
USES CRT;
Var K:Longint; tt:Byte;
FUNCTION Fibo(m:Longint):Longint;
8 h 54 m 28/7/2017
81
Thầy Trần Thông Quế
Begin
If ((m=1) Or (m=2)) Then
Fibo:=1
Else
Fibo:=Fibo(m-1) + Fibo(m-2);
End;
BEGIN CLRSCR;
Repeat
Writeln('TIM SO FIBONACI THU K');
Writeln('---------------------');
Write('-Nhap so K= ');
Readln(K);
Writeln('So Fibonacci thu ',k,' = ',Fibo(K));
Writeln;
Write('More (1/0)?. Come on -> Press 1; Stop -> Press 0:');
Readln(tt);
Until tt=0;
END.
4.2- Cho trước độ dài n. Tìm và in lên màn dãy Fibonacci có độ dài n cho trước.
CODE:
Program Fibo;
Uses crt;
Var i,n: longint;
Function Fibona(i: longint): longint;
Begin
if (i<3) then fibona:=1
Else Fibona:=Fibona(i-1)+Fibona(i-2);
End;
Begin clrscr;
Write('n='); Readln(n);
Write('Day Fibonaci can tim ung voi do dai cho truoc ',n,' la:');
For i:= 1 to n do
Write(Fibona(i):6);
Readln
End.
5/ Dùng ĐỆ QUY, tìm cách và hiển thị các bước của cách ấy chuyển n đĩa có lỗ ở giữa (n đọc từ bàn phím
vào) từ cọc 1 sang cọc 2 được dùng cọc trung gian 3 trong quá trình chuyển. Luật chơi:
• Mỗi lần chỉ được chuyển 1 đĩa,
• Đĩa nhỏ ở trên đĩa lớn,
• Khi chuyển không được đặt đĩa trên bất cứ mặt bằng nào (mặt bàn, ghế, nền nhà . . .).
CODE:
Uses Crt;
var n, count:integer; hoi:char;
Procedure Move(n,c1,c2,c3: integer);
Begin
8 h 54 m 28/7/2017
82
Thầy Trần Thông Quế
If n=1 Then
Begin
Writeln('Chuyen dia tu coc ',C1,' sang coc ',C2);
Inc(count);
End
Else
Begin
Move(n-1,C1,C3,C2);
Move(1,C1,C2,C3);
Move(n-1,C2,C1,C3);
End;
End;
Begin clrscr;
Repeat
Write('Nhap so dia can chuyen:'); Readln(n);
count:=0;
Move(n,1,2,3);
Write('So lan chuyen dia=',count);
Writeln;
Writeln('= = = = = = = = = = = = = = ');
Write('Thu nua chu (c/k)? Tiep=>go c, ngung=> go k:');
Readln(hoi);
Until hoi IN ['k', 'K'];
End.
CHÚ Ý BỔ ÍCH: KHI TEST, CHỚ CÓ TEST VỚI SỐ ĐĨA LỚN, VÍ DỤ VỚI N=64. Dùng trị số này,
có chồng chất 100 lần tuổi thọ của bạn cũng không đủ thời gian chờ kết quả chạy chương trình (với N=64) !
6/ Liệt kê các hoán vị của N số đọc từ bàn phím vào và cho biết tổng số các hoán vị ấy. Yêu cầu: Mỗi lần
chỉ hiện lên màn 20 kết quả, xem tiếp gõ ENTER. Ví dụ vào N=6 thì tổng số hoán vị bằng 720.
Program HoanVinhodequy;
Uses crt;
Type chuoi=Array[1..20] of Integer;
Var a:chuoi; m,n,i,dem:integer;
Procedure Init;
Var i:Integer;
Begin
for i:=1 to n do a[i]:=i;
End;
Procedure Doicho(var x,y:integer);
var tg:integer;
Begin
tg:=x; x:=y;y:=tg;
End;
8 h 54 m 28/7/2017
83
Thầy Trần Thông Quế
Procedure Inra;
var i:integer;
Begin
Writeln; Inc(dem);
For i:=1 to n do
Write(a[i]:4);
If (dem MOD 20)=0 then Readln;
End;
Procedure Hoanvi(i:integer);
var j:integer;
Begin
If i=1 then Inra
Else
For j:=i downto 1 do
Begin
Doicho(a[i],a[j]);
Hoanvi(i-1);
Doicho(a[i],a[j]);
End;
End;
{Main Program}
Begin clrscr;
dem:=0;
Write('Nhap so luong so n can hoan vi:');readln(n);
Writeln(' Cac hoan vi cua ',n,' so: ');
Init;
Hoanvi(n);
Writeln; Writeln;
If dem<>0 then Write('Tong cong co ',dem,' hoan vi cua ',n,' so.');
Readln;
End.
7/Vẽ liên tiếp các hình vuông nội tiếp trong hình vuông đã cho, sao cho các đỉnh của hình vuông nội tiếp là
điểm giữa của các cạnh của hinh vuông ngoại tiếp nó.
KHUẾN CÁO ĐÁNG NGHE: Code đồ họa dưới đây (cũng như mọi Code đồ họa khác), đòi hỏi chạy ở
MODE FULL CREEN, mà các Windows từ VERSION 7 trở lên không hỗ trợ FULL CREEN. Nói vậy tức
là bạn chỉ chạy được các GRAPHIC PROGRAM trong WinXp.
CODE (Phải chạy trên nền WinXp)
uses crt, graph;
const w=400;
Var gd,gm:integer;
procedure hv(x1,y1,x2,y2,x3,y3,x4,y4, sb:integer);
Begin
setcolor(sb mod 15+1);
line(x1,y1,x2,y2);
line(x2,y2,x3,y3);
8 h 54 m 28/7/2017
84
Thầy Trần Thông Quế
line(x3,y3,x4,y4);
line(x4,y4,x1,y1);
If sb>0 then
hv((x1+x2) DIV 2, (y1+y2) DIV 2,(x2+x3) DIV 2,(y2+y3) DIV 2,
(x3+x4) DIV 2,(y3+y4) DIV 2,(x4+x1) DIV 2,(y4+y1)DIV 2,sb-1);
End;
Begin clrscr;
gd:=detect;
Initgraph(gd,gm,' ');
hv((getmaxX-w) DIV 2,(getmaxY-w) DIV 2,(getmaxX-w) DIV 2,
(getmaxY+w) DIV 2,
(getmaxX+w) DIV 2,(getmaxY+w) DIV 2,(getmaxX+w) DIV 2,
(getmaxY-w) DIV 2,16);
Readln;
closeGraph;
End.
8/ Viết các hàm đệ quy tính các tổng S sau:
8.1- Tính N!! . Sau đó dùng hàm đó để tính: S=1!!-2!!+…+(-1)k+1k!! (k<1000)
8.2- S=1+22+33+44. . .+nn
8.3- S=
có n dấu căn.
8.4- S=
*8.5- S(n)= trong đó x là số thực
GỢI Ý: Nếu như thoạt nhìn, không thấy quy luật dùng đệ quy ở biểu thức đã cho, thì hãy biến đổi toán học
nó sao cho xuất hiện biểu thức dùng được đệ quy.
Chẳng hạn bài 8.5 có vẻ khó nhất với các bạn. Ta biến đổi nó như sau:
a) Nhìn vào hệ thức (8.5) ta suy ra:
S(n-1) =
S(n-2) =
b) Tính hiệu S(n) – S(n-1) ta được S(n) = S(n-1) + (*)
8 h 54 m 28/7/2017
85
Thầy Trần Thông Quế
c) Tính hiệu S(n-1) – S(n-2) ta được (**)
Thế (**) vào (*) ta có ngay quy luật để thiết kế đệ quy tính S(n):
S(n) = S(n-1) + quy luật đệ quy đã hiện rõ!
Việc còn lại (viết code tính S(n)) là việc dễ đối với các bạn!
9- Liệt kê tất cả các dãy nhị phân dài n (n đọc từ bàn phím vào).
Uses Crt;
Var i,n:integer;
b:Array[1..100] of 0..1; tt:byte;
Procedure Result;
Var i: Integer;
Begin
For i:=1 to n Do Write(b[i]:2); Writeln;
End;
Procedure Try(i:Integer);
Var j:Integer;
Begin
For j:=0 to 1 do
Begin
b[i]:=j;
If i=n Then Result Else Try(i+1);
End;
End;
Begin clrscr;
Repeat
Write('Nhap n:'); Readln(n);
Try(1);
Writeln;
Write('Another Test (1/0)?. Come on -> Press 1, Stop -> Press 0:');
Readln(tt);
Until tt=0;
End.
*10- Điền các dấu “(“, “)” và 4 phép tính số học vào một biểu thức số học để tính đúng gía trị n cho trước.
Program Dien_dau_phep_tinh;
Uses crt;
8 h 54 m 28/7/2017
86
Thầy Trần Thông Quế
Var p,a:array[1..100] of char;
i,j,k,h,d:longint; n:real;hoi:char;
Procedure Inra;
Begin
Write('(((((');
For i:=1 to 6 do
Begin
If i=1 then Write(i,a[i]);
If i>1 then Write(i,')',a[i]);
End;
Writeln;
d:=d+1;
End;
Procedure Test(k:integer);
Var j,i1:integer; t:real;
Begin
For j:=1 to 4 do
Begin
a[k]:=p[j];
If k=5 then
Begin
t:=1;
For i1:=2 to 6 do
Begin
If a[i1-1]='-' then t:=t-i1;
If a[i1-1]='+' then t:=t+i1;
If a[i1-1]='*' then t:=t*i1;
If a[i1-1]='/' then t:=t/i1;
End;
If t=n then Inra;
End
Else Test(k+1);
End;
End;
Begin clrscr;
Repeat
Writeln;
Write('Nhap gia tri n can co='); Readln(n);
d:=0;
p[1]:='-';
p[2]:='+';
p[3]:='*';
p[4]:='/';
Test(1);
Writeln;
Writeln(' Co ',d,' cach dien cac phep tinh de bieu thuc da cho co gia tri bang so ',n:9:2);
8 h 54 m 28/7/2017
87
Thầy Trần Thông Quế
Write('Another Test (y/n)?'); Readln(hoi);
Until hoi In ['n','N'];
End.
11- Cho trước bộ số 1, 2, 3, 4. Liệt kê tất cả các số dài n lập nên từ bộ số đã cho.
CODE.
Uses Crt;
Var n:Byte;
a:Array[1..20] of Byte; Ans:Char;
Procedure Result_Print;
Var i:Byte;
Begin
For i:=1 to n Do
Write(a[i]);
End;
Procedure For_Recur(i:integer);
Var j:Byte;
Begin
For j:=1 to 4 do
Begin
a[i]:=j;
If i Press c; Stop-.Press k or K.');
Readln(Ans);
Until Ans In ['k', 'K'];
End.
**12- Nhập vào một dãy số có n phần tử (n cho trước). Phân hoạch dãy này thành các dãy con. Tìm ước số
chung lớn nhất của các số thuộc mỗi dãy con. In kết quả lên màn.
Program PhanHoach_Tap;
uses crt;
Type m=array[1..100] of integer;
Var c,a:m;
p:array[1..100] of Boolean;
z,i,n,dem:integer;
8 h 54 m 28/7/2017
88
Thầy Trần Thông Quế
Function uscln(a,b:integer):integer;
Begin
while a<>b do
begin
if a>b then a:=a-b
Else b:=b-a;
end;
uscln:=b;
end;
Procedure thu(k:integer);
var j,i1,us1,i,j1:integer;
Begin
for j:=z to n do
if p[j] then
Begin
c[k]:=a[j]; p[j]:=False;
If k>1 then
Begin
dem:=dem+1;
Writeln('* Tap con thu ',dem,' la:');
For i1:=1 to k do
write(c[i1]:4);Writeln;
us1:=c[1];
For j1:=2 to k do us1:=uscln(us1,c[j1]);
Write('Uoc so chung lon nhat cua ');
Writeln(' tap con thu ',dem,' la:',us1);
End;
If k<>n then
Begin
z:=j+1; Thu(k+1);
End;
p[j]:=true;
z:=j-1;
End;
End;
Begin clrscr;
Write('Vao n='); Readln(n);
For i:=1 to n do
Begin
Write('a[',i,']='); Readln(a[i]);
End;
dem:=0; z:=1;
For i:=1 to n do p[i]:=true;
Thu(1);
Writeln;
Writeln('Voi so n=',n,' vua nhap vao, so tap con =',dem);
8 h 54 m 28/7/2017
89
Thầy Trần Thông Quế
Readln { không có “;” cũng như có “;” }
End.
*13-Cho bộ 9 chữ cái a, b, c, d, e, f, g, h, i. Lập trình tạo các từ có từ 2 đến 4 chữ cái (trong đó có ít nhất 1
nguyên âm) thuộc bộ trên. Kết qủa lưu lên text file cactu.ou
Uses Crt;
Const chucai=['a','e','i'];
fo='cactu.ou';
Var c:ArrAy[1..5] Of Char;
yes:Boolean;
dem, n:longint;
f:text;
Procedure WriteTo;
Var i:integer;
Begin
{Inc(dem);}
For i:=1 to n Do Write(f,c[i],' ');
Writeln(f);
End;
Procedure Tim(i:Integer);
Var ch:char; nho:Boolean;
Begin
Nho:=yes;
For ch:='a' to 'i' do
Begin
c[i]:=ch;
If ch In chucai then yes:=True;
If (i=n) Then
Begin
If yes then WriteTo
End
Else
Tim(i+1);
yes:=nho;
End;
End;
Begin clrscr;
{Dem:=0;}
Assign(f,fo); Rewrite(f);
For n:=2 to 4 do
Begin
yes:=False;
Tim(1);
End;
{Writeln(f,'So tu da liet ke=',dem);}
8 h 54 m 28/7/2017
90
Thầy Trần Thông Quế
Close(f);
Write('Done!');
Readln;
End.
14/ Tìm cách xếp 8 quân xe lên bàn cờ tướng 8x8 để không quân nào ăn được nào. Yêu cầu: Mỗi lần xem
từng kết quả một. Xem tiếp gõ ENTER; Thoát gõ CTRL-ECS.
Uses Crt;
Const fo='tamxe.ou';
Var f:Text; d:word; line:string;
cx:Array[1..8] Of Boolean;
a:Array[1..8] of Byte;
Procedure WriteOnFile;
Var i:Byte;
Begin
Inc(d);
Writeln(f);
Write(f,'cachh thu ',d,':');
For i:=1 to 8 do Write(f,'[',i,',',a[i],']',';');
End;
Procedure Try(k:Byte);
Var i:Byte;
Begin
For i:=1 to 8 do
If cx[i] Then
Begin
a[k]:=i;
cx[i]:=False;
If k=8 then WriteOnFile Else Try(k+1);
cx[i]:=True;
End;
End;
Begin Clrscr;
d:=0;
FillChar(cx,sizeof(cx),True);
Assign(f,fo); Rewrite(f);
Try(1);
Reset(f);
While Not SeekEof(f) Do
Begin
Readln(f,line);
Writeln(#32:7,line);
If (d MOD 20)=0 Then Readln; {De xem tung dap so mot; Go CTRL-ESC: Thoat}
End;
Close(f);
8 h 54 m 28/7/2017
91
Thầy Trần Thông Quế
Readln;
End.
= = = = = = = = = = = = = = = = = =
PHẦN VI. BẢN GHI & TỆP (RECORD and FILES)
Lập trình làm các việc sau:
RECORD
1/Thực hiện các phép toán trên hai phân số.
Uses Crt;
Type phanso=Record
ts,ms:Integer;
End;
Var ps1,ps2,ps3:phanso; pheptoan,tiep: char;
err: Boolean;
Procedure Nhap(Var ps:phanso);
Begin
Write('Nhap tu:');Readln(ps.ts);
Write('Nhap mau:');Readln(ps.ms);
End;
Procedure Xuat(Var ps:phanso);
Begin
Write('(',ps.ts,'/',ps.ms,')');
End;
Procedure Cong(ps1,ps2:phanso; Var tps:phanso);
Begin
tps.ts:=ps1.ts*ps2.ms+ps1.ms*ps2.ts;
tps.ms:=ps1.ms*ps2.ms;
End;
Procedure Tru(ps1,ps2:phanso; Var tps:phanso);
Begin
tps.ts:=ps1.ts*ps2.ms-ps1.ms*ps2.ts;
8 h 54 m 28/7/2017
92
Thầy Trần Thông Quế
tps.ms:=ps1.ms*ps2.ms;
End;
Procedure Nhan(ps1,ps2:phanso; Var tic:phanso);
Begin
tic.ts:=ps1.ts*ps2.ts;
tic.ms:=ps1.ms*ps2.ms;
End;
Function Uscln(a,b:integer):integer;
Begin
While a<>b do
If a> b then a:=a-b
Else b:=b-a;
Uscln:=a;
End;
Procedure Rutgon(Var ps:phanso);
Var uc:integer;
Begin
uc:=Uscln(ps.ts,ps.ms);
ps.ts:=ps.ts DIV uc;
ps.ms:=ps.ms DIV uc;
End;
Procedure Doidau(Var ps:phanso);
Begin
ps.ts:=-ps.ts;
End;
Procedure Ngichdao(Var ps:phanso);
Var tam:integer;
Begin
tam:=ps.ts;
ps.ts:=ps.ms;
ps.ms:=tam;
End;
{Main Prog.}
Begin clrscr;
Repeat
8 h 54 m 28/7/2017
93
Thầy Trần Thông Quế
Write('Nhap ps thu nhat:'); Writeln;
Nhap(ps1);
Write('Nhap ky hieu phep toan:'); Readln(pheptoan);
err:=false;
If pheptoan In ['+','-','*',':'] Then
Begin
Writeln;
Write('Nhap ps thu hai:');
Writeln;
Nhap(ps2);
Write('Ket qua:');
Xuat(ps1);
Write(pheptoan);
xuat(ps2);
Write('=');
Case pheptoan of
'+':Begin Cong(ps1,ps2,ps3); Rutgon(ps3); End;
'-':Begin
Tru(ps1,ps2,ps3);
Doidau(ps2);
cong(ps1,ps2,ps3);
Rutgon(ps3);
End;
'*':Begin nhan(ps1,ps2,ps3);Rutgon(ps3); End;
':':If ps2.ts<>0 then
Begin
Ngichdao(ps2);
Nhan(ps1,ps2,ps3);
Rutgon(ps3);
End
Else err:=true;
End;
If Not err Then
Begin
Xuat(ps3);
Writeln;
Write('Go phim bat ky de tiep tuc cong viec!'); Readln;
Clrscr;
End
Else Write('Loi: khong chia duoc cho Zero!');
8 h 54 m 28/7/2017
94
Thầy Trần Thông Quế
Writeln;
End
Else Writeln('Program chua lam duoc phep toan nay!');
Write('More(y/n)?, tiep -> go y, ngung -> go n:');
Readln(tiep);
Until tiep='n';
End.
2/ Thực hiện các phép toán trên hai đa thức
Uses Crt;
Const max=20;
Type dathuc=record
bac:integer;
hso:Array[0..max] of real;
End;
Var a,b,c:dathuc; i:integer;
Procedure Nhap(kh:String; var p:dathuc);
Begin
Writeln; Writeln;
With p do
Begin
Repeat
Write('Nhap vao lan luot bac ',Chr(Ord(kh[1])+7),
' va cac he so cua da thuc ',kh,'=');
Readln(bac);
If bac>max Then
Write('Bac cua da thuc phai <=max)',max);
Until (Bac>=1) And (Bac<=max);
For i:=bac downto 0 Do
Begin Write(#32:3,'a[',i,']='); Readln(hso[i]); End;
End;
End;
Procedure PolyDisp(kyhieu:string; p:dathuc);
Begin
Write(kyhieu,'=');
With p do
Begin
For i:=bac downto 1 Do
8 h 54 m 28/7/2017
95
Thầy Trần Thông Quế
Begin
If hso[i]<>0 Then
Begin
If Frac(hso[i])=0 Then
Write(hso[i]:0:0,'.x')
Else Write(hso[i]:0:2,'.x');
If i>1 then Write('^',i);
End;
If hso[i-1]>0 Then Write('+');
End;
If hso[0]<>0 Then
If Frac(hso[0])=0 Then Write(hso[0]:0:0)
Else Write(hso[0]:0:2);
End;
Writeln;
End;
Procedure PolyAdd(p,q:dathuc; Var sum:dathuc); {cong da thuc}
Var i,j:integer;
Begin
If p.bac>q.bac Then sum.bac:=p.bac
Else sum.bac:=q.bac;
For i:=sum.bac downto 0 Do
sum.hso[i]:=p.hso[i]+q.hso[i];
Write('Tong cua 2 d/thuc f(x) va g(x) la:');
Polydisp('S(x)',sum);
End;
Procedure PolySubt(p,q:dathuc; Var h:dathuc); {tru da thuc}
Var i,j:integer;
Begin
If p.bac>q.bac Then h.bac:=p.bac
Else h.bac:=q.bac;
For i:=h.bac downto 0 Do
h.hso[i]:=p.hso[i]-q.hso[i];
Write('Hieu cua 2 d/thuc f(x) va g(x) la:');
Polydisp('H(x)',h);
End;
Procedure PolyFact(p,q:dathuc; Var tic:dathuc); {nhan da thuc}
Var i,j:integer;
Begin
8 h 54 m 28/7/2017
96
Thầy Trần Thông Quế
tic.bac:=p.bac+q.bac;
For i:=0 to tic.bac do tic.hso[i]:=0;
For i:=p.bac downto 0 Do
For j:=q.bac downto 0 Do
tic.hso[i+j]:=tic.hso[i+j]+p.hso[i]*q.hso[j];
Write('Tich cua 2 dthuc f(x) va g(x) la:');
Polydisp('T(x)',tic);
End;
Procedure PolyDivi(p,q:dathuc; Var thg:dathuc); {chia da thuc}
Var i,j,m:integer; du:dathuc;
Begin
m:=p.bac-q.bac;
If m<0 Then
Begin
Write('Khong chia duoc!');
Readln;
Exit;
End;
For i:=0 to m Do thg.hso[i]:=0;
thg.bac:=m;
For i:=m Downto 0 Do
Begin
thg.hso[i]:=p.hso[p.bac]/q.hso[q.bac];
For j:=q.bac downto 0 Do
p.hso[p.bac-q.bac+j]:=p.hso[p.bac-q.bac+j]-thg.hso[i]*q.hso[j];
p.bac:=p.bac-1;
End;
du:=p;
While (du.hso[du.bac]=0) and (du.bac>0) Do
du.bac:=du.bac-1;
Write('Thuong cua 2 dthuc f(x) va g(x) la:');
PolyDisp('Th(x)',thg);
If (du.bac=0) then Write('2 dthuc da cho chia het nhau!')
Else Polydisp('Da thuc du',du);
End;
{Main Prog}
Begin clrscr;
Nhap('f(x)',a);
Nhap('g(x)',b);
Writeln('Cac da thuc vua nhap:');
PolyDisp('f(x)',a);
8 h 54 m 28/7/2017
97
Thầy Trần Thông Quế
PolyDisp('g(x)',b);
Writeln;
PolyAdd(a,b,c);
Writeln;
PolySubt(a,b,c);
Writeln;
PolyFact(a,b,c);
Writeln;
PolyDivi(a,b,c);
Readln;
End.
3/Thực hiện các phép toán trên hai số phức. (Với nhiều học sinh, phép tính chia hai số phức
là khó nhất!)
Uses Crt;
Type complex=Record
thuc,ao:Real;
End;
Var a,b,c: complex;
Procedure Input(kt: Char; Var x: complex);
Begin
Writeln('Nhap so phuc ',kt,':');
Write('Phan thuc:'); Readln(x.thuc);
Write('Phan ao:'); Readln(x.ao);
End;
Procedure WriteCompl(x:complex);
Begin
Write('(');
If Frac(x.thuc)=0 then Write(x.thuc:0:0)
Else Write(x.thuc:0:2); Write(';');
If Frac(x.ao)=0 then Write(x.ao:0:0)
Else Write(x.ao:0:2); Write(')');
End;
Procedure Add(x,y:complex; Var z:complex);
Begin
z.thuc:=x.thuc+y.thuc;
z.ao:=x.ao+y.ao;
8 h 54 m 28/7/2017
98
Thầy Trần Thông Quế
End;
Procedure Sub(x,y:complex; Var z:complex);
Begin
z.thuc:=x.thuc-y.thuc;
z.ao:=x.ao-y.ao;
End;
Procedure Multip(x,y:complex; Var z:complex);
Begin
z.thuc:=x.thuc*y.thuc-x.ao*y.ao;
z.ao:=x.thuc*y.ao+x.ao*y.thuc;
End;
Procedure Divi(x,y:complex; Var z:complex);
Begin
z.thuc:=(x.thuc*y.thuc+x.ao*y.ao)/(sqr(y.thuc)+sqr(y.ao));
z.ao:=(x.ao*y.thuc-x.thuc*y.ao)/(sqr(y.thuc)+sqr(y.ao));
End;
Begin clrscr;
Input('A',a);
Input('B',b);
clrscr;
Writeln('Hai so phuc vua nhap la:');
Writeln;
Write('So phuc A:'); WriteCompl(a); Writeln;
Write('So phuc b:'); WriteCompl(b); Writeln;
Add(a,b,c);
Write('Tong 2 so phuc vua nhap='); WriteCompl(c); Writeln;
sub(a,b,c);
Write('Hieu 2 so phuc vua nhap='); WriteCompl(c); Writeln;
Multip(a,b,c);
Write('Tich 2 so phuc vua nhap='); WriteCompl(c); Writeln;
Divi(a,b,c);
Write('Thuong cua 2 so phuc vua nhap='); WriteCompl(c);
Readln;
End.
FILES
8 h 54 m 28/7/2017
99
Thầy Trần Thông Quế
4/ Các thông tin Check In của khách tại sân bay Nội Bài được lưu trong text file tên là
KHACHBAY.VAO có cấu trúc sau: Dòng đầu ghi số khách bay, các dòng tiếp theo ghi
trọng lượng của từng đồ xách tay (túi, hộp, balô …) của mỗi khách. Dữ liệu ra gồm hai text
file:
file TRONGLUONG.RA ghi tổng trọng lượng các đồ xách tay của mỗi khách bay;
file HUYBAY.RA ghi số thứ tự của những khách bay bị hủy chuyến bay nếu tổng trọng
lượng các đồ xách tay của người này 20 KG HOẶC số đồ xách tay nhiều hơn 5.
Dưới đây là một ví dụ về 3 files như vậy:
KHACHBAY.VAO
5
19.5
2.5 1.5 2 3.25 1 3 (Trên mỗi dòng các số cách nhau ít nhất một ký tự trống)
6.25 2.5 7
12 6.5 4 10 7.5
2 6 8
TRONGLUONG.RA
19.50
13.25
15.75
40.00
16.00
HUYBAY.RA
2 → khách này có số đồ xách tay >5
4
Uses Crt;
Var tepvao,tepra,tephuy: Text;
sum,w: Real; n,i,k:Byte;
Begin Clrscr;
Assign(tepvao,'khachbay.vao'); Reset(tepvao);
Readln(tepvao,n);
Assign(tepra,'trgluong.ra'); Rewrite(tepra);
Assign(tephuy,'huybay.ra'); Rewrite(tephuy);
For i:=1 to n do
Begin
sum:=0; k:=0;
While Not(SeekEoln(tepvao)) Do
Begin
Read(tepvao,w);
8 h 54 m 28/7/2017
100
Thầy Trần Thông Quế
sum:=sum+w;
k:=k+1;
End;
Writeln(tepra,sum);
If (sum>20) Or (k>7) Then Writeln(tephuy,i);
Readln(tepvao);
End;
Close(tepvao);
Close(tepra);
Close(tephuy);
Assign(tepra,'trgluong.ra'); Reset(tepra);
Writeln('Noi dung cua file trgluong.ra ghi tong trongluong');
Writeln(' cac kien hang cua tung khach hang:');
Writeln;
While Not(SeekEof(tepra)) do
Begin
Readln(tepra,sum);
Writeln(sum:0:2);
End;
Close(tepra);
Writeln;
Assign(tephuy,'huybay.ra'); Reset(tephuy);
Writeln('Noi dung tep huybay.ra ghi so thu tu cac khach bi huy bay:');
Writeln;
While Not(SeekEof(tephuy)) do
Begin
Readln(tephuy,i);
Writeln(i);
End;
Close(tephuy);
Readln;
End.
5/ Các số nguyên (gồm cả số dương lẫn số âm) được lưu trên text file SONGUYEN.DAT,
Hãy cất các số dương lên file POSI.DAT, cất các số âm lên fie NEGA.DAT. Hiển thị nội
dung hai file này lên màn hình.
Program PosiNegaFile;
Uses Crt;
Var f1,f2,f3: file Of Integer;
i,n,x:integer;
8 h 54 m 28/7/2017
101
Thầy Trần Thông Quế
Begin clrscr;
{$I-} Assign(f1,'Songuyen.dat'); Rewrite(f1); {$I+}
Write('Cho so luong cac so nguyen:'); Readln(n);
For i:=1 to n do
Begin
Write('So thu ',i,':');
Readln(x);
Write(f1,x);
End;
Close(f1);
Write(#10#13,'Da nhap xong ',n,' so nguyen len file songuyen.dat');
Writeln('Press Any Key to Continue...');
Repeat Until KeyPressed;
Readkey;
Clrscr;
{$I-} Assign(f1,'Songuyen.dat');
Assign(f2,'Posi.dat');
Assign(f3,'Nega.dat');
Reset(f1);
Rewrite(f2);
Rewrite(f3);
{$I+}
{Ghi cac so Duong len File f2, ghi cac so am len file f3}
While Not EOF(f1) Do
Begin
Read(f1,x);
If (x>=0) Then Write(f2,x)
Else Write(f3,x);
End;
Close(f1); Close(f2); Close(f3);
{Doc Data cua file f2}
Assign(f2,'Posi.dat'); Reset(f2);
Writeln('Data tren file Posi.dat:');
While Not EOF(f2) Do
Begin
Read(f2,x);
Write(x:3);
End;
Close(f2);
Writeln;
{ Doc Data tren file f3}
Assign(f3,'Nega.dat'); Reset(f3);
8 h 54 m 28/7/2017
102
Thầy Trần Thông Quế
Writeln('Data tren file Nega.dat:');
While Not EOF(f3) Do
Begin
Read(f3,x);
Write(x:3);
End;
Close(f3);
Write(#10#13,' Press Any Key to continue...');
Repeat until KeyPressed;
End.
6/Text file Num1.txt chứa một số số nguyên; text file Num2.txt cũng chứa một số số nguyên.
Hai files này có vài số như nhau. Tìm và “nhặt” các số có mặt ở cả hai file trên và
lưu chúng lên file Ketqua.txt. Hiện nội dung file Ketqua.txt lên màn hình.
Uses Crt;
Var f1,f2,f3: Text;
m,n,i,j,x:Integer;
a1,a2:Array[1..100] of Integer;
Begin clrscr;
{$I-}
Assign(f1,'Num1.txt');
Assign(f2,'Num2.txt');
Rewrite(f1);
Rewrite(f2);
{$I+}
Write('Cho so cac so trong file Num1.txt:'); Readln(m);
Writeln(f1,m);
For i:=1 to m do
Begin
Write('So thu ',i,':');
Readln(x);
Writeln(f1,x:3);
End;
Close(f1);
Write('Cho so cac so trong file Num2.txt:'); Readln(n);
Writeln(f2,n);
For i:=1 to n do
Begin
Write('So thu ',i,':');
Readln(x);
Writeln(f2,x:3);
8 h 54 m 28/7/2017
103
Thầy Trần Thông Quế
End;
Close(f2);
{$I-}
Assign(f1,'Num1.txt');
Assign(f2,'Num2.txt');
Assign(f3,'Ketqua.txt');
Reset(f1);
Reset(f2);
Rewrite(f3);
{$I+}
{Doc Data tren file f1 vao mang a1 (tuc vao Ram)}
Readln(f1,m);
For i:=1 to m do
Readln(f1,a1[i]);
{Doc Data tren file f2 vao mang a2 (tuc vao Ram)}
Readln(f2,n);
For j:=1 to n do
Readln(f2,a2[j]);
Writeln;
Writeln('CAC SO CO MAT O CA 2 FILE:');
Writeln;
For i:=1 to m do
For j:=1 to n do
Begin
If a1[i]=a2[j] Then
Begin
Writeln(f3,a1[i]:3);
Writeln(a1[i]:3);
End;
End;
Close(f1);
Close(f2);
Close(f3);
Write(#10#13,'GO PHIM BAT KY DE TIEP...');
Repeat Until KeyPressed;
End.
= = = = = = = = = = = = = = = = = = =
8 h 54 m 28/7/2017
104
Thầy Trần Thông Quế
PHẦN VII. ĐỒ HỌA (GRAPHIC)
(Ít nhất cũng có 5 bài khá thú vị với những người mê lập trình:
đó là các bài: In lịch; Vẽ đồng hồ; Kính vạn hoa; Tìm MỘT nghiệm của bài
toán Đặt Hậu; Tìm TẤT CẢ NGHIỆM có thể
cho bài toán Đặt Hậu)
Lời khuyên hữu ích: TẤT CẢ CÁC BÀI TOÁN GRAPHIC VÀ GRAPH DÙNG GRAPHIC ĐỀU PHẢI
CHẠY TRONG CÁC PHIÊN BẢN WINDOW CÓ HỖ TRỢ FULL SCREEN MODE. ĐẾN CHẾT
CŨNG ĐỪNG QUÊN LỜI DẶN NÀY!!!
Lập trình Đồ họa thực thi các bài toán sau:
1/ Vẽ cột phát sóng và các vòng sóng truyền lan.
Uses Crt, Graph;
Var Gd, Gm: Integer; r:word;
Begin clrscr;
Gd:=Detect; InitGraph(Gd,Gm,'D:\BP\BGI');
r:=15;
Repeat
SetColor(4);
MoveTo(300,200);
LineTo(320,440);
LineTo(280,440);
LineTo(300,200);
Rectangle(280,440,320,470);
SetColor(15);
Circle(300,200,r);
Delay(100);
If r>GetmaxY/2 then ClearDevice;
If r<=GetmaxY/2 then r:=r+30
Else r:=15;
Until KeyPressed;
CloseGraph;
End.
2/ Vẽ các vòng tròn đồng tâm đổi màu liên tục.
Uses Crt,Graph;
Var i,j,Gd,Gm,xt,yt,yc:Integer;
r:Word; hoi:char;
Begin clrscr;
Gd:=Detect; InitGraph(Gd,Gm,'D:\BP\BGI');
8 h 54 m 28/7/2017
105
Thầy Trần Thông Quế
If GraphResult<>0 Then
Begin
Write('Loi do hoa.');
Halt;
End
Else
Begin
xt:=getMaxX Div 2;
yt:=GetMaxY Div 2;
yc:=GetMaxY Div 30;
End;
Repeat
SetBkColor(Black);
SetColor(15);
Rectangle(1,1,200,15);
SetColor(12);
OutTextXY(12,5,'PRESS ANY KEY TO STOP.');
R:=1;
For i:=1 to 15 do
Begin
SetColor(Random(16));
For j:=1 to yc do
Circle(xt,yt,r+j);
Inc(r,yc);
End;
Until KeyPressed;
CloseGraph;
End.
3/ Vẽ đồ thị hàm sinx (hoặc cosx: Tùy!).Yêu cầu: chương trình ngắn nhất có thể.
uses crt,graph;
var mh, mot,maxx,maxy, xtam,ytam:integer;
x, y:real;
Function F(x:real):real;
Begin
F:=sin(x);
End;
Begin clrscr;
mh:=Detect; InitGraph(mh,mot,'..\BGI');
SetBkColor(Cyan);
If GraphResult<>GrOk then Halt
Else
Begin
maxx:=Getmaxx;maxy:=Getmaxy;
xtam:=maxx DIV 2;
ytam:=maxy DIV 2;
Setcolor(White);
8 h 54 m 28/7/2017
106
Thầy Trần Thông Quế
Line(0,ytam,maxx-5,ytam);
OutTextxy(maxx-10,ytam-3,'>');
Line(xtam,5,xtam,maxy);
OutTextxy(xtam-3,5,'>');
OutTextxy(xtam-10,ytam+10,'O');
X:=-4*Pi;
Repeat
y:=Round(F(x)*40);
PutPixel(Round(20*x)+xtam,ytam-Round(y),Red);
x:=x+0.001;
Until x>4*Pi;
Readln;
closegraph;
End;
End.
*4/ In lịch dương có khuôn dạng tương tự lịch tờ to treo tường.
PROGRAM InLich;
Uses Crt,Graph,Dos;
Label 1;
Var n,m,y: integer;
Function NumDays(m: integer): Integer; {Ham tra ve so ngay trong thang}
Begin
case m of
4,6,9,11:NumDays:=30;
2:if (m mod 4)<>0 then NumDays:=28 else
begin
if (m mod 100)<>0 then NumDays:=29 else
begin
if (m mod 400)<>0 then NumDays:=28 else NumDays:=29
end
end
else Numdays:=31
end;
End;
{Ham tra ve so thu tu cua thu trong tuan ung voi ngay mong 1 cua thang}
function FirstDay(m,y:word): word;
var d,y1,m1,d1,dow1,dow: word;
Begin
d:=1;
GetDate(y1,m1,d1,dow1);
setdate(y,m,d);
GetDate(y,m,d,dow);
FirstDay:=dow;
setdate(y1,m1,d1);
8 h 54 m 28/7/2017
107
Thầy Trần Thông Quế
End;
Procedure In_lich(m,y: integer);
var i,j,k,n,rows,cols,gd,gm: integer;
Begin
k:=FirstDay(m,y);
n:=numDays(m);
Cols:=7;
Rows:= (n+k) DIV 7;
if (n+k) MOD 7 <> 0 then Rows:= Rows + 1;
Writeln;
textmode(c80);
textcolor(12);
Writeln(#32:16,'LICH THANG ',m,' - NAM ',y);
writeln(#32:16,'-------------------------');
writeln;
textcolor(lightmagenta);
Write('SUN':8);
textcolor(lightgreen);
Write('MON':8,'TUE':8,'WED':8,'THU':8,'FRI':8);
textcolor(lightblue);
Writeln('SAT':8);
Writeln;
For i:=1 to n+k do
Begin
If i<=k then Write(#32:8)
Else
Write(i-k:8); textcolor(yellow);
If i MOD 7 = 0 then Writeln;
End;
End;
BEGIN
1:clrscr;
Write('Nhap thang,nam (nam co 4 chu so):');
readln(m,y);
In_lich(m,y);
Writeln(#10#13);
textcolor(lightmagenta);
Write('Nhan phim bat ky de tiep tuc. Nhan "k" de ket thuc...');
if readkey<> 'k' then goto 1;
END.
Cách kiểm tra kết quả chạy program xem có CHÍNH XÁC KHÔNG: Gỉa sử nhập dữ liệu là tháng 7 năm
2017 thì LƯU Ý: Ra SAT ứng với ngày 8, SUN ứng với ngày 9 là prog. chạy chính xác. TỐT NHẤT NÊN
SO VỚI LỊCH BỎ TÚI của nhà xuất bản uy tín.
8 h 54 m 28/7/2017
108
Thầy Trần Thông Quế
*5/ Tạo lập bảng mã ASCII mở rộng. Yêu cầu: gõ PgDn để xem tiếp. Gõ phím bất kỳ để thoát.
Program AsciiTable;
Uses Crt, Addcrt;
Label 1;
Const Hexa:Array[0..15] of Char='0123456789ABCDEF';
Type St=String[3];
Var i,j,x,m,n,y,e:Integer;
ch:Char;
Procedure Box(x1,x2,y1,y2:Byte);
Var i:Byte;
Begin
If (x1<0)Or (y1<0) Or (x2>80) Or (y2>25) Or (x1>x2) Or (y1>y2) Then exit;
Textcolor(0);
GotoXY(x1,y1); Write('I');
GotoXY(x2,y1); Write(';');
GotoXY(x1,y2); Write('H');
GotoXY(x2,y2); Write('<');
For i:=(x1+1) to (x2-1) Do
Begin
GotoXY(i,y1);
Write('M');
End;
For i:=(x1+1) to (x2-1) Do
Begin
GotoXY(i,y2);
Write('M');
End;
For i:=(y1+1) to (y2-1) Do
Begin
GotoXY(x1,i);
Write(':');
End;
For i:=(y1+1) to (y2-1) Do
Begin
GotoXY(x2,i);
Write(':');
End;
End;
Procedure Color(x1,x2,y1,y2:Byte);
Begin
Tomau(x1,y1,x2,y2,3);
Box(x1+1,y1+1,x2-1,y2-1);
Tomau(x1+2,y1+2,x2-2,y2-2,3);
End;
Function Doi(i1:Byte):St;
8 h 54 m 28/7/2017
109
Thầy Trần Thông Quế
Begin
Doi:=Hexa[i1 Shr 4]+Hexa[i1 And $0F];
End;
Begin {Main}
TextBackGround(3);
clrscr;
Cursor(1);
Khungdon(2,2,79,24,15);TextC(14,9); Writexy(35,2,' TABLE ASCII ');
TextC(1,15);
WriteXY(50,3,'Wroten By TRAN THONG QUE'); TextC(4,3);
Window(2,4,79,24);
x:=1; y:=1;
While (x<=72) Do
Begin
Khungdon(x+2,y,x+8,y+2,15);
Khungdon(x+2,y+2,x+8,y+19,15);
x:=x+6;
End;
i:=3;
While (i<=79) Do
Begin
GotoXY(i,3); Write(#197);
i:=i+6;
End;
WriteXY(3,3,'C'); WriteXY(75,3,'D');
i:=9;
While (i<=79) Do
Begin
WriteXY(i,1,'B');
i:=i+6;
End;
WriteXY(75,1,'Y');
i:=9;
While (i<=79) Do
Begin
WriteXY(i,20,'A');
i:=i+6;
End;
WriteXY(75,20,'Y');
TextC(1,3); x:=5;
For i:=1 to 4 Do Begin WriteXY(x,2,'Deci'); x:=x+18; End; x:=11;
For i:=1 to 4 Do Begin WriteXY(x,2,'Hexa'); x:=x+18; End; x:=17;
For i:=1 to 4 Do Begin WriteXY(x,2,'Char'); x:=x+18; End;
Repeat
m:=64; n:=16;
Window(4,4,76,24);
y:=2; i:=4; j:=1; e:=4;
Repeat
8 h 54 m 28/7/2017
110
Thầy Trần Thông Quế
While (i<=m) And (j<=n) Do
Begin
TextC(e,3); WriteXY(15,10,' ');
WriteXY(15,11,' '); WriteXY(15,13,' ');
WriteXY(15,16,' ');
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
If (j<>7) Then
Begin
GotoXY(y+12,i); Write(chr(j):3);
End;
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Until n=80;
SetWin;
WriteXY(40,24,'PgDn->Continue; Other Key->Quit.');
ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
m:=128; n:=80;
Window(4,4,76,24);
y:=2;i:=4; j:=65; e:=4;
Repeat
While (i<=m) And(j<=n) Do
Begin
TextC(e,3);
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
GotoXY(y+12,i); Write(chr(j):3);
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Until n=144;
Setwin;
Write(40,24,'PgDn->Continue; Other key->Quit.'); ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
m:=192; n:=144;
Window(4,4,76,24);
y:=2; i:=4; j:=129; e:=4;
Repeat
While (i<=m) And (j<=n) do
Begin
TextC(e,3);
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
GotoXY(y+12,i); Write(chr(j):3);
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
8 h 54 m 28/7/2017
111
Thầy Trần Thông Quế
Until n=208;
Setwin;
Write(40,24,'PgDn->Continue; Other key->Quit.'); ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
m:=256; n:=208;
Window(4,4,76,24);
y:=2; i:=4; j:=193; e:=4;
Repeat
While (i<=m) And (j<=n) Do
Begin
TextC(e,3);
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
GotoXY(y+12,i); Write(chr(j):3);
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Until n=272;
Setwin;
Write(40,24,'PgDn->Continue; Other key->Quit.'); ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
Until ch=#27;
Setwin;
1:TextC(15,0); Clrscr;
End.
**6/Tạo trò chơi bắn vịt trời đang bay. Gõ ký tự “d” bắn; Gõ , : di chuyển “súng”; Gõ: Esc: ra.
**7/ Tạo “Kính vạn hoa”. Yêu cầu: Gõ ESC: Thoát; Gõ phím bất kỳ: Tiếp tục.
PROGRAM VANHOA;
USES crt,graph;
const
dong=1; lim=3;
TYPE
BASEARRAY=ARRAY[1..100] OF real;
Var
ordrePoly,khoang:integer;
number:byte;
f1,f2,f3,f4:integer;
c1,c2,c3,c4:integer;
GraphDriver,graphMode:integer;
xp1,yp1,xp2,yp2:real;
xtl,ytl:real;
MaxX,MaxY:integer;
XgFen,xdFen,YbFen,YhFen:real;
XgClot,XdClot,YbClot,YhClot:integer;
mangX,mangY:basearray;
i:integer;
8 h 54 m 28/7/2017
112
Thầy Trần Thông Quế
Sotg,kc,lap:byte;
ch:char;k:integer;
PROCEDURE KTDOHOA;
VAR
errorCode:integer;
somau:byte;
Begin
graphDriver:=detect;
initgraph(graphdriver,graphMode,'D:\bp\bgi');
ErrorCode:=graphResult;
If errorCode<> grOK then
begin
writeln('LOI DO HOA ',graphErrorMsg(ErrorCode));
halt(1);
end;
MaxX:=getMaxx;
MaxY:=getMaxY;
end;
PROCEDURE CUASO(f1,f2,f3,f4:real);
BEGIN
Xgfen:=f1;
XdFen:=f2;
ybFen:=f3;
yhFen:=f4;
END;
PROCEDURE TAMNHIN(C1,C2,C3,C4:INTEGER);
BEGIN
XgClot:=c1;
XdClot:=c2;
YbClot:=c3;
YhClot:=c4;
Xtl:=(XdClot-XgClot)/(XdFen-XgFen);
Ytl:=(YhClot-YbClot)/(YhFen-YbFen);
Setviewport(xgClot,maxY-YhClot,xdClot,maxY-YbClot,ClipOn);
END;
PROCEDURE CAT(x1,y1,x2,y2:real);
type
muc=(l,r,low,h);
code=set of muc;
Var
c,c1,c2:code;
x,y:real;
xx1,yy1:integer;
xx2,yy2:integer;
8 h 54 m 28/7/2017
113
Thầy Trần Thông Quế
PROCEDURE BINARY(X,Y:REAL;VAR C:CODE);
Begin
c:=[];
If xxdfen then c:=[r];
If yYhFen then c:=c+[h]
End;
BEGIN
binary(x1,y1,c1);
binary(x2,y2,c2);
WHILE (c1<>[] ) or (c2<>[])do
BEGIN
if (c1*c2)<>[] then exit;
if c=[] then c:=c2 else c:=c1;
if l in c then
begin
x:=xgFen;
y:=y1+(y2-y1)*(xgFen-x1)/(x2-x1)
end
else if r in c then
begin
x:=xdFen;
y:=y1+(y2-y1)*(xdFen-x1)/(x2-x1)
end
else if low in c then
begin
y:=ybFen;
x:=x1+(x2-x1)*(ybFen-y1)/(y2-y1)
end
else if h in c then
begin
y:=yhFen;
x:=x1+(x2-x1)*(yhFen-y1)/(y2-y1)
end;
IF c=c1 then
Begin
x1:=x;
y1:=y;
binary(x,y,c1);
END
Else
Begin
x2:=x;
y2:=y;
binary(x,y,c2);
8 h 54 m 28/7/2017
114
Thầy Trần Thông Quế
End;
END ;
xx1:=round((x1-xgFen)*Xtl);
yy1:=round((yhfen-y1)*Ytl);
xx2:=round((x2-xgFen)*Xtl);
yy2:=round((yhfen-y2)*Ytl);
MoveTo(xx1,yy1);
Lineto(xx2,yy2);
END;
PROCEDURE VETOI(x,y:real);
BEGIN
xp2:=x;
yp2:=y;
cat(xp1,yp1,xp2,yp2);
xp1:=xp2;
yp1:=yp2;
END;
PROCEDURE DATBUT(x,y:real);
BEGIN
xp1:=x;
yp1:=y;
vetoi(x,y);
END;
PROCEDURE NHAPSOLIEU;
Begin
TextBackGround(blue);
ClrScr;
Writeln(' KINH VAN HOA ');
Write(' Cho so Tam giac ' );
Textcolor(white);
Write('( An 0 de thoat ) : ');
readln(Sotg);
If sotg<>0 then
Begin
writeln;
write(' Cho so khoang chia : ');
readln(kc);
writeln;
write(' Cho so lan Lap : ');
readln(Lap);
end;
END;
PROCEDURE DAGIAC(MANGX,MANGY:BASEARRAY;LIM:INTEGER;MODE:
INTEGER);
Var
8 h 54 m 28/7/2017
115
Thầy Trần Thông Quế
i:integer;
Begin
datbut(mangx[1],mangy[1]);
For i:=2 to lim do vetoi(mangx[i],mangy[i]);
If mode=dong then vetoi(mangx[1],mangy[1]);
End;
PROCEDURE VEDAGIAC(MANGX,MANGY:BASEARRAY;LIM:INTEGER;MODE:
INTEGER;color:byte);
Begin
setcolor(color);
dagiac(MANGx,mangy,lim,mode);
End;
PROCEDURE VE(SoTg,kc,lap:byte);
Var
angle,hs:real;
i,j,sogoc:byte;
tg:byte;
Begin
hs:=2*pi/Sotg;
For Sogoc:=1 to sotg do
Begin
mangx[1]:=0;mangy[1]:=0;
angle:=(sogoc-1)*hs;
mangx[2]:=cos(angle);
mangy[2]:=sin(angle);
angle:=Sogoc*hs;
mangx[3]:=cos(angle);
mangy[3]:=sin(angle);
mangx[4]:=0;mangy[4]:=0;
For i:=1 to lap do
Begin
Vedagiac(mangx,mangy,lim,dong,white);
If odd(sogoc) then
Begin
For j:=lim+1 downto 2 do
Begin
mangx[j]:=mangx[j]+(mangx[j-1]-mangx[j])/kc;
mangy[j]:=mangy[j]+(mangy[j-1]-mangy[j])/kc;
End;
Mangx[1]:= Mangx[lim+1];
Mangy[1]:=Mangy[lim+1];
End
Else
Begin
For j:=1 to lim do
Begin
8 h 54 m 28/7/2017
116
Thầy Trần Thông Quế
mangx[j]:=mangx[j]+(mangx[j+1]-mangx[j])/kc;
mangy[j]:=mangy[j]+(mangy[j+1]-mangy[j])/kc;
End;
Mangx[lim+1]:= Mangx[1];
Mangy[lim+1]:=Mangy[1];
End;
end;{cua lap}
end;{for ngoai cung}
End;{cua ve}
(**************************************************************)
BEGIN
nhapSolieu;
Repeat
ktdohoa;
CuaSo(-1,1 ,-1,1);
TamNhin(160,maxx-160,75,maxy-75);
Ve(sotg,kc,lap);
TamNhin(0,maxx,0,maxy);
rectangle(1,1,maxx-1,maxy-1);
rectangle(5,5,maxx-5,maxy-5);
setcolor(yellow);
settextjustify(1,1);
settextstyle(1,0,4);
outtextxy(maxx div 2,20,' VE KINH VAN HOA ');
outtextxy(maxx div 2,45,' ************************ ');
settextstyle(1,0,1);
setcolor(lightblue);
outtextxy(maxx div 2,maxy-20,' Go ESC de thoat, Go phim BAT KY de tiep tuc !');
settextstyle(2,1,8);
outtextxy(20,maxy div 2,'Thay: TRAN THONG QUE');
outtextxy(maxx-24,maxy div 2,'COPYRIGHT (C) 1994');
repeat until KeyPressed;
ch:=readkey;
if ch=#27 then
begin
cleardevice;
closegraph;
halt;
end;
closeGraph;
nhapsolieu;
Until ( Sotg=0);
END.
CÁC BÀI 7, 8, 10, 11 RẤT KHÓ CẢ VỀ MẶT THUẬT TOÁN VÀ CẢ VỀ KỸ NĂNG LẬP TRÌNH!!!
8 h 54 m 28/7/2017
117
Thầy Trần Thông Quế
**7/ Tạo đồng hồ có 3 kim+tiếng tích tắc kêu theo nhịp chạy của kim giây.
Và thêm các yêu cầu sau:
a- Dòng trên cùng phía phải màn hình có dòng chũ: “Gõ phím bất kỳ để
đổi màu đồng hồ và nền màn hình.
b- Dòng cuối cùng phía trái màn hình hiện thời gian hiện hành.
c- Dòng cuối cùng phía phải màn hình hiện ngày tháng năm hiện thời.
d- Kim giờ và kim phút có dạng hình tứ giác. (giả hình thoi- Quasi Lozenge)
program Draw_Clock;
uses crt,GRAPH,dos;
const
color:array[0..15] of byte=(8,7,3,15,6,14,10,4,2,9,1,12,5,0,13,11);
var
m,co:byte;
col:set of 0..15;
r,xt,yt:word;
e:char;
st:string[10];st1,st2,st3:string[4];
{--------------------------------------------------------------}
procedure init;
var gd,gm:integer;
begin
gd:=0;
initgraph(gd,gm,'..\bgi');
if graphresult<>0 then halt;m:=1;e:=#2;
end;
{--------------------------------------------------------------}
procedure draw_frame;
const
number:array[1..12] of
string[2]=('1','2','3','4','5','6','7','8','9','10','11','12');
dayofweek:array[0..6]of string[3]=('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
var
i,x,y,year,month,day,day_of_week:word;
begin
xt:=getmaxx div 2;yt:=getmaxy div 2;
r:=yt-10;
settextjustify(1,1);
{ve duong vien ngoai cung:}
setcolor(color[13]);
setlinestyle(0,0,3);
rectangle(1,1,getmaxx,getmaxy);
rectangle(3,3,getmaxx-2,getmaxy-2);
{ve duong tron bao dong ho:}
for i:= 0 to 6 do circle(xt,yt,r+3-i);
{to mau nau khoang trong:}
8 h 54 m 28/7/2017
118
Thầy Trần Thông Quế
m:=(m mod 2)+1;
if odd(m) then co:=1 else co:=1+(color[13] mod 11);
setfillstyle(co,color[4]);
floodfill(xt+r-20,yt+r-20,color[13]);
setfillstyle(1,color[3]);
floodfill(xt,yt,color[13]);
setcolor(color[1]);
setlinestyle(0,0,3);
rectangle(1,1,getmaxx,getmaxy);
rectangle(3,3,getmaxx-2,getmaxy-2);
setfillstyle(1,color[1]);
bar(0,getmaxy-15,getmaxx,getmaxy);
setfillstyle(solidfill,color[13]);
bar(80,getmaxy-15,getmaxx-80,getmaxy);
{hien ngay thang nam o dong duoi cung phai man hinh:}
setfillstyle(solidfill,color[8]);
bar(8,getmaxy-50,170,getmaxy-20);
bar(getmaxx-170,getmaxy-50,getmaxx-8,getmaxy-20);
setfillstyle(1,color[11]);
bar(getmaxx-150,60,getmaxx-10,70);
getdate(year,month,day,day_of_week);
str(day,st1);
str(month,st2);
str(year,st3);
if day<10 then st1:='0'+st1;
if month<10 then st2:='0'+st2;
{settextstyle(4,0,6);
setcolor(color[5]);
outtextxy(getmaxx-80,25,st3);
settextstyle(4,0,4);
setcolor(color[6]);
outtextxy(120,20,' Happy New Year !'); }
settextstyle(0,0,2);
setcolor(color[7]);
for i:=0 to 1 do outtextxy(40+30*i,60,chr(i+3));
setcolor(color[15]);
for i:=2 to 3 do outtextxy(40+30*i,60,chr(i+3));
st:=' ';st:=dayofweek[day_of_week]+','+st1+'.'+st2;
settextstyle(0,0,2);
setcolor(color[9]);
outtextxy(getmaxx-90,getmaxy-35,st);
settextstyle(2,0,1);
setusercharsize(2,3,1,1);
setcolor(color[10]);
outtextxy(getmaxx-80,63,' * Press any key to change color...');
{trang tri ben trong dong ho:}
settextstyle(0,0,1);
setcolor(color[11]);
for i:=1 to 60 do
8 h 54 m 28/7/2017
119
Thầy Trần Thông Quế
begin
x:=xt+round((r-20)*sin(i*pi/30));
y:=yt-round((r-20)*cos(i*pi/30));
if(i mod 5)<>0 then outtextxy(x,y,chr(1))
end;
settextstyle(0,0,2);
for i:=1 to 12 do
begin
x:=xt+round((r-50)*sin(i*pi/6));
y:=yt-round((r-50)*cos(i*pi/6));
setcolor(color[12]);
outtextxy(x,y,number[i]);
x:=xt+round((r-20)*sin(i*pi/6));
y:=yt-round((r-20)*cos(i*pi/6));
setcolor(color[10]);
outtextxy(x,y,chr(2)); {chr(2)=" "}
end;
{setcolor(color[14]);
outtextxy(xt,yt+100,' CHA DE PASCAL! ');
outtextxy(xt,yt-100,'');
outtextxy(xt,yt-105,' NIKLAUS WIRTH '); }
setcolor(color[2]);
settextstyle(0,0,3);
outtextxy(xt,yt,chr(3)); {chr(3):hinh trai tim}
end;
{------------------------------------------------------}
procedure draw_index(r:word;goc:real;color:byte);
var
x,y,a,b,c:real;
d:array[1..5]of pointtype; {toa do 4 dinh tu giac}
begin
{if goc>=2*pi then goc:=goc-2*pi;}
x:=xt+r*sin(goc);
y:=yt-r*cos(goc);
setcolor(color);
if r>yt-35 then
begin {kim giay}
setlinestyle(0,0,2);
line( xt,yt,round(x),round(y));
setlinestyle(0,0,3);
line(xt,yt,round(xt-r/5*sin(goc)),round(yt+r/5*cos(goc)));
end
else
begin
{ve kim gio hoac kim phut duoi dang hinh tu giac co 4 dinh
toa do 4 dinh chua trong mang d:}
8 h 54 m 28/7/2017
120
Thầy Trần Thông Quế
d[1].x:=xt;d[1].y:=yt;
a:=(4*xt+x)/5;b:=(4*yt+y)/5;c:=(x-xt)/(yt-y+0.000001);
d[2].x:=round(a-sqrt((100+(r mod (yt-40)))/(1+sqr(c))));
d[2].y:=round(b+c*((a-sqrt((100+(r mod (yt-40)))/(1+sqr(c))))-a));
d[3].x:=round(x);
d[3].y:=round(y);
d[4].x:=round(a+sqrt((100+(r mod (yt-40)))/(1+sqr(c))));
d[4].y:=round(b+c*((a+sqrt((100+(r mod (yt-40)))/(1+sqr(c))))-a));
d[5].x:=xt;
d[5].y:=yt;
drawpoly(5,d); {ve hinh tu giac}
end;
end;
{-------------------------------------------------------}
procedure run;
const
a:array[1..2] of string=('SEE YOU GAIN','!');
var
h,m,s,se,ok:word;
goch,gocm,gocs,g:real;
i,j,k:integer;
nb:boolean;
{------------------------------------------------------}
procedure tinhgoc;
begin
goch:=pi*((h mod 12)/6+m/360+s/4320);
gocm:=pi*(m/30+s/1800);
gocs:=pi*s/30;
if (s=59)and odd(m) then e:='a';
ok:=s;
end;
{-----------------------------------------------------}
procedure draw;
begin
draw_index(r-80,goch,color[11]);
draw_index(r-30,gocm,color[12]);
draw_index(r-20,gocs,color[14]);
end;
{phan phu}
{-----------------------------------------------------}
procedure change;
begin
i:=(i mod k)+1;if i=1 then j:=(j mod 4)+1;
case j of
1:k:=179;
2:k:=186;
3:k:=191;
4:k:=196
end;
8 h 54 m 28/7/2017
121
Thầy Trần Thông Quế
end; {het phan phu}
Begin
setwritemode(xorput);
gettime(h,m,s,se);
tinhgoc;
draw;
{hien gio o dong duoi cung ben trai man hinh:}
str(h,st1);
str(m,st2);
str(s,st3);st:=' ';
if m<10 then st2:='0'+st2;
if s<10 then st3:='0'+st3;
st:=' ';
st:=st1+':'+st2+':'+st3;
settextstyle(0,0,2);
setcolor(color[9]);
outtextxy(90,getmaxy-35,st);
i:=0;
j:=0;
k:=179;
nb:=false;
repeat
gettime(h,m,s,se);
if ok<>s then
begin
if((m=59)and(s>(58-h)))or((m=29)and(s=59))then nb:=true;
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
settextstyle(0,0,2);
setcolor(color[8]);
outtextxy(90,getmaxy-35,st);
draw;tinhgoc;
{phan phu:co the bo di:}
if (s mod 5)=0 then
begin
if gocs>=2*pi then gocs:=gocs-2*pi;setfillstyle(solidfill,color[2]);
floodfill(round(xt+(r-20)*sin(gocs)),round(yt-(r-20)*cos(gocs)),color[10]);
end;
if ((s-1) mod 5)=0 then
begin
g:=pi*(s-1)/30;
if g>=2*pi then g:=g-2*pi;setfillstyle(solidfill,color[3]);
floodfill(round(xt+(r-20)*sin(g)),round(yt-(r-20)*cos(g)),color[10]);
end;
{het phan phu}
draw;
str(h,st1);str(m,st2);str(s,st3);st:=' ';
if m<10 then st2:='0'+st2;if s<10 then st3:='0'+st3;
8 h 54 m 28/7/2017
122
Thầy Trần Thông Quế
Begin
st:=' ';
st:=st1+':'+st2+':'+st3;
settextstyle(0,0,2);
setcolor(color[9]);
outtextxy(90,getmaxy-35,st);
settextstyle(0,0,1);
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
if nb then
begin
sound(2700);
delay(1000);
nosound;
delay(1000);
sound(2700);
delay(1000);
nosound;
end
else
sound(2700);
delay(750);
nosound;
delay(750);
End;
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
if nb then
Begin delay(750);
sound(2700);
delay(100);
nosound;
delay(750);
End
else
delay(1000);
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
if nb then
Begin
8 h 54 m 28/7/2017
123
Thầy Trần Thông Quế
nosound;
delay(80);
Begin sound(2700);
delay(1000);
nosound;
delay(1000);
sound(2700);delay(120);
End
else
End;
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
Outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
delay(200);
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
delay(150);nb:=false;
end; while keypressed do e:=readkey;
until e<>#2;
if e<>#27 then e:=#2;
End;
{------------------------------------------------------}
procedure set_color;
var i:byte;
begin
randomize;
col:=[];
for i:=0 to 15 do
begin
repeat
color[i]:=random(16);
if (i>=11) and (i<=14) then
if (color[i]=0) and not(0 in col) then color[i]:=color[i-1];
until not(color[i] in col);
col:=col+[color[i]]
end;
end;
{------------------------------------------------------}
procedure maker;
begin
clrscr;
gotoxy(30,17); TEXTCOLOR(YELLOW);
write('Press any key to continue...');
window(20,10,60,15);
8 h 54 m 28/7/2017
124
Thầy Trần Thông Quế
textbackground(lightgray);
clrscr;
textcolor(blue);
writeln;
writeln(' THAY TRAN-THONG-QUE ');
writeln;
writeln(' * * * * * * * * * ');
textcolor(lightgray);
e:=readkey;
end;
begin
maker;
init;
repeat
graphdefaults;
cleardevice;
draw_frame;
run;
set_color;
until e=#27;
closegraph;
end.
**8/ Đồ họa hóa bài toán Tháp Hà Nội (Hanoi Tower Problem): Chuyển n đĩa (chỉ nên test với n=3 or n=4)
có lỗ ở giữa từ cọc 1 sang cọc 2 được dùng cọc trung gian. Luật chơi:
a- Mỗi lần chỉ chuyển 1 đĩa,
b- Trong lúc chuyển không được đặt đĩa (nghỉ) trên bất cứ chỗ nào (mặt bàn, ghế, sàn nhà…),
c- Đĩa to nằm trên đĩa bé.
Uses Crt,Graph;
Type coc=1..3;
Const n=3; yorg=20;xorg:Array[coc] of integer=(13,40,67);
time=5000; time2=4000;
Var dk:Array[1..n,coc] of Integer;
docao:Array[coc] of integer;
i:integer;
Procedure tre(T:integer);
Begin
GotoXY(43,4);
Delay(T);
End;
Procedure MoveUp(c1,c2:Integer);
Var i,j,x:Integer;
Begin
For j:=1 to 4 Do
Begin
8 h 54 m 28/7/2017
125
Thầy Trần Thông Quế
X:=xorg[c1]-dk[docao[c1],c1];
GotoXY(X,YORG-n-j-1);
For i:=1 to 2*dk[docao[c1],c1]+1 do Write(#219);
tre(time);
GotoXY(X,Yorg-n-j-1);
For i:=1 to 2*dk[docao[c1],c1]+1 do Write(#32);
tre(time);
End;
End;
Procedure MoveDown(c1,c2:integer);
Var i,j,x:Integer;
Begin
For j:=4 Downto 1 Do
Begin
x:=XORG[c2]-DK[docao[c1],c1];
GotoXY(X,YORG-n-j-1);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#219);
tre(time);
GotoXY(X,YORG-n-j-1);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#32);
tre(time);
End;
End;
Procedure MoveRight(c1,c2:integer);
Var i,j,x,xx:integer;
Begin
x:=XORG[c1];
While x<=XORG[c2] Do
Begin
xx:=XORG[c1]-DK[docao[c1],c1]+x-XORG[c1];
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#219);
tre(time2);
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#32);
tre(time2);
X:=X+2;
End;
End;
Procedure MoveLeft(c1,c2:Integer);
Var i,j,x,xx:integer;
Begin
x:=XORG[c1];
While x>=XORG[c2] Do
Begin
8 h 54 m 28/7/2017
126
Thầy Trần Thông Quế
xx:=XORG[c1]-DK[docao[c1],c1]+x-XORG[c1];
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#219);
tre(time2);
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#32);
tre(time2);
X:=X-2;
End;
End;
Procedure Move(n,c1,c2,c3:integer);
Var x:integer;
Begin
If n=1 Then
Begin
x:=XORG[c1]-Dk[docao[c1],c1];
GotoXY(x,YORG-docao[c1]+1);
For i:=1 to 2*DK[docao[c1],c1]+1 do
Begin
If docao[c1]=1 Then
Begin
Write('-');
If i=DK[docao[c1],c1] Then Write(#193);
End
Else Write(#32);
End;
GotoXY(XORG[c1],YORG - docao[c1]+1);
Write(#179); tre(time);
MoveUp(c1,c2);
If c2>c1 then MoveRight(c1,c2)
Else MoveLeft(c1,c2);
MoveDown(c1,c2);
docao[c2]:=docao[c2]+1;
DK[docao[c2],c2]:=DK[docao[c1],c1];
Dk[docao[c1],c1]:=0;
docao[c1]:=docao[c1]-1;
x:=XORG[c2]-DK[docao[c2],c2];
GotoXY(x,YORG-docao[c2]+1);
For i:=1 to 2*DK[docao[c2],c2]+1 do Write(#219);
Delay(200);
End
Else
Begin
Move(n-1,c1,c3,c2);
Move(1,c1,c2,c3);
Move(n-1,c3,c2,c1);
End;
End;
{Main prog.}
8 h 54 m 28/7/2017
127
Thầy Trần Thông Quế
Begin Clrscr;
GotoXY(35,4); Write('BAI TOAN THAP HA NOI.');
GotoXY(4,YORG-n+4);
GotoXY(XORG[1],YORG-n); Write(#179);
GotoXY(XORG[1]-1,YORG-n+1); Write(#219#219#219);
GotoXY(XORG[1]-2,YORG-n+2); Write(#219#219#219#219#219);
GotoXY(XORG[1]-3,YORG-n+3); Write(#219#219#219#219#219#219#219);
GotoXY(XORG[1]-4,YORG-n+4); Write(#219#219#219#219#219#219#219#219#219);
For i:=0 to n Do
Begin
GotoXY(XORG[2],YORG-n+I);
Write(#179);
End;
For I:=0 to n do
Begin
GotoXY(XORG[3],YORG-n+I);
Write(#179);
End;
docao[1]:=n; docao[2]:=0; docao[3]:=0;
For I:=1 to n do DK[I,1]:=n-I+1;
For I:=1 to n do DK[I,2]:=0;
For I:=1 to n do DK[I,3]:=0;
GotoXY(22,24); Write('Press Ctrl_C to Stop.');
GotoXY(43,4);
Repeat
Delay(500); Move(n,1,2,3);
Delay(500); Move(n,2,3,1);
Delay(500); Move(n,3,1,2);
Until KeyPressed;
End.
*9/ (MỘT TRONG SỐ CÁC ĐỀ OLYMPIC TIN HỌC CỦA HỌC SINH THCS 4/1994)
Vẽ hai đường tròn. Xét các vị trí tương quan giữa chúng. Và tính diện tích phần mặt phẳng giới hạn bởi 2
đường tròn khi chúng ở trong nhau hoặc tiếp súc trong với nhau. Hiển thị các kết qủa tính diện tích.
BẢNG TEST
CÁC TEST Vị trí tương quan giữa hai vòng tròn Tọa độ tâm & bán kính vòng tròn
R
Y
X
Hai vòng tròn rời nhau
Hai vòng tròn cắt nhau
Hai vòng tròn tiếp xúc ngoài Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2 200
50
200
270
200
350 200
50
200
130
200
200 100
30
100
40
100
50
8 h 54 m 28/7/2017
128
Thầy Trần Thông Quế
Hai vòng tròn trùng khít nhau
100
100
100 Vòng tròn tròn bé nằm trọn trong vòng
60 tròn to. Dt còn lại của vòng to=2016
100 Vòng tròn bé đồng tâm với vòng tròn to
80 Dt còn lại của vòng to=11310
100 Vòng tròn bé tiếp xúc trong phải với
vòng tròn to. Dt còn lại . . . =23562
50
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2 200
200
200
220
200
200
200
250
200
200 200
200
200
220
200
200
200
200
200
170 100 Vòng tròn bé tiếp xúc trong phía trên với
Vòng tròn to. Dt còn lại . . .=16022
70
Uses Crt, graph;
Const maxx=639; maxy=449;
Var x1,x2,y1,y2,r1,r2:Integer;
Procedure Khung(x1,x2,y1,y2:Integer);
Var i,j: Integer;
Begin
TextBackGround(Blue); TextColor(LightGray);
Gotoxy(x1,y1); Write(#218);
For i:=x1+1 to x2-1 do Write(#196);
Write(#191);
For j:=y1+1 to y2-1 do
Begin
Gotoxy(x1,j); Write(#179);
For i:=x1+1 to x2-1 do Write(' ');
Write(#179);
End;
Gotoxy(x1,y2); Write(#192);
For i:=x1+1 to x2-1 do Write(#196);
Write(#217);
End;
Function Doc(min,max:Integer):Integer;
Var n:Integer; {min0) Or (n<=min) Or (n>=max) Then
8 h 54 m 28/7/2017
129
Thầy Trần Thông Quế
Begin
Sound(1200);
Delay(100);
Nosound;
End;
Until (IoResult=0) And (n>min) And (nGrOk then
Begin
Gotoxy(11,11);
Sound(1200); Delay(100); Nosound;
8 h 54 m 28/7/2017
130
Thầy Trần Thông Quế
Writeln('Khong khoi dong duoc do hoa.');
Run:=False; Exit;
End;
SetBkColor(Blue); SetColor(LightRed);
SetFillStyle(1,LightGray);
Bar(1,1,maxx-1,maxy-1);
Rectangle(0,0,maxx,maxy);
SetColor(Yellow);
Circle(x1,y1,r1); Circle(x2,y2,r2);
i:=Sqrt((Longint(x1)-x2)*(x1-x2)+(Longint(y1)-y2)*(y1-y2));
If (x1=y1) And (x2=y2) And (r1=r2) Then
Begin
SetColor(White);
OutTextxy(10,450,'Hai vong tron trung khit nhau.')
End
Else If(r1>=r2+i) Then
Begin
SetColor(White);
OutTextxy(10,450,'Vong tron 2 nam trong vong tron 1.');
Str(Pi*(Longint(r1)*r1-Longint(r2)*r2):0:2,s);
OutTextxy(10,460,'Dien tich phan trong la:');
SetColor(LightRed); OutTextxy(10+26*8,460,s);
SetFillStyle(3,LightGray);
If x2+r2=x1+r1 Then FloodFill(x1,y1-r1+1,Yellow)
Else FloodFill(x1,y1+r1-1,Yellow)
End
Else If(r2>=r1+i) Then
Begin
SetColor(White);
OutTextxy(10,450,'Vong tron 1 nam trong vong tron 2.');
Str(Pi*(Longint(r2)*r2-Longint(r1)*r1):0:2,s);
OutTextxy(10,460,'Dien tich phan trong la:');
SetColor(LightRed); OutTextxy(10+26*8,460,s);
SetFillStyle(3,LightGray);
If y1+r1=y2+r2 Then FloodFill(x2,y2-r2+1,Yellow)
Else FloodFill(x2,y2+r2-1,Yellow);
End;
SetColor(LightGray);
OutTextxy(10,470,'Nhan Rnter -> Stop.');
Sound(1500); Delay(100); Nosound;
Repeat ch:=Readkey Until ch=#13;
CloseGraph;
Run:=True;
End;
Function Done:Boolean;
Var ch:char;
Begin
Khung(20,15,60,17); Window(21,16,59,16);
8 h 54 m 28/7/2017
131
Thầy Trần Thông Quế
TextColor(LightGray);
Write('More (y/n)?');
Repeat ch:=Readkey Until ch In ['y','Y','n','N'];
TextColor(LightRed);
Write(ch);
Window(1,1,80,25);
If ch In ['n','N'] Then Done:=true
Else Done:=False;
End;
Begin
Repeat
Init;
If not Run then Halt;
Until Done;
End.
**10- (TÌM 1 LỜI GIẢI CHO BÀI TOÁN 8 HẬU TRÊN BÀN CỜ VUA 8X8). Tìm MỘT nghiệm cho bài
toán: Đặt 8 hậu trên bàn cờ vua 8x8 sao cho không con nào ăn được con nào.
Program Tim_Mot_Loi_Giai_Cho_Bai_8_Hau;
Uses crt,graph;
Const dl=200;
Var
p:pointer;
found:boolean;
a:array[1..8] of boolean;
b:array[2..16] of boolean;
c:array[-7..7]of boolean;
h:array[1..8] of Integer;
Procedure Initgr;
Var gd,gm:integer;
Begin
gd:=detect;
initgraph(gd,gm,'..\bgi');
if graphresult<>grok then
begin
write('Loi Do Hoa ! Go Enter Ket Thuc');
readln;
halt(1)
end
End;
Procedure Demo;
Begin
settextstyle(1,0,3);
setbkcolor(green);
setcolor(blue);
8 h 54 m 28/7/2017
132
Thầy Trần Thông Quế
outtextxy(425,30,'Tim Mot Loi Giai');
settextstyle(1,0,4);
setcolor(white);
outtextxy(425,90,'Cho Bai Toan');
setcolor(red);
settextstyle(4,0,7);
outtextxy(440,160,'8 Hau');
setcolor(blue);
settextstyle(1,0,3);
outtextxy(440,410,'Ha Noi - 2005');
setcolor(white);
settextstyle(3,0,1);
outtextxy(425,440,' Thay Tran-Hong-Que');
End;
Procedure Draw(i,j:integer);
Begin
if (i+j)mod 2=0 then
begin
setfillstyle(1,7);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end
else
begin
setfillstyle(1,white);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end;
End;
Procedure Draw_Queen(i,j:integer);
Var size:integer;
Begin
setfillstyle(1,3);
setcolor(red);
bar(i,j,i+50,j+55);
ellipse(i+25,j+35,0,360,10,5);
line(i+25-10,j+35,i+25-20,j+35-20);
line(i+25+10,j+35,i+25+20,j+35-20);
line(i+25-10-10,j+35-20,i+25+20,j+35-20);
circle(i+25-10-10+5,j+35-20-3,3);
circle(i+25-10-10+5+10,j+35-20-3,3);
circle(i+25-10-10+5+20,j+35-20-3,3);
circle(i+25-10-10+5+30,j+35-20-3,3);
setfillstyle(1,4);
floodfill(i+25,j+35-10,4);
setfillstyle(1,8);
floodfill(i+25-10-10+5,j+35-20-3,4);
floodfill(i+25-10-10+5+10,j+35-20-3,4);
floodfill(i+25-10-10+5+10+10,j+35-20-3,4);
8 h 54 m 28/7/2017
133
Thầy Trần Thông Quế
floodfill(i+25-10-10+5+10+10+10,j+35-20-3,4);
size:=Imagesize(i+1,j+1,i+51,j+51);
getmem(p,size);
getimage(i+2,j+2,i+50-2,j+50-2,p^);
End;
Procedure Put_Queen(i,j:integer);
Begin
Putimage(i+2,j+2,P^,Xorput);
End;
Procedure Table;
Var m,n:integer;
Begin
setviewport(0,0,getmaxx,getmaxy,false);
for m:=1 to 8 do
for n:=1 to 8 do
Draw(m,n);
Demo;
Draw_Queen(10,getmaxy-65);Put_Queen(10,getmaxy-65);
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
End;
Procedure Result;
Var s:string[2];
i:integer;
Begin
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
settextstyle(1,0,3);
setcolor(white);
for i:=1 to 8 do
begin
str(h[i],s);
outtextxy(28+(i-1)*50,getmaxy-50,s);
end;
End;
Procedure Try(i:integer;Var q:boolean);
Var j:integer;
Begin
j:=0;
8 h 54 m 28/7/2017
134
Thầy Trần Thông Quế
repeat
q:=false; inc(j);
if a[j] and b[i+j] and c[i-j] then
begin
h[i]:=j;
Put_Queen((i-1)*50+10,(j-1)*50+10);
sound(150);delay(dl);nosound;
a[j]:=false;b[i+j]:=false;c[i-j]:=false;
if i<8 then
begin
Try(i+1,q);
if not q then
begin
a[j]:=True;b[i+j]:=true;c[i-j]:=true;
Put_Queen((i-1)*50+10,(j-1)*50+10);
sound(350);delay(dl);nosound;
end;
end
else q:=true;
end;
until q or(j=8);
End;
Procedure Search;
Var i:integer;ch:char;
Begin
for i:=1 to 8 do a[i]:=true;
for i:=2 to 16 do b[i]:=true;
for i:=-7 to 7 do c[i]:=true;
Try(1,found);
if found then Result;
setcolor(white);
settextstyle(2,0,7);
outtextxy(430,300,'Go Esc Ket Thuc !');
repeat ch:=readkey until ch=#27;
End;
BEGIN
Initgr;
Table;
Search;
Closegraph;
END.
**11- (TÌM TẤT CẢ CÁC NGHIỆM CÓ THỂ CÓ CỦA BÀI TOÁN ĐẶT 8 HẬU TRÊN BÀN CỜ VUA
8X8). Tìm TẤT CẢ CÁC NGHIỆM có thể cho bài toán “Hậu”: Tìm cách đặt 8 hậu trên bàn cờ vua 8x8 sao
cho không con nào ăn được con nào. Gõ lần lượt một phím bất kỳ để xem từng nghiệm. Gõ ESC để ra.
Program Tim_Tat_Ca_Loi_Giai_Xep_8_Hau;
8 h 54 m 28/7/2017
135
Thầy Trần Thông Quế
Uses crt,graph;
Const Mc:Array [1..210,1..2] of Word =
((1046,24),(1046,12),(1174,12),(1244,24),
(1046,24),(1244,24),(1046,24),(1244,24),
(1174,24),(934,24),(934,12),(1046,12),
(1174,24),(934,24),(1174,24),(934,24),
(1174,24),(1046,24),(880,24),(880,12),
(934,12),(1046,24),(880,24),(1046,24),
(934,24),(880,24),(934,24),(784,96),
(1046,24),(1046,12),(1174,12),(1244,24),
(1046,24),(1244,24),(1046,24),(1244,24),
(1174,24),(934,24),(934,12),(1046,12),
(1174,24),(934,24),(1174,24),(934,24),
(1174,24),(1046,24),(880,24),(880,12),
(934,12),(1046,24),(1244,24),(1174,24),
(742,24),(784,24),(36000,24),(36000,48),
(36000,24),(1174,24),(1174,48),(1046,24),
(1174,24),(784,72),(784,24),(1174,48),
(1398,24),(1244,24),(1174,72),(1046,24),
(1174,48),(934,24),(784,24),(880,72),
(880,24),(934,48),(784,24),(880,24),
(588,72),(1174,24),(1174,48),(1046,24),
(1174,24),(784,72),(588,24),(588,48),
(784,24),(934,24),(880,72),(880,24),
(934,48),(742,24),(880,24),(588,72),
(588,24),(1046,48),(1046,24),(934,24),
(934,96),(36000,48),(36000,24),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
(784,24),(1174,48),(1398,24),(1244,24),
(1174,72),(1046,24),(1174,48),(934,24),
(784,24),(880,72),(880,24),(934,48),
(784,24),(880,24),(588,72),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
(588,24),(588,48),(784,24),(934,24),
(880,72),(880,24),(934,48),(742,24),
(784,24),(880,72),(1046,24),(1046,24),
(1174,24),(742,24),(880,24),(784,96),
(784,48),(880,72),(784,24),(880,48),
(588,24),(588,24),(522,72),(934,24),
(880,48),(588,24),(784,24),(880,72),
(880,24),(1046,48),(1174,24),(1244,24),
(1174,96),(36000,48),(1398,24),(1244,24),
(1174,72),(934,24),(934,48),(1046,24),
(1174,24),(1174,72),(880,24),(934,48),
(784,24),(880,24),(588,48),(36000,48),
(1046,32),(934,32),(880,32),(784,48),
(36000,24),(36000,48),(36000,24),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
8 h 54 m 28/7/2017
136
Thầy Trần Thông Quế
(784,24),(1174,48),(1398,24),(1244,24),
(1174,72),(1046,24),(1174,48),(934,24),
(784,24),(880,72),(880,24),(934,48),
(784,24),(880,24),(588,72),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
(588,24),(588,48),(784,24),(934,24),
(880,72),(880,24));
Var
p:pointer;
t,g:integer;
ch:char;
stop:boolean;
a:array[1..8] of boolean;
b:array[2..16] of boolean;
c:array[-7..7]of boolean;
h:array[1..8] of Integer;
Procedure Initgr;
Var gd,gm:integer;
Begin
gd:=detect;
initgraph(gd,gm,'..\bgi');
if graphresult<>grok then
begin
write('Loi Do Hoa ! Go Enter Ket Thuc');
readln;
halt(1)
end
End;
Procedure Demo;
Begin
settextstyle(1,0,2);
setbkcolor(green);
setcolor(blue);
outtextxy(425,30,'Tim Tat Ca Loi Giai');
settextstyle(1,0,4);
setcolor(white);
outtextxy(425,60,'Cho Bai Toan');
setcolor(red);
settextstyle(4,0,7);
outtextxy(440,100,'8 Hau');
setcolor(Blue);
settextstyle(1,0,3);
outtextxy(440,370,'Ha Noi - 2002');
setcolor(Magenta);
settextstyle(3,0,1);
outtextxy(425,410,' Thay Tran-hong-Que');
setcolor(red);
8 h 54 m 28/7/2017
137
Thầy Trần Thông Quế
outtextxy(425,440,' Hoi Tin hoc Viet nam');
End;
Procedure Draw(i,j:integer);
Begin
if (i+j)mod 2=0 then
begin
setfillstyle(1,7);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end
else
begin
setfillstyle(1,white);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end;
End;
Procedure Draw_Queen(i,j:integer);
Var size:integer;
Begin
setfillstyle(1,3);
setcolor(red);
bar(i,j,i+50,j+55);
ellipse(i+25,j+35,0,360,10,5);
line(i+25-10,j+35,i+25-20,j+35-20);
line(i+25+10,j+35,i+25+20,j+35-20);
line(i+25-10-10,j+35-20,i+25+20,j+35-20);
circle(i+25-10-10+5,j+35-20-3,3);
circle(i+25-10-10+5+10,j+35-20-3,3);
circle(i+25-10-10+5+20,j+35-20-3,3);
circle(i+25-10-10+5+30,j+35-20-3,3);
setfillstyle(1,4);
floodfill(i+25,j+35-10,4);
setfillstyle(1,8);
floodfill(i+25-10-10+5,j+35-20-3,4);
floodfill(i+25-10-10+5+10,j+35-20-3,4);
floodfill(i+25-10-10+5+10+10,j+35-20-3,4);
floodfill(i+25-10-10+5+10+10+10,j+35-20-3,4);
size:=Imagesize(i+1,j+1,i+51,j+51);
getmem(p,size);
getimage(i+2,j+2,i+50-2,j+50-2,p^);
End;
Procedure Put_Queen(i,j:integer);
Begin
Putimage(i+2,j+2,P^,Xorput);
End;
{===============================}
Procedure Table;
8 h 54 m 28/7/2017
138
Thầy Trần Thông Quế
Var m,n:integer;
Begin
setviewport(0,0,getmaxx,getmaxy,false);
for m:=1 to 8 do
for n:=1 to 8 do
Draw(m,n);
Demo;
Draw_Queen(10,getmaxy-65);Put_Queen(10,getmaxy-65);
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
End;
Procedure Result;
Var s:string[2];
i:integer;
Begin
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
settextstyle(1,0,3);
setcolor(white);
for i:=1 to 8 do
begin
str(h[i],s);
outtextxy(28+(i-1)*50,getmaxy-50,s);
end;
End;
Procedure Wait;
Begin
inc(t);
Result;
setcolor(yellow);
settextstyle(2,0,6);
outtextxy(430,200,'Go Phim Esc De Ngung !');
setcolor(white);
settextstyle(2,0,5);
outtextxy(420,230,'Go Phim Bat Ky De Tiep Tuc...');
while keypressed do ch:=readkey;
repeat until keypressed;
ch:=readkey;
if ch=#27 then stop:=true;
End;
8 h 54 m 28/7/2017
139
Thầy Trần Thông Quế
Procedure Music;
Begin
sound(Mc[g][1]);
delay(mc[g][2]*8);{ delay(20000);}
nosound;
if g=210 then g:=1 else inc(g)
End;
Procedure Try(i:integer);
Var j:integer;
Begin
j:=0;
repeat
inc(j);
if a[j] and b[i+j] and c[i-j] then
begin
h[i]:=j;
Put_Queen((i-1)*50+10,(j-1)*50+10);
Music;
a[j]:=false;b[i+j]:=false;c[i-j]:=false;
if i<8 then Try(i+1)
else Wait;
a[j]:=True;b[i+j]:=true;c[i-j]:=true;
Put_Queen((i-1)*50+10,(j-1)*50+10);
Music;
end;
until (j=8) or stop;
End;
Procedure Search;
Var i:integer;
s:string[30];
Begin
t:=0;g:=1;
stop:=false;
for i:=1 to 8 do a[i]:=true;
for i:=2 to 16 do b[i]:=true;
for i:=-7 to 7 do c[i]:=true;
Try(1);
str(t,s);
if stop then
s:='Da Tim Duoc '+s+' Loi Giai'
else
s:='Tong So Co '+s+' Loi Giai';
setcolor(red);
settextstyle(2,0,6);
outtextxy(418,280,s);
setcolor(white);
settextstyle(2,0,7);
8 h 54 m 28/7/2017
140
Thầy Trần Thông Quế
outtextxy(430,310,'Go Esc Ket Thuc !');
repeat ch:=readkey until ch=#27;
End;
BEGIN
Initgr;
Table;
Search;
Closegraph;
END.
= = = = = = = = = = = = = = = = = = = = = =
PHẦN VIII. GRAPH THEORY & APPLICATIONS
VIII.1-TÌM KIẾM TRÊN ĐỒ THỊ (tên khác: DUYỆT ĐỒ THỊ); TÔ
MÀU ĐỒ THỊ; TÌM MIỀN LIÊN THÔNG CỦA ĐT.
(Nếu quên OR lơ mơ về lý thuyết một vấn đề nào đó, các bạn nên đến thư viện – để mất ít tiền nhất- xem
quyển: LÝ THUYÊT ĐỒ THỊ, nxb GIÁO DỤC 2012. Tác giả: Trần Thông Quế)
A/ CÁC THUẬT TOÁN TÌM KIẾM (DUYỆT) TRÊN ĐỒ THỊ.
1-Hãy cài đặt trực quan (đồ họa hóa code) hai thuật toán DBF và BFS trên cùng một bản Code (BÀI CƠ
BẢN NHƯNG KHÔNG DỄ!).
Yêu cầu: * Gõ ENTER để chuyển từ thuật toán DFS sang BFS và ngược lại,
* Gõ ESC để thoát
CODE:
PROGRAM DFS_BFS_SEARCH;
USES CRT,GRAPH;
CONST R=15;DL=500;N=8;VC=100; {KHONG CO DUONG DI THI DAT VO CUC VC=100}
C:ARRAY[1..8] OF INTEGER=(150,330,450,450,330,150,30,30);
D:ARRAY[1..8] OF INTEGER=(30,30,150,330,450,450,330,150);
CL:ARRAY[0..3] OF WORD=(BLUE,YELLOW,WHITE,WHITE);
NL:ARRAY[0..3] OF WORD=(YELLOW,BLUE,RED,BLACK);
TYPE CSD=0..VC;
AR=ARRAY[CSD] OF CSD;
QUEUE=RECORD
REAR:CSD;
ELEMENT:AR;
END;
VAR G:ARRAY[CSD,CSD] OF BOOLEAN;
8 h 54 m 28/7/2017
141
Thầy Trần Thông Quế
I,J,K,U:CSD;
P:AR;
(*-----------------------------------------------------------*)
PROCEDURE INITGR; { KHOI TAO DO HOA}
VAR GD,GM:INTEGER;
BEGIN
GD:=DETECT;
INITGRAPH(GD,GM,'..\BGI');
IF (GRAPHRESULT<> GROK) THEN
BEGIN
WRITELN('LOI KHOI TAO DO HOA, GO ENTER KET THUC !');
READLN;
HALT(1)
END
END;
(*-----------------------------------------------------*)
PROCEDURE ADD(X:CSD;VAR Q:QUEUE); {THEM PHAN TU TU DUOI HANG DOI}
BEGIN
WITH Q DO
BEGIN
REAR:=REAR+1;
ELEMENT[REAR]:=X
END;
END;
(*-----------------------------------------------------*)
PROCEDURE DELETE(VAR Q:QUEUE;VAR X:CSD); {BOT PHAN TU KHOI HANG DOI}
VAR K:CSD;
BEGIN
WITH Q DO
BEGIN
X:=ELEMENT[1];
FOR K:=1 TO REAR-1 DO ELEMENT[K]:=ELEMENT[K+1];
REAR:=REAR-1
END;
END;
(*-----------------------------------------------------*)
PROCEDURE VENUT(U:CSD;M1,M2:WORD); {VE CAC DINH DO THI}
VAR ST:STRING[3];
BEGIN
SETFILLSTYLE(1,M2);
SETCOLOR(M1);
FILLELLIPSE(C[U],D[U],R,R);
STR(U,ST);
OUTTEXTXY(C[U]-2,D[U]-2,ST);
END;
(*-------------------------------*)
8 h 54 m 28/7/2017
142
Thầy Trần Thông Quế
PROCEDURE LINK(X,Y:CSD;M:WORD);
BEGIN
SETCOLOR(M);
LINE(C[X],D[X],C[Y],D[Y]);
END;
(*-------------------------------*)
PROCEDURE DATA_AUTO_CREA; {TU DONG TAO DU LIEU NGAU NHIEN CHO PROG.}
BEGIN
RANDOMIZE;
FOR I:=1 TO N DO
BEGIN
G[I,I]:=FALSE;
FOR J:=I+1 TO N DO
BEGIN
G[I,J]:=RANDOM(3)=1;
G[J,I]:=G[I,J]
END;
END;
FOR I:=1 TO N DO
BEGIN
J:=0;
REPEAT
J:=J+1
UNTIL G[I,J] OR (J=N);
IF (J=N) AND (NOT G[I,N]) THEN
BEGIN
J:=1+RANDOM(N);
IF J=I THEN IF I
8 h 54 m 28/7/2017
143
Thầy Trần Thông Quế
BEGIN
SETBKCOLOR(BLUE);CLEARDEVICE;
SETFILLSTYLE(1,DARKGRAY);
BAR(0,0,GETMAXY,GETMAXY);
FOR I:=1 TO N DO
FOR J:=1 TO N DO IF G[I,J] THEN LINK(I,J,NL[0]);
LINE(C[I],D[I],C[J],D[J]);
FOR I:=1 TO N DO VENUT(I,CL[0],NL[0]);
END;
(*--------------------------------------------------*)
PROCEDURE VE_GR_BFS(U:CSD); {HIEN THI DO THI DE DUYET THEO BE RONG}
VAR Q:QUEUE;
BEGIN
VENUT(U,CL[K],NL[K]);
P[U]:=0;
Q.REAR:=0;
ADD(U,Q);
WHILE Q.REAR<>0 DO
BEGIN
DELETE(Q,I);
FOR J:=1 TO N DO
IF G[I,J] THEN
IF P[J]=VC THEN
BEGIN
P[J]:=I;
LINK(I,J,NL[K]);
VENUT(J,CL[K],NL[K]);
VENUT(I,CL[K],NL[K]);
ADD(J,Q);
DELAY(DL);
END;
END;
END;
(*--------------------------*)
PROCEDURE BFS; {DUYET THEO CHIEU RONG}
BEGIN
FOR U:=1 TO N DO P[U]:=VC;
K:=0;
FOR U:=1 TO N DO IF P[U]=VC THEN
BEGIN
K:=(K+1) MOD 4;
VE_GR_BFS(U);DELAY(DL)
END;
END;
(*--------------------*)
PROCEDURE VE_DT_DFS(U:CSD); {HIEN THI DO THI DE DUYET THEO CHIEU SAU}
8 h 54 m 28/7/2017
144
Thầy Trần Thông Quế
VAR T:CSD;
BEGIN
I:=I+1;
P[U]:=I;
FOR T:=1 TO N DO
IF G[U,T] THEN
IF P[T]=0 THEN
BEGIN
LINK(U,T,NL[K]);
VENUT(U,CL[K],NL[K]);
VENUT(T,CL[K],NL[K]);
DELAY(DL);
VE_DT_DFS(T);
END;
END;
(*-----------------------------*)
PROCEDURE DFS; {DUYET THEO CHIEU SAU}
BEGIN
FOR I:=1 TO N DO P[I]:=0;
I:=0;
FOR U:=1 TO N DO IF P[U]=0 THEN
BEGIN
K:=(K+1) MOD 4;
VENUT(U,CL[K],NL[K]);
VE_DT_DFS(U);DELAY(DL)
END;
END;
(*-----------------------------------*)
PROCEDURE PROC_CALL_PROC; {THU TUC GOI CAC THU TUC DUYET}
VAR KT:CHAR;
BEGIN
IF KEYPRESSED THEN
REPEAT KT:=READKEY UNTIL NOT KEYPRESSED;
REPEAT
DATA_AUTO_CREA;
PRINT_GRAPH;
DEMO('Theo Be Rong');
KT:=READKEY;
IF KT=#27 THEN EXIT;
BFS;
KT:=READKEY;
IF KT=#27 THEN EXIT;
PRINT_GRAPH;
DEMO('Theo Do Sau');
KT:=READKEY;
IF KT=#27 THEN EXIT;
8 h 54 m 28/7/2017
145
Thầy Trần Thông Quế
DFS;
KT:=READKEY;
UNTIL (KT=#27);
END;
(*-----------------------------------*)
BEGIN (* CHUONG TRINH CHINH *)
CLRSCR;
INITGR;
PROC_CALL_PROC;
CLOSEGRAPH;
END.
Thử một bài duy nhất ở mức TRÊN CƠ BẢN về duyệt theo BFS:
2-(IOI-1996: THI OLYMPIC TIN HỌC QUỐC TẾ 1996) Tiếp theo thành tựu khối lập phương kỳ diệu, ông
Rubik phát minh dạng cải biên phẳng của khối này và ông gọi đó là các ô vuông kỳ diệu. Đó là một bảng 8
ô vuông có kích thước như nhau được tô màu khác nhau.
1 2 3 4
8 7 6 5
Các màu tô được ký hiệu bởi 8 số nguyên dương đàu tiên (xem hình ngay trên) viết lần lượt theo chiều kim
đồng hồ, bắt đầu từ ô góc trên cùng trái và kết thúc ở ô góc dưới cùng trái.
Một cấu hình như trên gọi là cấu hình ban đầu. Ta thực hiện 3 phép biến đổi cơ bản ký hiệu là ‘A’, ‘B’, ‘C’
để tác động lên cấu hình của bảng, trong đó:
• ‘A’: Đổi chỗ dòng trên và dòng dưới
• ‘B’: Thực hiện phép hoán vị theo chiều sang phải vòng quanh bảng.
• ‘C’: Quay theo chiều kim đồng hồ 4 ô ở giữa
Mọi cấu hình đều có thể được tác động bởi 3 phép biến đổi cơ bản nói trên. Và tác động của 3 phép biến đổi
cơ bản ấy mô tả bởi hình dưới đây: (Ở MỖI BỘ DATA DƯỚI ĐÂY CÁC SỐ TRÊN CÙNG VÀ DƯỚI
CÙNG LÀ VỊ TRÍ CÁC Ô CỦA BẢNG)
BẢNG 1 1 2 3 4 INDEX của các ô
1 2 3 4
8 7 6 5
8 7 6 5 INDEX của các ô
BẢNG 2
4 1 2 3
6 7 8
5
8 h 54 m 28/7/2017
146
Thầy Trần Thông Quế
BẢNG 3 1 7 2 4
8 6 3 5
Các số ghi ở ngoài bảng chỉ vị trí các ô của bảng. Nếu một ô ở vị trí p chứa số i thì có nghĩa là sau khi làm
phép biến đổi tương ứng, ô vuông mà vị trí trước lúc biến đổi của nó là i sẽ được chuyển đến vị trí p.
a) Hãy viết program tìm dãy các phép biến đổi để đưa cấu hình ban đầu về một cấu hình đích cho trước.
b) Bạn sẽ được thêm 2 điểm nếu số phép biến đổi của bạn không quá 300
* Dữ liệu vào cất trên text file Data.in gồm:
- Một dòng duy nhất chứa 8 số nguyên mô tả cấu hình đích.
* Kết quả ghi lên text file Data.ou:
-Dòng đầu tiên ghi số các phép biến đổi L
- Tại L dòng tiếp theo ghi ký hiệu các phép biến đổi đã nói trên theo TRÌNH TỰ mà program của bạn đã
thực hiện
MỘT VÍ DỤ CỤ THỂ CỦA BÀI TOÁN NÀY CHO DƯỚI ĐÂY
Data.In
2 6 8 4 5 7 3 1
Data.Ou
7
B
C
A
B
C
C
B
Program MagicSquare; {BAI NAY DUYET DO THI THEO BFS)
Uses crt;
Const kt=8; m=40320; fi='Data.In'; fo='Data.Ou';
Type Bd=array[1..kt] of 1..kt; Ht=array[1..kt] of 1..kt;
Const thuan:Array['A'..'C'] Of Bd=((8,7,6,5,4,3,2,1),(4,1,2,3,6,7,8,5),
(1,7,2,4,5,3,6,8)); {Cac b_doi co ban}
nguoc:Array['A'..'C'] of Bd=((8,7,6,5,4,3,2,1),(2,3,4,1,8,5,6,7),
(1,3,6,4,5,7,2,8)); {Nguoc cua b_doi}
dau:Ht=(1,2,3,4,5,6,7,8); {Trang thai ban dau}
Var dic:Ht; {Bien luu trang thai dich}
s:String; {Day cac b_doi dua tr_thai dau den tr_thai dich}
fact:Array[0..kt] of Longint; {mang luu tu 0! den 8!}
last:Array[0..m] of Char; {last[sh(dic)] la ky tu cuoi cung cua day cac}
{b_doi dua trang thai dau ve trang thai dich}
{Neu last[sh(dic)]=' ' thi dich cung rong (tuc dich khong duoc sinh}
Procedure Nhap;
Var tepvao:text; i:word;
Begin
8 h 54 m 28/7/2017
147
Thầy Trần Thông Quế
Assign(tepvao,fi); Reset(tepvao);
For i:=1 to kt Do Read(tepvao,dic[i]);
Close(tepvao);
End; {Het nhap lieu}
Procedure Facto; {Tinh giai thua}
Var i:word;
Begin
fact[1]:=1; fact[0]:=1;
For i:=2 to kt Do
fact[i]:=i*fact[i-1];
End;
Function sh(p:Ht):Word; {ham sh de tinh so hieu cua mot hoan vi bat ky}
Var res, L, i,j:Word;
Begin
res:=0;
For i:=1 to kt Do
Begin
L:=0; {L- so cac phan tu cua p o cac vi tri tu 1->i-1 nhỏ hơn p[i]}
For j:=1 to i-1 Do
If p[j]dic[i] then
Begin
8 h 54 m 28/7/2017
148
Thầy Trần Thông Quế
bang:=false;
exit;
End;
End;
Procedure sinh; {Tao day cac b_doi tu tr_thai dau de dat tr_thai dich}
{last[sh(dic)] la phep b_doi cuoi cung cua day}
Const qs=700; {kich thuoc danh sach}
Var hdoi:Array[0..qs-1] of ht; {Khai bao hang doi chua cac b_doi}
notfound:Boolean;
head, tail, i, rankq:Word;
r, s:Ht; x:Char;
Begin
For i:=0 to m Do last[i]:=' '; {khoi tri}
last[0]:='.';
head:=0; tail:=1;
hdoi[0]:=dau;
notfound:=true;
While notfound Do
Begin
r:=hdoi[head]; Inc(head);
If head=qs Then head:=0;
For x:='A' to 'C' Do
Begin
App(r, x, s);
rankq:=sh(s);
If last[rankq]=' ' Then
Begin
last[rankq]:=x;
If bang(dic,s) Then
Begin
notfound:=false;
break;
End;
hdoi[tail]:=s;
Inc(tail);
If tail=qs Then tail:=0;
End;
End;
End;
End; {ket thuc thu tuc sinh}
Procedure tim; {kien tao cac phep bien doi}
Var rankq:Word; x:Char; p,q:Ht;
Begin
q:=dic; rankq:=sh(q); s:=' ';
While rankq<>0 do
Begin
8 h 54 m 28/7/2017
149
Thầy Trần Thông Quế
x:=last[rankq];
s:=x+s;
bd_nguoc(q,x,p);
q:=p;
rankq:=sh(q);
End;
End;
Procedure Xuat;
Var tepra:text; L,i:word;
Begin
Assign(tepra,fo); rewrite(tepra);
L:=length(s);
Writeln(tepra, L-1);
For i:=1 to L do Writeln(tepra, s[i]);
Close(tepra);
End;
Begin {Main Prog.}
clrscr;
Nhap;
Facto;
Sinh;
Tim;
Xuat;
Writeln('Done!');
readln;
End.
B/ CÁC THUẬT TOÁN TÌM CÁC MIỀN LIÊN THÔNG TRÊN ĐỒ THỊ
B.1) TÌM MIỀN LIÊN THÔNG TRÊN ĐỒ THỊ VÔ HƯỚNG
3- Cài đặt thuật toán tìm & liệt kê các thành phần (miền) liên thông của một đồ thị vô hướng. Biết rằng cấu
trúc của đồ thị vô hướng được biểu diễn bởi danh sách liệt kê cạnh như sau (Ds này lưu trên Text File
LTHG.IN):
13 10
1 2
1 3
2 3
4 5
4 7
5 6
8 9
10 12
11 12
12 13
Kết quả lưu trên file Xuat.kq
CODE: Để đạt được mục tiêu đề bài ta duyệt đồ thị Đệ quy theo DFS
8 h 54 m 28/7/2017
150
Thầy Trần Thông Quế
Program Dem_so_thp_lthong;
uses crt;
const max=50;
fi='lthg.in'; fo='xuat.kq'; {Du lieu vao la Ds liet ke canh!}
type m1=Array[0..max] of integer;
m2=Array[1..max,1..max] of byte;
var a:m2; {ma tran danh sach liet ke canh}
n:integer;
v:m1;
sm:integer; {so mien lien thong}
Procedure Nhap;
var f:text; i,j:integer;
Begin
Assign(f,fi); Reset(f);
Read(f,n);
FillChar(a,sizeof(a),0); {khoi tri cho mang a}
While not seekeof(f) do {tao ma tran luu dinh dau va cuoi cua moi canh}
Begin
Read(f,i);
While not seekeoln(f) do
Begin
Read(f,j);
a[i,j]:=1;
a[j,i]:=1;
End;
Readln(f);
End;
Close(f);
End;
Procedure DFS(i:integer);
Var j:integer;
Begin
For j:=1 to n do
If v[j]=0 then {neu j chua thuoc mien lien thong nao thi}
If a[i,j]=1 then {neu j ke voi i thi }
Begin
v[j]:=sm; {ghi nho dinh j cung mien lth sm voi i}
DFS(j); {duyet tiep do thi theo chieu sau tu dinh j}
End;
End;
Procedure Xuly;
Var s:integer;
Begin
FillChar(v,sizeof(v),0);
sm:=0;
For s:=1 to n do
8 h 54 m 28/7/2017
151
Thầy Trần Thông Quế
If v[s]=0 then
Begin
Inc(sm); {danh so cho mien lth moi}
v[s]:=sm; {s la dinh dau tien phat hien thuoc mien lth moi}
DFS(s); {Duyet dthi tim tat ca cac dinh lth voi s}
End;
End;
Procedure ghikq;
var f:text; i,j:integer;
Begin
Assign(f,fo); Rewrite(f);
Writeln(f,'So mien lien thong la:',sm);
For i:=1 to sm do
Begin
For j:=1 to n do
If v[j]=i then
Write(f,j,' ');
Writeln(f,'<-- Day la cac dinh o mien Lt thu ',i);
End;
close(f);
End;
Procedure Inkq;
var f:text; line:string[50];
Begin
Assign(f,fo); Reset(f);
While not seekeof(f) Do
Begin
Readln(f,line);
Writeln(line);
End;
Close(f);
End;
Begin clrscr;
Nhap;
Xuly;
Ghikq;
Inkq;
Writeln;
Write('Go ENTER de thoat!');
Readln;
End.
8 h 54 m 28/7/2017
152
Thầy Trần Thông Quế
B.2) TÌM MIỀN LIÊN THÔNG MẠNH TRÊN ĐỒ THỊ CÓ HƯỚNG (THỰC
CHẤT LÀ CÀI ĐẶT THUẬT TOÁN TARJAN)
4/ Cài đặt thuật toán tìm & liệt kê các miền liên thông MẠNH của đồ thị có hướng (thuật toán TARJAN).
Biết rằng đồ thị có hướng này được biểu diễn bởi ds cung sau đây (và ds này lưu trên text file
LTH_MANH.IN):
11 15
1 2
1 8
2 3
3 4
4 2
4 5
5 6
6 7
7 5
8 9
9 4
9 10
10 8
10 11
11 9
Kết quả lưu trên file LTH_MAMH.OU
CODE: (Về duyệt đồ thị, bài này cũng dùng DFS)
Program Tarjan_Alg;
Uses crt;
Const fi='LTH_MANH.IN'; fo='LTH_MANH.OU';
Type lk=^nut;
nut=record
s:word;
next:lk;
End;
cay=array[0..200] of lk;
m1=array[0..200] of word;
Var sv,id,m,n,top:word; {m:so dinh; n:so canh}
Num,Low,p,s:m1; dsk:cay;
f:Text;
Procedure Nhap;
Var i,u,v: word; t:lk;
Begin
Assign(f,fi); Reset(f);
Readln(f,m,n); {doc so dinh m, so canh n tu tep vao cac bien nho m,n}
For i:=1 to n Do
Begin
Readln(f,u,v);
New(t);
8 h 54 m 28/7/2017
153
Thầy Trần Thông Quế
t^.s:=v;
t^.next:=dsk[u];
dsk[u]:=t;
End;
Close(f);
End;
Function min(u,v:word):word;
Begin
If u
Procedure DFS(i:word);
Var j:word; t:lk;
Begin
Inc(id);
Num[i]:=id;
Low[i]:=Num[i];
t:=dsk[i];
Inc(top);
s[top]:=i;
While Not (t=Nil) Do
Begin
j:=t^.s;
If p[j]=0 then
If Num[j]=0 then
Begin
DFS(j);
Low[i]:=min(Low[i], Low[j]);
End
Else Low[i]:=min(Low[i], Num[j]);
t:=t^.next;
End;
If Low[i]=Num[i] then
Begin
Inc(sv);
Repeat
j:=s[top]; {lay 1 phan tu ra khoi Stack tai dinh, luu vao j}
dec(top); {Khi do so phan tu o Stack giam di mot}
p[j]:=sv;
Until i=j;
End;
End;
Procedure Visit;
var i:word;
Begin
For i:=1 to m do
8 h 54 m 28/7/2017
154
Thầy Trần Thông Quế
If Num[i]=0 then DFS(i);
End;
Procedure Xuat;
Var i,j:word;
Begin
Assign(f,fo); Rewrite(f);
Writeln;Writeln;
Writeln(f,'So mien lien thong la:',sv);
For i:=1 to sv Do
Begin
For j:=1 to m Do
If p[j]=i then write(f,j,' ');
Writeln(f,'-> Cac dinh thuoc mien lien thong thu ',i,'.');
End;
Close(f);
end;
Procedure Inkq;
Var f:Text;line:String;
Begin
Assign(f,fo); Reset(f);
While Not SeekEof(f) Do
Begin
Readln(f,line);
Writeln(line);
End;
Close(f);
End;
{ Main Program }
Begin clrscr;
Nhap;
Visit;
Xuat;
Inkq;
Readln;
End.
B.3) BÀI TOÁN TÔ MÀU ĐỒ THỊ
5- Hãy dùng số màu ít nhất để tô màu đồ thị có N đỉnh, sao cho hai đỉnh BẤT KỲ KỀ NHAU phải được tô
bằng màu KHÁC NHAU.
Yêu cầu:
1-Đồ họa hóa Code
2-Cấu trúc đồ thị tự động thay đổi nhờ nhấn phím ENTER; nhấn ESC để thoát.
CODE:
PROGRAM COLOR_GRAPH;
8 h 54 m 28/7/2017
155
Thầy Trần Thông Quế
USES CRT,GRAPH;
CONST R=15;DL=500;VC=100;N=8;
C:ARRAY[1..8] OF INTEGER=(150,330,450,450,330,150,30,30);
D:ARRAY[1..8] OF INTEGER=(30,30,150,330,450,450,330,150);
CL:ARRAY[0..4] OF WORD=(WHITE,RED,YELLOW,BLUE,GREEN);
TYPE CSD=0..VC;
VAR G:ARRAY[CSD,CSD] OF BOOLEAN;
V,V0,V1:SET OF CSD;
I,J,K:CSD;
(*------------------------------------------------------------*)
PROCEDURE INITGR;
VAR GD,GM:INTEGER;
BEGIN
GD:=DETECT;
INITGRAPH(GD,GM,'..\BGI');
IF (GRAPHRESULT<> GROK) THEN
BEGIN
WRITELN('LOI KHOI TAO DO HOA, GO ENTER KET THUC !');
READLN;
HALT(1)
END
END;
(*-----------------------------------------------------*)
PROCEDURE VENUT(U:CSD;M:WORD);
BEGIN
SETFILLSTYLE(1,M);SETCOLOR(M);
FILLELLIPSE(C[U],D[U],R,R);
END;
(*-------------------------------*)
PROCEDURE LINK(X,Y:CSD;M:WORD);
BEGIN
SETCOLOR(M);
LINE(C[X],D[X],C[Y],D[Y]);
END;
(*-------------------------------*)
PROCEDURE INIT_GRAPH;
BEGIN
RANDOMIZE;
FOR I:=1 TO N DO
BEGIN
G[I,I]:=FALSE;
FOR J:=I+1 TO N DO
BEGIN
G[I,J]:=RANDOM(3)=1;
G[J,I]:=G[I,J]
END;
8 h 54 m 28/7/2017
156
Thầy Trần Thông Quế
END;
FOR I:=1 TO N DO
BEGIN
J:=0;
REPEAT
J:=J+1
UNTIL G[I,J] OR (J=N);
IF (J=N) AND (NOT G[I,N]) THEN
BEGIN
J:=RANDOM(N)+1;
IF J=I THEN IF I[] DO
BEGIN
K:=K+1; I:=0;
REPEAT I:=I+1 UNTIL I IN V0;
VENUT(I,CL[K]); DELAY(DL);
8 h 54 m 28/7/2017
157
Thầy Trần Thông Quế
V1:=[I];
FOR I:=1 TO N DO
IF I IN V0 THEN
BEGIN
J:=0;
REPEAT
J:=J+1;
CHECK:=G[I,J] AND (J IN V1);
UNTIL CHECK OR (J=N);
IF NOT CHECK THEN
BEGIN
VENUT(I,CL[K]); DELAY(DL);
V1:=V1+[I];
END;
END;
V0:=V0-V1;
END;
END;
(*---------------------------------------*)
PROCEDURE PROC_CALL_PROC; {THU TUC GOI CAC THU TUC}
VAR KT:CHAR;
BEGIN
IF KEYPRESSED THEN
REPEAT KT:=READKEY UNTIL NOT KEYPRESSED;
REPEAT
INIT_GRAPH;
PRINT_GRAPH;
MENU_PRINT;
COLORING;
KT:=READKEY;
UNTIL (KT=#27);
END;
(*--------------------------------------*)
BEGIN (* CHUONG TRINH CHINH *)
CLRSCR;
INITGR;
V:=[];
FOR I:=1 TO N DO V:=V+[I];
PROC_CALL_PROC;
CLOSEGRAPH;
END.
8 h 54 m 28/7/2017
158
Thầy Trần Thông Quế
VIII-2/ ĐỒ THỊ EULER & ĐỒ THỊ HAMILTON
A) ĐỒ THỊ EULER
6- Liệt kê các đường đi Euler trên đồ thị vô hướng được biểu diễn bởi ma trận kề dưới đây:
9 Số đỉnh của đồ thị (Bắt buộc phải có dữ liệu này!)
0 1 1 0 0 0 0 0 0
1 0 1 0 0 0 0 0 0
1 1 0 1 0 1 0 0 0
0 0 1 0 1 0 0 0 0
0 0 0 1 0 1 0 1 1
0 0 1 0 1 0 1 1 0
0 0 0 0 0 1 0 1 0
0 0 0 0 1 1 1 0 1
0 0 0 0 1 0 0 1 0
CODE:
Program Duongdi_Euler;
uses crt;
Label L1;
Const max=30;
Type mg1=array[1..max,1..max] of byte;
mg2=array[1..max] of boolean;
mg3=array[1..max] of integer;
Var c:mg1; check:mg2; i,j,u,n,dem1,dem:integer;
f:text; tf:string[12];
Function l_thg(u,v:integer; ktra:mg2):integer;
var i,j,d,k,l:integer; p:mg3;
Begin
c[u,v]:=0; c[v,u]:=0;
For i:=1 to n do p[i]:=0;
d:=0;
For i:=1 to n do
Begin
If (p[i]=0) and ktra[i] then
Begin
Inc(d); p[i]:=d;
for j:=1 to n do
for L:=1 to n do
If (p[j]=0) and ktra[j] and (p[L]=d) and (c[L,j]=1) then
p[j]:=d;
End;
End;
c[u,v]:=1; c[v,u]:=1;
L_thg:=d;
End;
8 h 54 m 28/7/2017
159
Thầy Trần Thông Quế
{Main Prog.}
Begin clrscr;
Write('Nhap ten tep du lieu:'); readln(tf);
Assign(f,tf); Reset(f);
Readln(f,n);
For i:=1 to n do
For j:=1 to n do Read(f,c[i,j]);
Close(f);
Write('Cho biet dinh xuat phat:'); Readln(u);
Writeln('Duong di Euler tim duoc:'); Writeln;
dem:=0;
For j:=1 to n do check[j]:=true;
L1:dem1:=0;
For j:=1 to n do
If c[u,j]=1 then Inc(dem1);
dem:=dem+1;
If dem1=1 then
Begin
For j:=1 to n do If c[u,j]=1 then
Begin
check[u]:=false;
c[u,j]:=0; c[j,u]:=0;
Writeln('Di qua canh thu ',dem,' dung 1 lan la tu:',u,'->',j);
u:=j;
Goto L1;
End;
End
Else
Begin
For j:=1 to n do
If c[u,j]=1 then
Begin
If L_thg(u,j,check)=1 then
Begin
c[u,j]:=0; c[j,u]:=0;
Writeln('Di qua canh thu ',dem,' dung 1 lan la tu:',u,'->',j);
u:=j;
Goto L1;
End
End
End;
Readln;
End.
7- Tìm và hiển thị chu trình EULER trên đồ thị biểu diễn bởi danh sách liệt kê cạnh. Yêu cầu: Program phải
chạy được cả với đồ thị vô hướng và đồ thị có hướng (đồ thị vô hướng: gõ 0; đồ thị có hướng: gõ 1).
Test1: Dùng file vào DTEUL.IN
8 h 54 m 28/7/2017
160
Thầy Trần Thông Quế
4 5 -> 4 đỉnh; 5 cạnh (Bắt buộc phải có hai data này!)
1 2
1 4
2 3
2 4
3 4
Test 2: Dùng file vào EU1.IN
5 6
1 2
1 5
2 5
3 4
3 5
4 5
B) ĐỒ THỊ HAMILTON
8- Tìm và hiển thị đường đi Hamilton trên đồ thị vô hướng được biểu diễn bởi danh sách liệt kê cạnh.
Test1: Dùng file vào DTEUL.IN
4 5
1 2
1 4
2 3
2 4
3 4
Test 2: Dùng file vào EU1.IN
5 6
1 2
1 5
2 5
3 4
3 5
4 5
9/ (Bài này bạn thử test với ma trận kề của đồ thị) Tìm và liệt kê chu trình Hamilton trên đồ thị được biểu
diễn bởi ma trận kề dưới đây.
8
0 1 1 1 0 0 0 0
1 0 0 0 1 0 0 0
1 0 0 1 1 0 0 0
1 0 1 0 0 1 1 0
0 1 1 0 0 1 0 1
0 0 0 1 1 0 1 0
0 0 0 1 0 1 0 1
0 0 0 0 1 0 1 0
8 h 54 m 28/7/2017
161
Thầy Trần Thông Quế
CODE:
Program Chutrinh_Hamilton;
Uses crt;
Var i,j,n:Integer;
c:Array[1..20,1..20] of byte;
p:Array[1..20] of byte;
b:array[1..20] of boolean;
d:Word; f1,f2:Text;
Procedure Xuly;
Label l1;
Var t:integer; ktra:boolean;
Begin
ktra:=true;
For t:=1 to n-1 Do
If c[p[t],p[t+1]]=0 then
Begin
ktra:=False;
goto L1;
End;
If c[p[n],p[1]]=0 then ktra:=False;
L1:If ktra then
Begin
d:=d+1;
Write(f2,'Chu trinh Hamilton thu ',d,' la:');
For t:=1 to n Do Write(f2,p[t]:3);
Writeln(f2);
End;
End;
Procedure test(k:integer);
Var i1,j:integer;
Begin
For j:=1 to n do
If b[j] then
Begin
p[k]:=j; b[j]:=False;
If k=n then xuly Else test(k+1);
b[j]:=True;
End;
End;
{Main Prog.}
Begin clrscr;
Assign(f1,'CtHamil.Inp'); Reset(f1);
Assign(f2,'CtHamil.Out'); Rewrite(f2);
Readln(f1,n);
For i:=1 to n do
For j:=1 to n do Read(f1,c[i,j]);
8 h 54 m 28/7/2017
162
Thầy Trần Thông Quế
Close(f1);
For i:=1 to n do b[i]:=True; d:=0;
Test(1);
Close(f2);
Writeln('DONE!');
Writeln('Go Enter de quay ve chuong trinh!');
Writeln('De xem ket qua, go phim F3, go CtHamil.Out, roi ENTER.');
Readln;
End.
10/ CHU TRÌNH HAMILTON TRÊN ĐỒ THỊ CÓ TRỌNG SỐ: Bài toán KINH ĐIỂN nổi tiếng:
TRAVELLING SALESMAN PROBLEM. Không hề ảnh hưởng đến nội dung và cách giải bài toán, ta gọi
bài toán này là bài toán NGƯỜI DU LỊCH.
Một nước có N địa điểm du lịch được đánh số từ 1 đến N. Giữa hai địa điểm bất kỳ có thể có đường đi hoặc
không. Giữa hai địa diểm i, j có đường đi thì giá đi (bằng ô tô chẳng hạn) du lịch giữa chúng là những số
nguyên C(i,j)>0. Nói chung C(i, j) khác C(j, i). Khách du lịch xuất phát từ địa điểm k ,muốn tham quan tất
cả các địa điểm, mỗi địa điểm đúng 1 lần, rồi quay về k (k
6
0 3 0 4 0 0
3 0 4 0 2 0
0 4 0 0 1 1
4 0 0 0 1 5
0 2 1 1 0 5
0 0 1 5 5 0
1 6
CODE:
Program Nguoi_Dulich; { chu trinh Hamilton tren do thi co trong so}
Uses crt;
Const sd=10;
fi='HMT.VAO'; fo='HMT.RA';
Type m1=Array[1..sd,1..sd] of Integer;
m2=Array[1..sd] of Integer;
m3=Array[1..sd] of Boolean;
Var c:m1;
a,x:m2;
d:m3;
n,cmin,sum,maxsum,dem:Integer;
Procedure Nhap;
Var f:text; x,i,j:Integer;
Begin
Assign(f,fi); Reset(f);
Readln(f,n);
cmin:=maxint;
For i:=1 to n do
8 h 54 m 28/7/2017
163
Thầy Trần Thông Quế
Begin
For j:=1 to n do
Begin
Read(f,c[i,j]);
If c[i,j]>0 then
If (c[i,j]j) Then
cmin:=c[i,j];
End;
Readln(f);
End;
Close(f);
End;
Procedure Tim_Chiphi_Min;
Begin
If sum+c[a[n],a[1]]n Then
Begin
If c[a[n],a[1]]>0 Then Tim_Chiphi_Min;
End
Else
For j:=1 to n Do
If d[j] Then
If c[a[i-1],j]>0 then
Begin
a[i]:=j;
d[j]:=False;
sum:=sum+c[a[i-1],j];
If sum+(n-i+1)*cmin0 then
8 h 54 m 28/7/2017
164
Thầy Trần Thông Quế
Begin
Writeln(g,'Tong chi phi cua hanh trinh DU LICH=',maxsum);
Write(g,'Tour du lich KHEP KIN co chi phi min ma khach da di la:');
For i:=1 to n do Write(g,x[i],' ');
Writeln(g,x[1]);
End
Else
Writeln(g,0);
End;
Procedure Init; {Khoi tri cho cac bien}
Var i,j:integer;
Begin
For i:=1 to n do d[i]:=True;
maxsum:=maxint;
sum:=0;
a[1]:=1;
d[1]:=false;
dem:=0;
End;
Begin clrscr;
Nhap;
Init;
Assign(g,fo); Rewrite(g);
Try(2);
Xuat; Writeln;
Writeln(#32:7,'XONG! GO ENTER->GO PHIM F3->GO HMT.RA->ENTER: DE XEM KET QUA.');
Readln;
Close(g);
End.
= = = = = = = = = = = = = = = =
VIII-3/ CÁC THUẬT TOÁN TÌM ĐƯỜNG ĐI
NGẮN NHẤT TRÊN ĐỒ THỊ.
VIII-3.1) THUẬT TOÁN DIJKSTRA: Tìm đường ngắn nhất từ một điểm đến các điểm
còn lại trên đồ thị.
1- Một đồ thị vô hướng CÓ TRỌNG SỐ được biểu diễn bởi danh sách liệt kê cạnh dưới
đây (Lưu trên text file DATA.VAO có cấu trúc dưới đây). Lập trình tìm và hiển thị
đường ngắn nhất từ đỉnh cho trước bất kỳ đến đỉnh đích tùy chọn trên đồ thị ấy.
5 9 5 đỉnh, 9 cung: bắt buộc phải ghi ở đây
1 2 1
8 h 54 m 28/7/2017
165
Thầy Trần Thông Quế
1 5 9
2 3 2
2 4 5
3 4 1
3 5 2
4 3 7
5 2 8
5 4 10
CODE:
{Chuong trinh nay Test tren tep DATA.VAO}
Program Min_Path;
Uses crt;
Const max=50;
Type contro=^ct;
ct=record
bd:byte; {Dinh bat dau}
lk:contro;
End;
Var n,m,xp,dich:integer;
tt:boolean;
v,dau,cuoi,len:Array[1..max] of integer;
FileName:String;
Procedure Data_Inp(Filename:String);
Var i:byte; f:Text;
Begin
Assign(f,FileName); Reset(f);
Readln(f,n,m);
For i:=1 to m do Readln(f,dau[i],cuoi[i],len[i]);
Close(f);
Writeln('Do thi dang xet co ',n,' dinh va ',m,' cung');
For i:=1 to m do
Writeln('Canh ',dau[i],'-->',cuoi[i],' co trong so=',len[i]);
End;
Function MemCheck(x:byte):contro;
Var p:contro;
Begin
New(p);
If p=Nil Then
8 h 54 m 28/7/2017
166
Thầy Trần Thông Quế
Begin
Writeln('Thieu bo nho!'); Halt;
Readln;
End;
p^.bd:=x;
MemCheck:=p;
End;
Procedure PathMin_Find;
Var ds,p:contro; i,d,x:byte;
Begin
x:=dich; ds:=Nil; d:=v[x];
While (x<>xp) Do
For i:=1 to m do
If cuoi[i]=x Then
If (v[dau[i]]<>-1) and (v[dau[i]]+len[i]=v[x]) Then
Begin
v[x]:=-1;
x:=dau[i];
p:=MemCheck(x);
p^.lk:=ds; ds:=p;
Break;
End;
p:=ds;
While p<>Nil Do
Begin
Write(p^.bd,'-->'); p:=p^.Lk;
End;
Writeln(dich,' voi do dai min=',d);
End;
Procedure Init;
Var i:Byte;
Begin
For i:=1 to n do v[i]:=-1;
End;
Procedure LastProces;
Var tt:boolean; j,x,y:byte;
Begin
tt:=True;
While tt Do
8 h 54 m 28/7/2017
167
Thầy Trần Thông Quế
Begin
tt:=False;
For j:=1 to m do
Begin
x:=dau[j]; y:=cuoi[j];
If v[x]<>-1 Then
Begin
If (v[y]=-1) Or (v[x]+len[j]
8 h 54 m 28/7/2017
168
Thầy Trần Thông Quế
VIII-3.2) THUẬT TOÁN FORD-BELLMAN: Tìm đường ngắn nhất giữa mọi CẶP
đỉnh tùy ý trên đồ thị KHÔNG CÓ CHU TRÌNH ÂM.
2-CÀI ĐẶT FORD-BELLMAN ALGORITHM
(Tổ chức dư liệu VÀO: Bạn hãy tự vẽ bịa ra một đồ thị có trọng số, rồi bạn lập MA
TRẬN KỀ CHO nó. Code của bạn sẽ Test trên ma trận đó. Khi tạo đồ thị nhớ kiểm tra
bảo đảm nó không có chu trình ÂM)
CODE:
Program Ford_Bell_Algo;
Uses Crt;
Const fi='sl.vao'; fo='sl.ra'; max=100;
vocuc=100*50*maxint; {=163835000}
Type m1=array[1..max,1..max] of longint;
m2=array[1..max] of longint;
m3=array[1..max] of byte;
Var a:m1;v:m2; t:m3;
m:integer; n,x,y:byte;
Procedure Input;
Var f:Text; k,w:integer;
i,j:byte;
Begin
assign(f,fi); reset(f);
Fillchar(a,sizeof(a),0); Readln(f,n,m,x,y);
For k:=1 to m do
Begin
Readln(f,i,j,w);
a[i,j]:=w; a[j,i]:=w;
End;
close(f);
End;
Procedure init;
var i,j:byte;
Begin
For i:=1 to n do
For j:=1 to n do
If a[i,j]=0 then a[i,j]:=vocuc;
For i:=1 to n do v[i]:=a[x,i]; v[x]:=0;
FillChar(t,sizeof(t),0);
End;
8 h 54 m 28/7/2017
169
Thầy Trần Thông Quế
Procedure Ford_Bellman;
Var i,j,k:byte; stop:boolean;
Begin
for k:=1 to n-1 do
Begin
stop:=true;
For i:=1 to n do
For j:=1 to n do
If j<>x then
If v[j]>v[i]+a[i,j] then
Begin
v[j]:=v[i]+a[i,j];
t[j]:=i;
stop:=false;
End;
If stop then break;
End;
End;
Procedure Xuat;
var f:text; kq:m3; i,j:byte;
Begin
Assign(f,fo); Rewrite(f);
If v[y]=vocuc then
Begin
Writeln(f,-1);
close(f);
halt;
End;
Writeln(f,v[y]);
i:=y;
j:=0;
Repeat
Inc(j);
kq[j]:=i;
i:=t[i];
Until i=0;
Assign(f,fo); Reset(f);
While Not SeekEof(f) Do
For i:=j Downto 1 do Writeln(f,kq[i]);
close(f);
End;
8 h 54 m 28/7/2017
170
Thầy Trần Thông Quế
Begin clrscr;
input;
init;
Ford_Bellman;
xuat;
Write('DONE!');
readln
End.
VIII.-3.3) THUẬT TOÁN FLOYD-WARSHALL: Tìm đường ngắn nhất giữa mọi
cặp đỉnh thông qua các đỉnh TRUNG GIAN trên đồ thị có trọng số.
3-ĐỒ HỌA HÓA code cho thuật toán trên. Yêu cầu:
a) Gõ ENTER để thay đổi cấu trúc đồ thị,
b) Gõ SPCE: tìm tiếp,
c) Gõ ESC: Thoát.
CODE:
Program Floyd_Warshall_Alg;
uses crt,graph;
const r=15;dl=500;n=5;vc=200;vocuc=10000;
c:array[1..5]of integer =(240,460,350,130,20);
d:array[1..5] of integer=(20,240,460,460,240);
ec:array[1..10] of integer =(350,276,204,130,405,295,240,240,185,75);
ed:array[1..10] of integer=(130,166,166,130,360,360,240,460,360,360);
var g,p,a:array[1..n,1..n] of integer;
dau,cuoi:integer;
Procedure initgr;
var gd,gm:integer;
begin
gd:=detect;
initgraph(gd,gm,'..\bgi');
if (graphresult<>grok) then
begin
writeln('Loi khoi tao do hoa,go enter ket thuc!');
readln;
halt(1);
end
end;
8 h 54 m 28/7/2017
171
Thầy Trần Thông Quế
Procedure venut(u,m1,m2:integer);
var st:string[3];
begin
setfillstyle(1,m2);
setcolor(m1);
fillellipse(c[u],d[u],r,r);
str(u,st);
outtextxy(c[u]-2,d[u]-2,st);
end;
Procedure link(x,y,m1,m2:integer);
var t:integer;st:string[3];
begin
setcolor(m2);
line(c[x],d[x],c[y],d[y]);
t:=y-x +((x-1)*(2*n-x)) div 2;
str(g[x,y],st);
setcolor(m1);
outtextxy(ec[t],ed[t],st);
end;
Procedure init_graph;
var i,j:integer;
begin
randomize;
for i:=1 to n do
begin
g[i,i]:=0;
for j:= i+1 to n do
begin
if random(2) = 1 then g[i,j]:=10 +random(vc-10)
else g[i,j]:=vocuc;
g[j,i]:=g[i,j];
end;
end;
for i:= 1 to n do
begin
j:=0;
repeat
j:=j+1;
until((g[i,j]>0) and (g[i,j]
172
Thầy Trần Thông Quế
begin
j:=1+random(n);
if j=i then if i
173
Thầy Trần Thông Quế
bar(0,0,getmaxy,getmaxy);
for i:= 1 to n do
begin
for j:= 1 to n do
if (g[i,j]>0) and(g[i,j]
174
Thầy Trần Thông Quế
end;
end;
Procedure Thbao_kq;
var st:string[20];
Begin
if a[dau,cuoi]=vocuc then st:='Khong co duong di!'
else
begin
str(a[dau,cuoi],st);
st:='Duong di min='+st;
Timdequy(dau,cuoi);
end;
setcolor(red);
outtextxy(490,210,st);
End;
Procedure Thutuc_goi_thutuc;
Var k:char;
Begin
if keypressed then
repeat
k:=readkey
until not keypressed;
repeat
init_graph;
floyd;
repeat
print_graph;
demo;
Thbao_kq;
k:=readkey;
until (k=#27) or (k=#13);
until(k=#27);
End;
Begin clrscr;
initgr;
Thutuc_goi_thutuc;
closegraph;
End.
8 h 54 m 28/7/2017
175
Thầy Trần Thông Quế
BỐN BÀI TỰ LUYỆN (TL) CHO CÁC BẠN ÁP DỤNG ALGORITHMS TRÊN
ĐÂY:
TL1/ Trong một mạng lưới giao thông có n thành phố và m hành trình tàu đi trong n
thành phố đó. Thời gian đi từ thành phố i đến thành phố j là t ij. Mỗi hành trình i
xuất phát tại thành phố si1 vào thời điểm ti, đi qua một dãy các thành phố si2, si3,...,
sik. Tại mỗi thành phố tàu sẽ dừng lại để hành khách lên hoặc xuống tàu. Một người
xuất phát ở thành phố s tại thời điểm t muốn đi tới thành phố d.
a) Hãy tìm lộ trình sao cho người đó đến d sớm nhất.
b) Hãy tìm lộ trình với số lần chuyển tàu ít nhất.
Dữ liệu vào lưu trên text file với tên TauHoa.Vao gồm các đại lượng n, m, s, t, d, số
hành trình và ma trận tij. Dữ liệu ra lưu trên text file với tên TauHoa.Ra gồm thời gian
đến d sớm nhất và số lần chuyển tàu ít nhất.
TL2/ Một toà nhà cao tầng có n thang máy. Mỗi thang máy nối liền đúng 2 tầng với nhau
và không dừng lại ở những tầng nằm giữa 2 tầng này. Vận tốc của các thang máy là
như nhau: 5 giây qua một tầng.
Thời điểm bắt đầu, mỗi thang máy đều ở tầng thấp và chúng cùng bắt đầu di
chuyển lên tầng trên. Sau khi tới tầng trên, ngay lập tức lại chuyển xuống tầng dưới,
rồi lại lên tầng trên, và cứ lặp lại như thế ...
An đang ở tầng 1 (tầng thấp nhất) và muốn nhanh chóng lên tầng trên cùng của toà
nhà. Anh ta thay đổi thang máy chỉ trên những tầng chung của 2 thang máy và nếu thang
máy kia tại thời điểm này cũng tới tầng này thì việc chuyển thang máy khi đó coi như
không tốn thời gian. Hãy lập trình tính thời gian ít nhất để An có thể lên tới tầng trên
cùng của toà nhà.
Dữ liệu vào cất trên text file với tên Lift.In gồm:
Dòng đầu tiên chứa 2 số nguyên dương K, N cách nhau ít nhất một dấu cách, là
số tầng và số thang máy của toà nhà (2 K 1000; 1 N 50000).
Trên mỗi một N dòng tiếp theo ghi 2 số nguyên dương A, B (cách nhau một
dấu cách) mô tả một thang máy di chuyển giữa 2 tầng A, B (1 A < B K).
Chú ý:
— Không có 2 thang máy nào khác nhau mà lại cùng di chuyển giữa 2 tầng như
nhau.
— Dữ liệu vào đảm bảo luôn luôn tồn tại nghiệm.
Kết quả ghi lên text file với tên Lift.Ou gồm: chỉ một dòng ghi thời gian ít nhất
mà An có thể di chuyển lên tầng trên cùng của toà nhà. Ví dụ: Xem 2 bộ dữ liệu
dưới đây:
8 h 54 m 28/7/2017
176
Thầy Trần Thông Quế
Lift1.In
10 4
1 5
5 10
5 7
7 10
45
Lift1.Ou
Lift2.In Lift2.Ou
20 5 150
1 7
7 20
4 7
4 10
10 20
TL3/ Cho số nguyên k (0 < k 255) và n xâu ký tự có cùng độ dài L chỉ gồm các chữ
cái thường (0 < n 100) và (0 < L 255) là S1, S2,..., Sn. đôi một khác nhau. Hãy
tìm xâu Smin nhỏ nhất thoả mãn tính chất sau: tồn tại k vị trí khác nhau trong xâu
Smin là các vị trí xuất hiện của một trong các xâu S 1, S2,..., Sn. Ta gọi p là vị trí xuất
hiện của xâu S trong Smin nếu giá trị của hàm Copy(Smin, p, L) = S.
Dữ liệu vào cất trên text file với tên Str.In gồm :
Dòng đầu ghi n, L, k :
n dòng tiếp theo, dòng thứ i ghi xâu Si:
Kết quả ghi lên text file với tên
Str.Ou gồm :
Dòng đầu tiên ghi độ dài nhỏ nhất:
Dòng thứ 2 ghi xâu Smin thoả điều
kiện đầu bài (xem 2 file bên).
k dòng tiếp theo, mỗi dòng ghi 2 số u, p cho biết sự xuất hiện của xâu S u tại p
trong xâu Smin. Một ví dụ cụ thể cho dưới đây:
Str.In Str.Ou
2 10 2 17
aaaaaaaxyz aaaaaaaxyzabcdefg
xyzabcdefg 1 1
2 8
8 h 54 m 28/7/2017
177
Thầy Trần Thông Quế
TL4/ Một bãi tập kết rác hình chữ nhật được kẻ ô vuông. Các túi rác
có khối lượng là một số nguyên (hay số thực thì cũng chẳng ảnh hưởng gì đến cách giải
bài toán!) đặt tại mỗi ô vuông. Một robot đi từ ô góc trên cùng trái đến góc duới cùng
phải của bãi rác để gom rác theo luật sau: robot chỉ đi xuống hoặc sang phải theo các
cạnh của ô vuông. Viết code tìm một chiến thuật để robot gom được khối luợng rác lớn
nhất.
VIII-4. CÂY KHUNG (SPANNING TREE) & BÀI TOÁN TÌM CÂY
KHUNG NGẮN NHẤT (SPANNING TREE MIN) TRÊN ĐỒ THỊ.
Ôn một chút lý thuyết:
A) CÂY KHUNG LÀ GÌ? Cho đồ thị vô hướng, liên thông G = {V, E} có N ĐỈNH
(N > 1). Mọi đồ thị con H = {W, F} có N 1 cạnh ( W V, F E) gọi là CÂY
KHUNG của đồ thị G.
B) CÂY KHUNG MIN LÀ GÌ? Cho đồ thị vô hướng có TRỌNG SỐ không âm, liên
thông G = {V, E} có N đỉnh (N > 1), cây khung NGẮN NHẤT (CKMIN) của đồ thị G
là cây khung có tổng trọng số trên tất cả các cạnh của nó là nhỏ nhất.
C) BÀI TOÁN TÌM CKMIN: Cho đồ thị G vô hướng, liên thông và có trọng số không
âm. Hãy tìm cây khung ngắn nhất của G.
Đến nay có 2 thuật toán giải bài này: thuật toán KRUSCAL & thuật toán PRIM.
5- CÀI ĐẶT THUẬT TOÁN KRUSCAL
a) Tổ chức Data: Cấu trúc của đồ thị cho trước được biểu diễn bởi danh sách liệt kê
cạnh dưới đây (các số cách nhau một ký tự trống):
9 14 9: số đỉnh; 14: số cạnh
1 2 4
1 8 8
2 3 6
2 8 11
3 4 7
3 6 4
3 9 2
4 5 9
4 6 14
8 h 54 m 28/7/2017
178
Thầy Trần Thông Quế
5 6 10
6 7 2
7 8 1
7 9 6
8 9 7
b) CODE:
Program Krusal_Alg;
Uses crt;
Const fi='KRUSCAL.IN'; fo='KRUSCAL.OU'; ln=50;
Type bg=Record
x,y:byte; {x-ding dau, y-dinh cuoi cua canh}
c:integer; {c la trong so tren cac canh cua do thi}
End;
Var m,t:longint; n,count:Integer; {t- de luu tong trong so cua CKmin}
g:text; {count-dem so canh cua CKmin}
a:Array[1..ln*ln DIV 2] of bg;
b:Array[1..ln] of integer;
line:string[4];
Procedure doc; {ct con nhap du lieu vao ct}
Var f:text; i:Integer;
Begin
Assign(f,fi); Reset(f);
Readln(f,n,m);
For i:=1 to m Do
Readln(f,a[i].x,a[i].y,a[i].c);
close(f);
End;
Procedure Saptang;
Var i,j:integer; c:bg;
Begin
For i:=1 to m-1 do
For j:=i+1 to m do
If a[i].c>a[j].c then {dung c lam bien trung gian luon}
Begin c:=a[j];a[j]:=a[i]; a[i]:=c; End;
End;
Function Root(x:integer):Integer; {xac dinh dinh goc la dinh x cho cay}
8 h 54 m 28/7/2017
179
Thầy Trần Thông Quế
Var i:integer;
Begin
i:=x;
While b[i]>0 Do i:=b[i];
Root:=i;
End;
Procedure Hopnhat(x,y:integer); {Hop nhat cac dinh o 2 mien biet lap}
Var tg:integer;
Begin
tg:=b[x]+b[y];
If b[x]>b[y] Then
Begin
b[x]:=y;
b[y]:=tg;
End
Else
Begin
b[y]:=x;
b[x]:=tg;
End;
End;
Procedure Ck_crea; {kien tao dan dan cay khung min}
Var f:Text; i:longint; x,y,t1,t2:Integer;
Begin
t:=0; count:=0;
Doc;
Saptang;
For i:=1 to n Do b[i]:=-1;
For i:=1 to m Do
Begin
If count=n-1 Then Exit;
x:=a[i].x;
y:=a[i].y;
t1:=Root(x);
t2:=Root(y);
If t1<>t2 Then
Begin
Hopnhat(t1,t2);
Writeln(g,x,' ',y);
8 h 54 m 28/7/2017
180
Thầy Trần Thông Quế
Inc(count);
t:=t+a[i].c;
End;
End;
End;
Begin clrscr;
Assign(g,fo); Rewrite(g);
Ck_crea; Writeln;
Writeln('Tap hop cac canh cua Cay_khung_min dang xet:');
{Write(g,t);}
Close(g);
Reset(g);
While Not SeekEof(g) Do
Begin
Readln(g,line);
Writeln(line);
End;
Writeln;
Writeln('Va tong trong so cua cay_khung_min nay=',t);
Readln
End.
6) CÀI ĐẶT THUẬT TOÁN PRIM
a-Tổ chức dữ liệu:
Cấu trúc của đồ thị cho trước được biểu diễn bởi danh sách liệt kê cạnh dưới đây:
và lưu tren text file PRIM.IN (các số trên mỗi dòng cách nhau một ký tự trống):
9 14 9: số đỉnh; 14: số cạnh
1 2 4
1 8 8
2 3 6
2 8 11
3 4 7
3 6 4
3 9 2
4 5 9
4 6 14
5 6 10
6 7 2
7 8 1
8 h 54 m 28/7/2017
181
Thầy Trần Thông Quế
7 9 6
8 9 7
b- CODE:
Program Prim_Algol;
Uses crt;
Const Ln=50; fi='PRIM.IN'; {fi=Tep luu data vao}
fo='Ra.kq'; { Tep ghi ket qua cua chuong trinh}
Type m1=Array[1..Ln,1..Ln] of integer;
m2=Array[1..Ln] of integer;
Var a:m1; {mang ghi nho trong so cua do thi}
d:m2; {mang ghi nho dinh da nap vao cay khung nho nhat}
d1,d2:m2; {mang ghi nho cac canh cua cay khung nho nhat}
n,tong:Integer;
Procedure Doc;
Var f:text; i,j,x:Integer;
Begin
Assign(f,fi); Reset(f); Readln(f,n);
While Not SeekEof(f) Do
Begin
Readln(f,i,j,x);
a[i,j]:=x;
a[j,i]:=x;
End;
Close(f);
End;
Procedure Timcanhmin(Var i,j:Integer);
Var x,y,wmin:Integer; {wmin: trong so nho nhat}
Begin
wmin:=Maxint;
For x:=1 to n Do
If d[x]=1 Then
For y:=1 to n Do
If d[y]=0 then
If (a[x,y]>0) and (a[x,y]
8 h 54 m 28/7/2017
182
Thầy Trần Thông Quế
End;
End;
Procedure TtPrim;
Var i,j,k:Integer;
Begin
For i:=1 to n Do d[i]:=0;
d[1]:=1;
For k:=1 to n-1 do
Begin
Timcanhmin(i,j);
d[j]:=1; {danh dau dinh j da duoc nap vao cay khung}
d1[k]:=i; {luu dinh dau cua canh da nap vao cay khung}
d2[k]:=j; {luu dinh cuoi cua canh da nap vao cay khung}
End;
End;
Procedure ghi;
Var f:Text; i:integer;
Begin
Assign(f,fo); Rewrite(f);
tong:=0;
For i:=1 to n-1 do
Begin
Writeln(f,d1[i],' ',d2[i]);
tong:=tong+a[d1[i],d2[i]];
End;
Writeln(f,'Tg trg_so=',tong);
Close(f);
End;
Procedure Xem_kq;
Var f:Text; line:string[12];
Begin
Writeln(#32:20,'KET QUA CHAY CHUONG TRINH:');
Writeln('Tap cac canh cua Ck_min va tong trong so cua no (dong cuoi):');
Writeln;
Assign(f,'Ra.kq'); Reset(f);
While Not SeekEof(f) Do
Begin
Readln(f,line);
Writeln(#32:7,line);
8 h 54 m 28/7/2017
183
Thầy Trần Thông Quế
End;
close(f);
End;
Begin clrscr;
Doc;
TtPrim;
Ghi;
Xem_kq;
Readln;
End.
BÀI TỰ LUYỆN CHO CÁC BẠN (Thực chất là tìm CKMIN)
TL1/ Một thành phố cần trải nhựa mạng giao thông có N nút giao thông cho bởi đồ thị bạn tự vẽ
(dễ thôi). Trọng số của các cạnh đồ thị này biểu diễn độ dài các con đường. Cần
phải trải nhựa những con đường nào để vẫn có đường đi được trải nhựa giữa hai
nút giao thông bất kỳ mà ĐỘ DÀI ĐƯỢC TRẢI NHỰA LÀ NGẮN NHẤT.
TL2/ Giả sử mạng truyền dữ liệu giữa các trung tâm máy tính ở một số tỉnh miền Bắc cho bởi
đồ thị bạn tự vẽ. Trọng số ghi trên các cạnh của đồ thị này biểu thị CHI PHÍ xây dựng
đường truyền dữ liệu. Viết code để sao cho chi phí thiết đặt mạng truyền dữ liệu là ÍT
NHẤT mà vẫn đảm bảo truyền dữ liệu được giữa 2 trung tâm BẤT KỲ thuộc mạng. (Đơn
vị tiền chi phí: Triệu).
TL3/ Có n phòng làm việc của một công ty được nối tiếp với nhau bằng hệ thống dây điện.
Sơ đồ nối dây của mạng điện này biểu diễn bởi ma trận A[i, j], trong đó A[i, j] là độ
dài dây điện nối giữa phòng i với phòng j.
Nếu không có dây điện nối giữa phòng i với phòng j thì A[i, j] = 0. Hiện tại n
phòng này đều có đường dây điện nối tới nhưng quá thừa nên lãng phí. Hãy tìm
tổng độ dài ngắn nhất của hệ thống dây điện cần sửa lại cách nối điện sao cho n
phòng của công ty đều có điện.
Dữ liệu vào cất trên text file với tên E_line.In. Dòng đầu tiên là số phòng n; n
dòng kế tiếp mô tả ma trận A[i, j], mỗi dòng n số cách nhau ít nhất một ký tự trống.
Kết quả cất trên text file với tên E_line.Ou mà dòng đầu là tổng độ dài dây điện
dùng cho công ty; các dòng sau mỗi dòng ghi 2 số u i và vj biểu thị có đường dây
nối phòng ui với phòng vi (i = 1, 2, 3, ...)
Một trường hợp cụ thể của bài toán này với file vào và xuất dữ liệu cho dưới
đây:
4 5
E_line.In E_line.Ou
8 h 54 m 28/7/2017
3 4
1 4
2 4
184
Thầy Trần Thông Quế
0 3 4 2
3 0 3 2
4 3 0 1
2 2 1 0
= = = = = = = = = = = = = = = = = =
PHẦN IX. ĐỒ THỊ HAI PHÍA
(ÁP DỤNG GIẢI VÀI BÀI TOÁN TÌM CẶP GHÉP CỰC ĐẠI VÀ LẬP LỊCH TỐI ƯU)
A-ÔN MỘT VÀI KHÁI NIỆM CƠ BẢN ĐỂ LÀM TOÁN
1/ Thế nào là đồ thị hai phía?
Cho tập đỉnh V1 và tập đỉnh V2 thỏa mãn:
V1 Giao V2 = Rỗng (a)
V1 Hợp V2 = V (b)
và tập cạnh E gồm các cạnh e = (v1, v2) mà
v1 Thuộc V1, v2 Thuộc V2 (c)
Tập G = {V,E} với V, E thỏa các điều kiện a, b, c ở trên gọi là đồ thị HAI PHÍA (đồ thị hai phía cũng được
ký hiệu là G{V1, V2, E}).
2/ Hai dạng bài toán về cặp ghép trên đồ thị hai phía:
2.1) Trước hết cần định nghĩa khái niệm cặp ghép:
Ta gọi tập PAI gồm các cạnh thuộc E và không có đỉnh nào chung là cặp ghép. Số cạnh của PAI là lực
lượng của cặp ghép và ký hiệu PAI.
2.2) Tiếp theo là định nghĩa khái niệm cặp ghép đầy đủ:
Nếu tập V1 và V2 đều có N đỉnh và PAI = N thì PAI gọi là cặp ghép ĐẦY ĐỦ. Hai dạng bài toán về cặp
ghép:
2.3) Dạng 1
Đây là bài toán tìm tập PAI có lực lượng |PAI| cực đại. Bài toán tìm cặp ghép đầy đủ là trường hợp riêng
của bài toán này.
2.4) Dạng 2 (CẶP GHÉP CỰC ĐẠI)
Tìm cặp ghép có TỔNG TRỌNG SỐ LỚN NHẤT (GỌI TẮT LÀ CẶP GHÉP CỰC ĐẠI, viêt tắt: Cặp ghép
Max) trên các cạnh thuộc tập PAI. Một số các bài toán XẾP LỊCH thuộc dạng này.
Để giải hai dạng bài toán trên ta có các thuật toán cơ bản sau:
a-Thuật toán cơ bản dựa vào đồ thị hai phía, dây chuyền (luồng) và sửa nhãn để tìm cặp ghép Max,
b-Đệ quy – Quay lui,
c-Quy hoạch động,
d-Sắp xếp Topo,
e-Thuật toán Jonson,
f-Thuật toán Heristic,
g-Thuật toán Hunggari,
g-Thuật toán làm Mịn dần kết quả.
8 h 54 m 28/7/2017
185
Thầy Trần Thông Quế
DƯỚI ĐÂY CHỈ CÓ ĐIỀU KIỆN NÊU VÀI BÀI TOÁN ÁP DỤNG MỘT
SỐ TRONG CÁC THUẬT TOÁN TRÊN. (Các bạn có thể tham khảo chi tiết ở
quyển LÝ THUYẾT ĐỒ THỊ, NXB Giáo Dục, 2012, Tác giả: Trần Thông Quế).
B-LẬP TRÌNH GIẢI CÁC BÀI TOÁN CẶP GHÉP SAU:
1/ Bài toán 1.
Một lớp học sinh gồm N người (đánh số thứ tự từ 1 đến N và N 1000) đi cắm trại tham gia trò chơi như
sau: mỗi em nam ghép cặp với một em nữ (và ngược lại mỗi em nữ ghép cặp với một em nam). Người ta
dùng một tham số nguyên dương w để đánh giá độ ăn ý của các cặp ghép đó. Yêu cầu tìm những cặp ghép
cho tổng độ ăn ý lớn nhất.
Dữ liệu vào cất trên text file với tên Ghepcap.In gồm:
* Dòng 1 là số N.
* Các dòng tiếp theo mỗi dòng gồm 3 số x, y, w với ý nghĩa : x là số hiệu của nam sinh, y số hiệu của nữ
sinh, w là độ ăn ý của 2 bạn đã ghép cặp với nhau.
Kết quả ghi lên text file với tên Ghepcap.Ou gồm:
* Dòng đầu chứa một số nguyên dương là tổng độ ăn ý lớn nhất của các cặp ghép.
* Các dòng tiếp theo mỗi dòng ghi 3 số x, y, w.
Một ví dụ cụ thể là:
Ghepcap.In
4
1 2 2
1 3 1
4 2 3
4 3 1
Ghepcap.Ou
4
1 3 1
4 2 3
1) CODE1. (Phuong an 1: Dung de quy quay lui de tim cap ghep CUC DAI)
Program GhepNamNu;
Uses crt;
Const fi='Ghepcap.In';
fo='Ghepcap.Ou';
min=-10000;
Var f:text; n:integer;
Test,Free: array[1..100] of boolean;
A: array[1..100,1..100] of integer;
Trace,besttr: array[1..100] of integer;
nho:integer;
Procedure Nhap;
Var i,j1,j2,j3:integer;
Begin
assign(f,fi); reset(f); readln(f,n);
for i:=1 to n do for j1:=1 to n do a[i,j1]:=min;
for i:=1 to n do begin test[i]:=true; free[i]:=true; end;
for i:=1 to n do
Begin
readln(f,j1,j2,j3);
8 h 54 m 28/7/2017
186
Thầy Trần Thông Quế
A[j1,j2]:=j3;
A[j2,j1]:=j3;
test[j2]:=false;
End;
close(f);
nho:=0;
End;
Procedure Tichluy;
Var tong, i:integer;
Begin
tong:=0;
for i:=1 to n do if test[i] then tong:=tong+a[i,trace[i]];
if tong>nho then
Begin
nho:=tong;
besttr:=trace;
End;
End;
Procedure Try(i:integer); {de quy quay lui}
Var j, k:integer; ok:boolean;
Begin
if not free[i] then try(i+1) else
for j:=1 to n do if i<>j then if free[j] then
Begin
free[j]:=false;
free[i]:=false;
trace[i]:=j;
trace[j]:=i;
ok:=true;
for k:=1 to n do if free[k] then ok:=false;
if ok then Tichluy else try(i+1);
free[j]:=true;
free[i]:=true;
End
End;
Procedure Xuat;
Var i:integer;
Begin
Assign(f,fo); Rewrite(f);
writeln(f,nho);
for i:=1 to n do if test[i] then
writeln(f,i,' ',besttr[i],' ',a[i,besttr[i]]);
close(f);
End;
Procedure Xem;
Var f:text; line:string;
Begin
Assign(f,fo); Reset(f);
8 h 54 m 28/7/2017
187
Thầy Trần Thông Quế
Writeln(#32:12,'KET QUA PROGRAM:');
Writeln;
While not (seekeof(f)) do
Begin
Readln(f,line);
Writeln(#32:7,line);
End;
Close(f);
End;
{Main Prog.}
Begin clrscr;
Nhap;
Try(1);
Xuat;
Xem;
Write('Done!');
Readln;
End.
2) CODE2 (DÙNG THUẬT TOÁN KRUSCAL ĐỂ TÌM CẶP GHÉP MAX )
Program Ghepcap;
Uses Crt;
Const Const fi='Ghepcap.In';
fo='Ghepcap.Ou';
max=10000;
Var Tree:array[1..100] of integer;
canh:array[1..100,1..2] of integer;
a:array[1..100,1..100] of integer;
f:text;
N:integer;
trongso:integer;
test: array[1..100] of boolean;
Procedure Nhap;
Var i,j,u,v:integer;
Begin
assign(f,fi);
reset(f);
read(f,n);
readln(f);
for i:=1 to n do test[i]:=true;
for i:=1 to n do
for j:=1 to n do a[i,j]:=0;
for i:=1 to n do
begin
readln(f,u,v,a[u,v]);
test[v]:=false;
a[v,u]:=a[u,v];
end;
close(f);
8 h 54 m 28/7/2017
188
Thầy Trần Thông Quế
for i:=1 to n do tree[i]:=i;
for i:=1 to n do
for j:=1 to n do
if a[i,j]=0 then
if (test[i] and test[j]) then
a[i,j]:=max
else if (not test[i] and not test[j]) then
a[i,j]:=-10000;
trongso:=0;
end;
Procedure Timmax(var u,v:integer);
Var temp:integer;
i,j:integer;
max:integer;
Begin
max:=-maxint;
for i:=1 to n-1 do
for j:=i+1 to n do
if tree[i]<>tree[j] then
if max
Procedure Ghepcap(ok,u,v:integer);
var i,tam:integer;
Begin
if a[u,v]<>max then
trongso:=trongso+a[u,v];
canh[ok,1]:=u;
canh[ok,2]:=v;
tam:=tree[v];
for i:=1 to n do
if tree[i]=tam then tree[i]:=tree[u];
end;
Procedure Creat;
Var ok,u,v:integer;
Begin
for ok:=1 to n-1 do
begin
Timmax(u,v);
Ghepcap(ok,u,v);
end;
end;
Procedure Print;
Var i:integer;
8 h 54 m 28/7/2017
189
Thầy Trần Thông Quế
Begin
Assign(f,fo);
rewrite(f);
writeln(f,trongso);
for i:=1 to n-1 do
if a[canh[i,1],canh[i,2]]<>max then
writeln(f,canh[i,1]:2,canh[i,2]:2,a[canh[i,1],canh[i,2]]:2);
close(f);
end;
{Main Prog.}
Begin clrscr;
Nhap;
Creat;
PRINT;
Write('Done!');
ENd.
2/ Bài toán 2
Có n lọ hoa và k bó hoa được đánh số thứ tự từ nhỏ tới lớn. Cần cắm k bó hoa vào n lọ sao cho hoa có số
thứ tự nhỏ phải đứng trước hoa có số thứ tự lớn. Giá trị thẩm mỹ khi cắm bó hoa i vào lọ j là v(i, j). Hãy tìm
một cách cắm hoa sao cho tổng giá trị thẩm mỹ là lớn nhất. Biết rằng mỗi bó hoa chỉ được cắm vào một lọ
và mỗi lọ chỉ cắm một bó hoa.
Dữ liệu vào cất trên text file với tên Camhoa.In gồm :
*Dòng 1: ghi 2 số n và k.
* k dòng tiếp theo mỗi dòng ghi n số nguyên dương với số ở hàng i cột j biểu thị giá trị thẩm mỹ bó hoa i
cắm vào lọ j.
Kết quả ghi lên text file với tên Camhoa.Ou gồm :
*Dòng đầu: In tổng giá trị thẩm mỹ lớn nhất:
* k dòng tiếp theo mỗi dòng ghi 2 số i, j biểu thị bó hoa i cắm vào lọ j. Một trường hợp cụ thể của bài toán
ghi ở bên phải các dòng này.
Camhoa.In
4 3
7 8 9 10
10 9 8 7
5 6 7 8
Camhoa.Ou
24
1 1
2 2
3 4
Để giải bài này ta dùng QUY HOẠCH ĐỘNG
a- DIỄN TẢ THUẬT TOÁN BẰNG NGÔN NGỮ TỰ NHIÊN: Dữ liệu của bài toán có thể biểu diễn nhờ
đồ thị 2 phía: một phía là k bó hoa, một phía là n lọ hoa và yêu cầu ghép cặp (có 2 điều kiện). Ta dùng mảng
2 chiều L[i, j] để lưu tổng giá trị thẩm mỹ lớn nhất khi ghép (cắm) bó hoa i với (vào) lọ j. Bài toán yêu cầu
khi ghép phải đảm bảo: bó hoa có số thứ tự bé phải đứng trước bó hoa có số thứ tự lớn, nên mảng L xác
định như sau:
* Nếu i > j thì không có cách ghép cặp.
8 h 54 m 28/7/2017
190
Thầy Trần Thông Quế
* Nếu i = j thì L[i, j] = v[1, 1] + v[2, 2] + ... + v[i, i].
* Nếu i < j thì L[i, j] = Max(L[i—1,j —1] + v[i, j], L[i, j — 1]).
b-CODE (QUY HOẠCH ĐỘNG)
Program CAMHOA;
Uses Crt;
Const max=100;
Var v:Array[1..max,1..max] of integer;
L:Array[0..max,0..max] of longint;
cap:Array[1..max] of integer;
n, k:integer; f:text;
Procedure Doc;
Var i,j:integer;
Begin
Assign(f,'Bt2.In'); Reset(f);
Readln(f,n,k);
For i:=1 to k do
For j:=1 to n do Read(f,v[i,j]);
close(f);
End;
Function Lonnhat(x,y:integer):integer;
Begin
If (x>y) Then Lonnhat:=x else Lonnhat:=y;
End;
Function Thamymax(i:integer):integer;
Var j, s:integer;
Begin
s:=0;
For j:=1 to i do
s:=s+v[j,j];
thamymax:=s;
End;
Procedure Xuly;
Var i,j:Integer;
Begin
For i:=1 to max do
For j:=1 to max do L[i,j]:=-maxint;
For i:=1 to k do
For j:=1 to n do
If i=j Then L[i,j]:=ThamyMax(i)
Else If i
Procedure Xuat;
Var i,j,d:integer;
Begin
Assign(f,'Camhoa.ou'); Rewrite(f);
Writeln(f,'Tong max cua do tham my:',L[k,n]);
8 h 54 m 28/7/2017
191
Thầy Trần Thông Quế
i:=k; j:=n; d:=0;
While (i>0) And (j>0) do
If (L[i,j]=L[i,j-1]) And (v[i,j]>0) Then
Begin
Cap[i]:=j-1;
Dec(j);
End
Else Begin cap[i]:=j; dec(i); dec(j) End;
For i:=1 to k do
Writeln(f,'Bo hoa thu ',i,' cam vao lo ',cap[i]);
Close(f);
End;
Procedure Xem;
Var f:text; line:string;
Begin
Assign(f,'Camhoa.ou'); Reset(f);
Writeln(#32:13,'KET QUA PROGRAM:');
Writeln;
While not (seekeof(f)) do
Begin
Readln(f,line);
Writeln(#32:7,line);
End;
close(f);
End;
{Main Prog.}
Begin clrscr;
Doc;
Xuly;
Xuat;
Xem;
Write('Done!');
Readln;
End.
3/Bài toán 3. Một sản phẩm có N chi tiết, mỗi chi tiết phải lần lượt gia công trên hai máy A, B (A trước,
B sau). Thời gian để gia công chi tiết trên máy A là Ai, trên máy B là Bi (i = 1,2,...,N). Hãy lập lịch hoàn
thành các chi tiết với thời gian ít nhất.
Dữ liệu vào cất trên text file với tên Bt3.In gồm :
*Dòng đầu tiên ghi số n.
*N dòng tiếp theo, dòng i + 1 là số ai và bi.
Kết quả ghi lên text file với tên Bt3.Ou gồm :
* Dòng đầu ghi thời gian ít nhất gia công các chi tiết.
*Dòng thứ hai ghi số hiệu các việc đã thực hiện theo lịch tối ưu.
Ví dụ:
Bt3.In
5
3 3
4 3
8 h 54 m 28/7/2017
192
Thầy Trần Thông Quế
6 2
5 7
6 3
Bt3.Ou
26
1 4 2 5 3
ĐỂ GIẢI BÀI NÀY TA DÙNG THUẬT TOÁN JONSON
CODE THAM KHẢO (CHƯA TEST)
Program Johnson_Algo ;
Uses Crt ;
Const ln=100; f1=’Bt3.In’; fo=’Bt3.Ou’;
Type m1=Array[1..2, 1..ln] of Real;
kq=Array[1..ln] of Byte;
mdx=Array[1..ln] of Boolean;
Var a:m1; {a[1,j] luu thoi gian chi tiet j tren may A; A[2,j] luu thoi gian chi tiet j tren may B}
resul:kq; {ket qua xep lich}
dx:mdx; {danh dau chi tiet da lam}
n :Byte ;
f :Text ;
Procedure Nhap;
Begin
{Đọc số N và các giá trị A[2,n] vào chương trình, các con tự làm (XEM LẠI PHẦN RECORD & FILE!)}
End ;
Function ChitietMin(var may :Byte) :Byte ;
Var Lmin:integer; chitiet:byte;
Begin
Lmin:=Maxint;
For i:=1 to 2 Do
For j:=n Downto 1 Do
If Not dx[j] then
If a[i,j]
193
Thầy Trần Thông Quế
Resul[dau]:=chitiet;
dx[chitiet]:=True;
End;
Until dau=cuoi-1;
End;
Procedure HienThi;
Begin
{Ghi mang ket qua len file Bt4.Ou theo dung yeu cau o de ra. các con tự làm} End;
Function max2(a,b:Real):Real;
Begin
{Ham xac dinh so lon hon trong 2 so a, b cho truoc. Các con tự làm}
End;
Function Tinh;
Var i,j :Byte; t1, t2:Real;
Begin
t1:=0; t2:=0;
For i:=1 to n Do
Begin
t1:=t1+a[1, resul[i]];
t2:=max2(t1,t2)+a[2,resul[i]] ;
End ;
Writeln(f, t2 :0 :0) ;
End ;
{Main Prog.}
Begin Clrscr;
Nhap;
Johnson_algo;
Assign(f,fo); Rewrite(f);
Tinh;
HienThi;
Write(‘Done!’);
Readln;
End.
4/Bài toán 4 Có N việc. Việc thứ i hoàn thành trong thời gian ti. Các việc này được thực hiện trên M
máy (có công suất như nhau và mỗi máy đều có thể thực hiện được bất cứ việc nào trong N việc), mỗi việc
được thực hiện liên tục trên một máy cho đến khi xong. Hãy lập lịch để các máy thực hiện đủ N việc sao
cho tổng thời gian hoàn thành các việc càng ít càng tốt.
Dữ liệu vào cất trên text file với tên Bt4.In gồm:
Dòng đầu ghi 2 số N, M.
Dòng 2 ghi N số t1, t2,...,tN
Kết quả ghi lên text file với tên Bt4.Ou gồm:
Dòng đầu ghi tổng thời gian hoàn thành N việc.
M dòng sau: tại dòng i + 1 ghi số hiệu các việc thực hiện trên máy i.
Một ví dụ cụ thể của bài toán là ta có 3 máy M1, M2, M3 và 6 việc với thời gian hoàn thành tương ứng là t1
= 2, t2 = 5, t3 = 8, t4 = 1, t5 = 5, t6 = 1 với các file trên đây là:
Bt4.In
8 h 54 m 28/7/2017
194
Thầy Trần Thông Quế
6 3
2 5 8 1 5 1
Bt4.Ou
8
3
2 1 4
5 6
BÀI NÀY DÙNG THUẬT TOÁN HEURISTIC (CÁC CON CẦN VẼ BIỂU ĐỒ ĐỂ HIỂU RÕ CÁC LẬP
LUẬN SAU)
a-Diễn đạt thuật toán bằng ngôn ngữ tự nhiên (hãy tự vẽ biểu đồ để dễ hiểu thuật toán hơn)
*Tại thời điểm t = 0, thực hiện việc V2 trên máy M1, V5 trên máy M2 và V1, trên máy M3.
*Tại t = 2 việc V1 được hoàn thành, liền đó trên máy M3 thực hiện tiếp việc V4. Trong thời gian này 2 máy
M1 và M2 vẫn đang thực hiện công việc của mình ...
*Ta thấy thời gian hoàn thành cả 6 việc là 12 và các máy M1, M2 có quá nhiều thời gian nhàn rỗi. Phương
án trên đây là một phương án tồi.
Để cải thiện nghiệm của bài toán này ta thử một phương án 2 dưới đây:
+ Xếp các việc theo thứ tự giảm dần của thời gian
+ Lần lượt xếp các việc theo thứ tự ấy vào các máy còn nhiều thời gian rảnh nhất.
Như vậy thời gian hoàn thành cả 6 việc ở phương án P2 là 8. Nghiệm này đã tốt hơn nghiệm của phương án
P1: Mọi việc hoàn thành sớm hơn phương án P1 bốn đơn vị thời gian (các bạn hãy hình dung nếu đơn vị
thời gian là tháng thì kế hoạch sản xuất đã về đích trước 4 tháng — đó là khoảng thời gian rất đáng kể trong
sản xuất) và thời gian rảnh của máy M1 là ít nhất.
DÙNG HEURISTIC METHOD
b- Code. (CHƯA TEST)
Ues Crt;
Cosnt ln=1000; fi=’Bt4.In]; fo=’Bt4.Ou’;
Type m1=Array[1..ln] of Longint;
Var t:m1; {t[i]: thoi gian lam viec i; i=1..n}
id:m1; {id[i]: so hieu cua cong viec i}
phan cong may j lam viec i}p:m1; {p[i]:=j
n,m:Integer; {n: So luong cong viec ; m: so luong may}
maxt:Longint {Thoi gian cua may co thoi gian da gia cong lon nhat}
may:m1; {may[i]: Thoi gian da lam (da thuc hien gia cong) cua may i}
Procedure Nhap;
Var i:Integer;
Begin
{Doc cac data n,m vao mang t tu file Bt4.In roi lam lenh sau, }
{ con tu lam. }
For i:=1 to n do id[i]:=i;
End;
Procedure Sort(var a:m1);
Var i, j, c:integer;
Begin
{Sap xep giam mang t theo thoi gian va xep ca mang id. Vi de nen cac con tu lam}
End;
8 h 54 m 28/7/2017
195
Thầy Trần Thông Quế
Function Tim_May_min:Integer;
Begin
{Tim may co thoi gian lam nho nhat. Vi de nen cac con tu lam }
End;
Procedure Ghi;
Var f: Text; i, j: Integer; sum: Longint;
Begin
Assign(f,fo); Rewrite(f);
Writeln(f, maxt);
For j:=1 to m Do
Begin
sum:=0;
For i:=1 to n Do
If p[i]:=j then
Begin
Writeln(f, id[i]:4) ; {In ra so hieu cua may i}
sum:=sum+t[i];
End;
Writeln(f,’ Tong thoi gian da lam cua may ‘, j ,’:’, sum);
End;
Close(f);
End;
Procedure Phancong;
Var i,j,Lj:Integer; Ok: Boolean;
Begin
FillChar(may, sizeof(may), 0);
FillChar(p ,sizeof(p), 0);
i:=0; maxt:=-maxint;
For j:=1 to m do {giao m viec dau cho m may}
Begin
Inc(i);
may[j]:=t[i];
p[i]:=j;
If t[i]>maxt then maxt:=t[i];
End;
Inc(i);
While i<=n Do
Begin
Ok:=False;
For j:=1 to m do
Begin
If i>n then Break;
If may[j]+t[i]<=maxt then
Begin
ok:=true;
may[j]:=may[j]+t[i];
p[i]:=j; {Giao viec i cho may j}
Inc(i);
8 h 54 m 28/7/2017
196
Thầy Trần Thông Quế
End;
End;
If not ok then
If i<=n then
Begin
j:=Tim_May_min ;
may[j]:=may[j]+t[i];
p[i]:=j; {Giao viec moi cho may j da co thoi gian lam it nhat}
If may[j]> maxt the maxt:=may[j];
End;
End;
End;
{ Main Prog.}
Begin clrscr;
Nhap;
Sort(t);
Phancong;
Ghi;
Write(‘Done!’);
Readln;
End.
MỘT VÀI BÀI ĐỂ CÁC BẠN TỰ LUYỆN
LT1. Một xí nghiệp có N công nhân và dây chuyền sản xuất có M máy (M < N).. Nếu giao máy i cho công
nhân j làm thì sẽ đạt lợi nhuận là C[i, j]. Hãy tìm cách bố trí công nhân và máy sao cho không quá một công
nhân đứng một máy và mỗi máy không có nhiều hơn một công nhân để tổng lợi nhuận lớn nhất.
LT2. Có N việc, mỗi việc i phải làm trước một số việc nào đó trong N việc này. Hãy lập lịch thực hiện đủ N
việc đã cho.
Dữ liệu vào cất trên text file với tên Lt2.In gồm :
* Dòng đầu ghi số nguyên dương N.
* Các dòng kế sau ghi các số biểu thị thứ tự bộ phận: đầu dòng là số i, kế sau là các số Ji1, Ji2,,..., Jis có
nghĩa là việc i phải làm trước các việc Ji1, Ji2,..., Jis.
Kết quả ghi lên text file với tên Lt2.Ou chỉ có một dòng ghi số hiệu các việc đã lần lượt được thực hiện.
Lt2.In
10
1 2 3
2 4 10
3 5
4 6 8
Lt2.Ou
1 2 7 9 4 6 3 5 8 10
LT3. Có N việc. Với mỗi việc cho biết tiền công phải trả cho người làm thuê, thời gian để hoàn thành việc,
thời điểm kết thúc việc. Hãy xếp lịch sao cho người làm thuê thu được nhiều tiền công nhất.
Dữ liệu vào cất trên text file với tên Lt3.In gồm :
* Dòng đầu là số nguyên dương N.
** N dòng sau, dòng i + 1 ghi 3 số: thời gian hoàn thành công việc t, thời điểm kết thúc công việc k và tiền
công tc.
Kết quả ghi lên text file với tên Lt3.Ou gồm :
8 h 54 m 28/7/2017
197
Thầy Trần Thông Quế
* Dòng đầu là tổng tiền công lớn nhất.
* Các dòng tiếp theo mỗi dòng ghi 4 số: số hiệu công việc i, thời điểm bắt đầu
công việc t1, thời điểm kết thúc công việc t2, tiền công tc.
Thuật toán :
* Xếp tăng bộ dữ liệu theo khoá là thời điểm cuối cùng phải kết thúc công việc.
Lt3.In
10
1 4 89
5 5 86
4 11 83
5 7 84
1 2 25
3 11 61
6 11 33
4 7 28
3 10 1
5 14 71
Lt3.Ou
329
5 0 1 25
1 1 2 89
3 2 6 83
6 6 9 81
10 9 14 71
LT4- Có N việc đánh số từ 1 đến N cần được bố trí thực hiện trên một máy. Biết:
* pi là thời gian để hoàn thành việc i.
* di là thời điểm cuối cùng phải kết thúc việc i.
* hi là hệ số thưởng phạt của việc i.
ti). Thời điểm bắt đầu thực hiện các việc là 0, hãy lập trình tự thực hiện N việc sao cho tổng giá trị thưởng
phạt của tất cả các việc là lớn nhất.Mỗi việc phải thực hiện liên tục từ lúc bắt đầu cho tới lúc kết thúc,
không cho phép ngắt quãng. Coi như thời gian chuyển từ việc này sang việc khác bằng 0. Giả sử ti là thời
điểm hoàn thành việc i, khi đó giá trị thưởng, phạt việc i là hix(di
Dữ liệu vào cất trên text file với tên Bt8.In gồm:
*Dòng đầu ghi số nguyên dương N (N < 2001)
* Dòng 2 ghi N số nguyên dương p1,...,pN.
* Dòng 3 ghi N số nguyên dương d1,...,dN.
* Dòng 4 ghi N số nguyên dương h1,...,hN.
Kết quả ghi lên text file với tên Bt8.Ou gồm :
* Dòng đầu ghi giá trị thưởng phạt lớn nhất tìm được.
* Dòng 2 ghi N số là trình tự thực hiện các việc.
Ví dụ:
Test_1
Lt4.In
5
2 2 3 4 3
3 2 10 11 9
1 2 2 1 3
8 h 54 m 28/7/2017
198
Thầy Trần Thông Quế
Lt4.Ou
6
2 5 3 1 4
Test_2
Lt4_2.In
4
1 2 3 4
3 2 1 3
1 2 1 2
Lt4_2.ou
-17
1 2 3 4
Mọi ý kiến đóng góp gửi về MailBox của thầy là: quethongtran@yahoo.com
8 h 54 m 28/7/2017
199
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
200
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
201
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
202
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
203
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
204
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
205
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
206
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
207
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
208
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
209
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
210
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
211
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
212
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
213
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
214
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
8 h 54 m 28/7/2017
8
Thầy Trần Thông Quế End; Readln; End.
10- Không dùng thuật toán xử lý mảng 2-chiều, chỉ dùng các biến đơn, lập trình in lên màn hình bảng ziczac chứa 100 số tự nhiên đầu tiên (Bạn có làm được bài này trong 10 phút không?)
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 - - - - - - - - - - - - - - - - - - - - - - 90 91 92 93 94 95 96 97 98 99
KHÔNG THỂ CÓ CODE NÀO NGẮN HƠN CODE DƯỚI ĐÂY!
Uses crt; Var i,j:Byte; Begin clrscr; For i:=0 to 9 do begin For j:=0 to 9 do Write(10*i+j:4); Writeln; end; Readln; End.
11- Dùng ký tự '*', lập trình tạo tam giác cân rỗng. In kết quả lên màn hình. (Bạn có làm được bài này trong 10 phút không?)
Uses Crt; Var chcao,i: Byte; Begin clrscr; Write('Nhap chieu cao tam giac:'); Readln(chcao); Writeln('*':chcao); For i:=2 to chcao-1 do Writeln('*':chcao-i+1,'*':2*i-2); For i:=1 to 2*chcao-1 do Write('*'); Writeln; Writeln; Readln; End.
12- Nhập một dãy số nguyên từ bàn phím vào, lập trình tìm trong dãy ấy bộ (không kể thứ tự) 3 số liên tiếp có tổng bằng số M cho trước.
Uses Crt; Var a:array[1..1000] of integer; n,i,j,k,M:integer; Begin clrscr; Writeln; 8 h 54 m 28/7/2017
9
Thầy Trần Thông Quế Write(#32:2,'M='); Readln(M); Write('n='); Readln(n); For i:=1 to n do Begin Write('a[',i,']='); Readln(a[i]); End; Writeln('Cac bo so trong day thoa man yeu cau bai toan la:'); For i:=1 to n do For j:=1 to n-1 do For k:=j+1 to n do if (i<>j) and (i<>k) and (j<>k) and (a[i]+a[j]+a[k]=M) then Writeln(a[i]:3,a[j]:3,a[k]:3) Readln; End.
13- Lập trình tìm tất cả các số hoàn hảo của số n tùy ý đọc từ bàn phím vào. Yêu cầu xuất kết quả theo Form sau: Chẳng hạn, Vào: 1200,
Ra:
Số hoàn hảo thứ nhất: 6 Và các ước của nó là: 1 2 3 = = = = = = = = = = = = = = = = = Số hoàn hảo thứ hai: 28 Và các ước của nó là: 1 2 4 7 14 = = = = = = = = = = = = = = = = = . . . . . . . . . . . . . . . . . .
Uses crt; Var i,j,n,tong_uoc,dem:longint; tt:byte; Begin clrscr; Repeat Write('Nhap so nguyen duong n:'); Readln(n); dem:=0; For i:=1 to n Do Begin tong_uoc:=0; For j:=1 to i-1 Do If(i MOD j=0) Then tong_uoc:=tong_uoc+j; If tong_uoc=i Then Begin dem:=dem+1; Writeln('* So hoan hao thu ', dem,' la:',i); Write('* va cac uoc so cua no la:'); For j:=1 to i-1 Do If (i MOD J=0) Then Write(j,' '); Writeln; Writeln('= = = = = = = = ='); Writeln;
8 h 54 m 28/7/2017
10
Thầy Trần Thông Quế End; End; Write('More (1/0)?. Come On -> Press 1; Stop -> Press 0:'); Readln(tt); Until tt=0; End. *14- Kiểm tra giả thiết Goldbach – Snhirenman: “Mọi số tự nhiên CHẴN lớn hơn 2 đều có thể biểu diễn bằng TỔNG của HAI số NGUYÊN TỐ”. (Giả thiết Christian Goldbach – nhà toán học Đức – Nửa đầu thế kỉ XVIII, năm 1742 trong thư gửi Euler, Goldbach viết: “Mọi số lẻ bất kỳ đều viết được dưới dạng tổng của ba số nguyên tố “. Sau này mệnh đề đó được gọi là bài toán Goldbach (hay giả thiết Goldbach) Hơn 250 năm bài toán Goldbach vẫn chưa được chứng minh, và cho đến năm 1930, nhà toán học Nga L. G. Snhirenman mới chỉ chứng minh trường hợp nhỏ của giả thiết: “Mọi số chẵn n ≥ 4 đều có thể biểu diễn thành tổng của 2 số nguyên tố”). Uses crt; Var so1, so2, so3, so4: integer; kt1, kt2: boolean; {kt=kiem tra} hoi:char; Begin clrscr; Repeat Write(‘Nhap so chan so1>2:’); Readln(so1); so2:=2; Repeat so3:=so1-so2; so4:=2; While (so4<=sqrt(so2)) And (so2 Mod so4<>0) do Inc(so4); If so4>sqrt(so2) then kt1:=true Else kt1:=false; so4:=2; While (so4<=sqrt(so3)) And (so3 Mod so4<>0) do Inc(so4); If so4>sqrt(so3) then kt2:=true Else kt2:=false; Inc(so2); Until (so3<=2) Or (kt1 and kt2); If kt1 and kt2 then Write(‘GIA THIET GOLDBACH DUNG.’) Else Write(‘GIA THIET GOLDBACH SAI.’); Writeln; Write(‘Another test (y/n)?’); Readln(hoi); Until hoi In [‘N’, ‘n’]; End. *15- Tìm và liệt kê tất cả các số Mersenne nhỏ hơn một số tự nhiên N cho trước (với n>=3)-Các số nguyên tố biểu diễn được dưới dạng 2n – 1 (n-số tự nhiên) gọi là số Mersenne- uses Crt; Var so, n, i, ntmin:longint;
8 h 54 m 28/7/2017
11
Thầy Trần Thông Quế check, stop: Boolean; tt:Byte; Begin clrscr; Repeat Write(‘Nhap n>=3:’); Readln(n); stop:=false; ntmin:=2; Writeln(#32:20,’CAC SO MERSENNE:’); While Not stop Do Begin i:=2; While (i<=sqrt(ntmin)) And (ntmin MOD i<>0) Do Inc(i); If i>sqrt(ntmin) then check:=true Else check:=false; If check then Begin so:=1; For i:=1 to ntmin do so:=2*so; Dec(so,1); i:=2; While (i<=sqrt(so)) And (so MOD i<>0) do Inc(i); If i>sqrt(so) then check:=true Else check:=false; stop:=so>n; If check and Not stop Then Writeln(so); End; Inc(ntmin); End; Writeln; Write(‘Another Test (1/0)?, Come on -) press 1; Stop -> press 0:’); Readln(tt); Until tt=0; End.
16- Không dùng thuật toán đệ quy, lập trình tìm và in lên màn dãy FIBONACI với độ dài cho trước n.
Program Day_Fibo; Uses crt; Var i,n,f1,f2,fi,fi_1,fi_2:Integer; Begin clrscr; Write(‘Nhap do dai day Fibonaci n=’); Readln(n); Writeln(‘ DAY FIBONACI UNG VOI DO DAI ‘,N,’ LA:’); Writeln; i:=1; f1:=1;f2:=1; fi:=f1+f2; Write(f1:3, f2:3); For i:=3 to n Do Begin
8 h 54 m 28/7/2017
12
Thầy Trần Thông Quế Write(fi:5); f1:=f2; f2:=fi; fi:=f1+f2; End; Readln; End.
17- Lập trình (PHI ĐỆ QUY) tìm ước số chung lớn nhất của N số tùy ý đọc từ bàn phím vào. Test. Vào: 72 40 24 48 56, Ra: 8
Uses Crt; Var a:Array[1..100] of integer; n,i,tt: Byte; d: Integer; Begin Clrscr; {Có lẽ bạn nên dùng PHÁT SINH DỮ LIỆU NGẪU NHIÊN TỰ ĐỘNG, sẽ nhanh hơn!} Repeat {Randomize;} Write(‘ Nhap so luong cac so hang n:’); Readln(n); For i:=1 to n Do Begin Write(‘a[‘,i,’]=’); Readln(a[i]); End; {a[i]:=Random(20);} Writeln(‘Day so vua nhap:’); For i:= 1 to n Do Write(a[i]:3); Writeln; Writeln(‘= = = = = = = = = = = = = = =’); For i:=1 to n-1 do Repeat d:=a[i]; a[i]:=a[i+1] MOD a[i]; a[i+1]:=d; Until a[i]=0; Write(‘USC max cua ‘,n,’ so vua nhap la:’,a[n]); Writeln; Write(‘More(1/0)? Continue - > 1, Stop -> 0:’); Readln(tt); Until tt=0; End.
18- Tìm nghiệm nguyên dương của phương trình sau:
a) 4x+3y-9z=n, với 0 ≤ x, y, z ≤ 50; n- đọc từ bàn phím vào.
Không áp đặt trước miền giá trị của x, y, z hãy tìm nghiệm nguyên dương của các phương trình sau:
b) x + y + z = n ; n- đọc từ bàn phím vào. c) x2 + y2 = n; n- đọc từ bàn phím vào.
Bài a)
Uses Crt; Var x,y,z,n,d:integer; 8 h 54 m 28/7/2017
13
Thầy Trần Thông Quế Begin clrscr; Write(‘Nhap n:’); Readln(n); d:=0; For x:=0 to 50 do For y:=0 to 50 do For z:=0 to 50 do If ((4*x+3*y-9*z)=n) then Begin Writeln(x:4,y:4,z:4); Inc(d); If (d MOD 20)=0 then Begin Write(‘Go ENTER -> xem tiep.’); Readln; End; End; End.
Các bài còn lại làm tưong tự.
19- Lập trình tạo bảng ba cột GÓC SIN COS, tính giá trị hàm Sin, Cos ứng với góc ở cột cận trái. (Vì có từ góc 0o đến 360o nên yêu cầu mỗi lần chỉ hiện lên màn 20 giá trị kết quả, để XEM TIẾP: gõ phím ENTER.)
Uses Crt; Var goc:word; gocradian: Real; Begin clrscr; Writeln(#32:9,’BANG GIA TRI GOC, SIN, COS:’); Writeln(‘ Nho an ENTER de xem tiep.’); For goc:=1 To 360 Do Begin gocradian:=goc*pi/180; Writeln(#32:24,goc,#32:5,sin(gocradian):0:4,#32:3,cos(gocradian):0:4); If (goc MOD 20) = 0 then Readln; End; End.
B.2.2) CÁC LỆNH LẶP KHÔNG XÁC ĐỊNH (WHILE. . .DO; REPEAT…UNTIL)
Lập trình giải các bài toán sau:
20- Tính gần đúng với sai số 10^-6 (1/1000000): số Pi; sinx; cosx; e^x.
a) Tính gần đúng số PI.
8 h 54 m 28/7/2017
14
Thầy Trần Thông Quế Program tinhgandung_So_Pi; Uses Crt; Const ss=1E-6 Var sp: Real; n, dau: integer; Begin clrscr; n:=0; sp:=0; While (1/(2*n+1))>=ss do Begin If n MOD 2 = 0 then dau:=1 Else dau:=-1; sp:=sp+dau*(1/(2*n+1)); n:=n+1; End; Write(‘Gia tri gan dung cua so Pi=’,4*sp:8:4); Readln; End. b) TÍNH GẦN ĐÚNG SINX BỞI CÔNG THỨC TRUY HỒI RÚT GỌN CÒN 1 SỐ HẠNG
Lời nhắc không thừa: + Đối số x trong các hàm sin, cos ở đây cần hiểu ngầm có đơn vị đo là Radian (Trong mọi Program để nó như một hư số). + và có LỜI NHẮC QUAN TRỌNG HƠN: Hãy test program với bộ số sau: x=0 hoặc x=3.1416 (= ) sinx=0; x=1.5708 (=/2) sinx=1; x=4.7124 (=3/2) sinx=-1 và trong đầu luôn có hình ảnh Vòng Tròn Đơn Vị: Uses Crt; Const ss=1E-6; Var x,S,T: Real; n: Integer; hd:char; Begin Clrscr; Repeat Write(‘Nhap vao cung x (Radian)cua ham Sin:’); Readln(x); S:=x; T:=x; n:=0; While ABS(T)>=ss Do Begin n:=n+2; T:=-T*SQR(x)/(n*(n+1)); S:=S+T; End;
8 h 54 m 28/7/2017
15
Thầy Trần Thông Quế Write(‘Sin(x)=’,S:0:6); Writeln; Write(‘More (y/n)? Come on -> Press y; Stop -> Press n:’); Readln(hd); Until hd In [‘n’,’N’]; End.
HAI HÀM CÒN LẠI LÀM TƯƠNG TỰ! ĐỂ Ý:
21- Phân tích một số tự nhiên ra các thừa số nguyên tố.
Program Thua_so_nguyen_to; {Repeat và While lồng nhau}
Uses crt;
Var n,i:longint;
Begin clrscr;
Write(‘n=’);Readln(n);
Writeln(‘Cac thua so nguyen to cua ‘,n,’ la:’);
Repeat
i:=2;
While (n Mod i<>0) AND (i 22- Giả sử dân số Việt Nam năm 2017 là 96 triệu dân và tỷ lệ bình quân tăng dân số hàng năm là 3/1000.
Tính xem SỚM NHẤT đến năm nào thì dân số nước ta đạt 110 triệu dân. Uses Crt;
Const tyle=0.003;
Var ds:Real; nam: Integer;
Begin clrscr;
Write(‘Nhap dan so hien tai:’); Readln(ds);
nam:=2017;
While (ds<=110*1E+6) Do
Begin
Inc(nam);
ds:=ds*(1+tyle);
End;
Write(‘Som nhat den nam ‘,nam,’ dan so nuoc ta dat 110 trieu dan.’); 8 h 54 m 28/7/2017 16 23- Cho trước số nguyên dương n có nhiều hơn 1 chữ số. Đếm số chữ số của số đó và tính tổng của chúng.
Chẳng hạn, vào: 9876543, ra: 7 và 42 Uses crt;
Var n,dem,tong:Longint;
Begin clrscr;
Write(‘Nhap so nguyen duong nhieu hon 1 chu so:’);
Readln(n);
tong:=0; dem:=0;
While n>0 Do
Begin
Inc(dem);
tong:=tong+n MOD 10;
n:=n DIV 10;
End;
Writeln(‘Tong cac chu so cua so vua nhap:’,tong);
Writeln(‘So cac chu so cua so vua nhap=’,dem);
Readln;
End. 24- Thực hiện phép chia bằng phép trừ. Program Chia_la_tru;
Uses crt;
Var Sobichia, Sochia,Thuong, du:Longint; hoi:char;
Begin clrscr;
REPEAT
Write(‘Nhap Sobichia:’) ; Readln(Sobichia);
Write(‘Nhap Sochia<=Sobichia:’) ; Readln(Sochia);
Thuong:=0;
While (Sochia<=Sobichia) Do
Begin
Sobichia:=Sobichia-sochia;
thuong:=thuong+1;
End;
du:=Sobichia;
Writeln(‘Thuong=’,Thuong);
Writeln(‘So du=’,du);
Writeln;
Write(‘Another Test (y/n)?:’); Readln(hoi);
UNTIL hoi In [‘n’,’N’];
End. 25- Lập trình đảo ngược một số nguyên dương (PHI ĐỆ QUY) cho trước có nhiều hơn 1 chữ số. Ví dụ vào
2017, ra: 7102. 8 h 54 m 28/7/2017 17 26- Tìm ước số chung lớn nhất của hai số nguyên dương cho trước nhờ thuật toán Euclide:
26.1) Dùng phép trừ
26.2) Dùng phép chia ĐÁP: 26.1)
Uses crt;
Var a,b,d:integer;
Begin clrscr;
Write(‘Nhap 2 so nguyen duong:’); Readln(a,b);
While (a-b<>0) Do
Begin
if a>b then a:=a-b
else b:=b-a;
End;
Write(‘Uscmax=’,b);
Readln;
End.
26.2)
Uses crt;
Var a,b,du:integer;
Begin clrscr;
Write(‘Nhap 2 so nguyen duong:’); Readln(a,b);
While (b<>0) Do
Begin
du:=a Mod b;
a:=b;
b:=du;
End;
Write(‘Uoc so chg max=’,a);
Readln;
End.
8 h 54 m 28/7/2017 18 8 h 54 m 28/7/2017 19 *29- Trên bàn có 26 viên sỏi. Người chơi với máy tính. Mỗi lần, mỗi đối thủ chỉ bốc không hơn 4 viên. Đối
thủ nào phải bốc viên sỏi cuối cùng là thua. Tìm một chiến thuật chơi để người đi trước nhưng luôn luôn
thua máy tính. {WRITELN(TONG_SOI-(5*i));} PROGRAM BOCSOI;
uses crt;
VAR
TONG_SOI,I,SOI_CON,N:INTEGER;ch:char;
BEGIN
REPEAT
clrscr;
I:=1;
TONG_SOI:=26;
REPEAT
WRITELN(‘LAN BOC THU ‘,I,’:’);
WRITE(‘ BAN BOC MAY VIEN (khong qua 4 vien): ‘);READLN(N);
WRITELN(‘ MAY BOC: ‘,5-N);{WRITELN(5-N);}
WRITELN(‘ SO SOI CON LAI:= ‘,TONG_SOI-(5*i));
SOI_CON:=TONG_SOI-(5*i);
I:=I+1;
UNTIL SOI_CON =1;
WRITELN(‘BAN PHAI BOC VIEN CUOI CUNG. BAN THUA ROI!’);
writeln;
write(‘ Tiep khong (c/k):’);readln(ch);
UNTIL (ch=’k’) OR (ch=’K’);
END.
*30- Tìm và in lên màn tất cả các cặp số thân thiện mà giá trị của chúng không quá 10000. (Hai số được gọi
là thân thiện nếu TỔNG CÁC ƯỚC CỦA SỐ LỚN BẰNG SỐ NHỎ: ví dụ 48 và 75 là cặp số thân thiện vì
các uớc của 75 là: 3 5 15 25 và tổng các ước này bằng 48!)
Uses Crt;
Var n1,n2,t,k: Integer; tt:Byte;
Begin Clrscr;
Repeat
Writeln(#32:20,’Cac cap so Than Thien <10000:’);
Writeln(#32:20,’= = = = = = = = = = = = = =’);
For n1:=1 to 10000 do
Begin 8 h 54 m 28/7/2017 20 PROGRAM NANGNHANH_LUYTHUA; Uses Crt;
VAR
a, b : Real;
k, n : integer; hoi: char;
BEGIN Clrscr;
Repeat
Write('a,k= '); Readln(a,k);
Write(a,' mu ',k,' = ');
b:=1;
While k>0 do
Begin
n:=k div 2;
If (n+n 8 h 54 m 28/7/2017 21 33. (Hàm Euler Eul(n)). Cho trước số tự nhiên n. Hàm Eul(n) chứa tất cả các số tự nhiên nhỏ hơn n và
nguyên tố cùng nhau với n. Tính hàm Eul(n).
Uses Crt;
Var n, ham_Eul,i,a,b,r: integer;
Begin clrscr;
Write('Nhap n:'); Readln(n);
ham_Eul:=0;
For i:=1 to (n-1) do
Begin
a:=i;
b:=n;
While b<>0 do
Begin
r:= a MOD b;
a:=b;
b:=r;
End;
If a=1 then Inc(ham_Eul);
End;
Write('Gia tri ham Euler=:',ham_Eul);
8 h 54 m 28/7/2017 22 = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = Trong Pascal có hai Modul để ta lập trình Đơn Thể. Âý là:
* Procedure (Thủ Tục).
* (và) FUNCTION (Hàm) Đặc biệt các em cần chú ý và nắm thật vững bản chất 3 khái niệm sau của lập trình Modul:
a-Biến toàn cục (Global Var.) và biến cục bộ (Locate Var.)
b-Các khái niệm về tham chiếu
c-Hai phương cách truyền data trong lập trình Modul của Pascal:
c1. Truyền theo Tham Trị (Transfer By Value Parameters)
c2. Truyền theo Tham Biến (Transfer By Variable Parameters) Trước hết các bạn hãy “khai vị” 3 “món” sau ( 3 MÓN “KHAI VỊ” NÀY KIỂM TRA XEM CÁC BẠN CÓ
HIỂU ĐẾN TẬN NGỌN NGUỒN CÁC KHÁI NIỆM a); b) ; c); d) nêu trên không. Vì chỉ khi hiểu rõ thực
chất 4 khái niệm đó, bạn mới hòng lập trình đơn thể thạo):
Không RUN program, chỉ dùng bút ghi kết quả của 3 program sau đây lên giấy + giải thích tỉ mỉ kết quả!
BA BÀI “KHAI VỊ” NÀY KHÔNG DỄ ĐÂU! NHỚ: KHÔNG ĐƯỢC RUN PROGRAM NHÉ!!! 1. Program Transf_By_Val;
Uses Crt;
Var so1, so2:integer;
Procedure Transf_Val(x, y:integer);
Begin
Writeln(' Ben trong thu tuc:');
x:=x+15;
y:=y+15;
Writeln('X=',x);
Write('Y=',y);
End;
Begin {Main Prog.)
Writeln('Co che truyen data theo THAM TRI:');
Write('Nhap so thu nhat so1='); Readln(so1);
Write('Nhap so thu hai so2='); Readln(so2);
Transf_Val(so1, so2);
Writeln;
Writeln('Ben ngoai thu tuc(tuc la sau truyen Data):');
Writeln('Bay gio so thu 1 so1=',so1);
Writeln('Bay gio so thu 2 so2=',so2);
Writeln('Go ENTER de stop!'); 8 h 54 m 28/7/2017 23 2. Program Transf_By_Vari_Para;
Uses Crt;
Var so1, so2:integer;
Procedure Transf_By_Vari_Para(Var x, y:integer);
Begin
Writeln('Trong than thu tuc:');
x:=x+15;
y:=y+15;
Writeln(' Tham so X=', x);
Writeln(' Tham so Y=', y);
End;
BEGIN {Main Prog.}
Writeln('Co che truyen Data theo THAM BIEN:');
Write('Nhap so thu nhat so1='); Readln(so1);
Write('Nhap so thu hai so2='); Readln(so2);
Writeln('Sau khi truyen Data (tucla ben ngoai thu tuc):');
Writeln('Bay gio so1=',so1);
Writeln('Bay gio so2=',so2);
Writeln;
Write(' Go ENTER de Stop!');
Readln;
END. 3. Program Obser_Transf_Data;
Uses Crt;
Var a, b: integer;
Procedure Obser(Var x, y:Integer);
Begin
Write(x:3, y:3);
x:=2;
x:=x+1;
y:=2*x;
End;
BEGIN {Main Prog.}
Clrscr;
a:=4; b:=5;
Write('Cac gia tri a, b:', a,'; ',b);
Writeln;
Obser(a,b);
Writeln('Cac gia tri a, b:',a,'; ',b);
Obser(b,a);
Writeln('Cac gia tri b, a:',b,'; ',a);
Readln;
END.
8 h 54 m 28/7/2017 24 Uses Crt;
Type Kytu='!'..'}';
Tapkytu=Set of Kytu;
Var A,B,C,D,E: Tapkytu; Procedure Nhap(Var x:Tapkytu);
Var kt: Char;
Begin
Read(kt);
While kt<>#13 Do
Begin
x:=x+[kt];
Read(kt);
End;
End; Procedure Inra(Y: Tapkytu);
Var kt: Char;
Begin
For kt:='!' to '}' Do
If kt In Y then Write(kt:3);
End; {main Prog.}
Begin clrscr;
A:=[]; B:=[]; C:=[]; D:=[]; E:=[];
Write('Nhap cac phan tu cua tap A (Ngung, go ENTER:'); Nhap(A);
Write('Nhap cac phan tu cua tap B (Ngung, go ENTER:'); Nhap(B);
C:=A+B;
D:=A*B;
E:=A-B;
Write('Hop cua 2 tap vua nhap C=A+B='); Inra(C); Writeln;
Write('Giao cua 2 tap vua nhap D=A*B='); Inra(D); Writeln;
Write('Hieu cua 2 tap vua nhap E=A-B='); Inra(E); Writeln;
Readln;
End. *5. Đọc từ bàn phím vào số nguyên dương n. Viết một hàm kiểm tra xem số ấy có là số chính phương
không (Số bằng bình phương của số tự nhiên khác gọi là số chính phương).
Uses Crt;
Var n:longint; tt:byte; Function chphuong_check(var k:longint):boolean;
Begin
If Sqrt(k)=Trunc(Sqrt(k)) then chphuong_check:=true
8 h 54 m 28/7/2017 25 Begin clrscr;
Repeat
Write('Nhap so nguyen n:'); Readln(n);
If chphuong_check(n) then Write(n,' la so chinh phuong.')
Else Write(n,' khong phai la so chin phuong.');
Writeln;
Write('More (1/0)?, Continue -> press 1, Stop -> press 0:');
Readln(tt);
Until tt=0;
End. *6. Đọc từ bàn phím vào số nguyên dương n. Viết một hàm kiểm tra xem số ấy có là số hoàn hảo không (số
bằng tổng các ước của nó kể cả đơn vị, gọi là số hoàn hảo,. Chẳng hạn 28 là số hoàn hảo vì
28= 1 + 2 + 4 + 7 + 14).
Uses Crt;
Var n:longint; Function Hhao_Check(var k:longint):Boolean;
Var i,sum:longint;
Begin
sum:=0;
For i:=1 to k DIV 2 do
If n MOD i=0 then sum:=sum+i;
If sum=n then Hhao_Check:=true
Else Hhao_Check:=false;
End; Begin clrscr;
Write('n='); Readln(n);
If Hhao_Check(n) then Write(n,' la so hoan hao.')
Else Write(n,' khong la so hoan hao.');
Readln;
End. CÓ THỂ BẠN KHÔNG ĐỂ Ý HOẶC KHÔNG HIỂU: Trong 2 bài 28 & 29, biến Toàn cục và Tham số
Thực sự là trùng nhau (n). Lời gọi hàm ở Main Program luôn luôn phải dùng BIẾN TOÀN CỤC HOẶC
THAM SỐ THỰC SỰ (NGHĨA LÀ: KHÔNG ĐƯỢC DÙNG BIẾN CỤC BỘ OR KHÔNG ĐƯỢC DÙNG
THAM SỐ HÌNH THỨC). 7. Đọc từ bàn phím vào số nguyên dương n. Viết một hàm kiểm tra xem số ấy có là số nguyên tố không.
USES CRT;
Var n ,d,i: Integer; Function ktnt:Boolean;
Begin
d:=0;
For i:=2 to n-1 do
If n mod i=0 then d:=d+1; 8 h 54 m 28/7/2017 26 BEGIN CLRSCR;
Write(#32:5,'Nhap n = '); Readln(n);
If ktnt then
Writeln(#32:9,n,' la so nguyen to.')
Else Writeln (#32:9,n,' khong phai la so nguyen to.');
Readln;
END. (CÁC HÀM KIỂM TRA TRÊN ĐÂY, KHÔNG NHẤT THIẾT PHẢI CÓ KIỂU BOOLEAN. KIỂU CỦA
NÓ CÓ THỂ LÀ BYTE (THƯỜNG) HOẶC LÀ CHAR (ĐÃ CÓ LÚC NHÀO BẠN THỬ VỚI KIỂU
CHAR CHO NHỮNG HÀM CÓ CHỨC NĂNG KIỂM TRA CHƯA?) 8. Đọc từ bàn phím vào một số nguyên dương, kiểm tra xem số ấy có đối xứng không. Một số đọc xuôi, đọc
ngược đều như nhau là số đối xứng. Ví dụ 123454321. CODE DƯỚI ĐÂY LÀ NGẮN NHẤT, KHÔNG THỂ NGẮN HƠN. Uses crt;
var n,m,tam:longint; tt:byte;
Begin clrscr;
Repeat
Write('Nhap n:'); Readln(n);
m:=0; tam:=n;
While (tam>0) Do
Begin
m:=m*10+tam MOD 10;
tam:=tam DIV 10;
End;
If m=n then Write('So vua nhap la so Doi xung.')
Else Write('So vua nhap Khong la so Doi xung.');
Writeln;
Write('Another Test (1/0)?. Come on->Press 1; Stop-> Press 0:');
Readln(tt);
Until tt=0;
End. **9. Lập trình biểu diễn một số nguyên dương bằng tổng của n số tự nhiên LIÊN TIẾP khác. Yêu cầu xuất:
Chẳng hạn: Vào 4, ra: 4 không biểu diễn được bằng tổng 2 số tự nhiên liên tiếp.
Vào 100, ra: 100=9+10+11+12+13+14+15+16
Số 100 biểu diễn được bằng tổng của 8 số tự nhiên liên tiếp.
Vào 5, ra: 5=2+3
Số 5 biểu diễn được bằng tổng của 2 số tự nhiên liên tiếp. BÀI NÀY KHÁ KHÓ ĐỐI VỚI HS VÀ CẢ SINH VIÊN! uses crt;
Const max=10000;
Var n,i,dem:Longint; a:array[1..max] of Longint; 8 h 54 m 28/7/2017 27 Begin
stop:=False;
kt:=False;
kd:=0;
While Not Stop do
Begin
bd:=kd;dem:=0;
t:=0;
If bd>=(m+1) DIV 2 then stop:=true
Else
Begin
While t Var tt:Byte;
Begin clrscr;
Repeat
Repeat
Write('Nhap so duong n='); Readln(n);
If n<0 then Writeln(' Nhap lai n>=0');
Until n>=0;
If Check(n) then
Begin
Write(n,'=');
For i:=1 to dem-1 do Write(a[i],'+');
Writeln(a[dem]);
Write('So ',n,' bieu dien duoc thanh');
Write(' tong cua ',dem,' so tu nhien lien tiep!');
End
Else
Begin 8 h 54 m 28/7/2017 28 **10. Lập trình phân tích một số tự nhiên bất kỳ thành tổng các số nguyên tố để thu được TÍCH CỦA CÁC
SỐ HẠNG LÀ LỚN NHẤT. Test1 vào: 8; ra: 3 3 2, tích các số hạng đạt max=18
Test2: Vào 23; ra: 3 3 3 3 3 3 3 2, tích các số hạng này đạt max=4374 Uses crt;
Const m=65;
Var pa_opt:Array[0..m] of Byte;
tic:Array[0..m] of longint;
j,s,p,k:longint; tt:Byte; Procedure Innit;
Var k:longint;
Begin
For k:=0 to p do
Begin
tic[k]:=0; pa_opt[k]:=0;
End;
tic[0]:=1;
End; Procedure Process;
Var j,k,s,ticmax:longint;
Begin
For j:=1 to p do
Begin
For k:=0 to p-j do
If (k=0) or (pa_opt[k]>0) then
Begin
s:=k+j;
ticmax:=tic[k]*j;
If ((pa_opt[s]=0) or (pa_opt[s]>0)) and (ticmax>tic[s]) then
Begin
tic[s]:=ticmax; pa_opt[s]:=j;
End;
End;
End;
End; Begin clrscr;
Repeat
8 h 54 m 28/7/2017 29 While s>0 Do
Begin
Write(pa_opt[s]:3); s:=s-pa_opt[s];
End;
Writeln;
Write('Ung voi ptich toi uu tren day, ta duoc tich max=',tic[p]:2);
Writeln; Writeln;
Writeln('* * * * * * * * * * * * * * ');
Write('Continue(1/0)?. Go 1->Tiep; go 0->ngung:');
Readln(tt);
Until tt=0;
End. **11. (SỐ TAM TAM) Liệt kê tất cả các số Tam Tam và đếm số lượng các số TAM TAM đã liệt kê. (Các
số Tam Tam là những số có 3 chữ số mà số đảo ngược của nó nguyên tố với nó. Chẳng hạn số 974 nguyên
tố cùng 479 là hai số TAM TAM)
Uses crt;
Var dem, i:integer; Function uscln(a,b:integer):integer;
var r:integer;
Begin
While b>0 do
Begin
r:=a MOd b; a:=b; b:=r;
End;
uscln:=a;
End; Function daoso(x:integer):integer;
Var y:integer;
Begin
y:=0;
While x>0 do
Begin
y:=10*y+(x MOD 10);
x:=x DIV 10;
End;
daoso:=y;
End; Procedure Tim;
Begin
dem:=0; writeln; Writeln;
Writeln(#32:18,'Cac so Tam tam thoa man d/kien dau bai:'); 8 h 54 m 28/7/2017 30 Begin clrscr;
Tim;
Readln;
End. **12. Liệt kê tất cả các cặp số Lucasa. (Giới hạn: 1 CODE DƯỚI ĐÂY LÀ NGẮN NHẤT! Uses crt;
Var n, i:longint; s1, s2:string; d: byte; hd:char;
Begin clrscr;
Repeat
d:=0;
Writeln(' Tim cac cap lucasa_number:');
Repeat
Write('Nhap can tren cua gioi han:'); Readln(n);
Until (n>1) and (n<2147483647);
Writeln('Cac cap Lucasa number <=',n,': ');
n:=Trunc(Sqrt(n));
For i:=1 to n do
If (i MOD 10 in [1, 5, 6]) then
Begin
Str(i,s1);
Str(i*i,s2);
If Copy(s2,Length(s2)-Length(s1)+1, Length(s1))=s1 Then
Begin
Inc(d);
Writeln('(',s1,',',s2,')');
End;
End;
Writeln('Tong cong co ',d,' cap LucasaNumbers.');
Write('Go ESc de tro lai chuong trinh!');
Until Readkey = #27;
End. 8 h 54 m 28/7/2017 31 Function NT(n:longint):boolean;
Var
i:longint;
Begin
If (n=0) or (n=1) then
NT:=False
Else
Begin
i:=2;
While (n mod i<>0) and (i<=sqrt(n)) do
i:=i+1;
If i> sqrt(n) then NT:=True
Else NT:=False;
End;
End; BEGIN CLrscr;
Write('Nhap so chu so n (n<=8):');
Readln(n);
dem:=1;
a[dem]:=0;
For i:=1 to n do
Begin
kb:=0;
For k:=1 to dem do
For cs:=0 to 9 do
If NT(a[k]*10+cs) then
Begin
kb:=kb+1;
b[kb]:=a[k]*10+cs;
End;
dem:=kb;
For k:=1 to dem do
a[k]:=b[k];
End;
For k:=1 to dem do
Write(a[k]:10);
Writeln;
Writeln('Co tat ca ',dem,' so sieu nguyen to co ',n,' chu so.');
Readln;
END. 8 h 54 m 28/7/2017 32 1- Cho trước độ dài n của dãy số. Đọc từ bàn phím vào dãy n số tự nhiên. Tìm và in lên màn hình các số nguyên tố cùng nhau trong dãy. Program songuyento_trongday;
uses crt;
var a:array[1..100] of integer;
i,n,j,dem:integer;
Begin
clrscr;
write(‘Nhap do dai cua day so: ‘); readln(n);
writeln(‘Nhap cac phan tu cua mang:’);
for i:=1 to n do
Begin
write(‘a[‘,i,’]=’);readln(A[i]);
End;
write(‘Day vua nhap la:’);
For i:=1 to n do write(‘ ‘,a[i]);
writeln;
writeln(‘= = = = = = = = = = = = = = = = =’);
write(‘Cac so nguyen to co trong mang la:’);
For i:=1 to n do
Begin
dem:=0;
for j:=2 to a[i]-1 do
Begin
If a[i] mod j=0 then dem:=dem+1;
End;
If dem=0 then write(‘ ‘,a[i]);
End;
readln;
End.
2- Cho trước độ dài n của dãy số. Đọc từ bàn phím vào dãy n số nguyên. Tìm và in lên màn dãy con dài nhất gồm toàn số dương.
Chẳng hạn, Vào: 12 -4 6 3 -21 19 5 7 21 -9 2
Ra: 19 5 7 21
Program DayconDuongDainhat; 8 h 54 m 28/7/2017 33 Uses crt;
Var a:Array[1..1000] of Integer;
n,i,j,k,kmax,id:byte;
Begin
clrscr;
{ Randomize;}
write(‘Nhap do dai n (2<=n<=1000) cua day so: ‘); readln(n);
writeln(‘Nhap cac phan tu cua mang:’);
for i:=1 to n do
Begin
write(‘a[‘,i,’]=’);
readln(a[i]);
{a[i]:=Random(100);}
End;
clrscr;
writeln(‘Day vua nhap la:’);
For i:=1 to n do write(‘ ‘,a[i]);
writeln;
writeln(‘= = = = = = = = = = = = = = = = = = = = = = = = = =’);
kmax:=0;
For i:=1 to n do
Begin
j:=i+1;
While ((a[i]>0) and (a[j]>0)) Do
Inc(j);
k:=j-i;
if k>kmax then
Begin
kmax:=k;
id:=i;
End;
End;
Writeln(‘Day con gom cac so duong lien tiep dai nhat:’);
For i:=id to id+kmax-1 do Write(a[i]:4);
Readln;
End. 3- Hai bài dưới đây yêu cầu dùng THUẬT TOÁN PHI ĐỆ QUY: a/ In lên màn hình tam giác ĐỀU Pascal.
b/ In lên màn hình tam giác VUÔNG Pascal.
(Tam giác Pascal là bảng số có hình tam giác chứa các hệ số của khai triển nhị thức Newton)
3.a)
Program Tg_vuong_Pascal;
uses crt;
Var a:array[1..16] of byte; i,j:byte;
Begin clrscr;
Writeln(‘Tam giac vuong Pascal co 16 dong:’);
Writeln; 8 h 54 m 28/7/2017 34 If (j=i) or (j=1) then a[j]:=1
Else a[j]:=a[j]+a[j-1]; For i:=1 to 16 do
Begin
For j:=i Downto 1 Do
For j:=1 to i do
Write(a[j]:4);
Writeln;
End;
Readln
End.
3.b)
Program InTamGiacPascal;
uses crt;
var hs:array[0..12] of integer; i,j:integer;
Begin ClrScr;
Write(‘Tam giac Pascal deu co 13 dong:’);
For i:=0 to 12 do
Begin
For j:=i DownTo 0 do
If (j=i) or (j=0) then hs[j]:=1
Else hs[j]:=hs[j]+hs[j-1];
Gotoxy((70-5*i) DIV 2,i+6);
For j:=0 to i do Write(hs[j]:5);
End;
Readln;
End. *4- (INFORMATIC OLYMPIC MOSCOW 1985). Tìm tất cả các cách biểu diễn một số tự nhiên bằng
tổng của các số tự nhiên khác.
Ví dụ. Vào: 5
Ra : Cách thứ 1: 5=4+1
Cách thứ 2: 5=2+3
Cách thứ 3: 5=3+1+1
Cách thứ 4: 5=2+2+1
Cách thứ 5: 5=2+1+1+1
Cách thứ 6: 5=1+1+1+1+1+1
Số cách biểu diễn = 6
Program ptich_thanh_tong;
Uses crt;
Var n,d,l,i,sum:Integer; dem:longint; tt:char;
s,r:array[1..100] of integer;
Begin clrscr;
Repeat
Write(‘ Nhap n:’); Readln(n); 8 h 54 m 28/7/2017 35 Writeln(‘Cac phuong an bieu dien tong:’); Writeln;
dem:=0;
s[1]:=n; r[1]:=1; d:=1;
While s[1]>1 do
Begin
inc(dem); sum:=0;
If s[d]=1 Then
Begin
sum:=sum+r[d];
Dec(d);
end;
sum:=sum+s[d]; r[d]:=r[d]-1; L:=s[d]-1;
If r[d]<>0 then Inc(d);
s[d]:=L; r[d]:=sum DIV L; L:=Sum MOD L;
If L<>0 then
Begin
Inc(d); s[d]:=L; r[d]:=1;
End;
Write(‘ Cach thu ‘,dem,’:’,n,’=’);
For i:=1 to d Do
For L:=1 to r[i] Do Write(s[i],’+’);
Writeln; Writeln;
End;
Writeln(#32:5,’So cach bieu dien=’,dem); Writeln;
Write(‘Continue (y/n) ?, Go y->de tiep; go n hoac N de thoat:’);
Readln(tt); Writeln; Writeln;
Until tt IN [‘n’,’N’];
End. *5- INFORMATIC OLYMPIC MOSCOW 1987 (TẬP NỬA BỘI-HALF MULTI SET). Tập A các số tự nhiên định nghĩa như sau: a- 1 A
b- K A thì 2K+1 A và 3K+1 A. Tìm và in lên màn n phần tử đầu tiên của tập A (n<1000). Tập định nghĩa trên đây gọi là HALF MULTI SET.
Chẳng hạn với n=9 thì các phần tử đầu tiên của tập A là:
1 3 4 7 9 10 13 15 19 Program half_multi_Set;
Uses Crt;
Const max=100;
Var i,k2,k3,a2,a3,n: Integer; a:array[1..100] of integer;
Begin Clrscr;
Write(‘Nhap n:’); Readln(n);
k2:=1; k3:=1; a[1]:=1;
Write(1);
For i:=2 to n do
Begin
a2:=2*a[k2]+1; a3:=3*a[k3]+1; 8 h 54 m 28/7/2017 36 If a2<=a3 Then
Begin
a[i]:=a2;
k2:=k2+1;
End;
If a3<=a2 then
Begin
a[i]:=a3;
k3:=k3+1;
End;
Write(a[i]:4);
End;
Readln;
End. **6- Cho trước dãy số nguyên có độ dài n (n đọc từ bàn phím vào). Tìm cách chia dãy ấy thành nhiều dãy
con có tổng bằng nhau. { Go ESC de ve Program}
Uses Crt;
const mn=60;
Var a,c:Array[1..mn] of word;
Procedure View(n:word);
Var i: word;
Begin
for i:=1 to n do
Write(a[i]:4);
Writeln;
End;
Function Min(a,b: word):word;
Begin
if a
8 h 54 m 28/7/2017 37 8 h 54 m 28/7/2017 38 8 h 54 m 28/7/2017 39 8 h 54 m 28/7/2017 40 41 *11- Cho trước ma trận vuông cấp n. Lập trình làm c- In lên màn ma trận tam giác dưới & ma trận tam giác trên.
d- Xem các phần tử thuộc đường chéo chính.
e- Xem các phần tử ở PHÍA TRÊN đường chéo chính.
f- TỔNG các phần tử ở PHÍA TRÊN đường chéo chính.
Program Bt_7;
Uses crt;
Var i,j,m,n,d,s,s1,s2,t:integer;
a:array[1..50,1..50] of integer;
Begin clrscr;
Randomize;
Write(‘Nhap so hang cot n cua ma tran vuong:’); Readln(n);
for i:=1 to n do
Begin
for j:=1 to n do a[i,j]:=Random(10);
End;
Writeln(‘Ma tran vua nhap:’);
For i:=1 to n do
Begin
For j:=1 to n do
Write(a[i,j]:3);
Writeln;
End;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘* * * * * * * * * * * * * * * * *’);
Writeln(‘Ma tran tam giac duoi:’);
For i:=1 to n do
Begin
For j:=1 to i do
write(a[i,j]:3);
writeln;
End;
Writeln(‘* * * * * * * * * * * * * * * * *’);
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘Ma tran tam giac tren:’);
For i:=1 to n do
Begin
For j:=i to n do 8 h 54 m 28/7/2017 42 Begin
Gotoxy(4*(j+1),3+i);
Write(a[i,j],’ ‘);
end;
Writeln;
end;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘ Cac phan tu thuoc duong cheo chinh:’);
for i:=1 to n do
Write(a[i,i]:4);
writeln;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘* * * * * * * * * * * * * * * * *’);
Writeln(‘ Cac phan tu nam PHIA tren duong cheo chinh:’);
for i:=1 to n do
Begin
for j:=i+1 to n do
Begin
Gotoxy(4*(j+1),3+i);
write(a[i,j],’ ‘);
writeln;
End;
End;
Writeln(‘An ENTER de tiep..’); Readln;
clrscr;
Writeln(‘* * * * * * * * * * * * * * * * *’);
t:=0;
for i:=1 to n do
Begin
For j:=i+1 to n do
t:=t+a[i,j];
End;
Write(‘Tong cac phan tu o PHIA tren duong cheo chinh:’,t);
Readln
End.
**12- Cho trước ma trận vuông cấp n. Lập trình làm các việc sau:
a/ In lên màn ma trận tam giác dưới đường chéo chính.
b/ Xem các phần tử thuộc đường chéo chính.
c/ Xem các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA TRÊN.
d/ Tính tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA TRÊN.
e/ Xem các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI.
f/ Tính tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI. 8 h 54 m 28/7/2017 43 TEST. Vào:
49 20 25 12
5 37 19 19
5 43 25 15
3 13 48 8
Ra:
a/ Ma trận tam giác dưới:
49
5 37
5 43 25
3 13 48 8
b/ Các phần tử thuộc đường chéo chính: 49 37 25 8
c/ Các phần tử thuộc đường // đường chéo chính sát ngay phía trên: 20 19 15
d/ Tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA TRÊN:
54
e/ Các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI:
5 43 48
f/ Tổng các phần tử thuộc đường // đường chéo chính SÁT NGAY PHÍA DƯỚI:
96 Program Bt_8;
Uses crt;
Var i,j,n,d,s,s1,s2,ln:integer;
a:array[1..20,1..20] of integer;
Begin clrscr;
Randomize;
s:=0;
Write('Nhap kich co ma tran vuong n='); Readln(n);
for i:=1 to n do
Begin
for j:=1 to n do a[i,j]:=Random(50);
End;
Writeln('Ma tra vua nhap:');
For i:=1 to n do
Begin
For j:=1 to n do
Write(a[i,j]:4);
Writeln;
End;
{ * * * * * * * * * * * * * * * *}
Writeln('Ma tran tam giac duoi:');
For i:=1 to n do
Begin
For j:=1 to i do
write(a[i,j]:4); 8 h 54 m 28/7/2017 44 writeln;
End;
Writeln('* * * * * * * * * * * * * * * * *');
Writeln(' Cac phan tu thuoc duong cheo chinh:');
for i:=1 to n do Write(a[i,i]:4); writeln;
Writeln('* * * * * * * * * * * * * * * * *');
s1:=0;
Writeln(' Cac phan tu thuoc duong // sat ngay PHIA TREN duong cheo chinh:');
For i:=1 to n-1 do
Write(#32:2,a[i,i+1]); Writeln;
Write('Tong cac phan tu thuoc duong // sat ngay PHIA TREN duong cheo chinh:');
For i:=1 to n-1 do
s1:=s1+a[i,i+1];
Write(s1:4); Writeln;
Writeln('* * * * * * * * * * * * * * * * *');
s2:=0;
Writeln(' Cac phan tu nam tren duong // sat ngay PHIA DUOI duong cheo chinh:');
For i:=2 to n do
Write(#32:2,a[i,i-1]); Writeln;
Write('Tong cac phan tu nam tren duong // sat ngay PHIA DUOI duong cheo chinh:');
For i:=2 to n do
s2:=s2+a[i,i-1];
Write(s2:4); Writeln;
Readln;
End.
**13- Cho ma trận vuông cấp n (n đọc từ bàn phím vào). Tìm: a/ Số lẻ lớn nhất DƯỚI ĐƯỜNG CHÉO PHỤ. b/ Tìm ít nhất một số trong ma trận lớn hơn số lẻ lớn nhất ấy+chỉ ra tọa độ của nó. c/ Thống kê số lượng các số lớn hơn số lẻ lớn nhất đã tìm thấy trên đây.
TEST. Vào: 10 12 47 7
5 45 11 39
19 33 29 20
16 19 20 23 Ra: + Số LẺ Max dưới đường chéo phụ=39
+ Tồn tại phần tử lớn hơn số max ở hàng 1, cột 3
+ Tồn tại phần tử lớn hơn số max ở hàng 2, cột 2
+ Số phần tử lớn hơn max là: 2
Program Bt_9;
Uses Crt;
Type mt=array[1..50,1..50] of integer;
Var a:mt; n,i,j,max:byte; 8 h 54 m 28/7/2017 45 8 h 54 m 28/7/2017 46 *14-Cho ma trận vuông cấp n (n đọc từ bàn phím vào). Tìm:
+ Phần tử nhỏ nhất dưới đường chéo chính.
+ Nhập vào tọa độ của phần tử nằm trên đường song song với đường chéo phụ, rồi tính
tổng các phần tử trên đường // này và chứa điểm đó. tử ấy và // với chéo phụ là 17 (=5+12) TEST. Dùng matrix trên đây, ta có kết quả sau:
+ Min dưới đường chéo chính=16
+ Đọc vào tọa độ hàng 1, cột 2 ta được tổng các phần tử trên đường chứa phần
Program Bt_10;
Uses Crt;
Type mt=array[1..50,1..50] of byte;
Var a:mt; n,i,j,k,l,row,col,ans:byte;
min,s:integer;
Procedure Input(Var matrix:mt; ten:char; soh,soc:byte);
Var i,j:byte;
Begin
Randomize;
For i:=1 to soh do
For j:=1 to soc do {matrix[i,j]:=Random(10);}
Begin
Write(ten,'[',i,',',j,']='); Readln(a[i,j]);
End;
End;
Procedure View(matrix:mt; soh,soc:byte);
Var i,j:byte; 8 h 54 m 28/7/2017 47 8 h 54 m 28/7/2017 48 1 2 3 8 7 9
2 3 1 5 4 6
3 1 2 2 3 1 } *16- Cho trước ma trận vuông cấp n. Lập trình kiểm tra xem nó có phải là ma trận La Tinh không. Ma trận
mà tất cả các cột, hàng đều là hoán vị của n số gọi là ma trận LaTinh.
{ Test1: Test2:
Program Check_Mtran_LaTinh;
Uses Crt;
type a=Array[1..30,1..30] of Integer;
Var mt:a; i,j,n,d:Integer;
Function ktrahang(i:integer):Boolean;
Var j,k:integer; check:boolean;
Begin
ktrahang:=false;
For k:=1 to n do 8 h 54 m 28/7/2017 49 8 h 54 m 28/7/2017 50 17- Cho trước ma trận vuông cấp n. . Lập trình kiểm tra xem nó có phải là ma trận đối xứng không. Một ma trận đối xứng là ma trận vuông A bằng chính ma trận chuyển vị của nó.
Mỗi phần tử của một ma trận đối xứng thì đối xứng qua đường chéo. Do vậy, nếu các phần tử được viết
dưới dạng A=a[i,j] thì với mọi i, j ta có: a[i, j]=a[j,i].
{Test1: 1 2 3 Test2: 9 5 7
2 4 -5 3 1 6
3 -5 6 8 4 2 }
Program Check_Symetr_ Matrix;
Uses Crt;
Type a=Array[1..30,1..30] of integer;
Var mt:a;i,j,n,d:integer; tt:byte;
Begin clrscr;
Repeat
Write(' Nhap kich thuoc ma tran vuong n:'); Readln(n);
for i:=1 to n do
for j:= 1 to n do
begin
write(' Nhap phan tu mt[',i,',',j,']=');
Readln(mt[i,j]);
end;
Writeln;
writeln('Ma tran vua nhap:');
Writeln;
for i:=1 to n do
begin
for j:= 1 to n do
write(mt[i,j]:3);
writeln;
end;
writeln;
d:=0;
for i:=1 to n do
for j:= 1 to n do
If mt[i,j]<>mt[j,i] Then Inc(d);
If d>0 Then Write('Ma tra vua nhap Khong Doi Xung.')
Else Write('Ma tran vua nhap Doi Xung.');
Writeln;
Write('More (1/0)?. More --> Press 1, Stop --> Press 0:');
Readln(tt);
Until tt=0;
End.
**18- Tạo ma phương (gọi khác: ma trận kỳ diệu-magic matrix-) bậc lẻ. Đó là ma trận mà tổng các số trên
các hàng bằng nhau = tổng các số trên các cột bằng nhau = tổng các sổ trên hai đường chéo bằng nhau . Ở
mức tổng quát, toán học mới chỉ chứng minh được: chỉ tạo được ma phương bậc LẺ. 8 h 54 m 28/7/2017 51 8 h 54 m 28/7/2017 52 8 h 54 m 28/7/2017 53 5 2 9
8 4 5 4 9 2 } 8 h 54 m 28/7/2017 54 8 h 54 m 28/7/2017 55 56 8 h 54 m 28/7/2017 57 8 h 54 m 28/7/2017 58 8 h 54 m 28/7/2017 59 8 h 54 m 28/7/2017 60 8 h 54 m 28/7/2017 61 Xm: gồm m chữ cái X; 62 8 h 54 m 28/7/2017 63 8 h 54 m 28/7/2017 64 8 h 54 m 28/7/2017 65 8 h 54 m 28/7/2017 66 8 h 54 m 28/7/2017 67 8 h 54 m 28/7/2017 68 8 h 54 m 28/7/2017 69 8 h 54 m 28/7/2017 70 8 h 54 m 28/7/2017 71 8 h 54 m 28/7/2017 72 8 h 54 m 28/7/2017 73 2 6
9 15 CODE.
Uses Crt;
Const fi='CNMAX.IN'; fo='CNMAX.OU';
mn=80; {Do dai toi dai cua xau ky tu}
Var f,g:Text;
ten:string[12];
m:Byte; {Chieu rong manh dat}
d:Longint; { Dem so dong}
x,y:String; {Theo thu tu: dong tren va dong duoi}
h:Array[0..mn] of Longint; { chieu cao ca cot}
dtmax:Longint; { Dien tich max}
axmax, cxmax:Longint; aymax, cymax:Byte; {Toa do diem a,c}
Procedure Ghi;
Begin
Assign(g,fo); Rewrite(g);
Writeln(g,dtmax);
Writeln(g,axmax,#32,aymax);
Writeln(g,cxmax,#32,cymax);
close(g);
end;
Function Dientich(i:Byte; Var c1,c2: Byte):Longint;
Begin
c1:=i;
While (y[c1-1]=y[i]) And (h[c1-1]>=h[i]) Do
Dec(c1);
c2:=i;
While (y[c2+1]=y[i]) And (h[c2+1]>=h[i]) Do
Inc(c2);
Dientich:=h[i]*(c2+1-c1);
End;
Procedure Run;
Var i,c1,c2:Byte; dt:Longint;
Begin
Write('Cho biet ten tep chua data vao:'); Readln(ten);
Assign(f,ten); Reset(f); Readln(f,m);
d:=0;
x:=#32;
For i:=1 to m Do x:=x+#32;
FillChar(h, sizeof(h),0);
While Not Eof(f) Do
Begin 8 h 54 m 28/7/2017 74 **11/ OLYMPIC TIN HỌC QUỐC TẾ NĂM 2000 TẠI BẮC KINH (HỦY ĐI ÍT NHẤT CÁC KÝ TỰ ĐỂ
PHẦN CÒN LẠI CỦA XÂU VẪN LÀ PALINDROM)
Dãy ký tự s gọi là PALINDROM nếu đọc xuôi, đọc ngược nó đều như nhau. Cho trước s độ dài n gồm các
chữ cái hoa, thường (có phân biệt) và các chữ số. Cho biết cần xóa đi ít nhất bao nhiêu ký tự trong s để
phần còn lại của s cũng là một PALINDROM. Giả sử sau xóa các ký tự còn lại của s tự động xích lại gần
nhau.
YÊU CẦU: Dùng 3 cách: ĐẸ QUY; MỘT MẢNG 1-CHIỀU; 2 MẢNG 1-CHIỀU 8 h 54 m 28/7/2017 75 8 h 54 m 28/7/2017 76 8 h 54 m 28/7/2017 77 8 h 54 m 28/7/2017 78 79 80 81 • Mỗi lần chỉ được chuyển 1 đĩa,
• Đĩa nhỏ ở trên đĩa lớn,
• Khi chuyển không được đặt đĩa trên bất cứ mặt bằng nào (mặt bàn, ghế, nền nhà . . .). CODE:
Uses Crt;
var n, count:integer; hoi:char;
Procedure Move(n,c1,c2,c3: integer);
Begin
8 h 54 m 28/7/2017 82 8 h 54 m 28/7/2017 83 8 h 54 m 28/7/2017 84 có n dấu căn. 8.4- S= *8.5- S(n)= trong đó x là số thực GỢI Ý: Nếu như thoạt nhìn, không thấy quy luật dùng đệ quy ở biểu thức đã cho, thì hãy biến đổi toán học
nó sao cho xuất hiện biểu thức dùng được đệ quy.
Chẳng hạn bài 8.5 có vẻ khó nhất với các bạn. Ta biến đổi nó như sau: a) Nhìn vào hệ thức (8.5) ta suy ra: S(n-1) = S(n-2) = b) Tính hiệu S(n) – S(n-1) ta được S(n) = S(n-1) + (*) 8 h 54 m 28/7/2017 85 c) Tính hiệu S(n-1) – S(n-2) ta được (**) Thế (**) vào (*) ta có ngay quy luật để thiết kế đệ quy tính S(n): S(n) = S(n-1) + quy luật đệ quy đã hiện rõ! Việc còn lại (viết code tính S(n)) là việc dễ đối với các bạn!
9- Liệt kê tất cả các dãy nhị phân dài n (n đọc từ bàn phím vào).
Uses Crt;
Var i,n:integer;
b:Array[1..100] of 0..1; tt:byte;
Procedure Result;
Var i: Integer;
Begin
For i:=1 to n Do Write(b[i]:2); Writeln;
End;
Procedure Try(i:Integer);
Var j:Integer;
Begin
For j:=0 to 1 do
Begin
b[i]:=j;
If i=n Then Result Else Try(i+1);
End;
End;
Begin clrscr;
Repeat
Write('Nhap n:'); Readln(n);
Try(1);
Writeln;
Write('Another Test (1/0)?. Come on -> Press 1, Stop -> Press 0:');
Readln(tt);
Until tt=0;
End. *10- Điền các dấu “(“, “)” và 4 phép tính số học vào một biểu thức số học để tính đúng gía trị n cho trước.
Program Dien_dau_phep_tinh;
Uses crt; 8 h 54 m 28/7/2017 86 8 h 54 m 28/7/2017 87 8 h 54 m 28/7/2017 88 89 Uses Crt;
Const chucai=['a','e','i'];
fo='cactu.ou';
Var c:ArrAy[1..5] Of Char;
yes:Boolean;
dem, n:longint;
f:text;
Procedure WriteTo;
Var i:integer;
Begin
{Inc(dem);}
For i:=1 to n Do Write(f,c[i],' ');
Writeln(f);
End;
Procedure Tim(i:Integer);
Var ch:char; nho:Boolean;
Begin
Nho:=yes;
For ch:='a' to 'i' do
Begin
c[i]:=ch;
If ch In chucai then yes:=True;
If (i=n) Then
Begin
If yes then WriteTo
End
Else
Tim(i+1);
yes:=nho;
End;
End;
Begin clrscr;
{Dem:=0;}
Assign(f,fo); Rewrite(f);
For n:=2 to 4 do
Begin
yes:=False;
Tim(1);
End;
{Writeln(f,'So tu da liet ke=',dem);} 8 h 54 m 28/7/2017 90 Close(f);
Write('Done!');
Readln;
End. 14/ Tìm cách xếp 8 quân xe lên bàn cờ tướng 8x8 để không quân nào ăn được nào. Yêu cầu: Mỗi lần xem
từng kết quả một. Xem tiếp gõ ENTER; Thoát gõ CTRL-ECS. Uses Crt;
Const fo='tamxe.ou';
Var f:Text; d:word; line:string;
cx:Array[1..8] Of Boolean;
a:Array[1..8] of Byte;
Procedure WriteOnFile;
Var i:Byte;
Begin
Inc(d);
Writeln(f);
Write(f,'cachh thu ',d,':');
For i:=1 to 8 do Write(f,'[',i,',',a[i],']',';');
End;
Procedure Try(k:Byte);
Var i:Byte;
Begin
For i:=1 to 8 do
If cx[i] Then
Begin
a[k]:=i;
cx[i]:=False;
If k=8 then WriteOnFile Else Try(k+1);
cx[i]:=True;
End;
End;
Begin Clrscr;
d:=0;
FillChar(cx,sizeof(cx),True);
Assign(f,fo); Rewrite(f);
Try(1);
Reset(f);
While Not SeekEof(f) Do
Begin
Readln(f,line);
Writeln(#32:7,line);
If (d MOD 20)=0 Then Readln; {De xem tung dap so mot; Go CTRL-ESC: Thoat}
End;
Close(f); 8 h 54 m 28/7/2017 91 Readln;
End.
= = = = = = = = = = = = = = = = = = 92 93 94 95 96 97 98 8 h 54 m 28/7/2017 99 2 → khách này có số đồ xách tay >5 4 Uses Crt;
Var tepvao,tepra,tephuy: Text;
sum,w: Real; n,i,k:Byte;
Begin Clrscr;
Assign(tepvao,'khachbay.vao'); Reset(tepvao);
Readln(tepvao,n);
Assign(tepra,'trgluong.ra'); Rewrite(tepra);
Assign(tephuy,'huybay.ra'); Rewrite(tephuy);
For i:=1 to n do
Begin
sum:=0; k:=0;
While Not(SeekEoln(tepvao)) Do
Begin
Read(tepvao,w);
8 h 54 m 28/7/2017 100 101 102 103 = = = = = = = = = = = = = = = = = = = 8 h 54 m 28/7/2017 104 8 h 54 m 28/7/2017 105 8 h 54 m 28/7/2017 106 8 h 54 m 28/7/2017 107 8 h 54 m 28/7/2017 108 8 h 54 m 28/7/2017 109 8 h 54 m 28/7/2017 110 8 h 54 m 28/7/2017 111 112 8 h 54 m 28/7/2017 113 8 h 54 m 28/7/2017 114 8 h 54 m 28/7/2017 115 8 h 54 m 28/7/2017 116 8 h 54 m 28/7/2017 117 a- Dòng trên cùng phía phải màn hình có dòng chũ: “Gõ phím bất kỳ để
đổi màu đồng hồ và nền màn hình.
b- Dòng cuối cùng phía trái màn hình hiện thời gian hiện hành.
c- Dòng cuối cùng phía phải màn hình hiện ngày tháng năm hiện thời.
d- Kim giờ và kim phút có dạng hình tứ giác. (giả hình thoi- Quasi Lozenge)
program Draw_Clock;
uses crt,GRAPH,dos;
const
color:array[0..15] of byte=(8,7,3,15,6,14,10,4,2,9,1,12,5,0,13,11);
var
m,co:byte;
col:set of 0..15;
r,xt,yt:word;
e:char;
st:string[10];st1,st2,st3:string[4];
{--------------------------------------------------------------}
procedure init;
var gd,gm:integer;
begin
gd:=0;
initgraph(gd,gm,'..\bgi');
if graphresult<>0 then halt;m:=1;e:=#2;
end;
{--------------------------------------------------------------}
procedure draw_frame;
const
number:array[1..12] of
string[2]=('1','2','3','4','5','6','7','8','9','10','11','12');
dayofweek:array[0..6]of string[3]=('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
var
i,x,y,year,month,day,day_of_week:word;
begin
xt:=getmaxx div 2;yt:=getmaxy div 2;
r:=yt-10;
settextjustify(1,1);
{ve duong vien ngoai cung:}
setcolor(color[13]);
setlinestyle(0,0,3);
rectangle(1,1,getmaxx,getmaxy);
rectangle(3,3,getmaxx-2,getmaxy-2);
{ve duong tron bao dong ho:}
for i:= 0 to 6 do circle(xt,yt,r+3-i);
{to mau nau khoang trong:} 8 h 54 m 28/7/2017 118 m:=(m mod 2)+1;
if odd(m) then co:=1 else co:=1+(color[13] mod 11);
setfillstyle(co,color[4]);
floodfill(xt+r-20,yt+r-20,color[13]);
setfillstyle(1,color[3]);
floodfill(xt,yt,color[13]);
setcolor(color[1]);
setlinestyle(0,0,3);
rectangle(1,1,getmaxx,getmaxy);
rectangle(3,3,getmaxx-2,getmaxy-2);
setfillstyle(1,color[1]);
bar(0,getmaxy-15,getmaxx,getmaxy);
setfillstyle(solidfill,color[13]);
bar(80,getmaxy-15,getmaxx-80,getmaxy);
{hien ngay thang nam o dong duoi cung phai man hinh:}
setfillstyle(solidfill,color[8]);
bar(8,getmaxy-50,170,getmaxy-20);
bar(getmaxx-170,getmaxy-50,getmaxx-8,getmaxy-20);
setfillstyle(1,color[11]);
bar(getmaxx-150,60,getmaxx-10,70);
getdate(year,month,day,day_of_week);
str(day,st1);
str(month,st2);
str(year,st3);
if day<10 then st1:='0'+st1;
if month<10 then st2:='0'+st2;
{settextstyle(4,0,6);
setcolor(color[5]);
outtextxy(getmaxx-80,25,st3);
settextstyle(4,0,4);
setcolor(color[6]);
outtextxy(120,20,' Happy New Year !'); }
settextstyle(0,0,2);
setcolor(color[7]);
for i:=0 to 1 do outtextxy(40+30*i,60,chr(i+3));
setcolor(color[15]);
for i:=2 to 3 do outtextxy(40+30*i,60,chr(i+3));
st:=' ';st:=dayofweek[day_of_week]+','+st1+'.'+st2;
settextstyle(0,0,2);
setcolor(color[9]);
outtextxy(getmaxx-90,getmaxy-35,st);
settextstyle(2,0,1);
setusercharsize(2,3,1,1);
setcolor(color[10]);
outtextxy(getmaxx-80,63,' * Press any key to change color...');
{trang tri ben trong dong ho:}
settextstyle(0,0,1);
setcolor(color[11]);
for i:=1 to 60 do 8 h 54 m 28/7/2017 119 begin
x:=xt+round((r-20)*sin(i*pi/30));
y:=yt-round((r-20)*cos(i*pi/30));
if(i mod 5)<>0 then outtextxy(x,y,chr(1))
end;
settextstyle(0,0,2);
for i:=1 to 12 do
begin
x:=xt+round((r-50)*sin(i*pi/6));
y:=yt-round((r-50)*cos(i*pi/6));
setcolor(color[12]);
outtextxy(x,y,number[i]);
x:=xt+round((r-20)*sin(i*pi/6));
y:=yt-round((r-20)*cos(i*pi/6));
setcolor(color[10]);
outtextxy(x,y,chr(2)); {chr(2)=" "}
end;
{setcolor(color[14]);
outtextxy(xt,yt+100,' CHA DE PASCAL! ');
outtextxy(xt,yt-100,'');
outtextxy(xt,yt-105,' NIKLAUS WIRTH '); }
setcolor(color[2]);
settextstyle(0,0,3);
outtextxy(xt,yt,chr(3)); {chr(3):hinh trai tim}
end;
{------------------------------------------------------}
procedure draw_index(r:word;goc:real;color:byte);
var
x,y,a,b,c:real;
d:array[1..5]of pointtype; {toa do 4 dinh tu giac}
begin
{if goc>=2*pi then goc:=goc-2*pi;}
x:=xt+r*sin(goc);
y:=yt-r*cos(goc);
setcolor(color);
if r>yt-35 then
begin {kim giay}
setlinestyle(0,0,2);
line( xt,yt,round(x),round(y));
setlinestyle(0,0,3);
line(xt,yt,round(xt-r/5*sin(goc)),round(yt+r/5*cos(goc)));
end
else
begin
{ve kim gio hoac kim phut duoi dang hinh tu giac co 4 dinh
toa do 4 dinh chua trong mang d:} 8 h 54 m 28/7/2017 120 d[1].x:=xt;d[1].y:=yt;
a:=(4*xt+x)/5;b:=(4*yt+y)/5;c:=(x-xt)/(yt-y+0.000001);
d[2].x:=round(a-sqrt((100+(r mod (yt-40)))/(1+sqr(c))));
d[2].y:=round(b+c*((a-sqrt((100+(r mod (yt-40)))/(1+sqr(c))))-a));
d[3].x:=round(x);
d[3].y:=round(y);
d[4].x:=round(a+sqrt((100+(r mod (yt-40)))/(1+sqr(c))));
d[4].y:=round(b+c*((a+sqrt((100+(r mod (yt-40)))/(1+sqr(c))))-a));
d[5].x:=xt;
d[5].y:=yt;
drawpoly(5,d); {ve hinh tu giac}
end;
end;
{-------------------------------------------------------}
procedure run;
const
a:array[1..2] of string=('SEE YOU GAIN','!');
var
h,m,s,se,ok:word;
goch,gocm,gocs,g:real;
i,j,k:integer;
nb:boolean;
{------------------------------------------------------}
procedure tinhgoc;
begin
goch:=pi*((h mod 12)/6+m/360+s/4320);
gocm:=pi*(m/30+s/1800);
gocs:=pi*s/30;
if (s=59)and odd(m) then e:='a';
ok:=s;
end;
{-----------------------------------------------------}
procedure draw;
begin
draw_index(r-80,goch,color[11]);
draw_index(r-30,gocm,color[12]);
draw_index(r-20,gocs,color[14]);
end;
{phan phu}
{-----------------------------------------------------}
procedure change;
begin
i:=(i mod k)+1;if i=1 then j:=(j mod 4)+1;
case j of
1:k:=179;
2:k:=186;
3:k:=191;
4:k:=196
end; 8 h 54 m 28/7/2017 121 end; {het phan phu}
Begin
setwritemode(xorput);
gettime(h,m,s,se);
tinhgoc;
draw;
{hien gio o dong duoi cung ben trai man hinh:}
str(h,st1);
str(m,st2);
str(s,st3);st:=' ';
if m<10 then st2:='0'+st2;
if s<10 then st3:='0'+st3;
st:=' ';
st:=st1+':'+st2+':'+st3;
settextstyle(0,0,2);
setcolor(color[9]);
outtextxy(90,getmaxy-35,st);
i:=0;
j:=0;
k:=179;
nb:=false;
repeat
gettime(h,m,s,se);
if ok<>s then
begin
if((m=59)and(s>(58-h)))or((m=29)and(s=59))then nb:=true;
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
settextstyle(0,0,2);
setcolor(color[8]);
outtextxy(90,getmaxy-35,st);
draw;tinhgoc;
{phan phu:co the bo di:}
if (s mod 5)=0 then
begin
if gocs>=2*pi then gocs:=gocs-2*pi;setfillstyle(solidfill,color[2]);
floodfill(round(xt+(r-20)*sin(gocs)),round(yt-(r-20)*cos(gocs)),color[10]);
end;
if ((s-1) mod 5)=0 then
begin
g:=pi*(s-1)/30;
if g>=2*pi then g:=g-2*pi;setfillstyle(solidfill,color[3]);
floodfill(round(xt+(r-20)*sin(g)),round(yt-(r-20)*cos(g)),color[10]);
end;
{het phan phu}
draw;
str(h,st1);str(m,st2);str(s,st3);st:=' ';
if m<10 then st2:='0'+st2;if s<10 then st3:='0'+st3; 8 h 54 m 28/7/2017 122 Begin st:=' ';
st:=st1+':'+st2+':'+st3;
settextstyle(0,0,2);
setcolor(color[9]);
outtextxy(90,getmaxy-35,st);
settextstyle(0,0,1);
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
if nb then
begin
sound(2700);
delay(1000);
nosound;
delay(1000);
sound(2700);
delay(1000);
nosound;
end
else
sound(2700);
delay(750);
nosound;
delay(750);
End;
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
if nb then
Begin delay(750);
sound(2700);
delay(100);
nosound;
delay(750);
End
else
delay(1000);
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
if nb then
Begin 8 h 54 m 28/7/2017 123 nosound;
delay(80); Begin sound(2700); delay(1000);
nosound;
delay(1000); sound(2700);delay(120);
End
else
End;
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
Outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
delay(200);
setcolor(color[13]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
change;
setcolor(color[3]);
outtextxy(getmaxx div 2,getmaxy-7,copy(a[j],i,60));
delay(150);nb:=false;
end; while keypressed do e:=readkey;
until e<>#2;
if e<>#27 then e:=#2;
End;
{------------------------------------------------------}
procedure set_color;
var i:byte;
begin
randomize;
col:=[];
for i:=0 to 15 do
begin
repeat
color[i]:=random(16);
if (i>=11) and (i<=14) then
if (color[i]=0) and not(0 in col) then color[i]:=color[i-1];
until not(color[i] in col);
col:=col+[color[i]]
end;
end;
{------------------------------------------------------}
procedure maker;
begin
clrscr;
gotoxy(30,17); TEXTCOLOR(YELLOW);
write('Press any key to continue...');
window(20,10,60,15); 8 h 54 m 28/7/2017 124 textbackground(lightgray);
clrscr;
textcolor(blue);
writeln;
writeln(' THAY TRAN-THONG-QUE ');
writeln;
writeln(' * * * * * * * * * ');
textcolor(lightgray);
e:=readkey;
end;
begin
maker;
init;
repeat
graphdefaults;
cleardevice;
draw_frame;
run;
set_color;
until e=#27;
closegraph;
end. **8/ Đồ họa hóa bài toán Tháp Hà Nội (Hanoi Tower Problem): Chuyển n đĩa (chỉ nên test với n=3 or n=4)
có lỗ ở giữa từ cọc 1 sang cọc 2 được dùng cọc trung gian. Luật chơi: a- Mỗi lần chỉ chuyển 1 đĩa,
b- Trong lúc chuyển không được đặt đĩa (nghỉ) trên bất cứ chỗ nào (mặt bàn, ghế, sàn nhà…),
c- Đĩa to nằm trên đĩa bé. Uses Crt,Graph;
Type coc=1..3;
Const n=3; yorg=20;xorg:Array[coc] of integer=(13,40,67);
time=5000; time2=4000;
Var dk:Array[1..n,coc] of Integer;
docao:Array[coc] of integer;
i:integer;
Procedure tre(T:integer);
Begin
GotoXY(43,4);
Delay(T);
End;
Procedure MoveUp(c1,c2:Integer);
Var i,j,x:Integer;
Begin
For j:=1 to 4 Do
Begin 8 h 54 m 28/7/2017 125 8 h 54 m 28/7/2017 126 8 h 54 m 28/7/2017 127 CÁC TEST Vị trí tương quan giữa hai vòng tròn Tọa độ tâm & bán kính vòng tròn
R
Y
X Hai vòng tròn rời nhau Hai vòng tròn cắt nhau Hai vòng tròn tiếp xúc ngoài Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2 200
50
200
270
200
350 200
50
200
130
200
200 100
30
100
40
100
50 8 h 54 m 28/7/2017 128 Hai vòng tròn trùng khít nhau 100
100 100 Vòng tròn tròn bé nằm trọn trong vòng
60 tròn to. Dt còn lại của vòng to=2016 100 Vòng tròn bé đồng tâm với vòng tròn to
80 Dt còn lại của vòng to=11310 100 Vòng tròn bé tiếp xúc trong phải với
vòng tròn to. Dt còn lại . . . =23562
50 Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2
Vòng tròn 1
Vòng tròn 2 200
200
200
220
200
200
200
250
200
200 200
200
200
220
200
200
200
200
200
170 100 Vòng tròn bé tiếp xúc trong phía trên với
Vòng tròn to. Dt còn lại . . .=16022
70 Uses Crt, graph;
Const maxx=639; maxy=449;
Var x1,x2,y1,y2,r1,r2:Integer;
Procedure Khung(x1,x2,y1,y2:Integer);
Var i,j: Integer;
Begin
TextBackGround(Blue); TextColor(LightGray);
Gotoxy(x1,y1); Write(#218);
For i:=x1+1 to x2-1 do Write(#196);
Write(#191);
For j:=y1+1 to y2-1 do
Begin
Gotoxy(x1,j); Write(#179);
For i:=x1+1 to x2-1 do Write(' ');
Write(#179);
End;
Gotoxy(x1,y2); Write(#192);
For i:=x1+1 to x2-1 do Write(#196);
Write(#217);
End;
Function Doc(min,max:Integer):Integer;
Var n:Integer; {min 8 h 54 m 28/7/2017 129 8 h 54 m 28/7/2017 130 8 h 54 m 28/7/2017 131 8 h 54 m 28/7/2017 132 8 h 54 m 28/7/2017 133 8 h 54 m 28/7/2017 134 8 h 54 m 28/7/2017 135 8 h 54 m 28/7/2017 136 8 h 54 m 28/7/2017 137 8 h 54 m 28/7/2017 138 8 h 54 m 28/7/2017 139 8 h 54 m 28/7/2017 140 = = = = = = = = = = = = = = = = = = = = = = (Nếu quên OR lơ mơ về lý thuyết một vấn đề nào đó, các bạn nên đến thư viện – để mất ít tiền nhất- xem
quyển: LÝ THUYÊT ĐỒ THỊ, nxb GIÁO DỤC 2012. Tác giả: Trần Thông Quế)
A/ CÁC THUẬT TOÁN TÌM KIẾM (DUYỆT) TRÊN ĐỒ THỊ.
1-Hãy cài đặt trực quan (đồ họa hóa code) hai thuật toán DBF và BFS trên cùng một bản Code (BÀI CƠ
BẢN NHƯNG KHÔNG DỄ!).
Yêu cầu: * Gõ ENTER để chuyển từ thuật toán DFS sang BFS và ngược lại,
* Gõ ESC để thoát CODE: PROGRAM DFS_BFS_SEARCH;
USES CRT,GRAPH;
CONST R=15;DL=500;N=8;VC=100; {KHONG CO DUONG DI THI DAT VO CUC VC=100}
C:ARRAY[1..8] OF INTEGER=(150,330,450,450,330,150,30,30);
D:ARRAY[1..8] OF INTEGER=(30,30,150,330,450,450,330,150);
CL:ARRAY[0..3] OF WORD=(BLUE,YELLOW,WHITE,WHITE);
NL:ARRAY[0..3] OF WORD=(YELLOW,BLUE,RED,BLACK);
TYPE CSD=0..VC;
AR=ARRAY[CSD] OF CSD;
QUEUE=RECORD
REAR:CSD;
ELEMENT:AR;
END;
VAR G:ARRAY[CSD,CSD] OF BOOLEAN; 8 h 54 m 28/7/2017 141 8 h 54 m 28/7/2017 142 8 h 54 m 28/7/2017 143 (*--------------------------*)
PROCEDURE BFS; {DUYET THEO CHIEU RONG}
BEGIN
FOR U:=1 TO N DO P[U]:=VC;
K:=0;
FOR U:=1 TO N DO IF P[U]=VC THEN
BEGIN
K:=(K+1) MOD 4;
VE_GR_BFS(U);DELAY(DL)
END;
END;
(*--------------------*)
PROCEDURE VE_DT_DFS(U:CSD); {HIEN THI DO THI DE DUYET THEO CHIEU SAU} 8 h 54 m 28/7/2017 144 8 h 54 m 28/7/2017 145 1 2 3 4 8 7 6 5 Các màu tô được ký hiệu bởi 8 số nguyên dương đàu tiên (xem hình ngay trên) viết lần lượt theo chiều kim
đồng hồ, bắt đầu từ ô góc trên cùng trái và kết thúc ở ô góc dưới cùng trái.
Một cấu hình như trên gọi là cấu hình ban đầu. Ta thực hiện 3 phép biến đổi cơ bản ký hiệu là ‘A’, ‘B’, ‘C’
để tác động lên cấu hình của bảng, trong đó:
• ‘A’: Đổi chỗ dòng trên và dòng dưới
• ‘B’: Thực hiện phép hoán vị theo chiều sang phải vòng quanh bảng.
• ‘C’: Quay theo chiều kim đồng hồ 4 ô ở giữa
Mọi cấu hình đều có thể được tác động bởi 3 phép biến đổi cơ bản nói trên. Và tác động của 3 phép biến đổi
cơ bản ấy mô tả bởi hình dưới đây: (Ở MỖI BỘ DATA DƯỚI ĐÂY CÁC SỐ TRÊN CÙNG VÀ DƯỚI
CÙNG LÀ VỊ TRÍ CÁC Ô CỦA BẢNG) BẢNG 1 1 2 3 4 INDEX của các ô 1 2 3 4 8 7 6 5 8 7 6 5 INDEX của các ô BẢNG 2 4 1 2 3 6 7 8 5
8 h 54 m 28/7/2017 146 BẢNG 3 1 7 2 4 8 6 3 5 Các số ghi ở ngoài bảng chỉ vị trí các ô của bảng. Nếu một ô ở vị trí p chứa số i thì có nghĩa là sau khi làm
phép biến đổi tương ứng, ô vuông mà vị trí trước lúc biến đổi của nó là i sẽ được chuyển đến vị trí p.
a) Hãy viết program tìm dãy các phép biến đổi để đưa cấu hình ban đầu về một cấu hình đích cho trước.
b) Bạn sẽ được thêm 2 điểm nếu số phép biến đổi của bạn không quá 300
* Dữ liệu vào cất trên text file Data.in gồm:
- Một dòng duy nhất chứa 8 số nguyên mô tả cấu hình đích.
* Kết quả ghi lên text file Data.ou:
-Dòng đầu tiên ghi số các phép biến đổi L
- Tại L dòng tiếp theo ghi ký hiệu các phép biến đổi đã nói trên theo TRÌNH TỰ mà program của bạn đã
thực hiện MỘT VÍ DỤ CỤ THỂ CỦA BÀI TOÁN NÀY CHO DƯỚI ĐÂY
Data.In
2 6 8 4 5 7 3 1 Data.Ou
7
B
C
A
B
C
C
B Program MagicSquare; {BAI NAY DUYET DO THI THEO BFS)
Uses crt;
Const kt=8; m=40320; fi='Data.In'; fo='Data.Ou';
Type Bd=array[1..kt] of 1..kt; Ht=array[1..kt] of 1..kt;
Const thuan:Array['A'..'C'] Of Bd=((8,7,6,5,4,3,2,1),(4,1,2,3,6,7,8,5),
(1,7,2,4,5,3,6,8)); {Cac b_doi co ban}
nguoc:Array['A'..'C'] of Bd=((8,7,6,5,4,3,2,1),(2,3,4,1,8,5,6,7),
(1,3,6,4,5,7,2,8)); {Nguoc cua b_doi}
dau:Ht=(1,2,3,4,5,6,7,8); {Trang thai ban dau}
Var dic:Ht; {Bien luu trang thai dich}
s:String; {Day cac b_doi dua tr_thai dau den tr_thai dich}
fact:Array[0..kt] of Longint; {mang luu tu 0! den 8!}
last:Array[0..m] of Char; {last[sh(dic)] la ky tu cuoi cung cua day cac}
{b_doi dua trang thai dau ve trang thai dich}
{Neu last[sh(dic)]=' ' thi dich cung rong (tuc dich khong duoc sinh}
Procedure Nhap;
Var tepvao:text; i:word;
Begin 8 h 54 m 28/7/2017 147 Procedure Facto; {Tinh giai thua}
Var i:word;
Begin
fact[1]:=1; fact[0]:=1;
For i:=2 to kt Do
fact[i]:=i*fact[i-1];
End; Function sh(p:Ht):Word; {ham sh de tinh so hieu cua mot hoan vi bat ky}
Var res, L, i,j:Word;
Begin
res:=0;
For i:=1 to kt Do
Begin
L:=0; {L- so cac phan tu cua p o cac vi tri tu 1->i-1 nhỏ hơn p[i]}
For j:=1 to i-1 Do
If p[j] 8 h 54 m 28/7/2017 148 8 h 54 m 28/7/2017 149 13 10
1 2
1 3
2 3
4 5
4 7
5 6
8 9
10 12
11 12
12 13 Kết quả lưu trên file Xuat.kq CODE: Để đạt được mục tiêu đề bài ta duyệt đồ thị Đệ quy theo DFS 8 h 54 m 28/7/2017 150 Procedure Nhap;
var f:text; i,j:integer;
Begin
Assign(f,fi); Reset(f);
Read(f,n);
FillChar(a,sizeof(a),0); {khoi tri cho mang a}
While not seekeof(f) do {tao ma tran luu dinh dau va cuoi cua moi canh}
Begin
Read(f,i);
While not seekeoln(f) do
Begin
Read(f,j);
a[i,j]:=1;
a[j,i]:=1;
End;
Readln(f);
End;
Close(f);
End; Procedure DFS(i:integer);
Var j:integer;
Begin
For j:=1 to n do
If v[j]=0 then {neu j chua thuoc mien lien thong nao thi}
If a[i,j]=1 then {neu j ke voi i thi }
Begin
v[j]:=sm; {ghi nho dinh j cung mien lth sm voi i}
DFS(j); {duyet tiep do thi theo chieu sau tu dinh j}
End;
End; Procedure Xuly;
Var s:integer;
Begin
FillChar(v,sizeof(v),0);
sm:=0;
For s:=1 to n do
8 h 54 m 28/7/2017 151 Procedure ghikq;
var f:text; i,j:integer;
Begin
Assign(f,fo); Rewrite(f);
Writeln(f,'So mien lien thong la:',sm);
For i:=1 to sm do
Begin
For j:=1 to n do
If v[j]=i then
Write(f,j,' ');
Writeln(f,'<-- Day la cac dinh o mien Lt thu ',i);
End;
close(f);
End; Procedure Inkq;
var f:text; line:string[50];
Begin
Assign(f,fo); Reset(f);
While not seekeof(f) Do
Begin
Readln(f,line);
Writeln(line);
End;
Close(f);
End;
Begin clrscr;
Nhap;
Xuly;
Ghikq;
Inkq;
Writeln;
Write('Go ENTER de thoat!');
Readln;
End. 8 h 54 m 28/7/2017 152 Kết quả lưu trên file LTH_MAMH.OU CODE: (Về duyệt đồ thị, bài này cũng dùng DFS)
Program Tarjan_Alg;
Uses crt;
Const fi='LTH_MANH.IN'; fo='LTH_MANH.OU';
Type lk=^nut;
nut=record
s:word;
next:lk;
End;
cay=array[0..200] of lk;
m1=array[0..200] of word;
Var sv,id,m,n,top:word; {m:so dinh; n:so canh}
Num,Low,p,s:m1; dsk:cay;
f:Text; Procedure Nhap;
Var i,u,v: word; t:lk;
Begin
Assign(f,fi); Reset(f);
Readln(f,m,n); {doc so dinh m, so canh n tu tep vao cac bien nho m,n}
For i:=1 to n Do
Begin
Readln(f,u,v);
New(t);
8 h 54 m 28/7/2017 153 Function min(u,v:word):word;
Begin
If u Procedure DFS(i:word);
Var j:word; t:lk;
Begin
Inc(id);
Num[i]:=id;
Low[i]:=Num[i];
t:=dsk[i];
Inc(top);
s[top]:=i;
While Not (t=Nil) Do
Begin
j:=t^.s;
If p[j]=0 then
If Num[j]=0 then
Begin
DFS(j);
Low[i]:=min(Low[i], Low[j]);
End
Else Low[i]:=min(Low[i], Num[j]);
t:=t^.next;
End;
If Low[i]=Num[i] then
Begin
Inc(sv);
Repeat
j:=s[top]; {lay 1 phan tu ra khoi Stack tai dinh, luu vao j}
dec(top); {Khi do so phan tu o Stack giam di mot}
p[j]:=sv;
Until i=j;
End;
End; Procedure Visit;
var i:word;
Begin
For i:=1 to m do 8 h 54 m 28/7/2017 154 Procedure Xuat;
Var i,j:word;
Begin
Assign(f,fo); Rewrite(f);
Writeln;Writeln;
Writeln(f,'So mien lien thong la:',sv);
For i:=1 to sv Do
Begin
For j:=1 to m Do
If p[j]=i then write(f,j,' ');
Writeln(f,'-> Cac dinh thuoc mien lien thong thu ',i,'.');
End;
Close(f);
end; Procedure Inkq;
Var f:Text;line:String;
Begin
Assign(f,fo); Reset(f);
While Not SeekEof(f) Do
Begin
Readln(f,line);
Writeln(line);
End;
Close(f);
End; { Main Program }
Begin clrscr;
Nhap;
Visit;
Xuat;
Inkq;
Readln;
End. B.3) BÀI TOÁN TÔ MÀU ĐỒ THỊ
5- Hãy dùng số màu ít nhất để tô màu đồ thị có N đỉnh, sao cho hai đỉnh BẤT KỲ KỀ NHAU phải được tô
bằng màu KHÁC NHAU.
Yêu cầu:
1-Đồ họa hóa Code
2-Cấu trúc đồ thị tự động thay đổi nhờ nhấn phím ENTER; nhấn ESC để thoát.
CODE:
PROGRAM COLOR_GRAPH; 8 h 54 m 28/7/2017 155 8 h 54 m 28/7/2017 156 8 h 54 m 28/7/2017 157 8 h 54 m 28/7/2017 158 9 Số đỉnh của đồ thị (Bắt buộc phải có dữ liệu này!)
0 1 1 0 0 0 0 0 0
1 0 1 0 0 0 0 0 0
1 1 0 1 0 1 0 0 0
0 0 1 0 1 0 0 0 0
0 0 0 1 0 1 0 1 1
0 0 1 0 1 0 1 1 0
0 0 0 0 0 1 0 1 0
0 0 0 0 1 1 1 0 1
0 0 0 0 1 0 0 1 0 CODE:
Program Duongdi_Euler;
uses crt;
Label L1;
Const max=30;
Type mg1=array[1..max,1..max] of byte;
mg2=array[1..max] of boolean;
mg3=array[1..max] of integer;
Var c:mg1; check:mg2; i,j,u,n,dem1,dem:integer;
f:text; tf:string[12]; Function l_thg(u,v:integer; ktra:mg2):integer;
var i,j,d,k,l:integer; p:mg3;
Begin
c[u,v]:=0; c[v,u]:=0;
For i:=1 to n do p[i]:=0;
d:=0;
For i:=1 to n do
Begin
If (p[i]=0) and ktra[i] then
Begin
Inc(d); p[i]:=d;
for j:=1 to n do
for L:=1 to n do
If (p[j]=0) and ktra[j] and (p[L]=d) and (c[L,j]=1) then
p[j]:=d;
End;
End;
c[u,v]:=1; c[v,u]:=1;
L_thg:=d;
End; 8 h 54 m 28/7/2017 159 7- Tìm và hiển thị chu trình EULER trên đồ thị biểu diễn bởi danh sách liệt kê cạnh. Yêu cầu: Program phải
chạy được cả với đồ thị vô hướng và đồ thị có hướng (đồ thị vô hướng: gõ 0; đồ thị có hướng: gõ 1).
Test1: Dùng file vào DTEUL.IN 8 h 54 m 28/7/2017 160 B) ĐỒ THỊ HAMILTON
8- Tìm và hiển thị đường đi Hamilton trên đồ thị vô hướng được biểu diễn bởi danh sách liệt kê cạnh.
Test1: Dùng file vào DTEUL.IN
4 5
1 2
1 4
2 3
2 4
3 4
Test 2: Dùng file vào EU1.IN
5 6
1 2
1 5
2 5
3 4
3 5
4 5 9/ (Bài này bạn thử test với ma trận kề của đồ thị) Tìm và liệt kê chu trình Hamilton trên đồ thị được biểu
diễn bởi ma trận kề dưới đây. 8
0 1 1 1 0 0 0 0
1 0 0 0 1 0 0 0
1 0 0 1 1 0 0 0
1 0 1 0 0 1 1 0
0 1 1 0 0 1 0 1
0 0 0 1 1 0 1 0
0 0 0 1 0 1 0 1
0 0 0 0 1 0 1 0 8 h 54 m 28/7/2017 161 Procedure Xuly;
Label l1;
Var t:integer; ktra:boolean;
Begin
ktra:=true;
For t:=1 to n-1 Do
If c[p[t],p[t+1]]=0 then
Begin
ktra:=False;
goto L1;
End;
If c[p[n],p[1]]=0 then ktra:=False;
L1:If ktra then
Begin
d:=d+1;
Write(f2,'Chu trinh Hamilton thu ',d,' la:');
For t:=1 to n Do Write(f2,p[t]:3);
Writeln(f2);
End;
End; Procedure test(k:integer);
Var i1,j:integer;
Begin
For j:=1 to n do
If b[j] then
Begin
p[k]:=j; b[j]:=False;
If k=n then xuly Else test(k+1);
b[j]:=True;
End;
End;
{Main Prog.}
Begin clrscr;
Assign(f1,'CtHamil.Inp'); Reset(f1);
Assign(f2,'CtHamil.Out'); Rewrite(f2);
Readln(f1,n);
For i:=1 to n do
For j:=1 to n do Read(f1,c[i,j]); 8 h 54 m 28/7/2017 162 10/ CHU TRÌNH HAMILTON TRÊN ĐỒ THỊ CÓ TRỌNG SỐ: Bài toán KINH ĐIỂN nổi tiếng:
TRAVELLING SALESMAN PROBLEM. Không hề ảnh hưởng đến nội dung và cách giải bài toán, ta gọi
bài toán này là bài toán NGƯỜI DU LỊCH. Một nước có N địa điểm du lịch được đánh số từ 1 đến N. Giữa hai địa điểm bất kỳ có thể có đường đi hoặc
không. Giữa hai địa diểm i, j có đường đi thì giá đi (bằng ô tô chẳng hạn) du lịch giữa chúng là những số
nguyên C(i,j)>0. Nói chung C(i, j) khác C(j, i). Khách du lịch xuất phát từ địa điểm k ,muốn tham quan tất
cả các địa điểm, mỗi địa điểm đúng 1 lần, rồi quay về k (k 6
0 3 0 4 0 0
3 0 4 0 2 0
0 4 0 0 1 1
4 0 0 0 1 5
0 2 1 1 0 5
0 0 1 5 5 0
1 6 CODE: Program Nguoi_Dulich; { chu trinh Hamilton tren do thi co trong so}
Uses crt;
Const sd=10;
fi='HMT.VAO'; fo='HMT.RA';
Type m1=Array[1..sd,1..sd] of Integer;
m2=Array[1..sd] of Integer;
m3=Array[1..sd] of Boolean;
Var c:m1;
a,x:m2;
d:m3;
n,cmin,sum,maxsum,dem:Integer; Procedure Nhap;
Var f:text; x,i,j:Integer;
Begin
Assign(f,fi); Reset(f);
Readln(f,n);
cmin:=maxint;
For i:=1 to n do
8 h 54 m 28/7/2017 163 Procedure Tim_Chiphi_Min;
Begin
If sum+c[a[n],a[1]] 8 h 54 m 28/7/2017 164 1- Một đồ thị vô hướng CÓ TRỌNG SỐ được biểu diễn bởi danh sách liệt kê cạnh dưới
đây (Lưu trên text file DATA.VAO có cấu trúc dưới đây). Lập trình tìm và hiển thị
đường ngắn nhất từ đỉnh cho trước bất kỳ đến đỉnh đích tùy chọn trên đồ thị ấy. 5 9 5 đỉnh, 9 cung: bắt buộc phải ghi ở đây
1 2 1 8 h 54 m 28/7/2017 165 1 5 9
2 3 2
2 4 5
3 4 1
3 5 2
4 3 7
5 2 8
5 4 10 CODE: {Chuong trinh nay Test tren tep DATA.VAO}
Program Min_Path;
Uses crt;
Const max=50;
Type contro=^ct;
ct=record
bd:byte; {Dinh bat dau}
lk:contro;
End;
Var n,m,xp,dich:integer;
tt:boolean;
v,dau,cuoi,len:Array[1..max] of integer;
FileName:String;
Procedure Data_Inp(Filename:String);
Var i:byte; f:Text;
Begin
Assign(f,FileName); Reset(f);
Readln(f,n,m);
For i:=1 to m do Readln(f,dau[i],cuoi[i],len[i]);
Close(f);
Writeln('Do thi dang xet co ',n,' dinh va ',m,' cung');
For i:=1 to m do
Writeln('Canh ',dau[i],'-->',cuoi[i],' co trong so=',len[i]);
End;
Function MemCheck(x:byte):contro;
Var p:contro;
Begin
New(p);
If p=Nil Then 8 h 54 m 28/7/2017 166 Begin
Writeln('Thieu bo nho!'); Halt;
Readln;
End;
p^.bd:=x;
MemCheck:=p;
End;
Procedure PathMin_Find;
Var ds,p:contro; i,d,x:byte;
Begin
x:=dich; ds:=Nil; d:=v[x];
While (x<>xp) Do
For i:=1 to m do
If cuoi[i]=x Then
If (v[dau[i]]<>-1) and (v[dau[i]]+len[i]=v[x]) Then
Begin
v[x]:=-1;
x:=dau[i];
p:=MemCheck(x);
p^.lk:=ds; ds:=p;
Break;
End;
p:=ds;
While p<>Nil Do
Begin
Write(p^.bd,'-->'); p:=p^.Lk;
End;
Writeln(dich,' voi do dai min=',d);
End;
Procedure Init;
Var i:Byte;
Begin
For i:=1 to n do v[i]:=-1;
End;
Procedure LastProces;
Var tt:boolean; j,x,y:byte;
Begin
tt:=True;
While tt Do 8 h 54 m 28/7/2017 167 Begin
tt:=False;
For j:=1 to m do
Begin
x:=dau[j]; y:=cuoi[j];
If v[x]<>-1 Then
Begin
If (v[y]=-1) Or (v[x]+len[j] 8 h 54 m 28/7/2017 168 CODE: Program Ford_Bell_Algo;
Uses Crt;
Const fi='sl.vao'; fo='sl.ra'; max=100;
vocuc=100*50*maxint; {=163835000}
Type m1=array[1..max,1..max] of longint;
m2=array[1..max] of longint;
m3=array[1..max] of byte;
Var a:m1;v:m2; t:m3;
m:integer; n,x,y:byte;
Procedure Input;
Var f:Text; k,w:integer;
i,j:byte;
Begin
assign(f,fi); reset(f);
Fillchar(a,sizeof(a),0); Readln(f,n,m,x,y);
For k:=1 to m do
Begin
Readln(f,i,j,w);
a[i,j]:=w; a[j,i]:=w;
End;
close(f);
End;
Procedure init;
var i,j:byte;
Begin
For i:=1 to n do
For j:=1 to n do
If a[i,j]=0 then a[i,j]:=vocuc;
For i:=1 to n do v[i]:=a[x,i]; v[x]:=0;
FillChar(t,sizeof(t),0);
End; 8 h 54 m 28/7/2017 169 Procedure Ford_Bellman;
Var i,j,k:byte; stop:boolean;
Begin
for k:=1 to n-1 do
Begin
stop:=true;
For i:=1 to n do
For j:=1 to n do
If j<>x then
If v[j]>v[i]+a[i,j] then
Begin
v[j]:=v[i]+a[i,j];
t[j]:=i;
stop:=false;
End;
If stop then break;
End;
End;
Procedure Xuat;
var f:text; kq:m3; i,j:byte;
Begin
Assign(f,fo); Rewrite(f);
If v[y]=vocuc then
Begin
Writeln(f,-1);
close(f);
halt;
End;
Writeln(f,v[y]);
i:=y;
j:=0;
Repeat
Inc(j);
kq[j]:=i;
i:=t[i];
Until i=0;
Assign(f,fo); Reset(f);
While Not SeekEof(f) Do
For i:=j Downto 1 do Writeln(f,kq[i]);
close(f);
End; 8 h 54 m 28/7/2017 170 Begin clrscr;
input;
init;
Ford_Bellman;
xuat;
Write('DONE!');
readln
End.
VIII.-3.3) THUẬT TOÁN FLOYD-WARSHALL: Tìm đường ngắn nhất giữa mọi
cặp đỉnh thông qua các đỉnh TRUNG GIAN trên đồ thị có trọng số.
3-ĐỒ HỌA HÓA code cho thuật toán trên. Yêu cầu: a) Gõ ENTER để thay đổi cấu trúc đồ thị,
b) Gõ SPCE: tìm tiếp,
c) Gõ ESC: Thoát. CODE:
Program Floyd_Warshall_Alg;
uses crt,graph;
const r=15;dl=500;n=5;vc=200;vocuc=10000;
c:array[1..5]of integer =(240,460,350,130,20);
d:array[1..5] of integer=(20,240,460,460,240);
ec:array[1..10] of integer =(350,276,204,130,405,295,240,240,185,75);
ed:array[1..10] of integer=(130,166,166,130,360,360,240,460,360,360);
var g,p,a:array[1..n,1..n] of integer;
dau,cuoi:integer;
Procedure initgr;
var gd,gm:integer;
begin
gd:=detect;
initgraph(gd,gm,'..\bgi');
if (graphresult<>grok) then
begin
writeln('Loi khoi tao do hoa,go enter ket thuc!');
readln;
halt(1);
end
end;
8 h 54 m 28/7/2017 171 172 173 174 175 Dữ liệu vào lưu trên text file với tên TauHoa.Vao gồm các đại lượng n, m, s, t, d, số
hành trình và ma trận tij. Dữ liệu ra lưu trên text file với tên TauHoa.Ra gồm thời gian
đến d sớm nhất và số lần chuyển tàu ít nhất. TL2/ Một toà nhà cao tầng có n thang máy. Mỗi thang máy nối liền đúng 2 tầng với nhau
và không dừng lại ở những tầng nằm giữa 2 tầng này. Vận tốc của các thang máy là
như nhau: 5 giây qua một tầng.
Thời điểm bắt đầu, mỗi thang máy đều ở tầng thấp và chúng cùng bắt đầu di
chuyển lên tầng trên. Sau khi tới tầng trên, ngay lập tức lại chuyển xuống tầng dưới,
rồi lại lên tầng trên, và cứ lặp lại như thế ...
An đang ở tầng 1 (tầng thấp nhất) và muốn nhanh chóng lên tầng trên cùng của toà
nhà. Anh ta thay đổi thang máy chỉ trên những tầng chung của 2 thang máy và nếu thang
máy kia tại thời điểm này cũng tới tầng này thì việc chuyển thang máy khi đó coi như
không tốn thời gian. Hãy lập trình tính thời gian ít nhất để An có thể lên tới tầng trên
cùng của toà nhà. Dữ liệu vào cất trên text file với tên Lift.In gồm:
Dòng đầu tiên chứa 2 số nguyên dương K, N cách nhau ít nhất một dấu cách, là số tầng và số thang máy của toà nhà (2 K 1000; 1 N 50000). Trên mỗi một N dòng tiếp theo ghi 2 số nguyên dương A, B (cách nhau một
dấu cách) mô tả một thang máy di chuyển giữa 2 tầng A, B (1 A < B K). nhau. — Dữ liệu vào đảm bảo luôn luôn tồn tại nghiệm.
Kết quả ghi lên text file với tên Lift.Ou gồm: chỉ một dòng ghi thời gian ít nhất
mà An có thể di chuyển lên tầng trên cùng của toà nhà. Ví dụ: Xem 2 bộ dữ liệu
dưới đây: 8 h 54 m 28/7/2017 176 Lift1.In
10 4
1 5
5 10
5 7
7 10 45 Lift1.Ou
Lift2.In Lift2.Ou
20 5 150 1 7
7 20
4 7
4 10
10 20
TL3/ Cho số nguyên k (0 < k 255) và n xâu ký tự có cùng độ dài L chỉ gồm các chữ
cái thường (0 < n 100) và (0 < L 255) là S1, S2,..., Sn. đôi một khác nhau. Hãy
tìm xâu Smin nhỏ nhất thoả mãn tính chất sau: tồn tại k vị trí khác nhau trong xâu
Smin là các vị trí xuất hiện của một trong các xâu S 1, S2,..., Sn. Ta gọi p là vị trí xuất
hiện của xâu S trong Smin nếu giá trị của hàm Copy(Smin, p, L) = S. Dữ liệu vào cất trên text file với tên Str.In gồm : Dòng đầu ghi n, L, k :
n dòng tiếp theo, dòng thứ i ghi xâu Si:
Kết quả ghi lên text file với tên
Str.Ou gồm :
Dòng đầu tiên ghi độ dài nhỏ nhất:
Dòng thứ 2 ghi xâu Smin thoả điều
kiện đầu bài (xem 2 file bên).
k dòng tiếp theo, mỗi dòng ghi 2 số u, p cho biết sự xuất hiện của xâu S u tại p trong xâu Smin. Một ví dụ cụ thể cho dưới đây: Str.In Str.Ou
2 10 2 17
aaaaaaaxyz aaaaaaaxyzabcdefg
xyzabcdefg 1 1
2 8 8 h 54 m 28/7/2017 177 Đến nay có 2 thuật toán giải bài này: thuật toán KRUSCAL & thuật toán PRIM.
5- CÀI ĐẶT THUẬT TOÁN KRUSCAL
a) Tổ chức Data: Cấu trúc của đồ thị cho trước được biểu diễn bởi danh sách liệt kê cạnh dưới đây (các số cách nhau một ký tự trống): 9 14 9: số đỉnh; 14: số cạnh
1 2 4
1 8 8
2 3 6
2 8 11
3 4 7
3 6 4
3 9 2
4 5 9
4 6 14 8 h 54 m 28/7/2017 178 5 6 10
6 7 2
7 8 1
7 9 6
8 9 7
b) CODE:
Program Krusal_Alg;
Uses crt;
Const fi='KRUSCAL.IN'; fo='KRUSCAL.OU'; ln=50;
Type bg=Record
x,y:byte; {x-ding dau, y-dinh cuoi cua canh}
c:integer; {c la trong so tren cac canh cua do thi}
End;
Var m,t:longint; n,count:Integer; {t- de luu tong trong so cua CKmin}
g:text; {count-dem so canh cua CKmin}
a:Array[1..ln*ln DIV 2] of bg;
b:Array[1..ln] of integer;
line:string[4];
Procedure doc; {ct con nhap du lieu vao ct}
Var f:text; i:Integer;
Begin
Assign(f,fi); Reset(f);
Readln(f,n,m);
For i:=1 to m Do
Readln(f,a[i].x,a[i].y,a[i].c);
close(f);
End;
Procedure Saptang;
Var i,j:integer; c:bg;
Begin
For i:=1 to m-1 do
For j:=i+1 to m do
If a[i].c>a[j].c then {dung c lam bien trung gian luon}
Begin c:=a[j];a[j]:=a[i]; a[i]:=c; End;
End;
Function Root(x:integer):Integer; {xac dinh dinh goc la dinh x cho cay} 8 h 54 m 28/7/2017 179 Var i:integer;
Begin
i:=x;
While b[i]>0 Do i:=b[i];
Root:=i;
End;
Procedure Hopnhat(x,y:integer); {Hop nhat cac dinh o 2 mien biet lap}
Var tg:integer;
Begin
tg:=b[x]+b[y];
If b[x]>b[y] Then
Begin
b[x]:=y;
b[y]:=tg;
End
Else
Begin
b[y]:=x;
b[x]:=tg;
End;
End;
Procedure Ck_crea; {kien tao dan dan cay khung min}
Var f:Text; i:longint; x,y,t1,t2:Integer;
Begin
t:=0; count:=0;
Doc;
Saptang;
For i:=1 to n Do b[i]:=-1;
For i:=1 to m Do
Begin
If count=n-1 Then Exit;
x:=a[i].x;
y:=a[i].y;
t1:=Root(x);
t2:=Root(y);
If t1<>t2 Then
Begin
Hopnhat(t1,t2);
Writeln(g,x,' ',y); 8 h 54 m 28/7/2017 180 Inc(count);
t:=t+a[i].c;
End;
End;
End;
Begin clrscr;
Assign(g,fo); Rewrite(g);
Ck_crea; Writeln;
Writeln('Tap hop cac canh cua Cay_khung_min dang xet:');
{Write(g,t);}
Close(g);
Reset(g);
While Not SeekEof(g) Do
Begin
Readln(g,line);
Writeln(line);
End;
Writeln;
Writeln('Va tong trong so cua cay_khung_min nay=',t);
Readln
End.
6) CÀI ĐẶT THUẬT TOÁN PRIM
a-Tổ chức dữ liệu:
Cấu trúc của đồ thị cho trước được biểu diễn bởi danh sách liệt kê cạnh dưới đây:
và lưu tren text file PRIM.IN (các số trên mỗi dòng cách nhau một ký tự trống):
9 14 9: số đỉnh; 14: số cạnh
1 2 4
1 8 8
2 3 6
2 8 11
3 4 7
3 6 4
3 9 2
4 5 9
4 6 14
5 6 10
6 7 2
7 8 1 8 h 54 m 28/7/2017 181 7 9 6
8 9 7 b- CODE: Program Prim_Algol;
Uses crt;
Const Ln=50; fi='PRIM.IN'; {fi=Tep luu data vao}
fo='Ra.kq'; { Tep ghi ket qua cua chuong trinh}
Type m1=Array[1..Ln,1..Ln] of integer;
m2=Array[1..Ln] of integer;
Var a:m1; {mang ghi nho trong so cua do thi}
d:m2; {mang ghi nho dinh da nap vao cay khung nho nhat}
d1,d2:m2; {mang ghi nho cac canh cua cay khung nho nhat}
n,tong:Integer;
Procedure Doc;
Var f:text; i,j,x:Integer;
Begin
Assign(f,fi); Reset(f); Readln(f,n);
While Not SeekEof(f) Do
Begin
Readln(f,i,j,x);
a[i,j]:=x;
a[j,i]:=x;
End;
Close(f);
End;
Procedure Timcanhmin(Var i,j:Integer);
Var x,y,wmin:Integer; {wmin: trong so nho nhat}
Begin
wmin:=Maxint;
For x:=1 to n Do
If d[x]=1 Then
For y:=1 to n Do
If d[y]=0 then
If (a[x,y]>0) and (a[x,y] 8 h 54 m 28/7/2017 182 End;
End;
Procedure TtPrim;
Var i,j,k:Integer;
Begin
For i:=1 to n Do d[i]:=0;
d[1]:=1;
For k:=1 to n-1 do
Begin
Timcanhmin(i,j);
d[j]:=1; {danh dau dinh j da duoc nap vao cay khung}
d1[k]:=i; {luu dinh dau cua canh da nap vao cay khung}
d2[k]:=j; {luu dinh cuoi cua canh da nap vao cay khung}
End;
End;
Procedure ghi;
Var f:Text; i:integer;
Begin
Assign(f,fo); Rewrite(f);
tong:=0;
For i:=1 to n-1 do
Begin
Writeln(f,d1[i],' ',d2[i]);
tong:=tong+a[d1[i],d2[i]];
End;
Writeln(f,'Tg trg_so=',tong);
Close(f);
End;
Procedure Xem_kq;
Var f:Text; line:string[12];
Begin
Writeln(#32:20,'KET QUA CHAY CHUONG TRINH:');
Writeln('Tap cac canh cua Ck_min va tong trong so cua no (dong cuoi):');
Writeln;
Assign(f,'Ra.kq'); Reset(f);
While Not SeekEof(f) Do
Begin
Readln(f,line);
Writeln(#32:7,line); 8 h 54 m 28/7/2017 183 End;
close(f);
End;
Begin clrscr;
Doc;
TtPrim;
Ghi;
Xem_kq;
Readln;
End.
BÀI TỰ LUYỆN CHO CÁC BẠN (Thực chất là tìm CKMIN) TL1/ Một thành phố cần trải nhựa mạng giao thông có N nút giao thông cho bởi đồ thị bạn tự vẽ
(dễ thôi). Trọng số của các cạnh đồ thị này biểu diễn độ dài các con đường. Cần
phải trải nhựa những con đường nào để vẫn có đường đi được trải nhựa giữa hai
nút giao thông bất kỳ mà ĐỘ DÀI ĐƯỢC TRẢI NHỰA LÀ NGẮN NHẤT. TL2/ Giả sử mạng truyền dữ liệu giữa các trung tâm máy tính ở một số tỉnh miền Bắc cho bởi
đồ thị bạn tự vẽ. Trọng số ghi trên các cạnh của đồ thị này biểu thị CHI PHÍ xây dựng
đường truyền dữ liệu. Viết code để sao cho chi phí thiết đặt mạng truyền dữ liệu là ÍT
NHẤT mà vẫn đảm bảo truyền dữ liệu được giữa 2 trung tâm BẤT KỲ thuộc mạng. (Đơn
vị tiền chi phí: Triệu). TL3/ Có n phòng làm việc của một công ty được nối tiếp với nhau bằng hệ thống dây điện.
Sơ đồ nối dây của mạng điện này biểu diễn bởi ma trận A[i, j], trong đó A[i, j] là độ
dài dây điện nối giữa phòng i với phòng j. Nếu không có dây điện nối giữa phòng i với phòng j thì A[i, j] = 0. Hiện tại n
phòng này đều có đường dây điện nối tới nhưng quá thừa nên lãng phí. Hãy tìm
tổng độ dài ngắn nhất của hệ thống dây điện cần sửa lại cách nối điện sao cho n
phòng của công ty đều có điện. Dữ liệu vào cất trên text file với tên E_line.In. Dòng đầu tiên là số phòng n; n
dòng kế tiếp mô tả ma trận A[i, j], mỗi dòng n số cách nhau ít nhất một ký tự trống.
Kết quả cất trên text file với tên E_line.Ou mà dòng đầu là tổng độ dài dây điện
dùng cho công ty; các dòng sau mỗi dòng ghi 2 số u i và vj biểu thị có đường dây
nối phòng ui với phòng vi (i = 1, 2, 3, ...) Một trường hợp cụ thể của bài toán này với file vào và xuất dữ liệu cho dưới đây: 4 5 E_line.In E_line.Ou
8 h 54 m 28/7/2017 3 4
1 4
2 4 184 = = = = = = = = = = = = = = = = = = A-ÔN MỘT VÀI KHÁI NIỆM CƠ BẢN ĐỂ LÀM TOÁN 1/ Thế nào là đồ thị hai phía? Cho tập đỉnh V1 và tập đỉnh V2 thỏa mãn:
V1 Giao V2 = Rỗng (a)
V1 Hợp V2 = V (b)
và tập cạnh E gồm các cạnh e = (v1, v2) mà
v1 Thuộc V1, v2 Thuộc V2 (c)
Tập G = {V,E} với V, E thỏa các điều kiện a, b, c ở trên gọi là đồ thị HAI PHÍA (đồ thị hai phía cũng được
ký hiệu là G{V1, V2, E}). 2/ Hai dạng bài toán về cặp ghép trên đồ thị hai phía: 2.1) Trước hết cần định nghĩa khái niệm cặp ghép:
Ta gọi tập PAI gồm các cạnh thuộc E và không có đỉnh nào chung là cặp ghép. Số cạnh của PAI là lực
lượng của cặp ghép và ký hiệu PAI. 2.2) Tiếp theo là định nghĩa khái niệm cặp ghép đầy đủ:
Nếu tập V1 và V2 đều có N đỉnh và PAI = N thì PAI gọi là cặp ghép ĐẦY ĐỦ. Hai dạng bài toán về cặp
ghép: 2.3) Dạng 1
Đây là bài toán tìm tập PAI có lực lượng |PAI| cực đại. Bài toán tìm cặp ghép đầy đủ là trường hợp riêng
của bài toán này. 2.4) Dạng 2 (CẶP GHÉP CỰC ĐẠI)
Tìm cặp ghép có TỔNG TRỌNG SỐ LỚN NHẤT (GỌI TẮT LÀ CẶP GHÉP CỰC ĐẠI, viêt tắt: Cặp ghép
Max) trên các cạnh thuộc tập PAI. Một số các bài toán XẾP LỊCH thuộc dạng này.
Để giải hai dạng bài toán trên ta có các thuật toán cơ bản sau: a-Thuật toán cơ bản dựa vào đồ thị hai phía, dây chuyền (luồng) và sửa nhãn để tìm cặp ghép Max,
b-Đệ quy – Quay lui,
c-Quy hoạch động,
d-Sắp xếp Topo,
e-Thuật toán Jonson,
f-Thuật toán Heristic,
g-Thuật toán Hunggari,
g-Thuật toán làm Mịn dần kết quả. 8 h 54 m 28/7/2017 185 B-LẬP TRÌNH GIẢI CÁC BÀI TOÁN CẶP GHÉP SAU:
1/ Bài toán 1.
Một lớp học sinh gồm N người (đánh số thứ tự từ 1 đến N và N 1000) đi cắm trại tham gia trò chơi như
sau: mỗi em nam ghép cặp với một em nữ (và ngược lại mỗi em nữ ghép cặp với một em nam). Người ta
dùng một tham số nguyên dương w để đánh giá độ ăn ý của các cặp ghép đó. Yêu cầu tìm những cặp ghép
cho tổng độ ăn ý lớn nhất.
Dữ liệu vào cất trên text file với tên Ghepcap.In gồm:
* Dòng 1 là số N.
* Các dòng tiếp theo mỗi dòng gồm 3 số x, y, w với ý nghĩa : x là số hiệu của nam sinh, y số hiệu của nữ
sinh, w là độ ăn ý của 2 bạn đã ghép cặp với nhau.
Kết quả ghi lên text file với tên Ghepcap.Ou gồm:
* Dòng đầu chứa một số nguyên dương là tổng độ ăn ý lớn nhất của các cặp ghép.
* Các dòng tiếp theo mỗi dòng ghi 3 số x, y, w.
Một ví dụ cụ thể là:
Ghepcap.In
4
1 2 2
1 3 1
4 2 3
4 3 1 Ghepcap.Ou
4
1 3 1
4 2 3 1) CODE1. (Phuong an 1: Dung de quy quay lui de tim cap ghep CUC DAI)
Program GhepNamNu;
Uses crt;
Const fi='Ghepcap.In';
fo='Ghepcap.Ou';
min=-10000;
Var f:text; n:integer;
Test,Free: array[1..100] of boolean;
A: array[1..100,1..100] of integer;
Trace,besttr: array[1..100] of integer;
nho:integer; Procedure Nhap;
Var i,j1,j2,j3:integer;
Begin
assign(f,fi); reset(f); readln(f,n);
for i:=1 to n do for j1:=1 to n do a[i,j1]:=min;
for i:=1 to n do begin test[i]:=true; free[i]:=true; end;
for i:=1 to n do
Begin
readln(f,j1,j2,j3); 8 h 54 m 28/7/2017 186 Procedure Tichluy;
Var tong, i:integer;
Begin
tong:=0;
for i:=1 to n do if test[i] then tong:=tong+a[i,trace[i]];
if tong>nho then
Begin
nho:=tong;
besttr:=trace;
End;
End; Procedure Try(i:integer); {de quy quay lui}
Var j, k:integer; ok:boolean;
Begin
if not free[i] then try(i+1) else
for j:=1 to n do if i<>j then if free[j] then
Begin
free[j]:=false;
free[i]:=false;
trace[i]:=j;
trace[j]:=i;
ok:=true;
for k:=1 to n do if free[k] then ok:=false;
if ok then Tichluy else try(i+1);
free[j]:=true;
free[i]:=true;
End
End; Procedure Xuat;
Var i:integer;
Begin
Assign(f,fo); Rewrite(f);
writeln(f,nho);
for i:=1 to n do if test[i] then
writeln(f,i,' ',besttr[i],' ',a[i,besttr[i]]);
close(f);
End; Procedure Xem;
Var f:text; line:string;
Begin
Assign(f,fo); Reset(f);
8 h 54 m 28/7/2017 187 2) CODE2 (DÙNG THUẬT TOÁN KRUSCAL ĐỂ TÌM CẶP GHÉP MAX )
Program Ghepcap;
Uses Crt;
Const Const fi='Ghepcap.In';
fo='Ghepcap.Ou';
max=10000;
Var Tree:array[1..100] of integer;
canh:array[1..100,1..2] of integer;
a:array[1..100,1..100] of integer;
f:text;
N:integer;
trongso:integer;
test: array[1..100] of boolean; Procedure Nhap;
Var i,j,u,v:integer;
Begin
assign(f,fi);
reset(f);
read(f,n);
readln(f);
for i:=1 to n do test[i]:=true;
for i:=1 to n do
for j:=1 to n do a[i,j]:=0;
for i:=1 to n do
begin
readln(f,u,v,a[u,v]);
test[v]:=false;
a[v,u]:=a[u,v];
end;
close(f); 8 h 54 m 28/7/2017 188 Procedure Timmax(var u,v:integer);
Var temp:integer;
i,j:integer;
max:integer;
Begin
max:=-maxint;
for i:=1 to n-1 do
for j:=i+1 to n do
if tree[i]<>tree[j] then
if max Procedure Ghepcap(ok,u,v:integer);
var i,tam:integer;
Begin
if a[u,v]<>max then
trongso:=trongso+a[u,v];
canh[ok,1]:=u;
canh[ok,2]:=v;
tam:=tree[v];
for i:=1 to n do
if tree[i]=tam then tree[i]:=tree[u];
end; Procedure Creat;
Var ok,u,v:integer;
Begin
for ok:=1 to n-1 do
begin
Timmax(u,v);
Ghepcap(ok,u,v);
end;
end; Procedure Print;
Var i:integer;
8 h 54 m 28/7/2017 189 Camhoa.In
4 3
7 8 9 10
10 9 8 7
5 6 7 8 Camhoa.Ou
24
1 1
2 2
3 4 Để giải bài này ta dùng QUY HOẠCH ĐỘNG a- DIỄN TẢ THUẬT TOÁN BẰNG NGÔN NGỮ TỰ NHIÊN: Dữ liệu của bài toán có thể biểu diễn nhờ
đồ thị 2 phía: một phía là k bó hoa, một phía là n lọ hoa và yêu cầu ghép cặp (có 2 điều kiện). Ta dùng mảng
2 chiều L[i, j] để lưu tổng giá trị thẩm mỹ lớn nhất khi ghép (cắm) bó hoa i với (vào) lọ j. Bài toán yêu cầu
khi ghép phải đảm bảo: bó hoa có số thứ tự bé phải đứng trước bó hoa có số thứ tự lớn, nên mảng L xác
định như sau:
* Nếu i > j thì không có cách ghép cặp. 8 h 54 m 28/7/2017 190 b-CODE (QUY HOẠCH ĐỘNG)
Program CAMHOA;
Uses Crt;
Const max=100;
Var v:Array[1..max,1..max] of integer;
L:Array[0..max,0..max] of longint;
cap:Array[1..max] of integer;
n, k:integer; f:text;
Procedure Doc;
Var i,j:integer;
Begin
Assign(f,'Bt2.In'); Reset(f);
Readln(f,n,k);
For i:=1 to k do
For j:=1 to n do Read(f,v[i,j]);
close(f);
End; Function Lonnhat(x,y:integer):integer;
Begin
If (x>y) Then Lonnhat:=x else Lonnhat:=y;
End; Function Thamymax(i:integer):integer;
Var j, s:integer;
Begin
s:=0;
For j:=1 to i do
s:=s+v[j,j];
thamymax:=s;
End; Procedure Xuly;
Var i,j:Integer;
Begin
For i:=1 to max do
For j:=1 to max do L[i,j]:=-maxint;
For i:=1 to k do
For j:=1 to n do
If i=j Then L[i,j]:=ThamyMax(i)
Else If i Procedure Xuat;
Var i,j,d:integer;
Begin
Assign(f,'Camhoa.ou'); Rewrite(f);
Writeln(f,'Tong max cua do tham my:',L[k,n]); 8 h 54 m 28/7/2017 191 Procedure Xem;
Var f:text; line:string;
Begin
Assign(f,'Camhoa.ou'); Reset(f);
Writeln(#32:13,'KET QUA PROGRAM:');
Writeln;
While not (seekeof(f)) do
Begin
Readln(f,line);
Writeln(#32:7,line);
End;
close(f);
End;
{Main Prog.}
Begin clrscr;
Doc;
Xuly;
Xuat;
Xem;
Write('Done!');
Readln;
End.
3/Bài toán 3. Một sản phẩm có N chi tiết, mỗi chi tiết phải lần lượt gia công trên hai máy A, B (A trước,
B sau). Thời gian để gia công chi tiết trên máy A là Ai, trên máy B là Bi (i = 1,2,...,N). Hãy lập lịch hoàn
thành các chi tiết với thời gian ít nhất.
Dữ liệu vào cất trên text file với tên Bt3.In gồm :
*Dòng đầu tiên ghi số n.
*N dòng tiếp theo, dòng i + 1 là số ai và bi.
Kết quả ghi lên text file với tên Bt3.Ou gồm :
* Dòng đầu ghi thời gian ít nhất gia công các chi tiết.
*Dòng thứ hai ghi số hiệu các việc đã thực hiện theo lịch tối ưu. Ví dụ:
Bt3.In
5
3 3
4 3
8 h 54 m 28/7/2017 192 Bt3.Ou
26
1 4 2 5 3 ĐỂ GIẢI BÀI NÀY TA DÙNG THUẬT TOÁN JONSON CODE THAM KHẢO (CHƯA TEST)
Program Johnson_Algo ;
Uses Crt ;
Const ln=100; f1=’Bt3.In’; fo=’Bt3.Ou’;
Type m1=Array[1..2, 1..ln] of Real;
kq=Array[1..ln] of Byte;
mdx=Array[1..ln] of Boolean;
Var a:m1; {a[1,j] luu thoi gian chi tiet j tren may A; A[2,j] luu thoi gian chi tiet j tren may B}
resul:kq; {ket qua xep lich}
dx:mdx; {danh dau chi tiet da lam}
n :Byte ;
f :Text ; Procedure Nhap;
Begin
{Đọc số N và các giá trị A[2,n] vào chương trình, các con tự làm (XEM LẠI PHẦN RECORD & FILE!)}
End ;
Function ChitietMin(var may :Byte) :Byte ;
Var Lmin:integer; chitiet:byte;
Begin
Lmin:=Maxint;
For i:=1 to 2 Do
For j:=n Downto 1 Do
If Not dx[j] then
If a[i,j] 193 4/Bài toán 4 Có N việc. Việc thứ i hoàn thành trong thời gian ti. Các việc này được thực hiện trên M
máy (có công suất như nhau và mỗi máy đều có thể thực hiện được bất cứ việc nào trong N việc), mỗi việc
được thực hiện liên tục trên một máy cho đến khi xong. Hãy lập lịch để các máy thực hiện đủ N việc sao
cho tổng thời gian hoàn thành các việc càng ít càng tốt.
Dữ liệu vào cất trên text file với tên Bt4.In gồm:
Dòng đầu ghi 2 số N, M.
Dòng 2 ghi N số t1, t2,...,tN
Kết quả ghi lên text file với tên Bt4.Ou gồm:
Dòng đầu ghi tổng thời gian hoàn thành N việc.
M dòng sau: tại dòng i + 1 ghi số hiệu các việc thực hiện trên máy i.
Một ví dụ cụ thể của bài toán là ta có 3 máy M1, M2, M3 và 6 việc với thời gian hoàn thành tương ứng là t1
= 2, t2 = 5, t3 = 8, t4 = 1, t5 = 5, t6 = 1 với các file trên đây là:
Bt4.In 8 h 54 m 28/7/2017 194 Bt4.Ou
8
3
2 1 4
5 6 BÀI NÀY DÙNG THUẬT TOÁN HEURISTIC (CÁC CON CẦN VẼ BIỂU ĐỒ ĐỂ HIỂU RÕ CÁC LẬP
LUẬN SAU)
a-Diễn đạt thuật toán bằng ngôn ngữ tự nhiên (hãy tự vẽ biểu đồ để dễ hiểu thuật toán hơn)
*Tại thời điểm t = 0, thực hiện việc V2 trên máy M1, V5 trên máy M2 và V1, trên máy M3.
*Tại t = 2 việc V1 được hoàn thành, liền đó trên máy M3 thực hiện tiếp việc V4. Trong thời gian này 2 máy
M1 và M2 vẫn đang thực hiện công việc của mình ...
*Ta thấy thời gian hoàn thành cả 6 việc là 12 và các máy M1, M2 có quá nhiều thời gian nhàn rỗi. Phương
án trên đây là một phương án tồi. Để cải thiện nghiệm của bài toán này ta thử một phương án 2 dưới đây:
+ Xếp các việc theo thứ tự giảm dần của thời gian
+ Lần lượt xếp các việc theo thứ tự ấy vào các máy còn nhiều thời gian rảnh nhất.
Như vậy thời gian hoàn thành cả 6 việc ở phương án P2 là 8. Nghiệm này đã tốt hơn nghiệm của phương án
P1: Mọi việc hoàn thành sớm hơn phương án P1 bốn đơn vị thời gian (các bạn hãy hình dung nếu đơn vị
thời gian là tháng thì kế hoạch sản xuất đã về đích trước 4 tháng — đó là khoảng thời gian rất đáng kể trong
sản xuất) và thời gian rảnh của máy M1 là ít nhất. DÙNG HEURISTIC METHOD
b- Code. (CHƯA TEST)
Ues Crt;
Cosnt ln=1000; fi=’Bt4.In]; fo=’Bt4.Ou’;
Type m1=Array[1..ln] of Longint;
Var t:m1; {t[i]: thoi gian lam viec i; i=1..n}
id:m1; {id[i]: so hieu cua cong viec i}
phan cong may j lam viec i}p:m1; {p[i]:=j
n,m:Integer; {n: So luong cong viec ; m: so luong may}
maxt:Longint {Thoi gian cua may co thoi gian da gia cong lon nhat}
may:m1; {may[i]: Thoi gian da lam (da thuc hien gia cong) cua may i} Procedure Nhap;
Var i:Integer;
Begin
{Doc cac data n,m vao mang t tu file Bt4.In roi lam lenh sau, }
{ con tu lam. }
For i:=1 to n do id[i]:=i;
End; Procedure Sort(var a:m1);
Var i, j, c:integer;
Begin
{Sap xep giam mang t theo thoi gian va xep ca mang id. Vi de nen cac con tu lam}
End; 8 h 54 m 28/7/2017 195 Procedure Ghi;
Var f: Text; i, j: Integer; sum: Longint;
Begin
Assign(f,fo); Rewrite(f);
Writeln(f, maxt);
For j:=1 to m Do
Begin
sum:=0;
For i:=1 to n Do
If p[i]:=j then
Begin
Writeln(f, id[i]:4) ; {In ra so hieu cua may i}
sum:=sum+t[i];
End;
Writeln(f,’ Tong thoi gian da lam cua may ‘, j ,’:’, sum);
End;
Close(f);
End; Procedure Phancong;
Var i,j,Lj:Integer; Ok: Boolean;
Begin
FillChar(may, sizeof(may), 0);
FillChar(p ,sizeof(p), 0);
i:=0; maxt:=-maxint;
For j:=1 to m do {giao m viec dau cho m may}
Begin
Inc(i);
may[j]:=t[i];
p[i]:=j;
If t[i]>maxt then maxt:=t[i];
End;
Inc(i);
While i<=n Do
Begin
Ok:=False;
For j:=1 to m do
Begin
If i>n then Break;
If may[j]+t[i]<=maxt then
Begin
ok:=true;
may[j]:=may[j]+t[i];
p[i]:=j; {Giao viec i cho may j}
Inc(i); 8 h 54 m 28/7/2017 196 { Main Prog.}
Begin clrscr;
Nhap;
Sort(t);
Phancong;
Ghi;
Write(‘Done!’);
Readln;
End. MỘT VÀI BÀI ĐỂ CÁC BẠN TỰ LUYỆN LT1. Một xí nghiệp có N công nhân và dây chuyền sản xuất có M máy (M < N).. Nếu giao máy i cho công
nhân j làm thì sẽ đạt lợi nhuận là C[i, j]. Hãy tìm cách bố trí công nhân và máy sao cho không quá một công
nhân đứng một máy và mỗi máy không có nhiều hơn một công nhân để tổng lợi nhuận lớn nhất. LT2. Có N việc, mỗi việc i phải làm trước một số việc nào đó trong N việc này. Hãy lập lịch thực hiện đủ N
việc đã cho.
Dữ liệu vào cất trên text file với tên Lt2.In gồm :
* Dòng đầu ghi số nguyên dương N.
* Các dòng kế sau ghi các số biểu thị thứ tự bộ phận: đầu dòng là số i, kế sau là các số Ji1, Ji2,,..., Jis có
nghĩa là việc i phải làm trước các việc Ji1, Ji2,..., Jis.
Kết quả ghi lên text file với tên Lt2.Ou chỉ có một dòng ghi số hiệu các việc đã lần lượt được thực hiện.
Lt2.In
10
1 2 3
2 4 10
3 5
4 6 8 Lt2.Ou
1 2 7 9 4 6 3 5 8 10 LT3. Có N việc. Với mỗi việc cho biết tiền công phải trả cho người làm thuê, thời gian để hoàn thành việc,
thời điểm kết thúc việc. Hãy xếp lịch sao cho người làm thuê thu được nhiều tiền công nhất.
Dữ liệu vào cất trên text file với tên Lt3.In gồm :
* Dòng đầu là số nguyên dương N.
** N dòng sau, dòng i + 1 ghi 3 số: thời gian hoàn thành công việc t, thời điểm kết thúc công việc k và tiền
công tc.
Kết quả ghi lên text file với tên Lt3.Ou gồm : 8 h 54 m 28/7/2017 197 Lt3.In
10
1 4 89
5 5 86
4 11 83
5 7 84
1 2 25
3 11 61
6 11 33
4 7 28
3 10 1
5 14 71 Lt3.Ou
329
5 0 1 25
1 1 2 89
3 2 6 83
6 6 9 81
10 9 14 71 LT4- Có N việc đánh số từ 1 đến N cần được bố trí thực hiện trên một máy. Biết:
* pi là thời gian để hoàn thành việc i.
* di là thời điểm cuối cùng phải kết thúc việc i.
* hi là hệ số thưởng phạt của việc i.
ti). Thời điểm bắt đầu thực hiện các việc là 0, hãy lập trình tự thực hiện N việc sao cho tổng giá trị thưởng
phạt của tất cả các việc là lớn nhất.Mỗi việc phải thực hiện liên tục từ lúc bắt đầu cho tới lúc kết thúc,
không cho phép ngắt quãng. Coi như thời gian chuyển từ việc này sang việc khác bằng 0. Giả sử ti là thời
điểm hoàn thành việc i, khi đó giá trị thưởng, phạt việc i là hix(di
Dữ liệu vào cất trên text file với tên Bt8.In gồm:
*Dòng đầu ghi số nguyên dương N (N < 2001)
* Dòng 2 ghi N số nguyên dương p1,...,pN.
* Dòng 3 ghi N số nguyên dương d1,...,dN.
* Dòng 4 ghi N số nguyên dương h1,...,hN.
Kết quả ghi lên text file với tên Bt8.Ou gồm :
* Dòng đầu ghi giá trị thưởng phạt lớn nhất tìm được.
* Dòng 2 ghi N số là trình tự thực hiện các việc.
Ví dụ:
Test_1
Lt4.In
5
2 2 3 4 3
3 2 10 11 9
1 2 2 1 3
8 h 54 m 28/7/2017 198 Test_2
Lt4_2.In
4
1 2 3 4
3 2 1 3
1 2 1 2
Lt4_2.ou
-17
1 2 3 4 Mọi ý kiến đóng góp gửi về MailBox của thầy là: quethongtran@yahoo.com 8 h 54 m 28/7/2017 199 8 h 54 m 28/7/2017 200 201 8 h 54 m 28/7/2017 202 8 h 54 m 28/7/2017 203 204 205 206 207 208 209 210 211 212 213 8 h 54 m 28/7/2017 214 8 h 54 m 28/7/2017Thầy Trần Thông Quế
Readln;
End.
Thầy Trần Thông Quế
USES CRT;
Var sovng, n, dv:longint;
Begin clrscr;
Write(‘n=’); Readln(n);
sovng:=0;
While (n>0) do
Begin
dv:=n MOD 10;
sovng:=10*sovng+dv; {sovng=số viết ngược}
n:=n DIV 10;
End;
Write(‘So viet nguoc lai la:’,sovng);
Readln;
End.
Thầy Trần Thông Quế
*27- Đọc từ bàn phím vào một số nguyên dương N (N>1). Tìm chữ số lớn nhất trong số vừa nhập và vị trí
của nó trong số vừa nhập. Hiện kết quả lên màn.
Program Tim_Chuso_Max;
uses crt;
Var so,i,max,temp,vitri:longint;
BEGIN Clrscr;
write(‘Nhap so :’); readln(so);
writeln(‘Trong so ‘,so,’ vua nhap ‘);
max:=0;
i:=1;
while (so<>0) do
Begin
temp:=so mod 10;
if temp>max then
Begin
max:=temp;
vitri:=i;
End;
i:=i+1;
so := so div 10;
End;
Write(‘ thi chu so ‘, max,’ la chu so lon nhat va nam o vi tri thu ‘,vitri);
Write(‘ ke tu ben phai sang.’);
readln;
END.
*28- Cho trước số tự nhiên N (ví dụ 100). Tìm & hiện lên màn tất cả các cặp số nguyên tố sinh đôi mà giá
trị của chúng không quá N. ( Hai số nguyên tố sinh đôi là hai số hơn kém nhau 2 đơn vị)
Uses crt;
Var so1, so2, so3, so4, n, dem: longint;
kt1, kt2: boolean; {kt=kiem tra}
Begin clrscr;
Write(‘Nhap so tu nhien n:’); Readln(n);
Writeln(‘Cac cap so sinh doi < n:’);
For so1:=2 to n-2 do
Begin
so4:=2;
While (so4<=sqrt(so1)) And (so1 MOD so4<>0) do
Inc(so4);
If so4>sqrt(so1) then
Begin
so2:=so1;
so3:=so2+2;
so4:=2;
While (so4<=sqrt(so3)) And (so3 Mod so4<>0) do Inc(so4);
If so4>sqrt(so3) then
Begin
Thầy Trần Thông Quế
Inc(dem);
Writeln(dem,’:’,’(‘,so2,’,’,so3,’)’);
End;
End;
End;
Readln;
End.
Thầy Trần Thông Quế
t:=0;
k:=2;
While (k<=(n1 DIV 2)) And (t<=10000) do
Begin
If (N1 mod k=0) Then t:=t+k;
inc(k);
End;
If (t>0) and (t<=10000) Then
Begin
n2:=t; t:=0;
k:=2;
While (k<=(n2 Div 2)) And (t<=n1) do
Begin
If (n2 mod k=0) then t:=t+k;
Inc(k);
End;
If t=n1 then Writeln(#32:30,’(‘,n1,’,’,n2,’)’);
End;
End;
Writeln(‘DONE!’);
Write(‘More?(1/0),Continue -> 1, Stop -> 0:’); Readln(tt);
Until tt=0;
End.
*31- (LUỸ THỪA NHANH. INFORMATIC OLYMPIC MOSCOW 1980). Nhập cơ số a và mũ k. Tính ak
với hạn chế: Không được dùng công thức tính lũy thừa, cũng không được dùng liên tiếp k phép nhân ( vì k
cực lớn và mục tiêu đầu bài là tính NHANH!)
Thầy Trần Thông Quế
Readln(hoi);
Until hoi='k';
END.
*32- (ĐẢO BIT. INFORMATIC OLYMPIC MOSCOW 1983)
Số nguyên m được viết trong hệ cơ số 2 theo trật tự ngược lại. Số nhận được viết trong hệ thập phân được
coi là giá trị của hàm B(m). Hãy tính giá trị hàm B(m) chẳng hạn với m=512 ; 513; 514;…; 1024.
PROGRAM DaoBit; {chay voi m=513}
VAR
m, b, k: integer;
BEGIN
k:=513;
m:=1;
Writeln(m);
While m<1024 do
begin
while m>=k do
begin
m:=m-k;
k:=k div 2;
end;
m:=m+k;
k:=513;
Writeln(m);
end;
Readln;
END.
Thầy Trần Thông Quế
Readln;
End.
PHẦN II. LẬP TRÌNH THEO MODUL
Thầy Trần Thông Quế
Readln;
End.
Thầy Trần Thông Quế
4. Lập trình đơn thể (Bạn chọn FUNCTION hay PROCEDURE LÀ VIỆC CỦA BẠN. HÃY TỰ SUY
NGHĨ TRƯỚC LÚC XEM ĐÁP ÁN BÊN DƯỚI.) thực thi 3 phép tính cơ bản (Hợp, Hiệu, Giao) của hai
tập hợp cho trước. Hiện kết quả lên màn.
BÀI NÀY NGẮN, NHƯNG KHÁ HAY VÌ NÓ CHO BẠN NHIỀU HIỂU BIẾT: 1. CÁCH KHAI BÁO Ở
ĐẦU PROGRAM; Ở 2 MODUL: CÁCH THAM CHIẾU KHÁC NHAU (TẠI SAO?); CÁCH DÙNG CÁC
LỆNH Ở MODUL NHẬP VÀ MODUL INRA…
Thầy Trần Thông Quế
Else chphuong_check:=false;
End;
Thầy Trần Thông Quế
If(d=0) and (n>1) then ktnt:=True
Else ktnt:=False;
End;
Thầy Trần Thông Quế
Function Check(m:Longint):boolean;
Var stop,kt:Boolean; kd,bd,t:Longint;
Thầy Trần Thông Quế
Write('So ',n,' khong bieu dien duoc thanh');
Write(' tong cua >=2 so tu nhien lien tiep!');
End;
Writeln; Writeln;
Write('More (1/0)? Tiep: go 1; Ngung: go 0:');
Readln(tt);
Until tt=0;
End.
Thầy Trần Thông Quế
Write('Nhap so nguyen duong p<100:'); Readln(p);
Innit;
Process;
s:=p;
Write('Phuong an phan tich so ',p,' thanh tong cac so ng_to de co tich max la:');
Thầy Trần Thông Quế
Writeln; Writeln(#32:18,'- - - - - - - - - - - - - - - - - - - -');
For i:=101 to 999 do
if uscln(i,daoso(i))=1 Then
Begin
Inc(dem);
Write(i:4);
End;
Writeln; Writeln;
Write(#32:20,'Bang tren day co tong cong ',dem,' so Tam tam.');
End;
Thầy Trần Thông Quế
**13. Liệt kê tất cả các số SIÊU NGUYÊN TỐ có không hơn 8 chữ số. (Các số SIÊU NGUYÊN TỐ dài L
là những số mà xóa đi k (k
Thầy Trần Thông Quế
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
PHẦN III- MẢNG (ARRAY)
(Bài khó: *; Bài rất khó: **)
II_1) MẢNG 1_CHIỀU. LẬP TRÌNH GIẢI CÁC BÀI TOÁN SAU:
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Function Check(tt, n, k: word):boolean;
Var t,s,i,m:word;
Begin
check:=False;
t:=tt Div k ;
If t*k <> tt then exit;
m:=1;
c[m]:=0;
s:=0;
For i:=1 to n do
Begin
s:=s+a[i];
If s>t then exit;
If s=t then
Begin
m:=m+1;c[m]:=i;
s:=0;
End;
End;
c[m]:=n;
check:=True;
End;
Procedure Result(tt, n, k:word);
Var s,i:word;
Begin
Writeln;
Write(‘Day a[1..’,n,’] co the chia thanh ‘,k,’ doan’);
Writeln(‘ co tong nhu nhau la=’,tt Div k);
s:=0;
If k=1 Then
Begin
For i:=1 to n do
s:=s+a[i];
Write(‘a[1..’,n,’]=’,s);
Exit;
End;
Writeln;
For i:=1 to k do
Begin
Writeln(‘Doan thu ‘,i,’: a[‘,c[i]+1,’..’,c[i+1],’]’);
If (i Mod 15 =0) then
If readkey=#27 then Exit;
End;
End;
Procedure Partion(n:word);
Var tt, k:word;
Begin
Thầy Trần Thông Quế
tt:=0;
For k:=1 to n do tt:=tt+a[k];
For k:=n Downto 1 do
If check (tt,n,k) then
Begin
Result(tt,n,k);
Exit;
End;
End;
Procedure Test;
var n:word;
Begin
randomize;
Repeat
clrscr;
n:=random(mn)+1;
RandomGene(n Div (random(5)+1),n);
View(n);
Partion(n);
Until readkey=#27;
End;
7- IFORMATIC OLYMPIC MOSCOW 1986. Có k làng. Nếu ở làng i đặt trạm cấp cứu, thì xe cấp cứu đi
đến làng j theo tín hiệu gọi cần thời gian:
A[i,i] + A[i,j] ( 1<=i, j<=k, i = j )
Tìm số hiệu làng i để đặt trạm cấp cứu sao cho từ đó đi tới làng xa nhất (về thời gian) sẽ mất thời gian ít
nhất.
Mảng A[1..k,1..k] cho trước, trong đó tất cả phần tử A[i,j]>0 và có thể A[i,j] <>A[j,i].
Uses Crt;
Const kk=20;
Var i,j,k,i1:integer;
s, t: real;
a:Array[1..kk,1..kk] of real;
Begin clrscr;
Write(‘Nhap so lang:’); Readln(k);
For i:=1 to k do
For j:=1 to k do
Begin
Write(‘a[‘,i,’,’,j,’]=’); Readln(a[i,j]);
End;
For i:=1 to k do
Begin
s:=0;
for j:=1 to k do
If(i<>j) And (s
Thầy Trần Thông Quế
s:=s+a[i,j];
If(i=1) Or (s
Thầy Trần Thông Quế
for j:=1 to len-i do b:=b*2;
s:=S+b;
end;
end;
Write('Doi sang thap phan la: ',S);
Writeln;
Write('More(y/n)?'); Readln(dap);
Until dap In['n', 'N'];
End.
10- Tìm khoảng cách nhỏ nhất giữa các phần tử thuộc dãy số nguyên đã cho.
Program Khoangcachmin;
uses crt;
var a:array[2..1000] of integer;
i,n,dmin:integer; hoi:byte;
Begin clrscr;
Repeat
Randomize;
write('Nhap do dai n (n<=1000) cua day so: '); readln(n);
writeln('Nhap cac phan tu cua mang:');
For i:=2 to n do
a[i]:=Random(100);
clrscr;
writeln('Day vua nhap la:');
For i:=2 to n do write(' ',a[i]);
writeln;
writeln('= = = = = = = = = = = = = = = = = = = = = = = = = =');
dmin:=abs(a[3]-a[2]);
For i:=4 to n do
If (dmin>abs(a[i]-a[i-1])) then dmin:=abs(a[i]-a[i-1]);
Writeln('Khoang cach nho nhat giua cac phan tu trong day la:',dmin);
Write('Another Test (1/0)?. Continue->Press 1; Stop->Press 0:');
Writeln;
Readln(hoi);
Until hoi=0;
End.
III_2) MẢNG HAI CHIỀU (TÊN KHÁC: MA TRẬN)
(CHỦ ĐỀ NÀY KHÁ NHIỀU BÀI TẬP THÚ VỊ HOẶC ÍT QUEN THUỘC VỚI CÁC BẠN)
Khuyến cáo: Các bạn học sinh hãy chú ý điều sau:
CÁI KHÓ CỐT LÕI CỦA CÁC BÀI TOÁN TỪ 7 ĐẾN 11 đối với các bạn học sinh hay sinh viên
KHÔNG Ở THUẬT TOÁN TÌM KIẾM HAY TÍNH TOÁN (những thuật toán này quá dễ với các bạn) MÀ
Ở THUẬT TOÁN DUYỆT THEO CÁC INDEX (CÁC CHỈ SỐ ) CỦA MA TRẬN. Bởi vậy khuyến cáo
các bạn nên XEM+NGẪM+NHỚ KỸ CÁCH DUYỆT INDEX ở các bài toán đó.
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Procedure Input(Var a:mt; n:byte);
Var i,j:byte;
Begin
randomize;
For i:=1 to n do
For j:=1 to n do a[i,j]:=random(50);
{ Begin
Write('a[',i,',',j,']=');
readln(a[i,j]);
End; }
End;
Procedure View(a:mt; n:byte);
Var i,j:byte;
Begin
For i:=1 to n do
Begin
For j:=1 to n do
Write(a[i,j]:4);
Writeln;
End;
End;
Function Timmax(a:mt; n:byte):byte;
Var i,j,m:Byte;
Begin
max:=0;
For i:=1 to n do
For j:=1 to n do
If ((i+j)>(n+1)) And ((a[i,j] Mod 2)=1) then max:=a[i,j];
If max=0 then
Writeln('Khong co so le nao lon nhat duoi duong cheo phu.')
Else
Begin
For i:=1 to n do
For j:=1 to n do
If ((i+j)>(n+1)) And ((a[i,j] Mod 2)=1) And (max
Thầy Trần Thông Quế
if ((i+j)<=n) And (a[i,j]>max) then
Begin
Inc(dem);
Writeln('Ton tai phan tu lon hon max o hang ',i,' cot ',j);
End;
If dem=0 Then write('Khong co phan tu nao > max.')
Else Write('So phan tu lon hon max la:',dem);
End;
Begin clrscr;
Write('Nhap kich co ma tran VUONG:'); Readln(n);
Input(a,n);
View(a,n);
max:=Timmax(a,n);
Maxindex(a,n,max);
Readln;
End.
Thầy Trần Thông Quế
Begin
For i:=1 to soh do
Begin
For j:=1 to soc do
Write(matrix[i,j]:3);
Writeln;
End;
End;
Begin Clrscr;
Repeat
Write('Nhap kich co n cua ma tran vuong:'); Readln(n);
Input(a,'a',n,n);
Writeln('Matrix vua nhap:');
Writeln;
View(a,n,n);
Writeln;
min:=a[2,1];
row:=2; col:=1;
For i:=1 to n do
For j:=1 to n do
If(i>j) And (min>a[i,j]) Then
Begin
Min:=a[i,j];
row:=i; col:=j;
End;
Writeln('Phan tu min o duoi duong cheo chinh:',min);
Write('Nhap chi so hang, cot can xu ly:'); Readln(k,l);
s:=0;
For i:=1 to n do
For j:=1 to n do
If (i+j=k+l) then S:=S+a[i,j];
Writeln('Tong cac phan tu tren duong // voi duong cheo phu va ');
Write('chua phan tu tren hang ',k,' cot ',l,' la:',S);
Writeln;
Write('Another Test (1/0)? More --> Press 1, Stop --> Press 0:');
Readln(Ans);
Until ans=0;
End.
*15- Lập trình tạo ma trận xoắn ốc. Lưu kết quả vào tệp Xoanoc.txt.
Program Mt_xoan;
Uses Crt;
var a:array[1..150,1..150]of word;
i,j,n,k:word;
f:text;
Procedure View;
Begin
Thầy Trần Thông Quế
For j:=1 to n do
Begin
For i:=1 to n do
Write(f,a[i,j]:6);
Writeln(f);
End;
End;
Procedure Datso;
Begin
inc(k);
a[i,j]:=k;
End;
Begin clrscr;
Write('Nhap kich co ma tran n='); Readln(n);
Assign(f,'Xoanoc.txt'); Rewrite(f);
j:=1;
while k
Thầy Trần Thông Quế
Begin
check:=false;
For j:=1 to n do
if k=mt[i,j] then check:=true;
If Not check then exit;
End;
ktrahang:=true;
End;
Function ktracot(j:integer):boolean;
var i,k:integer; check:boolean;
Begin
ktracot:=false;
For k:=1 to n do
Begin
check:=false;
For i:=1 to n do
If k=mt[i,j] then check:=true;
If Not check then Exit;
End;
ktracot:=true;
End;
Begin Clrscr;
Write('Nhap kich co ma tran vuong n='); Readln(n);
For i:=1 to n Do
For j:=1 to n Do
Begin
write('mt[',i,',',j,']=');readln(mt[i,j]);
End;
writeln('Ma tran vua nhap:');
For i:=1 to n do
Begin
For j:= 1 to n do
write(mt[i,j]:3);
writeln;
End;
writeln;
writeln('= = = = = = = = = = = = = = = = =');
d:=0;
For i:=1 to n Do
If (Not ktrahang(i)) Or (Not ktracot(i)) then
inc(d);
If d=0 then Write('La ma tran Latinh.')
Else Write('khong la ma tran Latinh.');
Readln;
End.
Thầy Trần Thông Quế
Thầy Trần Thông Quế
{Nhap xong data nho go ENTER de xem ket qua chay Program}
Program Magic_Matrix;
Uses crt, addcrt;
Const lim=11;
Type mt=array[1..lim,1..lim] of integer;
mtktr=array[1..lim,1..lim] of boolean;
Var matr:mt; mtcheck:mtktr; ok:boolean;
n,i,j,k:integer;
ch:char;
Procedure chinhtoado(Var i,j:integer; n:integer);
Begin
If i<1 then i:=n;
If i>n then i:=1;
If j<1 then j:=n;
If j>n then j:=1;
End;
Procedure datso(var matr:mt; Var mtcheck:mtktr; Var k:integer; i,j:integer);
Begin
matr[i,j]:=k;
mtcheck[i,j]:=false;
Inc(k);
End;
Procedure DrawTab(matr:mt; n:integer);
Var i,j:integer;
Begin
textbackground(lightred);
clrscr;
textcolor(lightcyan);
For j:=1 to 25 do
Begin
If(j<(13-n+1)) Or (j>(13+n+1)) then
For i:=1 to 80 do
Begin
gotoxy(i,j); write('$');
End
Else
For i:=1 to 80 do
If (i<(40-(5*n) Div 2-1)) or (i>(40+(5*n) Div 2+2)) then
Begin gotoxy(i,j); write('$'); End;
End;
FONT(40-(5*n) Div 2-2,13-n-1,40+(5*n) Div 2+3,13+n+1,14,1);
textcolor(white);
for i:=13-n+1 to 13+n-1 do
if (i Mod 2)=(13-n) Mod 2 then
Begin
Thầy Trần Thông Quế
for j:=40-(5*n) Div 2 to 40+(5*n) div 2+1 do
if j Mod 5=(40-(5*n) Div 2) Mod 5 then
Begin
gotoxy(j,i); write('!');
End
Else
Begin
gotoxy(j,i); write('=');
End;
End
Else Begin
for j:=40-(5*n) Div 2 to 40+(5*n) Div 2+1 do
if j Mod 5=(40-(5*n) Div 2) Mod 5 then
Begin
gotoxy(j,i); write('!');
End;
End;
for j:=40-(5*n) Div 2 to 40+(5*n) Div 2+1 do
if j Mod 5=(40-(5*n) Div 2) Mod 5 then
Begin
gotoxy(j,13-n); write('=');
gotoxy(j,13+n); write('=');
End
else
Begin
gotoxy(j,13-n); write('=');
gotoxy(j,13+n); write('=');
End;
textcolor(yellow);
for i:=1 to n do
for j:=1 to n do
Begin
gotoxy((40-(5*n) Div 2+1)+5*(j-1),(13-n+1)+2*(i-1));
write(matr[i,j]:3);
End;
End;
Begin {Main}
clrscr;
ch:='t';
While ch In ['t','T'] Do
Begin
Khungkep(20,4,61,16,14);
gotoxy(31,5); write(' HINH VUONG KY AO.');
WINDOW(21,6,60,15);
writeln(#32:7,'-----------------------------');
writeln(#32:5,'Day la bai toan tao hinh vuong va');
writeln(#32:5,' cac con so dat trong no thoa:');
writeln(#32:5,' Tong cac so tren cac hang,');
Thầy Trần Thông Quế
writeln(#32:5,' tren cac cot va tren duong cheo');
writeln(#32:5,' deu bang nhau. Den nay bai toan');
writeln(#32:5,' chi giai duoc voi cac hinh vuong ' );
writeln(#32:5,' co do dai canh la so le');
writeln;
write('Cho do dai canh:(n=3, 5, 7, 9, 11 ...):');
read(n);
setwin;
If (n Mod 2=0) or (n<3) or (n>lim) then n:=5;
for i:=1 to n do
for j:=1 to n do
mtcheck[i,j]:=true;
i:=1;
j:=n Div 2+1;
k:=1;
Repeat
datso(matr,mtcheck,k,i,j);
i:=i-1;
j:=j+1;
chinhtoado(i,j,n);
If mtcheck[i,j]=true then ok:=true
Else Begin
j:=j-1;
i:=i+1;
chinhtoado(i,j,n);
Inc(i);
if mtcheck[i,j]=true then ok:=true
else ok:=false;
End;
Until ok=false;
Drawtab(matr,n);
gotoxy(18, 25);
write('Go phom bat ky de thoat hay t, T de tiep tuc!');
Repeat Until Keypressed;
ch:=Readkey;
clrscr;
end;
End.
**19- Kiểm tra xem một ma trận vuông cấp n ( n LẺ) có là ma phương không?
{ Test 1: 3 7 1 Test 2: 8 1 6
3 5 7
Program Maphuong_Check;
Uses Crt;
Type mt=Array[1..30,1..30] of Integer;
var a:mt; i,j,n,s,s1,s2:integer;
Thầy Trần Thông Quế
Function shang(i:integer):integer;
var j,s:integer;
Begin
S:=0;
For j:=1 to n do
s:=s+a[i,j];
shang:=s;
End;
Function Scot(j:integer):integer;
Var i,s:Integer;
Begin
s:=0;
For i:=1 to n do
s:=s+a[i,j];
scot:=s;
End;
Begin clrscr;
write(' Nhap kich thuoc n cua ma tran vuong:'); Readln(n);
for i:=1 to n do
for j:= 1 to n do
begin
write(' Nhap phan tu a[',i,',',j,']=');
Readln(a[i,j]);
end;
clrscr;
writeln('Ma tran vua nhap:');
for i:=1 to n do
begin
for j:= 1 to n do
write(a[i,j]:3);
writeln;
end;
s:=shang(1);
s1:=0; s2:=0;
For i:=1 to n Do
Begin
If (shang(i)<>s) Or (scot(i)<>s) Then
Begin
Write('Ma tra vua nhap khong phai ma phuong');
Readln;
Exit;
End;
s1:=s1+a[i,i];
s2:=s2+a[i,n+1-i];
Thầy Trần Thông Quế
End;
If (s<>s1) Or (s<>s2) Then
Write('Ma tra vua nhap khong phai ma phuong')
Else Write('Ma tran vua nhap la ma phuong.');
Readln
End.
**20- Cho dãy các số nguyên có độ dài N. Tìm cách chia dãy đã cho thành các đoạn có tổng các phần tử
như nhau.
{Go ESC Thoat}
Uses Crt;
const mn=60;
Var a,c:Array[1..mn] of word;
Procedure View(n:word);
Var i: word;
Begin
for i:=1 to n do
Write(a[i]:4);
Writeln;
End;
Function Min(a,b: word):word;
Begin
if a tt then exit;
m:=1;
c[m]:=0;
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
s:=0;
For i:=1 to n do
Begin
s:=s+a[i];
If s>t then exit;
If s=t then
Begin
m:=m+1;c[m]:=i;
s:=0;
End;
End;
c[m]:=n;
check:=True;
End;
Procedure Result(tt, n, k:word);
Var s,i:word;
Begin
Writeln;
Write('Day a[1..',n,'] co the chia thanh ',k,' doan');
Writeln(' co tong nhu nhau la=',tt Div k);
s:=0;
If k=1 Then
Begin
For i:=1 to n do
s:=s+a[i];
Write('a[1..',n,']=',s);
Exit;
End;
Writeln;
For i:=1 to k do
Begin
Writeln('Doan thu ',i,': a[',c[i]+1,'..',c[i+1],']');
If (i Mod 15 =0) then
If Readkey=#27 then Exit;
End;
End;
Procedure Partion(n:word);
Var tt, k:word;
Begin
tt:=0;
For k:=1 to n do tt:=tt+a[k];
For k:=n Downto 1 do
If check (tt,n,k) then
Begin
Result(tt,n,k);
Exit;
End;
Thầy Trần Thông Quế
End;
Procedure Test;
var n:word;
Begin
randomize;
Repeat
clrscr;
n:=random(mn)+1;
RandomGene(n Div (random(5)+1),n);
View(n);
Partion(n);
Until readkey=#27;
End;
Begin Clrscr;
Test;
End.
21-(CHỌN SỐ Ở MỖI HÀNG MỖI CỘT) Cho trước ma trận vuông cấp n. Hãy chọn mỗi số ở mỗi hàng
(khác nhau), mỗi cột (khac nhau) sao cho tổng của chúng lớn nhất.
{ Test1: Test2: Test3:
3 4 4
7 9 6 4 3 4 5 241 164 180 20
3 5 8 6 7 8 9 162 81 102 96
8 6 9 1 9 7 4 169 197 80 153
1 3 5 7 11 26 214 223 }
Uses Crt;
Var a:Array[1..20, 1..20] of word;
b:Array[1..20] of Boolean;
x,ng:Array[1..20] of Byte;
r,n,i,dem:Byte;
max,sum:integer;
fi,fo:Text;
Procedure Doc;
Var i,j:word;
Begin
Assign(fi,'mang.in'); Reset(fi);
Readln(fi,n);
For i:=1 to n do
For j:=1 to n do
read(fi,a[i,j]);
Close(fi);
End;
Procedure Ghi;
Var i,j:word;
Thầy Trần Thông Quế
Begin
Assign(fo,'mang.ou'); Rewrite(fo);
For i:=1 to n do
Begin
For j:=1 to n do
Write(fo,a[i,j]:4);
Writeln(fo);
End;
End;
Procedure Xuly;
Var i: Word;
Begin
If sum>max Then
Begin
max:=sum;
ng:=x;
End;
End;
Procedure Xuat;
var i:Word;
Begin
Writeln(fo,' Tong max cua cac phan tu da chon=',max);
Writeln(fo,'Va cac phan tu ay la:');
For i:=1 to n do
Write(fo,a[i,ng[i]]:4,'(',i,',',ng[i],')');
End;
Procedure Chon(i:word);
Var j:Word;
Begin
For j:=1 to n do
If b[j] Then
Begin
x[i]:=j;
sum:=sum+a[i,j];
b[j]:=false;
if i=n Then xuly else chon(i+1);
b[j]:=true;
sum:=sum-a[i,j];
End;
End;
Begin clrscr;
Doc;
Ghi;
max:=0; sum:=0;
For i:=1 to n Do
Thầy Trần Thông Quế
b[i]:=true;
chon(1);
Xuat;
Close(fo);
Writeln('Done! Go ENTER -> ve Program; Go F3 -> Go MANG.OU: Xem kqua.');
Readln;
End.
PHẦN IV. XÂU KÝ TỰ (STRING)
(Trừ bài 1, không có bài nào dễ với học sinh, sinh viên)
Lập trình giải các bài toán sau:
1/(CHUẨN HÓA XÂU). Cho trước một xâu (dài < 256 ký tự) chứa các từ (Word). Giữa các từ của xâu có
nhiều hơn một dấu cách (ký tự trống). Hãy khử các dấu cách giữa các từ, chỉ GIỮ LẠI MỘT DẤU CÁCH
giữa chúng. Xâu như vậy gọi là xâu chuẩn.
(Từ là một xâu con không chứa dấu cách thuộc xâu đã cho mà nó được kết thúc bởi dấu cách SPACE, hoặc
dấu TAB.)
CODE.
ses crt;
var i:Byte; s:string;
Begin Clrscr;
Write('Nhap vao xau s co vai dau trong o giua cac tu:'); Readln(s);
While s=#32 do Delete(s,1,1);
While s[length(s)]=#32 do
Delete(s,length(s),1);
i:=1;
Repeat
If (s[i]=#32) and (s[i+1]=#32) then Delete(s,i,1)
Else Inc(i);
Until i>Length(s); {da xet het cac pt cua xau}
Write('Xau da khu trong
Thầy Trần Thông Quế
If xau[1] In chuthg Then xau[1]:=Upcase(xau[1]);
For i:=2 to d do
If (xau[i-1]=#32) and (xau[i] In chuthg) Then
xau[i]:=Upcase(xau[i]);
Write('Chu cai dau moi tu sua thanh chu hoa:',xau);
Readln;
End.
3/ (ĐỘ DÀI MAX CỦA XÂU CON CHUNG). Cho trước hai xâu s1 và s2. Tính độ dài max của xâu con
chung.
Vào: s1=xabcxxabcdxd; s2=aybcyabcdydy
Ra do dai max doan chung 2 xau=4
Uses Crt;
Var s1, s2:string;
Function lonnhat(a,b:integer):integer;
Begin
If (a>b) then lonnhat:=a
Else lonnhat:=b;
End;
Function DodaiMaxXauchung(Var x,y:string):integer;
Var m,n,i,j,v,t,kmax: integer;
a:array[1..255] of integer;
Begin
m:=length(x); n:=length(y);
kmax:=0;
Fillchar(a,sizeof(a),0);
For i:=1 to m do
Begin
v:=0;
For j:=1 to n do
Begin
t:=a[j];
If x[i]=y[j] then a[j]:=v+1
Else a[j]:=0;
kmax:=lonnhat(kmax,a[j]);
v:=t;
End;
End;
DodaiMaxXauchung:=kmax;
End;
Begin clrscr;
Write('xau s1='); Readln(s1);
Write('Xau s2='); Readln(s2);
Write('Do dai max cua doan chung thuoc 2 xau=',DodaiMaxXauchung(s1,s2));
Readln;
End.
Thầy Trần Thông Quế
*4/ (ĐOẠN LẶP (ĐẦU BÀI LẤY TRONG “NHỮNG VIÊN NGỌC LẬP TRÌNH” CỦA JON BENTLEY-
BẢN DỊCH TIẾNG VIỆT: GIA VIỆT & MINH TRUNG. NXB THỐNG KÊ,11/2002)) Cho xâu s có độ dài
n. Xác định 2 số i, j thỏa mãn điều kiện 1 i < j n và k là số lớn nhất sao cho s[i] = s[j], s[i+1] = s[j+1], . .
., s[i+k-1] = s[j+k-1]. Hai đoạn bằng nhau trong s gồm k ký tự là s[i..i+k-1] và s[j..j+k-1] với i
Thầy Trần Thông Quế
Ví dụ. Vào: (AB3(C2D)2(C5D)0)2A3
Ra: ABBBCCDCCDABBBCCDCCDAAA
BẢNG DÒ VẾT CỦA PROGRAM:
n c m t GIẢI THÍCH
1 A 1 Viết A 1 lần
2 B 2 Viết B 2 lần
3 C 2 Viết C 2 lần
4 D 1 Viết D 1 lần
5 # 2 3 Không có ký tự để viết. Lặp 2 lần từ bước 3 đến bước 5
6 # 2 1 Không có ký tự để viết. Lặp 2 lần từ bước 1 đến bước 6
7 A 3 Viết A 3 lần.
CODE.
Uses Crt;
Const max=500;
chuso=['0'..'9']; chucai=['A'..'Z'];
Type mi1=Array[0..max] of integer;
mc1=Array[0..max] of char;
Var M,T,R,st: mi1; {M:so lan lap; T: tu;R: luu; st:Stack}
c:mc1; p:integer; {dinh stack} s:string;
v:integer; {index cua stack}
n: integer;
Procedure Incre_Index;
Begin
While (s[v]=#32) do
Inc(v);
End;
Function Napso:integer;
var so:integer;
Begin
so:=0;
Incre_Index;
If Not (s[v] in Chuso) then
Begin
Napso:=1;
Exit;
End;
While (s[v] In Chuso) do
Begin
so:=so*10+(Ord(s[v])-Ord('0'));
Inc(v);
End;
Napso:=so;
End;
Thầy Trần Thông Quế
Procedure GanCnvaMn(ch:char);
Var so:integer;
Begin
Inc(v); so:=Napso;
If so=0 then Exit;
Inc(n);
C[n]:=ch; M[n]:=so;
End;
Procedure Chenngoac;
Begin
Inc(v);
Inc(p);
st[p]:=n+1;
End;
Procedure RutphantukhoiStack;
var tu, so: integer;
Begin
Inc(v); tu:=st[p];
Dec(p);
so:=Napso;
If (so=0) Then n:=tu-1;
If (so<2) Then Exit;
Inc(n);
C[n]:='#'; M[n]:=so; T[n]:=tu; R[n]:=so;
End;
Procedure Xulytiep;
Var i,j: integer;
Begin
Writeln('CAC BUOC KHAI TRIEN VA XAU KHAI TRIEN CUA XAU THU GON:');
For i:=1 to n do
Begin
Write(#13#10,i,'. ',C[i],#32,M[i],#32);
If C[i]='#' Then Write(T[i]);
Writeln;
End;
i:=1;
While (i<=n) Do
Begin
If (C[i]='#') Then
Begin
Dec(R[i]);
If (R[i]=0) Then
Begin
R[i]:=M[i];
Inc(i);
End
Thầy Trần Thông Quế
Else i:=T[i];
End
Else
Begin
For j:=1 to M[i] Do
Write(C[i]);
Inc(i);
End;
End;
End;
Procedure Khaitrien(Var s:string);
Var i:integer;
Begin
s:=s+'#'; v:=1; p:=0;
While (s[v]<>'#') Do
Begin
If(s[v] In Chucai) Then GanCnvaMn(s[v])
Else If (s[v]='(') Then ChenNgoac
Else If (s[v]=')') Then RutphantukhoiStack
Else Inc(v);
End;
Writeln(s,':');
Xulytiep;
End;
Begin clrscr;
s:='(AB3(C2D)2(C5D)0)2A3';
Khaitrien(s);
Readln;
End.
*6/)(TỪ CHUẨN) Một từ loại M là dãy các chữ số có giá trị từ 1 đến M. Độ dài của từ là số lượng các chữ
số trong dãy. Từ loại M được gọi là từ chuẩn nếu nó không chứa hai đoạn con kề liền trong nó giống nhau.
Cho trước số nguyên N, tìm và ghi lên text file TUCHUAN.OU tất cả các từ chuẩn loại 3 dài N
(1<=N<=40000)
CODE.
Uses Crt;
Const mn=40;mn1=40000;
fo='tuchuan.ou';
Var v:Array[0..mn1] of byte;
n:integer;
f:text;
Function Bang(i,k:integer):Boolean;
Var j:integer;
Begin
Bang:=false;
For j:=0 to k-1 do
Thầy Trần Thông Quế
If (v[i-j]<>v[i-k-j]) Then Exit;
Bang:=true;
End;
Function Chuan(i:integer):Boolean;
Var k:integer;
Begin
chuan:=false;
For k:=1 to (i DIV 2) do
If Bang(i,k) then Exit;
Chuan:=true;
End;
Function Tim(i:integer):Boolean;
Begin
Tim:=true;
While (v[i]<3) do
Begin
Inc(v[i]);
If chuan(i) then Exit;
End;
Tim:=False;
End;
Procedure Ketqua(d:integer);
Var i:integer;
Begin
If d=0 then Write(f,'Vo nghiem')
Else
Begin
Write(f,'Ngiem thu ',d,':');
For i:=1 to n Do
Write(f,v[i]);
Writeln(f);
End;
End;
Procedure Timtu(len:integer);
Var i:integer;
d:longint;
Begin
If(len<1) Or (len>mn) then Exit;
n:=len;
For i:=1 to n do v[i]:=0;
Assign(f,fo); Rewrite(f);
i:=1;
d:=0;
Repeat
If(i>n) then
Thầy Trần Thông Quế
Begin
Inc(d);
Ketqua(d);
i:=n;
End;
If (i<1) then
Begin
If d=0 then Ketqua(0);
close(f);
Write('Done.');
Readln;
Exit;
End;
If Tim(i) Then Inc(i)
Else
Begin
v[i]:=0;
Dec(i);
End;
Until False;
End;
Procedure Test;
Begin
Clrscr;
Timtu(7);
End;
Begin {Main}
Test;
End.
7/ (DECODING BINARY-CODE) Cho mã nhị phân (Binary-code) của n chữ cái đầu tiên trong Alphabet
tiếng Anh. Biết rằng không có mã nào là khúc đầu của mã khác, và độ dài max của mỗi mã là 10. Lập trình
giải mã một đoạn cho trước.
Vào
5
0000
0001
0010
0011
110
0000000100010000
Ra
5
0000
0001
Thầy Trần Thông Quế
0010
0011
110
14 E
16 A
17 B
18 C
19 D
CODE.
Uses crt;
Const fi='code.in'; fo='code.ou';
mn=2050;
Var a:Array[0..mn] of char; {mang tao Heap:cay ma}
Procedure giaima;
Var i,j,v,n:integer;
ch:char;
f,g:text;
x:string;
Begin
ch:='A';
Assign(f,fi); Reset(f);
Assign(g,fo); Rewrite(g);
Readln(f,n); Writeln(n,#13#10);
Fillchar(a,sizeof(a),0);
For i:=1 to n do
Begin
Readln(f,x); Writeln(x);
v:=1;
For j:=1 to length(x) do
If x[j]='0' Then v:=v*2
Else v:=v*2+1;
a[v]:=ch;
inc(ch);
End;
Writeln(#13#10);
For i:=1 to mn do
If(a[i]<>#0) then Writeln(i,#32,a[i]);
{Decoding}
While Not Eof(f) Do
Begin
Read(f,ch);
If (ch='0') or (ch='1') Then
Begin
v:=2*v;
If ch='1' Then v:=v+1;
If (a[v]<>#0) then
Thầy Trần Thông Quế
Begin
Write(g,a[v]);
v:=1;
End;
End;
End;
Close(f); close(g);
End;
Begin clrscr;
giaima;
Writeln('DONE!');
Readln;
End.
8/ (CEASAR CODE) Trong mật mã học, mật mã Caesar, còn gọi là mật mã dịch chuyển, là một trong
những mật mã đơn giản và cổ nhất (nên hiện nay hầu không dùng). Mật mã này là một dạng của mật mã
thay thế, trong đó mỗi ký tự trong văn bản được thay thế bằng một ký tự cách nó một đoạn trong bảng chữ
cái để tạo thành bản mã. Vĩ dụ, nếu độ dịch là 3 (3 gọi là khóa mã), A sẽ được thay bằng D, Ă sẽ được thay
bằng C và cứ thế đến hết. Phương pháp được đặt tên theo Caesar, vị hoàng đế đã sử dụng nó thường xuyên
trong công việc.
Ví dụ:
Bản chữ cái chưa mã hóa (bản rõ): ABCDEFGHIJKLMNOPQRSTUVWXYZ
Bản chữ cái mật mã: DEFGHIJKLMNOPQRSTUVWXYZABC
Sau Ceasar, các nhà mật mã học, tổng quát mã này lên một chút: chọn K (số nguyên)
làm khóa mã và ký tự thứ I trong Alphabet được mã bởi ký tự thứ (I + K) MOD 27 với
0 <=I<=26.
Bài toán của chúng ta là: Cho trước từ điển gồm các từ khác nhau từng đôi một và không từ nào rỗng, chứa
các chữ cái hoa. Một văn bản S được mã hóa bởi mã Ceasar.
Hãy xác định khóa K để giải mã văn bản ấy (tức là cho biết bản rõ).
Dữ liệu vào lưu trên text file tên là CEASAR.IN, dòng thứ nhất ghi số từ N thuộc từ điển (N<=100); N dòng
tiếp theo ghi các từ của từ điển, mỗi từ có độ dài <= 20 và ghi trên một dòng. Dòng cuối cùng ghi văn bản S
có không quá 250 chữ cái đã được mã hóa bởi mã Ceasar nói trên. Lập trình chọn khóa K để khôi phục bản
rõ sao cho bản rõ chứa nhiều từ nhất của từ điển.
Dữ liệu ra lưu trên text file có tên CEASAR.OU mà dòng đầu ghi giá trị khóa K, dòng tiếp theo ghi bản rõ
của văn bản mã hóa S. Xem:
Vào. CEASAR.IN
7
HANOI
YES
PEDAGOGICAL
HELLO
UNIVERSITY
ITEM
HERO
IBOPJAQFEBHPHJDBMAVOJWFSTJUZAJJ bản mã
Thầy Trần Thông Quế
CEASAR.OU
1
HANOI PEDAGOGICAL UNIVERSITY II
CODE.
Uses crt;
Const max=250; fi='Ceasar.In'; fo='Ceasar.Ou';
Type st21=String[21];
tudien=Array[1..max] Of st21;
Var td:tudien; ma,vb,kt,gm:string;
km,sl,slm:Byte; f:Text; n,k:Byte;
Procedure Init;
Var i:Byte;
begin
kt:=' ';
For i:=Ord('A') to Ord('Z') Do
kt:=kt+Char(i);
kt:=kt+kt;
Assign(f,'Ceasar.In'); Reset(f); Readln(f,n);
For i:=1 to n Do
Begin
Readln(f,td[i]); td[i]:=td[i]+' ';
End;
Readln(f,ma);
Close(f);
End;
Function Before(c:Char; k:Byte): Char;
Begin
Before:=kt[pos(c,kt)+27-k];
End;
Procedure Key_Find;
Var i,j:Byte;
Begin
km:=0; slm:=0;
For k:=1 to Length(ma) Do
Begin
vb[0]:=Succ(ma[0]);
For j:=1 to Length(ma) Do
vb[j]:=Before(ma[j],k); sl:=0;
For j:=1 to n Do
If pos(td[j],vb)>0 Then sl:=sl+1;
If sl>slm Then
Begin
slm:=sl; gm:=vb; km:=k;
End;
Thầy Trần Thông Quế
End;
End;
Procedure Result;
Begin
Assign(f,'Ceasar.Ou'); Rewrite(f);
Writeln(f,km); Writeln(f,gm);
Close(f);
End;
Procedure Proccess;
Begin
Key_Find;
Result;
End;
Begin clrscr;
Init;
Proccess;
Write('Done!');
Readln;
End.
**9/ (BURROWS-WHEELER CODE, TẮT: BW-CODE, ĐỀ SƠ KHẢO OLYMPIC TIN HỌC QUỐC
TẾ).
Có nhiều phương pháp mã hoá thông tin được sử dụng rộng rãi để đảm bảo tính chất an toàn, bảo mật dữ
liệu. Ở vòng sơ loại thi tin học Quốc tế, có bài toán về mã BW đề cập tới một cách tiếp cận mới trong kỹ
thuật mã hóa và giải mã. Burrows Wheeler đề xuất phương pháp mật mã như sau: ví dụ ta cần mã hoá từ
BANANA, các bước tiến hành là:
Bước 1: Từ cần mã hoá được dịch chuyển vòng tròn và tạo thành một ma trận L*L ký tự, trong đó L là độ
dài của từ. Ta có:
BANANA
ANANAB
NANABA
ANABAN
NABANA
ABANAN
Bước 2: Sắp xếp lại các dòng của ma trận theo thứ tự từ điển:
ABANANANABANANANABBANANANABANANANABA
Bước 3: Tạo một xâu từ các ký tự CUỐI ở mỗi dòng, hiển thị xâu này và cho biết từ gốc là từ thứ mấy trong
ma trận nhận được ở bước 2 (tức là cần tạo cặp (st,d): st-xâu đã mã, 4: index của từ gốc trong xâu đã sắp từ
điển. Ta có (NNBAAA,4) là từ mã BURROWS WHEELER. Dưới đây là CODE.
Program BW_code;
Uses Crt;
Var n:integer;
Thầy Trần Thông Quế
id:Array[0..256] of integer;
Procedure Doichoid(i,j:integer);
Var t:integer;
Begin
t:=id[i];
id[i]:=id[j];
id[j]:=t;
End;
Function So(Var s:string; i,j:integer):integer;
Var k: integer;
Begin
For k:=1 to n do
Begin
If (s[i]<>s[j]) Then
Begin
If s[i]
Thầy Trần Thông Quế
If id[i]=1 then d:=i;
End;
End;
Procedure Bs(var u:string);
Var i,j:integer;
Begin
For i:=1 to n do id[i]:=i;
For i:=1 to n-1 do
For j:=n downto i+1 do
If u[id[j]]
Thầy Trần Thông Quế
80
Thầy Trần Thông Quế
Readln(f,y);
Inc(d);
For i:=1 to m Do
If y[i]=x[i] then Inc(h[i]) Else h[i]:=1;
For i:=1 to m Do
Begin
dt:=Dientich(i,c1,c2);
If dt>dtmax Then
Begin
dtmax:=dt;
axmax:=d-h[i]+1; aymax:=c1;
cxmax:=d; cymax:=c2;
End;
End;
x:=y;
End;
Close(f);
Ghi;
End;
Procedure Xem;
Var g:Text; Line:String;
Begin
Writeln('KET QUA CHAY CHUONG TRINH:');
Writeln('* * * * * * * * * * * * *');
Writeln;
Assign(g,'CnMax.Ou'); Reset(g);
While Not SeekEof(g) Do
Begin
Readln(g,Line);
Writeln(#32:7,Line);
End;
Close(g);
End;
Begin clrscr;
Run;
Xem;
Readln
End.
Thầy Trần Thông Quế
Test Vào: Palindr.vao
9 độ dài xâu s
baeadbadb
Ra: Palindr.ra
4 số ít nhất các ký tự cần xóa
CODE.
Uses Crt;
Const mn=51;
fi='Palindro.in';
Type mi1=Array[0..mn] of Integer;
mi2=Array[0..mn] of mi1;
mc1=Array[0..mn] of Char;
Var n:integer;
f:Text;
s:mc1;
d,v:mi1;
c:mi2;
Procedure Doc;
Var i:integer;
Begin
Assign(f,fi); Reset(f);
Read(f,n);
For i:=1 to n do Read(f,s[i]);
End;
Function max(a,b:Integer):Integer;
Begin
If (a>b) Then max:=a
Else max:=b;
End;
Function Dequy(i,j:integer):integer;
Begin
if (i>j) then Dequy:=0
Else If i=j Then dequy:=1
Else
If s[i]=s[j] Then Dequy:=Dequy(i+1,j-1)+2
Else
Dequy:=Max(Dequy(i,j-1), Dequy(i+1,j));
End;
Procedure Qhd2; {DunG 2 mang 1-chieu v va d}
Var i,j: Integer;
Begin
Fillchar(v,sizeof(v),0);
For j:=1 to n do
Begin
Thầy Trần Thông Quế
d[j]:=1;
For i:=j-1 Downto 1 do
Begin
If s[i]=s[j] Then d[i]:=v[i+1]+2
Else d[i]:=Max(v[i],d[i+1])
End;
v:=d;
End;
Writeln(n-d[1])
End;
Procedure Qhd1; {Dung 1 mang 1-chieu}
Var i,j,t,tr:Integer;
Begin
For j:=1 to n do
Begin
Tr:=0;
d[j]:=1;
For i:=j-1 downto 1 do
Begin
t:=d[i];
If s[i]=s[j] then d[i]:=tr+2
else d[i]:=Max(d[i],d[i+1]);
tr:=t;
End;
End;
Write(n-d[1]);
End;
Procedure Test;
Begin
Doc;
Writeln('Dung Dequy: so it nhat cac ky tu can xoa=', n-Dequy(1,n));
Write('Dung 2 Mang 1 chieu:so it nhat ca ky tu can xoa=');
Qhd2;
Write('Dung 1 Mang mot chieu:so it nhat cac ky tu can xoa=');
Qhd1;
End;
Begin Clrscr;
Test;
Readln;
End.
12/ (OLYMPIC MOCKBA -TỪ ĐIỂN) Từ điển Dic gồm nhiều nhất 100 từ khác nhau đôi một. Mỗi từ có
độ dài tối đa là 50 và được viết trên một dòng. Cho trước xâu s có độ dài không quá 200 ký tự. Hãy cho biết
cần xóa khỏi s bao nhiêu ký tự để phần còn lại tạo thành một dãy liên tiếp các từ trong từ điển Dic, mỗi từ
có thể xuất hiện nhiều lần. Từ điển Dic được lưu trên text file Dic.in và kết qủa chạy program lưu tren text
file Dic.ou có cấu trúc và nội dung như dưới đây:
Thầy Trần Thông Quế
Dic.in Dic.ou
6 5
abba
not
is
astra
saint
panama
saintpavnamtranasnotsaintabba
Dic.ou
5
Giải thích
*Số ký tự cần xóa=5
*Các ký tự đã xóa là: v, t, r, n, a (các chữ gạch chân): saintpavnamtranaisnotsaintabba
*Các từ ghép lại là: 5,6,3,2,5,1: saintpanamaisnotsaintabba
CODE.
Uses Crt;
const fi='dictio.in'; fo='dictio.ou';
Type st=string[60];
Var f,g:Text;
s:string[200];
w:Array[1..110] of st;
d:Array[0..205] of integer;
n, kq:integer;
Procedure Doc;
Var i:integer;
Begin
Assign(f,fi); Reset(f);
Readln(f,n);
For i:=1 to n do Readln(f,w[i]);
Readln(f,s);
Close(f);
End;
Procedure Ghi(v:integer);
Begin
Assign(g,fo); Rewrite(g);
Writeln(g,v);
Close(g);
End;
Function So(var w:st; i:integer):integer;
Var j:integer;
Begin
so:=0;
Thầy Trần Thông Quế
j:=Length(w);
If j>i Then Exit;
If w[j]<>s[i] then Exit;
For I:=i Downto 1 do
If(s[i]=w[j]) Then
Begin
Dec(j);
If j=0 Then
Begin
So:=i; exit;
End;
End;
End;
Function min(a,b:integer):integer;
Begin
If(a
Thầy Trần Thông Quế
PHẦN V. ĐỆ QUY & QUAY LUI
(RECURSION & BACKTRACKING)
VIẾT CÁC HÀM HOẶC THỦ TỤC ĐỆ QUY GIẢI CÁC BÀI TOÁN SAU:
1/ Tìm ước số chung lớn nhất (USCLN) của 2 số. Áp dụng để tìm USCLN của n số đọc từ bàn phím vào.
CODE:
Program uscln;
Uses crt;
Var i,n,uc,tt:Integer;
a:array[1..1000] of integer;
Function uscmax(x,y:integer):integer;
Begin
If (y=0) Then uscmax:=x
Else uscmax:=uscmax(y,x MOD y)
End;
Begin clrscr;
Randomize;
Repeat
Write('Ban can bao nhieu so?:'); Readln(n);
For i:=1 to n do a[i]:=Random(100);
{Begin
Writeln('So thu ',i,':');
Readln(a[i]);
End;}
Writeln('Day so vua nhap:');
For i:=1 to n do Write(a[i]:3);
i:=1;
Repeat
uc:=uscmax(uc,a[i]);
Inc(i);
Until i=n+1;
Writeln;
Write('Uoc so chung lon nhat cua ',n,' so vua nhap=',uc);
Writeln;
Write('More (1/0)?. More->go 1; Stop->go 0:'); Readln(tt);
Until tt=0;
End.
2/ (KHÔNG ĐƯỢC DÙNG MẢNG). Tìm USCLN của 5 số đọc từ bàn phím vào. (Bài này có vẻ khó hơn
bài trên với một số học sinh!)
CODE:
Program uso;
Uses crt;
Var a,b,c,d,e,uc1,uc2,uc3,uc1a,uc1b:integer;
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Function ucln(x,y:longint):longint;
Begin
if y=0 then ucln:=x
Else ucln:=ucln(y,x MOD y);
End;
Begin clrscr;
Write('Nhap 5 so a,b,c,d,e:'); Readln(a,b,c,d,e);
uc1:=ucln(a,b);
uc2:=ucln(c,d);
uc3:=ucln(e,uc2);
uc1a:=ucln(uc1,uc2);
uc1b:=ucln(uc1a,uc3);
Write('Usc lon nhat cua 5 so vua nhap:',ucln(a,b));
Readln;
End.
3/ Đảo ngược một số nguyên dương gồm n chữ số (n>=2) đọc từ bàn phím vào. Ví dụ 2017 đảo ngược
thành 7102
CODE:
Program Dao_so;
Uses crt;
Var n:longint;
Procedure Daoso(so:longint);
Var csdv,caccscl:integer;
Begin
If (so<10) then Write(so)
Else Begin
csdv:=so MOD 10; {xac dinh chu so hang don vi}
caccscl:=so DIV 10; {xac dinh cac chu so con lai}
Write(csdv);
Daoso(caccscl);
End;
End;
Begin clrscr;
Writeln;
Write('Nhap vao mot so nguyen duong:'); Readln(n);
Write('So ',n,' viet nguoc lai la:');
Daoso(n);
Readln;
End.
4/ (DÃY FIBONACCI NỔI TIẾNG). Hai bài thú vị về dãy này:
4.1- Tìm và in lên màn số Fibonacci thứ k.
CODE:
Program So_Fibonacci_thu_K;
USES CRT;
Var K:Longint; tt:Byte;
FUNCTION Fibo(m:Longint):Longint;
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Begin
If ((m=1) Or (m=2)) Then
Fibo:=1
Else
Fibo:=Fibo(m-1) + Fibo(m-2);
End;
BEGIN CLRSCR;
Repeat
Writeln('TIM SO FIBONACI THU K');
Writeln('---------------------');
Write('-Nhap so K= ');
Readln(K);
Writeln('So Fibonacci thu ',k,' = ',Fibo(K));
Writeln;
Write('More (1/0)?. Come on -> Press 1; Stop -> Press 0:');
Readln(tt);
Until tt=0;
END.
4.2- Cho trước độ dài n. Tìm và in lên màn dãy Fibonacci có độ dài n cho trước.
CODE:
Program Fibo;
Uses crt;
Var i,n: longint;
Function Fibona(i: longint): longint;
Begin
if (i<3) then fibona:=1
Else Fibona:=Fibona(i-1)+Fibona(i-2);
End;
Begin clrscr;
Write('n='); Readln(n);
Write('Day Fibonaci can tim ung voi do dai cho truoc ',n,' la:');
For i:= 1 to n do
Write(Fibona(i):6);
Readln
End.
5/ Dùng ĐỆ QUY, tìm cách và hiển thị các bước của cách ấy chuyển n đĩa có lỗ ở giữa (n đọc từ bàn phím
vào) từ cọc 1 sang cọc 2 được dùng cọc trung gian 3 trong quá trình chuyển. Luật chơi:
Thầy Trần Thông Quế
If n=1 Then
Begin
Writeln('Chuyen dia tu coc ',C1,' sang coc ',C2);
Inc(count);
End
Else
Begin
Move(n-1,C1,C3,C2);
Move(1,C1,C2,C3);
Move(n-1,C2,C1,C3);
End;
End;
Begin clrscr;
Repeat
Write('Nhap so dia can chuyen:'); Readln(n);
count:=0;
Move(n,1,2,3);
Write('So lan chuyen dia=',count);
Writeln;
Writeln('= = = = = = = = = = = = = = ');
Write('Thu nua chu (c/k)? Tiep=>go c, ngung=> go k:');
Readln(hoi);
Until hoi IN ['k', 'K'];
End.
CHÚ Ý BỔ ÍCH: KHI TEST, CHỚ CÓ TEST VỚI SỐ ĐĨA LỚN, VÍ DỤ VỚI N=64. Dùng trị số này,
có chồng chất 100 lần tuổi thọ của bạn cũng không đủ thời gian chờ kết quả chạy chương trình (với N=64) !
6/ Liệt kê các hoán vị của N số đọc từ bàn phím vào và cho biết tổng số các hoán vị ấy. Yêu cầu: Mỗi lần
chỉ hiện lên màn 20 kết quả, xem tiếp gõ ENTER. Ví dụ vào N=6 thì tổng số hoán vị bằng 720.
Program HoanVinhodequy;
Uses crt;
Type chuoi=Array[1..20] of Integer;
Var a:chuoi; m,n,i,dem:integer;
Procedure Init;
Var i:Integer;
Begin
for i:=1 to n do a[i]:=i;
End;
Procedure Doicho(var x,y:integer);
var tg:integer;
Begin
tg:=x; x:=y;y:=tg;
End;
Thầy Trần Thông Quế
Procedure Inra;
var i:integer;
Begin
Writeln; Inc(dem);
For i:=1 to n do
Write(a[i]:4);
If (dem MOD 20)=0 then Readln;
End;
Procedure Hoanvi(i:integer);
var j:integer;
Begin
If i=1 then Inra
Else
For j:=i downto 1 do
Begin
Doicho(a[i],a[j]);
Hoanvi(i-1);
Doicho(a[i],a[j]);
End;
End;
{Main Program}
Begin clrscr;
dem:=0;
Write('Nhap so luong so n can hoan vi:');readln(n);
Writeln(' Cac hoan vi cua ',n,' so: ');
Init;
Hoanvi(n);
Writeln; Writeln;
If dem<>0 then Write('Tong cong co ',dem,' hoan vi cua ',n,' so.');
Readln;
End.
7/Vẽ liên tiếp các hình vuông nội tiếp trong hình vuông đã cho, sao cho các đỉnh của hình vuông nội tiếp là
điểm giữa của các cạnh của hinh vuông ngoại tiếp nó.
KHUẾN CÁO ĐÁNG NGHE: Code đồ họa dưới đây (cũng như mọi Code đồ họa khác), đòi hỏi chạy ở
MODE FULL CREEN, mà các Windows từ VERSION 7 trở lên không hỗ trợ FULL CREEN. Nói vậy tức
là bạn chỉ chạy được các GRAPHIC PROGRAM trong WinXp.
CODE (Phải chạy trên nền WinXp)
uses crt, graph;
const w=400;
Var gd,gm:integer;
procedure hv(x1,y1,x2,y2,x3,y3,x4,y4, sb:integer);
Begin
setcolor(sb mod 15+1);
line(x1,y1,x2,y2);
line(x2,y2,x3,y3);
Thầy Trần Thông Quế
line(x3,y3,x4,y4);
line(x4,y4,x1,y1);
If sb>0 then
hv((x1+x2) DIV 2, (y1+y2) DIV 2,(x2+x3) DIV 2,(y2+y3) DIV 2,
(x3+x4) DIV 2,(y3+y4) DIV 2,(x4+x1) DIV 2,(y4+y1)DIV 2,sb-1);
End;
Begin clrscr;
gd:=detect;
Initgraph(gd,gm,' ');
hv((getmaxX-w) DIV 2,(getmaxY-w) DIV 2,(getmaxX-w) DIV 2,
(getmaxY+w) DIV 2,
(getmaxX+w) DIV 2,(getmaxY+w) DIV 2,(getmaxX+w) DIV 2,
(getmaxY-w) DIV 2,16);
Readln;
closeGraph;
End.
8/ Viết các hàm đệ quy tính các tổng S sau:
8.1- Tính N!! . Sau đó dùng hàm đó để tính: S=1!!-2!!+…+(-1)k+1k!! (k<1000)
8.2- S=1+22+33+44. . .+nn
8.3- S=
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Var p,a:array[1..100] of char;
i,j,k,h,d:longint; n:real;hoi:char;
Procedure Inra;
Begin
Write('(((((');
For i:=1 to 6 do
Begin
If i=1 then Write(i,a[i]);
If i>1 then Write(i,')',a[i]);
End;
Writeln;
d:=d+1;
End;
Procedure Test(k:integer);
Var j,i1:integer; t:real;
Begin
For j:=1 to 4 do
Begin
a[k]:=p[j];
If k=5 then
Begin
t:=1;
For i1:=2 to 6 do
Begin
If a[i1-1]='-' then t:=t-i1;
If a[i1-1]='+' then t:=t+i1;
If a[i1-1]='*' then t:=t*i1;
If a[i1-1]='/' then t:=t/i1;
End;
If t=n then Inra;
End
Else Test(k+1);
End;
End;
Begin clrscr;
Repeat
Writeln;
Write('Nhap gia tri n can co='); Readln(n);
d:=0;
p[1]:='-';
p[2]:='+';
p[3]:='*';
p[4]:='/';
Test(1);
Writeln;
Writeln(' Co ',d,' cach dien cac phep tinh de bieu thuc da cho co gia tri bang so ',n:9:2);
Thầy Trần Thông Quế
Write('Another Test (y/n)?'); Readln(hoi);
Until hoi In ['n','N'];
End.
11- Cho trước bộ số 1, 2, 3, 4. Liệt kê tất cả các số dài n lập nên từ bộ số đã cho.
CODE.
Uses Crt;
Var n:Byte;
a:Array[1..20] of Byte; Ans:Char;
Procedure Result_Print;
Var i:Byte;
Begin
For i:=1 to n Do
Write(a[i]);
End;
Procedure For_Recur(i:integer);
Var j:Byte;
Begin
For j:=1 to 4 do
Begin
a[i]:=j;
If i
Thầy Trần Thông Quế
Function uscln(a,b:integer):integer;
Begin
while a<>b do
begin
if a>b then a:=a-b
Else b:=b-a;
end;
uscln:=b;
end;
Procedure thu(k:integer);
var j,i1,us1,i,j1:integer;
Begin
for j:=z to n do
if p[j] then
Begin
c[k]:=a[j]; p[j]:=False;
If k>1 then
Begin
dem:=dem+1;
Writeln('* Tap con thu ',dem,' la:');
For i1:=1 to k do
write(c[i1]:4);Writeln;
us1:=c[1];
For j1:=2 to k do us1:=uscln(us1,c[j1]);
Write('Uoc so chung lon nhat cua ');
Writeln(' tap con thu ',dem,' la:',us1);
End;
If k<>n then
Begin
z:=j+1; Thu(k+1);
End;
p[j]:=true;
z:=j-1;
End;
End;
Begin clrscr;
Write('Vao n='); Readln(n);
For i:=1 to n do
Begin
Write('a[',i,']='); Readln(a[i]);
End;
dem:=0; z:=1;
For i:=1 to n do p[i]:=true;
Thu(1);
Writeln;
Writeln('Voi so n=',n,' vua nhap vao, so tap con =',dem);
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Readln { không có “;” cũng như có “;” }
End.
*13-Cho bộ 9 chữ cái a, b, c, d, e, f, g, h, i. Lập trình tạo các từ có từ 2 đến 4 chữ cái (trong đó có ít nhất 1
nguyên âm) thuộc bộ trên. Kết qủa lưu lên text file cactu.ou
Thầy Trần Thông Quế
Thầy Trần Thông Quế
PHẦN VI. BẢN GHI & TỆP (RECORD and FILES)
Lập trình làm các việc sau:
RECORD
1/Thực hiện các phép toán trên hai phân số.
Uses Crt;
Type phanso=Record
ts,ms:Integer;
End;
Var ps1,ps2,ps3:phanso; pheptoan,tiep: char;
err: Boolean;
Procedure Nhap(Var ps:phanso);
Begin
Write('Nhap tu:');Readln(ps.ts);
Write('Nhap mau:');Readln(ps.ms);
End;
Procedure Xuat(Var ps:phanso);
Begin
Write('(',ps.ts,'/',ps.ms,')');
End;
Procedure Cong(ps1,ps2:phanso; Var tps:phanso);
Begin
tps.ts:=ps1.ts*ps2.ms+ps1.ms*ps2.ts;
tps.ms:=ps1.ms*ps2.ms;
End;
Procedure Tru(ps1,ps2:phanso; Var tps:phanso);
Begin
tps.ts:=ps1.ts*ps2.ms-ps1.ms*ps2.ts;
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
tps.ms:=ps1.ms*ps2.ms;
End;
Procedure Nhan(ps1,ps2:phanso; Var tic:phanso);
Begin
tic.ts:=ps1.ts*ps2.ts;
tic.ms:=ps1.ms*ps2.ms;
End;
Function Uscln(a,b:integer):integer;
Begin
While a<>b do
If a> b then a:=a-b
Else b:=b-a;
Uscln:=a;
End;
Procedure Rutgon(Var ps:phanso);
Var uc:integer;
Begin
uc:=Uscln(ps.ts,ps.ms);
ps.ts:=ps.ts DIV uc;
ps.ms:=ps.ms DIV uc;
End;
Procedure Doidau(Var ps:phanso);
Begin
ps.ts:=-ps.ts;
End;
Procedure Ngichdao(Var ps:phanso);
Var tam:integer;
Begin
tam:=ps.ts;
ps.ts:=ps.ms;
ps.ms:=tam;
End;
{Main Prog.}
Begin clrscr;
Repeat
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Write('Nhap ps thu nhat:'); Writeln;
Nhap(ps1);
Write('Nhap ky hieu phep toan:'); Readln(pheptoan);
err:=false;
If pheptoan In ['+','-','*',':'] Then
Begin
Writeln;
Write('Nhap ps thu hai:');
Writeln;
Nhap(ps2);
Write('Ket qua:');
Xuat(ps1);
Write(pheptoan);
xuat(ps2);
Write('=');
Case pheptoan of
'+':Begin Cong(ps1,ps2,ps3); Rutgon(ps3); End;
'-':Begin
Tru(ps1,ps2,ps3);
Doidau(ps2);
cong(ps1,ps2,ps3);
Rutgon(ps3);
End;
'*':Begin nhan(ps1,ps2,ps3);Rutgon(ps3); End;
':':If ps2.ts<>0 then
Begin
Ngichdao(ps2);
Nhan(ps1,ps2,ps3);
Rutgon(ps3);
End
Else err:=true;
End;
If Not err Then
Begin
Xuat(ps3);
Writeln;
Write('Go phim bat ky de tiep tuc cong viec!'); Readln;
Clrscr;
End
Else Write('Loi: khong chia duoc cho Zero!');
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Writeln;
End
Else Writeln('Program chua lam duoc phep toan nay!');
Write('More(y/n)?, tiep -> go y, ngung -> go n:');
Readln(tiep);
Until tiep='n';
End.
2/ Thực hiện các phép toán trên hai đa thức
Uses Crt;
Const max=20;
Type dathuc=record
bac:integer;
hso:Array[0..max] of real;
End;
Var a,b,c:dathuc; i:integer;
Procedure Nhap(kh:String; var p:dathuc);
Begin
Writeln; Writeln;
With p do
Begin
Repeat
Write('Nhap vao lan luot bac ',Chr(Ord(kh[1])+7),
' va cac he so cua da thuc ',kh,'=');
Readln(bac);
If bac>max Then
Write('Bac cua da thuc phai <=max)',max);
Until (Bac>=1) And (Bac<=max);
For i:=bac downto 0 Do
Begin Write(#32:3,'a[',i,']='); Readln(hso[i]); End;
End;
End;
Procedure PolyDisp(kyhieu:string; p:dathuc);
Begin
Write(kyhieu,'=');
With p do
Begin
For i:=bac downto 1 Do
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Begin
If hso[i]<>0 Then
Begin
If Frac(hso[i])=0 Then
Write(hso[i]:0:0,'.x')
Else Write(hso[i]:0:2,'.x');
If i>1 then Write('^',i);
End;
If hso[i-1]>0 Then Write('+');
End;
If hso[0]<>0 Then
If Frac(hso[0])=0 Then Write(hso[0]:0:0)
Else Write(hso[0]:0:2);
End;
Writeln;
End;
Procedure PolyAdd(p,q:dathuc; Var sum:dathuc); {cong da thuc}
Var i,j:integer;
Begin
If p.bac>q.bac Then sum.bac:=p.bac
Else sum.bac:=q.bac;
For i:=sum.bac downto 0 Do
sum.hso[i]:=p.hso[i]+q.hso[i];
Write('Tong cua 2 d/thuc f(x) va g(x) la:');
Polydisp('S(x)',sum);
End;
Procedure PolySubt(p,q:dathuc; Var h:dathuc); {tru da thuc}
Var i,j:integer;
Begin
If p.bac>q.bac Then h.bac:=p.bac
Else h.bac:=q.bac;
For i:=h.bac downto 0 Do
h.hso[i]:=p.hso[i]-q.hso[i];
Write('Hieu cua 2 d/thuc f(x) va g(x) la:');
Polydisp('H(x)',h);
End;
Procedure PolyFact(p,q:dathuc; Var tic:dathuc); {nhan da thuc}
Var i,j:integer;
Begin
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
tic.bac:=p.bac+q.bac;
For i:=0 to tic.bac do tic.hso[i]:=0;
For i:=p.bac downto 0 Do
For j:=q.bac downto 0 Do
tic.hso[i+j]:=tic.hso[i+j]+p.hso[i]*q.hso[j];
Write('Tich cua 2 dthuc f(x) va g(x) la:');
Polydisp('T(x)',tic);
End;
Procedure PolyDivi(p,q:dathuc; Var thg:dathuc); {chia da thuc}
Var i,j,m:integer; du:dathuc;
Begin
m:=p.bac-q.bac;
If m<0 Then
Begin
Write('Khong chia duoc!');
Readln;
Exit;
End;
For i:=0 to m Do thg.hso[i]:=0;
thg.bac:=m;
For i:=m Downto 0 Do
Begin
thg.hso[i]:=p.hso[p.bac]/q.hso[q.bac];
For j:=q.bac downto 0 Do
p.hso[p.bac-q.bac+j]:=p.hso[p.bac-q.bac+j]-thg.hso[i]*q.hso[j];
p.bac:=p.bac-1;
End;
du:=p;
While (du.hso[du.bac]=0) and (du.bac>0) Do
du.bac:=du.bac-1;
Write('Thuong cua 2 dthuc f(x) va g(x) la:');
PolyDisp('Th(x)',thg);
If (du.bac=0) then Write('2 dthuc da cho chia het nhau!')
Else Polydisp('Da thuc du',du);
End;
{Main Prog}
Begin clrscr;
Nhap('f(x)',a);
Nhap('g(x)',b);
Writeln('Cac da thuc vua nhap:');
PolyDisp('f(x)',a);
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
PolyDisp('g(x)',b);
Writeln;
PolyAdd(a,b,c);
Writeln;
PolySubt(a,b,c);
Writeln;
PolyFact(a,b,c);
Writeln;
PolyDivi(a,b,c);
Readln;
End.
3/Thực hiện các phép toán trên hai số phức. (Với nhiều học sinh, phép tính chia hai số phức
là khó nhất!)
Uses Crt;
Type complex=Record
thuc,ao:Real;
End;
Var a,b,c: complex;
Procedure Input(kt: Char; Var x: complex);
Begin
Writeln('Nhap so phuc ',kt,':');
Write('Phan thuc:'); Readln(x.thuc);
Write('Phan ao:'); Readln(x.ao);
End;
Procedure WriteCompl(x:complex);
Begin
Write('(');
If Frac(x.thuc)=0 then Write(x.thuc:0:0)
Else Write(x.thuc:0:2); Write(';');
If Frac(x.ao)=0 then Write(x.ao:0:0)
Else Write(x.ao:0:2); Write(')');
End;
Procedure Add(x,y:complex; Var z:complex);
Begin
z.thuc:=x.thuc+y.thuc;
z.ao:=x.ao+y.ao;
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
End;
Procedure Sub(x,y:complex; Var z:complex);
Begin
z.thuc:=x.thuc-y.thuc;
z.ao:=x.ao-y.ao;
End;
Procedure Multip(x,y:complex; Var z:complex);
Begin
z.thuc:=x.thuc*y.thuc-x.ao*y.ao;
z.ao:=x.thuc*y.ao+x.ao*y.thuc;
End;
Procedure Divi(x,y:complex; Var z:complex);
Begin
z.thuc:=(x.thuc*y.thuc+x.ao*y.ao)/(sqr(y.thuc)+sqr(y.ao));
z.ao:=(x.ao*y.thuc-x.thuc*y.ao)/(sqr(y.thuc)+sqr(y.ao));
End;
Begin clrscr;
Input('A',a);
Input('B',b);
clrscr;
Writeln('Hai so phuc vua nhap la:');
Writeln;
Write('So phuc A:'); WriteCompl(a); Writeln;
Write('So phuc b:'); WriteCompl(b); Writeln;
Add(a,b,c);
Write('Tong 2 so phuc vua nhap='); WriteCompl(c); Writeln;
sub(a,b,c);
Write('Hieu 2 so phuc vua nhap='); WriteCompl(c); Writeln;
Multip(a,b,c);
Write('Tich 2 so phuc vua nhap='); WriteCompl(c); Writeln;
Divi(a,b,c);
Write('Thuong cua 2 so phuc vua nhap='); WriteCompl(c);
Readln;
End.
FILES
Thầy Trần Thông Quế
4/ Các thông tin Check In của khách tại sân bay Nội Bài được lưu trong text file tên là
KHACHBAY.VAO có cấu trúc sau: Dòng đầu ghi số khách bay, các dòng tiếp theo ghi
trọng lượng của từng đồ xách tay (túi, hộp, balô …) của mỗi khách. Dữ liệu ra gồm hai text
file:
file TRONGLUONG.RA ghi tổng trọng lượng các đồ xách tay của mỗi khách bay;
file HUYBAY.RA ghi số thứ tự của những khách bay bị hủy chuyến bay nếu tổng trọng
lượng các đồ xách tay của người này 20 KG HOẶC số đồ xách tay nhiều hơn 5.
Dưới đây là một ví dụ về 3 files như vậy:
KHACHBAY.VAO
5
19.5
2.5 1.5 2 3.25 1 3 (Trên mỗi dòng các số cách nhau ít nhất một ký tự trống)
6.25 2.5 7
12 6.5 4 10 7.5
2 6 8
TRONGLUONG.RA
19.50
13.25
15.75
40.00
16.00
HUYBAY.RA
Thầy Trần Thông Quế
sum:=sum+w;
k:=k+1;
End;
Writeln(tepra,sum);
If (sum>20) Or (k>7) Then Writeln(tephuy,i);
Readln(tepvao);
End;
Close(tepvao);
Close(tepra);
Close(tephuy);
Assign(tepra,'trgluong.ra'); Reset(tepra);
Writeln('Noi dung cua file trgluong.ra ghi tong trongluong');
Writeln(' cac kien hang cua tung khach hang:');
Writeln;
While Not(SeekEof(tepra)) do
Begin
Readln(tepra,sum);
Writeln(sum:0:2);
End;
Close(tepra);
Writeln;
Assign(tephuy,'huybay.ra'); Reset(tephuy);
Writeln('Noi dung tep huybay.ra ghi so thu tu cac khach bi huy bay:');
Writeln;
While Not(SeekEof(tephuy)) do
Begin
Readln(tephuy,i);
Writeln(i);
End;
Close(tephuy);
Readln;
End.
5/ Các số nguyên (gồm cả số dương lẫn số âm) được lưu trên text file SONGUYEN.DAT,
Hãy cất các số dương lên file POSI.DAT, cất các số âm lên fie NEGA.DAT. Hiển thị nội
dung hai file này lên màn hình.
Program PosiNegaFile;
Uses Crt;
Var f1,f2,f3: file Of Integer;
i,n,x:integer;
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Begin clrscr;
{$I-} Assign(f1,'Songuyen.dat'); Rewrite(f1); {$I+}
Write('Cho so luong cac so nguyen:'); Readln(n);
For i:=1 to n do
Begin
Write('So thu ',i,':');
Readln(x);
Write(f1,x);
End;
Close(f1);
Write(#10#13,'Da nhap xong ',n,' so nguyen len file songuyen.dat');
Writeln('Press Any Key to Continue...');
Repeat Until KeyPressed;
Readkey;
Clrscr;
{$I-} Assign(f1,'Songuyen.dat');
Assign(f2,'Posi.dat');
Assign(f3,'Nega.dat');
Reset(f1);
Rewrite(f2);
Rewrite(f3);
{$I+}
{Ghi cac so Duong len File f2, ghi cac so am len file f3}
While Not EOF(f1) Do
Begin
Read(f1,x);
If (x>=0) Then Write(f2,x)
Else Write(f3,x);
End;
Close(f1); Close(f2); Close(f3);
{Doc Data cua file f2}
Assign(f2,'Posi.dat'); Reset(f2);
Writeln('Data tren file Posi.dat:');
While Not EOF(f2) Do
Begin
Read(f2,x);
Write(x:3);
End;
Close(f2);
Writeln;
{ Doc Data tren file f3}
Assign(f3,'Nega.dat'); Reset(f3);
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Writeln('Data tren file Nega.dat:');
While Not EOF(f3) Do
Begin
Read(f3,x);
Write(x:3);
End;
Close(f3);
Write(#10#13,' Press Any Key to continue...');
Repeat until KeyPressed;
End.
6/Text file Num1.txt chứa một số số nguyên; text file Num2.txt cũng chứa một số số nguyên.
Hai files này có vài số như nhau. Tìm và “nhặt” các số có mặt ở cả hai file trên và
lưu chúng lên file Ketqua.txt. Hiện nội dung file Ketqua.txt lên màn hình.
Uses Crt;
Var f1,f2,f3: Text;
m,n,i,j,x:Integer;
a1,a2:Array[1..100] of Integer;
Begin clrscr;
{$I-}
Assign(f1,'Num1.txt');
Assign(f2,'Num2.txt');
Rewrite(f1);
Rewrite(f2);
{$I+}
Write('Cho so cac so trong file Num1.txt:'); Readln(m);
Writeln(f1,m);
For i:=1 to m do
Begin
Write('So thu ',i,':');
Readln(x);
Writeln(f1,x:3);
End;
Close(f1);
Write('Cho so cac so trong file Num2.txt:'); Readln(n);
Writeln(f2,n);
For i:=1 to n do
Begin
Write('So thu ',i,':');
Readln(x);
Writeln(f2,x:3);
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
End;
Close(f2);
{$I-}
Assign(f1,'Num1.txt');
Assign(f2,'Num2.txt');
Assign(f3,'Ketqua.txt');
Reset(f1);
Reset(f2);
Rewrite(f3);
{$I+}
{Doc Data tren file f1 vao mang a1 (tuc vao Ram)}
Readln(f1,m);
For i:=1 to m do
Readln(f1,a1[i]);
{Doc Data tren file f2 vao mang a2 (tuc vao Ram)}
Readln(f2,n);
For j:=1 to n do
Readln(f2,a2[j]);
Writeln;
Writeln('CAC SO CO MAT O CA 2 FILE:');
Writeln;
For i:=1 to m do
For j:=1 to n do
Begin
If a1[i]=a2[j] Then
Begin
Writeln(f3,a1[i]:3);
Writeln(a1[i]:3);
End;
End;
Close(f1);
Close(f2);
Close(f3);
Write(#10#13,'GO PHIM BAT KY DE TIEP...');
Repeat Until KeyPressed;
End.
Thầy Trần Thông Quế
PHẦN VII. ĐỒ HỌA (GRAPHIC)
(Ít nhất cũng có 5 bài khá thú vị với những người mê lập trình:
đó là các bài: In lịch; Vẽ đồng hồ; Kính vạn hoa; Tìm MỘT nghiệm của bài
toán Đặt Hậu; Tìm TẤT CẢ NGHIỆM có thể
cho bài toán Đặt Hậu)
Lời khuyên hữu ích: TẤT CẢ CÁC BÀI TOÁN GRAPHIC VÀ GRAPH DÙNG GRAPHIC ĐỀU PHẢI
CHẠY TRONG CÁC PHIÊN BẢN WINDOW CÓ HỖ TRỢ FULL SCREEN MODE. ĐẾN CHẾT
CŨNG ĐỪNG QUÊN LỜI DẶN NÀY!!!
Lập trình Đồ họa thực thi các bài toán sau:
1/ Vẽ cột phát sóng và các vòng sóng truyền lan.
Uses Crt, Graph;
Var Gd, Gm: Integer; r:word;
Begin clrscr;
Gd:=Detect; InitGraph(Gd,Gm,'D:\BP\BGI');
r:=15;
Repeat
SetColor(4);
MoveTo(300,200);
LineTo(320,440);
LineTo(280,440);
LineTo(300,200);
Rectangle(280,440,320,470);
SetColor(15);
Circle(300,200,r);
Delay(100);
If r>GetmaxY/2 then ClearDevice;
If r<=GetmaxY/2 then r:=r+30
Else r:=15;
Until KeyPressed;
CloseGraph;
End.
2/ Vẽ các vòng tròn đồng tâm đổi màu liên tục.
Uses Crt,Graph;
Var i,j,Gd,Gm,xt,yt,yc:Integer;
r:Word; hoi:char;
Begin clrscr;
Gd:=Detect; InitGraph(Gd,Gm,'D:\BP\BGI');
Thầy Trần Thông Quế
If GraphResult<>0 Then
Begin
Write('Loi do hoa.');
Halt;
End
Else
Begin
xt:=getMaxX Div 2;
yt:=GetMaxY Div 2;
yc:=GetMaxY Div 30;
End;
Repeat
SetBkColor(Black);
SetColor(15);
Rectangle(1,1,200,15);
SetColor(12);
OutTextXY(12,5,'PRESS ANY KEY TO STOP.');
R:=1;
For i:=1 to 15 do
Begin
SetColor(Random(16));
For j:=1 to yc do
Circle(xt,yt,r+j);
Inc(r,yc);
End;
Until KeyPressed;
CloseGraph;
End.
3/ Vẽ đồ thị hàm sinx (hoặc cosx: Tùy!).Yêu cầu: chương trình ngắn nhất có thể.
uses crt,graph;
var mh, mot,maxx,maxy, xtam,ytam:integer;
x, y:real;
Function F(x:real):real;
Begin
F:=sin(x);
End;
Begin clrscr;
mh:=Detect; InitGraph(mh,mot,'..\BGI');
SetBkColor(Cyan);
If GraphResult<>GrOk then Halt
Else
Begin
maxx:=Getmaxx;maxy:=Getmaxy;
xtam:=maxx DIV 2;
ytam:=maxy DIV 2;
Setcolor(White);
Thầy Trần Thông Quế
Line(0,ytam,maxx-5,ytam);
OutTextxy(maxx-10,ytam-3,'>');
Line(xtam,5,xtam,maxy);
OutTextxy(xtam-3,5,'>');
OutTextxy(xtam-10,ytam+10,'O');
X:=-4*Pi;
Repeat
y:=Round(F(x)*40);
PutPixel(Round(20*x)+xtam,ytam-Round(y),Red);
x:=x+0.001;
Until x>4*Pi;
Readln;
closegraph;
End;
End.
*4/ In lịch dương có khuôn dạng tương tự lịch tờ to treo tường.
PROGRAM InLich;
Uses Crt,Graph,Dos;
Label 1;
Var n,m,y: integer;
Function NumDays(m: integer): Integer; {Ham tra ve so ngay trong thang}
Begin
case m of
4,6,9,11:NumDays:=30;
2:if (m mod 4)<>0 then NumDays:=28 else
begin
if (m mod 100)<>0 then NumDays:=29 else
begin
if (m mod 400)<>0 then NumDays:=28 else NumDays:=29
end
end
else Numdays:=31
end;
End;
{Ham tra ve so thu tu cua thu trong tuan ung voi ngay mong 1 cua thang}
function FirstDay(m,y:word): word;
var d,y1,m1,d1,dow1,dow: word;
Begin
d:=1;
GetDate(y1,m1,d1,dow1);
setdate(y,m,d);
GetDate(y,m,d,dow);
FirstDay:=dow;
setdate(y1,m1,d1);
Thầy Trần Thông Quế
End;
Procedure In_lich(m,y: integer);
var i,j,k,n,rows,cols,gd,gm: integer;
Begin
k:=FirstDay(m,y);
n:=numDays(m);
Cols:=7;
Rows:= (n+k) DIV 7;
if (n+k) MOD 7 <> 0 then Rows:= Rows + 1;
Writeln;
textmode(c80);
textcolor(12);
Writeln(#32:16,'LICH THANG ',m,' - NAM ',y);
writeln(#32:16,'-------------------------');
writeln;
textcolor(lightmagenta);
Write('SUN':8);
textcolor(lightgreen);
Write('MON':8,'TUE':8,'WED':8,'THU':8,'FRI':8);
textcolor(lightblue);
Writeln('SAT':8);
Writeln;
For i:=1 to n+k do
Begin
If i<=k then Write(#32:8)
Else
Write(i-k:8); textcolor(yellow);
If i MOD 7 = 0 then Writeln;
End;
End;
BEGIN
1:clrscr;
Write('Nhap thang,nam (nam co 4 chu so):');
readln(m,y);
In_lich(m,y);
Writeln(#10#13);
textcolor(lightmagenta);
Write('Nhan phim bat ky de tiep tuc. Nhan "k" de ket thuc...');
if readkey<> 'k' then goto 1;
END.
Cách kiểm tra kết quả chạy program xem có CHÍNH XÁC KHÔNG: Gỉa sử nhập dữ liệu là tháng 7 năm
2017 thì LƯU Ý: Ra SAT ứng với ngày 8, SUN ứng với ngày 9 là prog. chạy chính xác. TỐT NHẤT NÊN
SO VỚI LỊCH BỎ TÚI của nhà xuất bản uy tín.
Thầy Trần Thông Quế
*5/ Tạo lập bảng mã ASCII mở rộng. Yêu cầu: gõ PgDn để xem tiếp. Gõ phím bất kỳ để thoát.
Program AsciiTable;
Uses Crt, Addcrt;
Label 1;
Const Hexa:Array[0..15] of Char='0123456789ABCDEF';
Type St=String[3];
Var i,j,x,m,n,y,e:Integer;
ch:Char;
Procedure Box(x1,x2,y1,y2:Byte);
Var i:Byte;
Begin
If (x1<0)Or (y1<0) Or (x2>80) Or (y2>25) Or (x1>x2) Or (y1>y2) Then exit;
Textcolor(0);
GotoXY(x1,y1); Write('I');
GotoXY(x2,y1); Write(';');
GotoXY(x1,y2); Write('H');
GotoXY(x2,y2); Write('<');
For i:=(x1+1) to (x2-1) Do
Begin
GotoXY(i,y1);
Write('M');
End;
For i:=(x1+1) to (x2-1) Do
Begin
GotoXY(i,y2);
Write('M');
End;
For i:=(y1+1) to (y2-1) Do
Begin
GotoXY(x1,i);
Write(':');
End;
For i:=(y1+1) to (y2-1) Do
Begin
GotoXY(x2,i);
Write(':');
End;
End;
Procedure Color(x1,x2,y1,y2:Byte);
Begin
Tomau(x1,y1,x2,y2,3);
Box(x1+1,y1+1,x2-1,y2-1);
Tomau(x1+2,y1+2,x2-2,y2-2,3);
End;
Function Doi(i1:Byte):St;
Thầy Trần Thông Quế
Begin
Doi:=Hexa[i1 Shr 4]+Hexa[i1 And $0F];
End;
Begin {Main}
TextBackGround(3);
clrscr;
Cursor(1);
Khungdon(2,2,79,24,15);TextC(14,9); Writexy(35,2,' TABLE ASCII ');
TextC(1,15);
WriteXY(50,3,'Wroten By TRAN THONG QUE'); TextC(4,3);
Window(2,4,79,24);
x:=1; y:=1;
While (x<=72) Do
Begin
Khungdon(x+2,y,x+8,y+2,15);
Khungdon(x+2,y+2,x+8,y+19,15);
x:=x+6;
End;
i:=3;
While (i<=79) Do
Begin
GotoXY(i,3); Write(#197);
i:=i+6;
End;
WriteXY(3,3,'C'); WriteXY(75,3,'D');
i:=9;
While (i<=79) Do
Begin
WriteXY(i,1,'B');
i:=i+6;
End;
WriteXY(75,1,'Y');
i:=9;
While (i<=79) Do
Begin
WriteXY(i,20,'A');
i:=i+6;
End;
WriteXY(75,20,'Y');
TextC(1,3); x:=5;
For i:=1 to 4 Do Begin WriteXY(x,2,'Deci'); x:=x+18; End; x:=11;
For i:=1 to 4 Do Begin WriteXY(x,2,'Hexa'); x:=x+18; End; x:=17;
For i:=1 to 4 Do Begin WriteXY(x,2,'Char'); x:=x+18; End;
Repeat
m:=64; n:=16;
Window(4,4,76,24);
y:=2; i:=4; j:=1; e:=4;
Repeat
Thầy Trần Thông Quế
While (i<=m) And (j<=n) Do
Begin
TextC(e,3); WriteXY(15,10,' ');
WriteXY(15,11,' '); WriteXY(15,13,' ');
WriteXY(15,16,' ');
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
If (j<>7) Then
Begin
GotoXY(y+12,i); Write(chr(j):3);
End;
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Until n=80;
SetWin;
WriteXY(40,24,'PgDn->Continue; Other Key->Quit.');
ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
m:=128; n:=80;
Window(4,4,76,24);
y:=2;i:=4; j:=65; e:=4;
Repeat
While (i<=m) And(j<=n) Do
Begin
TextC(e,3);
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
GotoXY(y+12,i); Write(chr(j):3);
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Until n=144;
Setwin;
Write(40,24,'PgDn->Continue; Other key->Quit.'); ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
m:=192; n:=144;
Window(4,4,76,24);
y:=2; i:=4; j:=129; e:=4;
Repeat
While (i<=m) And (j<=n) do
Begin
TextC(e,3);
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
GotoXY(y+12,i); Write(chr(j):3);
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Thầy Trần Thông Quế
Until n=208;
Setwin;
Write(40,24,'PgDn->Continue; Other key->Quit.'); ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
m:=256; n:=208;
Window(4,4,76,24);
y:=2; i:=4; j:=193; e:=4;
Repeat
While (i<=m) And (j<=n) Do
Begin
TextC(e,3);
GotoXY(y,i); Write(j:3);
GotoXY(y+6,i); Write(Doi(j):3);
GotoXY(y+12,i); Write(chr(j):3);
i:=i+1; j:=j+1;
End;
y:=y+18; i:=4; n:=n+16; e:=e+2;
Until n=272;
Setwin;
Write(40,24,'PgDn->Continue; Other key->Quit.'); ch:=Readkey;
If ch=#0 then ch:=Readkey; If ch<>#81 then Goto 1;
Until ch=#27;
Setwin;
1:TextC(15,0); Clrscr;
End.
**6/Tạo trò chơi bắn vịt trời đang bay. Gõ ký tự “d” bắn; Gõ , : di chuyển “súng”; Gõ: Esc: ra.
**7/ Tạo “Kính vạn hoa”. Yêu cầu: Gõ ESC: Thoát; Gõ phím bất kỳ: Tiếp tục.
PROGRAM VANHOA;
USES crt,graph;
const
dong=1; lim=3;
TYPE
BASEARRAY=ARRAY[1..100] OF real;
Var
ordrePoly,khoang:integer;
number:byte;
f1,f2,f3,f4:integer;
c1,c2,c3,c4:integer;
GraphDriver,graphMode:integer;
xp1,yp1,xp2,yp2:real;
xtl,ytl:real;
MaxX,MaxY:integer;
XgFen,xdFen,YbFen,YhFen:real;
XgClot,XdClot,YbClot,YhClot:integer;
mangX,mangY:basearray;
i:integer;
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Sotg,kc,lap:byte;
ch:char;k:integer;
PROCEDURE KTDOHOA;
VAR
errorCode:integer;
somau:byte;
Begin
graphDriver:=detect;
initgraph(graphdriver,graphMode,'D:\bp\bgi');
ErrorCode:=graphResult;
If errorCode<> grOK then
begin
writeln('LOI DO HOA ',graphErrorMsg(ErrorCode));
halt(1);
end;
MaxX:=getMaxx;
MaxY:=getMaxY;
end;
PROCEDURE CUASO(f1,f2,f3,f4:real);
BEGIN
Xgfen:=f1;
XdFen:=f2;
ybFen:=f3;
yhFen:=f4;
END;
PROCEDURE TAMNHIN(C1,C2,C3,C4:INTEGER);
BEGIN
XgClot:=c1;
XdClot:=c2;
YbClot:=c3;
YhClot:=c4;
Xtl:=(XdClot-XgClot)/(XdFen-XgFen);
Ytl:=(YhClot-YbClot)/(YhFen-YbFen);
Setviewport(xgClot,maxY-YhClot,xdClot,maxY-YbClot,ClipOn);
END;
PROCEDURE CAT(x1,y1,x2,y2:real);
type
muc=(l,r,low,h);
code=set of muc;
Var
c,c1,c2:code;
x,y:real;
xx1,yy1:integer;
xx2,yy2:integer;
Thầy Trần Thông Quế
PROCEDURE BINARY(X,Y:REAL;VAR C:CODE);
Begin
c:=[];
If x
Thầy Trần Thông Quế
End;
END ;
xx1:=round((x1-xgFen)*Xtl);
yy1:=round((yhfen-y1)*Ytl);
xx2:=round((x2-xgFen)*Xtl);
yy2:=round((yhfen-y2)*Ytl);
MoveTo(xx1,yy1);
Lineto(xx2,yy2);
END;
PROCEDURE VETOI(x,y:real);
BEGIN
xp2:=x;
yp2:=y;
cat(xp1,yp1,xp2,yp2);
xp1:=xp2;
yp1:=yp2;
END;
PROCEDURE DATBUT(x,y:real);
BEGIN
xp1:=x;
yp1:=y;
vetoi(x,y);
END;
PROCEDURE NHAPSOLIEU;
Begin
TextBackGround(blue);
ClrScr;
Writeln(' KINH VAN HOA ');
Write(' Cho so Tam giac ' );
Textcolor(white);
Write('( An 0 de thoat ) : ');
readln(Sotg);
If sotg<>0 then
Begin
writeln;
write(' Cho so khoang chia : ');
readln(kc);
writeln;
write(' Cho so lan Lap : ');
readln(Lap);
end;
END;
PROCEDURE DAGIAC(MANGX,MANGY:BASEARRAY;LIM:INTEGER;MODE:
INTEGER);
Var
Thầy Trần Thông Quế
i:integer;
Begin
datbut(mangx[1],mangy[1]);
For i:=2 to lim do vetoi(mangx[i],mangy[i]);
If mode=dong then vetoi(mangx[1],mangy[1]);
End;
PROCEDURE VEDAGIAC(MANGX,MANGY:BASEARRAY;LIM:INTEGER;MODE:
INTEGER;color:byte);
Begin
setcolor(color);
dagiac(MANGx,mangy,lim,mode);
End;
PROCEDURE VE(SoTg,kc,lap:byte);
Var
angle,hs:real;
i,j,sogoc:byte;
tg:byte;
Begin
hs:=2*pi/Sotg;
For Sogoc:=1 to sotg do
Begin
mangx[1]:=0;mangy[1]:=0;
angle:=(sogoc-1)*hs;
mangx[2]:=cos(angle);
mangy[2]:=sin(angle);
angle:=Sogoc*hs;
mangx[3]:=cos(angle);
mangy[3]:=sin(angle);
mangx[4]:=0;mangy[4]:=0;
For i:=1 to lap do
Begin
Vedagiac(mangx,mangy,lim,dong,white);
If odd(sogoc) then
Begin
For j:=lim+1 downto 2 do
Begin
mangx[j]:=mangx[j]+(mangx[j-1]-mangx[j])/kc;
mangy[j]:=mangy[j]+(mangy[j-1]-mangy[j])/kc;
End;
Mangx[1]:= Mangx[lim+1];
Mangy[1]:=Mangy[lim+1];
End
Else
Begin
For j:=1 to lim do
Begin
Thầy Trần Thông Quế
mangx[j]:=mangx[j]+(mangx[j+1]-mangx[j])/kc;
mangy[j]:=mangy[j]+(mangy[j+1]-mangy[j])/kc;
End;
Mangx[lim+1]:= Mangx[1];
Mangy[lim+1]:=Mangy[1];
End;
end;{cua lap}
end;{for ngoai cung}
End;{cua ve}
(**************************************************************)
BEGIN
nhapSolieu;
Repeat
ktdohoa;
CuaSo(-1,1 ,-1,1);
TamNhin(160,maxx-160,75,maxy-75);
Ve(sotg,kc,lap);
TamNhin(0,maxx,0,maxy);
rectangle(1,1,maxx-1,maxy-1);
rectangle(5,5,maxx-5,maxy-5);
setcolor(yellow);
settextjustify(1,1);
settextstyle(1,0,4);
outtextxy(maxx div 2,20,' VE KINH VAN HOA ');
outtextxy(maxx div 2,45,' ************************ ');
settextstyle(1,0,1);
setcolor(lightblue);
outtextxy(maxx div 2,maxy-20,' Go ESC de thoat, Go phim BAT KY de tiep tuc !');
settextstyle(2,1,8);
outtextxy(20,maxy div 2,'Thay: TRAN THONG QUE');
outtextxy(maxx-24,maxy div 2,'COPYRIGHT (C) 1994');
repeat until KeyPressed;
ch:=readkey;
if ch=#27 then
begin
cleardevice;
closegraph;
halt;
end;
closeGraph;
nhapsolieu;
Until ( Sotg=0);
END.
CÁC BÀI 7, 8, 10, 11 RẤT KHÓ CẢ VỀ MẶT THUẬT TOÁN VÀ CẢ VỀ KỸ NĂNG LẬP TRÌNH!!!
Thầy Trần Thông Quế
**7/ Tạo đồng hồ có 3 kim+tiếng tích tắc kêu theo nhịp chạy của kim giây.
Và thêm các yêu cầu sau:
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
X:=xorg[c1]-dk[docao[c1],c1];
GotoXY(X,YORG-n-j-1);
For i:=1 to 2*dk[docao[c1],c1]+1 do Write(#219);
tre(time);
GotoXY(X,Yorg-n-j-1);
For i:=1 to 2*dk[docao[c1],c1]+1 do Write(#32);
tre(time);
End;
End;
Procedure MoveDown(c1,c2:integer);
Var i,j,x:Integer;
Begin
For j:=4 Downto 1 Do
Begin
x:=XORG[c2]-DK[docao[c1],c1];
GotoXY(X,YORG-n-j-1);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#219);
tre(time);
GotoXY(X,YORG-n-j-1);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#32);
tre(time);
End;
End;
Procedure MoveRight(c1,c2:integer);
Var i,j,x,xx:integer;
Begin
x:=XORG[c1];
While x<=XORG[c2] Do
Begin
xx:=XORG[c1]-DK[docao[c1],c1]+x-XORG[c1];
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#219);
tre(time2);
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#32);
tre(time2);
X:=X+2;
End;
End;
Procedure MoveLeft(c1,c2:Integer);
Var i,j,x,xx:integer;
Begin
x:=XORG[c1];
While x>=XORG[c2] Do
Begin
Thầy Trần Thông Quế
xx:=XORG[c1]-DK[docao[c1],c1]+x-XORG[c1];
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#219);
tre(time2);
GotoXY(XX,YORG-n-5);
For i:=1 to 2*DK[docao[c1],c1]+1 Do Write(#32);
tre(time2);
X:=X-2;
End;
End;
Procedure Move(n,c1,c2,c3:integer);
Var x:integer;
Begin
If n=1 Then
Begin
x:=XORG[c1]-Dk[docao[c1],c1];
GotoXY(x,YORG-docao[c1]+1);
For i:=1 to 2*DK[docao[c1],c1]+1 do
Begin
If docao[c1]=1 Then
Begin
Write('-');
If i=DK[docao[c1],c1] Then Write(#193);
End
Else Write(#32);
End;
GotoXY(XORG[c1],YORG - docao[c1]+1);
Write(#179); tre(time);
MoveUp(c1,c2);
If c2>c1 then MoveRight(c1,c2)
Else MoveLeft(c1,c2);
MoveDown(c1,c2);
docao[c2]:=docao[c2]+1;
DK[docao[c2],c2]:=DK[docao[c1],c1];
Dk[docao[c1],c1]:=0;
docao[c1]:=docao[c1]-1;
x:=XORG[c2]-DK[docao[c2],c2];
GotoXY(x,YORG-docao[c2]+1);
For i:=1 to 2*DK[docao[c2],c2]+1 do Write(#219);
Delay(200);
End
Else
Begin
Move(n-1,c1,c3,c2);
Move(1,c1,c2,c3);
Move(n-1,c3,c2,c1);
End;
End;
{Main prog.}
Thầy Trần Thông Quế
Begin Clrscr;
GotoXY(35,4); Write('BAI TOAN THAP HA NOI.');
GotoXY(4,YORG-n+4);
GotoXY(XORG[1],YORG-n); Write(#179);
GotoXY(XORG[1]-1,YORG-n+1); Write(#219#219#219);
GotoXY(XORG[1]-2,YORG-n+2); Write(#219#219#219#219#219);
GotoXY(XORG[1]-3,YORG-n+3); Write(#219#219#219#219#219#219#219);
GotoXY(XORG[1]-4,YORG-n+4); Write(#219#219#219#219#219#219#219#219#219);
For i:=0 to n Do
Begin
GotoXY(XORG[2],YORG-n+I);
Write(#179);
End;
For I:=0 to n do
Begin
GotoXY(XORG[3],YORG-n+I);
Write(#179);
End;
docao[1]:=n; docao[2]:=0; docao[3]:=0;
For I:=1 to n do DK[I,1]:=n-I+1;
For I:=1 to n do DK[I,2]:=0;
For I:=1 to n do DK[I,3]:=0;
GotoXY(22,24); Write('Press Ctrl_C to Stop.');
GotoXY(43,4);
Repeat
Delay(500); Move(n,1,2,3);
Delay(500); Move(n,2,3,1);
Delay(500); Move(n,3,1,2);
Until KeyPressed;
End.
*9/ (MỘT TRONG SỐ CÁC ĐỀ OLYMPIC TIN HỌC CỦA HỌC SINH THCS 4/1994)
Vẽ hai đường tròn. Xét các vị trí tương quan giữa chúng. Và tính diện tích phần mặt phẳng giới hạn bởi 2
đường tròn khi chúng ở trong nhau hoặc tiếp súc trong với nhau. Hiển thị các kết qủa tính diện tích.
BẢNG TEST
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Begin
Sound(1200);
Delay(100);
Nosound;
End;
Until (IoResult=0) And (n>min) And (n
Thầy Trần Thông Quế
Writeln('Khong khoi dong duoc do hoa.');
Run:=False; Exit;
End;
SetBkColor(Blue); SetColor(LightRed);
SetFillStyle(1,LightGray);
Bar(1,1,maxx-1,maxy-1);
Rectangle(0,0,maxx,maxy);
SetColor(Yellow);
Circle(x1,y1,r1); Circle(x2,y2,r2);
i:=Sqrt((Longint(x1)-x2)*(x1-x2)+(Longint(y1)-y2)*(y1-y2));
If (x1=y1) And (x2=y2) And (r1=r2) Then
Begin
SetColor(White);
OutTextxy(10,450,'Hai vong tron trung khit nhau.')
End
Else If(r1>=r2+i) Then
Begin
SetColor(White);
OutTextxy(10,450,'Vong tron 2 nam trong vong tron 1.');
Str(Pi*(Longint(r1)*r1-Longint(r2)*r2):0:2,s);
OutTextxy(10,460,'Dien tich phan trong la:');
SetColor(LightRed); OutTextxy(10+26*8,460,s);
SetFillStyle(3,LightGray);
If x2+r2=x1+r1 Then FloodFill(x1,y1-r1+1,Yellow)
Else FloodFill(x1,y1+r1-1,Yellow)
End
Else If(r2>=r1+i) Then
Begin
SetColor(White);
OutTextxy(10,450,'Vong tron 1 nam trong vong tron 2.');
Str(Pi*(Longint(r2)*r2-Longint(r1)*r1):0:2,s);
OutTextxy(10,460,'Dien tich phan trong la:');
SetColor(LightRed); OutTextxy(10+26*8,460,s);
SetFillStyle(3,LightGray);
If y1+r1=y2+r2 Then FloodFill(x2,y2-r2+1,Yellow)
Else FloodFill(x2,y2+r2-1,Yellow);
End;
SetColor(LightGray);
OutTextxy(10,470,'Nhan Rnter -> Stop.');
Sound(1500); Delay(100); Nosound;
Repeat ch:=Readkey Until ch=#13;
CloseGraph;
Run:=True;
End;
Function Done:Boolean;
Var ch:char;
Begin
Khung(20,15,60,17); Window(21,16,59,16);
Thầy Trần Thông Quế
TextColor(LightGray);
Write('More (y/n)?');
Repeat ch:=Readkey Until ch In ['y','Y','n','N'];
TextColor(LightRed);
Write(ch);
Window(1,1,80,25);
If ch In ['n','N'] Then Done:=true
Else Done:=False;
End;
Begin
Repeat
Init;
If not Run then Halt;
Until Done;
End.
**10- (TÌM 1 LỜI GIẢI CHO BÀI TOÁN 8 HẬU TRÊN BÀN CỜ VUA 8X8). Tìm MỘT nghiệm cho bài
toán: Đặt 8 hậu trên bàn cờ vua 8x8 sao cho không con nào ăn được con nào.
Program Tim_Mot_Loi_Giai_Cho_Bai_8_Hau;
Uses crt,graph;
Const dl=200;
Var
p:pointer;
found:boolean;
a:array[1..8] of boolean;
b:array[2..16] of boolean;
c:array[-7..7]of boolean;
h:array[1..8] of Integer;
Procedure Initgr;
Var gd,gm:integer;
Begin
gd:=detect;
initgraph(gd,gm,'..\bgi');
if graphresult<>grok then
begin
write('Loi Do Hoa ! Go Enter Ket Thuc');
readln;
halt(1)
end
End;
Procedure Demo;
Begin
settextstyle(1,0,3);
setbkcolor(green);
setcolor(blue);
Thầy Trần Thông Quế
outtextxy(425,30,'Tim Mot Loi Giai');
settextstyle(1,0,4);
setcolor(white);
outtextxy(425,90,'Cho Bai Toan');
setcolor(red);
settextstyle(4,0,7);
outtextxy(440,160,'8 Hau');
setcolor(blue);
settextstyle(1,0,3);
outtextxy(440,410,'Ha Noi - 2005');
setcolor(white);
settextstyle(3,0,1);
outtextxy(425,440,' Thay Tran-Hong-Que');
End;
Procedure Draw(i,j:integer);
Begin
if (i+j)mod 2=0 then
begin
setfillstyle(1,7);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end
else
begin
setfillstyle(1,white);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end;
End;
Procedure Draw_Queen(i,j:integer);
Var size:integer;
Begin
setfillstyle(1,3);
setcolor(red);
bar(i,j,i+50,j+55);
ellipse(i+25,j+35,0,360,10,5);
line(i+25-10,j+35,i+25-20,j+35-20);
line(i+25+10,j+35,i+25+20,j+35-20);
line(i+25-10-10,j+35-20,i+25+20,j+35-20);
circle(i+25-10-10+5,j+35-20-3,3);
circle(i+25-10-10+5+10,j+35-20-3,3);
circle(i+25-10-10+5+20,j+35-20-3,3);
circle(i+25-10-10+5+30,j+35-20-3,3);
setfillstyle(1,4);
floodfill(i+25,j+35-10,4);
setfillstyle(1,8);
floodfill(i+25-10-10+5,j+35-20-3,4);
floodfill(i+25-10-10+5+10,j+35-20-3,4);
floodfill(i+25-10-10+5+10+10,j+35-20-3,4);
Thầy Trần Thông Quế
floodfill(i+25-10-10+5+10+10+10,j+35-20-3,4);
size:=Imagesize(i+1,j+1,i+51,j+51);
getmem(p,size);
getimage(i+2,j+2,i+50-2,j+50-2,p^);
End;
Procedure Put_Queen(i,j:integer);
Begin
Putimage(i+2,j+2,P^,Xorput);
End;
Procedure Table;
Var m,n:integer;
Begin
setviewport(0,0,getmaxx,getmaxy,false);
for m:=1 to 8 do
for n:=1 to 8 do
Draw(m,n);
Demo;
Draw_Queen(10,getmaxy-65);Put_Queen(10,getmaxy-65);
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
End;
Procedure Result;
Var s:string[2];
i:integer;
Begin
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
settextstyle(1,0,3);
setcolor(white);
for i:=1 to 8 do
begin
str(h[i],s);
outtextxy(28+(i-1)*50,getmaxy-50,s);
end;
End;
Procedure Try(i:integer;Var q:boolean);
Var j:integer;
Begin
j:=0;
Thầy Trần Thông Quế
repeat
q:=false; inc(j);
if a[j] and b[i+j] and c[i-j] then
begin
h[i]:=j;
Put_Queen((i-1)*50+10,(j-1)*50+10);
sound(150);delay(dl);nosound;
a[j]:=false;b[i+j]:=false;c[i-j]:=false;
if i<8 then
begin
Try(i+1,q);
if not q then
begin
a[j]:=True;b[i+j]:=true;c[i-j]:=true;
Put_Queen((i-1)*50+10,(j-1)*50+10);
sound(350);delay(dl);nosound;
end;
end
else q:=true;
end;
until q or(j=8);
End;
Procedure Search;
Var i:integer;ch:char;
Begin
for i:=1 to 8 do a[i]:=true;
for i:=2 to 16 do b[i]:=true;
for i:=-7 to 7 do c[i]:=true;
Try(1,found);
if found then Result;
setcolor(white);
settextstyle(2,0,7);
outtextxy(430,300,'Go Esc Ket Thuc !');
repeat ch:=readkey until ch=#27;
End;
BEGIN
Initgr;
Table;
Search;
Closegraph;
END.
**11- (TÌM TẤT CẢ CÁC NGHIỆM CÓ THỂ CÓ CỦA BÀI TOÁN ĐẶT 8 HẬU TRÊN BÀN CỜ VUA
8X8). Tìm TẤT CẢ CÁC NGHIỆM có thể cho bài toán “Hậu”: Tìm cách đặt 8 hậu trên bàn cờ vua 8x8 sao
cho không con nào ăn được con nào. Gõ lần lượt một phím bất kỳ để xem từng nghiệm. Gõ ESC để ra.
Program Tim_Tat_Ca_Loi_Giai_Xep_8_Hau;
Thầy Trần Thông Quế
Uses crt,graph;
Const Mc:Array [1..210,1..2] of Word =
((1046,24),(1046,12),(1174,12),(1244,24),
(1046,24),(1244,24),(1046,24),(1244,24),
(1174,24),(934,24),(934,12),(1046,12),
(1174,24),(934,24),(1174,24),(934,24),
(1174,24),(1046,24),(880,24),(880,12),
(934,12),(1046,24),(880,24),(1046,24),
(934,24),(880,24),(934,24),(784,96),
(1046,24),(1046,12),(1174,12),(1244,24),
(1046,24),(1244,24),(1046,24),(1244,24),
(1174,24),(934,24),(934,12),(1046,12),
(1174,24),(934,24),(1174,24),(934,24),
(1174,24),(1046,24),(880,24),(880,12),
(934,12),(1046,24),(1244,24),(1174,24),
(742,24),(784,24),(36000,24),(36000,48),
(36000,24),(1174,24),(1174,48),(1046,24),
(1174,24),(784,72),(784,24),(1174,48),
(1398,24),(1244,24),(1174,72),(1046,24),
(1174,48),(934,24),(784,24),(880,72),
(880,24),(934,48),(784,24),(880,24),
(588,72),(1174,24),(1174,48),(1046,24),
(1174,24),(784,72),(588,24),(588,48),
(784,24),(934,24),(880,72),(880,24),
(934,48),(742,24),(880,24),(588,72),
(588,24),(1046,48),(1046,24),(934,24),
(934,96),(36000,48),(36000,24),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
(784,24),(1174,48),(1398,24),(1244,24),
(1174,72),(1046,24),(1174,48),(934,24),
(784,24),(880,72),(880,24),(934,48),
(784,24),(880,24),(588,72),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
(588,24),(588,48),(784,24),(934,24),
(880,72),(880,24),(934,48),(742,24),
(784,24),(880,72),(1046,24),(1046,24),
(1174,24),(742,24),(880,24),(784,96),
(784,48),(880,72),(784,24),(880,48),
(588,24),(588,24),(522,72),(934,24),
(880,48),(588,24),(784,24),(880,72),
(880,24),(1046,48),(1174,24),(1244,24),
(1174,96),(36000,48),(1398,24),(1244,24),
(1174,72),(934,24),(934,48),(1046,24),
(1174,24),(1174,72),(880,24),(934,48),
(784,24),(880,24),(588,48),(36000,48),
(1046,32),(934,32),(880,32),(784,48),
(36000,24),(36000,48),(36000,24),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
Thầy Trần Thông Quế
(784,24),(1174,48),(1398,24),(1244,24),
(1174,72),(1046,24),(1174,48),(934,24),
(784,24),(880,72),(880,24),(934,48),
(784,24),(880,24),(588,72),(1174,24),
(1174,48),(1046,24),(1174,24),(784,72),
(588,24),(588,48),(784,24),(934,24),
(880,72),(880,24));
Var
p:pointer;
t,g:integer;
ch:char;
stop:boolean;
a:array[1..8] of boolean;
b:array[2..16] of boolean;
c:array[-7..7]of boolean;
h:array[1..8] of Integer;
Procedure Initgr;
Var gd,gm:integer;
Begin
gd:=detect;
initgraph(gd,gm,'..\bgi');
if graphresult<>grok then
begin
write('Loi Do Hoa ! Go Enter Ket Thuc');
readln;
halt(1)
end
End;
Procedure Demo;
Begin
settextstyle(1,0,2);
setbkcolor(green);
setcolor(blue);
outtextxy(425,30,'Tim Tat Ca Loi Giai');
settextstyle(1,0,4);
setcolor(white);
outtextxy(425,60,'Cho Bai Toan');
setcolor(red);
settextstyle(4,0,7);
outtextxy(440,100,'8 Hau');
setcolor(Blue);
settextstyle(1,0,3);
outtextxy(440,370,'Ha Noi - 2002');
setcolor(Magenta);
settextstyle(3,0,1);
outtextxy(425,410,' Thay Tran-hong-Que');
setcolor(red);
Thầy Trần Thông Quế
outtextxy(425,440,' Hoi Tin hoc Viet nam');
End;
Procedure Draw(i,j:integer);
Begin
if (i+j)mod 2=0 then
begin
setfillstyle(1,7);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end
else
begin
setfillstyle(1,white);
bar((i-1)*50+10,(j-1)*50+10,(i-1)*50+50+10,(j-1)*50+50+10);
end;
End;
Procedure Draw_Queen(i,j:integer);
Var size:integer;
Begin
setfillstyle(1,3);
setcolor(red);
bar(i,j,i+50,j+55);
ellipse(i+25,j+35,0,360,10,5);
line(i+25-10,j+35,i+25-20,j+35-20);
line(i+25+10,j+35,i+25+20,j+35-20);
line(i+25-10-10,j+35-20,i+25+20,j+35-20);
circle(i+25-10-10+5,j+35-20-3,3);
circle(i+25-10-10+5+10,j+35-20-3,3);
circle(i+25-10-10+5+20,j+35-20-3,3);
circle(i+25-10-10+5+30,j+35-20-3,3);
setfillstyle(1,4);
floodfill(i+25,j+35-10,4);
setfillstyle(1,8);
floodfill(i+25-10-10+5,j+35-20-3,4);
floodfill(i+25-10-10+5+10,j+35-20-3,4);
floodfill(i+25-10-10+5+10+10,j+35-20-3,4);
floodfill(i+25-10-10+5+10+10+10,j+35-20-3,4);
size:=Imagesize(i+1,j+1,i+51,j+51);
getmem(p,size);
getimage(i+2,j+2,i+50-2,j+50-2,p^);
End;
Procedure Put_Queen(i,j:integer);
Begin
Putimage(i+2,j+2,P^,Xorput);
End;
{===============================}
Procedure Table;
Thầy Trần Thông Quế
Var m,n:integer;
Begin
setviewport(0,0,getmaxx,getmaxy,false);
for m:=1 to 8 do
for n:=1 to 8 do
Draw(m,n);
Demo;
Draw_Queen(10,getmaxy-65);Put_Queen(10,getmaxy-65);
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
End;
Procedure Result;
Var s:string[2];
i:integer;
Begin
setfillstyle(1,blue);
bar(7,410,413,470);
setcolor(red);
rectangle(8,8,412,411);
rectangle(7,7,413,412);
settextstyle(1,0,3);
setcolor(white);
for i:=1 to 8 do
begin
str(h[i],s);
outtextxy(28+(i-1)*50,getmaxy-50,s);
end;
End;
Procedure Wait;
Begin
inc(t);
Result;
setcolor(yellow);
settextstyle(2,0,6);
outtextxy(430,200,'Go Phim Esc De Ngung !');
setcolor(white);
settextstyle(2,0,5);
outtextxy(420,230,'Go Phim Bat Ky De Tiep Tuc...');
while keypressed do ch:=readkey;
repeat until keypressed;
ch:=readkey;
if ch=#27 then stop:=true;
End;
Thầy Trần Thông Quế
Procedure Music;
Begin
sound(Mc[g][1]);
delay(mc[g][2]*8);{ delay(20000);}
nosound;
if g=210 then g:=1 else inc(g)
End;
Procedure Try(i:integer);
Var j:integer;
Begin
j:=0;
repeat
inc(j);
if a[j] and b[i+j] and c[i-j] then
begin
h[i]:=j;
Put_Queen((i-1)*50+10,(j-1)*50+10);
Music;
a[j]:=false;b[i+j]:=false;c[i-j]:=false;
if i<8 then Try(i+1)
else Wait;
a[j]:=True;b[i+j]:=true;c[i-j]:=true;
Put_Queen((i-1)*50+10,(j-1)*50+10);
Music;
end;
until (j=8) or stop;
End;
Procedure Search;
Var i:integer;
s:string[30];
Begin
t:=0;g:=1;
stop:=false;
for i:=1 to 8 do a[i]:=true;
for i:=2 to 16 do b[i]:=true;
for i:=-7 to 7 do c[i]:=true;
Try(1);
str(t,s);
if stop then
s:='Da Tim Duoc '+s+' Loi Giai'
else
s:='Tong So Co '+s+' Loi Giai';
setcolor(red);
settextstyle(2,0,6);
outtextxy(418,280,s);
setcolor(white);
settextstyle(2,0,7);
Thầy Trần Thông Quế
outtextxy(430,310,'Go Esc Ket Thuc !');
repeat ch:=readkey until ch=#27;
End;
BEGIN
Initgr;
Table;
Search;
Closegraph;
END.
PHẦN VIII. GRAPH THEORY & APPLICATIONS
VIII.1-TÌM KIẾM TRÊN ĐỒ THỊ (tên khác: DUYỆT ĐỒ THỊ); TÔ
MÀU ĐỒ THỊ; TÌM MIỀN LIÊN THÔNG CỦA ĐT.
Thầy Trần Thông Quế
I,J,K,U:CSD;
P:AR;
(*-----------------------------------------------------------*)
PROCEDURE INITGR; { KHOI TAO DO HOA}
VAR GD,GM:INTEGER;
BEGIN
GD:=DETECT;
INITGRAPH(GD,GM,'..\BGI');
IF (GRAPHRESULT<> GROK) THEN
BEGIN
WRITELN('LOI KHOI TAO DO HOA, GO ENTER KET THUC !');
READLN;
HALT(1)
END
END;
(*-----------------------------------------------------*)
PROCEDURE ADD(X:CSD;VAR Q:QUEUE); {THEM PHAN TU TU DUOI HANG DOI}
BEGIN
WITH Q DO
BEGIN
REAR:=REAR+1;
ELEMENT[REAR]:=X
END;
END;
(*-----------------------------------------------------*)
PROCEDURE DELETE(VAR Q:QUEUE;VAR X:CSD); {BOT PHAN TU KHOI HANG DOI}
VAR K:CSD;
BEGIN
WITH Q DO
BEGIN
X:=ELEMENT[1];
FOR K:=1 TO REAR-1 DO ELEMENT[K]:=ELEMENT[K+1];
REAR:=REAR-1
END;
END;
(*-----------------------------------------------------*)
PROCEDURE VENUT(U:CSD;M1,M2:WORD); {VE CAC DINH DO THI}
VAR ST:STRING[3];
BEGIN
SETFILLSTYLE(1,M2);
SETCOLOR(M1);
FILLELLIPSE(C[U],D[U],R,R);
STR(U,ST);
OUTTEXTXY(C[U]-2,D[U]-2,ST);
END;
(*-------------------------------*)
Thầy Trần Thông Quế
PROCEDURE LINK(X,Y:CSD;M:WORD);
BEGIN
SETCOLOR(M);
LINE(C[X],D[X],C[Y],D[Y]);
END;
(*-------------------------------*)
PROCEDURE DATA_AUTO_CREA; {TU DONG TAO DU LIEU NGAU NHIEN CHO PROG.}
BEGIN
RANDOMIZE;
FOR I:=1 TO N DO
BEGIN
G[I,I]:=FALSE;
FOR J:=I+1 TO N DO
BEGIN
G[I,J]:=RANDOM(3)=1;
G[J,I]:=G[I,J]
END;
END;
FOR I:=1 TO N DO
BEGIN
J:=0;
REPEAT
J:=J+1
UNTIL G[I,J] OR (J=N);
IF (J=N) AND (NOT G[I,N]) THEN
BEGIN
J:=1+RANDOM(N);
IF J=I THEN IF I
Thầy Trần Thông Quế
BEGIN
SETBKCOLOR(BLUE);CLEARDEVICE;
SETFILLSTYLE(1,DARKGRAY);
BAR(0,0,GETMAXY,GETMAXY);
FOR I:=1 TO N DO
FOR J:=1 TO N DO IF G[I,J] THEN LINK(I,J,NL[0]);
LINE(C[I],D[I],C[J],D[J]);
FOR I:=1 TO N DO VENUT(I,CL[0],NL[0]);
END;
(*--------------------------------------------------*)
PROCEDURE VE_GR_BFS(U:CSD); {HIEN THI DO THI DE DUYET THEO BE RONG}
VAR Q:QUEUE;
BEGIN
VENUT(U,CL[K],NL[K]);
P[U]:=0;
Q.REAR:=0;
ADD(U,Q);
WHILE Q.REAR<>0 DO
BEGIN
DELETE(Q,I);
FOR J:=1 TO N DO
IF G[I,J] THEN
IF P[J]=VC THEN
BEGIN
P[J]:=I;
LINK(I,J,NL[K]);
VENUT(J,CL[K],NL[K]);
VENUT(I,CL[K],NL[K]);
ADD(J,Q);
DELAY(DL);
END;
END;
END;
Thầy Trần Thông Quế
VAR T:CSD;
BEGIN
I:=I+1;
P[U]:=I;
FOR T:=1 TO N DO
IF G[U,T] THEN
IF P[T]=0 THEN
BEGIN
LINK(U,T,NL[K]);
VENUT(U,CL[K],NL[K]);
VENUT(T,CL[K],NL[K]);
DELAY(DL);
VE_DT_DFS(T);
END;
END;
(*-----------------------------*)
PROCEDURE DFS; {DUYET THEO CHIEU SAU}
BEGIN
FOR I:=1 TO N DO P[I]:=0;
I:=0;
FOR U:=1 TO N DO IF P[U]=0 THEN
BEGIN
K:=(K+1) MOD 4;
VENUT(U,CL[K],NL[K]);
VE_DT_DFS(U);DELAY(DL)
END;
END;
(*-----------------------------------*)
PROCEDURE PROC_CALL_PROC; {THU TUC GOI CAC THU TUC DUYET}
VAR KT:CHAR;
BEGIN
IF KEYPRESSED THEN
REPEAT KT:=READKEY UNTIL NOT KEYPRESSED;
REPEAT
DATA_AUTO_CREA;
PRINT_GRAPH;
DEMO('Theo Be Rong');
KT:=READKEY;
IF KT=#27 THEN EXIT;
BFS;
KT:=READKEY;
IF KT=#27 THEN EXIT;
PRINT_GRAPH;
DEMO('Theo Do Sau');
KT:=READKEY;
IF KT=#27 THEN EXIT;
Thầy Trần Thông Quế
DFS;
KT:=READKEY;
UNTIL (KT=#27);
END;
(*-----------------------------------*)
BEGIN (* CHUONG TRINH CHINH *)
CLRSCR;
INITGR;
PROC_CALL_PROC;
CLOSEGRAPH;
END.
Thử một bài duy nhất ở mức TRÊN CƠ BẢN về duyệt theo BFS:
2-(IOI-1996: THI OLYMPIC TIN HỌC QUỐC TẾ 1996) Tiếp theo thành tựu khối lập phương kỳ diệu, ông
Rubik phát minh dạng cải biên phẳng của khối này và ông gọi đó là các ô vuông kỳ diệu. Đó là một bảng 8
ô vuông có kích thước như nhau được tô màu khác nhau.
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Assign(tepvao,fi); Reset(tepvao);
For i:=1 to kt Do Read(tepvao,dic[i]);
Close(tepvao);
End; {Het nhap lieu}
Thầy Trần Thông Quế
bang:=false;
exit;
End;
End;
Procedure sinh; {Tao day cac b_doi tu tr_thai dau de dat tr_thai dich}
{last[sh(dic)] la phep b_doi cuoi cung cua day}
Const qs=700; {kich thuoc danh sach}
Var hdoi:Array[0..qs-1] of ht; {Khai bao hang doi chua cac b_doi}
notfound:Boolean;
head, tail, i, rankq:Word;
r, s:Ht; x:Char;
Begin
For i:=0 to m Do last[i]:=' '; {khoi tri}
last[0]:='.';
head:=0; tail:=1;
hdoi[0]:=dau;
notfound:=true;
While notfound Do
Begin
r:=hdoi[head]; Inc(head);
If head=qs Then head:=0;
For x:='A' to 'C' Do
Begin
App(r, x, s);
rankq:=sh(s);
If last[rankq]=' ' Then
Begin
last[rankq]:=x;
If bang(dic,s) Then
Begin
notfound:=false;
break;
End;
hdoi[tail]:=s;
Inc(tail);
If tail=qs Then tail:=0;
End;
End;
End;
End; {ket thuc thu tuc sinh}
Procedure tim; {kien tao cac phep bien doi}
Var rankq:Word; x:Char; p,q:Ht;
Begin
q:=dic; rankq:=sh(q); s:=' ';
While rankq<>0 do
Begin
Thầy Trần Thông Quế
x:=last[rankq];
s:=x+s;
bd_nguoc(q,x,p);
q:=p;
rankq:=sh(q);
End;
End;
Procedure Xuat;
Var tepra:text; L,i:word;
Begin
Assign(tepra,fo); rewrite(tepra);
L:=length(s);
Writeln(tepra, L-1);
For i:=1 to L do Writeln(tepra, s[i]);
Close(tepra);
End;
Begin {Main Prog.}
clrscr;
Nhap;
Facto;
Sinh;
Tim;
Xuat;
Writeln('Done!');
readln;
End.
B/ CÁC THUẬT TOÁN TÌM CÁC MIỀN LIÊN THÔNG TRÊN ĐỒ THỊ
B.1) TÌM MIỀN LIÊN THÔNG TRÊN ĐỒ THỊ VÔ HƯỚNG
3- Cài đặt thuật toán tìm & liệt kê các thành phần (miền) liên thông của một đồ thị vô hướng. Biết rằng cấu
trúc của đồ thị vô hướng được biểu diễn bởi danh sách liệt kê cạnh như sau (Ds này lưu trên Text File
LTHG.IN):
Thầy Trần Thông Quế
Program Dem_so_thp_lthong;
uses crt;
const max=50;
fi='lthg.in'; fo='xuat.kq'; {Du lieu vao la Ds liet ke canh!}
type m1=Array[0..max] of integer;
m2=Array[1..max,1..max] of byte;
var a:m2; {ma tran danh sach liet ke canh}
n:integer;
v:m1;
sm:integer; {so mien lien thong}
Thầy Trần Thông Quế
If v[s]=0 then
Begin
Inc(sm); {danh so cho mien lth moi}
v[s]:=sm; {s la dinh dau tien phat hien thuoc mien lth moi}
DFS(s); {Duyet dthi tim tat ca cac dinh lth voi s}
End;
End;
Thầy Trần Thông Quế
B.2) TÌM MIỀN LIÊN THÔNG MẠNH TRÊN ĐỒ THỊ CÓ HƯỚNG (THỰC
CHẤT LÀ CÀI ĐẶT THUẬT TOÁN TARJAN)
4/ Cài đặt thuật toán tìm & liệt kê các miền liên thông MẠNH của đồ thị có hướng (thuật toán TARJAN).
Biết rằng đồ thị có hướng này được biểu diễn bởi ds cung sau đây (và ds này lưu trên text file
LTH_MANH.IN):
11 15
1 2
1 8
2 3
3 4
4 2
4 5
5 6
6 7
7 5
8 9
9 4
9 10
10 8
10 11
11 9
Thầy Trần Thông Quế
t^.s:=v;
t^.next:=dsk[u];
dsk[u]:=t;
End;
Close(f);
End;
Thầy Trần Thông Quế
If Num[i]=0 then DFS(i);
End;
Thầy Trần Thông Quế
USES CRT,GRAPH;
CONST R=15;DL=500;VC=100;N=8;
C:ARRAY[1..8] OF INTEGER=(150,330,450,450,330,150,30,30);
D:ARRAY[1..8] OF INTEGER=(30,30,150,330,450,450,330,150);
CL:ARRAY[0..4] OF WORD=(WHITE,RED,YELLOW,BLUE,GREEN);
TYPE CSD=0..VC;
VAR G:ARRAY[CSD,CSD] OF BOOLEAN;
V,V0,V1:SET OF CSD;
I,J,K:CSD;
(*------------------------------------------------------------*)
PROCEDURE INITGR;
VAR GD,GM:INTEGER;
BEGIN
GD:=DETECT;
INITGRAPH(GD,GM,'..\BGI');
IF (GRAPHRESULT<> GROK) THEN
BEGIN
WRITELN('LOI KHOI TAO DO HOA, GO ENTER KET THUC !');
READLN;
HALT(1)
END
END;
(*-----------------------------------------------------*)
PROCEDURE VENUT(U:CSD;M:WORD);
BEGIN
SETFILLSTYLE(1,M);SETCOLOR(M);
FILLELLIPSE(C[U],D[U],R,R);
END;
(*-------------------------------*)
PROCEDURE LINK(X,Y:CSD;M:WORD);
BEGIN
SETCOLOR(M);
LINE(C[X],D[X],C[Y],D[Y]);
END;
(*-------------------------------*)
PROCEDURE INIT_GRAPH;
BEGIN
RANDOMIZE;
FOR I:=1 TO N DO
BEGIN
G[I,I]:=FALSE;
FOR J:=I+1 TO N DO
BEGIN
G[I,J]:=RANDOM(3)=1;
G[J,I]:=G[I,J]
END;
Thầy Trần Thông Quế
END;
FOR I:=1 TO N DO
BEGIN
J:=0;
REPEAT
J:=J+1
UNTIL G[I,J] OR (J=N);
IF (J=N) AND (NOT G[I,N]) THEN
BEGIN
J:=RANDOM(N)+1;
IF J=I THEN IF I
Thầy Trần Thông Quế
V1:=[I];
FOR I:=1 TO N DO
IF I IN V0 THEN
BEGIN
J:=0;
REPEAT
J:=J+1;
CHECK:=G[I,J] AND (J IN V1);
UNTIL CHECK OR (J=N);
IF NOT CHECK THEN
BEGIN
VENUT(I,CL[K]); DELAY(DL);
V1:=V1+[I];
END;
END;
V0:=V0-V1;
END;
END;
(*---------------------------------------*)
PROCEDURE PROC_CALL_PROC; {THU TUC GOI CAC THU TUC}
VAR KT:CHAR;
BEGIN
IF KEYPRESSED THEN
REPEAT KT:=READKEY UNTIL NOT KEYPRESSED;
REPEAT
INIT_GRAPH;
PRINT_GRAPH;
MENU_PRINT;
COLORING;
KT:=READKEY;
UNTIL (KT=#27);
END;
(*--------------------------------------*)
BEGIN (* CHUONG TRINH CHINH *)
CLRSCR;
INITGR;
V:=[];
FOR I:=1 TO N DO V:=V+[I];
PROC_CALL_PROC;
CLOSEGRAPH;
END.
Thầy Trần Thông Quế
VIII-2/ ĐỒ THỊ EULER & ĐỒ THỊ HAMILTON
A) ĐỒ THỊ EULER
6- Liệt kê các đường đi Euler trên đồ thị vô hướng được biểu diễn bởi ma trận kề dưới đây:
Thầy Trần Thông Quế
{Main Prog.}
Begin clrscr;
Write('Nhap ten tep du lieu:'); readln(tf);
Assign(f,tf); Reset(f);
Readln(f,n);
For i:=1 to n do
For j:=1 to n do Read(f,c[i,j]);
Close(f);
Write('Cho biet dinh xuat phat:'); Readln(u);
Writeln('Duong di Euler tim duoc:'); Writeln;
dem:=0;
For j:=1 to n do check[j]:=true;
L1:dem1:=0;
For j:=1 to n do
If c[u,j]=1 then Inc(dem1);
dem:=dem+1;
If dem1=1 then
Begin
For j:=1 to n do If c[u,j]=1 then
Begin
check[u]:=false;
c[u,j]:=0; c[j,u]:=0;
Writeln('Di qua canh thu ',dem,' dung 1 lan la tu:',u,'->',j);
u:=j;
Goto L1;
End;
End
Else
Begin
For j:=1 to n do
If c[u,j]=1 then
Begin
If L_thg(u,j,check)=1 then
Begin
c[u,j]:=0; c[j,u]:=0;
Writeln('Di qua canh thu ',dem,' dung 1 lan la tu:',u,'->',j);
u:=j;
Goto L1;
End
End
End;
Readln;
End.
Thầy Trần Thông Quế
4 5 -> 4 đỉnh; 5 cạnh (Bắt buộc phải có hai data này!)
1 2
1 4
2 3
2 4
3 4
Test 2: Dùng file vào EU1.IN
5 6
1 2
1 5
2 5
3 4
3 5
4 5
Thầy Trần Thông Quế
CODE:
Program Chutrinh_Hamilton;
Uses crt;
Var i,j,n:Integer;
c:Array[1..20,1..20] of byte;
p:Array[1..20] of byte;
b:array[1..20] of boolean;
d:Word; f1,f2:Text;
Thầy Trần Thông Quế
Close(f1);
For i:=1 to n do b[i]:=True; d:=0;
Test(1);
Close(f2);
Writeln('DONE!');
Writeln('Go Enter de quay ve chuong trinh!');
Writeln('De xem ket qua, go phim F3, go CtHamil.Out, roi ENTER.');
Readln;
End.
Thầy Trần Thông Quế
Begin
For j:=1 to n do
Begin
Read(f,c[i,j]);
If c[i,j]>0 then
If (c[i,j]
Thầy Trần Thông Quế
Begin
Writeln(g,'Tong chi phi cua hanh trinh DU LICH=',maxsum);
Write(g,'Tour du lich KHEP KIN co chi phi min ma khach da di la:');
For i:=1 to n do Write(g,x[i],' ');
Writeln(g,x[1]);
End
Else
Writeln(g,0);
End;
Procedure Init; {Khoi tri cho cac bien}
Var i,j:integer;
Begin
For i:=1 to n do d[i]:=True;
maxsum:=maxint;
sum:=0;
a[1]:=1;
d[1]:=false;
dem:=0;
End;
Begin clrscr;
Nhap;
Init;
Assign(g,fo); Rewrite(g);
Try(2);
Xuat; Writeln;
Writeln(#32:7,'XONG! GO ENTER->GO PHIM F3->GO HMT.RA->ENTER: DE XEM KET QUA.');
Readln;
Close(g);
End.
= = = = = = = = = = = = = = = =
VIII-3/ CÁC THUẬT TOÁN TÌM ĐƯỜNG ĐI
NGẮN NHẤT TRÊN ĐỒ THỊ.
VIII-3.1) THUẬT TOÁN DIJKSTRA: Tìm đường ngắn nhất từ một điểm đến các điểm
còn lại trên đồ thị.
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
VIII-3.2) THUẬT TOÁN FORD-BELLMAN: Tìm đường ngắn nhất giữa mọi CẶP
đỉnh tùy ý trên đồ thị KHÔNG CÓ CHU TRÌNH ÂM.
2-CÀI ĐẶT FORD-BELLMAN ALGORITHM
(Tổ chức dư liệu VÀO: Bạn hãy tự vẽ bịa ra một đồ thị có trọng số, rồi bạn lập MA
TRẬN KỀ CHO nó. Code của bạn sẽ Test trên ma trận đó. Khi tạo đồ thị nhớ kiểm tra
bảo đảm nó không có chu trình ÂM)
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Procedure venut(u,m1,m2:integer);
var st:string[3];
begin
setfillstyle(1,m2);
setcolor(m1);
fillellipse(c[u],d[u],r,r);
str(u,st);
outtextxy(c[u]-2,d[u]-2,st);
end;
Procedure link(x,y,m1,m2:integer);
var t:integer;st:string[3];
begin
setcolor(m2);
line(c[x],d[x],c[y],d[y]);
t:=y-x +((x-1)*(2*n-x)) div 2;
str(g[x,y],st);
setcolor(m1);
outtextxy(ec[t],ed[t],st);
end;
Procedure init_graph;
var i,j:integer;
begin
randomize;
for i:=1 to n do
begin
g[i,i]:=0;
for j:= i+1 to n do
begin
if random(2) = 1 then g[i,j]:=10 +random(vc-10)
else g[i,j]:=vocuc;
g[j,i]:=g[i,j];
end;
end;
for i:= 1 to n do
begin
j:=0;
repeat
j:=j+1;
until((g[i,j]>0) and (g[i,j]
Thầy Trần Thông Quế
begin
j:=1+random(n);
if j=i then if i
Thầy Trần Thông Quế
bar(0,0,getmaxy,getmaxy);
for i:= 1 to n do
begin
for j:= 1 to n do
if (g[i,j]>0) and(g[i,j]
Thầy Trần Thông Quế
end;
end;
Procedure Thbao_kq;
var st:string[20];
Begin
if a[dau,cuoi]=vocuc then st:='Khong co duong di!'
else
begin
str(a[dau,cuoi],st);
st:='Duong di min='+st;
Timdequy(dau,cuoi);
end;
setcolor(red);
outtextxy(490,210,st);
End;
Procedure Thutuc_goi_thutuc;
Var k:char;
Begin
if keypressed then
repeat
k:=readkey
until not keypressed;
repeat
init_graph;
floyd;
repeat
print_graph;
demo;
Thbao_kq;
k:=readkey;
until (k=#27) or (k=#13);
until(k=#27);
End;
Begin clrscr;
initgr;
Thutuc_goi_thutuc;
closegraph;
End.
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
BỐN BÀI TỰ LUYỆN (TL) CHO CÁC BẠN ÁP DỤNG ALGORITHMS TRÊN
ĐÂY:
TL1/ Trong một mạng lưới giao thông có n thành phố và m hành trình tàu đi trong n
thành phố đó. Thời gian đi từ thành phố i đến thành phố j là t ij. Mỗi hành trình i
xuất phát tại thành phố si1 vào thời điểm ti, đi qua một dãy các thành phố si2, si3,...,
sik. Tại mỗi thành phố tàu sẽ dừng lại để hành khách lên hoặc xuống tàu. Một người
xuất phát ở thành phố s tại thời điểm t muốn đi tới thành phố d.
a) Hãy tìm lộ trình sao cho người đó đến d sớm nhất.
b) Hãy tìm lộ trình với số lần chuyển tàu ít nhất.
Chú ý:
— Không có 2 thang máy nào khác nhau mà lại cùng di chuyển giữa 2 tầng như
Thầy Trần Thông Quế
Thầy Trần Thông Quế
TL4/ Một bãi tập kết rác hình chữ nhật được kẻ ô vuông. Các túi rác
có khối lượng là một số nguyên (hay số thực thì cũng chẳng ảnh hưởng gì đến cách giải
bài toán!) đặt tại mỗi ô vuông. Một robot đi từ ô góc trên cùng trái đến góc duới cùng
phải của bãi rác để gom rác theo luật sau: robot chỉ đi xuống hoặc sang phải theo các
cạnh của ô vuông. Viết code tìm một chiến thuật để robot gom được khối luợng rác lớn
nhất.
VIII-4. CÂY KHUNG (SPANNING TREE) & BÀI TOÁN TÌM CÂY
KHUNG NGẮN NHẤT (SPANNING TREE MIN) TRÊN ĐỒ THỊ.
Ôn một chút lý thuyết:
A) CÂY KHUNG LÀ GÌ? Cho đồ thị vô hướng, liên thông G = {V, E} có N ĐỈNH
(N > 1). Mọi đồ thị con H = {W, F} có N 1 cạnh ( W V, F E) gọi là CÂY
KHUNG của đồ thị G.
B) CÂY KHUNG MIN LÀ GÌ? Cho đồ thị vô hướng có TRỌNG SỐ không âm, liên
thông G = {V, E} có N đỉnh (N > 1), cây khung NGẮN NHẤT (CKMIN) của đồ thị G
là cây khung có tổng trọng số trên tất cả các cạnh của nó là nhỏ nhất.
C) BÀI TOÁN TÌM CKMIN: Cho đồ thị G vô hướng, liên thông và có trọng số không
âm. Hãy tìm cây khung ngắn nhất của G.
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
0 3 4 2
3 0 3 2
4 3 0 1
2 2 1 0
PHẦN IX. ĐỒ THỊ HAI PHÍA
(ÁP DỤNG GIẢI VÀI BÀI TOÁN TÌM CẶP GHÉP CỰC ĐẠI VÀ LẬP LỊCH TỐI ƯU)
Thầy Trần Thông Quế
DƯỚI ĐÂY CHỈ CÓ ĐIỀU KIỆN NÊU VÀI BÀI TOÁN ÁP DỤNG MỘT
SỐ TRONG CÁC THUẬT TOÁN TRÊN. (Các bạn có thể tham khảo chi tiết ở
quyển LÝ THUYẾT ĐỒ THỊ, NXB Giáo Dục, 2012, Tác giả: Trần Thông Quế).
Thầy Trần Thông Quế
A[j1,j2]:=j3;
A[j2,j1]:=j3;
test[j2]:=false;
End;
close(f);
nho:=0;
End;
Thầy Trần Thông Quế
Writeln(#32:12,'KET QUA PROGRAM:');
Writeln;
While not (seekeof(f)) do
Begin
Readln(f,line);
Writeln(#32:7,line);
End;
Close(f);
End;
{Main Prog.}
Begin clrscr;
Nhap;
Try(1);
Xuat;
Xem;
Write('Done!');
Readln;
End.
Thầy Trần Thông Quế
for i:=1 to n do tree[i]:=i;
for i:=1 to n do
for j:=1 to n do
if a[i,j]=0 then
if (test[i] and test[j]) then
a[i,j]:=max
else if (not test[i] and not test[j]) then
a[i,j]:=-10000;
trongso:=0;
end;
Thầy Trần Thông Quế
Begin
Assign(f,fo);
rewrite(f);
writeln(f,trongso);
for i:=1 to n-1 do
if a[canh[i,1],canh[i,2]]<>max then
writeln(f,canh[i,1]:2,canh[i,2]:2,a[canh[i,1],canh[i,2]]:2);
close(f);
end;
{Main Prog.}
Begin clrscr;
Nhap;
Creat;
PRINT;
Write('Done!');
ENd.
2/ Bài toán 2
Có n lọ hoa và k bó hoa được đánh số thứ tự từ nhỏ tới lớn. Cần cắm k bó hoa vào n lọ sao cho hoa có số
thứ tự nhỏ phải đứng trước hoa có số thứ tự lớn. Giá trị thẩm mỹ khi cắm bó hoa i vào lọ j là v(i, j). Hãy tìm
một cách cắm hoa sao cho tổng giá trị thẩm mỹ là lớn nhất. Biết rằng mỗi bó hoa chỉ được cắm vào một lọ
và mỗi lọ chỉ cắm một bó hoa.
Dữ liệu vào cất trên text file với tên Camhoa.In gồm :
*Dòng 1: ghi 2 số n và k.
* k dòng tiếp theo mỗi dòng ghi n số nguyên dương với số ở hàng i cột j biểu thị giá trị thẩm mỹ bó hoa i
cắm vào lọ j.
Kết quả ghi lên text file với tên Camhoa.Ou gồm :
*Dòng đầu: In tổng giá trị thẩm mỹ lớn nhất:
* k dòng tiếp theo mỗi dòng ghi 2 số i, j biểu thị bó hoa i cắm vào lọ j. Một trường hợp cụ thể của bài toán
ghi ở bên phải các dòng này.
Thầy Trần Thông Quế
* Nếu i = j thì L[i, j] = v[1, 1] + v[2, 2] + ... + v[i, i].
* Nếu i < j thì L[i, j] = Max(L[i—1,j —1] + v[i, j], L[i, j — 1]).
Thầy Trần Thông Quế
i:=k; j:=n; d:=0;
While (i>0) And (j>0) do
If (L[i,j]=L[i,j-1]) And (v[i,j]>0) Then
Begin
Cap[i]:=j-1;
Dec(j);
End
Else Begin cap[i]:=j; dec(i); dec(j) End;
For i:=1 to k do
Writeln(f,'Bo hoa thu ',i,' cam vao lo ',cap[i]);
Close(f);
End;
Thầy Trần Thông Quế
6 2
5 7
6 3
Thầy Trần Thông Quế
Resul[dau]:=chitiet;
dx[chitiet]:=True;
End;
Until dau=cuoi-1;
End;
Procedure HienThi;
Begin
{Ghi mang ket qua len file Bt4.Ou theo dung yeu cau o de ra. các con tự làm} End;
Function max2(a,b:Real):Real;
Begin
{Ham xac dinh so lon hon trong 2 so a, b cho truoc. Các con tự làm}
End;
Function Tinh;
Var i,j :Byte; t1, t2:Real;
Begin
t1:=0; t2:=0;
For i:=1 to n Do
Begin
t1:=t1+a[1, resul[i]];
t2:=max2(t1,t2)+a[2,resul[i]] ;
End ;
Writeln(f, t2 :0 :0) ;
End ;
{Main Prog.}
Begin Clrscr;
Nhap;
Johnson_algo;
Assign(f,fo); Rewrite(f);
Tinh;
HienThi;
Write(‘Done!’);
Readln;
End.
Thầy Trần Thông Quế
6 3
2 5 8 1 5 1
Thầy Trần Thông Quế
Function Tim_May_min:Integer;
Begin
{Tim may co thoi gian lam nho nhat. Vi de nen cac con tu lam }
End;
Thầy Trần Thông Quế
End;
End;
If not ok then
If i<=n then
Begin
j:=Tim_May_min ;
may[j]:=may[j]+t[i];
p[i]:=j; {Giao viec moi cho may j da co thoi gian lam it nhat}
If may[j]> maxt the maxt:=may[j];
End;
End;
End;
Thầy Trần Thông Quế
* Dòng đầu là tổng tiền công lớn nhất.
* Các dòng tiếp theo mỗi dòng ghi 4 số: số hiệu công việc i, thời điểm bắt đầu
công việc t1, thời điểm kết thúc công việc t2, tiền công tc.
Thuật toán :
* Xếp tăng bộ dữ liệu theo khoá là thời điểm cuối cùng phải kết thúc công việc.
Thầy Trần Thông Quế
Lt4.Ou
6
2 5 3 1 4
Thầy Trần Thông Quế
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Thầy Trần Thông Quế
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
8 h 54 m 28/7/2017
Thầy Trần Thông Quế
Thầy Trần Thông Quế
![Báo cáo bài tập Nhập môn Lập trình lớp: [Thông tin thêm về lớp/khóa học nếu có]](https://cdn.tailieu.vn/images/document/thumbnail/2021/20210705/xusong/135x160/3811625456409.jpg)
