program BTVN(komenu);
uses crt;
var st,x:string;
i,n:integer;
procedure chuhoa(st:string);
var s:string;
i:integer;
begin
s:=st;
for i:=1 to length(s) do
s[i]:=upcase(s[i]);
writeln(s);
end;
procedure chuthuong(st:string);
var s:string;
i:integer;
begin
s:=st;
for i:=1 to length(s) do
if s[i] in ['A'..'Z'] then
s[i]:=chr(ord(s[i])+32);
writeln(s);
end;
procedure xaudx(st:string);
var s,x:string;
i:integer;
begin
s:=st;
x:=' ';
for i:=length(s) downto 1 do
x:=x+s[i];
delete(x,1,1);
if x=s then writeln('Xau ',s,' la xau doi xung')
else writeln('Xau ',s,' ko doi xung ');
end;
procedure xoatrang(st:string);
var s:string;
i:integer;
begin
s:=st;
while s[1]=' ' do delete(s,1,1);
while s[length(s)]=' ' do delete(s,length(s),1);
while pos(' ',s)<>0 do delete(s,pos(' ',s),1);
writeln(s);
end;
procedure xoadup(st:string);
var s:string;
i:integer;
begin s:=st;i:=1;
while i<length(s) do
if pos(s[i]+s[i],s)<>0 then
delete(s,pos(s[i]+s[i],s),1) else i:=i+1;
writeln(s);
end;
function thuoc(s:string; k:integer; ch:char):boolean;
var i,d:integer;
begin d:=0;
for i:=1 to k do if ch=s[i] then d:=d+i;
if d=0 then thuoc:=false
else thuoc:=true;
end;
procedure chucai(st:string);
var s:string;
i,d,j,k:integer;
begin d:=0;s:=st;
for i:=1 to length(s) do
if upcase(s[i]) in ['A'..'Z'] then
if thuoc(s,i-1,s[i])=false then
begin k:=0;
for j:=1 to length(s) do
if s[j]=s[i] then k:=k+1;
writeln(' ki tu ',s[i],' xuat hien ',k,' lan');
end;
end;
procedure chuso(st:string);
var s:string;
i,d,j,k:integer;
begin d:=0;s:=st;
for i:=1 to length(s) do
if s[i] in ['1'..'9'] then
if thuoc(s,i-1,s[i])=false then
begin k:=0;
for j:=1 to length(s) do
if s[j]=s[i] then k:=k+1;
writeln(' chu so ',s[i],' xuat hien ',k,' lan');
end;
end;
procedure demtu(st:string);
var s:string;
i,d:integer;
begin d:=0;
s:=st;
while s[1]=#32 do delete(s,1,1);
while s[length(s)]= #32 do delete(s,length(s),1);
while pos(#32#32,s)<>0 do delete(s,pos(#32#32,s),1);
s:=s+#32;
writeln('Trong xau co cac tu la:');
while pos(#32,s)<>0 do
begin
writeln(copy(s,1,pos(#32,s)));
delete(s,1,pos(#32,s));d:=d+1;
end;
writeln('tong cong la ',d,' tu');
end;
procedure kitu(st:string);
var s:string; c:char;
i,d:integer;
begin d:=0; s:=st;
write('Nhap ki tu: ');readln(c);
for i:=1 to length(s) do
if c=s[i] then d:=d+1;
if d= 0 then writeln(c,' ko xuat hien trong ',s)
else writeln(c,' xuat hien ',d,' lan trong ',s);
end;
BEGIN
clrscr;
write('Nhap xau: ');readln(st);
write('Xau chu hoa la:');chuhoa(st);
write('Xau chu thuong la:');chuthuong(st);
xaudx(st);
write('Xau sau khi xoa trang la:');xoatrang(st);
write('Xau sau khi xoa dup la:');xoadup(st);
write('Cac chu cai:');chucai(st);
write('Cac chu so:'); chuso(st);
demtu(st);
kitu(st);
readln;
END.
program BTVN;
uses crt;
var st,x:string;
i,n:integer;
procedure chuhoa(st:string);
var s:string;
i:integer;
begin
s:=st;
for i:=1 to length(s) do
s[i]:=upcase(s[i]);
writeln('Xau dang chu hoa la:',s);
end;
procedure chuthuong(st:string);
var s:string;
i:integer;
begin
s:=st;
for i:=1 to length(s) do
if s[i] in ['A'..'Z'] then
s[i]:=chr(ord(s[i])+32);
writeln('Xau dang chu thuong la:',s);
end;
procedure xaudx(st:string);
var s,x:string;
i:integer;
begin
s:=st;
x:=' ';
for i:=length(s) downto 1 do
x:=x+s[i];
delete(x,1,1);
if x=s then writeln('Xau ',s,' la xau doi xung')
else writeln('Xau ',s,' ko doi xung ');
end;
procedure xoatrang(st:string);
var s:string;
i:integer;
begin
s:=st;
while s[1]=' ' do delete(s,1,1);
while s[length(s)]=' ' do delete(s,length(s),1);
while pos(' ',s)<>0 do delete(s,pos(' ',s),1);
writeln('Xau sau khi xoa ki tu trang thua la:',s);
end;
procedure xoadup(st:string);
var s:string;
i:integer;
begin s:=st;i:=1;
while i<length(s) do
if pos(s[i]+s[i],s)<>0 then
delete(s,pos(s[i]+s[i],s),1) else i:=i+1;
writeln('Xau sau khi xoa ki tu dup la:',s);
end;
function thuoc(s:string; k:integer; ch:char):boolean;
var i,d:integer;
begin d:=0;
for i:=1 to k do if ch=s[i] then d:=d+i;
if d=0 then thuoc:=false
else thuoc:=true;
end;
procedure chucai(st:string);
var s:string;
i,d,j,k:integer;
begin d:=0;s:=st;
for i:=1 to length(s) do
if upcase(s[i]) in ['A'..'Z'] then
if thuoc(s,i-1,s[i])=false then
begin k:=0;
for j:=1 to length(s) do
if s[j]=s[i] then k:=k+1;
writeln(' ki tu ',s[i],' xuat hien ',k,' lan');
end;
end;
procedure chuso(st:string);
var s:string;
i,d,j,k:integer;
begin d:=0;s:=st;
for i:=1 to length(s) do
if s[i] in ['1'..'9'] then
if thuoc(s,i-1,s[i])=false then
begin k:=0;
for j:=1 to length(s) do
if s[j]=s[i] then k:=k+1;
writeln(' chu so ',s[i],' xuat hien ',k,' lan');
end;
end;
procedure demtu(st:string);
var s:string;
i,d:integer;
begin d:=0;
s:=st;
while s[1]=#32 do delete(s,1,1);
while s[length(s)]= #32 do delete(s,length(s),1);
while pos(#32#32,s)<>0 do delete(s,pos(#32#32,s),1);
s:=s+#32;
writeln('Trong xau co cac tu la:');
while pos(#32,s)<>0 do
begin
writeln(copy(s,1,pos(#32,s)));
delete(s,1,pos(#32,s));d:=d+1;
end;
writeln('tong cong la ',d,' tu');
end;
procedure kitu(st:string);
var s:string; c:char;
i,d:integer;
begin d:=0; s:=st;
write('Nhap ki tu: ');readln(c);
for i:=1 to length(s) do
if c=s[i] then d:=d+1;
if d= 0 then writeln(c,' ko xuat hien trong ',s)
else writeln(c,' xuat hien ',d,' lan trong ',s);
end;
BEGIN
clrscr;
write('Nhap xau: ');readln(st);
writeln('MENU: ');
writeln('1.In xau ra chu hoa.');
writeln('2.In xau ra chu thuong.');
writeln('3.Kiem tra xem xau co doi xung ko.');
writeln('4.Xoa ki tu trang thua trong xau.');
writeln('5.Xoa ki tu dup trong xau.');
writeln('6.In ra chu cai va so luong.');
writeln('7.In ra chu so va so luong.');
writeln('8.Dem so tu trong cau va in moi tu 1 dong.');
writeln('9.In ra so la xuat hien cua 1 ki tu trong xau');
writeln('0.Thoat.');
repeat
write('Nhap lua chon: ');readln(n);
case n of
1:chuhoa(st);
2:chuthuong(st);
3:xaudx(st);
4:xoatrang(st);
5:xoadup(st);
6:chucai(st);
7:chuso(st);
8:demtu(st);
9:kitu(st);
0:exit;
end; until n=0;
readln;
END.
Bạn đang đọc truyện trên: Truyen2U.Pro