pascal tuan anh
Đề số 1
Bài 1. Số nguyên tố
áp dụng thuật toán Sàng Eratosthene như sau: xây dựng một tập hợp các phần tử từ 2 đến n gọi là sàng. Ta sẽ lọc dần các số ra khỏi sàng theo cách sau đây: Số nhỏ nhất trong sàng (theo cách xây dựng của ta là số nguyên tố) được in ra. Sau đó ta lọc khỏi sàng tất cả các bội số của số nhỏ nhất này kể cả chính nó. Số nguyên tố tiếp theo chính là số nhỏ nhất trong phần còn lại của sàng. Ta tiếp tục xử lý phần còn lại này theo quy cách trên cho tới khi sàng không còn số nào. Như vậy không một số nguyên tố nào bị lọc khỏi sàng mà không được in ra.
PROGRAM Sang;
Uses crt;
Const max=60000;
out='snt.txt';
Var n:integer;
mark:array[1..max] of boolean;
i,j:integer;
f:text;
BEGIN
clrscr;
write('Cho n = ');
readln(n);
for i:=1 to n do mark[i]:=false;
assign(f,out);
rewrite(f);
for i:=2 to n do
if not mark[i] then
write(f,i,' ');
j:=2*i;
while j<n do
mark[j]:=true;
j:=j+i;
end;
end;
if i mod 1000=0 then writeln(f);
end;
close(f);
END.
Bài 2. Hệ đếm
Có thể có nhiều cách giải khác nhau nhưng tất cả đều cần phải giải quyết các vấn đề:
- Kiểm tra xem một số có là số nguyên tố hay không?
- Tìm dạng biểu diễn nhị phân của một số.
- Kiểm tra một số có là đối xứng không?
- Chọn các số đối xứng (trong hệ thập phân) thích hợp để kiểm tra.
Việc giải quyết rất đơn giản, xin dành lại cho bạn đọc.
PROGRAM Bienso;
Uses crt;
Var m,i,j,k,n,l:integer;
a,b:array[1..14] of integer;
Procedure chuyenma(i:integer);
Begin
l:=0;
while i<>0 do
l:=l+1;
a[l]:=i mod 2;
i:=i div 2;
end;
End;
Function ngto(i:integer):boolean;
var b:boolean;
j:integer;
Begin
b:=true;
j:=1;
while (j<trunc(sqrt(i))) and b do
j:=j+1;
if i mod j = 0 then b:=false;
end;
ngto:=b;
End;
Function doixung:boolean;
var b:boolean;
j:integer;
Begin
b:=true;
i:=1;
while (i<=l div 2) and b do
if a[i]<>a[l-i+1] then b:=false
else i:=i+1;
end;
doixung:=b;
End;
BEGIN
clrscr;
b[1]:=1; b[2]:=3;
b[3]:=7; b[4]:=9;
for m:=1 to 4 do
for k:=0 to 9 do
n:=101*b[m] + 10*k;
if ngto(n) then
chuyenma(n);
if doixung then
write('Bien so can tim: ',n:5,' Ma nhi phan la ');
for j:=1 to l do
write(a[j]:2);
writeln;
end
else
writeln('So ngto doi xung nhung ma nhi phan khong doi xung ',n:5);
end;
end;
END.
Đề số 2
Bài 1. Tính giá trị biểu thức
Đây chỉ là một bài toán tính toán giá trị biểu thức thông thường, tuy nhiên ta cần lưu ý hai vấn đề sau:
- Có một số biểu thức con xuất hiện ở một số nơi trong biểu thức. Nếu ta trình bày lại biểu thức như đầu bài thì có nghĩa là đ• tính "lặp" các biểu thức con đó. Việc tính lặp đó, một mặt sẽ gây rối rắm khi viết chương trình, mặt khác làm chương trình thực hiện lâu hơn. Bởi vậy việc "làm tốt hơn" chương trình cả về trình bày lẫn thực hiện luôn luôn được đặt ra (Với các bài toán lớn thì ý nghĩa của công việc đó càng cao). Người ta gọi việc làm đó là tối ưu chương trình". Khi thể hiện cách thức đó thường chúng ta cần thêm biến phụ để lưu trữ các giá trị trung gian đó.
- Việc tổ chức dữ liệu vào đúng đắn cũng được thể hiện thông qua toán tử REPEAT - UNTIL ở đây sử dụng các siêu lệnh dịch ({$I+} và {$I-}) để làm điều đó.
PROGRAM Bieuthuc;
Uses crt;
Var c,d:integer;
i:byte;
gt,x1,x2,phu,phu2:real;
BEGIN
clrscr;
write('Cho hai so c va d: ');
repeat
gotoxy(22,1);
clreol;
{$I-}
readln(c,d);
i:=ioresult;
{$I+}
if i<>0 then writeln(#7);
until i=0;
phu:=sqrt(9+4*abs(c*d));
x1:=(3+phu)/2;
x2:=(3-phu)/2;
phu2:=c*x1*x1*x1+d*x2*x2;
phu:=sin(abs(phu2-c*d));
gt:=abs(phu)*phu*phu;
phu:=(phu2-x1);
gt:=abs(gt/(sqrt(phu*phu+3.14)));
gt:=gt+(sin(phu)/cos(phu));
write('Gia tri cua bieu thuc la: ',gt);
readln;
END.
Bài 2. Quan hệ
Lập mảng XEP[1..N] khởi tạo mọi giá trị bằng 0. Bắt đầu chia nhóm từ người thứ nhất cho tới người thứ N. Khi xét người thứ i, những khả năng sau có thể xảy ra:
- Nếu XEP[i]=0 (chưa được xếp nhóm) thì xếp vào nhóm 1 (XEP[i]=1) và xếp những người j quen i vào nhóm 2 (cho XEP[j]=2).
- Nếu XEP[i]=1 và trong số những người quen i có một người j mà XEP[j] cũng bằng 1 thì kết luận không xếp được.
- Nếu XEP[i]=2 và trong số những người quen i có một người j mà XEP[j] cũng bằng 2 thì kết luận không xếp được.
PROGRAM QuanHe;
Uses crt;
Const inp='quanhe.inp';
out='quanhe.out';
Var n:integer;
f:text;
a:array[1..100,1..100] of integer;
xep:array[1..100] of integer;
Procedure readinp;
var i,j:integer;
Begin
assign(f,inp);
reset(f);
readln(f,n);
for i:=1 to n do
for j:=1 to n do
read(f,a[i,j]);
readln(f);
end;
close(f);
End;
procedure continue(i,k:integer);
var j:integer;
for j:=1 to n do
if a[i,j]<>0 then
if xep[j]=0 then
xep[j]:=k;
continue(j,3-k);
end
else
if xep[j]=3-k then
write(f,'KHONG XEP DUOC');
close(f);
halt;
end;
end;
Procedure select;
var i,j:integer;
Begin
for i:=1 to n do
xep[i]:=0;
for i:=1 to n do
if xep[i]=0 then
xep[i]:=1;
continue(i,2);
end;
End;
var i:integer;
BEGIN
readinp;
assign(f,out);
rewrite(f);
select;
for i:=1 to n do
if xep[i]=1 then write(f,i,' ');
writeln(f);
for i:=1 to n do
if xep[i]=2 then write(f,i,' ');
close(f);
END.
4
0 1 0 1
1 0 1 0
0 1 0 0
1 0 0 0
Đề số 3
Bài 1. Phân số
Khởi tạo phân số có dạng 1/1 (P=1, Q=1). Chừng nào Q<max, nếu P/Q<R thì tăng P một đơn vị, nếu P/Q>R thì tăng Q lên 1.
PROGRAM Phantich;
Uses crt;
Const out='kq.txt';
Var socach, q, r:integer;
a:array[0..50] of integer;
f:text;
Procedure tach(n,k:integer); {tach n so con lai, truoc do da tach duoc k so}
var j,l:integer;
Begin
if (n>0) then
if (k=0) then l:=1
else l:=a[k];
for j:=l to n do
k:=k+1;
a[k]:=j;
tach(n-j,k);
k:=k-1;
end;
end
else
if k>1 then
inc(socach);
write(f,a[1]);
for j:=2 to k do
write(f,'+',a[j]:2);
writeln(f);
end;
End;
BEGIN
clrscr;
repeat
write('Cho mot so nam giua 2 va 50: ');
readln(q);
until ((q>1) and (q<51));
writeln('Cac cach phan tich ',q,' thanh tong cac so nho hon');
writeln;
socach:=0;
r:=0;
assign(f,out);
rewrite(f);
tach(q,r);
close(f);
END.
Bài 2. Kiến thiết xâu văn bản
Ta gọi mọi d•y thoả m•n điều kiện đề bài là d•y hợp lệ. Dễ dàng nhận xét được rằng không thể xây dựng d•y hợp lệ bằng cách mở rộng thêm một phần tử vào phần đuôi của một d•y không hợp lệ. Nói một cách khác, một d•y hợp lệ B hoặc là d•y gồm một phần tử hoặc chỉ được xây dựng bằng cách khai triển d•y hợp lệ A (A<B). Do vậy ta tìm và đưa ra các d•y hợp lệ bằng cách kiến thiết lần lượt, vừa mở rộng vừa kiểm tra tính hợp lệ.
Ta có thể áp dụng phương pháp quay lui sau: Nếu giá trị phần tử cuối của d•y hợp lệ nhỏ hơn 3 thì tăng lên một đơn vị và kiểm tra tính hợp lệ, ngược lại giảm chiều dài của d•y đi một đơn vị.
PROGRAM XauVanBan;
Uses crt;
Const n=4;
out='xvb.txt';
Var d:array[0..n] of integer;
good:boolean; {kiem tra day co hop le hay khong}
length,s,i,k,m,mlimit:integer;
f:text;
BEGIN
clrscr;
length:=0;
s:=0;
d[0]:=0;
assign(f,out);
rewrite(f);
Repeat
if length<n then
length:=length+1;
d[length]:=0;
end;
Repeat
while d[length]=3 do
length:=length-1;
if length=0 then break;
d[length]:=d[length]+1;
good:=true;
m:=1;
mlimit:=length div 2;
while ((m<=mlimit) and good) do
k:=0; {kiem tra cac xau con lien ke}
repeat
good:=d[length-k]<>d[length-m-k];
k:=k+1;
until ((k=m) or good);
m:=m+1;
end;
Until good;
if length=0 then break;
i:=0;
s:=s+1;
Repeat
i:=i+1;
write(f,d[i]);
Until i=length;
writeln(f);
Until length=0;
writeln(f);
writeln(f,'Tat ca co ',s,' day hop le');
close(f);
END.
Đề số 4
Bài 1. Điểm trên mặt phẳng
Trong bài này ta sử dụng một kiến thức về hình học: Điểm (x,y) muốn thuộc đường thẳng đi qua hai điểm (x1,y1) và (x2,y2) khi và chỉ khi nó thoả m•n:
(x-x2)(y1-y2)=(y-y2)(x1-x2) hay
(x-x2))y1-y2)-(y-y2)(x1-x2)=0 (*)
Đường thẳng l sẽ chia các điểm không thuộc nó thành 2 loại (tương ứng với hai nửa mặt phẳng): một loại làm cho vế trái của (*) dương và loại còn lại làm cho nó âm. Vì lẽ đó nếu 2 điểm cùng phía khi và chỉ khi tích hai vế dương.
PROGRAM MatPhang;
Uses crt;
Var a,b,c,d,e,f,g,h:real;
BEGIN
clrscr;
write('Cho toa do e,f: ');
readln(e,f);
write('Cho toa do g,h: ');
repeat
readln(g,h);
until (not ((g=e) and (f=h))) and (not ((g=f) and (h=e)));
write('Cho toa do a,b: ');
repeat
readln(a,b);
until (g-e)*(b-f)<>(h-f)*(a-e); {khong thuoc l}
write('Cho toa do c,d: ');
repeat
readln(c,d);
until (g-e)*(d-f)<>(h-f)*(c-e); {khong thuoc l}
if ((g-e)*(d-f)-(h-f)*(c-e))*((g-e)*(b-f)-(h-f)*(a-e))>0 then
writeln('hai diem nam cung phia so voi l')
else
writeln('hai diem nam khac phia so voi l');
readln;
END.
Bài 2. Chia vật
Trong bài toán này có rất ít mối liên hệ để có thể tìm ra được một công thức trực tiếp tính toán số cách chia. Vì vậy ta sẽ phải dùng giải pháp đệ quy.
PROGRAM Chiaphan;
uses crt;
var sovat,songuoi:integer;
Function chia(m,n:integer):integer;
if m=0 then chia:=1
else
if n=0 then chia:=0
else
if m<n then chia:=chia(m,m)
else chia:=chia(m,n-1) + chia(m-n,n);
end;
BEGIN
clrscr;
write('Cho so vat va so nguoi: ');
readln(sovat,songuoi);
writeln('So cach chia la: ', chia(sovat,songuoi));
readln;
END.
Đề Số 5
Bài 1. Tìm nghiệm phương trình siêu việt
Ta áp dụng phương pháp chia đôi như sau: giả sử (a,b) là một khoảng nào đó sao cho f(a)<0, f(b)>0. Gọi c là trung điểm của (a,b). Nếu f(c)=0 thì c chính là nghiệm. Ngược lại nếu f(c)>0 thì ta thay b bằng c, nếu f(c)<0 thì ta thay a bằng c. Quá trình này cứ tiếp diễn và khoảng (a,b) luôn luôn được điều chỉnh với mục đích:
- Đảm bảo giá trị của hàm f tại hai mút luôn trái dấu. Vì f là một hàm liên tục nên trong khoảng (a,b) luôn luôn có nghiệm.
- Mỗi lần điều chỉnh, độ dài của khoảng giảm hai lần. Gọi nghiệm đúng là x, với bất cứ giá trị c nào nằm trong đoạn [a,b] ta luôn có đánh giá: |x-c|<|b-a|. Vì vậy nếu ở một bước nào đó ta chọn a làm nghiệm xấp xỉ thì sai số cũng không vượt quá b-a.
PROGRAM chiadoi;
uses crt;
const saiso=0.000001;
var a,b,c,f:real;
nghiemdung:boolean;
i:integer;
BEGIN
nghiemdung:=false;
a:=-1; b:=0;
while (b-a>saiso) and (not nghiemdung) do
c:=(a+b)/2;
f:=c*c*c+exp(c);
if f>0 then b:=c
else
if f<0 then a:=c
else nghiemdung:=true;
end;
if nghiemdung then
write('Nghiem dung = ',c:9:6)
else
write('Nghiem gan dung = ',c:9:6);
END.
Bài 2. Đặt phép tính
Ta tiến hành duyệt các khả năng đặt dấu '+' và '-' giữa các số để tìm biểu thức có giá trị đ• cho. Mỗi vị trí có ba phương án là đặt dấu '+', dấu '-' hoặc không đặt dấu gì cả.
PROGRAM Datdau;
uses crt;
type dau=(cong,tru,khong);
var i,j:byte;
vitri:array[1..9] of dau;
n:integer;
Procedure inketqua;
var i:byte;
Begin
writeln;
write('1');
for i:=1 to 8 do
case vitri[i] of
cong: write('+');
tru: write('-')
end;
write(i+1);
end;
writeln;
halt;
End;
Procedure tinhgiatri;
var j:byte;
kq,phu:longint;
dautien:dau;
b:boolean;
Begin
kq:=0;
dautien:=cong;
phu:=1;
j:=1;
repeat
while (vitri[j]=khong) and (j<9) do
j:=j+1;
phu:=phu*10+j;
end;
case dautien of
cong: kq:=kq+phu;
tru: kq:=kq-phu;
end;
b:=j<9;
if b then
dautien:=vitri[j];
inc(j);
phu:=j;
end;
until not b;
if kq=n then inketqua;
End;
Procedure thuchien(j:byte);
var dau0:dau;
Begin
for dau0:=cong to khong do
vitri[j]:=dau0;
if j=8 then tinhgiatri
else thuchien(j+1);
end;
End;
BEGIN
clrscr;
write('Vao so <32767: ');
readln(n);
vitri[9]:=cong;
thuchien(1);
writeln('Khong co bieu thuc nao thoa man');
END.
Đề số 6
Bài 1. Trò chơi bốc sỏi
Gọi số lượng bốc tối đa mỗi lần là k. Chiến thuật thắng cho máy là cố gắng bốc số sỏi sao cho số lượng còn lại chia hết cho k+1 (mod (k+1) =0). Còn nếu số sỏi trước khi bốc đang chia hết cho k+1 thì chỉ nên cho máy bốc một viên để hạn chế khả năng thắng của đối thủ.
PROGRAM Bocsoi;
uses crt;
var sosoi,soboctoida,soluongboc:integer;
maytinhboc:boolean;
BEGIN
clrscr;
repeat
write('Cho so vien soi:');
readln(sosoi);
write('Cho so vien duoc boc toi da: ');
readln(soboctoida);
until (sosoi>0) and (soboctoida>0);
maytinhboc:=true;
while sosoi>0 do
if maytinhboc then
if sosoi mod (soboctoida+1)=0 then
soluongboc:=1
else
soluongboc:=sosoi mod (soboctoida+1);
writeln('May tinh boc ',soluongboc,' vien');
maytinhboc:=false;
sosoi:=sosoi-soluongboc;
end
else
repeat
write('Ban boc bao nhieu vien ');
readln(soluongboc);
until (soluongboc>0) and (soluongboc<=soboctoida);
maytinhboc:=true;
sosoi:=sosoi-soluongboc;
end;
if maytinhboc then
writeln('May thua - Nguoi thang')
else writeln('Nguoi thua - May thang');
END.
Bài 2. Chu trình đơn hoạch
Đây chính là bài toán tìm chu trình Euler trên đồ thị vô hướng. Điều đó có nghĩa là có chu trình đơn hoạch khi và chỉ khi mọi đỉnh trong đồ thị đều là đỉnh bậc chẵn.
Thuật giải có thể được tiến hành như sau:
- Đầu tiên tìm một chu trình C bất kỳ trong đồ thị. Xoá các cạnh thuộc C đi ta được đồ thị mới H.
- Bắt đầu từ một đỉnh nào đó của chu trình C, đi theo các cạnh của chu trình C chừng nào chưa gặp phải đỉnh không cô lập của H. Nếu gặp phải đỉnh như vậy thì ta đi theo chu trình Euler của thành phần liên thông của H chứa đỉnh đó. Sau đó lại tiếp tục đi theo cạnh của C cho đến khi gặp phải đỉnh không cô lập của H thì lại theo chu trình Euler của thành phần liên thông tương ứng trong H ... Quá trình sẽ kết thúc khi ta trở về đỉnh xuất phát, tức là thu được chu trình đi qua mỗi cạnh của đồ thị đúng một lần.
PROGRAM ChuTrinhEuler;
Uses crt;
Var ke:array[1..1000] of shortint;
Tro,STACK,chuaxet,pre,bac,CE:array[1..100] of byte;
dd:array[1..100] of boolean;
f:text;
n,m,goc,giu,j:integer;
{-------------------------------------------------------}
Procedure Doc; {Nhap du lieu tu tep}
Var i:integer;
Begin
Assign(f,'dothi.txt');
Reset(f);
Readln(f,n); m:=0;
For i:=1 to n do
tro[i]:=m+1; bac[i]:=0;
while not eoln(f) do
inc(m); inc(bac[i]);
read(f,ke[m]);
end;
readln(f);
end;
tro[n+1]:=m+1;
For i:=1 to n do if bac[i] mod 2 <>0 then
write('Do thi khong phai la do thi EULER. ');
readln; halt;
end;
Close(f);
End;
{-------------------------------------------------------}
Function cycle(u:byte):boolean; {kiem tra ket thuc chu trinh}
Var truoc:byte;
Begin
truoc:=pre[u]; cycle:=true;
While truoc<>goc do
Begin
if truoc=u then exit;
truoc:=pre[truoc];
End;
if truoc=u then exit;
cycle:=false;
End;
{-----------------------------------------------------}
Procedure DFS(v:byte);
Var u,i,j:byte;
Begin
chuaxet[v]:=1;
For u:=tro[v] to tro[v+1]-1 do
if ke[u]>0 then
if chuaxet[ke[u]]=0 then
pre[ke[u]]:=v;
if ke[u+1]<0 then j:=tro[-ke[u+1]]-1
else j:=tro[ke[u+1]]-1;
for i:=tro[ke[u]] to j do
if ke[i]=v then
begin ke[i]:=-ke[i]; dd[i]:=true;i:=j; end;
ke[u]:=-ke[u]; dd[u]:=true;
DFS(-ke[u]);
end
else
if cycle(ke[u]) then begin giu:=v;exit; end;
End;
{-----------------------------------------------------}
Procedure ChuTrinh(i:byte); {tim 1 chu trinh bat dau tu 1 dinh}
Var j:integer;
Begin
Fillchar(chuaxet,sizeof(chuaxet),0);
Fillchar(dd,sizeof(dd),false);
goc:=i; pre[i]:=i;
DFS(i);
For j:=1 to m do if dd[j] then ke[j]:=-ke[j];
End;
{-------------------------------------------------------}
Procedure Inketqua;
Var i:integer;
Begin
Writeln(' Chu trinh EULER trong do thi la :');
For i:=1 to j-1 do write(CE[i],'==>'); write(CE[j]);
End;
{-------------------------------------------------------}
Procedure loaicanh(x,y:integer);
Var i,d,c:integer;
Begin
for i:=tro[x] to tro[x+1]-1 do
if ke[i]=y then begin ke[i]:=-ke[i]; i:=tro[x+1]-1; end;
for i:=tro[y] to tro[y+1]-1 do
if ke[i]=x then begin ke[i]:=-ke[i]; i:=tro[y+1]-1; end;
End;
{-------------------------------------------------------}
Procedure ChutrinhEULER;
Var u,v,i,k:integer;
Begin
u:=1; Chutrinh(u);
v:=1; j:=1; CE[j]:=1;
Repeat
if bac[v]<=2 then
for i:=tro[v] to tro[v+1]-1 do
if ke[i]>0 then
dec(bac[v]);
inc(j); CE[j]:=ke[i];
dec(bac[ke[i]]);
loaicanh(v,ke[i]);k:=tro[v+1]-1;
if ke[i]<0 then v:=-ke[i]
else v:=ke[i];
i:=k;
end;
end
else
chutrinh(v);
inc(j); CE[j]:=giu;
dec(bac[giu]); dec(bac[v]);
loaicanh(v,giu);
v:=giu;
end;
Until v=u;
Inketqua;
End;
{-------------------------------------------------------}
BEGIN
ClrScr;
Doc;
ChuTrinhEULER;
END.
Đề số 7
Bài 1. Phân tích số
Giả sử a1+...+an=n là một phân tích của n. Ta thấy mọi phân tích của n đều có thể nhận được từ việc tách khỏi n một số a1 và phân tích phần (n-a1) còn lại. a1 có thể nhận mọi giá trị từ 1 đến n. Do vậy ta sẽ dùng một thủ tục đệ quy để tách một số tự nhiên thành tổng các số tự nhiên khác. Do thứ tự bên trong tổng (a1+...+ak) là không quan trọng nên để tối ưu số bước tách và để tránh trùng lặp nhiều lần một phân tích ta giả thiết: a1<=a2<=...<=an. Sự phân tích sẽ hoàn tất nếu phần còn lại khi tách là bằng 0.
PROGRAM ChiaKeo;
Uses crt;
Const inp='keo.inp';
out='keo.out';
Var i,j,n,max,j1,j2,chenh:integer;
c:array[1..100] of integer;
v:array[1..2,0..20000] of byte;
f:text;
Procedure doc;
Begin
assign(f,inp);
reset(f);
readln(f,n);
for i:=1 to n do
read(f,c[i]);
close(f);
End;
Procedure chia;
Begin
fillchar(v,sizeof(v),0);
v[1,0]:=1; max:=0;
for i:=1 to N do
for j:=max downto 0 do
if v[1,j]=1 then
if v[1,j+c[i]]=0 then
v[1,j+c[i]]:=1;
v[2,j+c[i]]:=i;
end;
max:=max+c[i];
end;
j1:=max div 2;
while (v[1,j1]=0) do dec(j1);
j2:=max-j1;
chenh:=j2-j1;
End;
Procedure viet;
Begin
assign(f,out);
rewrite(f);
writeln(f,chenh);
i:=j1; j:=0;
while i>=1 do
inc(j);
write(f,v[2,i]:4);
i:=i-c[v[2,i]];
if (j mod 20 = 0) then writeln(f);
end;
i:=j2; j:=0;
writeln(f);
while i>=1 do
inc(j);
write(f,v[2,i]:4);
i:=i-c[v[2,i]];
if (j mod 20=0) then writeln(f);
end;
close(f);
End;
BEGIN
doc;
chia;
viet;
END.
3
6 3 2
Bài 2. Chia kẹo
Sử dụng phương pháp qui hoạch động. Lấy một mảng có độ dài bằng tổng số kẹo có nhiệm vụ đánh dấu số kẹo có thể được chia cho từng người. Nếu vị trí càng gần tổng số kẹo chia đôi được đánh dấu thì độ chênh lệch giữa hai nhóm càng ít.
PROGRAM Phanso;
Uses crt;
Var p,q,max:integer;
r,p0,q0:real;
BEGIN
clrscr;
write('Nhap so nguyen duong MAX: ');
readln(max);
write('Nhap so thuc R: ');
readln(r);
p:=1; q:=1;
while q<=max do
q0:=q; p0:=p;
if p0/q0<r then inc(p)
else inc(q);
end;
if q>max then dec(q);
write('Phan so tim duoc: ',p,'/',q);
readln;
END.
Đề số 8
Bài 1. Cân một vật
Bài này ta sử dụng phương pháp duyệt các khả năng đặt quả cân từng bên đĩa cho đến khi tìm được một phương án cân hoặc duyệt hết mà không tìm được phương án nào. Mỗi quả cân sẽ được nhận một trong 3 giá trị:
-1: đặt quả cân bên trái.
0: không sử dụng quả cân này.
1: đặt quả cân bên phải.
PROGRAM Can;
Uses crt;
Var n,i,y,vc:integer;
x,d:array[1..100] of integer;
Procedure Print;
Begin
writeln('Dat cac qua can nhu sau ');
writeln('Trai':24,'Phai':24);
for i:=1 to n do
if x[i]=1 then writeln('':20,d[i]);
if x[i]=-1 then writeln('':45,d[i]);
end;
halt;
End;
Procedure chon(i:integer);
var k:integer;
Begin
for k:=-1 to 1 do
y:=y+k*d[i];
x[i]:=k;
if y=vc then print
else
if i<n then chon(i+1);
x[i]:=0;
y:=y-k*d[i]
end;
End;
BEGIN
clrscr;
writeln('Vao trong luong can can');
readln(vc);
write('So luong qua can n = ');
readln(n);
writeln('Nhap trong luong cac qua can');
for i:=1 to n do readln(d[i]);
y:=0;
for i:=1 to n do x[i]:=0;
chon(1);
write('Khong can duoc');
END.
Bài 2. Ghép xâu
Ta dùng kỹ thuật quay lui để duyệt mọi cách biểu diễn S dưới dạng ghép của các xâu Ai.
PROGRAM GhepXau;
Uses crt;
Const inp='xau.inp';
out='xau.out';
Var a:array[1..100] of string[40];
kq:array[1..100] of string[10];
s:string;
n,i,j,k,u,sbd:byte;
f:text;
Procedure xep(var s:string);
var s2:string;
i:integer;
Begin
if s='' then
sbd:=sbd+1;
for i:=1 to k do write(f,kq[i]);
writeln(f);
end
else
for i:=1 to n do
u:=length(a[i]);
if a[i]=copy(s,1,u) then
k:=k+1;
{tam[k]:=i;}
str(i,s2);
kq[k]:='A['+s2+']';
delete(s,1,u);
xep(s);
k:=k-1;
s:=a[i]+s;
end;
end;
End;
BEGIN
assign(f,inp);
reset(f);
readln(f,s);
readln(f,n);
for i:=1 to n do readln(f,a[i]);
close(f);
assign(f,out);
rewrite(f);
sbd:=0;
k:=0;
xep(s);
if sbd=0 then writeln(f,'KHONG CO');
close(f);
END.
abcdef
11
ab
cd
ef
abc
def
a
c
d
f
Đề số 9
Bài 1. Đường đi ngắn nhất
Đây là một ví dụ điển hình của thuật toán Dijkstra dùng để tìm đường đi ngắn nhất giữa hai đỉnh của một đồ thị có trọng số không âm.
PROGRAM TT_Dijkstra;
Uses crt;
Const marr=101;
max=-1;
inp='input.txt';
out='output.txt';
Type arr1=array[0..marr,0..marr] of integer;
arr2=array[0..marr] of integer;
arr3=array[0..marr] of longint;
arr4=array[0..marr] of boolean;
Var a:arr1;
pre:arr2;
mark:arr4;
d:arr3;
n,u,v:integer;
m:longint;
f:text;
{----------------------------------------------------}
Procedure readinp;
var i,j:integer;
Begin
assign(f,inp);
reset(f);
readln(f,n,u,v);
for i:=1 to n do
for j:=1 to n do
read(f,a[i,j]);
readln(f);
end;
close(f);
End;
{----------------------------------------------------}
Procedure init;
var i:integer;
Begin
fillchar(mark,sizeof(mark),false);
fillchar(pre,sizeof(pre),0);
for i:=1 to n do d[i]:=max;
d[u]:=0;
End;
{----------------------------------------------------}
Procedure timmin(var j:integer);
var i:integer;
Begin
j:=1;
while mark[j] do inc(j);
for i:=j+1 to n do
if not mark[i] then
if d[i]<>max then
if (d[j]=max) or (d[i]<d[j]) then j:=i;
End;
{----------------------------------------------------}
Procedure dijkstra;
var i,j:integer;
Begin
repeat
timmin(j);
if (j=n+1) or (j=v) then exit;
mark[j]:=true;
for i:=1 to n do
if not mark[i] and (a[j,i]<>0) then
if (d[i]=max) or ((d[i]<>max) and (d[i]>d[j]+a[j,i])) then
d[i]:=d[j]+a[j,i];
pre[i]:=j;
end;
until j=n+1;
End;
{----------------------------------------------------}
Procedure find(i:integer);
Begin
if i=u then write(f,m,#10,#13,u,' ')
else
inc(m,a[pre[i],i]);
find(pre[i]);
write(f,i,' ');
end;
End;
{----------------------------------------------------}
Procedure writeout;
var i:integer;
Begin
assign(f,out);
rewrite(f);
m:=0;
find(v);
close(f);
End;
{----------------------------------------------------}
BEGIN
clrscr;
readinp;
dijkstra;
writeout;
END.
3 1 3
0 2 4
0 0 1
0 0 0
Bài 2. D•y số
Ta giải bài toán này bằng phương pháp quy hoạch động. Sử dụng hai mảng, tại vị trí thứ i, một mảng lưu số lượng d•y tăng dài nhất tính đến vị trí thứ i, còn một mảng lưu vị trí số liền kề với nó trong d•y trên.
PROGRAM Congty;
Uses crt;
Var a,tt,sl:array[1..1000] of integer;
f,f1:text;
n,max:integer;
Procedure Doc;
Var i:integer;
Begin
Assign(f,'ct.inp');
Reset(f);
Read(f,n);
For i:=1 to n do
read(f,a[i]);
Close(f);
End;
Procedure Chuan_bi;
Var i:integer;
Begin
For i:=1 to n do
sl[i]:=0;
tt[i]:=0;
end;
sl[1]:=1;
End;
Procedure Day_so;
Var i:integer;
Procedure xac_dinh(i:integer);
Var j,max,k:integer;
Begin
max:=0; k:=0;
For j:=1 to i-1 do
if (a[j]<=a[i]) and (sl[j]>max) then
max:=sl[j];
k:=j;
end;
sl[i]:=max+1;
tt[i]:=k;
End;
Begin
For i:=2 to n do
Xac_dinh(i);
End;
Procedure danh_dau;
Var i,jm,j:integer;
Begin
max:=0;
For i:=1 to n do
if sl[i]>max then
max:=sl[i];
j:=i;
end;
jm:=tt[j];
sl[j]:=-sl[j];
Repeat
sl[jm]:=-sl[jm];
jm:=tt[jm];
Until jm=0;
End;
Procedure Dua_ra;
Var i:integer;
Begin
Assign(f1,'ct.out');
Rewrite(f1);
Writeln(f1,max);
For i:=1 to n do
if sl[i]<0 then writeln(f1,i,' ',a[i]);
Write(' OK ');
Close(f1);
End;
Procedure test;
Begin
ClrScr;
Doc;
Chuan_bi;
Day_so;
Danh_dau;
Dua_ra;
Readln;
End;
BEGIN
END.
Đề số 10
Bài 1. Giai thừa
Do N lớn cho nên ta sẽ phải nhân các số rất lớn, vượt quá khả năng lưu trữ của biến đơn. Ta sẽ giải quyết bằng cách lưu kết quả vào một mảng các số nguyên, có nghĩa là ghép kết quả bằng nhiều biến nguyên. Và đương nhiên ta sẽ phải viết lại thủ tục nhân cho số được lưu bởi mảng đó.
Program giaithua;
uses crt;
Var
Result: array[1..32200] of Word;
i,n,leng: Word;
Count: LongInt;
timeStart,timeEnd,time: LongInt;
CurrentTime: LongInt absolute $0000:$046C;
{-------------------------------------------------}
procedure Multiply(count:Word);
var
carry,i: Word; {thu tuc nhan bien Result voi count}
mul: LongInt;
carry:=0; { carry : so nho }
for i:=1 to leng do { xet tung phan tu cua Result }
mul:=LongInt(Result[i])*count+carry;
Result[i]:=mul mod 10000; { Ket qua moi }
carry:=mul div 10000; { so nho moi }
end;
while carry<>0 do
Inc(leng);
Result[leng]:=carry mod 10000;
carry:=carry div 10000;
end;
end;
{-------------------------------------------------}
function Format(Number:Word; Count:Byte):string;
var
s:string;
Str(Number,s); { Chuyen so thanh chuoi }
while Length(s)<Count do s:='0'+s; { Them 0 vao dau chuoi so }
Format:=s;
end;
{-------------------------------------------------}
procedure WriteResult; { Thu tuc viet ket qua }
Writeln;
Write(n,'! = ',Result[leng]);
for i:=leng-1 downto 1 do Write(Format(Result[i],4));
Writeln;
end;
{-------------------------------------------------}
clrscr;
Writeln('Chuong trinh tinh giai thua (n! = 1.2.3...n)');
Write('Cho so n (n <= 31500) : ');
Readln(n);
timeStart:=CurrentTime; { Danh dau thoi diem bat dau }
leng:=1;
Result[1]:=1; { Gan gia tri ban dau la 1 }
for i:=1 to n do Multiply(i); { Tinh giai thua }
timeEnd:=CurrentTime; { Xac dinh thoi diem ket thuc }
WriteResult;
Count:=Length(Format(Result[leng],0))+LongInt(leng-1)*4;
Writeln('So chu so : ',Count);
time:=timeEnd-timeStart; { So nhip dem thoi gian }
Writeln('Thoi gian tinh la : ',time/18.2:0:1,' giay');
readln;
end. {1000! 0,1s 0,2}
{ 5000! 4,2s 8,1
{10000! 18,9s {35,4
30000!201,9s}
Bài 2. Biến đổi xâu
Sử dụng phương pháp qui hoạch động: giả sử độ dài của S1/S2 tương ứng bằng M/N, ta xây dựng mảng A[0..M,0..N] mà A[i,j] bằng số phép biến đổi ít nhất cần dùng để biến đổi đoạn độ dài i của S1 thành đoạn độ dài j của S2. Ta có A[0,j]=j và A[i,0]=i với 0<=i<=M và 0<=j<=N. Việc tính A[i,j] dựa vào công thức đệ quy:
A[i,j]=min(A[i,j-1]+1, A[i-1,j]+1, A[i-1,j-1]+T[i,j])
Với T[i,j]=0/1 tuỳ theo S1[i] bằng hay khác S2[j].
PROGRAM BienDoiXau;
Uses crt;
Const th:set of char=['A'..'Z','a'..'z','0'..'9'];
Type st100=string[100];
Var s1,s2:st100;
n,m:integer;
a:array[0..100,0..100] of integer;
b:boolean;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Procedure Nhap(var s:st100);
Var c:char;
i,u,v,u1,v1:integer;
s:=''; u:=wherex;v:=wherey;
Repeat
c:=readkey;
if (c<>#8) and (c in th) then
s:=s+c;
write(c);
end
else
if (c=#8) and (s<>'') then
u1:=wherex;v1:=wherey;
if (v1>v) and (u1=1) then
gotoxy(80,wherey-1);
write(' '); gotoxy(80,wherey-1);
end
else
gotoxy(wherex-1,wherey);
write(' '); gotoxy(wherex-1,wherey);
end;
delete(s,length(s),1);
end;
Until c=#13;
writeln;
writeln(s);
End;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Procedure thay(k:char;i:integer;var s:st100);
Begin
if s[i]<>k then
s[i]:=k;
writeln('Thay ',i,' ',k);
Writeln(s1);
Write(s2);readln;
end
else b:=true;
End;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Procedure them(k:char;i:integer;var s:st100);
Var j:integer;
st:string;
Begin
st:=k;
Writeln('Them ',i,' ',k);
if i=1 then insert(st,s,i)
else
if i+1<=length(s) then insert(st,s,i+1)
else s:=s+st;
Writeln(s1);
Write(s2);readln;
End;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
procedure xoa(i:integer;var s:st100);
Writeln('Xoa ',i);
delete(s,i,1);
Writeln(s1);
Write(s2);readln;
end;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Function min(a,b,c:integer):integer;
Begin
If a>b then
if b>c then min:=c
else min:=b
else
if a<c then min:=a
else min:=c;
End;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Procedure xuly;
Var i,j:integer;
n:=length(s1); m:=length(s2);
For i:=1 to m do a[0,i]:=i;
For i:=1 to n do a[i,0]:=i;
For i:=1 to n do
for j:=1 to m do
if s1[i]=s2[j] then
a[i,j]:=min(a[i-1,j]+1,a[i,j-1]+1,a[i-1,j-1])
else a[i,j]:=min(a[i-1,j]+1,a[i,j-1]+1,a[i-1,j-1]+1);
End;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Function tim(i,j:integer):byte;
Var t:integer;
Begin
t:=a[i,j];
if t = a[i-1,j]+1 then tim:=1
else
if t=a[i,j-1]+1 then tim:=3
else
if t=a[i-1,j-1]+1 then tim:=2
else
if t=a[i-1,j-1] then tim:=2;
End;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Procedure inkq;
Var i,j,k:integer;
Begin
i:=n; j:=m;
b:=false;
Repeat
case tim(i,j) of
1 : begin xoa(i,s1); dec(i); end;
2 : begin thay(s2[j],i,s1);dec(i); dec(j); end;
3 : begin them(s2[j],i,s1); dec(j); end;
end;
Until (i=0) or (j=0) {or b};
if (i=0) and (j<>0) then
for k:=1 to j do them(s2[k],k,s1);
if (i<>0) and (j=0) then
for k:=i downto 1 do xoa(k,s1);
End;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Procedure test;
Var ch:char;
Begin
ClrScr;
Writeln('Nhap xau 1 : ');
Nhap(s1);
Writeln('Nhap xau 2 : ');
Nhap(s2);
Xuly;
Inkq;
Writeln('Ket qua : ',#7);
Writeln(s1);
Writeln(s2);
{Write(a[n,m]);}
Readln;
End;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++}
BEGIN
END.
Đề số 11
Bài 1. M• đi tuần
Do chỉ phải đưa ra một cách đi cho nên ta sẽ áp dụng thuật toán kinh tế sau: Xuất phát từ một ô, con m• sẽ di chuyển đến ô chưa đến nào mà từ đó có ít khả năng lựa chọn để đi tiếp nhất. Bằng cách đi này con m• sẽ đi được qua tất cả 64 ô bàn cờ 8x8, mỗi ô đúng một lần.
Trong phần chương trình có sử dụng kỹ thuật đặt lính canh để kiểm soát các ô ngoài bàn cờ và kỹ thuật đặt hằng biểu diễn các ô con m• có thể nhảy đến.
PROGRAM Madituan;
Uses crt;
Const n=8;
gx: array[1..8] of integer = (-2,-1, 1, 2, 2, 1,-1,-2);
gy: array[1..8] of integer = ( 1, 2, 2, 1,-1,-2,-2,-1);
out='result.txt';
Var mark:array[-1..10,-1..10] of boolean;
x,y,x0,y0:integer;
f:text;
Procedure Prepare;
var i,j:integer;
Begin
fillchar(mark,sizeof(mark),false);
for i:=-1 to 10 do
mark[-1,i]:=true;
mark[0,i]:=true;
mark[n+1,i]:=true;
mark[n+2,i]:=true;
end;
for i:=-1 to 10 do
mark[i,-1]:=true;
mark[i,0]:=true;
mark[i,n+1]:=true;
mark[i,n+2]:=true;
end;
mark[x0,y0]:=true;
x:=x0; y:=y0;
End;
Function Capab(i,j:integer):integer;
var k,l:integer;
Begin
l:=0;
for k:=1 to 8 do
if not mark[i+gx[k],j+gy[k]] then inc(l);
Capab:=l;
End;
Procedure move;
var i,j,u,v,k,s,tg,h:integer;
Begin
repeat
s:=10;
h:=0;
for k:=1 to 8 do
i:=x+gx[k];
j:=y+gy[k];
if mark[i,j] then
inc(h);
continue;
end;
tg:=Capab(i,j);
if tg<s then
s:=tg;
u:=i;
v:=j;
end;
end;
if h=8 then exit;
x:=u; y:=v;
mark[x,y]:=true;
writeln(f,x,' ',y);
until h=8;
End;
BEGIN
clrscr;
write('Nhap vi tri xuat phat (0<x,y<9): ');
readln(x0,y0);
Prepare;
assign(f,out);
rewrite(f);
writeln(f,x,' ',y);
Move;
close(f);
END.
Bài 2. Sắp xếp
Đối với bài toán này thì ta không thể áp dụng các thuật toán sắp xếp thông thường được vì số lượng phần tử là quá lớn. ở đây ta nhận xét tuổi của dân cư là một số nguyên nằm trong khoảng từ 0 đến 100. Do vậy ta áp dụng thuật toán sắp xếp Pigeonhole như sau:
Chuẩn bị một mảng 101 phần tử từ 0 đến 100 kiểu Longint để lưu trữ số người cùng độ tuổi. Tiến hành đọc lần lượt từ file dữ liệu tuổi của dân cư, gặp độ tuổi nào thì tăng phần tử tương ứng của mảng lên 1. Sau khi đọc hết file dữ liệu ta sẽ được một mảng lưu giữ số lượng người cùng độ tuổi. Công việc cuối cùng bây giờ chỉ là ghi ra file kết quả lần lượt các số theo từng độ tuổi được lưu giữ trong mảng trên.
PROGRAM PigeonHole;
Uses crt;
Const inp='tuoi.inp';
out='tuoi.out';
n=100;
Var age:array[0..n] of longint;
f:text;
Procedure readinp;
var i,k:integer;
Begin
for i:=0 to n do
age[i]:=0;
assign(f,inp);
reset(f);
while not seekeof(f) do
read(f,k);
inc(age[k]);
end;
close(f);
End;
Procedure Writeout;
var i,j:integer;
Begin
assign(f,out);
rewrite(f);
for i:=0 to n do
for j:=1 to age[i] do
write(f,i,' ');
if (j mod 1000 = 0) or (j=age[i]) then writeln(f);
end;
end;
close(f);
End;
BEGIN
readinp;
writeout;
END.
1 2 20 45 4 65 3
2 4 55 2 4 5 100
Đề số 12
Bài 1. Ghép số nguyên tố
Để giải quyết hiệu quả bài toán này ta cần tìm thuật toán kiểm tra một số có thể có nhiều chữ số mà biến đơn không lưu được có phải là số nguyên tố hay không.
Việc xử lý với số lớn ta đ• nhắc đến trong bài toán tính giai thừa, có nghĩa là phải xử lý chuỗi. Còn để kiểm tra nhanh một số có phải là số nguyên tố hay không ta dựa vào nhận xét một số nguyên tố thì chia 6 dư 1 hoặc dư 5. Lưu ý, điều ngược lại là không đúng, cho nên ta kiểm tra thấy số đó chia 6 dư 1 hoặc dư 5 thì lại phải tiếp tục áp dụng các phương pháp kiểm tra số nguyên tố thông thường để làm.
{$N+}
PROGRAM GhepSont;
uses crt;
const
fileout='nt.txt';
maxn=300;
var
n:integer;
f:text;
procedure readf;
write('N=');
readln(n);
end;
function modb(x,y:extended):extended;
modb:=y*frac(x/y);
end;
function prime(x:extended):boolean;
var
j,k:longint;
if (x<=3)or(x=5) then
prime:=true;
exit;
end;
if (modb(x,2)=0)or(modb(x,3)=0)or(modb(x,5)=0) then
prime:=false;
exit;
end;
if x>3 then
prime:=true;
j:=5;k:=2;
while j+k<=sqrt(x) do
j:=j+k;
if modb(x,j) =0 then
prime:=false;
exit;
end;
k:=6-k;
end;
end;
end;
procedure solve;
var
i,bn:longint;
code,count:integer;
k,l,truoc:extended;
s,tg:string;
i:=2;
bn:=2;
count:=1;
repeat
if prime(i) then
if count=1 then
inc(count);
str(i,s);
truoc:=i;
end
else
count:=1;
str(i,tg);
s:=s+tg;
val(s,k,code);
if prime(k) then
dec(n);
writeln(f,k:0:0);
if n=0 then
close(f);
halt(0);
end;
end;
end;
end;
if i<5 then i:=i+1
else
i:=i+bn;
bn:=6-bn;
end;
until false;
end;
procedure result;
assign(f,fileout);
rewrite(f);
end;
BEGIN
clrscr;
readf;
result;
solve;
END.
Bài 2. Xếp việc
Sắp xếp các công việc theo trình tự không tăng của tỷ số T[i]/C[i], đó là trình tự thực hiện tốt nhất.
PROGRAM XepViec;
uses crt;
const
fileinp='xepviec.inp';
fileout='xepviec.out';
maxn=1000;
var
n:integer;
sum,money:longint;
d,p:array[1..maxn]of integer;
index:array[0..maxn]of real;
vt:array[0..maxn]of integer;
time:array[1..maxn]of longint;
procedure readf;
var
f:text;
i:integer;
assign(f,fileinp);
reset(f);
read(f,n);
sum:=0;
for i:=1 to n do
read(f,d[i],p[i]);
inc(sum,p[i]);
end;
close(f);
end;
procedure makeindex;
var
i:integer;
for i:=1 to n do
index[i]:=d[i]/p[i];
vt[i]:=i;
end;
index[0]:=0;
vt[0]:=0;
end;
procedure sort(l,r:integer);
var
i,j,t1:integer;
v,t:real;
if r>l then
v:=index[r];
i:=l-1;
j:=r;
repeat
repeat inc(i); until index[i]>=v;
repeat dec(j); until index[j]<=v;
t:=index[i];index[i]:=index[j];index[j]:=t;
t1:=vt[i];vt[i]:=vt[j];vt[j]:=t1;
until j<i;
index[j]:=index[i];index[i]:=index[r];index[r]:=t;
vt[j]:=vt[i];vt[i]:=vt[r];vt[r]:=t1;
sort(l,i-1);sort(i+1,r);
end;
end;
procedure result;
var
f:text;
i,ti:integer;
assign(f,fileout);
rewrite(f);
money:=0;
ti:=0;
for i:=1 to n do
time[vt[i]]:=ti;
inc(money,ti*p[vt[i]]);
inc(ti,d[vt[i]]);
end;
writeln(f,money);
for i:=1 to n do
writeln(f,time[i]);
close(f);
end;
BEGIN
readf;
makeindex;
sort(1,n);
result;
END.
Đề Số 13
Bài 1. Giao d?ch
Bài này ta chỉ cần sử dụng phương pháp loang một cách khéo léo. Xuất phát từ một đỉnh không có cung vào sẽ là nơi đặt trạm (hoặc nếu không có đỉnh nào như vậy thì lấy một đỉnh bất kỳ), ta loang ra toàn bộ đồ thị, sau đó loại bỏ các đỉnh vừa loang đó đi rồi làm lại như trên ta được số trạm ít nhất cần tìm. 2 câu sau chỉ là hệ quả của câu đầu tiên, xin dành cho bạn đọc tự giải quyết.
PROGRAM GiaoDich;
const tfi = 'GIAODICH.INP';
tfo = 'GIAODICH.OUT';
max = 100;
var a: array[1.. max, 1.. max] of Boolean;
VResult: array[1.. max * max, 1.. 2] of Byte;
Push: array[1.. max] of Integer;
Free, Visit: array[1.. max] of Boolean;
Number, Low: array[1.. max] of Integer;
n, count, countPush, countV: Integer;
f: Text;
procedure Enter;
var u, v: Integer;
FillChar(a, SizeOf(a), 0);
Assign(f, tfi); Reset(f);
Readln(f, n);
while not seekeof(f) do
Readln(f, u, v);
a[u, v]:= true;
end;
Close(f);
end;
procedure InitOne;
FillChar(Free, SizeOf(Free), 1);
count:= 0;
end;
procedure StandartDFS(u: Integer);
var v: Integer;
Free[u]:= false;
for v:= 1 to n do
if Free[v] and a[u, v] then
StandartDFS(v);
end;
procedure DFSOne(u: Integer);
var v: Integer;
Free[u]:= false;
for v:= 1 to n do
if Free[v] and a[u, v] then
DFSOne(v);
Inc(count);
Number[count]:= u;
end;
procedure PrintOne;
var i: Integer;
Writeln(f, countPush);
for i:= 1 to countPush do
Write(f, Push[i], ' ');
Writeln(f);
end;
procedure InitTwo;
FillChar(Free, SizeOf(Free), 1);
countV:= 0;
end;
procedure DFSTwo(u: Integer);
var v: Integer;
Free[u]:= false;
for v:= 1 to n do
if a[u, v] then
if not Free[v] then
Inc(countV);
VResult[countV, 1]:= u; VResult[countV, 2]:= v;
end
else DFSTwo(v);
end;
end;
procedure PrintTwo;
var i: Integer;
Writeln(f, countV);
for i:= 1 to countV do
Writeln(f, VResult[i, 1], ' ', VResult[i, 2]);
end;
procedure PrintThree;
var i: Integer;
Writeln(f, countPush - 1);
for i:= 2 to countPush do
Writeln(f, Push[1], ' ', Push[i]);
end;
procedure Solve;
var i: Integer;
{*****************************************************************}
InitOne;
for i:= 1 to n do
if Free[i] then DFSOne(i);
FillChar(Free, SizeOf(Free), true);
countPush:= 0;
for i:= n downto 1 do
if Free[Number[i]] then
Inc(countPush);
Push[countPush]:= Number[i];
StandartDFS(Number[i]);
end;
PrintOne;
{*****************************************************************}
InitTwo;
for i:= 1 to countPush do
DFSTwo(Push[i]);
PrintTwo;
{*****************************************************************}
PrintThree;
end;
Enter;
Assign(f, tfo); Rewrite(f);
Solve;
Close(f);
end.
Bài 2. Xoá số
Giả sử N=A1A2...Am với Ai là các chữ số thập phân đi từ trái sang phải d•y chữ số A1,A2,...,Am. Tìm chữ số Ai đầu tiên lớn hơn chữ số ngay sau nó, nếu có thì đó là chữ số cần xoá, nếu không thì xoá chữ số cuối cùng.
Chương trình ở đây giải quyết được số rất lớn nhập từ file.
Program FindNumber;
const tfi = 'NUMBER.INP';
tfo = 'NUMBER.OUT';
max = 11;
var Count: array[1.. max] of LongInt;
Number: array[1.. max] of Integer;
value, min: Integer;
n, m, k, pmin, vt: LongInt;
f: Text;
procedure Process;
while k > 0 do
if value < Number[k] then
if m >= count[k] then
m:= m - count[k];
Dec(k);
end
else
count[k]:= count[k] - m;
m:= 0;
Break;
end;
end
else
if Value = Number[k] then
Inc(count[k]);
Exit;
end
else
Inc(k);
Number[k]:= value;
count[k]:= 1;
Exit;
end;
end;
Inc(k);
Number[k]:= value;
Count[k]:= 1;
end;
procedure Enter;
var i: LongInt;
Assign(f, tfi); Reset(f);
Readln(f, n, m);
min:= 10;
for i:= 1 to m + 1 do
Read(f, value);
if (value <> 0) and (value < min) then
min:= value;
pmin:= i;
end;
if min = 1 then Break;
end;
Close(f);
FillChar(count, SizeOf(count), 0);
Assign(f, tfi); Reset(f);
Readln(f, n, m);
m:= m - pmin + 1;
for i:= 1 to pmin do
Read(f, value);
k:= 0;
vt:= n;
for i:= pmin + 1 to n do
Read(f, value);
Process;
if m = 0 then
vt:= i;
Break;
end;
end;
Close(f);
end;
procedure Print;
var i, j: LongInt;
fi: Text;
while m > 0 do
if m >= count[k] then
m:= m - count[k];
Dec(k);
end
else
count[k]:= count[k] - m;
m:= 0;
end;
end;
Assign(f, tfo); Rewrite(f);
Write(f, min, ' ');
for i:= 1 to k do
for j:= 1 to count[i] do
Write(f, Number[i], ' ');
Assign(fi, tfi); Reset(fi);
Readln(fi, n, m);
for i:= 1 to vt do
Read(fi, j);
for i:= vt + 1 to n do
Read(fi, j);
Write(f, j, ' ');
end;
Close(fi);
Close(f);
end;
Enter;
Print;
end.
16 7
2 1 2 3 2 9 5 8 0 2 3 7 5 6 3 2
Đề số 14
Bài 1. Lá bài
Xây dựng một mảng C[1..N] mà C[i] bằng số lá bài có màu i, 1<=i<=N. Nếu C[i] =0, loại lá bài i và giảm C[F[i]] một đơn vị, cứ như vậy cho đến khi mọi C[j] của các lá bài chưa bị loại đều khác 0.
PROGRAM LaBai;
Uses crt;
Const marr=10000;
inp='labai.inp';
out='labai.out';
Type mang=array[1..marr] of integer;
Var f:text;
n:integer;
bac,mau:mang;
{--------------------------------------------------------------}
Procedure Doc;
Var i,c:integer;
Begin
Assign(f,inp);
Reset(f);
Readln(f,n);
for i:=1 to n do begin bac[i]:=0; mau[i]:=0; end;
For i:=1 to n do
read(f,c);
mau[i]:=c;
inc(bac[c]);
inc(bac[i]);
end;
Close(f);
End;
{--------------------------------------------------------------}
Procedure xoadinh;
Var i,j:integer;
Begin
for i:=1 to n do
if bac[i]=1 then
j:=i;
while bac[j]=1 do
dec(bac[j]);
dec(bac[mau[j]]); mau[j]:=-mau[j];
j:=-mau[j];
end;
end;
End;
{--------------------------------------------------------------}
Procedure inkq;
Var i,s:integer;
Begin
Assign(f,out);
Rewrite(f); s:=1;
for i:=1 to n do
if mau[i]>0 then
write(f,i,' '); inc(s);
if s mod 30=0 then writeln(f);
end;
end;
writeln(f); s:=1;
for i:=1 to n do
if mau[i]>0 then
write(f,mau[i],' '); inc(s);
if s mod 30=0 then writeln(f);
end;
end;
Close(f);
End;
{--------------------------------------------------------------}
BEGIN
ClrScr;
Doc;
writeln('Wait !..');
xoadinh;
Inkq;
write('OK .');
{Readln;}
END.
4
3 1 1 2
Bài 2. Lịch gia công tuần tự hai máy
Nhận xét: vì phải làm trên máy A xong mới được làm trên máy B cho nên muốn thời gian nhỏ nhất có thể thì ta phải cho máy A làm liên tục, lúc đó
+ Tchờ
Do vậy Tchờ càng nhỏ càng tốt. Điều đó có nghĩa là máy A hoàn thành chi tiết càng nhanh càng tốt, ngược lại máy B hoàn thành chi tiết càng chậm càng tốt.
Từ đó ta áp dụng thuật toán Johnson như sau:
Chuẩn bị một d•y các ngăn rống (số ngăn bằng số chi tiết). Xếp thời gian hoàn thành các chi tiết đối với cả hai máy vào một bảng. Tìm thời gian nhỏ nhất của bảng. Nếu nó thuộc máy A thì xếp chi tiết vào bên trái nhất của ngăn còn rỗng, còn nếu nó thuộc máy B thì xếp chi tiết vào ngăn bên phải nhất còn rỗng. Sau đó xoá khỏi bảng chi tiết đó đi. Cứ làm như vậy đến khi không còn ngăn rỗng nào. Ta có thứ tự thực hiện các chi tiết từ trái sang phải.
PROGRAM LichGiaCong;
Uses crt;
Const inp='thoigian.txt';
out='lich.out';
marr=1000;
Var n,l,r:integer;
f:text;
ta,tb,sc:array[1..marr] of integer;
marka,markb:array[1..marr] of boolean;
Procedure readinp;
var i:integer;
Begin
assign(f,inp);
reset(f);
readln(f,n);
for i:=1 to n do read(f,ta[i]);
for i:=1 to n do read(f,tb[i]);
close(f);
End;
Procedure schedule;
var i,ja,jb,ma,mb:integer;
a,b:boolean;
for i:=1 to n do marka[i]:=false;
for i:=1 to n do markb[i]:=false;
l:=0; r:=n+1;
repeat
ma:=maxint;
for i:=1 to n do
if not marka[i] then
if ma>ta[i] then
ma:=ta[i];
ja:=i;
end;
mb:=maxint;
for i:=1 to n do
if not markb[i] then
if mb>tb[i] then
mb:=tb[i];
jb:=i;
end;
if ma<=mb then
inc(l);
sc[l]:=ja;
marka[ja]:=true;
markb[ja]:=true;
end
else
dec(r);
sc[r]:=jb;
marka[jb]:=true;
markb[jb]:=true;
end;
until l+1=r;
end;
Procedure writeout;
var i:integer;
Begin
assign(f,out);
rewrite(f);
for i:=1 to n do write(f,sc[i],' ');
close(f);
End;
BEGIN
readinp;
schedule;
writeout;
END.
5
2 5 3 7 3
5 1 5 6 6
Đề Số 15
Bài 1. D•y ngoặc
Kiểm tra tính hợp lệ của d•y ngoặc bằng cách sử dụng hai biến đếm T, V, một biến kiểm tra ngoặc tròn '()', một biến kiểm tra ngoặc vuông '[]'. Quy tắc kiểm tra như sau: duyệt từ đầu đến cuối d•y, nếu:
- gặp dấu ngoặc '(' thì tăng T lên 1
- gặp dấu ngoặc ')' thì giảm T đi 1
- gặp dấu ngoặc '[' thì tăng V lên 1
- gặp dấu ngoặc ']' thì giảm V đi 1
Trong quá trình duyệt nếu T (hoặc V) giảm xuống <0 thêm dấu một ngoặc tròn '(' (hoặc ngoặc vuông '[') ngay trước vị trí đó để T (hoặc V) bằng 0. Nếu T và V đều bằng 0 khi kết thúc quá trình duyệt thì d•y ngoặc là đúng.Trường hợp kết thúc d•y mà T và V vẫn lớn hơn 0 thì thêm đủ số ngoặc ')' và ']' vào cuối d•y để T và V cùng bằng 0.
PROGRAM Bracket;
Uses crt;
Const inp='bracket.inp';
out='bracket.out';
Var s:string[200];
f:text;
t,v:integer;
Procedure readinp;
Begin
assign(f,inp);
reset(f);
readln(f,s);
close(f);
End;
procedure lamnguoc;
var i:integer;
t:=0; v:=0;
i:=length(s);
while i>0 do
case s[i] of
'(': dec(t);
')': inc(t);
'[': dec(v);
']': inc(v);
end;
if t<0 then
insert(')',s,i+1);
t:=0;
end;
if v<0 then
insert(']',s,i+1);
v:=0;
end;
dec(i);
end;
end;
procedure lamxuoi;
var i:integer;
t:=0; v:=0;
i:=1;
while i<=length(s) do
case s[i] of
'(': inc(t);
')': dec(t);
'[': inc(v);
']': dec(v);
end;
if t<0 then
insert('(',s,i);
inc(i);
t:=0;
end;
if v<0 then
insert('[',s,i);
inc(i);
v:=0;
end;
inc(i);
end;
if (t>0) or (v>0) then lamnguoc;
end;
Procedure writeout;
Begin
assign(f,out);
rewrite(f);
write(f,s);
close(f);
End;
BEGIN
readinp;
lamxuoi;
writeout;
END.
((]]()(([[])
Bài 2. Đua ngựa
Ta áp dụng phương pháp của Tôn Tẫn giúp Điền Kỵ thắng vua Tề thời Xuân Thu. Có nghĩa là ta cho con ngựa có hệ số thấp nhất của mình đấu với con ngựa có hệ số cao nhất của vua Tề, rồi lấy con ngựa có hệ số thấp thứ hai đấu với con ngựa có hệ số cao thứ hai của vua Tề, ... cứ làm như vậy ta sẽ có số trận thắng nhiều nhất có thể. Tuy nhiên ở đây ta phải để ý đến trường hợp các con ngựa có cùng hệ số, lúc đó ta sẽ phải xét riêng.
PROGRAM Duangua;
Uses crt;
Const tf='heso.txt';
tf1='lich.txt';
Type bg=record
cs:integer;
gt:integer;
end;
mang= array[0..6000] of bg;
Var f:text;
a,b:mang;
x:array[1..6000] of integer;
n,diem:integer;
kd:boolean;
{-------------------------------------------------------------}
Procedure doc;
Var i:integer;
Begin
Assign(f,tf);
reset(f);
Read(f,n);
For i:=1 to n do
read(f,a[i].gt);
For i:=1 to n do
read(f,b[i].gt);
close(f);
End;
{-------------------------------------------------------------}
Procedure sapxep(var c:mang);
Var i,j:integer;
x:bg;
Begin
For i:=2 to n do
x:=c[i]; c[0].gt:=x.gt; j:=i-1;
while c[j].gt<x.gt do
c[j+1]:=c[j];
dec(j);
end;
c[j+1]:=x;
end;
End;
{-------------------------------------------------------------}
Procedure thubg(i,j:integer);
Var i1,j1:integer;
Bạn đang đọc truyện trên: Truyen2U.Pro