PROGRAM dbase(INPUT,OUTPUT);

{

G.C.E. A Level Computing Science (105) Paper 3

Athens College (GCE School) Athens Greece

Centre Number    : 92060

Title of Project : Data Base Management System
                   ---------------------------

Programmer       : Diomidis D. Spinellis

Purpose and scope of the project : This system allows the user to define and
use a custom designed database. The following features are available : Field
naming, record indexing, insertion, deletion,  editing,  display, search and
sorted listing of records. This  project demonstrates the use  of the binary
tree file indexing method used for speed and efficiency.




Database file structure :
The DataBase consists of the following files :
1. Structure File (.STR)
   It is file including the following data :
   No of fields (integer)
   Field 1 Name (String)
   Field 1 length (Integer)
   Field 1 type (Character) (Validation type as explained in ValidRead)
   Field 2 Name
   Field 2 le...................................
   .............................................
   .............................................
   Field n type
   Field on which the Database is indexed (integer)
2. Index File (.NDX)
   It consists of entries of type IndexFileRec which point to the .DBF file
   The first two records are not normal records.
   Record 0 points to a linked list (by the left node) of the deleted items.
   Record 1 is a dummy record which serves as the root of  the tree.  It can
   not be deleted and thus the search always begins from it.
3. Database file (.DBF)
   It contains all the records in a packed form.

Limits :
Max number of fields  : 20 fields
Max field name length : 30 Characters
Max record length     : 200 bytes
Max Key length        : 30 Characters




                                  (C)Copyright  Diomidis D. Spinellis 1985 1986

}
{-----------------------------------------------------------------------------}
const
  KeyLen=20;
  MaxFieldNumber=20;
  MaxFieldNameLength=30;
  MaxRecordLength=200;
  MaxFileNameLength=80;
  MaxStringLength=255;

{-----------------------------------------------------------------------------}
type
  KeyType=String[KeyLen];
  FileNameType = string[MaxFileNameLength];
  FieldNameType = string[MaxFieldNameLength];
  CompareResult = (Greater,Less,Equal);
  MaxString = string[255];

  IndexFileRec=Record
    LeftBranch  : Integer;
    RightBranch : Integer;
    Key         : KeyType;
    DataPoint   : Integer;
  End;

  FieldInfoType = Record
    Name        : string[MaxFieldNameLength];
    Length      : Integer;
    Validate    : Char;
  end;

  FileStrucType = Record
    FieldNum,IndexField,RecordLength : Integer;
    FieldInfo : array[1..MaxFieldNumber] of FieldInfoType;
  end;

  RecordString = string[MaxRecordLength];


{-----------------------------------------------------------------------------}
Var
  IndexFile     : FILE OF IndexFileRec;
  DatabaseFile  : File of Char;
  StructureFile : Text;
  Buffer_A,Buffer_b,Buffer_C  : IndexFileRec;
  FileStruc     : FileStrucType;
  Root          : integer; {Root is the local Variable changed by Search}
  CODE,I        : integer;
  Name          : KeyType;
  C,CC          : Char;
  PaddString,OldDataPack : RecordString;
  Dummy         : Boolean; {Used for function calls that return boolean type}
  Edit          : Boolean;{If set the ReadItem proc will allow default entries}
  FileInUse     : Boolean;

{-----------------------------------------------------------------------------}
function ValidRead( ValidType : Char ; StringLength : Integer ) : MaxString ;
{Read a string with input length and type validation}
Const
  Return = 13;
  BackSpace = 8 ;
  Bell = 7 ;
Var
  c : Char;
  i : Integer;
  Result : MaxString;

  Function Valid(C : Char):Boolean;
  Var
    Result : Boolean;
  begin
    Result:=False;
    case ValidType of
      'A' : If c in ['A'..'Z','a'..'z'] then Result:=True; {Alpha}
      'N' : If c in ['0'..'9','+','-','#','.',','] then Result:=True; {Numeric}
      'D' : If c in ['0'..'9'] then Result:=True; {Digit}
      'Y' : If c in ['Y','N','y','n','T','t','F','f'] then Result:=True;{YesNo}
      'E' : If c in [' '..'~'] then Result:=True; {All the printable ASCII set}
    end;
    Valid:=Result;
  end;

begin
  i:=0;
  Result:='';
  repeat
    Read(Kbd,C);
    If C=Chr(BackSpace) then
      if i>0 then
      begin
        Result:=Copy(Result,1,Length(Result)-1);
        Write(Chr(BackSpace),' ',Chr(BackSpace));
        i:=i-1;
      end
      else
        Write(Chr(Bell))
    else
      If Valid(c) and (i<StringLength) then
      begin
        Result:=Concat(Result,c);
        Write(c);
        i:=i+1;
      end
      else
        if not (c=Chr(Return)) then
          Write(chr(Bell));
  Until C=Chr(Return) ;
  ValidRead:=Result;
  Writeln('');
end;

{-----------------------------------------------------------------------------}
procedure Prompt(Name : MaxString);
{Will initialize the screen for the operation named in name}
begin
  ClrScr;
  WriteLn(Name);
  WriteLn(Copy('-------------------------------------------',1,Length(Name)));
  WriteLn('');
end;

{-----------------------------------------------------------------------------}
function Upper(C : Char) : Char;
{Make C uppercase if required}
var
  cc : char;
begin
  if (C>='a') and (C<='z') then
    cc:=chr(Ord(c)-Ord('a')+Ord('A'))
  else
    cc:=c;
  Upper:=cc;
end;

{-----------------------------------------------------------------------------}
function Compare(A,B : KeyType) : CompareResult;
{Compare to entries of the index file acording to ASCII colating sequence and
return Greater Less or Equal}
begin
  if A>B then
    Compare:=Greater
  else if A<B then
    Compare:=Less
  else
    Compare:=Equal;
end;

{-----------------------------------------------------------------------------}
procedure IndexRead(Where : Integer ; var What : IndexFileRec);
{Read an entry from position Where in the index file into What}
begin
  Seek(IndexFile,Where);
  Read(IndexFile,What);
end;

{-----------------------------------------------------------------------------}
procedure IndexWrite(Where : Integer ; What : IndexFileRec);
{Write an entry to position Where in the index file from What}
begin
  Seek(IndexFile,Where);
  Write(IndexFile,What);
end;

{-----------------------------------------------------------------------------}
procedure InitVars;
{Initialize global variables}
var
  i : Integer;
begin
  PaddString:='';
  for i:=1 to MaxRecordLength do
    PaddString:=ConCat(PaddString,' ');
  Edit:=False; {Only the edit function sets edit to true}
  FileInUse:=False;
end;

{-----------------------------------------------------------------------------}
procedure OpenFiles;
{Open all database files}
Var
  FileName,StructureName,DatabaseName,IndexName : FileNameType;

Begin
  Write('File name :');
  FileName:=ValidRead('E',MaxFileNameLength);
  StructureName:=ConCat(FileName,'.STR');
  DatabaseName:=ConCat(FileName,'.DBF');
  IndexName:=ConCat(FileName,'.NDX');
  Assign(StructureFile,StructureName);
  Assign(DatabaseFile,DatabaseName);
  Assign(IndexFile,IndexName);
end;

{-----------------------------------------------------------------------------}
Procedure CloseFiles;
{Close all Database files}
begin
  Close(IndexFile);
  Close(DatabaseFile);
  Close(StructureFile);
  FileInUse:=False;
end;

{-----------------------------------------------------------------------------}
Procedure PrepareNewFile;
{Initializes all Database files}

Procedure PrepareStructureFile;

Var
  IndexField,I,FieldNumber,FieldLength,RecordLength : Integer;
  FieldName : FieldNameType;
  FieldType : Char;
  NumberInStringForm : String[20];
  EvalResult : Integer;

begin
  Repeat
    Write('Number of fields (1-',MaxFieldNumber,') :');
    NumberInStringForm:=ValidRead('D',5);
    Val(NumberInStringForm,FieldNumber,EvalResult);
  until (FieldNumber<=MaxFieldNumber) and (FieldNumber>0) ;
  WriteLn(StructureFile,FieldNumber);
  RecordLength:=0;
  For i:=1 to FieldNumber Do
  begin
    Write('Enter field ',i,' name :');
    FieldName:=ValidRead('E',MaxFieldNameLength);
    repeat
      Write('Enter field length (up to ',MaxRecordLength-RecordLength,' ) :');
      NumberInStringForm:=ValidRead('D',5);
      Val(NumberInStringForm,FieldLength,EvalResult);
    until RecordLength+FieldLength<MaxRecordLength;
    Write('Field type :A(lphabetic N(umeric D(igit Y(es/No E(verything :');
    repeat
      Read(Kbd,FieldType);
      FieldType:=Upper(FieldType);
    until FieldType in ['A','N','D','Y','E'];
    Writeln(FieldType);
    RecordLength:=RecordLength+FieldLength;
    WriteLn(StructureFile,FieldName);
    WriteLn(StructureFile,FieldLength);
    WriteLn(StructureFile,FieldType);
  end;
  repeat
    Write('Index on which field (1-',FieldNumber,') :');
    NumberInStringForm:=ValidRead('D',5);
    Val(NumberInStringForm,IndexField,EvalResult);
  until (IndexField>0) and (IndexField<=FieldNumber);
  Writeln(StructureFile,IndexField);
end;

Procedure PrepareIndexFile;
Var
  I:integer;
Begin
  Buffer_A.LeftBranch:=0;
  Buffer_A.RightBranch:=0;
  For I:=1 TO KeyLen Do
    Buffer_A.Key[i]:=chr(0);
    Buffer_A.DataPoint:=0;
  Write(IndexFile,Buffer_A);
  IndexWrite(1,Buffer_A);
End;


begin
  OpenFiles;
  Rewrite(StructureFile);
  Rewrite(DatabaseFile);
  Rewrite(IndexFile);
  PrepareStructureFile;
  PrepareIndexFile;
  CloseFiles;
end;

{-----------------------------------------------------------------------------}
Procedure UseFile;
{Prepares the program to use an old data file}
begin
  OpenFiles;
  Reset(StructureFile);
  Reset(DatabaseFile);
  Reset(IndexFile);
  ReadLn(StructureFile,FileStruc.FieldNum);
  FileStruc.RecordLength:=0;
  For i:=1 to FileStruc.FieldNum Do
  begin
    Readln(StructureFile,FileStruc.FieldInfo[i].Name);
    Readln(StructureFile,FileStruc.FieldInfo[i].Length);
    Readln(StructureFile,FileStruc.FieldInfo[i].Validate);
    FileStruc.RecordLength:=FileStruc.RecordLength       +
                            FileStruc.FieldInfo[i].Length
  end;
  Readln(StructureFile,FileStruc.IndexField);
  FileInUse:=True;
end;

{-----------------------------------------------------------------------------}
procedure DataRead(ItemNum : Integer ; var DataPack : RecordString);
{Read data from position ItemNum in the database file into DataPack}
var
  i : integer;
  c : Char;
begin
  seek(DatabaseFile,ItemNum);
  DataPack:='';
  For i:=1 to FileStruc.RecordLength do
  begin
    Read(DatabaseFile,C);
    DataPack:=Concat(DataPack,C);
  end;
end;

{-----------------------------------------------------------------------------}
Procedure DisplayItem(ItemNum : Integer);
{Display the contents of the item located in postion ItemNum in DBF file}
Var
  DataPack : RecordString ;
  i,DataPackPos : integer;
begin
  WriteLn('');
  DataRead(ItemNum,DataPack);
  DataPackPos:=1;
  For i:=1 to FileStruc.FieldNum do
  begin
    Write(FileStruc.FieldInfo[i].Name,' : ');
    WriteLn(Copy(DataPack,DataPackPos,FileStruc.FieldInfo[i].Length));
    DataPackPos:=DataPackPos+FileStruc.FieldInfo[i].Length;
  end;
end;

{-----------------------------------------------------------------------------}
Function KeyName : KeyType;
{Returns the name of the field onto which the database is indexed}
begin
  KeyName:=FileStruc.FieldInfo[FileStruc.IndexField].Name;
end;

{-----------------------------------------------------------------------------}
Procedure NotFoundError(Name : KeyType);
{Reports an error if entry with key name Name was no found}
begin
  WriteLn('An entry with the ',Keyname,' ',Name,' could not be located.');
  WriteLn('Either you have misspeled it or it was never entered in the file.');
end;

{-----------------------------------------------------------------------------}
function ReadKeyName : KeyType ;
{Returns the name of the record the user wants to act uppon}
Var
  Key : KeyType;
begin
  Write('Enter ',KeyName,':');
  Key:=ValidRead('E',KeyLen);
  ReadKeyName:=Key;
end;

{-----------------------------------------------------------------------------}
Procedure ReadItem(ItemNum : Integer ; Key : KeyType);
{Reads all the contents of a record. If Edit is true allows default responses
acording to the variable OldDataPack. ItemNum points to the database file}
Var
  DataPack,DataRead : RecordString;
  i,DataPackPos : integer;
  c : Char;

function Padd(What : RecordString) : RecordString;
  begin
    Padd:=Copy(Concat(What,PaddString),1,MaxRecordLength);
  end;

function Min(a,b : Integer ) : Integer;
begin
  if a>b then Min:=b else Min:=a;
end;

begin
  seek(DatabaseFile,ItemNum);
  DataPack:='';
  For i:=1 to FileStruc.FieldNum do
  begin
    If i=FileStruc.IndexField Then
      DataRead:=Key
    else
      If Edit then
      begin
        Write('Enter new ',FileStruc.FieldInfo[i].Name,'(Y/N) ?');
        Repeat
          Read(Kbd,C);
        until c in ['Y','y','N','n'] ;
        DelLine;
        GotoXY(1,WhereY);
        If (c='N') or (c='n') then
        begin
          DataRead:=Copy(OldDataPack,Length(DataPack)+1,
                         FileStruc.FieldInfo[i].Length);
          Write(FileStruc.FieldInfo[i].Name,':');
          WriteLn(DataRead);
        end {No Change}
        else
        begin
          Write(FileStruc.FieldInfo[i].Name,':');
          DataRead:=ValidRead(FileStruc.FieldInfo[i].Validate,
                              FileStruc.FieldInfo[i].Length);
        end; {Change}
      end {If edit}
      else {No edit}
      begin
        Write(FileStruc.FieldInfo[i].Name,':');
        DataRead:=ValidRead(FileStruc.FieldInfo[i].Validate,
                            FileStruc.FieldInfo[i].Length);
      end; {No edit}
    DataPack:=ConCat(DataPack,Copy(Padd(DataRead),1,
                     FileStruc.FieldInfo[i].Length));
  end; {for i}
  For i:=1 to FileStruc.RecordLength do
    Write(DatabaseFile,DataPack[i]);
end;

{-----------------------------------------------------------------------------}
Procedure List(Node:integer);
{Goes throught the tree structure in the collating sequence manner}
Var
  Buffer : IndexFileRec;
Begin
  IndexRead(Node,Buffer);
  If Buffer.LeftBranch<>0 Then
    List(Buffer.LeftBranch);
  DisplayItem(Buffer.DataPoint);
  If Buffer.RightBranch<>0 Then
    List(Buffer.RightBranch);
End;

{-----------------------------------------------------------------------------}
Function Search(Key:KeyType):integer;
{Return the Position of Key in file, 0 If not existing.
Also set the global Variable Root to the Root of the record or where the
nonexisting record should be hanged.}

Var
  Pos:integer;
  Found,StillOthers:Boolean;

Begin
  Found:=False;
  StillOthers:=True;
  Pos:=1;
  Root:=0;
  While StillOthers and not Found Do
  Begin
    IndexRead(Pos,Buffer_A);
    case Compare(Buffer_A.Key,Key) of
      Equal :
      Begin
        Found:=True;
        Search:=Pos;
      End;

      Greater :
      Begin
        Root:=Pos;
        If Buffer_A.LeftBranch<>0 Then
          Pos:=Buffer_A.LeftBranch
        Else
        Begin
          StillOthers:=False;
          Search:=0;
        End;
      End;

      Less :
      Begin
        Root:=Pos;
        If Buffer_A.RightBranch<>0 Then
          Pos:=Buffer_A.RightBranch
        Else
        Begin
          StillOthers:=False;
          Search:=0;
        End; {If}
      End; {Less}
    End; {Case}
  End; {While}
End; {Function}

{-----------------------------------------------------------------------------}
Function Insert:Boolean;
{Inserts a record into the file structure}
Var
  InsertPosition,IndexPos,DataPosition : integer;
  Rec : IndexFileRec;
  Key : KeyType;

Procedure FindInsertPosition ;
{Sets InsertPosition to the position to insert a record and updates the
deleted linked list if needed .Buffer_B is destroyed . Also the DataPosition
for the database file is set }
  Var
    NewListPointer : Integer;
  Begin
    IndexRead(0,Buffer_B);
    if Buffer_B.LeftBranch=0 Then
    begin
      InsertPosition:=FileSize(IndexFile);
      DataPosition:=FileSize(DatabaseFile)
    end
    Else
    Begin
      InsertPosition:=Buffer_B.LeftBranch;
      IndexRead(InsertPosition,Buffer_B);
      DataPosition:=Buffer_B.DataPoint;
      NewListPointer:=Buffer_B.LeftBranch;
      IndexRead(0,Buffer_B);
      Buffer_B.LeftBranch:=NewListPointer;
      IndexWrite(0,Buffer_B);
    end;
  end;


Begin
  Key:=ReadKeyName;
  IndexPos:=Search(Key);
  If IndexPos=0 Then
  Begin
    FindInsertPosition;
    ReadItem(DataPosition,Key);
    IndexRead(Root,Buffer_A);
    Rec.LeftBranch:=0;
    Rec.RightBranch:=0;
    Rec.DataPoint:=DataPosition;
    Rec.Key:=Key;
    case Compare(Buffer_a.Key,Rec.Key) of
      Greater :
        Buffer_A.LeftBranch:=InsertPosition;
      Less :
        Buffer_A.RightBranch:=InsertPosition;
    end;
    IndexWrite(Root,Buffer_A);
    IndexWrite(InsertPosition,Rec);
    Insert:=True;
    End
  Else
    Insert:=False;
End;

{-----------------------------------------------------------------------------}
Function Delete(Key:KeyType):Boolean;
{Removes the record Key from the tree structure and returns True if it exists.
The record is also appended to the deleted records linked list}
Var
  DelPos,HangPos,Pos,Left :integer;
  Dummy :Boolean;

Procedure UpdateDeletedList;
  Begin
    IndexRead(0,Buffer_B);
    IndexRead(DelPos,Buffer_A);
    {Check to see if already done (due to recursivness it is called twice)}
    If not (Buffer_B.LeftBranch=DelPos) then
    begin
      {Make the deleted record point to the old deleted record}
      Buffer_A.LeftBranch:=Buffer_B.LeftBranch;
      {Make the start of the linked list point to the deleted record}
      Buffer_B.LeftBranch:=DelPos;
      IndexWrite(DelPos,Buffer_A);
      IndexWrite(0,Buffer_B);
    end;
  end;

Begin
  DelPos:=Search(Key);
  If not (DelPos=0) Then
  Begin
    IndexRead(DelPos,Buffer_a);
    If (Buffer_A.LeftBranch=0) OR (Buffer_A.RightBranch=0) Then
    Begin
      IndexRead(Root,Buffer_B);
      HangPos:=Buffer_A.LeftBranch+Buffer_A.RightBranch; {1 or 2 of them are 0}
      Case Compare(Buffer_B.Key,Key) of
        Greater : Buffer_B.LeftBranch:=HangPos;
        Less    : Buffer_B.RightBranch:=HangPos;
      end;
      IndexWrite(Root,Buffer_B);
      Delete:=True;
    End
    Else
    Begin
      { save the left pointer and make it zero call Delete recursively
        hang the node pointed by the left pointer where apropriate  }
      Left:=Buffer_A.LeftBranch;
      Buffer_A.LeftBranch:=0;
      IndexWrite(DelPos,Buffer_A);
      Dummy:=Delete(Buffer_A.Key);
      IndexRead(Left,Buffer_A);
      Pos:=Search(Buffer_A.Key);
      {Pos should be zero because this node is now disconnected}
      IndexRead(Left,Buffer_A);
      IndexRead(Root,Buffer_B); {Where this node should be hanged}
      Case Compare(Buffer_B.Key,Buffer_A.Key) of
        Greater : Buffer_B.LeftBranch:=Left;
        Less    : Buffer_B.RightBranch:=Left;
      end;
      IndexWrite(Root,Buffer_B);
      Delete:=True;
    End;
    UpdateDeletedList;
  End
  Else
    Delete:=False;
End;

{-----------------------------------------------------------------------------}
procedure OptionsScreen;
{Prompt the user the available options he can perform}
begin
  ClrScr;
  WriteLn('GCE  A Level Computer Science Project         (C) 1985,86 Diomidis D. Spinellis');
  WriteLn('');
  WriteLn('                            Data Base Management System');
  WriteLn('                            ---------------------------');
  WriteLn('');
  WriteLn('');
  WriteLn('');
  WriteLn('Available Options');
  WriteLn('-----------------');
  WriteLn('');
  WriteLn('C(reate a new file');
  WriteLn('U(se an existing data file');
  If FileInUse then
  begin
    WriteLn('A(dd a new entry');
    WriteLn('D(isplay an existing entry');
    WriteLn('L(ist Alphabeticaly');
    WriteLn('R(emove an existing entry');
    WriteLn('E(dit an existing entry');
  end;
  WriteLn('Q(uit from the programme');
  WriteLn('');
  WriteLn('');
  WriteLn('');
  Write('Select operation by typing the options first letter ');
end;

{=============================================================================}
Begin
  InitVars;
  repeat
    OptionsScreen;
    repeat
      read(kbd,c);
      c:=Upper(c);
    until ( (c in ['C','U','A','D','L','R','E','Q']) and FileInUse) or
          (c in ['C','U','Q']);
    WriteLn('');
    Case c of

      'Q' : {Quit}
      begin
        Prompt('Quit');
      end;

      'C' : {Create new file}
      Begin
        Prompt('Create a New File');
        If FileInUse then CloseFiles;
        PrepareNewFile;
      End;

      'A' : {Add new entry}
      Begin
        Prompt('Add a New Entry');
        If Insert Then
          WriteLn('Record Inserted')
        Else
          WriteLn('Record already exists');
      End;

      'D' : {Display}
      Begin
        Prompt('Display an Existing Entry');
        Name:=ReadKeyName;
        I:=Search(Name);
        If (I<>0) Then
        Begin
          IndexRead(I,Buffer_A);
          DisplayItem(Buffer_A.DataPoint);
        End
        Else
          NotFoundError(Name);
      End;

      'L' : {list}
      Begin
        Prompt('List Alphabeticaly');
        IndexRead(1,Buffer_A);
        If not (Buffer_A.RightBranch=0) then List(Buffer_A.RightBranch);
      End;

      'R' :       {Remove}
      Begin
        Prompt('Remove an Existing Entry');
        Name:=ReadKeyName;
        If Delete(Name) Then WriteLn('Name Deleted') Else NotFoundError(Name);
      End;

      'E' : {Edit}
      Begin
        Prompt('Edit an Existing Enty');
        Name:=ReadKeyName;
        I:=Search(Name);
        If (I<>0) Then
        Begin
          IndexRead(I,Buffer_A);
          DataRead(Buffer_A.DataPoint,OldDataPack);
          WriteLn('Old contents of entry :');
          DisplayItem(Buffer_a.DataPoint);
          WriteLn('');
          Dummy:=Delete(Name);
          Edit:=True; {Allow default responses based on OldDataPack}
          Dummy:=Insert;
          Edit:=False; {Disable default responses for all other uses}
        End
        Else
          NotFoundError(Name);
      End;

      'U' : {Use an old data file}
      begin
        Prompt('Use an Existing Data File');
        If FileInUse then CloseFiles;
        UseFile;
      end;

{
Non documented feature is commented out for the official release. Was
extensively used as an examine file utility during programme development
and debuging.
      'X' : eXamine
      Begin
        RESET(IndexFile);
        I:=0;
        WriteLn('  REC          Key          LEFT RIGHT             DataPoint');
        WriteLn('');
        While NOT(EOF(IndexFile)) Do
        Begin
          Read(IndexFile,Buffer_A);
          WriteLn(I:5,Buffer_A.Key:KeyLen,Buffer_A.LeftBranch:5,
          Buffer_A.RightBranch:5,'     ',Buffer_A.DataPoint:5);
          I:=I+1;
        End
      End;
}

    End;
    WriteLn('');
    Write('Press any key to continue ') ;
    Read(Kbd,CC) ;
    WriteLn('');
  until C='Q' ;
  If FileInUse then CloseFiles;
  ClrScr;
  WriteLn('End of the Database Management System');
  WriteLn('You are reminded of the necessity of frequent backups of your data');
  WriteLn('');
End.