Pascal 16 Mot so bai tap Pascal hay

[r]

ChuÈn ho¸ 3-7 Program Norm_3_7;

uses crt ;

const

fi = 'norm.inp' ;

fo = 'norm.out' ;

{ fo = '' ;}

max = '000000000000000000000' ; type

st = string[21] ;

var

f,g : text ;

s,smax : st ;

d,c : integer ;

ok : boolean ;

procedure khoitao ;

begin

smax:='0' ;

end ;

function lonhon(s,s1 : st) : boolean ;

begin

lonhon:=true ;

if length(s1)>length(s) then

begin

lonhon:=false ;

exit ;

end ;

if length(s1)<length(s) then exit ;

if s>s1 then exit ;

lonhon:=false ;

end ;

procedure ghinhan ;

begin

if lonhon(s,smax) then smax:=s ;

end ;

procedure xoa0 ;

begin

while s[1]='0' do delete(s,1,1) ;

end ;

procedure chia3 ;

var so,nho,i,j : byte ;

a,c,du : integer ;

x,x1,x2 : st ;

begin

x:='' ;

x1:='' ;

i:=1 ;

if s[1]<'3' then

begin

x1:=x1+s[1] ;

i:=2 ;

end ;

while i<=length(s) do

begin

x1:=x1+s[i] ;

val(x1,a,c) ;

du:=a mod 3 ;

c:=a div 3 ;

if du=0 then x1:='' else str(du,x1); str(c,x2) ;

x:=x+x2 ;

inc(i) ;

end ;

if x1='' then

begin

ok:=true ;

s:=x ;

end ;

end ;

procedure chuan1 ;

var i,tcs : integer ;

begin

tcs:=0 ;

for i:=1 to length(s) do

inc(tcs,ord(s[i])-48) ;

if tcs mod 3 = 0 then

chia3 ;

end ;

procedure chuan2 ;

var so,nho,i,j : byte ;

a,c,du : integer ;

x,x1,x2 : st ;

begin

x:='' ;

x1:='' ;

i:=1 ;

if s[1]<'7' then

begin

x1:=x1+s[1] ;

i:=2 ;

end ;

while i<=length(s) do

begin

x1:=x1+s[i] ;

val(x1,a,c) ;

du:=a mod 7 ;

c:=a div 7 ;

if du=0 then x1:='' else str(du,x1) ; str(c,x2) ;

x:=x+x2 ;

inc(i) ;

end ;

if x1='' then

begin

ok:=true ;

s:=x ;

end ;

end ;

procedure chuan3 ;

var i : integer ;

begin

ok:=false ;

for i:=1 to length(s) do

if s[i]='3' then

begin

delete(s,i,1) ;

ok:=true ;

exit ;

end ;

xoa0 ;

end ;

procedure chuan4 ;

var i : integer ;

begin

ok:=false ;

for i:=1 to length(s) do

if s[i]='7' then

begin

delete(s,i,1) ;

ok:=true ;

exit ;

end ;

xoa0 ;

end ;

procedure chuan5 ;

var i,dem,j : integer ;

c : char ;

begin

ok:=false ;

i:=1 ;

while i<=length(s) do

begin

c:=s[i] ;

dem:=0 ;

j:=i ;

while (s[i]=c) and (dem<3) do begin

inc(i) ;

inc(dem) ;

end ;

if dem=3 then

begin

delete(s,j,3) ;

ok:=true ;

exit ;

end ;

end ;

xoa0 ;

end ;

procedure chuan6 ;

var i,dem,j : integer ;

c : char ;

begin

i:=1 ;

ok:=false ;

while i<=length(s) do

begin

c:=s[i] ;

dem:=0 ;

j:=i ;

while (s[i]=c) and (dem<7) do begin

inc(i) ;

inc(dem) ;

end ;

if dem=7 then

begin

delete(s,j,7) ;

ok:=true ;

exit ;

end ;

end ;

xoa0 ;

end ;

function thoaman : boolean ;

var

x : st ;

begin

thoaman:=false ;

x:=s ;

chuan1 ;

if s<>x then exit ;

s:=x ;

chuan2 ;

if s<>x then exit ;

s:=x ;

chuan3 ;

if s<>x then exit ;

s:=x ;

chuan4 ;

if s<>x then exit ;

s:=x ;

chuan5 ;

if s<>x then exit ;

s:=x ;

chuan6 ;

if s<>x then exit ;

thoaman:=true ;

end ;

procedure duyet(var x : st) ;

var a : st ;

i : byte ;

begin

a:=s ;

for i:=1 to 6 do

begin

case i of

1 : chuan1 ;

2 : chuan2 ;

3 : chuan3 ;

4 : chuan4 ;

5 : chuan5 ;

6 : chuan6 ;

end ;

if lonhon(s,smax) and lonhon(a,s) then duyet(s) else

if thoaman then ghinhan ;

s:=a ;

end ;

end ;

procedure xuly ;

var ch : char ;

begin

repeat

ch:=readkey ;

case ch of

'3' : chuan3 ;

'4' : chuan4 ;

'1' : chuan1 ;

'2' : chuan2 ;

'5' : chuan5 ;

'6' : chuan6 ;

end ;

writeln(s) ;

until ch=#27 ;

end ;

procedure inkq ;

begin

writeln('Max = ',smax) ;

writeln(g,smax) ;

end ;

BEGIN

clrscr ;

assign(f,fi) ;

reset(f) ;

assign(g,fo) ;

rewrite(g) ;

while not eof(f) do

begin

readln(f,s) ;

smax:='0' ;

writeln(s) ;

{ xuly ;}

duyet(s) ;

inkq ;

end ;

close(f) ;

close(g) ;

END

Input: 999 Output: 11 Input: 237 Output: 2