Bài tập xâu (3)

1 ) Tạo một dòng chữ chạy từ phải sang trái trong một hình chữ nhật trên màn hình ( để quảng cáo )

2 ) Nhập từ bàn phím xâu kí tự S . Thông báo có bao nhiêu loại kí tự chữ cái ‘a’ ..’z’ , ‘A’..’Z’ chứa trong xâu S và số lượng của mỗi loại .

3 ) Nhập xâu kí tự S ( coi như 1 dòng chữ ) chỉ gồm các loại kí tự chữ cái ‘a’ ..’z’ , ‘A’..’Z’ và chữ số ‘0’..’9’ . Một từ là 1 nhóm các kí tự liên tiếp nhau không chứa kí tự #32 .
a) Hãy thông báo S có bao nhiêu từ .
b) Nhập từ bàn phím 1 từ , thông báo số lần gặp từ này trong xâu S.

4 ) Một xâu kí tự được gọi là đối xứng (Palindrome) nếu nó không thay đổi khi ta đảo ngược thứ tự các kí tự của xâu . Thí dụ ‘able was I ere I saw elba’ . Nhập từ bàn phím một xâu , thông báo nó có phải là xâu Palindrome hay không .


5 ) Cho File ‘Leutrai.txt’ có số dòng không hạn chế , mỗi dòng chỉ gồm các kí tự dấu chấm ‘.’ và chữ số ‘1’. Các chữ số ‘1’ tạo thành các tam giác cân , như hình vẽ bên có 5 “lều trại”
..............1................1.............1
...........1 1 1...........111.............
........1 1 1 1 1.....................1....
........................................1 1 1.
..................1.............................

Hãy thông báo số “lều trại “của file .
( Số 1 đứng riêng lẻ một mình cũng coi như 1 lều )


6 ) Nhập xâu S và số 1<=i <= length(S) . Không dùng thủ tục delete , copy xâu ,hãy chuyển xâu con gồm i kí tự ở đầu xâu S về cuối xâu với số phép chuyển đổi các kí tự càng ít càng tốt .
Thí dụ :
S=‘TRANVANTHANH’ và i=4 --> S=‘VANTHANHTRAN’

Gợi ý : Dùng các tính chất của phép đối xứng : dx(dx(A)+dx(B)) = B + A

7 ) Nhập mảng A các xâu kí tự . Mỗi xâu là họ tên của 1 học sinh trong lớp em .Nhập N là số học sinh của lớp . Tạo mảng B các xâu kí tự , sao cho B[i] được hình thành từ A[i] bằng cách nối tên , sau đó là đệm và cuối cùng là họ của học sinh A[i] . Sắp xếp tăng dần các phần tử của mảng A theo khoá là giá trị phần tử tương ứng của mảng B . Qui ước “Tên” là từ cuối cùng trong họ tên , “Họ” là từ đầu tiên trong họ tên , các từ còn lại là “Đệm” của họ tên .
{Hạn chế : Họ tên không có dấu } .

8 ) Nhập một số nhỏ hơn 1000. Trình bày dòng chữ cho biết giá trị của số đó .
Thí dụ : 605 : Sau tram linh nam
615 : Sau tram muoi lam
625 : Sau tram hai muoi lam

9 ) Dùng xâu kí tự để xây dựng các phép toán : cộng ,trừ với số lớn .

10 ) ( Đề thi chọn đội tuyển quốc gia 1990 - Vòng 2 , bài 5)
Dùng xâu kí tự để xây dựng các phép toán : nhân với số lớn .

11) Dùng xâu kí tự để xây dựng các phép toán : chia nguyên với số lớn .Hạn chế : số chia không quá 9 .

12 ) ( Đề thi Tin học quốc gia 1994 - Bảng A, vòng 1 , bài 1 câu b )
Dãy Fibonaci F1,F2,...Fn được định nghĩa :
F1=F2=1
Fn=Fn-1+Fn-2 ( n >2 )
Nhập xâu kí tự chữ số S ( không quá 200 chữ số ) . Phân tích số đã biểu diễn bằng xâu S thành tổng các số hạng của dãy Fibonaci.

13 ) ( Dựa theo đề thi Tin học quốc tế tại Hy lạp - Ngày 22-5-1991 Bài S-terms )
Một xâu kí tự A được gọi là S_Từ nếu :
+ A chỉ gồm các loại kí tự ‘S ‘, ’(‘ và ’)’
+ Xâu A=‘S’ là một S_Từ
+ Nếu A¬1,A2 là S_Từ thì xâu A=‘(‘+A1+A2+’)’ là S_Từ
Xâu S_Từ được gọi là có độ dài N nếu số kí tự ‘S’ trong nó đúng bằng N
a) Nhập N từ bàn phím ( 1 N  .Hiển thị lên màn hình tổng số các S_Từ có độ dài N .
b) Xây dựng File Text : ‘S_TU.OUT’ chứa toàn bộ các S_Từ có độ dài N ( N đã nhập ở câu a ) . Mỗi dòng chứa 1 S_Từ
Thí dụ : N=4
Kết quả câu a ) : 5
Kết quả câu b) : (S((SS)S))
(S(S(SS)))
(((SS)S)S)
((S(SS))S)
((SS)(SS))

14 ) Lập ma phương bậc chẵn khác n >2 . Thuật toán “Tạo mẫu và phép đối xứng” .

15 ) Xét xâu nhị phân ( chứa các kí tự ‘0’ và ‘1’ ) . Xâu nhị phân S gọi là không lặp bậc L nếu mọi xâu con độ dài L của nó khác nhau từng đôi một . Xâu nhị phân không lặp bậc L được gọi là xâu kết thúc ( bậc L ) , nếu việc bổ sung vào bên phải hoặc bên trái nó kí tự nhị phân {0,1} bất kì sẽ làm mất tính không lặp . Xây dựng thuật toán và viết chương trình để xác định xâu nhị phân không lặp kết thúc bậc L có độ dài ngắn nhất với L cho trước . ( Đề thi chọn đội tuyển Tin học quốc gia 1989 - Vòng 1 , bài 3 . Do điều kiện năm 1989 , đề bài còn cho phép : không nhất thiết thực hiện chương trình trên máy )








Phần bài chữa

Bài 1

Uses Crt;
Const S = 'Truong PTTH Chuyen ban Le Quy Don Ha dong * ';
Var i,L : Integer;
Procedure Khung;
Var i : Integer;
Begin
Gotoxy(16,;Write(#218);
Gotoxy(17,;For i:=17 to 63 do Write('-');
Gotoxy(64,;Write(#191);
Gotoxy(16,12);Write(#192);
Gotoxy(17,12);For i:=17 to 63 do Write('-');
Gotoxy(64,12);Write(#217);
End;
Begin
Clrscr;
L := length(S);
i := 0;
Repeat
Khung;
Inc(i);
S := copy(S,2,L-1)+copy(S,1,1);
Gotoxy(18,10);Clreol;
Write(S);
Delay(100);
Until (i>200) or KeyPressed;
End.

Bài 2 & 3 :

Uses Crt;
Var D : Array['0'..'z'] of Integer;
tong_tu,demtu : Integer;
tunhap : String;
Procedure Doc_Dem;
Const Fi = 'demkitu.txt';
Var F : Text;
S,tu : String;
i,k,t : Byte;
j : Char;
tt : Boolean;
Begin
Demtu := 0;
Write('Nhap tu can dem : ');
Readln(tunhap);
Writeln('File da cho la : ');
FillChar(D,Sizeof(D),0);
Assign(F,Fi);
{$I-} Reset(F); {$I+}
If IoResult<>0 then
Begin
Writeln('Loi File ');
Readln;
Halt;
End;
While not SeekEof(F) do
Begin
Readln(F,S);
Writeln(S);
{ Dem tung ki tu }
For i:=1 to length(S) do
For j:='0' to 'z' do
If (S[i]= j) then Inc(D[j]);
{ Dem tu }
S :=' '+S;
For i:=1 to length(S)-1 do
If (S[i]=' ') and (S[i+1]<>' ') then
Begin
Inc(tong_tu);
{ Dem tu da nhap }
k := i+1;
t := 1;
tt := True;
While (t<=length(Tunhap)) and tt do
If S[k]=Tunhap[t] then
Begin
Inc(k);Inc(t);
End
Else tt := False;
If t>Length(tunhap) then Inc(demtu);
End;
End;
Close(F);
End;
Procedure Hien_so_luong_ki_tu;
Var i : Char;
Begin
For i:='0' to 'z' do
If (i in ['0'..'9']) or (i in ['A'..'Z']) or (i in ['a'..'z']) then
If (D[i]>0) then Write(i:2,' :',D[i]:2,' ');
End;
BEGIN
Clrscr;
Doc_Dem;
Writeln('Ket qua ');
Hien_so_luong_ki_tu;
Writeln;
Writeln('Tong so tu la : ',tong_tu);
Writeln('So tu " ',tunhap,'" trong File la : ',demtu);
Readln;
END.

Bài 4 :
Uses Crt;
Var S : String;
i,L,N : Integer;
TT : Boolean;
Begin
Clrscr;
Writeln('Nhap mot xau ki tu ');
Readln(S);
i:=1 ;
TT := True;
L := Length(S) ;
N := L div 2;
While TT and (i<=N) do
Begin
If S[i]=S[L-i+1] then Inc(i)
Else TT := False;
End;
If i>N then Writeln('Xau ',S,' la doi xung ')
Else Writeln('Xau ',S,' khong doi xung ');
Readln;
END.

Bài 5 :
Uses Crt;
Const Fi = 'DemLeu.txt';
Var F : Text;
A,B : String;
i,Leu : Integer;
BEGIN
Clrscr;
A:='';
For i:=1 to 80 do A:=A+ '.';
Assign(F,Fi);
Reset(F);
Leu:=0;
While not seekeof(F) do
Begin
Readln(F,B);
Writeln(B);
B:='.' + B + '.';
For i:=2 to length(B)-1 do
If (B[i-1]= '.') and (B[i+1]='.') and( B[i]='1')
and(A[i]='.') then Inc(Leu);
A:=B;
End;
Close(F);
Writeln('so Leu la : ', Leu);
Readln
END.

Bài 6 :
{ có thể dễ dàng giải bài này nếu dùng một số hàm và thủ tục chuẩn để xử lý String . Cụ thể chỉ cần vài lệnh sau :
phu := copy(S,1,i);
Delete(S,1,i);
S := S + phu

Nhưng khi xử lý mảng : chuyển i phần tử đầu của mảng về cuối mảng thì phải thực hiện chuyển dần từng phần tử của mảng , nếu không có thuật toán tốt thì phải thực hiện quá nhiều phép toán đơn vị . Dưới đây giới thiệu một phương pháp tốt giải quyết bài toán này , dựa vào tính chất của phép đối xứng mảng }

Uses Crt;
Var S : String;
i,n : Byte;
Procedure DX(i,j : Byte);
Var L,r : Byte;
coc : Char;
Begin
L := i;
R := j;
While L<R do
Begin
coc := S[L];
S[L] := S[R];
S[R] := coc;
Inc(L);
Dec(R);
End;
End;
Procedure Chuyen;
Begin
DX(1,i);
DX(i+1,n);
DX(1,n);
End;
Procedure Nhap;
Begin
Write('Nhap xau S = ');
Readln(S);
N := Length(S);
Write('Nhap so phan tu can chuyen tu dau trai sang phai, i= ');
Readln(i);
End;
Procedure Hien;
Begin
Writeln('Xau S sau khi chuyen ',i,' phan tu dau trai ve dau phai ');
Writeln(S);
End;
BEGIN
Clrscr;
Nhap;
Chuyen;
Hien;
Readln;
END.

Bài 7 :

Uses Crt;
Const Max = 50;
Type Str48 = String[48];
Str7 = String[7];
Mang= Array[1..Max] of Str48;
m2 = Array[1..6] of Str7;
Var A,B : Mang;
C : M2;
ss : Integer;
Procedure Nhap;
Const Fi = 'Lop.txt';
Var F : Text;
i : Integer;
Begin
Assign(F,Fi);
Reset(F);
i := 0;
While not SeekEof(F) do
Begin
Inc(i);
Readln(F,A[i]);
End;
SS := i;
Close(F);
End;

Procedure Sach(Var S : Str48);
Begin
While (S<>'') and (S[1]=' ') do Delete(S,1,1);
While (S<>'') and (S[Length(S)]=' ') do Delete(S,Length(S),1);
End;
Procedure Nan(Var S : Str48);
Var i : Integer;
Begin
Sach(S);
S := ' '+S;
For i:=1 to length(S)-1 do
If (S[i]=' ') and (S[i+1]<>' ') then S[i+1] := Upcase(S[i+1]);
Sach(S);
End;
Function PosP(S : Str48) : Integer;
Var i : Integer;
TT : Boolean;
Begin
i:=length(S);
TT := True;
While (i>= 1) and TT do
If S[i]<>' ' then Dec(i) Else TT := False;
If i>=1 then PosP := i-1;
End;
Procedure BoXung(Var S : Str7);
Begin
While (S<>'') and (S[1]=' ') do Delete(S,1,1);
While (S<>'') and (S[Length(S)]=' ') do Delete(S,Length(S),1);
While length(S)<=6 do S := S+' ';
End;
Procedure TaoB;
Var i,pt,pp,L,j : Integer;
phu : Str48;
Begin
For i:=1 to ss do
Begin
Nan(A[i]);
L := Length(A[i]);
pp := PosP(A[i]);
C[6] := Copy(A[i],PP+1,L-pp); { C[6] là Tên }
Boxung(C[6]);
phu := Copy(A[i],1,pp);
For j:=1 to 5 do
Begin
Sach(phu);
phu := phu+' ';
pt := Pos(' ',phu);
C[j] := Copy(phu,1,pt);
Boxung(C[j]);
phu := Copy(phu,pt+1,L);
End;
B[i] := C[6];
For j:=5 downto 1 do B[i] := B[i]+C[j];
Writeln(B[i]);
End;
End;
Procedure Sap;
Var i,j : Integer;
p : Str48;
Begin
Writeln('*** Danh sach da sap tang : ');
For i:=1 to SS-1 do
For j := i+1 to SS do
Begin
If B[i]>B[j] then
Begin
p := B[i];
B[i] := B[j];
B[j] := p;
p := A[i];
A[i] := A[j];
A[j] := p;
End;
End;
End;
Procedure Hien;
Var i : Integer;
Begin
For i:=1 to ss do
Begin
Writeln(A[i]);
If i mod 24 =0 then Readln
End;
End;
BEGIN
Clrscr;
Nhap;
TaoB;
Sap;
Hien;
Readln;
END.

Bài 8 :
Uses Crt;
Type Str4 = String[4];
Var S : Array [1..9] of Str4;
x : 0..999;
kq : String;
Procedure Nhap;
Begin
Repeat
Clrscr;
Write('Nhap vao so duong nguyen <1000 ');
{$I-} Readln(x);{$I+}
Until (IoResult=0) and (x>0) and (x<1000);
S[1] := 'MOT '; S[2] := 'HAI '; S[3] := 'BA ';
S[4] := 'BON '; S[5] := 'NAM '; S[6] := 'SAU ';
S[7] := 'BAY '; S[8] := 'TAM '; S[9] := 'CHIN';
End;
Procedure Chuyen;
Var dv,ch,tr : Byte;
Begin
dv := x mod 10;
ch := (x div 10) mod 10;
tr := x div 100;
kq := '';
If tr>0 then Kq := Kq+S[tr]+' trăm';
If (ch=0) and (dv>0) then
If (tr=0) then kq := kq+S[dv]
Else Kq := Kq+' LINH '+S[dv];
If ch=1 then Kq := Kq+' mười ';
If ch>1 then Kq := Kq+S[ch]+' mươi ';
If (ch>0) and (dv<>5) and (dv>0) then kq := kq+ s[dv];
If (ch>0) and (dv=5) then kq := kq+' lăm ';
Writeln(kq);
End;
BEGIN
Nhap;
Chuyen;
Readln;
END.

Bài 9 :

{Chu y nhap tu ban phim xau chi co the dai toi 127 }
Uses Crt;

Var A,B,C : String;
L : Integer;
Ch : Char;
Procedure Nhap;
Var i : Integer;
Begin
Writeln('Nhap so thu nhat : ');Readln(A);
Writeln('Nhap so thu hai : ');Readln(B);
End;
Procedure Sua;
Var i: Integer;
Begin
L := Length(A);
If L<Length(B) then L:= Length(B);
While Length(A) < L do A := '0'+A;
While Length(B) < L do B := '0'+B;
C := ''; For i := 1 to L do C := '0'+C;
End;
Procedure Cong(A,B : String;Var C : String);
Var nho,phu,i : Integer;
Begin
Nho := 0;
For i:= L downto 1 do
Begin
phu := Ord(A[i])+Ord(B[i])-96+ nho;
C[i] := Char((phu mod 10)+48);
nho := phu div 10;
End;
If nho>0 then C :='1'+C;
End;
Procedure Tru(A,B : String; Var C : String);
Var nho,phu,i : Integer;
Begin
Nho := 0;
For i:= L downto 1 do
Begin
phu := Ord(A[i])-( Ord(B[i])+nho );
nho := Ord(phu<0);
If nho=1 then Inc(phu,10);
C[i] := Char((phu mod 10) + 48);
End;
End;
Procedure Hien;
Begin
Writeln(' '+A);
Writeln(' '+B);
If Length(C)>L then Writeln(C) Else Writeln(' '+C);
End;
Procedure LamCong;
Begin
Cong(A,B,C);
Hien;
End;
Procedure LamTru;
Begin
If A>=B then Tru(A,B,C) Else
Begin
Tru(B,A,C);
C := ‘-’+C;
End;
Hien;
End;
BEGIN
Clrscr;
Nhap;
Sua;
Writeln('Cong hay tru (C/T) ');
Readln(ch);
If Upcase(ch)='C' then LamCong;
If Upcase(ch)='T' then LamTru;
Readln;
END.

Bài 10 :
Uses Crt;
Var A,B,C : String;
L,LA,LB : Integer;
TT : Boolean;
Procedure Nhap;
Begin
Writeln('Nhap so thu nhat : ');Readln(A);
Writeln('Nhap so thu hai : ');Readln(B);
LA := Length(A);
LB := Length(B);
L := LA+LB;
While (Length(A) < L) do A := '0'+A;
While (Length(B) < L) do B := '0'+B;
End;
Procedure Cong(A,B : String;Var C : String);
Var LL,nho,phu,i : Integer;
Begin
C := '';
For i := 1 to L do C := '0'+C;
Nho := 0;
For i:= L downto 1 do
Begin
phu := Ord(A[i])-96+ Ord(B[i]) + nho;
C[i] := Char((phu mod 10) + 48);
nho := phu div 10;
End;
End;
Procedure Nhan;
Var nho,phu,k : Integer;
D : String;
Procedure Nhan1(k : Integer;A,B : String;Var D : String);
Var nho,phu,i : Integer;
Begin
Nho := 0;
D := '';
For i:=1 to L do D :='0'+D;
For i := L downto L-LA+1 do
Begin
Phu := (Ord(A[i])-48)*(Ord(B[k])-48) + nho;
nho := phu div 10;
D[k-(L-i)] := Char((phu mod 10) + 48);
End;
End;
Begin
Nho := 0;
C := '';
For k := 1 to L do C := '0'+C;
For k := L downto L-LB+1 do
Begin
Nhan1(k,A,B,D);
Cong(C,D,C);
End;
End;
Procedure Hien;
Var i : Integer;
Begin
i := 1;
While A[i]='0' do Begin A[i]:=' ';Inc(i);End;
Writeln(A);
i := 1;
While B[i]='0' do Begin B[i]:=' ';Inc(i);End;
Writeln(B);
i := 1;
While C[i]='0' do Begin C[i]:=' ';Inc(i);End;
Writeln(C);
End;
BEGIN
Clrscr;
Nhap;
Nhan;
Hien;
Readln;
END.

Bài 11:
Uses crt;
Var Bichia,Thuong : string;
i,sochia,nho : Byte;
Procedure Nhap;
Var x,y : Integer;
ch:char;
Begin
clrscr;
Bichia:='';
Write(' Cho so bi chia ');
Repeat
ch:=Readkey;
If ch in ['0'..'9'] then
Begin
Bichia := Bichia+ch ;
Write(ch);
End
Until (ch=#13) ;
Writeln;
Write(' Nhap so chia <10 la : ');
x := Wherex;
y := Wherey;
Repeat
{$I-}Gotoxy(x,y); ClrEol;Readln(sochia); {$I+}
Until (Ioresult=0) and (sochia<10) and (sochia>0);
Writeln;
End;
Procedure Divtay;
Var i,phu : Byte;
Begin
Nho:=0; Thuong:='';
For i:=1 to Length(bichia) do
Begin
Phu := Ord(Bichia[i])-48+ Nho*10;
Thuong := Thuong+Chr((Phu div Sochia)+48);
Nho := Phu mod Sochia;
If Thuong[1]='0' then Delete(Thuong,1,1);
End;
End;
Procedure Hien;
Begin
Clrscr;
Writeln(Bichia,' Chia cho ',Sochia);
Writeln(Bichia,' MOD ',Sochia,' = ',Nho);
While (Thuong<>'') and (Thuong[1]='0') do Delete(Thuong,1,1);
If Thuong='' then Thuong := '0';
Writeln(Bichia,' DIV ',sochia,' = ',Thuong);
Gotoxy(20,23);Write(' ESC ---> THOAT ');
End;
BEGIN
Repeat
Nhap;
Divtay;
Hien;
Until Readkey=#27;
END.

Bài 12:
Uses Crt;
Var F1,F2,S : String;
Procedure Nhap;
Var Ch : Char;
Begin
S := '';
Writeln('Nhap so nguyen duong (toi da 200 chu so ) S = ');
Repeat
Ch := ReadKey;
If Pos(Ch,'0123456789')>0 then
Begin
S := S + ch;
Write(ch);
End;
Until ch = #13;
Writeln;
F1 := '1';
F2 := '1';
End;
Procedure Sap(Var X,Y : String);
Var L : Integer;
Begin
L := Length(X);
If Length(Y)>L then L := Length(Y);
While Length(X)<L do X := '0'+X;
While Length(Y)<L do Y := '0'+Y;
End;
Function Cong(X,Y : String) : String;
Var nho,phu,i : Integer;
C : String;
Begin
C := '';
nho := 0;
Sap(X,Y);
For i := Length(X) downto 1 do
Begin
phu := Ord(X[i])+Ord(Y[i])-96+nho;
nho := phu div 10;
C := Char((phu mod 10) + 48)+C;
End;
If nho=1 then C := '1'+C;
Cong := C;
End;
Function Tru(X,Y : String) : String;
Var nho,phu,i : Integer;
C : String;
Begin
C := '';
nho := 0;
Sap(X,Y);
For i := Length(X) downto 1 do
Begin
phu := Ord(X[i])-Ord(Y[i])-nho;
nho := Ord(phu<0);
If nho = 1 then Inc(phu,10);
C := Char((phu mod 10) + 48)+C;
End;
Tru := C;
End;
Procedure Timthuan(S : String; Var F1,F2 : String) ;
Var F3 : String;
Begin
Repeat
F3 := Cong(F1,F2);
F1 := F2;
F2 := F3;
Sap(F2,S);
Until F2>S;
End;
Procedure TimNguoc(Var S,F1,F2 : String) ;
Var F0 : String;
Begin
Repeat
F0 := Tru(F2,F1);
F2 := F1;
F1 := F0;
Sap(F0,S);
Until F0<=S;
End;
Procedure XuLy;
Begin
Writeln(S,' = ');
TimThuan(S,F1,F2);
Repeat
While (Length(F1)>1) and (F1[1]='0') do Delete(F1,1,1);
Writeln(F1,' ');
S := Tru(S,F1);
While (Length(S)>1) and (S[1]='0') do Delete(S,1,1);
If S>'0' then Timnguoc(S,F1,F2);
Until S = '0';
End;
BEGIN
Clrscr;
Nhap;
XuLy;
Readln
END.

Bài 13 :
Uses Crt;
Const Max = 13;
Output = 'S_tu.out';
Nhap = 'T.txt';
Type PT = String[3*Max-2];
Var N : Byte;
Tro : Array[0..Max] of Longint;
F2 : Text;
F : File of PT;
Procedure Lam;
Var i,j : Byte;
p1,p2,k : Longint;
ST,s1,s2 : PT;
Procedure Doc(p1,p2:Longint;var s1,s2:Pt);
Begin
Seek(F,p1);
Read(F,s1);
Seek(F,p2);
Read(F,s2);
End;
Procedure Ghi(p:Longint;var s:Pt);
Begin
Seek(F,p);
Write(F,s);
End;
Begin
Tro[0]:=0;
Tro[1]:=1;
ST:='S';
Seek(F,1);
Write(F,ST);
k:=1;
For i:=2 to N do { Lan luot xay dung cac S_tu gom i ki tu S }
Begin
For j:=1 to i div 2 do{ Chon cac S_tu co j ki tu S ( j <= i div 2 ) }
If j=i-j then
Begin {p1 cho Tim S_tu co j ki tu S }
For p1:=Tro[j-1]+1 to Tro[j] do
{ Chi can xet p2 trong doan S_tu co j ki tu S va p2 o doan tren p1 }
{ de tao S_tu tu cac S_tu S1 va S2 ma S1<>S2 }
For p2:=p1+1 to Tro[j] do
Begin
Inc(k);
Doc(p1,p2,s1,s2);
ST:='('+S1+S2+')';
Ghi(k,ST);
Inc(k);
ST:='('+S2+S1+')';
Ghi(k,ST);
End;
{ Tao S_tu tu cac S_tu S1 va S2 ma S1=S2}
For p1:=Tro[j-1]+1 to Tro[j] do
Begin
Inc(k);
Doc(p1,p1,s1,s2);
ST:='('+S1+S2+')';
Ghi(k,ST);
End;
End
Else { p1 vi tri S_tu co j ki tu S }
{ p2 vi tri S-tu co i-j ki tu S }
For p1:=tro[j-1]+1 to tro[j] do
For p2:=tro[i-j-1]+1 to tro[i-j] do
Begin
Inc(k);
Doc(p1,p2,s1,s2);
ST:='('+S1+S2+')';
Ghi(k,ST);
Inc(k);
ST:='('+S2+S1+')';
Ghi(k,ST);
End;
Tro[i]:=k;
End;
{ Ghi cac S_tu co N ki tu S vao File }
For k:=Tro[N-1]+1 to Tro[N] do
Begin
Seek(F,k);
Read(F,ST);
Writeln(F2,ST);
End;
Writeln(F2,'Tong So = ',Tro[N]-tro[N-1]);
Writeln('Tong So = ',Tro[N]-tro[N-1]);
End;
BEGIN
Clrscr;
Write('Nhap N = ');
Readln(N);
Assign(F2,output);
Rewrite(F2);
Assign(F,nhap);
Rewrite(F);
Lam;
Erase(F);
Close(F);
Close(F2);
END.

Bài 14 :
Uses Crt;
Const Max = 18;
Var n,k : Byte;
S : String;
M : Array[1..Max,1..Max] of Integer;
Procedure Init;
Var i,j : Byte;
Begin
Repeat
Write('Nhap cap cua ma phuong chan (n<=18; n<>2) : ');
Readln(n);
Until (Ioresult=0) and (not odd(n)) and (n<>2) and(n<=18);
For i:=1 to n do
For j:=1 to n do M[i,j] := (i-1)*n+j;
k := n div 2;
End;
Procedure Hien;
Var i,j : Byte;
Begin
For i:=1 to n do
Begin
For j:=1 to n do Write(M[i,j]:4);
Writeln;
End;
Writeln;
End;
Procedure Taomau;
Var i : Byte;
Begin
For i:=1 to k div 2 do S := S+'T';
If odd(k) then { k le } S := S+'DN';
While length(S)<k do S := S+'B';
End;
Procedure Tam(i,j : Byte);
Var coc : Integer;
Begin
coc := M[i,j];
M[i,j] := M[n-i+1,n-j+1];
M[n-i+1,n-j+1] := Coc;
coc := M[n-i+1];
M[n-i+1,j] := M[i,n-j+1];
M[i,n-j+1] := coc;
End;
Procedure Doc(i,j : Byte);
Var coc : Integer;
Begin
coc := M[i,j];
M[i,j] := M[i,n-j+1];
M[i,n-j+1] := coc;
End;
Procedure Ngang(i,j : Byte);
Var coc : Integer;
Begin
coc := M[i,j];
M[i,j] := M[n+1-i,j];
M[n+1-i,j] := Coc;
End;
Procedure Xuly(i : Byte);
Var j : Byte;
Begin
For j:=1 to k do
Case S[j] of
'T' : Tam(i,j);
'D' : Doc(i,j);
'N' : Ngang(i,j);
End;
End;
Procedure QuayS;
Begin
S := S[length(S)]+copy(S,1,length(S)-1);
End;
Procedure Work;
Var i : Byte;
Begin
For i:=1 to k do
Begin
Xuly(i);
QuayS;
End;
End;
Function Test : Boolean;
Var i,j : Byte;
Tong,phu : Integer;
Ok : Boolean;
Begin
Tong := (n*n+1)*(n div 2);
Ok := True;
i := 1;
While (i<=n) and Ok do
Begin
Phu := 0;
For j:=1 to n do phu := phu + M[i,j];
Writeln('Dong ',i,' = ',phu,' ');
If phu <> tong then ok := False Else Inc(i);
End;
Ok := True;
j := 1;
While (j<=n) and Ok do
Begin
Phu := 0;
For i:=1 to n do phu := phu + M[i,j];
Writeln('Cot ',j,' = ',phu,' ');
If phu <> tong then Ok := False Else Inc(j);
End;
Ok := True;
phu := 0;
For i:=1 to n do phu := phu+M[i,i];
Writeln('Duong cheo chinh = ',phu,' ');
If phu <> tong then Ok := False;
Ok := True;
phu := 0;
For i:=1 to n do phu := phu+M[i,n-i+1];
Writeln('Duong cheo phu = ',phu,' ');
If phu <> tong then Ok := False;
Test := Ok;
End;
BEGIN
Clrscr;
Init;
Hien;
Taomau;
Work;
Hien;
If test then Writeln('Dung la ma phuong ')
Else writeln('Khong la ma phuong ');
Readln;
END.

Bài 15
Uses Crt;
Const max = 255;
Var L : byte;
S : string;
Procedure Nhap;
Begin
Repeat
Gotoxy(10,;
Write(' Bac cua xau nhi phan khong lap : ');
{$i-} Readln(L); {$i+}
Until (ioresult=0) and (L>=1);
End;
Procedure Tao_xau;
Var Ok : Boolean;
Function Kt1(st:string) : Boolean;
Var i,j : Byte;
Begin
Kt1:= true;
If length(st) >=L then
For i := 1 to Length(st)-L do
For j := i+1 to Length(st)-L+1 do
If copy(st,i,L) = copy(st,j,L) then
Begin
Kt1 := false;
Exit;
End;
End;
Function Kt2:Boolean;
Begin
Kt2:=false;
If not Kt1('0'+S) and not Kt1('1'+S) and not Kt1(S+'1')
and not Kt1(S+'0') then Kt2:=true;
End;
Procedure Tim(Var s : string);
Var i,k : Byte;
S1 : String;
Ok1 : Boolean;
Begin
k := 1;
S1 := '';
Repeat
Ok1 := kt1(S+'0');
If not OK1 then S := S+'1' Else S := S +'0';
Until Kt2;
Clrscr;
Gotoxy(10,12);
Write('Xau nhi phan khong lap co bac ',L,' ngan nhat : ');
Gotoxy(10,13); Write(s);
Ok := False;
End;
Begin
S := '';
Ok := true;
Tim(s);
End;

BEGIN
Repeat
Clrscr;
Nhap;
Tao_xau;
Gotoxy(10,20);
Write(' ESC to quit');
Until Readkey=#27;
END.