Chương trình con và lập trình có cấu trúc

uses crt;

var s:string;

i,d,t,x,y:integer;

begin

clrscr;

write('Nhap xau S:'); readln(s);

d:=length(s);

t:=0;

for i:=1 to d do

if s[i] in ['0'..'9'] then

begin

val(s[i],x,y);

t:=t+x;

end;

writeln('Mat khau la: ',t);

readln;

end.

bài 1 chạy không được

Bài làm của bạn @Tran Nguyễn Đăng Dương(bạn được 20 điểm, xếp thứ 1 chung cuộc)

-Bài 1:

program hedem; uses crt; const fi='hedem.inp'; fo='hedem.out'; var st:string; hedema,hedemb:integer; f1,f2:text; Function heasanghe10(st1:string):integer; var d,i,code,x,kq:integer; begin d:=Length(st1); kq:=0; x:=0; for i:=1 to d do begin case st1[i] of '0'..'9':begin Val(st1[i],x,code); kq:=kq*hedema+x; end; 'A'..'F':begin x:=ord(st1[i])-55; kq:=kq*hedema+x; end; end; end; exit(kq); end; Procedure he10sangheb(kq:Integer); var dem,d,i,x:integer; du:array[1..100] of Integer; begin dem:=0; x:=0; repeat dem:=dem+1; du[dem]:=kq mod hedemb; kq:=kq div hedemb; until kq=0; for i:=dem downto 1 do begin case du[i] of 0..9:write(f2,du[i]); 10..15:begin x:=du[i]+55; write(f2,Chr(x)); end; end; end; end; begin clrscr; assign(f1,fi); reset(f1); assign(f2,fo); rewrite(f2); read(f1,hedema,hedemb); readln(f1); read(f1,st); he10sangheb(heasanghe10(st)); Close(f1); Close(f2); End.

-Bài 2:

Program ntghep; uses crt; const fi='ntghep.inp'; fo='ntghep.out'; var n:integer; f1,f2:text; Function SNTcheck(m:longint):boolean; var i:longint; begin for i:=2 to trunc(sqrt(m)) do if m mod i=0 then exit(false); exit(true); end; Function timsntthun(m:longint):longint; var dem,j:longint; begin j:=2; dem:=0; repeat while not SNTcheck(j) do inc(j); inc(dem); inc(j); until dem=m; exit(j-1); end; Function timsntghepthun(m:integer):longint; var dem,k,code,kq:longint; st,st1:string; begin k:=1; kq:=0; dem:=0; repeat str(timsntthun(k),st); str(timsntthun(k+1),st1); Val(st+st1,kq,code); if SNTcheck(kq) then inc(dem); k:=k+2; until dem=m; exit(kq); end; Begin clrscr; assign(f1,fi); reset(f1); assign(f2,fo); rewrite(f2); read(f1,n); write(f2,timsntghepthun(n)); Close(f1); Close(f2); End.

-Bài 3;

Program Fibonacci; uses crt; const fi='fibonaci.inp'; fo='fibonaci.out'; var n:integer; f1,f2:text; procedure fibo(n:integer); var i,vt:integer; fibo:array[1..100] of Integer; kt:boolean; begin fibo[1]:=1; fibo[2]:=1; kt:=false; for i:=3 to n do begin fibo[i]:=fibo[i-1]+fibo[i-2]; if fibo[i]=n then begin kt:=true; vt:=i; end; end; for i:=1 to n do write(f2,fibo[i],' '); writeln(f2); if kt then writeln(f2,'Co. ',vt) else writeln(f2,'Khong'); write(f2,fibo[n]); end; Begin clrscr; assign(f1,fi); reset(f1); assign(f2,fo); rewrite(f2); read(f1,n); fibo(n); Close(f1); Close(f2); End.

-Bài 4:

Program map; uses crt; const fi='map.inp'; fo='map.out'; type arr=array[0..2001,0..71] of Char; var area,tam:arr; e,f:array[1..4] of Integer; ch:char; st:string; i,j,x,y,vtdx,vtdy,vtcd,vtcdm:integer; dem,max:longint; f1,f2:text; Procedure mapfinding(a,b:integer; var c:arr); var k:integer; begin if (a>0) and (a<=x) and (b>0) and (b<=y) and (c[a,b]=ch) then begin vtcd:=a; c[a,b]:='*'; inc(dem); for k:=1 to 4 do mapfinding(a+e[k],b+f[k],c); end; end; Begin clrscr; assign(f1,fi); reset(f1); assign(f2,fo); rewrite(f2); readln(f1,ch); e[1]:=-1; e[4]:=1; f[2]:=-1; f[3]:=1; i:=0; repeat readln(f1,st); inc(x); for y:=1 to Length(st) do area[x,y]:=st[y]; until eof(f1); tam:=area; for i:=1 to x do for j:=1 to y do if tam[i,j]=ch then begin mapfinding(i,j,tam); if max<dem then begin max:=dem; vtdx:=i; vtdy:=j; vtcdm:=vtcd; end; dem:=0; end; mapfinding(vtdx,vtdy,area); writeln(f2,max,' ',vtdx,' ',vtdy,' ',vtcdm); for i:=vtdx to vtcdm do begin for j:=1 to y do write(f2,area[i,j]); writeln(f2); end; Close(f1); Close(f2); End.

-Bài 5:

Program smart; uses crt; const fi='smart.inp'; fo='smart.out'; type AsVBs=record a,v,b:string; end; AVBs=record a,v,b:string; end; AsVB=record a,v,b:string; end; AisB=record a,b:string; end; Question=record a,typea,v,b,typeb:string; end; var AsVBsinfo:array[0..101] of AsVBs; AVBsinfo:array[0..101] of AVBs; AsVBinfo:array[0..101] of AsVB; AisBinfo:array[0..101] of AisB; Questions:array[0..101] of Question; i,j,k,noAsVBs,noAVBs,noAsVB,noAisB,noQuestions,vt:integer; f1,f2:text; st,st1,st2,st3:string; check,check1,check2:boolean; Procedure readinfo; begin repeat readln(f1,st); if st='#' then break; for i:=1 to 3 do begin j:=1; while (st[j]<>' ') and (st[j]<>'.') do inc(j); case i of 1:st1:=upcase(copy(st,1,j-1)); 2:st2:=upcase(copy(st,1,j-1)); 3:st3:=upcase(copy(st,1,j-1)); end; Delete(st,1,j); end; Delete(st,Length(st),1); st:=upcase(st); if st1='DOES' then begin inc(noQuestions); Questions[noQuestions].a:=st2; Questions[noQuestions].v:=st3; Questions[noQuestions].b:=st; end else if st2='IS' then begin inc(noAisB); AisBinfo[noAisB].a:=st1; AisBinfo[noAisB].b:=st+'S'; end else if (st1[Length(st1)]='S') and (st3[Length(st3)]='S') then begin inc(noAsVBs); AsVBsinfo[noAsVBs].a:=st1; AsVBsinfo[noAsVBs].v:=st2; AsVBsinfo[noAsVBs].b:=st3; end else if st1[Length(st1)]='S' then begin inc(noAsVB); write(st1,' ',st2,' ',st3,' ',st,' AsVB'); AsVBinfo[noAsVB].a:=st1; AsVBinfo[noAsVB].v:=st2; AsVBinfo[noAsVB].b:=st3; end else if st3[Length(st3)]='S' then begin inc(noAVBs); AVBsinfo[noAVBs].a:=st1; AVBsinfo[noAVBs].v:=st2; AVBsinfo[noAVBs].b:=st3; end; until eof(f1); end; Begin clrscr; assign(f1,fi); reset(f1); assign(f2,fo); rewrite(f2); readinfo; for i:=1 to noQuestions do begin for j:=1 to noAisB do begin if Questions[i].a=AisBinfo[j].a then Questions[i].typea:=AisBinfo[j].b; if Questions[i].b=AisBinfo[j].a then Questions[i].typeb:=AisBinfo[j].b; end; if (Questions[i].typea='') and (Questions[i].typeb='') then writeln(f2,'No.') else begin check:=false; check1:=false; check2:=false; if (Questions[i].typea<>'') and (Questions[i].typeb<>'') then begin for j:=1 to noAsVBs do begin if (Questions[i].typea=AsVBsinfo[j].a) and (Questions[i].typeb=AsVBsinfo[j].b) and (Questions[i].v=AsVBsinfo[j].v) then begin writeln(f2,'Yes.'); check:=true; end; end; end; if (Questions[i].typea<>'') and (not check) then begin for j:=1 to noAsVB do begin if (Questions[i].typea=AsVBinfo[j].a) and (Questions[i].b=AsVBinfo[j].b) and (Questions[i].v=AsVBinfo[j].v) then begin writeln(f2,'Yes.'); check1:=true; end; end; end; if (Questions[i].typeb<>'') and (not check) and (not check1) then begin for j:=1 to noAVBs do begin if (Questions[i].a=AVBsinfo[j].a) and (Questions[i].typeb=AVBsinfo[j].b) and (Questions[i].v=AVBsinfo[j].v) then begin writeln(f2,'Yes.'); check2:=true; end; end; end; if (not check) and (not check1) and (not check2) then writeln(f2,'No.'); end; end; Close(f1); Close(f2); End.

Bài làm của bạn @Encyclopedia(bạn được 20 điểm, xếp thứ 2 chung cuộc vì nộp bài chậm hơn bạn @Tran Nguyễn Đăng Dương)

bài 1:

var st:string; hedema,hedemb:integer; f,g:text; const fi='hedem.inp'; fo='hedem.out'; Function doisanghe10(st1:string):integer; var d,i,code,x,kq:integer; begin d:=Length(st1); kq:=0; x:=0; for i:=1 to d do begin case st1[i] of '0'..'9':begin Val(st1[i],x,code); kq:=kq*hedema+x; end; 'A'..'F':begin x:=ord(st1[i])-55; kq:=kq*hedema+x; end; end; end; exit(kq); end; Procedure chuyen10sangb(kq:Integer); var dem,d,i,x:integer; du:array[1..100] of Integer; begin dem:=0; x:=0; repeat dem:=dem+1; du[dem]:=kq mod hedemb; kq:=kq div hedemb; until kq=0; for i:=dem downto 1 do begin case du[i] of 0..9:write(g,du[i]); 10..15:begin x:=du[i]+55; write(g,Chr(x)); end; end; end; end; begin assign(f,fi); reset(f); assign(g,fo); rewrite(g); read(f,hedema,hedemb); readln(f); read(f,st); chuyen10sangb(doisanghe10(st)); Close(f); Close(g); End.

bài 2:

const fi='ntghep.inp'; fo='ntghep.out'; var n:integer; f1,f2:text; Function SNTcheck(m:longint):boolean; var i:longint; begin for i:=2 to trunc(sqrt(m)) do if m mod i=0 then exit(false); exit(true); end; Function timsntthun(m:longint):longint; var dem,j:longint; begin j:=2; dem:=0; repeat while not SNTcheck(j) do inc(j); inc(dem); inc(j); until dem=m; exit(j-1); end; Function timsntghepthun(m:integer):longint; var dem,k,code,kq:longint; st,st1:string; begin k:=1; kq:=0; dem:=0; repeat str(timsntthun(k),st); str(timsntthun(k+1),st1); Val(st+st1,kq,code); if SNTcheck(kq) then inc(dem); k:=k+2; until dem=m; exit(kq); end; Begin assign(f1,fi); reset(f1); assign(f2,fo); rewrite(f2); read(f1,n); write(f2,timsntghepthun(n)); Close(f1); Close(f2); End.

bài 3:

const fi='fibonaci.inp'; fo='fibonaci.out'; var n:integer; f1,f2:text; procedure fibo(n:integer); var i,vt:integer; fibo:array[1..100] of Integer; kt:boolean; begin fibo[1]:=1; fibo[2]:=1; kt:=false; for i:=3 to n do begin fibo[i]:=fibo[i-1]+fibo[i-2]; if fibo[i]=n then begin kt:=true; vt:=i; end; end; for i:=1 to n do write(f2,fibo[i],' '); writeln(f2); if kt then writeln(f2,'Co. ',vt) else writeln(f2,'Khong'); write(f2,fibo[n]); end; Begin assign(f1,fi); reset(f1); assign(f2,fo); rewrite(f2); read(f1,n); fibo(n); Close(f1); Close(f2); End.

bài 4:

type arr=array[0..2001,0..71] of Char; var area,tam:arr; e,f:array[1..4] of Integer; ch:char; st:string; i,j,x,y,vtdx,vtdy,vtcd,vtcdm:integer; dem,max:longint; f1,f2:text; const fi='map.inp'; fo='map.out'; Procedure mapfinding(a,b:integer; var c:arr); var k:integer; begin if (a>0) and (a<=x) and (b>0) and (b<=y) and (c[a,b]=ch) then begin vtcd:=a; c[a,b]:='*'; inc(dem); for k:=1 to 4 do mapfinding(a+e[k],b+f[k],c); end; end; Begin assign(f1,fi); reset(f1); assign(f2,fo); rewrite(f2); readln(f1,ch); e[1]:=-1; e[4]:=1; f[2]:=-1; f[3]:=1; i:=0; repeat readln(f1,st); inc(x); for y:=1 to Length(st) do area[x,y]:=st[y]; until eof(f1); tam:=area; for i:=1 to x do for j:=1 to y do if tam[i,j]=ch then begin mapfinding(i,j,tam); if max<dem then begin max:=dem; vtdx:=i; vtdy:=j; vtcdm:=vtcd; end; dem:=0; end; mapfinding(vtdx,vtdy,area); writeln(f2,max,' ',vtdx,' ',vtdy,' ',vtcdm); for i:=vtdx to vtcdm do begin for j:=1 to y do write(f2,area[i,j]); writeln(f2); end; Close(f1); Close(f2); End. //THE END

bài 5

const fi='bxl.inp'; fo='bxl.out'; type AsVBs=record a,v,b:string; end; AVBs=record a,v,b:string; end; AsVB=record a,v,b:string; end; AisB=record a,b:string; end; Question=record a,typea,v,b,typeb:string; end; var AsVBsinfo:array[0..101] of AsVBs; AVBsinfo:array[0..101] of AVBs; AsVBinfo:array[0..101] of AsVB; AisBinfo:array[0..101] of AisB; Questions:array[0..101] of Question; i,j,k,noAsVBs,noAVBs,noAsVB,noAisB,noQuestions,vt:integer; f1,f2:text; st,st1,st2,st3:string; check,check1,check2:boolean; Procedure readinfo; begin repeat readln(f1,st); if st='#' then break; for i:=1 to 3 do begin j:=1; while (st[j]<>' ') and (st[j]<>'.') do inc(j); case i of 1:st1:=upcase(copy(st,1,j-1)); 2:st2:=upcase(copy(st,1,j-1)); 3:st3:=upcase(copy(st,1,j-1)); end; Delete(st,1,j); end; Delete(st,Length(st),1); st:=upcase(st); if st1='DOES' then begin inc(noQuestions); Questions[noQuestions].a:=st2; Questions[noQuestions].v:=st3; Questions[noQuestions].b:=st; end else if st2='IS' then begin inc(noAisB); AisBinfo[noAisB].a:=st1; AisBinfo[noAisB].b:=st+'S'; end else if (st1[Length(st1)]='S') and (st3[Length(st3)]='S') then begin inc(noAsVBs); AsVBsinfo[noAsVBs].a:=st1; AsVBsinfo[noAsVBs].v:=st2; AsVBsinfo[noAsVBs].b:=st3; end else if st1[Length(st1)]='S' then begin inc(noAsVB); write(st1,' ',st2,' ',st3,' ',st,' AsVB'); AsVBinfo[noAsVB].a:=st1; AsVBinfo[noAsVB].v:=st2; AsVBinfo[noAsVB].b:=st3; end else if st3[Length(st3)]='S' then begin inc(noAVBs); AVBsinfo[noAVBs].a:=st1; AVBsinfo[noAVBs].v:=st2; AVBsinfo[noAVBs].b:=st3; end; until eof(f1); end; Begin assign(f1,fi); reset(f1); assign(f2,fo); rewrite(f2); readinfo; for i:=1 to noQuestions do begin for j:=1 to noAisB do begin if Questions[i].a=AisBinfo[j].a then Questions[i].typea:=AisBinfo[j].b; if Questions[i].b=AisBinfo[j].a then Questions[i].typeb:=AisBinfo[j].b; end; if (Questions[i].typea='') and (Questions[i].typeb='') then writeln(f2,'No.') else begin check:=false; check1:=false; check2:=false; if (Questions[i].typea<>'') and (Questions[i].typeb<>'') then begin for j:=1 to noAsVBs do begin if (Questions[i].typea=AsVBsinfo[j].a) and (Questions[i].typeb=AsVBsinfo[j].b) and (Questions[i].v=AsVBsinfo[j].v) then begin writeln(f2,'Yes.'); check:=true; end; end; end; if (Questions[i].typea<>'') and (not check) then begin for j:=1 to noAsVB do begin if (Questions[i].typea=AsVBinfo[j].a) and (Questions[i].b=AsVBinfo[j].b) and (Questions[i].v=AsVBinfo[j].v) then begin writeln(f2,'Yes.'); check1:=true; end; end; end; if (Questions[i].typeb<>'') and (not check) and (not check1) then begin for j:=1 to noAVBs do begin if (Questions[i].a=AVBsinfo[j].a) and (Questions[i].typeb=AVBsinfo[j].b) and (Questions[i].v=AVBsinfo[j].v) then begin writeln(f2,'Yes.'); check2:=true; end; end; end; if (not check) and (not check1) and (not check2) then writeln(f2,'No.'); end; end; Close(f1); Close(f2); End.

Cảm ơn Phước Thịnh đã tổ chức cuộc thi này. Thầy sẽ nhắn tin và trao giải cho các bạn đạt giải.

Các bạn cố gắng đợi một thời gian rồi thầy @phynit sẽ thưởng cho các bạn

Thịnh comment 1 cái anh tick thưởng CTV em nhé!

Tìm UCLN,BCNN của hai số nguyên

uses crt; var a,b:integer; {--------------------ham-tim-UCLN-----------------------} function ucln(var x,y:integer):integer; var i:integer; begin ucln:=1; if x<y then begin for i:=1 to x do if (x mod i=0) and (y mod i=0) then begin if ucln<i then ucln:=i; end; end; if x=y then ucln:=x; if x>y then begin for i:=1 to y do if (x mod i=0) and (y mod i=0) then begin if ucln<i then ucln:=i; end; end; end; {---------------------ham-tim-BCNN----------------------------} function bcnn(var x,y:integer):real; var i:integer; begin bcnn:=x*y; for i:=x*y downto 1 do if (i mod x=0) and (i mod y=0) then begin if bcnn>i then bcnn:=i; end; end; {---------------------chuong-trinh-chinh--------------------} begin clrscr; write('Nhap so thu nhat:'); readln(a); write('Nhap so thu hai:'); readln(b); if (a<>0) and (b<>0) then writeln('Uoc chung lon nhat cua hai so la: ',ucln(a,b)) else writeln(a,' va ',b,' khong co uoc chung lon nhat'); writeln('Boi chung nho nhat cua hai so la: ',bcnn(a,b):4:0); readln; end.

Tính n! Với n nguyên

uses crt; var n:integer; {----------------------ham-tinh-giai-thua---------------------} function giaithua(var x:integer):real; var i:integer; begin giaithua:=1; for i:=1 to x do giaithua:=giaithua*i; end; {---------------------chuong-trinh-chinh--------------------} begin clrscr; write('Nhap n='); readln(n); writeln(n,'!=',giaithua(n):4:0); readln; end.

Tính a^b, với a,b là số thực

uses crt; var a:real; b:integer; {----------------------ham-tinh-giai-thua---------------------} function luythua(var x:real; y:integer):real; var i:integer; begin luythua:=1; for i:=1 to y do luythua:=luythua*x; end; {---------------------chuong-trinh-chinh--------------------} begin clrscr; write('Nhap a='); readln(a); write('Nhap b='); readln(b); if b>=0 then writeln(a:4:2,'^',b,'=',luythua(a,b):4:2) else writeln(a:4:2,'^',b,'=1/',luythua(a,abs(b)):4:2); readln; end.

Tráo đổi hai số nguyên x và y

uses crt; var x,y:integer; {-----------------------thu-tuc-hoan-doi-hai-so-----------------------} procedure hoandoi(var a,b:integer); var tam:integer; begin tam:=a; a:=b; b:=tam; end; {-----------------------chuong-trinh-chinh----------------------------} begin clrscr; write('Nhap x='); readln(x); write('Nhap y='); readln(y); hoandoi(x,y); writeln('Sau khi hoan doi: x=',x,' va y=',y); readln; end.

Bài 1:

*Hàm

function dientich(var x:integer):real;

begin

dientich:=sqr(x);

end;

*Thủ tục:

procedure dientich(var x:integer);

var dt:real;

begin

dt:=sqr(x);

writeln('Dien tich hinh vuong la: ',dt:0:0);

end;

Bài 2:

*Thủ tục:

procedure dientich(var a,b,c:real);

var p,s:real;

begin

p:=(a+b+c)/2;

s:=sqrt(p*(p-a)*(p-b)*(p-c));

writeln('Dien tich tam giac la: ',s:4:2);

end;

*Hàm

function dientich(var a,b,c:real):real;

var p,s:real;

begin

p:=(a+b+c)/2;

s:=sqrt(p*(p-a)*(p-b)*(p-c));

dientich:=s;

end;

Bài 3:

*Thủ tục

procedure hoandoi(var a,b:integer);

var tam:integer;

begin

tam:=a;

a:=b;

b:=tam;

end;

Câu 1:

uses crt; var ten:string; kt:integer; begin clrscr; write('Nhap ho va ten cua hoc sinh:'); readln(ten); writeln('Ki tu thu 5 la: ',ten[5]); kt:=0; if ten[1] in ['A'..'Z'] then kt:=1; if kt=0 then writeln('Ki tu dau tien chua viet hoa') else writeln('Ki tu dau tien da viet hoa'); readln; end.

Câu 2:

uses crt; var d,r:real; {-------------------------chuong-trinh-con----------------------------} function dientich(x,y:real):real; begin dientich:=x*y; end; {-------------------------chuong-trinh-chinh---------------------------} begin clrscr; repeat write('Nhap chieu dai:'); readln(d); write('Nhap chieu rong:'); readln(r); until (d>0) and (r>0) and (d>=r); writeln('Dien tich cua hinh chu nhat la: ',dientich(d,r):4:2); readln; end.

Câu 3:

uses crt; var st:string; dem,d,i:integer; begin clrscr; write('Nhap xau:'); readln(st); dem:=0; d:=length(st); for i:=1 to d do if st[i] in ['0'..'9'] then inc(dem); writeln('So ki tu chu so la: ',dem); readln; end.

const fi='so.equ';

fo='soam5.equ';

var f1,f2:text;

i,n:integer;

a:array[1..100]of integer;

begin

assign(f1,fi); reset(f1);

assign(f2,fo); rewrite(f2);

n:=0;

while not eoln(f1) do

begin

inc(n);

read(f1,a[n]);

end;

for i:=1 to n do

if (a[i]<0) and (a[i] mod 5=0) then write(f2,a[i]:4);

close(f1);

close(f2);

end.

uses crt; var a,b,c:real; {----------------------------chuong-trinh-con-----------------------------} function tong(x,y:real):real; begin tong:=x+y; end; {----------------------------chuong-trinh-chinh---------------------------} begin clrscr; write('a='); readln(a); write('b='); readln(b); write('c='); readln(c); writeln('Tong cua ba so la: ',tong(a,tong(b,c)):4:2); readln; end.

uses crt; var xa,ya,xb,yb:integer; kc:real; {------------------------chuong-trinh-con-nhap----------------------------} procedure nhap(var xc,yc,xd,yd:integer); begin write('Nhap toa do cua diem thu nhat:'); readln(xc,yc); write('Nhap toa do cua diem thu hai:'); readln(xd,yd); end; {------------------------chuong-trinh-chinh------------------------------} begin clrscr; nhap(xa,ya,xb,yb); kc:=sqrt(sqr(xa-xb)+sqr(ya-yb)); writeln('Khoang cach giua hai diem la: ',kc:4:2); readln; end.