Programming in Pascal

For III semester students of B.E Computer science,Bangalore University 

Contents

1.
PROGRAM binary_search;

{Program to search a number using binary search}

USES crt;

TYPE index=1..100;
VAR  arr:ARRAY[1..100] OF index;
VAR  mid,low,high,search:integer;
     i,n:index;
     found:boolean;

BEGIN
     clrscr;
     writeln('BINARY SEARCH');
     writeln('Enter the array size');
     readln(n);
     writeln('Enter the array elements');
     FOR i:=1 TO n DO
     BEGIN
          readln(arr[i]);
     END;
     writeln('Enter the search element');
     readln(search);
     low:=1;
     high:=n;
     found:=false;
     REPEAT
           mid:=trunc(low+high) DIV 2;
           IF (search<arr[mid]) THEN
           high:=mid-1;
           IF (search>arr[mid]) THEN
           low:=mid+1;
           IF (search=arr[mid]) THEN
           found:=true
           ELSE
           found:=false;
     UNTIL ((found=true) OR (high<low));
     IF found=true THEN writeln('ELEMENT FOUND')
     ELSE writeln('ELEMENT NOT FOUND');
END.

2.
PROGRAM linear_search;

{Program to search a number using linear search}

USES crt;

TYPE index=1..100;

VAR n,searchkey,i:integer;
    found:boolean;
    arr:ARRAY[1..100] OF index;

BEGIN
     writeln('LINEAR SEARCH');
     writeln('Enter the boundary of the array');
     readln(n);
     writeln('Enter the array elements');
     FOR i:=1 TO n DO
     BEGIN
          readln(arr[i]);
     END;
     i:=1;
     found:=false;
     writeln('Enter the search element');
     readln(searchkey);
     WHILE ((i<=n) AND (found=false)) DO
     BEGIN
          IF arr[i]=searchkey THEN
          found:=true
          ELSE found:=false;
          i:=i+1;
     END;
     IF found=true THEN
     writeln('ELEMENT FOUND')
     ELSE
     writeln('ELEMENT NOT FOUND');
END.

3.
PROGRAM bubble_sort;

CONST items=100;

VAR n,temp,pass,index:integer;
    sorted:boolean;
    vector:ARRAY[1..items] of integer;

PROCEDURE sort;

BEGIN
     pass:=1;
     REPEAT
           sorted:=true;
           FOR index:=1 TO items-pass DO
           BEGIN
                IF vector[index]>vector[index+1] THEN
                BEGIN
                     sorted:=false;
                     temp:=vector[index];
                     vector[index]:=vector[index+1];
                     vector[index+1]:=temp;
                END;
           END;
           pass:=pass+1;
     UNTIL sorted;
END;

BEGIN
     writeln('How many elements');
     readln(n);
     writeln('Enter the unsorted elements');
     index:=1;
     REPEAT
     readln(vector[index]);
     index:=index+1;
     UNTIL index=n+1;
     sort;
     writeln('Sorted Data');
     FOR index:=1 TO items DO
     BEGIN
          IF ((index-1) MOD 10)=0 THEN writeln;
          writeln(vector[index]:4);
     END;
     writeln('Total number of passes=> ',pass);
     writeln;
END.

4.
PROGRAM insertion_sort;

{Program to sort the given nos using insertion sort}

USES crt;

VAR a:ARRAY[1..100] of real;

VAR temp:real;
    i,j,n:integer;

BEGIN
     clrscr;
     writeln('Enter the boundary of the array');
     readln(n);
     writeln('Enter the elements of the array');
     FOR i:=1 TO n DO
     BEGIN
          readln(a[i]);
     END;
     FOR i:=2 TO n DO
     BEGIN
          j:=i-1;
          WHILE ((j>=1) AND (a[j+1]<a[j])) DO
          BEGIN
               temp:=a[j];
               a[j]:=a[j+1];
               a[j+1]:=temp;
               j:=j-1;
          END;
     END;
     writeln('The sorted elements are as follows');
     FOR i:=1 TO n DO
     writeln(a[i]);
END.

5.
program QSort;
{$R-,S-}
uses Crt;

{ This program demonstrates the quicksort algorithm, which      }
{ provides an extremely efficient method of sorting arrays in   }
{ memory. The program generates a list of 1000 random numbers   }
{ between 0 and 29999, and then sorts them using the QUICKSORT  }
{ procedure. Finally, the sorted list is output on the screen.  }
{ Note that stack and range checks are turned off (through the  }
{ compiler directive above) to optimize execution speed.        }

const
  Max = 1000;

type
  List = array[1..Max] of Integer;

var
  Data: List;
  I: Integer;

{ QUICKSORT sorts elements in the array A with indices between  }
{ LO and HI (both inclusive). Note that the QUICKSORT proce-    }
{ dure provides only an "interface" to the program. The actual  }
{ processing takes place in the SORT procedure, which executes  }
{ itself recursively.                                           }

procedure QuickSort(var A: List; Lo, Hi: Integer);

procedure Sort(l, r: Integer);
var
  i, j, x, y: integer;
begin
  i := l; j := r; x := a[(l+r) DIV 2];
  repeat
    while a[i] < x do i := i + 1;
    while x < a[j] do j := j - 1;
    if i <= j then
    begin
      y := a[i]; a[i] := a[j]; a[j] := y;
      i := i + 1; j := j - 1;
    end;
  until i > j;
  if l < j then Sort(l, j);
  if i < r then Sort(i, r);
end;

begin {QuickSort};
  Sort(Lo,Hi);
end;

begin {QSort}
  Write('Now generating 1000 random numbers...');
  Randomize;
  for i := 1 to Max do Data[i] := Random(30000);
  Writeln;
  Write('Now sorting random numbers...');
  QuickSort(Data, 1, Max);
  Writeln;
  for i := 1 to 1000 do Write(Data[i]:8);
end.

6.
PROGRAM backwards;

{This program reads a line of text and writes it out in a reverse order}

USES crt;

PROCEDURE flipit;

{Reads single characters recursively and then writes them out}

VAR c:char;

{The procedure flipit is the key thing in this program.First it reads
a single character and then makes sure (checks) that it is not an end
of line,and if this condition satisfies then it once again goes to the
procedure flipit and reads the next single character.This process continues
until the end of line is detected,after which the computer writes out the
output in the order of the most recent character written first (i.e., the
character where the end of line was encountered) and the first character
written last.Hence we get a line of text written in a reverse order in the
output.}

BEGIN
     read(c);
     IF NOT eoln THEN flipit;
     write(c)
END;

BEGIN
     clrscr;
     writeln('Enter a line of text');
     writeln;
     flipit;
END.

7.
 PROGRAM factorial;

{Program to calculate the factorial of a number using recursive function}

VAR x:integer;

FUNCTION fact(n:integer):integer;

BEGIN
     IF n<=1 THEN fact:=1
     ELSE fact:=n*fact(n-1);
END;

BEGIN
     writeln('Enter any integer');
     read(x);
     writeln('The factorial is ',fact(x))
END.

8.
PROGRAM fibonacci_series;

(*Program to find the fibonacci series upto a given number*)

VAR a,b,j,n:integer;

PROCEDURE fib(a,b,j:integer);

BEGIN
     IF j>0 THEN
     BEGIN
          WHILE j<>a DO
          BEGIN
          writeln(a:1,' ');
          fib(b,a+b,j-1);
          END;
     END;
END;
BEGIN
     writeln('FIBONACCI SERIES');
     writeln;
     writeln('Enter any number');
     readln(n);
     writeln;
     IF n<=0 THEN writeln('Invalid Entry,please try again!')
     ELSE
     fib(0,1,n);
END.

9.
PROGRAM gcd_recursion;

{Program to calculate the GCD of 2 nos using recursive function}

USES crt;

VAR a,b:integer;

FUNCTION gcd(p,q:integer):integer;

BEGIN
     IF p<q THEN
        BEGIN
             gcd:=gcd(q,p);
        END
     ELSE
        IF q=0 THEN
           BEGIN
                gcd:=p;
           END
        ELSE
            gcd:=gcd(q,p MOD q);
END;

BEGIN
     clrscr;
     writeln('Enter any two elements');
     readln(a,b);
     gcd(a,b);
     writeln('The gcd of two numbers is ',gcd(a,b));
END.

10.
PROGRAM fact1;

{Factorial of a number}

USES crt;

VAR n:integer;

FUNCTION fact(i:integer):integer;

VAR prod1:integer;

BEGIN
     BEGIN
          prod1:=1;
          REPEAT
          prod1:=prod1*i;
          i:=i-1;
          UNTIL i = 1;
     END;
writeln('The factorial of ',n,' is ',prod1)
END;

BEGIN
     clrscr;
     writeln('Enter any number');
     read(n);
     fact(n);

END.

11.
PROGRAM gcd;

(*program to find the gcd of two numbers*)

USES crt;

VAR a,b,c,d,i:integer;

BEGIN
     clrscr;
     writeln('Enter any two integers');
     readln(a,b);
     IF a<=b THEN c:=a;
     c:=b;
     FOR i:=1 TO c DO

         BEGIN

              IF (a MOD i=0)AND(b MOD i=0) THEN
              d:=i;
         END;

     writeln('The GCD of two numbers is ',d);
END.

12.
PROGRAM file_create;

TYPE student=RECORD
                   name:string[20];
                   rollno,marks:integer;
             END;
VAR n,i:integer;
    data:student;
    file1:FILE OF student;

BEGIN
     writeln('Program to create a sequential file of student data');
     assign(file1,'file1.dat');
     rewrite(file1);
     REPEAT
           write('Enter the number of students:');
           readln(n);
     UNTIL n>0;
     FOR i:=1 TO n DO
         WITH data DO
         BEGIN
              write('NAME : ');
              readln(name);
              write('ROLL NO : ');
              readln(rollno);
              write('MARKS : ');
              readln(marks);
              write(file1,data);
         END;
         reset(file1);
         writeln('The data file contains the following information: ');
         writeln('NAME':15,'':12,'ROLL NO.':8,'MARKS':10);
         WHILE (NOT eof(file1)) DO
         BEGIN
              read(file1,data);
              WITH data DO
                   writeln(name:20,rollno:12,marks:12);
         END;
END.

13.
PROGRAM function_procedure_parameter;

VAR x:real;

          FUNCTION f1(a:real):real;

          BEGIN
                f1:=sqr(a);
          END;

    PROCEDURE p(x:real);
                                 {A function is declared within a Procedure}
          FUNCTION f(x:real):real;

          VAR y:real;

          BEGIN
               y:=f(x);
               writeln('The output is...');
               writeln(y);
          END;

BEGIN            {main program statements}
     x:=9;
     p(x,f1);
END.

14.
PROGRAM towers_of_hanoi;

{This program solves a well known game using recursive procedures calls
and user defined data}

TYPE poles=(left,centre,right);
     disks=0..maxint;

VAR n:disks;

    PROCEDURE transfer(n:disks;origin,destination,other:poles);

    {Note that origin,destination and other are formal parameters for the
    procedure transfer,they are supposed to be replaced by the actual parameter
    left,centre,right in the procedure reference in the main program}

    {Transfer n disks from the origin to the destination}

              PROCEDURE diskmove(origin,destination:poles);

              {Move a single disk from the origin to the destination}
              BEGIN
                   write('Move ');
                   CASE origin OF
                        left    :IF destination=centre
                                 THEN writeln('left to centre')
                                 ELSE writeln('left to right');
                        centre  :IF destination=left
                                 THEN writeln('centre to left')
                                 ELSE writeln('centre to right');
                        right   :IF destination=centre
                                 THEN writeln('right to centre')
                                 ELSE writeln('right to left');
                   END;          {End case}
              END;               {End diskmove}
    BEGIN     {Transfer}
              IF n>0 THEN BEGIN
                          transfer(n-1,origin,other,destination);
                          diskmove(origin,destination);
                          transfer(n-1,other,destination,origin);
                          END;
    END;                  {End Transfer}

BEGIN                     {Main action block}
     write('Enter the number of disks->');
     readln(n);
     writeln;
     transfer(n,left,right,centre);  {Transfer n disk from left to right}
END.

15.
PROGRAM matrix1;

{Program that declares a integer matrix and initializes it to 1's
on the diagonal and 0's elsewhere}

VAR arr:ARRAY[1..100,1..100] OF integer;
    i,j,index,m,n:integer;

BEGIN
     writeln;
     writeln('Enter the number of rows and columns');
     readln(m,n);
     FOR i:=1 TO m DO
     BEGIN
          FOR j:=1 TO n DO
          BEGIN
               IF i=j THEN
               arr[i,j]:=1
               ELSE
               arr[i,j]:=0;
               IF ((j-1) MOD n)=0 THEN writeln;
               write(' ',arr[i,j],' ');
          END;
     END;

END.

16.
PROGRAM power;

{Program that will allow an integer type number to be raised to an
integer type power}

USES crt;

VAR x,y:integer;

PROCEDURE pow(a,b:integer);

{Procedure to calculate x^y}

VAR count,expo:integer;

BEGIN
     count:=1;
     expo:=1;
     FOR count:=1 TO b DO
         BEGIN
              expo:=expo*a;
         END;
         writeln('The answer is ',expo);
END;

BEGIN
     clrscr;
     writeln('Program to calculate "x to the power of y" ');
     writeln;
     writeln('Enter any two numbers x & y');
     readln(x,y);
     pow(x,y);
END.

17.
PROGRAM prime_check;

VAR n,i,s:integer;
    flag:boolean;

BEGIN
     writeln('Enter any number');
     readln(n);
     flag:=false;
     s:=trunc(sqrt(n*1.0));
     FOR i:=2 TO s DO
     IF ((n MOD i)=0) THEN
     flag:=false
     ELSE
     flag:=true;
     IF flag=true THEN writeln('It is a Prime number')
     ELSE
     writeln('Not a prime number');
END.

18.
PROGRAM prime_generation;

VAR i,j,k,n:integer;

BEGIN
     writeln('Enter any number');
     readln(n);
     FOR i:=2 TO n DO
     BEGIN
          k:=0;
          FOR j:=1 TO n DO
          IF i MOD j =0 THEN k:=k+1;
          IF k<=2 THEN writeln(i);
     END;
END.

19.
PROGRAM graph;

CONST scale=30;
      centre=40;
      increment=15;
      PI=3.14159;

VAR i,angle:integer;

    FUNCTION sinetrace:integer;
    {Evaluate position on the screen for plotting sine wave}
    BEGIN
         sinetrace:=trunc(centre-scale*sin(angle*PI/100));
    END;

BEGIN
     angle:=0;
     WHILE angle>=0 DO
     BEGIN
          FOR i:=1 TO sinetrace DO
               write(' ');
               writeln('sine');
               angle:=angle+increment;
     END;
END.

20.
PROGRAM vowels;

USES crt;

{Program that counts the number of vowels in a sentence}

CONST space=' ';
      maxchar=80;

TYPE vowel=(a,e,i,o,u);

VAR buffer:ARRAY[1..maxchar] of char;
    vowelcount:ARRAY[vowel] of integer;

PROCEDURE initialize;

VAR ch:vowel;

BEGIN
     FOR ch:=a TO u DO
     BEGIN
          vowelcount[ch]:=0;
     END;
END;

PROCEDURE textinput;

VAR index:integer;

BEGIN
     writeln('Input a sentence');
     FOR index:=1 TO maxchar DO
         IF eoln THEN buffer[index]:=space
         ELSE read(buffer[index]);
         readln;
END;

PROCEDURE analysis;

VAR index:integer;
    ch:vowel;

BEGIN
     index:=1;
     WHILE index<>maxchar+1 DO
     BEGIN
          IF buffer[index] IN ['a','e','i','o','u'] THEN
          BEGIN
               CASE buffer[index] OF
               'a':ch:=a;
               'e':ch:=e;
               'i':ch:=i;
               'o':ch:=o;
               'u':ch:=u;
               END;
               vowelcount[ch]:=vowelcount[ch]+1;
          END;
          index:=index+1;
     END;
END;

PROCEDURE vowelout;

VAR ch:vowel;

BEGIN
     clrscr;
     writeln;
     writeln('   a   e   i   o   u');
     FOR ch:=a TO u DO
     write(vowelcount[ch]:4);
     writeln;
END;

BEGIN
     initialize;
     textinput;
     analysis;
     vowelout;
END.

21.
PROGRAM no_of_words;

{Program to count the number of words in a sentence}

USES crt;

CONST space=' ';

VAR nextchar:char;
    words:integer;

BEGIN
     words:=1;
     clrscr;
     writeln('Input sentence-terminate with return');
     WHILE not eoln DO
     BEGIN
          read(nextchar);       {If readln was used instead of
                                 read then the program would not work}
          IF nextchar=space THEN
          words:=words+1;
     END;
     writeln('Number of words in the sentence => ',words);
END.

22.
PROGRAM makelist;

TYPE link=^personal;
     personal=RECORD
                name:PACKED ARRAY[1..30] OF char;
                next:link
              END;

VAR item,pointer:link;

PROCEDURE readname(VAR newname:link);
{This procedure reads a name into the computer}

VAR count:0..40;

BEGIN
     FOR count:=1 TO 40 DO
     newname^.name[count]:=' ';
     write('New name: ');
     count:=0;
     WHILE NOT eoln DO
     BEGIN
          count:=count+1;
          read(newname^.name[count])
     END;
     readln
END;

BEGIN
     BEGIN
          new(item);
          readname(item);
          item^.next:=NIL;
          pointer:=item;
          WHILE NOT ((item^.name[1] IN ['E','e'])
                 AND (item^.name[2] IN ['N','n'])
                 AND (item^.name[3] IN ['D','d'])) DO
                 BEGIN
                      new(item);
                      readname(item);
                      item^.next:=pointer;
                      pointer:=item;
                 END;
          pointer:=item^.next
     END;
     BEGIN
          writeln;
          WHILE pointer<>NIL DO
          BEGIN
               item:=pointer;
               writeln(item^.name);
               pointer:=item^.next
          END;
     END;
END.

   © Copyrights Madhu Sudan Rao G.K