LTpascal Free pascal 32-64
Bài 1: Mã hóa theo khóa:
uses crt;
var s:string[100];
a:array[1..100] of word;
n:integer;
procedure nhap;
var i:integer;
begin
clrscr;
write('So luong phan tu:');readln(n);
writeln('Nhap cac chi so trong khoa:');
for i:=1 to n do
begin
write('a[',i,']=');readln(a[i]);
end;
write('Nhap chuoi:');readln(s);
end;
procedure mahoa(s:string);
var i,j:integer; kq:string[100];
begin
clrscr;
if length(s) mod n <>0 then
for i:=1 to n-(length(s) mod n) do
s:=s+#32;
kq:='';
for i:=0 to (n div length(s)) +1 do
for j:= n*i+1 to n*(i+1) do
kq:=kq+s[a[j-(n*i)]+(n*i)];

write('Chuoi ma hoa theo khoa:',kq);
end;
begin
nhap;mahoa;
readln;
end.
/////////////////////////////////////////
Mã hóa 3:
Uses crt;
Var Khoa, S:string;
procedure mahoa(Khoa,S:string);
var i:byte; k,e:integer;
KQ:string;
Maascii2:integer;
begin
While length(s) mod length(khoa) <>0 do
s:=s+#32;
i:=1; kq:='';
while length(s) >0 do
begin
if (Khoa[i] >= '0') and (Khoa[i] <= '9') then
begin
val(Khoa[i], k, e); (*chuyen doi ki tu so Khoa[i] sang k neu loi sang ma loi e *)
if e <> 0 then
begin
writeln(' Loi chuyen doi thanh so tai vi tri ', i, ' trong khoa.');
exit; end; KQ := KQ + S[k];
end
else

begin writeln('Ky tu khong hop le tai vi tri ', i, ' trong khoa.');
exit;
end;
if i=length(khoa) then
begin
delete(s,1,i);
i:=1;
end
else inc(i);
end;
write( 'Xau ma hoa:' ,KQ) ;
end;
function ConvertToASCIIString(Khoa: string): string;
var i, MaASCII: integer;
ChuoiSoTemp, ChuoiSo: string;
begin
ChuoiSo := '';
for i := 1 to length(Khoa) do
begin
MaASCII := Ord(Khoa[i]);
Str(MaASCII, ChuoiSoTemp);
ChuoiSo := ChuoiSo + ChuoiSoTemp + ',';
end;
ConvertToASCIIString := ChuoiSo;
end;
Begin
Clrscr;
write('Nhap khoa: '); readln(Khoa);
writeln('Khoa truoc khi chuyen doi: ', Khoa);

Khoa := ConvertToASCIIString(Khoa);
writeln('Khoa sau khi chuyen doi: ', Khoa);
Write(' Nhap xau: ');Readln(s);
Mahoa(Khoa,S);
Readln;
End.
/////////////////////////////////////////
uses crt;
function RemoveSpaces(Khoa: string): string; (*Ham loai bo khoang trang trong chuoi*)
var i: integer;
KhoaWithoutSpaces: string;
begin
KhoaWithoutSpaces := '';
for i := 1 to length(Khoa) do
begin
if Khoa[i] <> ' ' then KhoaWithoutSpaces := KhoaWithoutSpaces + Khoa[i];
end;
RemoveSpaces := KhoaWithoutSpaces;
end;
procedure mahoa(Khoa, S: string); var i: byte; k, e: integer; KQ: string; begin while length(S) mod
length(Khoa) <> 0 do S := S + #32; i := 1; KQ := ''; while length(S) > 0 do begin if (Khoa[i] >= '0') and
(Khoa[i] <= '9') then begin val(Khoa[i], k, e); (*chuyen doi ki tu so Khoa[i] sang k neu loi sang ma loi e *) if
e <> 0 then begin writeln('Loi chuyen doi thanh so tai vi tri ', i, ' trong khoa.'); exit; end; KQ := KQ + S[k];
end else begin writeln('Ky tu khong hop le tai vi tri ', i, ' trong khoa: ', Khoa[i]); exit; end; if i =
length(Khoa) then begin delete(S, 1, length(Khoa)); i := 1; end else inc(i); end; write('Xau ma hoa: ', KQ);
end; function ConvertToASCIIString(Khoa: string): string; var i, MaASCII: integer; ChuoiSoTemp, ChuoiSo:
string; begin ChuoiSo := ''; for i := 1 to length(Khoa) do begin MaASCII := Ord(Khoa[i]); Str(MaASCII,
ChuoiSoTemp); ChuoiSo := ChuoiSo + ChuoiSoTemp + ' '; end; ConvertToASCIIString := ChuoiSo; end; var
Khoa, S: string;
begin
clrscr;
write('Nhap khoa: '); readln(Khoa);

Khoa := RemoveSpaces(Khoa); (* Loai bo khoang trang *)
writeln('Khoa truoc khi chuyen doi: ', Khoa);
Khoa := ConvertToASCIIString(Khoa);
writeln('Khoa sau khi chuyen doi: ', Khoa);
write('Nhap xau: ');
readln(S);
mahoa(Khoa, S);
readln;
end.
////////////////////////
uses crt;
function ConvertToASCIIString(Khoa: string): string;
var i, MaASCII: integer;
ChuoiSoTemp, ChuoiSo: string;
begin
ChuoiSo := '';
for i := 1 to length(Khoa) do
begin
MaASCII := Ord(Khoa[i]);
Str(MaASCII, ChuoiSoTemp);
ChuoiSo := ChuoiSo + ChuoiSoTemp + ' ';
end;
ConvertToASCIIString := ChuoiSo;
end;
var Khoa, ChuoiSo: string;
begin clrscr;
write('Nhap khoa: ');
readln(Khoa);
ChuoiSo := ConvertToASCIIString(Khoa);

writeln('Chuoi so tuong ung: ', ChuoiSo);
readln;
end.
/////////////////////////////////
Bài chuyển đổi kí tự sang mã Ascii2
program ConvertToASCII;
uses crt;
var ch: char;
asciiCode: integer;
begin clrscr;
write('Nhap mot ky tu: ');
readln(ch);
asciiCode := ord(ch);
writeln('Ma ASCII cua ky tu ', ch, ' la: ', asciiCode);
readln;
end.
/////////////////////////////
Chuyen ki tu sang ma Ascii và chuyen ma ascii thanh chuoi so:
uses crt;
var Khoa: char;
MaASCII: integer;
ChuoiSo: string;
begin clrscr;
write('Nhap mot ky tu: ');
readln(Khoa);
MaASCII := Ord(Khoa);
Str(MaASCII, ChuoiSo);
writeln('Ma ASCII cua ky tu ', Khoa, ' la: ', MaASCII);
writeln('Chuoi so tuong ung: ', ChuoiSo);

readln;
end.
///////////////////////
Bài: vẽ hình tròn
program CircleDemo;
uses graph;
var gd, gm: integer;
begin gd := DETECT;
initgraph(gd, gm, '');
if graphresult <> grOk then
begin writeln('Graphics error:', grapherrormsg(graphresult)); readln; exit; end;
setcolor(white); circle(200, 200, 100);
readln;
closegraph;
end.
///////////////////////////////
Bài: SẮP XẾP CÁC DÃY SỐ TRONG XÂU
Cho xâu S (không quá 255 ký tự) có lẫn các dãy số (các dãy số này nguyên dương và mỗi dãy số
không quá 10 chữ số) ở các vị trí khác nhau trong S. Hãy viết chương trình sắp xếp các dãy số này theo
thứ tự tăng dần tính từ trái qua mà vị trí các ký tự trong S vẫn giữ nguyên.
Vi dụ: Cho xâu s: abc123dfggsf4563sf34sf56sf
Kết quả: In ra màn hình là: abc34dfggsf56sf123sf4563sf
uses crt;
var s:string;
a:array[1..50]of string[10];
vt:array[1..50]of byte;
n:byte;
procedure chuyen(var s:string);
var i, j, so:byte;

kt:integer;
begin
i:=1;j:=1;
while i<=length(s) do
begin
val(s[i],so,kt);
if kt=0 then
begin
vt[j]:=i;
while (kt=0) and (i<=length(s)) do
begin
a[j]:=a[j]+s[i];
delete(s,i,1);
val(s[i],so,kt);
end;
j:=j+1;
end;
i:=i+1;
end;
n:=j-1;
end;
procedure sapxep;
var i, j: byte; tg: string[10];
so1,so2:longint; kt:integer;
begin
for i:=1 to n-1 do
for j:=i+1 to n do
begin
val(a[i],so1,kt); val(a[j],so2,kt);

if so1>so2 then
begin
tg:=a[i];
a[i]:=a[j];
a[j]:=tg;
end;
end;
end;
procedure chenso(var s:string);
var i:byte;
begin
for i:=n downto 1 do
insert(a[i],s,vt[i]);
end;
begin
clrscr;
write('Nhap xau s=');

readln(s);

chuyen(s);
sapxep;
chenso(s);
writeln('Xau sau khi sap xep:');

writeln(s);

readln;
end.
////////////////////////////////////
Bài 3: SỐ LA MÃ: (Chuyển số thập phân thành số La mã)
a/ Viết chương trình nhập vào số tự nhiên N (0 < N < 4000) từ bàn phím. Viết ra màn hình số N
dưới dạng số La Mã.
•

Ví dụ: Nhập N=25 thì in ra màn hình là XXV.
Nhập N=98 thì in ra màn hình là XCVIII.

Nhập N=2017 thì in ra màn hình là MMXVII
•

Cho biết:

Chữ số La Mã

I

V

X

L

C

D

M

Giá trị

1

5

10

50

100

500

1000

•

Ý tưởng thuật toán:

Ta nhận thấy, ứng với đề cho, ta có bảng dữ liệu tương quan giữa số La Mã và số thập phân như sau:
Chữ số La Mã

M

CM

D

CD

C

XC

L

XL

X

IX

V

IV

I

Giá trị thập phân

1000

900

500

400

100

90

50

40

10

9

5

4

1

•

Như vậy để đơn giản, ta định nghĩa hai mảng. Một mảng LaMa kiểu xâu ký tự có 13 phần tử
chứa ký tự hay cụm ký tự ứng với giá trị từ lớn đến bé. Một mảng So cũng có 13 phần tử chứa
giá trị số thập phân tương ứng với từng phần tử trong mảng Lama.

•

Khi đó, ta tiến hành dò tìm trong mảng So[i] (với i=1..13), nếu tại i mà N≥So[i] thì giảm
N←N-So[i] và KQ←KQ+LaMa[i]. Làm như vậy cho đến khi N←0 thì dừng.

•

Như vậy để đơn giản, ta định nghĩa hai mảng. Một mảng LaMa kiểu xâu ký tự có 13 phần tử
chứa ký tự hay cụm ký tự ứng với giá trị từ lớn đến bé. Một mảng So cũng có 13 phần tử chứa
giá trị số thập phân tương ứng với từng phần tử trong mảng Lama.

•

Khi đó, ta tiến hành dò tìm trong mảng So[i] (với i=1..13), nếu tại i mà N≥So[i] thì giảm
N←N-So[i] và KQ←KQ+LaMa[i]. Làm như vậy cho đến khi N←0 thì dừng.

uses crt;
const lama:array[1..13]of string[2]= ('M','CM','D','CD','C','XC','L','XL','X','IX','V','IV','I');
so:array[1..13]of word=(1000,900,500,400,100,90,50,40,10,9,5,4,1);
var n:word;

procedure xuly(n:word);
var i,t:word;yes:boolean;kq:string[50];
begin
kq:='';
while n>0 do
begin

for i:=1 to 13 do
if n>=so[i] then
begin
t:=i;
break;
end;
n:=n-so[t];
kq:=kq+lama[t];
end;
write(kq);
end;
begin
clrscr;
repeat
write('Nhap so n=');readln(n);
if (n<=0) or (N>=4000) then
writeln('So nhap khong hop le!');
until (n>0) and (n<4000);
write('So ',n,' duoc doi ra so la ma la: ');
xuly(n);
readln;
end.
///////////////////////////////////////////////

Bài 3: SỐ LA MÃ: (Chuyển số La mã thành số thập phân)
b/ Viết chương trình nhập vào xâu La mã S (không quá 20 ký tự) từ bàn phím. Viết ra màn hình
số tự nhiên N có giá trị (0•

Ví dụ: Nhập S= XXV thì in ra màn hình là 25.
Nhập S= XCVIII thì in ra màn hình là 98.

Nhập S= MMXVII thì in ra màn hình là 2017
•

Cho biết:

Chữ số La Mã

I

V

X

L

C

D

M

Giá trị

1

5

10

50

100

500

1000

Ta có qui tắc chuyển đổi như sau:
Số thập phân được cấu thành từ các chữ số đơn lẻ. Ví dụ: 1989 được ghép bởi 1,9,0,8. Còn đối
với cách biểu diễn chữ số la mã thì mỗi chữ số khác 0 ở mỗi hàng (hàng đơn vị, hàng chục, hàng trăm,…)
sẽ được biểu diễn bởi 1 kí tự số la mã. 1000 = M, 900 = CM, 0 không được biểu diễn, 8 = VIII. 1908 =
MCMVIII

Ta có qui tắc chuyển đổi như sau:
- Chữ số đi sau có giá trị nhỏ hơn hoặc bằng giá trị của chữ số đi trước thì cộng thêm vào:
VI = I + V = 1+5 = 6
LX = X + L = 10 + 50 = 60
XX = X + X = 10 + 10 = 20
- Chữ số đi sau có giá trị lớn hơn chữ số có giá trị đi trước thì trừ bớt đi:
IV = V – I = 5 – 1
XL = L – X = 50 – 10 = 40
Ta có qui tắc chuyển đổi như sau:
“I” chỉ có thể bị trừ bởi “V”, “X”. ( IV = V – I = 5 – 1 = 4, IX = X – I = 10 – 1 = 9)
“X” chỉ có thể bị trừ bởi “C”, “L”. ( XC = 100 – 10 = 90, XL = 50 – 10 = 40)
“C” chỉ có thể bị trừ bởi “D” và “M”. (CD = 500 – 100 = 400, CM = 1000)
“V”, “L”, “D”, “M” không bao giờ bị trừ.
Chung qui, xét ví dụ:
MMXVII=1 + 1 + 5+ 10 + 1000 + 1000=2017.
XCVIII=1+1+1+5+100 -10=98
Như vậy, ta dùng mảng số nguyên dương A lưu giữ các giá trị tương ứng với các ký tự la mã ('I', 'V', 'X', 'L',
'C', 'D', 'M' ứng với các giá trị 1, 5, 10, 50, 100, 500, 1000) trong xâu S. Dĩ nhiên, ban đầu toàn bộ các
phần tử trong mảng A đều có giá trị 0. Sau đó duyệt toàn bộ xâu S theo chiều hướng từ phần tử cuối
cùng dần lùi đến phần tử thứ 2 (i←n..2, với n là độ dài xâu S), kiểm tra nếu tại i mà A[i]>A[i-1] thì

KQ←KQ-A[i-1], ngược lại KQ←KQ+A[i-1]. Dĩ nhiên, ban đầu, KQ sẽ có giá trị là giá trị ứng với ký tự la mã
cuối cùng trong xâu s, tức là: KQ←A[n].

uses crt;
const f1 = 'Lama_TP.int'; (* Dinh nghia ten file dau vao *)
f2 = 'Lama_TP.out'; (* Dinh nghia ten file dau ra *)
var A: array[1..50] of integer; (* Khai bao mang A chua cac gia tri so nguyen *)
s: string[50]; (* Khai bao bien chuoi s co do dai toi da 50 ky tu *) fv, fr: text; (* Khai bao hai
bien tep van ban fv va fr *)
procedure khoitao;
begin
assign(fv, f1); (* Gan bien fv voi ten file dau vao *)
{$I-} (* Tat kiem tra I/O tu dong *)
rewrite(fv); (* Tao moi file dau vao *)
if ioresult > 0 then
begin
writeln('Loi xay ra khi mo file'); (* Thong bao loi khi mo file *)
exit; (* Thoat khoi chuong trinh neu co loi *)
end;
writeln('Nhap chuoi ky tu Lama, vidu: M, CM, D, CD, C, XC, L, XL, X, IX, V, IV, I');
readln(s); (* Nhap chuoi ky tu tu ban phim *)
writeln(fv, s); (* Ghi chuoi ky tu vao file dau vao *)
close(fv); (* Dong file dau vao sau khi ghi du lieu *)
{$I+} (* Bat lai kiem tra I/O tu dong *)
assign(fv, f1); (* Gan bien fv voi ten file dau vao f1 *)
{$I-} (* Tat lai kiem tra I/O tu dong de kiem tra loi tiep *)
reset(fv); (* Mo lai file dau vao de doc du lieu *)
if ioresult > 0 then
begin

writeln('Loi xay ra khi mo file de doc du lieu'); (* Thong bao loi khi mo file *)
exit; (* Thoat khoi chuong trinh neu co loi *)
end;
{$I+} (* Bat lai kiem tra I/O tu dong *)
assign(fr, f2); (* Gan bien fr voi ten file dau ra *)
{$I-} (* Tat lai kiem tra I/O tu dong de kiem tra loi tiep *)
rewrite(fr); (* Tao moi file dau ra *)
if ioresult > 0 then
begin
writeln('Loi xay ra khi tao file dau ra'); (* Thong bao loi khi tao file *)
exit; (* Thoat khoi chuong trinh neu co loi *)
end;
{$I+} (* Bat lai kiem tra I/O tu dong *)
end;
function giaTriLaMa(ch: char): integer;
begin
case ch of
'I': giaTriLaMa := 1;
'V': giaTriLaMa := 5;
'X': giaTriLaMa := 10;
'L': giaTriLaMa := 50;
'C': giaTriLaMa := 100;
'D': giaTriLaMa := 500;
'M': giaTriLaMa := 1000;
else giaTriLaMa := 0; (* Truong hop khong hop le *)
end;
end;
function laHopLe(s: string): boolean;

var i: integer;
begin
laHopLe := true;
for i := 1 to length(s) - 1 do
begin
case s[i] of
'I': if not (s[i+1] in ['I', 'V', 'X']) or ((i < length(s) - 1) and (s[i+2] in ['V', 'X','L', 'C', 'D', 'M']))
then laHopLe := false;
'X': if not (s[i+1] in ['I', 'V', 'X', 'L', 'C']) or ((i < length(s) - 1) and (s[i+2] in ['L', 'C', 'D', 'M']))
then laHopLe := false;
'C': if not (s[i+1] in ['I', 'V', 'X', 'L', 'C', 'D', 'M']) or ((i < length(s) - 1) and (s[i+2] in ['D', 'M']))
then laHopLe := false;
'V', 'L', 'D', 'M': if (giaTriLaMa(s[i]) < giaTriLaMa(s[i+1])) then laHopLe := false;
end;
if not laHopLe then break;
end;
end;
procedure docdl;
var i: byte; (* Chi so cua mang *)
dem: integer; (* Bien dem cac ky tu hop le *)
begin
readln(fv, s); (* Doc mot dong tu file dau vao va gan vao chuoi s *)
for i := 1 to length(s) do s[i] := upcase(s[i]); (* Chuyen cac ky tu trong chuoi s thanh chu hoa *)
dem := 0;
for i := 1 to length(s) do
if S[i] in ['I', 'V', 'X', 'L', 'C', 'D', 'M'] then
inc(dem); (* Dem cac ky tu hop le trong chuoi s *)
if (dem <> length(s)) or (not laHopLe(s)) then (* Neu so ky tu hop le khong bang do dai chuoi
hoac khong dung thu tu *)
begin

write('Du lieu vao khong dung!'); (* Thong bao du lieu vao khong dung *)
readln;
close(fv); (* Dong file dau vao *)
close(fr); (* Dong file dau ra *)
exit;
end;
fillchar(a, sizeof(a), 0); (* Xoa du lieu mang A, gan cac phan tu bang 0 *)
for i := 1 to length(s) do
case s[i] of
'I': A[i] := 1;
'V': A[i] := 5;
'X': A[i] := 10;
'L': A[i] := 50;
'C': A[i] := 100;
'D': A[i] := 500;
'M': A[i] := 1000;
end;
end;
procedure xuly(S: string);
var KQ: longint; (* Bien luu ket qua cuoi cung *)
i: byte; (* Chi so cua mang *)
begin KQ := a[length(s)]; (* Khoi tao ket qua bang gia tri phan tu cuoi cung cua mang A *)
for i := length(s) downto 2 do if a[i] > a[i - 1] then
KQ := KQ - a[i - 1] (* Tru gia tri neu ky tu hien tai lon hon ky tu truoc do *)
else
KQ := KQ + a[i - 1]; (* Cong gia tri neu ky tu hien tai nho hon hoac bang ky tu truoc do *)
writeln(fr, KQ); (* Ghi ket qua vao file dau ra *)
end;

procedure inketqua;
var line: string;
begin
reset(fr); (* Mo file ket qua dau ra *)
while not eof(fr) do (* Vong lap doc du lieu cho den khi ket thuc file *)
begin
readln(fr, line); (* Doc mot dong tu file dau ra *)
writeln(line); (* In dong da doc ra man hinh *)
end;
close(fr); (* Dong file dau ra sau khi doc xong *)
end;
begin
khoitao; (* Goi ham khoi tao *)
while not eof(fv) do (* Vong lap doc du lieu cho den khi ket thuc file *)
begin
clrscr;
docdl; (* Doc du lieu *)
xuly(s); (* Xu ly du lieu *)
end;
close(fv); (* Dong file dau vao *)
close(fr); (* Dong file dau ra *)
inketqua; (* Goi ham in ket qua *)
writeln('Nhan Enter de thoat...'); (* Thong bao cho nguoi dung de thoat *)
readln; (* Dung chuong trinh de nguoi dung co the xem ket qua *)
end.
///////////////////////////
procedure catXoaKyTuKhongHopLe(var s: string);
var i, count: integer;

begin
i := 1;
while i <= Length(s) do
begin
count := 1; // Đếm số lần ký tự xuất hiện liên tiếp
while (i + count <= Length(s)) and (s[i] = s[i + count]) do
Inc(count); // Loại bỏ ký tự nếu nó xuất hiện quá nhiều lần liên tiếp
if (count > 3) or not (s[i] in ['I', 'V', 'X', 'L', 'C', 'D', 'M']) or (not laHopLe(s)) then
begin
Delete(s, i, count);
end
else
begin
Inc(i, count);
end;
end;
writeln('Chuỗi sau khi cắt bỏ ký tự không hợp lệ: ', s);
end;
procedure catXoaKyTuKhongHopLe(var s: string);
var i: integer;
begin i := 1;
while i <= Length(s) do
begin
if not (s[i] in ['I', 'V', 'X', 'L', 'C', 'D', 'M']) (*or (not laHopLe(s))*) then
Delete(s, i, 1)
else
Inc(i);
end;

writeln('Chuoi sau khi cat bo ki tu khong hop le', s);
end;
///////////////////////////////////////////////
{{{program CatKyTuKhongHopLe;
uses crt;
var s: string;
function giaTriLaMa(ch: char): integer;
begin
case ch of
'I': giaTriLaMa := 1;
'V': giaTriLaMa := 5;
'X': giaTriLaMa := 10;
'L': giaTriLaMa := 50;
'C': giaTriLaMa := 100;
'D': giaTriLaMa := 500;
'M': giaTriLaMa := 1000;
else giaTriLaMa := 0; (* Truong hop khong hop le *)
end;
end;
function laHopLe(var s: string): boolean;
var i: integer;
begin
i := 1;
while i <= length(s) do
begin
if (giaTriLaMa(s[i]) = 0)
or ((s[i] = 'I') and not (s[i+1] in ['I', 'V', 'X']) and (i < length(s)) and not (s[i+2] in ['V', 'X', 'L', 'C',
'D', 'M']))

or ((s[i] = 'X') and not (s[i+1] in ['I', 'V', 'X', 'L', 'C']) and (i < length(s)) and not (s[i+2] in ['L', 'C',
'D', 'M']))
or ((s[i] = 'C') and not (s[i+1] in ['I', 'V', 'X', 'L', 'C', 'D', 'M']) and (i < length(s)) and not (s[i+2] in
['D', 'M']))
or ((s[i] in ['V', 'L', 'D', 'M']) and (i < length(s)) and (giaTriLaMa(s[i]) < giaTriLaMa(s[i+1])))
then
begin
Delete(s, i, 1);
end
else
begin
Inc(i);
end;
end;
laHopLe := (length(s) > 0);
writeln('s'); readln;
end;
procedure catXoaKyTuKhongHopLe(var s: string);
(*Loai ki tu lap lai hon 3 lan lien tiep*)
Var i, count : byte;
Begin
i:=1;
while i <= Length(s) do
begin
count := 1;
while (i + count <= Length(s)) and (s[i] = s[i + count]) do Inc(count);
if count > 3 then
begin
Delete(s, i + 3, count - 3);

end;
Inc(i, 3); (*Tang i :=i+3*)
end;
writeln('Chuoi sau khi cat bo ki tu khong hop le: ', s);
end;
begin clrscr;
writeln('Nhap chuoi ki tu La Ma');
readln(s);
laHopLe(s);
catXoaKyTuKhongHopLe(s);
readln;
end.}}}}
//////////////////////////////////

cách triển khai thuật toán Fibonacci bằng Pascal:
program Fibonacci;
uses crt;
function Fibonacci(n: integer): longint;
begin
if (n = 0) then Fibonacci := 0
else
if (n = 1) then Fibonacci := 1
else
Fibonacci := Fibonacci(n-1) + Fibonacci(n-2);
end;
var i, num: integer;
begin
clrscr;

writeln('Nhap so luong phan tu Fibonacci can in: ');
readln(num);
writeln('Chuoi Fibonacci:');
for i := 0 to num-1 do write(Fibonacci(i), ' ');
writeln; writeln('Nhan Enter de thoat...');
readln;
end.
//////////////////////////
cách 2 su dung vòng lặp Fibonacci
program Fibonacci;
uses crt;
procedure Fibonacci(n: integer);
var i: integer;
a, b, temp: longint;
begin
a := 0;
b := 1;
writeln('Chuoi Fibonacci:');
if n >= 1 then write(a, ' ');
if n >= 2 then write(b, ' ');
for i := 3 to n do
begin
temp := a + b;
write(temp, ' ');
a := b;
b := temp;
end;
writeln;

end;
var num: integer;
begin
clrscr;
writeln('Nhap so luong phan tu Fibonacci can in: ');
readln(num);
Fibonacci(num);
writeln('Nhan Enter de thoat...');
readln;
end.;
//////////////////////////////
Program Fibonacci;
uses Crt;
Function Fib( n:integer): longint;
Begin
If (n=0) then Fib:=1
else
if (n=1) then Fib:=1
else
fib:=Fib(n-1)+Fib(n-2);
end;
(*---------------*)
Procedure InFib(n:integer);
var i:integer;
Begin
Writeln('In day Fibonacci ',n , ' phan tu la:');
For i:=0 to n-1 do
write(Fib(i), ' ');

Readln;
End;
(*---------------*)
Procedure KiemTrax;
var n:integer; x:longint;
Begin
Writeln('Kiem tra so x co phai la so Fibonacci');
n:=0;
Writeln('Nhap so x='); readln(x);
while x > fib(n) do
inc(n);
If x=Fib(n) then
writeln('x la so fibonacci= ', x)
else
Writeln('x khong phai la so Fibonacci');
readln;
End;
(*---------------*)
Procedure SothutuFibonacciNNLHm;
var m, n:integer;
Begin
Writeln('Tim so thu tu cua so Fibonacci lon hon m');
n:=0;
Writeln('Nhap so m= '); readln(m);
While Fib(n) < m do
inc(n);
Write('Thu tu so Fibonacci nho nhat lon hon ', m, 'la ', n);
readln;

end;
(*---------------*)
Procedure PhantichsoKthanhTongdayFibonacci;
var i,k, n:integer;
Begin
Writeln('Phan tich 1 so thanh tong cua day cac so Fibonacci');
n:=0;
Writeln('Nhap so k= '); readln(k);
While Fib(n) < k do
inc(n);
For i:=0 to n-1 do
write(Fib(i), ' + ');
writeln(k-Fib(n-1));
readln;
End;
(*---------------*)
Procedure InFibonacciKhoangmn;
Var m,n, i: Integer;
Begin
Writeln('Chuong trinh in day so Fibonacci nam giua khoang 2 so m va n:');
i:=0;
write('Nhap 2 so nguyen duong mreadln(m,n);
if mwhile Fib(i)< m do
inc(i);
While Fib(i) < n do
begin

write(Fib(i), ' ');
inc(i);
end;
readln;
end;
(*---------------*)
Procedure FibmaxSNT;
Var m, n, i:longint;
snt:boolean;
Begin
n:=0;
writeln('Chuong trinh tim so nguyen to Fibonacci lon nhat nho hon m: ');
Writeln('Nhap so m= '); readln(m);
while Fib(n) < m do
inc(n);
snt:=False;
while (not snt) and (n> 2) do
For i:=2 to fib(n-1) div 2 do
if Fib(n-1) div i = 0 then
dec(n)
else
snt:=true;
Writeln('So nguyen to Fibonacci lon nhat nho hon', m, 'La :', Fib(n-1));
end;
(*---------------*)
Var n:integer;
Begin
Clrscr;

Kiemtrax;
Clrscr;
SothutuFibonacciNNLHm;
Clrscr;
PhantichsoKthanhTongdayFibonacci;
Clrscr;
InFibonaccikhoangmn;
Clrscr;
FibmaxSNT;
Write('in day Fibonacci n phan tu:');
Write('Nhap so phan tu n='); readln(n);
InFib(n);
readln;
end.
/////////////////////////////////////////////////////////////