Bài làm của bạn @lê chí hiếu(bạn được 3 điểm)
bài 2
const fi='ntghep.inp'; fn='ntghep.out'; var t,i,k,n,kt:longint; s,s1:string; f:text; function nt(n:longint):boolean; var i:longint; begin for i:= 2 to trunc(sqrt(n)) do if n mod i=0 then exit(false); exit(true); end; {--------------------} begin assign(f,fi);reset(f); readln(f,n); close(f); assign(f,fn);rewrite(f); i:=0;k:=1; while i<=n do begin inc(k); if nt(k) then begin str(k,s1); if kt=1 then begin kt:=0; s:=s+s1; val(s,t); if nt(t) then i:=i+1; if i=n then break; s:=''; end else if kt=0 then begin s:=s1; kt:=1; end; end; end; writeln(f,s); close(F); end.
bài 3
fi='fibonaci.inp'; fn='fibonaci.out'; var a:array[0..1000] of int64; i,n:longint; f:text; kt:boolean; begin assign(f,fi);reset(f); readln(f,n); a[1]:=1; a[2]:=1; close(f); assign(f,fn);rewrite(F); i:=2; write(F,'1 1 '); while i<n do begin inc(i); a[i]:=a[i-1]+A[i-2]; write(f,a[i],' '); end; writeln(f); for i:=1 to n do if a[i]=n then begin kt:=true; break; end; if kt=true then writeln(f,'Co. ',i) else writeln(f,'Khong'); writeln(f,a[n]); close(F); end.
Bài làm của bạn @Luân Đào(bạn được 4 điểm)
program b1;
const fi = 'hedem.inp';
fo = 'hedem.out';
var a,t: string;
x,k: integer;
y: integer;
f: text;
function decto(a,n:integer):string;
var res,t: string;
begin
t := '0123456789abcdef';
repeat
res := t[(a mod n)+1] + res;
a := a div n;
until a = 0;
decto := res;
end;
function todec(a: string; n: integer):integer;
var res,i: integer;
begin
res := 0;
for i := length(a) downto 1 do begin
res := res + (ord(a[i]) - 48)*trunc(exp((length(a)-i)*ln(n)));
end;
todec := res;
end;
procedure ip;
begin
assign(f,fi);
reset(f);
readln(f,x,y);
read(f,a);
close(f);
end;
begin
ip;
assign(f,fo);
rewrite(f);
k:=todec(a,x);
t:=decto(k,y);
write(f,t);
close(f);
end.
program b2;
var k :smallint;
f1,f2: text;
const fi ='ntghep.inp';
fo ='ntghep.out';
function ktra(i :int64) :boolean;
var
j :longint;
begin
for j:=2 to trunc(sqrt(i)) do
if (i mod j=0) then exit(false);
exit(true);
end;
procedure chay;
var
i :longint;
j :int64;
kq,dem:smallint;
s,s2:string;
begin
kq:=0; i:=2; dem:=0;
while (kq<k) do
begin
if (ktra(i)) then
begin
inc(dem);
str(i,s);
if (dem mod 2=0) then
begin
val(s2+s,j);
if (ktra(j)) then inc(kq);
dem:=0;
end
else s2:=s;
end;
inc(i);
end;
write(f2,j);
end;
begin
assign(f1,fi); reset(f1);
assign(f2,fo); rewrite(f2);
read(f1, k);
chay;
close(f1); close(f2);
end.
program b3;
Const fi = 'fibonaci.inp';
fo = 'fibonaci.out';
var n: integer;
f : text;
a,b: array[1..30] of integer;
dem,i,p,j,l: integer;
procedure ip;
begin
assign(f,fi);
reset(f);
repeat
readln(f,n);
until n<=30;
close(f);
end;
procedure op;
begin
assign(f,fo);
rewrite(f);
i:=1;
for i:=1 to n do a[i]:=0;
a[1]:=1;
a[2]:=1;
j:=1;
for j:=3 to n do a[j]:=a[j-2]+a[j-1];
p:=1;
for p:=1 to n-1 do write(f,a[p],' ');
writeln(f,a[n]);
for l:= 1 to n do
b[l]:=a[l] - n;
for i:=1 to n do
if b[i] = 0 then writeln(f,'Co. ', i);
dem:=0;
for i:=1 to n do
if b[i] <> 0 then dem:=dem+1;
if dem = n then writeln(f,'Khong');
write(f,a[n]);
close(f);
end;
begin
ip;
op;
end.
Bài làm của bạn @TRẦN MINH HOÀNG(bạn được 7 điểm)
Câu 1:
var
m:longint; a,b,i:byte; n:string;
fi,fo:text;
procedure open_file(x:string);
begin
assign(fi,x+'.inp'); reset(fi);
assign(fo,x+'.out'); rewrite(fo);
end;
procedure close_file;
begin
close(fi);
close(fo);
end;
function doi1(x:char):byte;
begin
if x in ['A'..'Z'] then exit(ord(x)-55)
else VAL(x,doi1);
end;
function doi2(x:byte):string;
begin
if (0<=x) and (x<=9) then str(x,doi2)
else doi2:=chr(x+55);
end;
function amub(a,b:byte):int64;
begin
if b=0 then amub:=1 else amub:=amub(a,b-1)*a;
end;
begin
open_file('hedem');
readln(fi,a,b);
read(fi,n);
m:=0;
for i:=1 to length(n) do inc(m,doi1(n[i])*amub(a,length(n)-i));
n:='';
while m>=b do
begin
n:=doi2(m mod b)+n;
m:=m div b
end;
n:=doi2(m)+n;
write(fo,n);
close_file;
end.
Câu 2:
var
k,i,m:integer;
A:Array[1..501] of longint;
fi,fo:text;
procedure open_file(x:string);
begin
assign(fi,x+'.inp');
reset(fi);
assign(fo,x+'.out');
rewrite(fo);
end;
procedure close_file;
begin
close(fi);
close(fo);
end;
function NT(a:longint):boolean;
var i:longint;
begin
if a<=1 then exit(false) else
for i:=2 to trunc(sqrt(a)) do if (a mod i)=0 then exit(false);
exit(true);
end;
procedure NTers;
var i:integer;
begin
i:=0;
m:=2;
while i<500 do
begin
if NT(m) then begin inc(i); A[i]:=m; end;
m:=m+1;
end;
end;
function C_B(a,b:integer):qword;
var x,y:string;
begin
STR(a,x); STR(b,y); VAL(x+y,C_B);
end;
begin
open_file('ntghep');
readln(fi,k);
NTers;
i:=0;
m:=1;
while i<k do
begin
if NT(C_B(A[m],A[m+1])) then inc(i);
inc(m,2)
end;
write(fo,A[m-2],A[m-1]);
close_file;
end.
Câu 3:
var
n,i:byte;
fi,fo:text;
procedure open_file(x:string);
begin
assign(fi,x+'.inp');
reset(fi);
assign(fo,x+'.out');
rewrite(fo);
end;
procedure close_file;
begin
close(fi);
close(fo);
end;
function Fib(a:byte):longint;
begin
if a<=2 then Fib:=1 else Fib:=Fib(a-1)+Fib(a-2);
end;
procedure first;
var i:byte;
begin
for i:=1 to n do write(fo,Fib(i),' ');
end;
procedure second;
var i:byte;
begin
while Fib(i+1)<=n do
inc(i);
if Fib(i)=n then writeln(fo,'Co. ',i) else writeln(fo,'Khong')
end;
procedure third;
begin
write(fo,Fib(n))
end;
begin
open_file('Fibonaci');
read(fi,n);
first;
writeln(fo,'');
second;
third;
close_file;
end.
Bài làm của bạn Minh Lê(Link trang cá nhân: https://hoc24.vn/id/2720062)(bạn được 19,9 điểm, xếp thứ 3 chung cuộc)
// Bài 1 (hedem):
var s: string; a, b: integer; fi, fo: text; procedure open_file(s: string); begin assign(fi, s + '.INP'); reset(fi); assign(fo, s + '.OUT'); rewrite(fo); end; procedure close_file; begin close(fi); close(fo); end; function decode(var s: string; base: integer): integer; var i, n, ans, x: integer; begin n := length(s); ans := 0; for i := 1 to n do begin if (s[i] >= '0') and (s[i] <= '9') then x := ord(s[i]) - 48 else x := ord(s[i]) - 55; ans := base * ans + x; end; exit(ans); end; function encode(x, base: integer): string; var c: char; ans: string; begin ans := ''; while x <> 0 do begin if x mod base <= 9 then c := chr(x mod base + 48) else c := chr(x mod base + 55); ans := c + ans; x := x div base; end; exit(ans); end; begin open_file('hedem'); readln(fi, a, b); readln(fi, s); write(fo, encode(decode(s, a), b)); close_file; end.// Bài 2 (ntghep)
const INF = 36000000; var pr, mf: array[1..INF] of longint; k, pr_size: longint; fi, fo: text; procedure open_file(s: string); begin assign(fi, s + '.INP'); reset(fi); assign(fo, s + '.OUT'); rewrite(fo); end; procedure close_file; begin close(fi); close(fo); end; procedure build; var i, j: longint; begin pr_size := 0; for i := 2 to INF do begin if mf[i] = 0 then begin mf[i] := i; inc(pr_size); pr[pr_size] := i; end; for j := 1 to pr_size do if (pr[j] > i) or (pr[j] * i > INF) then break else mf[pr[j] * i] := pr[j]; end; end; function calc(k: longint): longint; var i, x: longint; x1, x2: string; begin for i := 1 to pr_size div 2 do begin str(pr[2*i - 1], x1); str(pr[2*i], x2); val(x1 + x2, x); if mf[x] = x then begin if k = 1 then exit(x) else dec(k); end; end; end; begin open_file('ntghep'); build; read(fi, k); write(fo, calc(k)); close_file; end.// Bài 3 (fibonaci)
var i, n: longint; fib: array[1..30] of longint; fi, fo: text; procedure open_file(s: string); begin assign(fi, s + '.INP'); reset(fi); assign(fo, s + '.OUT'); rewrite(fo); end; procedure close_file; begin close(fi); close(fo); end; procedure build; begin fib[1] := 1; fib[2] := 1; for i := 3 to n do fib[i] := fib[i - 2] + fib[i - 1]; end; procedure print1; begin for i := 1 to n do write(fo, fib[i], ' '); writeln(fo); end; procedure print2; begin for i := 1 to n do if fib[i] = n then begin writeln(fo, 'Có. ', i); exit; end; writeln(fo, 'Không'); end; procedure print3; begin writeln(fo, fib[n]); end; begin open_file('fibonaci'); read(fi, n); build; print1; print2; print3; close_file; end.// Bài 4 (map)
var i, j: longint; n, m: longint; s, x, y, z: longint; land: array[1..2000] of string; visited: array[1..2000, 1..70] of boolean; c: char; u, v: longint; _s, _x, _y, _z: longint; front, back: longint; queue: array[1..140000] of record first, second: longint; end; fi, fo: text; procedure open_file(s: string); begin assign(fi, s + '.INP'); reset(fi); assign(fo, s + '.OUT'); rewrite(fo); end; procedure close_file; begin close(fi); close(fo); end; procedure qpush(i, j: longint); begin inc(back); with queue[back] do begin first := i; second := j; end; end; procedure qinit(i, j: longint); begin front := 1; back := 0; qpush(i, j); visited[i, j] := true; _s := 1; _x := i; _y := j; _z := i; end; function is_valid1(i, j: longint): boolean; begin exit((i >= 1) and (i <= n) and (j >= 1) and (j <= m) and (land[i, j] = c) and (not visited[i, j])); end; procedure qupdate1(i, j: longint); begin qpush(i, j); visited[i, j] := true; inc(_s); if i > _z then _z := i; end; function is_valid2(i, j: longint): boolean; begin exit((i >= 1) and (i <= n) and (j >= 1) and (j <= m) and (land[i, j] = c)); end; procedure qupdate2(i, j: longint); begin qpush(i, j); land[i, j] := '*'; end; begin open_file('map'); readln(fi, c); n := 0; while not eof(fi) do begin inc(n); readln(fi, land[n]); end; m := length(land[1]); s := 0; for i := 1 to n do for j := 1 to m do if is_valid1(i, j) then begin qinit(i, j); while front <= back do begin u := queue[front].first; v := queue[front].second; inc(front); if is_valid1(u - 1, v) then qupdate1(u - 1, v); if is_valid1(u + 1, v) then qupdate1(u + 1, v); if is_valid1(u, v - 1) then qupdate1(u, v - 1); if is_valid1(u, v + 1) then qupdate1(u, v + 1); end; if _s > s then begin s := _s; x := _x; y := _y; z := _z; end; end; qinit(x, y); while front <= back do begin u := queue[front].first; v := queue[front].second; inc(front); if is_valid2(u - 1, v) then qupdate2(u - 1, v); if is_valid2(u + 1, v) then qupdate2(u + 1, v); if is_valid2(u, v - 1) then qupdate2(u, v - 1); if is_valid2(u, v + 1) then qupdate2(u, v + 1); end; writeln(fo, s, ' ', x, ' ', y, ' ', z); for i := x to z do begin for j := 1 to m do write(fo, land[i, j]); writeln(fo); end; close_file; end.// Bài 5 (bxl)
const mol = 1000007; const base = 37; var i, j, n, v: longint; a, b: string; s: array[0..4] of string; d: array[0..1000006] of boolean; define: array[0..1000006] of string; f1, f2, f3: boolean; fi, fo: text; procedure open_file(s: string); begin assign(fi, s + '.INP'); reset(fi); assign(fo, s + '.OUT'); rewrite(fo); end; procedure close_file; begin close(fi); close(fo); end; function hash(s: string): longint; var i, n, d: longint; begin n := length(s); d := 0; for i := 1 to n do d := (base*d + ord(s[i]) - 97) mod mol; exit(d); end; begin open_file('bxl'); while not eof(fi) do begin readln(fi, s[0]); i := 1; s[1] := ''; n := length(s[0]); if (n = 1) then break; for j := 1 to n do begin if s[0][j] = ' ' then begin inc(i); s[i] := ''; end else if (s[0][j] >= 'A') and (s[0][j] <= 'Z') then s[i] := s[i] + chr(ord(s[0][j]) + 32) else if (s[0][j] >= 'a') and (s[0][j] <= 'z') then s[i] := s[i] + s[0][j]; end; if s[1] = 'does' then begin a := define[hash(s[2])]; b := define[hash(s[4])]; f1 := d[hash(s[2] + ' ' + s[3] + ' ' + b )]; f2 := d[hash(a + ' ' + s[3] + ' ' + s[4])]; f3 := d[hash(a + ' ' + s[3] + ' ' + b )]; if f1 or f2 or f3 then writeln(fo, 'Yes.') else writeln(fo, 'No.'); end else if s[2] = 'is' then define[hash(s[1])] := s[4] + 's' else d[hash(s[1] + ' ' + s[2] + ' ' + s[3])] := true; end; close_file; end.// THE 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.
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.
