Chào mừng bạn đến với Việt Cảnh.

» Tài khoản trên diễn đàn khác tài khoản tại Trang chủ, Tài khoản trên Trang chủ dành cho khách hàng. Click vào "Tạo tài khoản mới" để đăng ký.

Trả lời Viết bài mới Công cụ bài viết Kiểu hiển thị
Cũ 11-10-2011, 10:23 AM   #1
ItalyStar ItalyStar đang ẩn
Nghệ nhân bàn tay sắt
 
Avatar của ItalyStar
 
Tham gia tháng: Jun 2011
Bài gửi: 1.703 

Cấp độ: 34 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 84 / 843
Nội công: 567 / 8243
Kinh nghiệm: 73%

Cảm ơn: 37
Được cảm ơn 149 lần trong 110 bài viết
Mặc định Tổng hợp các bài tập Pascal

Bài tập về bản ghi:

Mã:
 Program banghi1;
 uses crt;
 type sv=record
 ma:string[5];
 ten:string[30];
 que:string[30];
 dtb:real;
 hb:longint;
 end;
 type mang=array[1..10] of sv;
var  i,j,n:integer;
 lop:mang;

 Procedure nhap(var lop:mang;n:integer);
 var i:integer;
 begin
 for i:= 1 to n do
 with lop[i] do
 begin
 write('Ma: ');readln(ma);
 Write('Ten: ');readln(ten);
 Write('Que: ');readln(que);
 Write('DTB: ');readln(dtb);
 if (dtb>=8) then hb:=240000
 else
   if dtb<7 then hb:=0
     else hb:=180000;
 writeln;
 end;
end;

procedure ht(lop:mang);
var i:integer;
begin
writeln('   TT    MA      HTEN          QUE      DTB          HB');
for i:=1 to n do
with lop[i] do
begin

writeln(i:5,ma:6,ten:8,que:15,dtb:10:2,hb:15);
{Writeln('Thong tin sinh vien thu ',i);
writeln('Ma sv: ',ma);
writeln('Ten SV:',ten);
writeln('Que quan: ',que);
writeln('Diem TB: ',dtb:2:2);
writeln('Tien HB: ',hb);}


end;
end;


function dem(lop:mang):integer;
var d,i:integer;
begin
d:=0;
for i:= 1 to n do
if lop[i].hb=240000 then d:=d+1;
dem:=d;
end;

Procedure que(lop:mang);
var i,j:integer;
begin
for i:=1 to n do
begin
for j:=1 to length(lop[i].que) do
lop[i].que[j]:=upcase(lop[i].que[j]);
{lop[i].que:=upcase(lop[i].que);}
if lop[i].que='NAM DINH' then
begin
writeln;
end;
end;
end;

procedure sx(lop:mang);
var tg:sv;
begin

for i:= 1 to n-1 do
for j:=i+1 to n do
if lop[j].ten<lop[i].ten then
begin
tg:=lop[i];
lop[i]:=lop[j];
lop[j]:=tg;
end;
     ht(lop);
end;

procedure chen(lop:mang);
var x:sv;
i:integer;
begin
Write('Nhap sinh vien x: ');
with x do
begin
 write('Ma: ');readln(ma);
 Write('Ten: ');readln(ten);
 Write('Que: ');readln(que);
 Write('DTB: ');readln(dtb);
 if (dtb>=8) then hb:=240000
 else
   if dtb<7 then hb:=0
     else hb:=180000;
 writeln;
end;
for i:=n+1 downto 1 do
if (lop[i-1].ten>x.ten) then lop[i]:=lop[i-1]
else  begin
      lop[i]:=x;n:=n+1;
      break;
      end;
      ht(lop)


end;

Procedure xoa(lop:mang);
var i,j,k:integer;
x:string[20];
begin
write('nhap ten can xoa: ');
readln(x);

for i:= 1 to n do
if lop[i].ten=x then
begin
for j:=i to n-1 do
lop[j]:=lop[j+1];
n:=n-1;
break;
end;
ht(lop);

end;



 BEGIN
 clrscr;
 writeln('nhap so thanh vien cua lop n= ');readln(n);
 nhap(lop,n);
 writeln;
 ht(lop);
 write('So SV co HB 240000 la: ',dem(lop));
 writeln;
 Writeln('Cac SV co que o Nam Dinh la:');
 que(lop);
 sx(lop);
 writeln;
 chen(lop);
 xoa(lop);
 readln;
 END.

Xem các bài viết tương tự:



  Trả lời với trích dẫn
Cũ 11-10-2011, 10:25 AM   #2
vietcanhvn vietcanhvn đang ẩn
Admin
 
Avatar của vietcanhvn
 
Tham gia tháng: May 2011
Đến từ: Nam Định
Tuổi: 26
Bài gửi: 2.975 

Cấp độ: 42 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 209 / 1047
Nội công: 991 / 10656
Kinh nghiệm: 90%

Cảm ơn: 299
Được cảm ơn 1.662 lần trong 848 bài viết
Gửi tin nhắn qua ICQ tới vietcanhvn Gửi tin nhắn qua AIM tới vietcanhvn Gửi tin nhắn qua Yahoo! tới vietcanhvn Gửi tin nhắn qua Skype™ tới vietcanhvn
Mặc định

Bài tập: Biểu diễn số tự nhiên n dưới dạng nhị phân:

Mã:
{bieu dien so n duoi dang nhi phan}
program NP;
var d,i,n,dem:integer;
    a:array[1..10] of integer;
begin
write('nhap n='); readln(n);
i:=1;
while n<>0 do
begin
a[i]:=(n mod 2);
n:=n div 2;
d:=i;
i:=i+1;
end;
for i:=d downto 1 do
write(a[i]);
dem:=0;
for i:=1 to d do
if a[i]=1 then dem:=dem+1;
writeln;
writeln('co ',dem,'so 1');
readln;
end.


  Trả lời với trích dẫn
Cũ 11-10-2011, 10:27 AM   #3
vietcanhvn vietcanhvn đang ẩn
Admin
 
Avatar của vietcanhvn
 
Tham gia tháng: May 2011
Đến từ: Nam Định
Tuổi: 26
Bài gửi: 2.975 

Cấp độ: 42 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 209 / 1047
Nội công: 991 / 10656
Kinh nghiệm: 90%

Cảm ơn: 299
Được cảm ơn 1.662 lần trong 848 bài viết
Gửi tin nhắn qua ICQ tới vietcanhvn Gửi tin nhắn qua AIM tới vietcanhvn Gửi tin nhắn qua Yahoo! tới vietcanhvn Gửi tin nhắn qua Skype™ tới vietcanhvn
Mặc định

Biểu diễn cây nhị phân trong pascal, có sửa, xóa, tìm kiếm, thêm bớt, đếm số nút trên cây:

Mã:
program cayNP;
uses crt;
type tree= ^nut;
     nut=record
     dl:integer;
     left,right:tree;
     end;
 mang=array[1..1000] of integer;
 var a:mang;
     i,n,x,k:integer;
     t,p,q:tree;

procedure tao(var t:tree;x:integer);
begin
if t=nil then
   begin
   new(t);
   t^.dl:=x;
   t^.left:=nil;
   t^.right:=nil;
   end
else
 if t^.dl<x then tao(t^.right,x)
 else
  if t^.dl>x then tao(t^.left,x);
end;

procedure nhap(a:mang;n:integer;var t:tree);
begin
for i:=1 to n do
begin
write('a[',i,']=');
readln(a[i]);
end;
for i:=1 to n do
tao(t,a[i]);
end;

procedure dt(var t:tree);
begin
if t<>nil then
begin
write(t^.dl,' ');
dt(t^.left);
dt(t^.right);
end;
end;

procedure dg(var t:tree);
begin
if t<>nil then
begin
dg(t^.left);
write(t^.dl,' ');
dg(t^.right);
end;
end;

procedure ds(var t:tree);
begin
if t<>nil then
begin
ds(t^.left);
ds(t^.right);
write(t^.dl,' ');
end;
end;



procedure search(var t:tree;x:integer);
var kt:boolean;
begin
writeln;
kt:=false;
while (t<>nil) and (not kt) do
begin
if t^.dl=x then kt:=true
else if t^.dl<x then t:=t^.right
else t:=t^.left;
end;
if kt then write(x,' co trong danh sach')
else write(x,' khong co trong danh sach');
end;


procedure add(var t:tree;x:integer);
var p:tree;
begin
if t=nil then
   begin
   new(p);
   p^.dl:=x;
   p^.left:=nil;
   p^.right:=nil;
   t:=p;
   end
   else
if t<>nil then
   begin
   if t^.dl>x then
      begin
      if t^.left=nil then
          begin
          new(p);
          p^.dl:=x;
          p^.left:=nil;
          p^.right:=nil;
          t^.left:=p;
          end
          else
          add(t^.left,x);
      end;
      if t^.dl=x then write('co roi');
      if t^.dl<x then
       begin
       if t^.right=nil then
           begin
           new(p);
           p^.dl:=x;
           p^.left:=nil;
           p^.right:=nil;
           t^.right:=p;
           end
           else add(t^.right,x);
       end;
      end;
end;

procedure del(var t:tree;k:integer);
var m,p,q,v:tree;
begin
     {tim phan tu can xoa k}
     p:=t;q:=nil;
     while p<>nil do
           begin
           if k>p^.dl then
                          begin
                          q:=p;
                          p:=p^.right;
                          end
           else
           if k<p^.dl then
                          begin
                          q:=p;
                          p:=p^.left;
                          end
           else break;
           end;

     {da tim duoc nut co gia tri bang k, thuc hien xoa}
     m:=p;
     if (p^.left=nil) and (p^.right=nil) then
        begin
        if q=nil then t:=nil
        else
        begin
        if  p=q^.left then q^.left:=nil
        else q^.right:=nil;
        end;
        dispose(m);
        end
     else
     if (p^.left=nil) and (p^.right<>nil) then
        begin
        if q=nil then t:=p^.right
        else
        begin
        if p=q^.left then q^.left:=p^.right
        else q^.right:=p^.right;
        end;
        m^.right:=nil;
        end
     else
     if (p^.left<>nil) and (p^.right=nil) then
        begin
        if q=nil then t:=p^.left
        else
        begin
        if p=q^.left then q^.left:=p^.left
        else q^.right:=p^.left;
        end;
        m^.left:=nil;
        end
     else
         begin
         q:=p^.left;v:=nil;
         while q^.right<>nil do
               begin
               v:=q;
               q:=q^.right;{sau vong while v tro vao nut cha of nut cuc phai}
               end;
         p^.dl:=q^.dl;
         if v<>nil then v^.right:=q^.left
         else p^.left:=nil;
         dispose(q);
         end;
         end;

BEGIN
clrscr;
write('nhap n= ');readln(n);
nhap(a,n,t);
write('duyet truoc: ');
dt(t);
writeln;
write('duyet giua:  ');
dg(t);
writeln;
write('duyet sau:   ');
ds(t);

{writeln;
write('nhap gia tri can bo xung x= ');readln(x);
writeln('duyet truoc cay vua bo xung');
add(t,x);
dt(t);}

{writeln;
write('nhap gia tri can tim x= ');readln(x);
search(t,x);
dt(t);}

writeln;
write('nhap gia tri can xoa k= ');readln(k);
del(t,k);
dt(t);
readln;
END.
http://VietCanh.com


  Trả lời với trích dẫn
Cũ 11-10-2011, 10:29 AM   #4
vietcanhvn vietcanhvn đang ẩn
Admin
 
Avatar của vietcanhvn
 
Tham gia tháng: May 2011
Đến từ: Nam Định
Tuổi: 26
Bài gửi: 2.975 

Cấp độ: 42 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 209 / 1047
Nội công: 991 / 10656
Kinh nghiệm: 90%

Cảm ơn: 299
Được cảm ơn 1.662 lần trong 848 bài viết
Gửi tin nhắn qua ICQ tới vietcanhvn Gửi tin nhắn qua AIM tới vietcanhvn Gửi tin nhắn qua Yahoo! tới vietcanhvn Gửi tin nhắn qua Skype™ tới vietcanhvn
Mặc định

Bìa tập in ra các số là số chính phương có trong dãy số từ 1-n:

Mã:
{in ra cac so chinh phuong}
program b1;
var i,n,kt:integer;
begin
write('nhap n=');readln(n);
i:=1;
while i<=n do
begin
if (frac(sqrt(i))=0) then
writeln(i);
i:=i+1;
end;
readln;
end.


  Trả lời với trích dẫn
Cũ 11-10-2011, 10:30 AM   #5
vietcanhvn vietcanhvn đang ẩn
Admin
 
Avatar của vietcanhvn
 
Tham gia tháng: May 2011
Đến từ: Nam Định
Tuổi: 26
Bài gửi: 2.975 

Cấp độ: 42 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 209 / 1047
Nội công: 991 / 10656
Kinh nghiệm: 90%

Cảm ơn: 299
Được cảm ơn 1.662 lần trong 848 bài viết
Gửi tin nhắn qua ICQ tới vietcanhvn Gửi tin nhắn qua AIM tới vietcanhvn Gửi tin nhắn qua Yahoo! tới vietcanhvn Gửi tin nhắn qua Skype™ tới vietcanhvn
Mặc định

Bài tập: Vừa gà vừa chó
bó lại cho tròn
vừa 36 con
100 chân chẵn
Hỏi: có bao nhiêu con gà, bao nhiêu con chó:

Mã:
{giai bai toan co tim so ga, so cho}
program gacho;
var x,i:integer;
begin
for x:=0 to 36 do
if (x*2+(36-x)*4=100) then
begin
writeln('so ga la: ',x);
writeln('so cho la: ',36-x);
end;
readln;
end.


  Trả lời với trích dẫn
Cũ 11-10-2011, 10:32 AM   #6
vietcanhvn vietcanhvn đang ẩn
Admin
 
Avatar của vietcanhvn
 
Tham gia tháng: May 2011
Đến từ: Nam Định
Tuổi: 26
Bài gửi: 2.975 

Cấp độ: 42 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 209 / 1047
Nội công: 991 / 10656
Kinh nghiệm: 90%

Cảm ơn: 299
Được cảm ơn 1.662 lần trong 848 bài viết
Gửi tin nhắn qua ICQ tới vietcanhvn Gửi tin nhắn qua AIM tới vietcanhvn Gửi tin nhắn qua Yahoo! tới vietcanhvn Gửi tin nhắn qua Skype™ tới vietcanhvn
Mặc định

Bài tập: Giải phương trình bậc 1 trong pascal:

Mã:
{giai phuong trinh ax+by=c}
program PT;
uses crt;
var x,y,a,b,c,m,n:integer;

begin
clrscr;
writeln('nhap a=');readln(a);
writeln('nhap b=');readln(b);
writeln('nhap c=');readln(c);
m:=c div a;
n:=c div b;
for x:=0 to m do
for y:=0 to n do
if ((a*x+b*y)<>c) then
continue
else
begin
writeln;
writeln('cap nghiem');
writeln('no x=',x);
writeln('no y=',y);
end;
readln;
end.


  Trả lời với trích dẫn
Cũ 11-10-2011, 10:33 AM   #7
vietcanhvn vietcanhvn đang ẩn
Admin
 
Avatar của vietcanhvn
 
Tham gia tháng: May 2011
Đến từ: Nam Định
Tuổi: 26
Bài gửi: 2.975 

Cấp độ: 42 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 209 / 1047
Nội công: 991 / 10656
Kinh nghiệm: 90%

Cảm ơn: 299
Được cảm ơn 1.662 lần trong 848 bài viết
Gửi tin nhắn qua ICQ tới vietcanhvn Gửi tin nhắn qua AIM tới vietcanhvn Gửi tin nhắn qua Yahoo! tới vietcanhvn Gửi tin nhắn qua Skype™ tới vietcanhvn
Mặc định

Bài tập về mảng 1 chiều, nhập dãy số tự nhiên n, đếm, kiểm tra các số nguyên tố, số chính phương, số hoàn hảo trong dãy đó:

Mã:
Program mang1c;
uses crt;
type mang=array[1..10] of integer;
var i,j,n,dem:integer;
    a:mang;


procedure nhap(var a:mang;n:integer);
var i:integer;
begin
for i:= 1 to n do
begin
write('Nhap phan tu a[',i,']=');
readln(a[i]);
end;
end;

procedure ht( a:mang);
begin
writeln('Mang vua nhap la:');
for i:=1 to n do
write(a[i],' ');
end;

{CT con kiem tra x co phai la so nguyen to khong}
function nt(x:integer):boolean;
var i,d:integer;
    kt:boolean;
begin
kt:=true;d:=0;
for i:=2 to x div 2 do
   if x mod i=0 then kt:=false;
   nt:=kt;
end;

{CT con kiem tra x co phai la so hoan hao khong}
Function hh(x:integer):boolean;
var i,tong:integer;
     kt:boolean;
     begin
     tong:=0;kt:=true;
     for i:=1 to x div 2 do
     if x mod i=0 then tong:=tong+i;
     if tong<>x then kt:=false;
     hh:=kt;
     end;


{CT con kiem tra x co phai la so chinh phuong khong}
function cp(x:integer):boolean;
var kt:boolean;
begin
kt:=false;
if frac(sqrt(abs(x)))=0 then kt:=true;
cp:=kt;
end;

{Hien thi doan co nhieu so duong nhat}
procedure duong(a:mang);
var d,j,max,vd:integer;
begin
d:=0;max:=0;
for i:=1 to n+1 do
if(a[i]>0) then inc(d)
else
 if max<d then
   begin
   max:=d;
   vd:=i-d;
   d:=0;
   end;
for j:=vd to vd+max-1 do write(a[j],' ');
end;


BEGIN
clrscr;
write('Nhap so phan tu cua mang n=');readln(n);
nhap(a,n);
ht(a);


dem:=0;
for i:=1 to n do
if nt(a[i])and (a[i]>1) then
begin
writeln;
write('So nguyen to la: ',a[i]);
dem:=dem+1;
end;
writeln;
write('So so nguyen to la: ',dem);

Writeln;
dem:=0;
for i:=1 to n do
if hh(a[i]) then
begin
writeln;
write('So hoan hao la: ',a[i]);
dem:=dem+1;
end;
writeln;
Write('So so hoan hao la: ',dem);

writeln;
writeln;
dem:=0;
for i:=1 to n do
if cp(a[i]) then
begin
writeln('So chinh phuong la: ',a[i]);
dem:=dem+1;
end;
write('So so chinh phuong la: ',dem);

writeln;
writeln('Doan co nhieu so duong la:');
duong(a);

readln;
END.


  Trả lời với trích dẫn
Cũ 11-10-2011, 10:33 AM   #8
vietcanhvn vietcanhvn đang ẩn
Admin
 
Avatar của vietcanhvn
 
Tham gia tháng: May 2011
Đến từ: Nam Định
Tuổi: 26
Bài gửi: 2.975 

Cấp độ: 42 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 209 / 1047
Nội công: 991 / 10656
Kinh nghiệm: 90%

Cảm ơn: 299
Được cảm ơn 1.662 lần trong 848 bài viết
Gửi tin nhắn qua ICQ tới vietcanhvn Gửi tin nhắn qua AIM tới vietcanhvn Gửi tin nhắn qua Yahoo! tới vietcanhvn Gửi tin nhắn qua Skype™ tới vietcanhvn
Mặc định

Bài tập mảng 2 chiều:

Mã:
{viet chuong trinh nhap 1 ma tran, hien thi ma tran, dem xem tren duong cheo phu co bao nhieu so chia het cho ca 3 va 4,
tinh tong 2 duong cheo, tim cac so am va dua ra so am nho nhat, dua ra phan tu chi xuat hien 1 lan, chuyen ma tran ve mang 1 chieu.
}
program matran;
uses crt;
var
a:array[1..10,1..10] of integer;
b:array[1..20] of integer;
tong,n,i,j,x,y,c,d,kt,k:integer;
ok:boolean;
begin
clrscr;
writeln('nhap cap ma tran: n=');readln(n);
for i:=1 to n do
for j:=1 to n do
begin
write('nhap pt a[',i,',',j,']=');
readln(a[i,j]);
end;
writeln('mang vua nhap la:');
for i:=1 to n do
begin
for j:=1 to n do
write(a[i,j],' ');
writeln;
end;
{dg chep phu co bao nhieu so:3,4}
d:=0;
for i:=1 to n do
if (a[i,n-i+1] mod 12=0) then d:=d+1;
writeln('dg cheo fu co',d,'so chia het cho 3 va 4');
{tong cac pt tren 2 dc}
tong:=0;
for i:=1 to n do
tong:=tong+a[i,i]+a[i,n-i+1];
if n mod 2=0 then
writeln('tong la:',tong)
else
writeln('tong la',tong-a[(n+1)div 2,(n+1)div 2]);
{tim so am nho nhat}
d:=1;
for i:=1 to n do
for j:=1 to n do
if a[i,j]<0 then
begin
b[d]:=a[i,j];
d:=d+1;
end;
writeln('cac so am la:');
for k:=1 to d-1 do
write(b[k],' ');
writeln;
{so am nho nhat}
kt:=b[1];
for i:=2 to d-1 do
if (b[i]<kt) then kt:=b[i];
writeln('phan tu am nho nhat trong mang la:',kt);

{Pt chi xh 1 lan
for i:=1 to n do
for j:=1 to n do
begin
x:=a[i,j];
ok:=true;
for c:=1 to n do
for d:=1 to n do
begin
if a[c,d]=x then
ok:=false;
if ok then writeln('so xh 1 lan la',x);
end;
end;
 }



{chuyen sang mang 1c}
j:=1;
for d:=1 to n do
for c:=1 to n do
begin
b[j]:=a[d,c];
j:=j+1;
end;
writeln('mang vua duoi la:');
for i:=1 to n*n do
write(b[i], ' ');

      writeln;


for i:=1 to n do
for j:=1 to n do
begin
ok:=true;
for d:=1 to n do

for  c:=1 to n do
if (( (i<>d) or (j<>c)) and(a[i,j]=a[d,c])) then ok:=false;
 if ok then writeln('pt chi xh 1 lan la',a[i,j]);
 end;



readln;
end.


  Trả lời với trích dẫn
Cũ 11-10-2011, 10:35 AM   #9
vietcanhvn vietcanhvn đang ẩn
Admin
 
Avatar của vietcanhvn
 
Tham gia tháng: May 2011
Đến từ: Nam Định
Tuổi: 26
Bài gửi: 2.975 

Cấp độ: 42 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 209 / 1047
Nội công: 991 / 10656
Kinh nghiệm: 90%

Cảm ơn: 299
Được cảm ơn 1.662 lần trong 848 bài viết
Gửi tin nhắn qua ICQ tới vietcanhvn Gửi tin nhắn qua AIM tới vietcanhvn Gửi tin nhắn qua Yahoo! tới vietcanhvn Gửi tin nhắn qua Skype™ tới vietcanhvn
Mặc định

Bài tập sử dụng giải thuật mergesort sắp xếp 2 dãy số tự nhiên:

Mã:
program megersort;
uses crt;
type mang=array[1..100] of integer;
var a,b,c:mang;           {Ax,Ax+1,Ax+2,....,An}
  i,j,n,m:integer;          {By,By+1,By+2,....,Bm}

  procedure meger(a,b:mang;var c:mang;n,m:integer);
  var k,t,x,y:integer;
     begin
        i:=1;j:=1;k:=1;
      while (i<=n) and (j<=m) do
        begin
        if a[i]<b[j] then
          begin
           c[k]:=a[i];
           i:=i+1;k:=k+1;
          end
         else
           begin
            c[k]:=b[j];
            j:=j+1;k:=k+1;
            end;
         end;
  if i>n then
     for t:=j to m do
         begin
         c[k]:=b[t];
         k:=k+1;
         end
  else
      for t:=i to n do
          begin
          c[k]:=a[t];
          k:=k+1;
          end;

          for i:=1 to k-1 do
          write(c[i],' ');
  end;

  procedure nhap(var a:mang;n:integer);
  var i:integer;
  begin
  for i:=1 to n do
  begin
  write('a[',i,']=');readln(a[i]);
  end;
  end;

  procedure hta(a:mang;n:integer);
  var i:integer;
  begin
  writeln('day vua nhap la: ');
  for i:=1 to n do
  write(a[i],' ');
  end;

    procedure htb(b:mang;m:integer);
  var i:integer;
  begin
  writeln('day vua nhap la: ');
  for i:=1 to m do
  write(b[i],' ');
  end;

  BEGIN
  clrscr;
  write('nhap n= ');readln(n);
  nhap(a,n);
  hta(a,n);
  writeln;
  write('nhap m= ');readln(m);
  nhap(b,m);
  htb(b,m);
  writeln;
  meger(a,b,c,n,m);
  readln;
  END.


  Trả lời với trích dẫn
Cũ 11-10-2011, 10:41 AM   #10
vietcanhvn vietcanhvn đang ẩn
Admin
 
Avatar của vietcanhvn
 
Tham gia tháng: May 2011
Đến từ: Nam Định
Tuổi: 26
Bài gửi: 2.975 

Cấp độ: 42 [♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥♥ VietCanh ♥]
Sức mạnh: 209 / 1047
Nội công: 991 / 10656
Kinh nghiệm: 90%

Cảm ơn: 299
Được cảm ơn 1.662 lần trong 848 bài viết
Gửi tin nhắn qua ICQ tới vietcanhvn Gửi tin nhắn qua AIM tới vietcanhvn Gửi tin nhắn qua Yahoo! tới vietcanhvn Gửi tin nhắn qua Skype™ tới vietcanhvn
Mặc định

Bài tập biểu diễn cây nhị phân 2, đếm, sửa, xóa nút trên cây:

Mã:
program cay_NP;
uses crt;
type tree=^nut;
     nut=record
     dl:integer;
     l,r:tree;
     end;
     mang=array[1..100] of integer;
var i,j,n,x,f,k:integer;
    a:mang;
    t:tree;

procedure tao(var t:tree;x:integer);
var l,r:tree;
begin
     if t=nil then
        begin
        new(t);
        t^.dl:=x;
        t^.l:=nil;
        t^.r:=nil;
        end
     else
         if x>t^.dl then tao(t^.r,x)
            else if x<t^.dl then tao(t^.l,x);
end;

procedure taocay(var t:tree;a:mang);
var x:integer;
    l,r:tree;
begin
     for i:=1 to n do
     begin
     write('a[',i,']=');readln(a[i]);
     tao(t,a[i]);
     end;

end;

procedure dt(t:tree;a:mang);
begin
if t<>nil then
begin
write(t^.dl,' ');
dt(t^.l,a);
dt(t^.r,a);
end;
end;

procedure dg(t:tree;a:mang);
begin
if t<> nil then
begin
dg(t^.l,a);
write(t^.dl,' ');
dg(t^.r,a);
end;
end;

function found(t:tree;x:integer):boolean;
var kt:boolean;
begin
kt:=false;
while (t<>nil) and (t^.dl<>x) do
      begin
      if x>t^.dl then t:=t^.r
      else t:=t^.l;
      end;
if t<> nil then kt:=true;
found:=kt;
end;

procedure bs(var t:tree;x:integer);
var p,q,v:tree;
begin
  if t=nil then
     begin
     new(p);
     p^.dl:=x;
     p^.l:=nil;
     p^.r:=nil;
     t:=p;
     end
  else
  p:=t;q:=p;
  while p<>nil do
  begin
  if x>p^.dl then
             begin
             q:=p;
             p:=p^.r;
             end
  else
  if x<p^.dl then
             begin
             q:=p;
             p:=p^.l;
             end;
  end;
  new(v);
  v^.dl:=x;
  v^.l:=nil;
  v^.r:=nil;
  if x>q^.dl then q^.r:=v
  else if x<q^.dl then q^.l:=v;
  dt(t,a);
end;

procedure del(t:tree;x:integer);
var p,q,v,m:tree;
begin
p:=t;q:=nil;
while p<> nil do
      begin
      if x>p^.dl then
                 begin
                 q:=p;
                 p:=p^.r;
                 end
      else
      if x<p^.dl then
                 begin
                 q:=p;
                 p:=p^.l
                 end
      else break;
      end;
m:=p;
if (p^.l=nil) and(p^.r=nil) then
   begin
   if q=nil then t:=nil
   else
   if p=q^.r then q^.r:=nil
   else q^.l:=nil;
   dispose(m);
   end
else
if (p^.l<>nil) and (p^.r=nil) then
   begin
   if q=nil then t:=p^.l
   else
   if p=q^.r then q^.r:=p^.l
   else q^.l:=p^.l;
   m^.l:=nil;
   end
   else
if (p^.l=nil) and(p^.r<>nil) then
   begin
   if q=nil then t:=p^.r
   else
   begin
   if p=q^.r then q^.r:=p^.r
   else q^.l:=p^.r;
   end;
   m^.r:=nil;
   end
else
v:=nil;q:=p^.l;
while q^.r<>nil do
      begin
      v:=q;
      q:=q^.r;
      end;
p^.dl:=q^.dl;
if v<>nil then v^.r:=q^.l
else p^.l:=nil;
dispose(q);
dt(t,a);
end;

function dem(t:tree):integer;
var d:integer;
begin
d:=0;
if t<>nil then
begin
if (t^.l=nil) and (t^.r=nil) then
d:=1+dem(t^.l)+dem(t^.r)
else d:=dem(t^.l)+dem(t^.r);
end;
dem:=d;
end;


function deml1(t:tree):integer;
var d:integer;
begin
d:=0;
if t<>nil then
begin
if (((t^.l=nil) and (t^.r<>nil)) or ((t^.l<>nil) and (t^.r=nil))) then
d:=1+deml1(t^.l)+deml1(t^.r)
else d:=deml1(t^.l)+dem(t^.r);
end;
deml1:=d;
end;


BEGIN
clrscr;
write('nhap so nut n= ');readln(n);
taocay(t,a);
writeln;
write('duyet truoc: ');dt(t,a);
writeln;
write('duyet giua: ');dg(t,a);
{writeln;
write('nhap gia tri can bo xung k= ');readln(k);
if found(t,k) then write('trong day co roi')
else
begin
writeln('cay sau khi bo xung la: ');
bs(t,k);
end;          }
{writeln;
write('nhap gia tri can xoa x= ');readln(x);
if not found(t,x) then write('khong tim thay')
else
begin
writeln('cay sau khi xoa la: ');
del(t,x);
end;}

writeln;
write('so nut la la: ',dem(t));
writeln;
write('so nut la bac 1 la: ',deml1(t));
readln;
END.


  Trả lời với trích dẫn
Trả lời

Tags
bai tap pascal, bai tap ve tep trong pascal, bieu dien cay nhi phan trong pascal, bieu dien so tu nhien n duoi dang nhi phan, giai phuong trinh bac 1, giai phuong trinh bac 2 trong pascal, in ra so chinh phuong, kiem tra so chinh phuong, mang 1 chieu trong pascal, mang 2 chieu trong pascal, xay dung ban ghi trong pascal
Công cụ bài viết
Kiểu hiển thị

Quyền viết bài
Bạn không thể gửi chủ đề mới
Bạn không thể gửi trả lời
Bạn không thể gửi file đính kèm
Bạn không thể sửa bài viết của mình

BB code đang Mở
Mặt cười đang Mở
[IMG] đang Mở
HTML đang Tắt

Chuyển đến

sửa laptop uy tín hà nội | Ảnh Sex