Shareware Overload/ShartewareOverload.cdr/games/revolv.zip/REVOLVER.PAS

Pascal/Delphi Source File | 1988-03-24 | 26KB | 1,205 lines

Program Revolver;
{

                           R E V O L V E R

                             Version 1.0

                     Revolving Video Tape Catalog


                       Copyright D. Brown, 1988


This is a tiny List Manager, designed specifically for  maintaining a
revolving catalog of video tape recordings.

It is not intended to be used in maintaining a permanent video tape
library. That is best accomplished with one of the numerous programs
specifically designed for that purpose, or by designing your own
using a database manager.

Version 1.0 maintains two data files, one for VHS tapes and another
for  BETA.

Revolver is released into the Public Domain with the understanding
that it will not be sold and that any modifications will follow the
"Philosophy" as outlined in the documentation.

Please refer all questions or bug reports to David Brown, via:


                                             MCI Mail: 221-0001
                                         Compuserve: 73307,1432
}


Uses CRT, PRINTER, DOS;


type
  FName = string[9];
  LineStr = string[65];
  RecordEraseStr = String[9];


                Tape = record                { Tape File  }
                ItemNumber : Integer;        { Tape Number }
                RecordErase: RecordEraseStr; { Tape in/out circulation}
                Passes     : Integer;        { Number of Recordings}
                Line1,                       { \                   }
                Line2,                       {   >  Description    }
                Line3      : LineStr;        { /                   }
               end;


var
   DiskFileName                        : FName;
   RE                                  : RecordEraseStr;
   TapeFile                            : file of Tape;
   TapeRec                             : Tape;
   TType                               : String[4];

   MaxNumberOfTapes, NewEnd, Pnr,
   ItemNumber, TapesPrinted, PageNum,
   Col                                 : Integer;

   ED_Line1, ED_Line2, ED_Line3        : LineStr;

   Kh, Xh, Bh, Eh, Cj, LS, E, X,
   MM, TT                              : Char;

   ED_RecordErase, Printed, FuncKey,
   Up, NewFile, Quit, done             : Boolean;



{            * *   P r o c e d u r e s   * *          }
{_____________________________________________________}

Procedure FindEnd;
{________________}
begin

  Read(TapeFile,TapeRec);
    NewEnd:=FileSize(TapeFile);
  MaxNumberOfTapes:=NewEnd;
  If NewEnd < 2 Then NewFile:=TRUE;
  If NewEnd >=1 Then NewFile:=FALSE;

end; {of FindEnd proc }



{    <<<     Line Print Routines   >>>   }

Procedure Feeder;
{________________}
begin
Write(Lst,#12);
end;


Procedure Print_Out;
{___________________}

Begin

     with TapeRec do

            Write(LSt,
            '        TAPE # ', ItemNumber,': ',Line1,
            ^J,^M,
            '        [',RecordErase,']   ',Line2,
            ^J,^M,
            '        (',Passes,' Passes) ', Line3,
            ^J,^M,
            '        ---------------------------------------------------------',
            ^J,^M);

     end;


Procedure ReadOn;
{______________ }
Var
   Rt: Char;

begin
While FilePos(TapeFile) < MaxNumberOfTapes  do
      begin
        Read(TapeFile,TapeRec);
          with TapeRec do

          If RecordErase=RE Then
                         begin
                         Print_Out;
                         TapesPrinted:=TapesPrinted+1;

          If TapesPrinted= 15 Then
                          begin
                          Feeder;
                          PageNum:=PageNum+1;
                          Write(Lst,^J,^M,
           '         Page ', PageNum,'  ',TTYPE,' Tape Catalogue',  ^J,^J,^M,
 '        ---------------------------------------------------------',
 ^J,^M);
                          TapesPrinted:=0;
                          end;
                    end;
      Pnr:=Pnr+1;
      ReadOn;
    end;
end; {of proc }

Procedure PrintMast;
{___________________}
begin

     Writeln(Lst);
     Writeln(Lst,'               V i d e o   T a p e    C a t a l o g u e     ');
     Write(Lst,
     ^J,^M,

       '                               ',TTYPE,' TAPES                     ',
    ^J,^J,^M,
       '        ---------------------------------------------------------',
     ^J,^M);
end;


Procedure RunFile;
{_________________}
begin

Assign(TapeFile,DiskFileName);
      Reset(TapeFile);
           FindEnd;
              reset(TapeFile);
           ReadOn;
      Close(TapeFile);
end;


Procedure List_Tapes;
{___________________}
begin
     TapesPrinted:=1;
     PageNum:=1;
     PrintMast;
               RE:='Available';
               RunFile;
               RE:='In Use';
               RunFile;
               Feeder;
     Printed:=TRUE;

end;



Procedure LinePrint;
{__________________}

label
finish;

begin
     Write(' Make a printout?');
             TextColor(blink);     Write(' Y');
             TextColor(black);     Write('/');
                TextColor(blink);  Write('n');
                TextColor(black);
     Write('   ',^H,^H,^H,^H,^H);
Repeat
LS:=Readkey;
LS:=UpCase(LS);
Until (LS='Y') or (LS='N');
If LS='N' Then GoTo Finish;
   Printed:=False;
   clrscr;
   Write('Printing');
   List_Tapes;
finish:

end;


{    <<<     Line Print Routines   >>>   }
{                  E n d                 }



Procedure View;
{______________}
Var
   Rt: Char;
   Times: Integer;

begin

     RE:='Available';

                     Assign(TapeFile,DiskFileName);

                     Reset(TapeFile);

                     FindEnd;

                     reset(TapeFile);

                                     begin
                                     Times:=1;
                                     ClrScr;
                                     TextColor(Blue);
                    Writeln('   A V A I L A B L E    T A P E S');
TextColor(yellow);
Writeln;
Write(' ');
While FilePos(TapeFile) < MaxNumberOfTapes  do

      begin
      Read(TapeFile,TapeRec);
          with TapeRec do
                 If RecordErase=RE Then

                                   begin
                                   times:=times+1;
                                   with TapeRec do
                                   Write(ItemNumber,'  ');
                                   If times=10 then

                                               begin
                                               write(^J,^M,^J,' ');
                                               times:=1;
                                               end  { No ';' to force else }
                else
                    Pnr:=Pnr+1;
                                   end;
       end;
       Pnr:=0;
                                     end;

Close(TapeFile);
                begin
                     Writeln;
                       Writeln;
                             TextColor(black);
                             Write('Touch Any Key To Continue');
                     Rt:=Readkey;
                  TextColor(cyan);
                end;

end;



Procedure WipeLine;
{__________________}
Var
Space, BS : Integer;

begin
     Space:=0;
     BS:=0;

Repeat
Write(' ');
Space:=Space+1
Until Space=65;
Repeat
Write(^H);
BS:=BS+1;
Until BS=65;
end;



Procedure ClearRec;
{__________________}
Begin
With TapeRec do
begin

ItemNumber:=Pnr;
RecordErase:='      ';
Passes:=0;
Line1:=' ';
Line2:=' ';
Line3:=' ';
end;
End; {of proc}




Procedure RemoveRow;
{____________________}
Var
Space, BS : Integer;

Begin
                       BS:=0;
                       Repeat
                         Write(^H);
                         BS:=BS+1;
                       Until BS=64;

                       Space:=0;
                       Repeat
                         Write(' ');
                         Space:=Space+1;
                       Until Space=64;

                       BS:=0;
                       Repeat
                         Write(^H);
                         BS:=BS+1;
                       Until BS=64;
End;



Procedure Edit_Screen;
{_____________________}
begin
ClrScr;  {Important for Positioning }
       Write(^J);WRite(' ');
       Writeln('     ');
       Writeln;
   { Spray Record On the Screen }


   With TapeRec do

            Write(
            '                          T A P E   # ', ItemNumber,^J,^M,
            ^J,^M,
            ' [ ');
            TextColor(Red);
                     With TapeRec do
                     Write(RecordErase);
            TextColor(blue);
            Write(' ]',^J,^M);

            TextColor(black);
                      Write(' Passes: ');
            TextColor(black);
                      With TapeRec do
                      Write(Passes,^J,^M);

            Textcolor(blue);
                     With TapeRec do

Write('_________________________________________________________________',^m,
      ' ',Line1,^J,^M,
      '_________________________________________________________________',^m,
      ' ',Line2,^J,^M,
      '_________________________________________________________________',^m,
      ' ',Line3,^J,^M,
      ^J,^M);

end; {of Edit_Screen Proc.}




Procedure Editor;
{_______________}
Label
     Outofhere, Endit, ReTop, EndAll ;

Var
    Yn  : Char;
    TryStr, SecStr : String[3];
    int, code, SaveCount : integer;

Begin

{ Edit Tape Availability }

ReTop:

     With TapeRec do
     Begin

Repeat
          GoToXY(1,4);
          RemoveRow;

TextColor(blink+black);
          Write('In ');
TextColor(black);
          Write ('U');
TextColor(blink+black);
          Write('se / Make it ');
TextColor(black);
          Write('A');
TextColor(blink+black);
          Write('vailable ');

          GoToXY(8,4);
      Xh:=ReadKey;
        Write(' ',^H);
         Xh:=UpCase(Xh);
           Until (Xh='U') or (Xh='A') or (Xh=#13);

           If Xh='A' Then
                     Begin

                          GoToXY(1,4);
                              RemoveRow;
                                        TextColor(red);
                                                  Write('Erase this Material? ');
                                        TextColor(blink+black);
                                                   write('y');
                                        TextColor(Red);
                                                  write('/');
                                        TextColor(blink+black);
                                                  write('N');
                                        TextColor(black);
                                                  GoToXY(23,4);
                          Repeat
                                Yn:=ReadKey;
                                Yn:=UpCase(Yn);
                                Until (Yn='Y') or (Yn='N');
                                      If Yn='N' Then

                                    begin
                                         GoTo ReTop;
                                     end;
                      end;

             If Yn='Y' Then

                           If Xh= 'A' Then Ed_RecordErase:=True;
                           If (Xh= 'U') or (Xh=#13)
                                        Then Ed_RecordErase:=False;

                           If ED_RecordErase= False Then
                                   Begin
                                   GoToXY(1,4);
                                       RemoveRow;

                                   RecordErase:='In Use';
                                    TextColor(Red);
                                         Write(' In Use',^M,^J);
                                         end;

                           If ED_RecordErase= True Then
                                   Begin
                                   SaveCount:=passes;
                                   ClearRec;
                                       RecordErase:='Available';
                                       GoToXY(1,4);
                                       RemoveRow;

                                        TextColor(Blue);
                                                 Write(' Available');

                                                 Passes:=SaveCount;

                                             Edit_Screen;
                                         GoTo EndIt;
                                  TextColor(blue);

                                       end;



begin

{ Edit Tape Passes }

With TapeRec do
passes:=passes;

GoToXY(10,5);
       TextColor(blink+black);
                       Write('  ',^H,^H);
                 Write(passes);
                 GoToXY(10,5);

                 repeat
                       repeat
                       Kh:=ReadKey;
                 Until (Kh>#47) or (Kh=#13)
                 Until (Kh<#58) or (Kh=#13);
                             If Kh=#13 then
                                begin
                                     passes:=passes;
                                     TextColor(black);
                                     Write(' ',passes);
                                     Write(^J,^M);
                                     GoTo Outofhere
                                end;

                Write('  ',^H,^H);
                TextColor(black);
                          write(Kh);
                          Trystr:=Kh; { push Kh onto Trystr }

                          Readln(secstr); {accept secstr (in case more chars)}
                          trystr:=Kh+secstr;
                          val(trystr,int,code);
                          passes:=int;

outofhere:

          TextColor(blue)

end; {Begin}



{ Edit Line 1 }

Write(' ');
Kh:=#0;
Kh:=ReadKey;
If Kh=#13 then
   begin
     Line1:=Line1;
     Write(^J,^M);
    end;
        If Kh<>#13 then
           begin
          WipeLine;
          Write(Kh);
          Readln(ED_Line1);
                          Line1:=Kh+ED_Line1;
                                           end;



{ Edit Line 2 }

Write(' ');
Kh:=#0;
Kh:=ReadKey;
If Kh=#13 then
   begin
     Line2:=Line2;
     Write(^J,^M);
    end;
        If Kh<>#13 then
           begin
          WipeLine;
          Write(Kh);
          Readln(ED_Line2);
                          Line2:=Kh+ED_Line2;
                                           end;



{ Edit Line 3 }

Write(' ');
Kh:=#0;
Kh:=ReadKey;
If Kh=#13 then
   begin
     Line3:=Line3;
     Write(^J,^M,^J);
     GoTo EndAll;
    end;
        If Kh<>#13 then
           begin
          WipeLine;
          Write(Kh);
          Readln(ED_Line3);
                          Line3:=Kh+ED_Line3;
                                           end;

Writeln;


                ItemNumber:=(Pnr);

      end; {of BEGIN for TapeRec do }

Endit:

      GoToXY(1,12);

EndAll:

end; {of Editor Procedure}


FUNCTION FileExists(FileName : FName) : BOOLEAN;
{______________________________________________}
VAR
 f     : FILE;
 fAttr : WORD;

BEGIN
 ASSIGN(f, FileName);
 GetFAttr(f, fAttr);
 FileExists := (fAttr <> 0) AND ((fAttr AND Directory) = 0)
END;  { FileExists }




procedure Initialize;
{___________________}
const
   MaxNumberOfTapes = 1;

begin
  Assign(TapeFile,DiskFileName);
  Rewrite(TapeFile);
  NewFile:=TRUE;
end;



procedure AddRec;
{_______________}
label
 EndIt;
begin
  Reset(TapeFile);
   Seek(TapeFile, FileSize(TapeFile));
    Pnr:=FilePos(TapeFile)+1;


ClearRec;
Edit_Screen;

           If Quit=TRUE Then GoTo Endit
        Else;


       Editor;


              Seek(TapeFile, FileSize(TapeFile));
              Write(TapeFile, TapeRec);

   EndIt:
               Close(TapeFile);

  end; { of AddRec proc. }

procedure Page;
{______________}
{ Pages through records }
Label
     Endit, EndAll;

begin

If NewFile=TRUE Then GoTo EndAll;

Reset(TapeFile);
   FindEnd;


       If Up = True Then Pnr:=Pnr+1;
       If (Up = False) and (Pnr >1) Then Pnr:=Pnr-1;


If Pnr <= 0  Then
                begin
                   pnr:=0;
                   GoTo EndIt;
                   end;

If Pnr > MaxNumberOfTapes Then
                              begin
                                pnr:=MaxNumberOfTapes;

                              end;

If Pnr in [1..MaxNumberOfTapes] then
 {If asking for existing record, then:}


       Begin
            Seek(TapeFile,Pnr-1);
            Read(TapeFile,TapeRec);


EndIt:

        Edit_screen;


        end;

EndAll:
end;{of Page Proc.}


procedure SelectRec;
{_________________}

Label
     EndIt;

Var
    Sel : Char;
    TryStr, SecStr : String[3];
    int, code, SavePnr   : integer;


begin


     Reset(TapeFile);
        FindEnd;

        Repeat
        write(^H);
            RemoveRow;
            TextColor(black);
                 Write('  Select Tape Number ');
                 TextColor(Red);
                 Write('<Q>uit');
                 TextColor(black);
                 Write(' >> ');

                       Sel:=ReadKey;
                 Until (Sel>#48) and (Sel<#58)
                                 or (Sel=#0) or (Sel=#13)
                                 or (Sel=#13) or (Sel='Q') or (Sel='q');
                             If (Sel=#13) or (Sel=#0) or (Sel='Q') or (Sel='q')
                             then
                                     GoTo EndIt;

                Write('  ',^H,^H);

                          write(Sel);
                          Trystr:=Sel; { push Kh onto Trystr }

                          Readln(secstr); {accept secstr (in case more chars)}
                          trystr:=Sel+secstr;
                          val(trystr,int,code);
                          Pnr:=int;


               TextColor(blue);
       If pnr=0 then GoTo EndIt;
       If Pnr in [0..MaxNumberOfTapes] Then

       Begin
            Seek(TapeFile,Pnr-1);
             Read(TapeFile,TapeRec);
            Edit_screen;

Endit:

          Close(TapeFile);

        end; {<new}

end; { of Select proc. }



procedure EditRec;
{_________________}

Label
     EndIt;

begin


     If Pnr=0 Then GoTo EndIt;

     If Pnr < 1 Then
                begin
                Edit_Screen;
                GoTo EndIt;
                end;

     If Pnr >0 Then
     begin

      Reset(TapeFile);
               FindEnd;


    Seek(TapeFile,Pnr-1);

    Read(TapeFile,TapeRec);


    If Quit=TRUE Then GoTo Endit
    Else;

    Editor;

        Seek(TapeFile,Pnr-1);
         Write(TapeFile,TapeRec);
          Edit_Screen;
          Close(TapeFile);
Endit:
     end; {>begin}
     If (Pnr=0) and (Quit=FALSE) and  (Eh='E') and  (NewFile=TRUE)

       Then AddRec;
       NewFile:=FALSE;
end; { of EditData proc. }



Procedure EditMenu;
{_________________}

Label
Stop, KeyPad;


begin
repeat
    RemoveRow;
GoToXY(1,12);
  RemoveRow;
  TextColor(Magenta);
Write('<PgUp> Forward,');
  TextColor(brown);
Write('<PgDn> Reverse,');
  TextColor(black);
Write(' <A>dd, <E>dit, <S>elect #, <Q>uit  ',^H);
TextColor(blue);

Eh:=ReadKey;

Write(' ',^H);


If Eh=#0 Then GoTo KeyPad;

If EH <> #0 then
                FuncKey := False;

                Eh:=UpCase(Eh);
                Until (Eh in ['A','E','S','Q']);

Case Eh of
             'A' : AddRec;
             'E' : EditRec; {This will become Edit THIS tape}
             'S' : SelectRec;  {Select a tape to edit}
             'Q' : GoTo Stop;
                end;


KeyPad:


 If Eh = #0 then
               begin
               FuncKey :=True;
                       While FuncKey = True do
                       begin
                       Eh:=Readkey;

                            { <PageUp>  }
                 If  Eh = #73 Then
                              begin
                            Up:=TRUE;
                              Page;
                              Eh:=#0;
                              FuncKey :=False;
                              Eh:='X';

                              GoTo Stop;
                              end;

                              { <PageDn>  }
                 If  Eh = #81 Then
                              begin
                           Up:=FALSE;
                           Page;
                           Eh:=#0;
                              FuncKey :=False;
                              Eh:='X';
                              pnr:=pnr;
                              end;
stop:

                     end; {do}


   end;
end;



Procedure Edit_Mode;
{__________________}
begin
ClrScr;

   begin

   Edit_Screen;
   end;
     Repeat
     Quit:=FALSE;

     EditMenu;
Until Eh='Q';

Clrscr;
end;



Procedure MenuWindow;
{____________________}
begin
     Window(18,5,57,21);

TextBackground(blue);
TextColor(Yellow);

end;


procedure NewCheck;
{__________________}
begin


   Assign(TapeFile, DiskFileName);
     If Not FileExists(DiskFileName) Then
                                       Initialize;


   If NewFile=FALSE Then
   begin
   pnr:=0;
   ClearRec;
   Edit_Mode;
   end;

     If NewFile=TRUE
       Then
           begin
           AddRec;
           NewFile:=FALSE;
           Pnr:=1;
           Edit_Mode;

           end;


end;


Procedure EditWindow;
{____________________}
{+++ set editor window +++}
begin

 Window(6,8,72,17);
clrscr;
TextAttr:=white;
LowVideo;
TextBackground(lightgray);
TextColor(blue);

end;


Procedure Edit_Add;
{_________________}

begin

EditWindow;

NewCheck;

TextBackground(black);
 clrscr;
{   ***  Go back to Menu window  *** }
MenuWindow;
end;


Procedure Print_Mode;
{____________________}
begin
TextBackground(White);
TextColor(black);
     Window(26,13,50,13);

LinePrint;

TextBackground(blue);
TextColor(yellow);
 clrscr;
        MenuWindow;

end;


Procedure View_Vids;
{____________________}
begin

TextBackground(Magenta);
     Window(16,2,53,19);

View;

TextBackground(black);
 clrscr;
{   ***  Go back to Menu window  *** }
MenuWindow;

end;


Procedure Copyright;
{____________________}

begin
TextColor(Blue);
Writeln('                             R E V O L V E R');
Writeln('                                 Ver. 1.0');
Writeln('                        Copyright D. Brown, 1988');
TextColor(cyan);
writeln;

end;


Procedure TopPiece;
{__________________}
Begin
Writeln(' ╔════════════════════════════════════╗');
  Write(' ║');
Write('   File Open: ');
  Write(DiskFileName:9);
                        Writeln('             ║');
Writeln(' ╟────────────────────────────────────╢');
Writeln(' ║                                    ║');
Writeln(' ╟────────────────────────────────────╢');
Writeln(' ║                                    ║');
Writeln(' ║      E. Edit / Add / Browse        ║');
Writeln(' ║                                    ║');
Writeln(' ║      P. Print Tape Catalog         ║');
Writeln(' ║                                    ║');
Writeln(' ║      A. Available Tapes            ║');
Writeln(' ║                                    ║');
Writeln(' ║      C. Change Disk File           ║');
Writeln(' ║                                    ║');
Writeln(' ║      Q. Quit Program               ║');
Writeln(' ║                                    ║');
Write(' ╚════════════════════════════════════╝');

end;

Procedure Pick_One;
{__________________}

var
finish : boolean;


Begin

Finish:=FALSE;
   while not finish do
   begin
     Clrscr;
       TopPiece;
        GoToXY(5,4);

 Write('Select Tape (BETA or VHS) >  ');

  begin
        Repeat
         Write('_'^H);
          TT:=Readkey;
          TT:=UpCase(TT);
          Until (TT='B') Or (TT='V');
                Finish:=TRUE;
          If TT='B' Then TTYPE:='BETA';
          If TT='V' Then TTYPE:='VHS';

   end;

    If TTYPE='BETA' Then DiskFileName:='BETA.DTA';
    If TTYPE='VHS' Then DiskFileName:='VHS.DTA';
  end;
end;



procedure Menu;
{_____________}

begin

   while not done do
   begin
     Clrscr;
       TopPiece;
         GoToXY(5,4);

Write('Select Menu Option > ');
 begin
       Repeat
         Write('_'^H);
         X:=Readkey;
          MM:=Upcase(X);
       Until (MM in ['E','P','A','Q','C']);
  end;

Case MM of
'E' :  Edit_Add;
'P' :  Print_Mode;
'A' :  View_Vids;
'C' :  Pick_One;
'Q' :  done := true;
end;

  end;
end; {Of MAIN_Menu Proc.}






{               * *   M a i n   * *              }



begin


{ Set Default Values }
{--------------------}
NewFile:=FALSE;
Pnr:=0;
MM:=' ';
X:=' ';
DiskFileName:='NONE';
TextColor(cyan);
Done:=False;
{--------------------}
ClrScr;
       Copyright;
                 MenuWindow;
                            TopPiece;
                                     Pick_One;
                                     clrscr;
                                     menu;

   { Exit }
{ Default Window }
  Window(1,1,80,25);
TextMode(C80);
ClrScr;
end.