Các bài tập Pascal thường gặp

PROGRAM NCK;
        VAR A,B:REAL;
        BEGIN
        WRITELN('NHAP A, B: ');
        READLN(A,B);
        IF (A=0) AND (B<=0) THEN WRITELN('VO NGHIEM');
        IF (A=0) AND (B>0) THEN WRITELN('X THUO^.C R');
        IF A<0 THEN WRITELN('NGHIEM: X<',-B/A:0:2);
        IF A>0 THEN WRITELN('NGHIEM: X>',-B/A:0:2);
        READLN;
        END.  

PROGRAM NCK;
        VAR N:BYTE;
        BEGIN
        WRITELN('NHAP N: ');
        READLN(N);
        IF N=1 THEN WRITE('1 = ONE');
        IF N=2 THEN WRITE('2 = TWO');
        IF N=3 THEN WRITE('3 = THREE');
        IF N=4 THEN WRITE('4 = FOUR');
        IF N=5 THEN WRITE('5 = FIVE');
        READLN;
        END.  

PROGRAM NCK;
        VAR A1, B1, C1, A2, B2, C2:INTEGER;
        DX, DY ,DD : REAL;
        BEGIN
        WRITELN('NHAP HE SO A1, B1, C1: ');
        READLN(A1, B1, C1);
        WRITELN('NHAP HE SO A2, B2, C2: ');
        READLN(A2, B2, C2);
        DD := A1*B2-A2*B1;
        DX := C1*B2-C2*B1;
        DY := A1*C2-A2*C1;
        IF DD = 0 THEN
        IF (DX=0) AND (DY=0 ) THEN
        WRITE('HPT VSN')
        ELSE WRITE('HPT VN')
        ELSE
        BEGIN
        WRITELN('HPT CO NGHIEM: ');
        WRITELN('X = ', DX/DD:2:2);
        WRITELN('Y = ', DY/DD:2:2);
        END;
        READLN;
        END.  

PROGRAM NCK;
        VAR XA, YA, XB, YB, XC, YC, AB, BC, AC, S, P: REAL;
        BEGIN
        WRITELN('NHAP TOA DO DIEM A(XA,YA): ');
        READLN(XA,YA);
        WRITELN('NHAP TOA DO DIEM B(XB,YB): ');
        READLN(XB,YB);
        WRITELN('NHAP TOA DO DIEM C(XC,YC): ');
        READLN(XC,YC);
        AB:=SQRT(SQR(XB-XA)+SQR(YB-YA));
        BC:=SQRT(SQR(XC-XB)+SQR(YC-YB));
        AC:=SQRT(SQR(XC-XA)+SQR(YC-YA));
        IF (AB=0) OR (BC=0) OR (AC=0) OR (AB+AC=BC) OR (AB+BC=AC) OR (AC+BC=AB)          THEN
        WRITELN('KHONG PHAI LA 3 DINH CUA TAM GIAC')
        ELSE
        BEGIN
        WRITELN('LA 3 DINH CUA TAM GIAC');
        IF (AB=BC) AND (AB=AC) THEN WRITELN('LA TAM GIAC DEU');
        IF (AB=BC) OR (AB=AC) OR (BC=AC) THEN WRITELN('LA TAM GIAC CAN');
        IF (SQR(AB)+SQR(AC)=SQR(BC)) OR (SQR(AB)+SQR(BC)=SQR(AC)) OR          (SQR(BC)+SQR(AC)=SQR(AB)) THEN
        WRITELN('LA TAM GIAC VUONG');
        P:=(AB+AC+BC)/2;
        S:=SQRT(P*(P-AB)*(P-AC)*(P-BC));
        WRITELN('DIEN TICH CUA TAM GIAC LA:',S:0:2);
        END;
        READLN;
        END.  

PROGRAM NCK;
        VAR G,C:REAL;
        BEGIN
        X+Y=36;
        2X+4Y=100;
        G:=0;
        C:=0;
        WHILE G<36 DO
        BEGIN
        C:=36-G;
        IF 2*G+4*C=100 THEN WRITELN('SO GA LA: ',G,' SO CHO LA: ',C);
        G:=G+1;
        END;
        READLN;
        END.  

PROGRAM G_PTB2; {AX*X+BX+C=0}
        USES CRT;
        VAR A, B, C: INTEGER;
        D, X1, X2: REAL;
        BEGIN
        CLRSCR;
        WRITELN('** GIAI PHUONG TRINH BAC 2 **');
        WRITELN('NHAP HE SO A, B, C: ');
        READLN(A, B, C);
        D:=SQR(B)-4*A*C;
        IF D=0 THEN
        WRITE('PT CO NGHIEM KEP X = ',-B/2*A:2:2)
        ELSE
        IF D>0 THEN
        BEGIN
        X1:=(-B+SQRT(D))/(2*A);
        X2:=(-B-SQRT(D))/(2*A);
        WRITELN('PT CO 2 NGHIEM: ');
        WRITELN('X1 = ', X1:2:2);
        WRITELN('X2 = ', X2:2:2);
        END
        ELSE WRITE('PT VN');
        READLN;
        END.  

PROGRAM          NCK; {MS: 639}
         USES CRT;
         VAR A:          ARRAY[1..100] OF INTEGER;
             I, N,          LN, NN: INTEGER;
         BEGIN
           CLRSCR;
                    WRITELN('** CHUONG TRINH NCK **');
          
                    WRITE('NHAP N PHAN TU: ');
                    READLN(N);
           FOR I:=1          TO N DO
               BEGIN
                          WRITE('A[',I,']=');
                          READLN(A[I]);
               END;
           LN:=A[1];          NN:=A[1];
           FOR I:=1          TO N DO
             BEGIN
               IF          A[I]>LN THEN LN:=A[I];
               IF          A[I]             END;
                    WRITELN('MAX: ', LN, '  MIN: ',NN);
           READLN
         END.  

program fibonaci;
uses crt;
var a:array [1..100] of integer;

    n,i,m,d,s:integer;

procedure fibonaci;
begin

     if n=1 then a[1]:=1
        else begin

               i:=2;s:=1;a[1]:=1;

               repeat

                     a[i]:=s;

                     i:=i+1;

                     s:=a[i-1]+a[i-2];



               until i>n;

          end;

      write(' Day so fibonaci la:');

      for i:=1 to n do

          write(' ',a[i]);

      writeln;

end;

begin

     clrscr;

     write(' Nhap so de tinh day fibonaci:');readln(n);

     write(' Nhap so de kiem tra xem co trong day fibonaci khong:');readln(m);

     fibonaci;

     d:=0;

     for i:=1 to n do

         if a[i]=m then d:=d+1;

     if d=1 then writeln(' So de kiem tra co mat trong day fibonaci')

     else writeln(' So kiem tra khong co mat trong day fibonaci');

     readln;

end.  

program hoanhao;

uses crt;

var n,i,d,k,j:integer;

procedure hoanhao;

begin
d:=0;
for i:=1 to n-1 do
if n mod i=0 then d:=d+i;
if d=n then writeln(' So vua nhap la so hoan hao')
else writeln(' So vua nhap khong la so hoan hao');

end;
procedure vietlen;
begin
write(' Day so hoan hao tu 1-->2000:');
k:=0;
for i:=1 to 2000 do
begin
d:=0;
for j:=1 to i-1 do
if i mod j=0 then d:=d+j;
if d=i then begin
  write(' ',i);
  k:=k+1;
  end;
end;
writeln;
  writeln(' Trong day 1-->2000 co ',k,' so hoan hao');
end;
begin
clrscr;
write(' Nhap n=');readln(n);
hoanhao;
vietlen;
readln;
end.  

program chuong_trinh;

uses crt;

var i,n,k,d:integer;

    ok:boolean;

function chanle(n:integer):boolean;

begin

     ok:=true;

     if n mod 2<>0 then ok:=false;

     chanle:=ok;

end;

function nguyento(n:integer):boolean;

begin

     ok:=true;

     d:=0;

     for i:=1 to n-1 do

         if n mod i=0 then d:=d+1;

     if d<>1 then ok:=false;

     nguyento:=ok;

end;

function chinhphuong(n:integer):boolean;

begin

     ok:=true;

     k:=trunc(sqrt(n));

     if sqr(k)<>n then ok:=false;

     chinhphuong:=ok;

end;

begin

     clrscr;

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

     if chanle(n) then writeln(' So vua nhap la chan')

     else writeln(' So vua nhap la so le');

     if nguyento(n) then writeln(' So vua nhap la nguyen to')

     else writeln(' So vua nhap khong phai la so nguyen to');

     if chinhphuong(n) then writeln(' So vua nhap la so chinh phuong')

     else writeln(' So vua nhap khong la so chinh phuong');

     readln;

end.  

program hahuy;
uses crt;
const input='input.txt';
      output='output.txt';

var f1,f2: text;
    st1,st2,key:string;
    dem,vt: integer;
begin
clrscr;
  assign(f1,input);  rewrite(f1);
  assign(f2,output);  rewrite(f2);
  writeln('nhap xau 1'); readln(st1); write(f1,st1); close(f1);
  writeln('nhap xau 2'); readln(st2); write(f2,st2); close(f2);

st1:=st1 + st2;
writeln('do dai xau s1 = ',length(st1) );
writeln(st1);

dem:=0;
key:='may man';
vt:=pos(key,st1);
while vt<>0 do
   begin
delete(st1,vt,length(key));
dem:=dem+1;
vt:=pos(key,st1);
   end;
  writeln('tu khoa ',key,' xuat hien ',dem,' lan');
  write(' HAHUY_NO1VN  ');
   readln;
end.  

Program giaithua;
uses crt;
var a: integerl=;
Function gt(n:byte):Longint;  
Var
  s:Longint;
  i:byte;
Begin
  s:=1
  For i:=2 to n do 
    s:=s*i;
  gt:=s;
End;
Begin
     clrscr;
     write ('Nhap so can tinh giai thua: ');readln(a);
     if a:=0 or a:=1 then
         writeln('Giai thua cua ',a,' = 1')
     else
         writeln('Giai thua cua',a ,' =', giaithua(a) );
End.  

program Mang;
uses crt; 
var  a:array [ 1..20] of byte;
      i,n,d,j,k:integer; 

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

procedure nguyento; 
begin      
        write(' Day so cac so nguyen to:'); 
        k:=0; 
        for i:=1 to n do 
             begin               
                  d:=0; 
                  for j:=1 to a[i]-1 do 
                       if a[i] mod j=0 then 
                              d:=d+1; 
                       if d=1 then 
                             begin                                
                                  write(' ',a[i]); 
                                  k:=k+1;                           
                             end; 
              end; 
        if k=0 then 
                 write(' khong co so nao') 
        else 
                begin                 
                        writeln; 
                         writeln(' Trong day co ',k,' so nguyen to'); 
                end; 
end; 

begin 
       clrscr; 
       repeat            
             write(' Nhap n=');readln(n); 
        until (2     
        nhap; 
        nguyento; 
   readln; 
end.  

program mang2; 
uses crt; 
var    a:array [1..20] of integer;     
        b:array [1..20] of integer;    
        i,n,max,j,tg:integer; 

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

end; 

procedure timmax; 
begin      
     max:=a[1];      
     for i:=2 to n do         
          if a[i]>max then 
          max:=a[i];   
   
          j:=1;       
           for i:=1 to n do          
             if a[i]=max then 
                begin                                
                     b[j]:=i;                                
                     j:=j+1;                           
                 end;     
             write(' So lon nhat trong day la ',max,' o vi tri thu');     

            for i:=1 to j-1 do          
                  write(', ',b[i]);      
                  writeln; 
end; 

procedure tang;
begin      
for i:=1 to n-1 do          
      for j:=i+1 to n do             
              if a[i]>a[j] then
                    begin                                     
                        tg:=a[i];                                     
                        a[i]:=a[j];                                     
                        a[j]:=tg;                                
                    end;     
            write(' Day duoc sap xep lai la:');      
            for i:=1 to n do          
                write(' ',a[i]); 
end;

begin     
     clrscr;      
repeat            
    write(' Nhap n=');readln(n);      
until (2     nhap;      
     timmax;      
     tang;      
     readln;

end.