C1:Tep bang diem

program Cau7_1_Tep_bang_diem;

uses crt;

type hs=record

ht:string[30];

q:string[30];

dtb:real

end;

var f:file of hs;

procedure Nhap;

var a:hs;

i:byte;

begin

seek(f,0);

i:=1;

repeat

writeln('Nhap hoc sinh thu ',i,'(Neu khong muon nhap thi khong nhap ho ten)');

with a do

begin

write('Ho ten: '); readln(ht);

write('Que: '); readln(q);

write('Diem TB: '); readln(dtb);

end;

writeln;

if a.ht<>'' then write(f,a);

i:=i+1;

until a.ht='';

end;

procedure Hien;

var a:hs;

i:byte;

begin

seek(f,0);

writeln(' BANG DIEM');

writeln(' STT Ho ten Que Diem TB');

for i:=1 to filesize(f) do

with a do

begin

read(f,a);

writeln(i:4,ht:20,q:12,dtb:12:2);

end;

end;

procedure Sua;

var t:string[30];

i,vt:byte;

a:hs;

begin

seek(f,0);

write('Nhap ten hs muon sua ');readln(t);

for i:=1 to filesize(f) do

begin

read(f,a);

if a.ht=t then

begin

vt:=i-1;

writeln('Du lieu ban dau');

writeln('Ho ten: ',a.ht); writeln('Diem TB: ',a.dtb:4:2);

write('Nhap lai diem TB: '); readln(a.dtb);

seek(f,vt); write(f,a);

end;

end;

end;

BEGIN

clrscr;

assign(f,'d:\dsach.pas'); rewrite(f);

nhap; clrscr;

hien;

sua;

hien;

close(f);

readln;

end.

C2:Tam giac noi tiep elip

Program ve_hinh;

uses graph,crt;

var gd,gm:integer;

const poly1:array[1..3] of pointtype =((x:320;y:188),(x:250;y:270),(x:380;y:277));

begin

gd:=detect;

initgraph(gd,gm,'c:\tp\bgi');

setbkcolor(white);

setcolor(red);

setfillstyle(1,13);

delay(1000);

circle(320,240,100);

floodfill(320,240,red);

setfillstyle(1,14);

delay(1000);

bar(236,190,403,293);

setfillstyle(1,6);

delay(1000);

ellipse(320,240,0,360,84,52);

floodfill(320,240,4);

setfillstyle(1,10);

delay(1000);

fillpoly(3,poly1);

delay(500);

readln;

end.

C3: So lieu ban hang

program So_lieu_ban_hang;

uses crt;

type hang=record

th:string[30];

sl:integer;

dg,tt:real;

end;

var f: file of hang;

a: hang;

i,n:byte;

t:real;

begin

clrscr;

assign(f,'c:\so_lieu.pas');

rewrite(f);

t:=0;

write('So luong mat hang muon nhap n= '); readln(n);

for i:=1 to n do

begin

writeln('Nhap mat hang thu ',i);

with a do

begin

write('Ten hang: ');readln(th);

write('So luong: ');readln(sl);

write('Don gia: '); readln(dg);

tt:=sl*dg;

t:=t+tt;

end;

write(f,a);

end;

clrscr;

seek(f,0);

writeln(' SO LIEU BAN HANG');

writeln(' STT Ten Hang So luong Don gia Thanh tien');

for i:=1 to n do

begin

read(f,a);

with a do writeln(i:3,th:16,sl:14,dg:15:3,tt:18:3);

end;

write(' Tong: ',t:18:3);

close(f);

readln;

end.

C4: Danh sach sinh vien

Uses crt;

Type

p_hv=^hv;

hv=record ho_ten:string[25];

d_tb:real;

tiep:p_hv;

end;

Var

pdau,p:p_hv;

ch:char;

Procedure tao_ds(var p_dau:p_hv);

var

bht:string[25];

begin

clrscr;

p_dau:=nil;

writeln(' NHAP DANH SACH HOC VIEN. NEU MUON KET THUC NHAP THI KHONG NHAP HO TEN');

writeln(' ====================================================================');

repeat

write('Ho ten: ');readln(bht);

if bht<>'' then

begin

if p_dau=nil then

begin

new(p);

p_dau:=p;

end

else

begin

new(p^.tiep);

p:=p^.tiep;

end;

with p^ do

begin

tiep:=nil;

ho_ten:=bht;

write('Diem TBinh: ');

readln(d_tb);

end;

end;

until bht='';

end;

Procedure hien_ds(p_dau:p_hv);

var

i:integer;

begin

clrscr;

writeln(' BANG DIEM HOC VIEN');

writeln(' ==================');

writeln(' STT HO TEN DIEM TB');

p:=p_dau;

i:=0;

while (p<>nil) do

begin

i:=i+1;

with p^ do writeln(i:16,ho_ten:23,d_tb:16:1);

p:=p^.tiep;

end;

readln;

end;

Procedure chen(p_dau:p_hv);

var

bht:string[10];

ptim:p_hv;

begin

clrscr;

write('Nhap Ho ten can bo sung:'); readln(bht);

if bht<>'' then

begin

new(p);

p^.tiep:=nil;

p^.ho_ten:=bht;

write('Diem TB: '); readln(P^.d_tb);

write('Muon bo sung sau hoc vien nao: '); readln(bht);

ptim:=p_dau;

while (ptim<>nil) and (ptim^.ho_ten<>bht) do ptim:=ptim^.tiep;

if ptim=nil then writeln('Khong tim thay vi tri de bo sung ! ')

else

begin

if ptim^.tiep=nil then ptim^.tiep:=p

else

begin p^.tiep:=ptim^.tiep; ptim^.tiep:=p;

end; writeln('Da bo sung xong ! ');

end;

end;

readln;

end;

Procedure xoa(p_dau:p_hv);

var

bht:string[25];

ptr,ptim:p_hv;

begin

clrscr;

write('Nhap Ho ten hoc vien can xoa:'); readln(bht);

ptim:=p_dau;

while (ptim<>nil) and (ptim^.ho_ten<>bht) do

begin ptr:=ptim; ptim:=ptim^.tiep;

end;

if ptim=nil then writeln('Khong tim thay Hoc vien can xoa ! ')

else

begin

if ptim=pdau then pdau:=ptim^.tiep

else

if ptim^.tiep=nil then

ptr^.tiep:=nil

else ptr^.tiep:=ptim^.tiep;

dispose(ptim);

writeln('Da xoa xong ! ')

end;

readln;

end;

Begin

textmode(c80);

repeat

clrscr;

writeln(' CHON CHUC NANG CAN THUC HIEN');

writeln(' ============================');

writeln(' 1. Tao danh sach');

writeln(' 2. Chen them');

writeln(' 3. Loai bo');

writeln(' 4. Hien danh sach');

writeln(' 5. Ket thuc');

ch:=readkey;

case ch of

'1': tao_ds(pdau);

'2': chen(pdau);

'3': xoa(pdau);

'4': hien_ds(pdau);

end;

until ch='5';

End.

C5:Tep van ban cong ma tran

program Cau20_Tep_van_ban_Cong_Ma_tran;

uses crt;

var f:text;

a,b,c:array[1..10,1..10] of real;

i,j,n,m:byte;

tg:string[20];

begin

clrscr;

writeln('Nhap kich thuoc cua cac ma tran: ');

write('n= '); readln(n);

write('m= '); readln(m);

writeln;

writeln('Nhap ma tran A: ');

for i:=1 to n do

begin

for j:=1 to m do

begin

write('A[',i,',',j,']= '); readln(a[i,j]);

end;

writeln;

end;

writeln('Nhap ma tran B: ');

for i:=1 to n do

begin

for j:=1 to m do

begin

write('B[',i,',',j,']= '); readln(b[i,j]);

end;

writeln;

end;

for i:=1 to n do

for j:=1 to m do

c[i,j]:=a[i,j]+b[i,j];

writeln;

assign(f,'d:\ma_tran.pas'); rewrite(f);

writeln(f,n,' ',m);

writeln(f,'Ma tran A');

for i:=1 to n do

begin

for j:=1 to m do

write(f,a[i,j]:5:2,' ');

writeln(f);

end;

write(f,'Ma tran B');

writeln(f);

for i:=1 to n do

begin

for j:=1 to m do

write(f,b[i,j]:5:2,' ');

writeln(f);

end;

write(f,'Ma tran tong C=A+B'); writeln(f);

for i:=1 to n do

begin

for j:=1 to m do

write(f,c[i,j]:5:2,' ');

writeln(f);

end;

close(f);

writeln('Doc');

assign(f,'d:\ma_tran.pas');

reset(f);

while not eof(f) do

begin

readln(f,tg); writeln(tg);

end;

close(f);

readln;

end.

C6:Ma tran xoay

Program Ma_tran_xoay;

uses crt;

var a:array[1..15,1..15] of byte;

i,j:byte;

v,sv:byte;

n:byte;

t:byte;

begin

clrscr;

write('Nhap n= ');readln(n);

sv:=(n+1) div 2;

t:=0;

FOR v:=1 TO sv DO

Begin

For i:=v to n-v+1 do

begin

t:=t+1;

a[v,i]:=t;

end;

For i:=v+1 to n-v+1 do

begin

t:=t+1;

a[i,n-v+1]:=t;

end;

For i:=n-v downto v do

begin

t:=t+1;

a[n-v+1,i]:=t;

end;

For i:=n-v downto v+1 do

begin

t:=t+1;

a[i,v]:=t;

end;

End;

for i:=1 to n do

begin

for j:=1 to n do write(a[i,j]:6);

writeln;writeln;

end;

readln;

end.

C7: Do thi hinh sin

program Do_thi_hinh_SIN;

uses graph,crt;

var gd,gm:integer;

i,x,y,y2:integer;

begin

gd:=detect;

initgraph(gd,gm,'c:\tp\bgi');

setbkcolor(white);

setviewport(320,240,639,479,clipoff);

for i:=-300 to 300 do

begin

putpixel(i,0,red);

delay(3);

end;

setcolor(red);

line(300,0,295,3);line(300,0,295,-3);

for i:=220 downto -220 do

begin

putpixel(0,i,red);

delay(3);

end;

line(0,-220,3,-215);line(0,-220,-3,-215);

setcolor(3);

outtextxy(3,3,'0');

outtextxy(290,4,'x');

outtextxy(4,-215,'y');

setcolor(blue); outtextxy(180,160,'y=sin(x)');

setcolor(13); outtextxy(180,170,'y=2cos(x)+sin(x)');

for i:=-400 to 400 do

begin

x:=round(2*pi*i/200*20);

y:=round(sin(2*pi*i/200)*20);

y2:=round((2*cos(2*pi*i/200)+sin(2*pi*i/200))*20);

putpixel(x,-y,blue);

putpixel(x,-y2,13);

delay(3);

end;

readln;

closegraph;

end.

C8: Banh xe lan

program Banh_xe_lan;

uses graph,crt;

var goc:real;

gd,gm:integer;

mau:integer; x0,y0,x,y,r:integer;

i:byte;

dau:integer;

procedure nhoa(goc:real;mau:integer);

var x,y:integer;

begin x:=x0+round(r*cos(goc)); y:=y0+round(r*sin(goc));

setcolor(mau);

line(x0,y0,x,y);

end;

procedure bxe;

begin

setcolor(brown);

circle(x0,y0,r);

circle(x0,y0,r+3);

for i:=1 to 20 do

nhoa(goc+i*2*pi/20, i mod 15 +1);

end;

procedure xoa_bxe;

begin

setcolor(black);

circle(x0,y0,r);

circle(x0,y0,r+3);

for i:=1 to 20 do

nhoa(goc+i*2*pi/20,black);

end;

begin

gd:=0; initgraph(gd,gm,'c:\tp\bgi');

r:=100;

x0:=r+3;

y0:=getmaxy-200-r;

goc:=0;

dau:=1;

line(0,y0+r+4,getmaxx,y0+r+4);

repeat

x0:=x0+dau;

goc:=goc+dau*1/50;

bxe;

delay(10);

xoa_bxe;

if x0=getmaxx-r-3 then dau:=-1;

if x0= r then dau:=1;

until keypressed;

end.

C10:Ba hinh tron

program Ba_hinh_tron;

uses crt,graph;

var gd,gm:integer;

begin

gd:=0;

initgraph(gd,gm,'d:\tp\bgi');

setbkcolor(white);

setcolor(red);

circle(230,300,100);delay(500);

circle(400,300,100);delay(500);

circle(315,148,100);delay(500);

setfillstyle(1,lightgreen);

floodfill(310,300,red);delay(500);

setfillstyle(1,yellow);

floodfill(335,240,red);delay(500);

setfillstyle(1,brown);

floodfill(290,240,red);

readln;

end.

C11: La co viet nam

program La_co_Vietnam;

uses crt,graph;

var gd,gm:integer;

goc,r,i,j:integer;

p:array[1..10,1..2] of integer;

PROCEDURE sao(j:integer);

begin

goc:=36;

r:=20;

setcolor(yellow);

for i:=0 to 4 do

begin

p[2*i+1,1]:= round(r*sin(goc*pi/180))+149+j;

p[2*i+1,2]:= round(r*cos(goc*pi/180))+225;

goc:=goc+72;

end;

goc:=36+36;r:=8;

for i:=1 to 5 do

begin

p[2*i,1]:= round(r*sin(goc*pi/180))+149+j;

p[2*i,2]:= round(r*cos(goc*pi/180))+225;

goc:=goc+72;

end;

setfillstyle(1,yellow);

fillpoly(10,p);

end;

BEGIN

gd:=0; initgraph(gd,gm,'d:\tp\bgi');

setbkcolor(white);

for j:=-10 to 430 do

begin

cleardevice;

setfillstyle(1,lightgray);

bar(50+j,400,160+j,420);

bar(70+j,380,140+j,400);

setfillstyle(1,blue);

bar(100+j,200,110+j,380);

setfillstyle(1,red);

bar(110+j,200,200+j,250);

sao(j);

delay(10);

end;

readkey;

end.

C12:Chon chuc nang

uses crt;

const

scn=4;

dscn:array[1..scn] of string[15]=(' Tao Du lieu ',

' Nhap them ',

' Xoa Du lieu ',

' Ra khoi ');

mkchon=cyan;

mchon =red;

var

ch:char;

chon,i:integer;

Procedure Tao_dl;

begin

write('Tao du lieu');

readln;

end;

Procedure Them_dl;

begin

write('Nhap them');

readln;

end;

Procedure Xem_dl;

begin

write('Xem du lieu');

readln;

end;

Procedure hien_menu(sch,chon:integer);

const

bd=5;

cot=32;

Begin

textcolor(yellow); textbackground(red);

gotoxy(cot-1,bd); write('Chon chuc nang ');

for i:=1 to scn do

begin textbackground(mkchon); gotoxy(cot,bd+1+i); write(dscn[i]);

end; textbackground(mchon); gotoxy(cot,bd+1+chon); write(dscn[chon]);

end;

Procedure Chon_cn;

begin

repeat hien_menu(scn,chon);

ch:=readkey;

if ord(ch)=0 then { Ky tu dieu khien }

ch:=readkey; { Lay ky tu thu 2 }

case ord(ch) of

72: if chon>1 then { Chuyen len } chon:=chon-1

else

chon:=scn;

80: if chon<scn then { Chuyen xuong } chon:=chon+1

else

chon:=1;

end;

until ord(ch)=13;

end;

begin

textmode(c80);

chon:=1;

repeat textbackground(blue);

clrscr;

chon_cn; textbackground(black);

clrscr;

case chon of

1:tao_dl;

2:them_dl;

3:xem_dl;

end;

until chon=scn;

end.

C13: Hai day tang dan

Program Hai_day_tang_dan;

uses crt;

const max=32767;

var a,b,c:array[1..100] of integer;

m,n,k:byte;

i,j,t:byte;

begin

clrscr;

write('Nhap so phan tu cua day A: ');readln(m);

writeln('Nhap vao day A tang dan ');

for i:=1 to m do

begin

write('A[',i,']= ');readln(a[i]);

end;

a[m+1]:=max;

write('Nhap so phan tu cua day B: ');readln(n);

writeln('Nhap day B tang dan ');

for i:=1 to n do

begin

write('B[',i,']= ');readln(b[i]);

end;

b[n+1]:=max;

i:=1;

j:=1;

k:=1;

repeat

if a[i]<b[j] then

begin

c[k]:=a[i];

k:=k+1;

i:=i+1;

end

else

begin

c[k]:=b[j];

k:=k+1;

j:=j+1;

end;

until k=m+n+1;

writeln('Day C');

for t:=1 to m+n do

writeln('C[',t,']= ',c[t]);

readln;

end.

C14:Do thi ti trong cong nghiep

program Bieu_do;

uses crt,graph;

var gd,gm:integer;

cn,dv,nn:byte;

c,d,n:string[4];

begin

clrscr;

write('Nhap ti trong cua cong nghiep: '); readln(cn);

write('Nhap ti trong cua dich vu: '); readln(dv);

write('Nhap ti trong cua nong nghiep: '); readln(nn);

clrscr;

gd:=0; initgraph(gd,gm,'d:\tp\bgi');

setbkcolor(white); setcolor(red);

line(30,400,350,400);

line(30,400,30,40);

bar3d(100,400-4*cn,130,400,10,topon);

bar3d(200,400-4*dv,230,400,10,topon);

bar3d(300,400-4*nn,330,400,10,topon);

outtextxy(70,405,'Cong nghiep');

outtextxy(187,405,'Dich vu');

outtextxy(274,405,'Nong nghiep');

str(cn,c);c:=c+'%';

str(dv,d);d:=d+'%';

str(nn,n);n:=n+'%';

outtextxy(102,(400+(400-4*cn)) div 2,c);

outtextxy(202,(400+(400-4*dv)) div 2,d);

outtextxy(302,(400+(400-4*nn)) div 2,n);

outtextxy(200,430,'BIEU DO');

line(350,10,630,10);

line(350,25,630,25);

line(350,40,630,40);

line(350,10,350,40);

line(630,10,630,40);

line(450,10,450,40);

line(535,10,535,40);

outtextxy(355,15,'Cong nghiep');

outtextxy(465,15,'Dich vu');

outtextxy(540,15,'Nong nghiep');

outtextxy(390,30,c);

outtextxy(485,30,d);

outtextxy(570,30,n);

readln;

end.

C15:Dung Queue chuyen thap Ha noi

Uses crt; { Dung Queue chuyen thap Ha noi }

Type

p_node=^node;

node=record

t,cn,cd:byte; tiep:p_node;

end;

Var

front,rear,p:p_node;

st:integer;

Procedure Them_Q(n,c1,c2:byte);

begin

new(p);

with p^ do

begin tiep:=nil;

t:=n;

cn:=c1;

cd:=c2;

end;

if front=nil then

begin

front:=p;

rear:=p;

end

else

begin rear^.tiep:=p;

rear:=p;

end;

end;

Procedure Layra_Q(var p:p_node);

begin

p:=front;

front:=front^.tiep;

end;

Procedure chuyen_thap(n,c1,c3,c2:integer);

begin

if n=1 then

begin them_q(n,c1,c3);

end

else

begin

chuyen_thap(n-1,c1,c2,c3);

them_q(n,c1,c3);

chuyen_thap(n-1,c2,c3,c1);

end;

end;

Procedure hien_kq;

begin

writeln(' CAC BUOC CHUYEN');

writeln(' ===============');

while front<>nil do

begin

layra_q(p);

with p^ do

writeln('Chuyen tang ',st-t+1,' tu cot ',cn,' sang cot ',cd);

dispose(p);

end;

end;

Begin

textmode(c80);

textbackground(black);

write('Nhap so tang:');readln(st);

front:=nil;

rear :=nil;

chuyen_thap(st,1,3,2);

writeln;

hien_kq;

readln;

end.