Play and Learn 2/19941.ZIP/19941/EDUCNOMY/HERSCHEL/HBASE.PAS

Pascal/Delphi Source File | 1994-02-04 | 48.0 KB | 1,123 lines

Program HerschelCatalogDataBase (Input,Output);

{ This program is a simple data base manager for the Herschel catalog of
  deep sky objects, for amateur astronomers. }

{$C-}  { No user breaks - to speed screen output }

Const
  NumberOfRecords = 2510; { Number of records currently in the data file }
  NumberOfConstellations = 88; { Serpens is treated as a single constellation }
  Heading : String[70] = { The typed constant generates less object code }
  '   H Class   RNGC     R.A.       Dec.   Mag.        Type         Const';

Type
  HRecord = Record { The main record description used throughout the program }
              HClass : Byte;    { Byte types are used to save file space }
              HNum   : Integer; { But some fields go over the 0..255 limit }
              NGC    : Integer;
              RAHrs  : Byte;
              RAMins : Byte;
              RASecs : Byte;
              DecDeg : Integer;
              DecMin : Integer; { A neg. DecMin value is used to indicate  }
              Mag    : Byte;    { objects of Dec. 0d.,Xm. which are south  }
              Class  : Byte;    { of the equator by X mins. (needed 'cause }
              Con    : Byte;    { you can't have a DecDeg integer with a   }
            End; { Record }     { value of -0 }

  { The following structure is used to build a linked-list which holds the
    entire data file while the program runs. This linked structure is used
    because there is not enough memory left in the data segment for an array. }

  HRecordPointer = ^HElement;
                    HElement = Record
                      Data : HRecord;
                      Next : HRecordPointer;
                    End; { Record }

  { The following record is used for calling DOS interrupts }

  Register = Record
               AX,BX,CX,DX,Bp,SI,DI,DS,ES,Flags: Integer;
             End; { Record }

  HClassSet = Set Of 1..8; { Set used in selecting H classes }
  HTypeSet = Set Of 1..7; { Set used in selecting object types }
  Cons = 0..NumberOfConstellations; { Range of constellation indices }
  ConNames = Array[Cons] Of String[3];
  { ConNames is the type description of the "Names" typed constant below }
  Types = Array[1..7] Of String[16];
  { Types is the type description of the "TypeNames" typed constant below }
  Classes = Array[1..8] Of String[4];
  { Classes is the type description of the "TypeNames" typed constant below }
  ObjectType = Array[1..7] Of Char;
  { ObjectType is the type description of the "ObjectTypes" typed constant }
  HArray = Array[1..NumberOfRecords] Of HRecord;

{ Misc. typed constants follow }

Const
  { Typed constant array of constellation names (official abbreviations) }
  Names : ConNames=('   ','And','Ant','Aps','Aqr','Aql','Ara','Ari','Aur','Boo',
   'Cae','Cam','Cnc','CVn','CMa','CMi','Cap','Car','Cas','Cen','Cep','Cet',
   'Cha','Cir','Col','Com','CrA','CrB','Crv','Crt','Cru','Cyg','Del','Dor',
   'Dra','Equ','Eri','For','Gem','Gru','Her','Hor','Hya','Hyi','Ind','Lac',
   'Leo','LMi','Lep','Lib','Lup','Lyn','Lyr','Men','Mic','Mon','Mus','Nor',
   'Oct','Oph','Ori','Pav','Peg','Per','Phe','Pic','Psc','PsA','Pup','Pyx',
   'Ret','Sge','Sgr','Sco','Scl','Sct','Ser','Sex','Tau','Tel','Tri','TrA',
   'Tuc','UMa','UMi','Vel','Vir','Vol','Vul');

  { Names of object types used for display }
  TypeNames : Types = ('Open Cluster    ','Globular Cluster',
  'Diffuse Nebula  ','Planetary Nebula','Galaxy          ','Cluster/Nebula  ',
  'Nonexistant     ');

  { Object type abbreviations used for display }
  ObjectTypes : ObjectType = ('O','C','D','P','G','/','N');

  { Typed constant array of Herschel classes in Roman numeral form }
  ClassNames : Classes = ('   I','  II',' III','  IV','   V','  VI',
                        ' VII','VIII');

Var { Misc. global variables }
  FirstPosition,CurrentPosition : HRecordPointer;
  SelectArray : HArray; { User's selected data }
  SelectPointer,LowNGC,HighNGC,LowDecDeg,EndOfArray,VideoOfs,
  HighDecDeg,LowDecMin,HighDecMin,InCount,Index : Integer;
  LowRAHr,HighRAHr,LowRAMin,HighRAMin,Row,Col : Byte;
  LowMag,HighMag,CurrentEpoch,StartTime,FinishTime : Real;
  Constel,TrueConArray : Array[Cons] Of Boolean;
  { The Constel array flags each constellation as selected or not }
  Object : HRecord; { The variable used to hold the current record }
  SortField,Ch : Char; { Variables used for reading key presses }
  OK,AllOK,EndOfInput,Done,Selected,NewSelection,Expanding : Boolean;
  Device : Text; { Procedure WriteALine writes to this file (screen or print) }
  ClassSet : HClassSet; { These sets are used in the selection process }
  TypeSet : HTypeSet;

Procedure MemoryWrite(Ch: Char);
{ This procedure is a user-written I/O driver for screen output. It writes
  output directly to screen memory. This makes screen output much faster.
  Procedure View activates this driver, and de-activates it before returning
  to the main menu. }
  Const
    VideoSeg = $B000; { Video memory segment address }
  Var
    SChar : Integer;
  Begin { Procedure MemoryWrite }
    If Ch = #13 Then { Test for carriage return }
      Begin { Then }
        Row := Succ(Row); { Adjust row & col for new line }
        Col := 0;
      End { Then }
    Else
      Begin { Else }
        Col := Succ(Col); { New column for each character }
        SChar := ((Row-1)*160) + ((Col-1)*2); { Compute starting location }
        Mem[VideoSeg:VideoOfs + SChar] := Ord(Ch); { Put character in memory }
      End; { Else }
  End; { Procedure MemoryWrite }

{$I SORT.BOX}  { Include Borland's SORT.BOX toolbox include file }

Procedure ReadList;
{ This procedure supplies a single record of input to procedure Inp (below).
  ReadList reads from the static linked list containing the data file. This
  is the normal source of input when the program begins, or after the user
  has done an initialize. }
  Begin { Procedure ReadList }
    Object := CurrentPosition^.Data;
    CurrentPosition := CurrentPosition^.Next;
    EndOfInput := CurrentPosition = Nil;
  End; { Procedure ReadList }

Procedure ReadArray;
{ This procedure supplies a single record of input to procedure Inp (below).
  ReadArray reads from the SelectArray, which contains the user's currently
  selected data. This array is the source of input whenever the user does a
  second select-and-sort without first reinitializing. }
  Begin { Procedure ReadArray }
    Object := SelectArray[SelectPointer];
    SelectPointer := Succ(SelectPointer);
    EndOfInput := SelectPointer > EndOfArray;
  End; { Procedure ReadArray }

Procedure Inp;
{ This procedure is called by the Borland sort routines. This is where
  the program compares each object in the select array against the values
  chosen by the user, creating selected input to the sort. }
  Begin { Procedure Inp }
    SelectPointer := 1; { See proc. ReadArray }
    CurrentPosition := FirstPosition; { See proc. ReadList }
    EndOfInput := False; { For procs. ReadList & ReadArray }
    EndOfArray := InCount; { For proc. ReadArray }
    InCount := 0; { Var. to keep track of # of currently selected objects }
    Writeln('Reading and selecting input data'); { Look familiar? }
    Repeat { Loop to extract all valid input to sort }
      If Not Selected Then { All new input required - get it from linked list }
        ReadList
      Else { Else we are selecting from pre-sorted data - use SelectArray }
        ReadArray;
      With Object Do
        Begin { With }
          If                              { <- This if statement is the heart }
            Constel[Con] Then If          { of the program. It does the actual}
            (Class In TypeSet) Then If    { comparing in the selection process}
            (NGC >= LowNGC) Then If       { The use of "Then If's" rather than}
            (NGC <= HighNGC) Then If      { "And's" speeds the comparison     }
            (RAHrs > LowRAHr) Or          { process by eliminating further    }
            ((RAHrs = LowRAHr) And        { comparison as soon as a boolean   }
            (RAMins >= LowRAMin)) Then If {                      test fails.  }
            (RAHrs < HighRAHr) Or         { We test in order of likelyhood -  }
            ((RAHrs = HighRAHr) And       { by const., then object type etc.  }
            (RAMins <= HighRAMin)) Then If
            (DecDeg > LowDecDeg) Or
            ((DecDeg = LowDecDeg) And
            (DecDeg >= 0) And
            (DecMin >= LowDecMin)) Or     { See comment in Object type desc. }
            ((DecDeg = LowDecDeg) And     { concerning neg. DecMin values    }
            (DecDeg < 0) And
            (DecMin <= LowDecMin)) Then If
            ((DecDeg < HighDecDeg) Or
            ((DecDeg = HighDecDeg) And
            (DecMin <= HighDecMin))) Then If
            (Mag >= LowMag) Then If
            (Mag <= HighMag) Then If
            (HClass In ClassSet)
          Then
           Begin { Then }
             SortRelease(Object); { Release object to Borland's sort }
             InCount := Succ(InCount); { Keep count of objects selected }
           End; { Then }
        End; { With }
    Until EndOfInput;
    Selected := True; { User is creating a select array so its ok to precess }
    Writeln(Incount,' records input to sort');
    Writeln('Sorting'); { You'll stare at this line during the actual sort }
  End; { Procedure Inp }

Procedure Outp;
{ This procedure takes the output from the sort and writes it to the select
  array. This is the array on which all further operations will operate,
  until the user "initializes". This procedure is called from Borland's sort
  routines. }
  Begin { Procedure Outp }
    Writeln('Writing selected output data'); { The last sort screen message }
    For Index := 1 To Incount Do
      Begin { For }
        SortReturn(Object); { Return records in order from Borland's sort }
        SelectArray[Index] := Object; { Put 'em in the SelectArray }
      End; { For }
  End; { Procedure Outp }

Function Less; { Foward declared from the include file as type boolean }
{ This procedure is called by the Borland sort routines. Here is where the
  actual comparison process for the sort takes place. The case statement
  controls the fields sorted on, depending on the user's choice. }
  Var
    FirstObject : HRecord Absolute X;  { Records are passed to Borland's sort }
    SecondObject : HRecord Absolute Y; { by these absolute variables.  }
  Begin { Function Less }
    Case SortField Of { The same char. the user asked for in proc. Sort }
      'H','h' : Less := (FirstObject.HClass < SecondObject.HClass) Or
                        ((FirstObject.HClass = SecondObject.HClass) And
                        (FirstObject.HNum < SecondObject.HNum));
      'N','n' : Less := FirstObject.NGC < SecondObject.NGC;
      'R','r' : Less := (FirstObject.RAHrs < SecondObject.RAHrs) Or
                        ((FirstObject.RAHrs = SecondObject.RAHrs) And
                        (FirstObJect.RAMins < SecondObject.RAMins)) Or
                        (((FirstObject.RAHrs = SecondObject.RAHrs) And
                        (FirstObject.RAMins = SecondObject.RAMins) And
                        (FirstObject.RASecs < SecondObject.RASecs)));
      'D','d' : Less := (FirstObject.DecDeg < SecondObject.DecDeg) Or
                        ((FirstObject.DecDeg = SecondObject.DecDeg) And
                        (FirstObject.DecDeg < 0) And
                        (FirstObject.DecMin > SecondObject.DecMin)) Or
                        ((FirstObject.DecDeg = SecondObject.DecDeg) And
                        (FirstObject.DecDeg >= 0) And
                        (FirstObject.DecMin < SecondObject.DecMin));
      'M','m' : Less := (FirstObject.Mag < SecondObject.Mag) Or
                        ((FirstObject.Mag = SecondObject.Mag) And
                        ((FirstObject.RAHrs < SecondObject.RAHrs) Or
                        ((FirstObject.RAHrs = SecondObject.RAHrs) And
                        (FirstObJect.RAMins < SecondObject.RAMins)) Or
                        (((FirstObject.RAHrs = SecondObject.RAHrs) And
                        (FirstObject.RAMins = SecondObject.RAMins) And
                        (FirstObject.RASecs < SecondObject.RASecs)))));
      'O','o' : Less := (FirstObject.Class < SecondObject.Class) Or
                        ((FirstObject.Class = SecondObject.Class) And
                        ((FirstObject.RAHrs < SecondObject.RAHrs) Or
                        ((FirstObject.RAHrs = SecondObject.RAHrs) And
                        (FirstObJect.RAMins < SecondObject.RAMins)) Or
                        (((FirstObject.RAHrs = SecondObject.RAHrs) And
                        (FirstObject.RAMins = SecondObject.RAMins) And
                        (FirstObject.RASecs < SecondObject.RASecs)))));
      'C','c' : Less := (FirstObject.Con < SecondObject.Con) Or
                        ((FirstObject.Con = SecondObject.Con) And
                        ((FirstObject.RAHrs < SecondObject.RAHrs) Or
                        ((FirstObject.RAHrs = SecondObject.RAHrs) And
                        (FirstObJect.RAMins < SecondObject.RAMins)) Or
                        (((FirstObject.RAHrs = SecondObject.RAHrs) And
                        (FirstObject.RAMins = SecondObject.RAMins) And
                        (FirstObject.RAsECS < SecondObject.RASecs)))));
    End; { Case }
  End; { Function Less }

Procedure Error(ErrorNumber,ErrorAddress : Integer);
{ This procedure is a user written error handler. }
{ It will execute if an error occurs. }
  Begin { Procedure Error }
    ClrScr;
    Writeln('HBASE has crashed.'); { In case the user hadn't noticed }
    If (Hi(ErrorNumber) = 2) And (Lo(ErrorNumber) = $FF) Then
      Begin { Then }
        Writeln('Insufficient memory for execution.');
        Writeln('Remove any memory resident software and try again.');
      End; { Then }
    If (Hi(ErrorNumber) = 1) And (Lo(ErrorNumber) = 1) Then
      Writeln('File HBASE.DAT must be in current directory of default drive!');
    Halt; { Stop the program "manually" after reporting error }
  End; { Procedure Error }

Procedure InitializeVariables;
{ This procedure initializes various variables to their origional state. It
  is called from procedure Initialize when the program first begins, and is
  also the procedure called by the initialize option from the main menu. }
  Begin { Procedure InitializeVariables }
    Expanding := False; { Here is where it is reset }
    NewSelection := False; { Nothing has been selected }
    Selected := False; { No data selected yet - can't precess }
    InCount := 0; { Nothing has been selected & sorted yet }
    CurrentEpoch := 1975.0; { The epoch of the data file }
    { The rest of the statements assign values to the selection variables that
      will select for all possible objects. Thus, you get everything until you
      narrow down these values in the selection procedures. }
    SortField := ' ';
    ClassSet := [1..8];
    TypeSet := [1..7];
    LowNGC := 0;
    HighNGC := 8000;
    LowRAHr := 0;
    HighRAHr := 24;
    LowRAMin := 0;
    HighRAMin := 0;
    LowDecDeg := -90;
    HighDecDeg := 90;
    LowDecMin := 0;
    HighDecMin := 0;
    LowMag := 0.0;
    HighMag := 170.0;
    Constel := TrueConArray; { Each element = true, all const. selected }
  End; { Procedure InitializeVariables }

Procedure Tab(NumberOfSpaces : Byte);
{ Tab over a number of spaces rather than writing space constants }
  Begin { Procedure Tab }
    GoToXY(WhereX + NumberOfSpaces,WhereY);
  End; { Procedure Tab }

Procedure WriteTitleScreen;
{ Please leave this in place - I don't ask for money - just my name in lights }
  Begin { Procedure WriteTitleScreen }
    Clrscr;
    Writeln; Writeln; Writeln;
    Tab(32); Writeln('║   ║ ');
    Tab(32); Writeln('╠═══╣ ');
    Tab(32); Writeln('║   ║  B A S E');
    Writeln; Writeln; LowVideo;
    Tab(13); Writeln('A project in amateur astronomy by G. Dean Williams');
    Writeln;
    Tab(14); Writeln('Data by Sir William Herschel and Dennis Donnelly');
    GoToXY(67,25); Write('Version 01/87');
  End; { Procedure WriteTitleScreen }

Procedure GetScreenType;
{ This procedure determines whether the system uses a monochrome or color
  screen. This information is needed in procedure memorywrite. }
  Var
    Registers : Register;
    Result    : Integer;
    ScreenType : Byte;
  Begin { Procedure GetScreenType }
    INTR($11,Registers); { Interrupt to return screen type }
    Result := Registers.AX; { The raw result is in register AX }
    ScreenType := (Result Shl 10 ) Shr 14; { Extract screen type from result }
    If ScreenType = 2 Then
      VideoOfs := $8000 { Color system }
    Else
      VideoOfs := $0000; { Monochrome system }
  End; { Procedure GetScreenType }

Function Time: Real; { Get system time for calculating program run time }
Var
  RecPack:          Register;
  Ah,Al,Ch,Cl,Dh :   Byte;
Begin { Function Time }
  Ah := $2c; { Initial vaule before DOS call }
  With RecPack Do
    Begin { With }
      Ax := Ah Shl 8 + Al; { Prepare register value for interrupt }
    End; { With }
  Intr($21,RecPack); { Ask DOS for the time }
  With RecPack Do { Calculate time in seconds }
    Time := (Cx Shr 8) * 3600.0 + (Cx Mod 256) * 60.0 + (Dx Shr 8);
End; { Function Time }

Procedure Initialize;
{ This procedure is called from the main program when the program starts.
  It initializes a few necessary variables. }
  Var
    InFile : File Of HArray;
    ConIndex : Byte;
  Begin { Procedure Initialize }
    StartTime := Time; { Used to calculate program run time }
    WriteTitleScreen;
    ErrorPtr := Ofs(Error); { Activate the error handler procedure }
    AuxOutPtr := ConOutPtr; { Save ConOutPtr }
    GetScreenType; { Monochrome or color system? }
    Done := False; { See main program block }
    For ConIndex := 0 To NumberOfConstellations Do { Select all cons }
      TrueConArray[ConIndex] := True;
    InitializeVariables;
    Assign(InFile,'HBASE.DAT');
    Reset(Infile); { It had better be there or we'll crash }
    Read(InFile,SelectArray); { Load the select array with one big disk read }
    Close(InFile);
    New(FirstPosition); { Starting place for linked list }
    CurrentPosition := FirstPosition; { Start at the start }
    For Index := 1 To NumberOfRecords Do
      Begin { For loop to load the linked list from the select array }
        CurrentPosition^.Data := SelectArray[Index]; { Load object to list }
        New(CurrentPosition^.Next); { Increment position in liked list }
        CurrentPosition := CurrentPosition^.Next; { Increment CurrentPosition }
      End; { For }
    CurrentPosition^.Next := Nil; { The last linked list entry points nowhere }
    InCount := NumberOfRecords; { All objects are selected & sorted by H # }
  End; { Procedure Initialize }

Procedure WaitForSpace; { Wait until user presses space bar }
  Begin { Procedure WaitForSpace }
    Repeat
      Read(Kbd,Ch);
    Until Ch = ' ';
  End; { Procedure WaitForSpace }

Procedure Sort;
{ This procedure contains the sort menu, chosen from the main menu }
  Var
    SortFieldHold : Char;
    SortResult : Integer;
  Begin { Procedure Sort }
    ClrScr;
    Window(20,1,80,25); { Center sort menu screen }
    Ch := 'Y'; { In case we skip the following read }
    If ((InCount >= NumberOfRecords) And (Not NewSelection))
      Or (Not (Selected Or NewSelection) And (InCount = 0)) Then
        Begin { Then }
          Writeln;
          Write('Really sort the entire catalog? (Y/N): ');
          Repeat { Outer loop to catch those damn escape codes }
            Repeat
              Read(Kbd,Ch);
            Until Upcase(Ch) In ['Y','N',#27];
            If (Ch = #27) And Keypressed Then { Trap escape codes }
              Begin { Then }
                Read(Kbd,Ch); { Read 2nd char of escape code }
                Ch := 'a'; { Look out for escape code with  "y" or "n" }
              End; { Then }
          Until Upcase(Ch) In ['Y','N'];
          Writeln(Ch);
        End; { Then }
    If Upcase(Ch) = 'Y' Then { We are going to sort - proceed }
      Begin { Then }
        { The next line saves SortField in case it gets clobbered with "Q" }
        SortFieldHold := SortField;
        Writeln;
        Writeln('You can sort on the following fields:');
        Writeln;
        HighVideo; Write('  H'); LowVideo; Writeln('erschel Class');
        HighVideo; Write('  N'); LowVideo; Writeln('GC Number');
        HighVideo; Write('  R'); LowVideo; Writeln('ight Ascension');
        HighVideo; Write('  D'); LowVideo; Writeln('eclination');
        HighVideo; Write('  M'); LowVideo; Writeln('agnitude');
        HighVideo; Write('  O'); LowVideo; Writeln('bject Type');
        HighVideo; Write('  C'); LowVideo; Writeln('onstellation');
        Writeln;
        Write('Type a letter to sort or "Q" to quit to previous screen: ');
        Repeat { Outer loop to catch unwanted escape codes }
          Repeat
            Read(Kbd,SortField);
          Until Upcase(SortField) In ['H','N','R','D','M','O','C','Q',#27];
          If (SortField = #27) And Keypressed Then { Trap out escape codes }
            Begin { Then }
              Read(Kbd,SortField); { Get 2nd char of escape code }
              SortField := 'a'; { So it isn't a sort field character }
            End; { Then }
        Until Upcase(SortField) In ['H','N','R','D','M','O','C','Q'];
        HighVideo; Writeln(SortField); LowVideo;
        Writeln;
        If Upcase(SortField) <> 'Q' Then { A real sort field was entered }
          Begin { Then }
            NewSelection := False; { Selections are being sorted }
            { The call to the actual sort is in the next line }
            SortResult := TurboSort(SizeOf(HRecord)); { Call sort function }
            If SortResult <> 0 Then { Report sort error }
              Begin { Then }
                Writeln('--- Error Occured During Sort ---');
                Case SortResult Of
                  3 : Writeln('Not enough free memory for sorting');
                  10,11 : Writeln('Probable disk I/O error or disk full');
                  12 : Writeln('Disk directory full');
                End; { Case SortResult }
                Write('Press Space To Continue');
                WaitForSpace;
              End; { Then }
          End { Then }
        Else { The user did a "Q", so restore SortField }
          SortField := SortFieldHold;
      End; { Then }
  End; { Procedure Sort }

Procedure WriteALine;
{ This procedure writes a single line of output, either to the screen,
  or to the printer. It is called by procedures List and View. }
 Var
   RealMag : Real;
 Begin { Procedure WriteALine }
  With Object Do
    Begin { With }
      Write(Device,'   ',ClassNames[HClass],'-');
      { Classnames are the roman numeral classes stored in ClassNames array }
      If HNum < 10 Then    { We must test for & print all leading zeros so }
        Write(Device,'00') { that all field columns line up evenly. }
      Else
        If HNum < 100 Then
          Write(Device,'0');
      Write(Device,HNum,'   ');
      If NGC < 10 Then
        Write(Device,'000')
      Else
        If NGC < 100 Then
          Write(Device,'00')
        Else
          If NGC < 1000 Then
            Write(Device,'0');
      Write(Device,NGC,'   ');
      If RAHrs < 10 Then
        Write(Device,'0');
      Write(Device,RAHrs,'/');
      If RAMins < 10 Then
        Write(Device,'0');
      Write(Device,RAMins,'/');
      If RASecs < 10 Then
        Begin { Then }
          Write(Device,'0');
          Write(Device,RASecs:1,'   ');
        End { Then }
      Else
        Write(Device,RASecs:2,'   ');
      If (DecDeg < 0) Or (DecMin < 0) Then
        Write(Device,'-')
      Else
        Write(Device,' ');
      DecDeg := Abs(DecDeg); { We print neg. sign manually }
      If Decdeg < 10 Then
        Begin { Then }
          Write(Device,'0');
          Write(Device,DecDeg,'/');
        End { Then }
      Else
        Write(Device,DecDeg,'/');
      DecMin := Abs(DecMin); { See note in HRecord type description }
      If DecMin < 10 Then
        Write(Device,'0');
      Write(Device,DecMin,'   ');
      RealMag := Mag;
      RealMag := RealMag / 10; { Magnitudes are all multiplied by 10 so }
      If RealMag < 10 Then     { they can be stored as bytes & save space }
        Begin { Then }
          Write(Device,'0');
          Write(Device,RealMag:3:1,'   ');
        End { Then }
      Else
        Write(Device,RealMag:4:1,'   ');
      Write(Device,TypeNames[Class]);
      Write(Device,'   ',Names[Con],#13); { Write carriage return at end }
    End; { With }
  End; { Procedure WriteALine }

Procedure List;
{ This procedure sends the selected data to the printer }
  Const
    FormFeed = #12;
  Var
    NumberOfReports,CopyCount,LineCount : Byte;
  Begin { Procedure List }
    If NewSelection Then
      Sort; { User cannot list data until it is sorted }
    Assign(Device,'Lst:'); { So WriteALine will write to printer }
    Reset(Device);
    If InCount > 0 Then { There is something selected to print }
      Begin { Then }
        NumberOfReports := 1; { Default so user can just hit enter for 1 }
        Writeln;
        Repeat { Loop to get # of listings }
          Write('Enter desired number of copies (default is 1): ');
          {$I-} Readln(NumberOfReports) {$I+};
          OK := (IoResult = 0) And (NumberOfReports > 0) And
                (NumberOfReports < 251);
          If Not OK Then
            Write(^G); { Ring bell to alert user to entry error }
          If NumberOfReports > 250 Then
            Writeln('The maximum number of listings is 250!');
          Writeln;
        Until OK;
        ClrScr;
        Writeln('Ready printer and press space to proceed');
        Writeln('You can type "Q" at any time to stop printing ');
        WaitForSpace;
        CopyCount := 0;
        Repeat { Loop for number of copies }
          CopyCount := Succ(CopyCount);
          GotoXY(1,4); { So object count will stay put between copies }
          Writeln('List of selected objects going to printer.');
          For LineCount := 1 To 3 Do
            Writeln(Lst);
          Writeln(Lst,' ',Heading);
          Writeln(Lst);
          LineCount := 5;
          SelectPointer := 0;
          Repeat { Loop for writing all selected objects }
            SelectPointer := Succ(SelectPointer);
            GoToXY(1,5); { Position for the following write statements }
            Write(Succ(InCount) - SelectPointer,' objects left to print');
            Write(' on copy ',CopyCount,' of ',NumberOfReports,'.    ');
            If KeyPressed Then
              Begin { Then }
                Read(Kbd,Ch); { Get the character }
                If (Ch = #27) And Keypressed Then { Extended scan code? }
                  Begin { Then }
                    Read(Kbd,Ch); { Get 2nd character of scan code }
                    Ch := 'a'; { Trap unwanted "Q"s }
                  End; { Then }
                If Upcase(Ch) = 'Q' Then
                  SelectPointer := Incount; { Skip to end of list to stop }
              End; { Then }
            Object := SelectArray[SelectPointer]; { Get object to print }
            WriteALine; { Write it to Lst: device }
            Write(Lst,#10); { Line feed after carriage return from WriteALine }
            LineCount := Succ(LineCount); { Keep count of print lines }
            If LineCount > 62 Then { Time for new page }
              Begin { Then }
                Write(Lst,FormFeed); { Form Feed At End Of Each Page }
                For LineCount := 1 To 3 Do
                  Writeln(Lst);
                Writeln(Lst,' ',Heading);
                Writeln(Lst);
                LineCount := 5; { Adjust for heading lines }
              End; { Then }
          Until SelectPointer = Incount; { The last object }
          Write(Lst,FormFeed); { Final form feed between copies }
        Until (CopyCount = NumberOfReports) Or (Upcase(Ch) = 'Q');
      End { Then }
    Else
      Begin { Else }
        Write('No objects to list - Press Space To Continue ');
        WaitForSpace;
      End; { Else }
  End; { Procedure List }

Procedure View;
{ This procedure contains the on-screen editor code }
  Const
    Escape = #27;
  Var
    PagePointer : Integer;
    MaxDetailLines,Count : Byte;
    FunKey,TopOfList,BottomOfList : Boolean;

  Procedure WriteScreen;
  { This procedure is contained in, and is called by procedure view. It's
    purpose is to write a screenful of output on the screen. }
    Begin { Procedure WriteScreen }
      ClrScr;
      MaxDetailLines := 23; { Maximum detail lines on the view screen }
      TopOfList := (PagePointer = 0);
      If TopOfList Then { Write ** Top Of List ** message at top }
        MaxDetailLines := Pred(MaxDetailLines); { Leave space for message }
      BottomOfList := (InCount - PagePointer < MaxDetailLines);
      If BottomOfList Then { Write ** Bottom Of List message at bottom }
        MaxDetailLines := Pred(MaxDetailLines); { Leave space for message }
      If InCount = 22 Then
        MaxDetailLines := 21; { Don't write all 22 lines without message }
      Row := 1; { For procedure MemoryWrite }
      Col := 1;
      Write(' Seq.',Heading,#13,#13); { Heading, CR, and & blank line }
      If TopOfList Then
        Write('                         *****   Top Of List   *****',#13);
      Count := 0;
      While (Count < MaxDetailLines) And (PagePointer + Count < InCount) Do
        Begin { While loop to write a screenful of object lines }
          Count := Succ(Count); { Index for SelectArray }
          Object := SelectArray[PagePointer + Count]; { Get object to list }
          Write(' ',PagePointer + Count:4); { Sequence # for listing }
          WriteALine; { Write object to Con: device }
        End; { While }
      If BottomOfList Then
        Write('                        *****   Bottom Of List   *****',#13);
    End; { Procedure WriteScreen }

  Begin { Procedure View }
    If NewSelection Then
      Sort; { User cannot view data until it is sorted }
    ConOutPtr := Ofs(MemoryWrite); { Activate screen output driver }
    Assign(Device,'Con:'); { So WriteALine will write to the screen }
    Reset(Device);
    FunKey := False; { A cursor control key has not been pressed }
    Window(1,1,80,25); { Set window size to entire screen }
    If InCount > 0 Then { There is something selected to view }
      Begin { Then }
        PagePointer := 0; { Index to top of SelectArray }
        WriteScreen; { Write initial screenful of output }
        Repeat { Accept keyboard input until user "q"uits }
          Repeat
            Read(Kbd,Ch);
            FunKey := (Ch = Escape) And KeyPressed;
          Until FunKey Or (Upcase(Ch) In ['Q','B','E','S']);
          If FunKey And (InCount > 21) Then { Respond to edit keys }
            Begin { Then }
              FunKey := False; { Done pressing function key }
              Read(Kbd,Ch); { Get 2nd character of code }
              Case Ch Of
                #71 : Begin { Case home }
                        PagePointer := 0; { Top of list }
                        WriteScreen;
                      End; { Case home }
                #79 : Begin { Case end }
                        PagePointer := (InCount - 22); { Bottom of list }
                        If PagePointer < 0 Then
                          PagePointer := 0;
                        If InCount = 22 Then { Special case for TOL message }
                          PagePointer := 1;
                        WriteScreen;
                      End; { Case end }
                #73 : Begin { Case page up }
                        PagePointer := PagePointer - 23; { Up in list }
                        If PagePointer < 0 Then { Exceeded top of list }
                          PagePointer := 0; { Top }
                        WriteScreen;
                      End; { Case page up }
                #81 : Begin { Case page down }
                        Ch := 'a'; { # 81 is a 'Q' and we don't want to quit }
                        PagePointer := PagePointer + MaxDetailLines; { Down }
                        If PagePointer > (InCount - 22) Then { Exceeded list }
                          Begin { Then }
                            PagePointer := (InCount - 22); { Bottom }
                            If PagePointer < 0 Then
                              PagePointer := 0;
                          End; { Then }
                        If InCount = 22 Then
                          PagePointer := 1;
                        WriteScreen;
                      End; { Case page down }
              End; { Case }
            End { Then }
          Else
            If Ch = #81 Then
              Ch := 'a'; { Page down returns a 'Q' and we don't want to quit }
          If (Upcase(Ch) In ['B','E','S']) And (InCount > 21) Then
            Begin { Then } { Skip halfway to beginning or end, }
              Case Ch Of   { or skip to a particular sequence }
                'B','b' : PagePointer := PagePointer Div 2;
                'E','e' : Begin { Case E }
                            PagePointer := PagePointer +
                            (InCount - PagePointer) Div 2;
                            If PagePointer > (InCount - 21) Then
                              Begin { Then }
                                PagePointer := (InCount - 21);
                                If PagePointer < 0 Then
                                  PagePointer := 0;
                              End; { Then }
                          End; { Case E }
                'S','s' : Begin { Case S }
                            { Restore standard screen output driver }
                            ConOutPtr := AuxOutPtr;
                            ClrScr;
                            Repeat { 2 repeat loops to get valid seek # }
                              Repeat
                                Write('Enter sequence number between 1 and ');
                                Write(InCount,' to seek: ');
                                {$I-} Readln(PagePointer); {$I+}
                                OK := IOResult = 0;
                                If Not OK Then
                                  Write(^G); { Beep to indicate entry error }
                                Writeln;
                              Until OK;
                              AllOK := (PagePointer >= 1) And
                                       (PagePointer <= InCount);
                              PagePointer := Pred(PagePointer);
                              If Not AllOK Then
                                Write(^G); { Beep to indicate entry error }
                            Until AllOK;
                            If PagePointer > (InCount - 21) Then
                              Begin { Then }
                                PagePointer := (InCount - 21);
                                If PagePointer < 0 Then
                                  PagePointer := 0;
                              End; { Then }
                            { Go back to IO driver for view screen }
                            ConOutPtr := Ofs(MemoryWrite);
                          End; { Case S }
              End; { Case }
              WriteScreen; { After "B","E", or "S" entry }
            End; { Then }
        Until Upcase(Ch) = 'Q'; { Until user quits the viewer }
      End { Then }
    Else
      Begin { Else }
        Row := 19; { Row & col for printing error message }
        Col := 10;
        Write('No objects to view - Press Space To Continue ');
        WaitForSpace;
        ClrScr; { Clear the larger view window before returning to main menu }
      End; { Else }
    ConOutPtr := AuxOutPtr; { Restore standard screen output driver }
  End; { Procedure View }

Procedure Terminate;
{ This procedure is called when the user Quits the program }
  Var
    ActiveTime,ActiveHours,ActiveMinutes,ActiveSeconds : Real;
  Begin { Procedure Terminate }
    Window(1,1,80,25); { Restore full screen window }
    ClrScr; { Leave the DOS level screen uncluttered except for final message }
    FinishTime := Time; { Used To determine program run time }
    If FinishTime < StartTime Then
      FinishTime := FinishTime + 86400.0; { Add 24 hours after midnight }
    ActiveTime := FinishTime - StartTime; { Program run time in seconds }
    ActiveHours := Int(ActiveTime / 3600);
    ActiveMinutes := Int((ActiveTime - ActiveHours * 3600) / 60);
    ActiveSeconds := ActiveTime - ActiveHours * 3600 - ActiveMinutes * 60;
    Write('Hbase active for ');
    If ActiveHours > 0 Then
      If ActiveHours > 1 Then
        Write(ActiveHours:2:0,' hours ')
      Else
        Write(ActiveHours:2:0,' hour ');
    If ActiveMinutes > 0 Then
      If ActiveMinutes > 1 Then
        Write(ActiveMinutes:2:0,' minutes ')
      Else
        Write(ActiveMinutes:2:0,' minute ');
    If ActiveSeconds > 1 Then
      Write(ActiveSeconds:2:0,' seconds')
    Else
      Write(ActiveSeconds:2:0,' second');
    Writeln(' - returning to DOS ...');
  End; { Procedure Terminate }

{$I SELECTS.INC}  { Include parameter selection procedures }

Procedure Precess;
{ This procedure precesses the selected data's celestial coordinates to
  another epoch. The algolrithm is taken from Eric Burgess' CELESTIAL BASIC,
  and it is not as accurate as I would like. If you improve on it (even at a
  loss of speed), please let me know, 'cause I could use it myself. }
  Var
    R1,D1,T2,ChangeInRA,ChangeInDec,NewEpoch,
    RealMins,Difference,X,Y,Z,LastYear : Real;

  Function Tan (AngleInDegrees : Real): Real;
    { Represents the tangent of its degree-valued argument }
    Var
      Angle : Real;
    Function ConvertToRadians(Angle : Real): Real;
      Begin { Function ConvertToRadians }
        ConvertToRadians := Angle * (Pi / 180);
      End; { Function ConvertToRadians }
    Begin { Function Tan }
      Angle := ConvertToRadians(AngleInDegrees);
      Tan := Sin(Angle) / Cos(Angle);
    End; { Function Tan }

  Begin { Procedure Precess }
    If NewSelection Then
      Sort; { User cannot precess data until it is sorted }
    If Selected And (InCount > 0) Then
      Begin { Then }
        ClrScr;
        LastYear := CurrentEpoch;
        Repeat
          Write('Enter the new epoch: ');
          {$I-} Readln(NewEpoch) {$I+};
          OK := (IOResult = 0);
          If Not OK Then
            Write(^G); { Ring bell to alert user to entry error }
          Writeln;
        Until OK;
        ClrScr;
        Writeln('Selected data being precessed to epoch ',NewEpoch:7:2);
        Difference := NewEpoch - LastYear;
        CurrentEpoch := NewEpoch;
        For Index := 1 To InCount Do
          Begin { For }
            Object := SelectArray[Index]; { Get next object to precess }
            With Object Do { Precess it }
              Begin { With }
                R1 := RAHrs + RAMins / 60 + RASecs / 3600;
                D1 := DecDeg + DecMin / 60;
                R1 := R1 * 15;
                T2 := ((LastYear + NewEpoch) / 2 - 1900) / 100;
                X := 3.07234 + (0.00186 * T2);
                Y := 20.0468 - (0.0085 * T2);
                Z := Y / 15;
                ChangeInRA := 0.0042 * Difference *
                  (X + (Z * Sin(R1/57.29878) * Tan(D1/57.29878)));
                R1 := R1 + ChangeInRA;
                D1 := D1  + 0.00028 * Difference * Y * Cos(R1 / 57.29878);
                R1 := R1 / 15;
                If R1 > 24 Then
                  R1 := R1 - 24;
                If R1 < 0 Then
                  R1 := R1 + 24;
                RAHrs := Trunc(Int(R1));
                RealMins := (60 * (R1 - Int(R1)));
                RASecs := Trunc(60 * (RealMins - Int(RealMins)));
                RAMins := Trunc(RealMins);
                If D1 > 90 Then
                  D1 := 90 - (D1 - Int(D1));
                DecDeg := Trunc(Int(D1));
                DecMin := Trunc((D1 - Int(D1)) * 60);
                If D1 < 0 Then
                  Begin { Then }
                    DecDeg := Trunc(Int(D1));
                    D1 := Abs(D1);
                    DecMin := Trunc(60 * (D1 - Int(D1)));
                  End; { Then }
              End; { With }
            SelectArray[Index] := Object; { Put precessed object back }
          End; { For }
      End { Then }
    Else
      Begin { Else }
        If InCount > 0 Then { Selected = False }
          Writeln('No data has been selected for precession')
        Else { Incount = 0 }
          Writeln('  No objects to precess');
        Write    (' Press space to continue ');
        WaitForSpace;
      End; { Else }
  End; { Procedure Precess }

Procedure ExamineStatus; { Show selected values to user }
  Var
    Index,ConCount : Byte;
    ConSelected : Boolean;
  Begin { Procedure ExamineStatus }
    ClrScr;
    Window(20,1,80,25); { Center status display screen }
    Writeln;
    ConCount := 0;
    ConSelected := False;
    HighVideo; Writeln('Current selected values are:'); LowVideo;
    Writeln;
    Write('Sorted by ');
    Case SortField Of
      'H','h',' ' : Writeln('Herschel class.');
      'N','n' : Writeln('NGC number.');
      'R','r' : Writeln('right ascension.');
      'D','d' : Writeln('declination.');
      'M','m' : Writeln('magnitude.');
      'O','o' : Writeln('object type.');
      'C','c' : Writeln('constellation.');
    End; { Case }
    Writeln;
    If ClassSet  >= [1..8] Then
      Writeln('All Herschel classes.')
    Else
      Begin { Else }
        Write('Herschel class(es) ');
        For Index := 1 To 8 Do
          If Index In ClassSet Then
            Write(ClassNames[Index],' ');
        Writeln;
      End; { Else }
    Writeln;
    If (LowNGC <= 0) And (HighNGC >= 8000) Then
      Writeln('All NGC numbers.')
    Else
      Writeln('NGC numbers from ',LowNGC,' to ',HighNGC);
    Writeln;
    If (LowRAHr <= 0) And (LowRAMin <= 0) And (HighRAHr >= 24)
        And (HighRAMin >= 60) Then
      Writeln('All r.a. values.')
    Else
      Writeln('R.A. from ',LowRAHr,' Hrs, ',LowRAMin,' Min to ',
               HighRAHr,' Hrs, ',HighRAMin,' Min.');
    Writeln;
    If (LowDecDeg <= -90) And (LowDecMin <= -60) And (HighDecDeg >= 90) And
       (HighDecMin >= 60) Then
      Writeln('All Dec. values.')
    Else
      Writeln('Dec. from ',LowDecDeg,' Deg, ',LowDecMin,' Min to ',
               HighDecDeg,' Deg, ',HighDecMin,' Min.');
    Writeln;
    If (LowMag <= 0) And (HighMag >= 170.0) Then
      Writeln('All magnitudes.')
    Else
      Writeln('Magnitudes from ',(LowMag/10):4:1,' to ',(HighMag/10):4:1,'.');
    Writeln;
    If TypeSet  >= [1..7] Then
      Writeln('All object types.')
    Else
      Begin { Else }
        Write('Object type(s) ');
        For Index := 1 To 7 Do
          If Index In TypeSet Then
            Write(ObjectTypes[Index],' ');
        Writeln;
      End; { Else }
    Writeln;
    For Index := 1 To NumberOfConstellations Do
      If Not Constel[Index] Then
        Begin { Then }
          ConSelected := True;
          ConCount := Succ(ConCount);
        End; { Then }
      If Not ConSelected Then
        Writeln('All Constellations.')
    Else
      If ConCount = NumberOfConstellations Then
        Writeln('No Constellations.')
      Else
        Begin { Else }
          Writeln('The following constellation(s):');
          ConCount := 0;
          For Index := 1 To NumberOfConstellations Do
            Begin { For }
              If Constel[Index] Then
                Begin { Then }
                  ConCount := Succ(ConCount);
                  If ConCount > 14 Then
                    Begin { Then }
                      Writeln;
                      ConCount := 0;
                    End { Then }
                  Else
                    Write(Names[Index],' ');
                End; { Then }
            End; { For }
        End; { Else }
    Writeln; Writeln;
    HighVideo; Write('Press space to return to main menu '); LowVideo;
    WaitForSpace;
  End; { Procedure ExamineStatus }

{$I HELP.INC}  { Include the online help procedure }

Procedure MainMenu;
{ This is the main menu called by the main program }
  Begin { Procedure MainMenu }
    ClrScr;
    Window(11,1,80,25); { Center the main menu screen }
    LowVideo; { Some procedures return in HighVideo mode }
    Writeln;
    If InCount <> 1 Then { Test to keep our grammar correct }
      Writeln('There are currently ',InCount,' objects selected.')
    Else
      Writeln('There is currently 1 object selected.');
    Writeln;
    HighVideo;
    If NewSelection Then { New selections not yet sorted - warn the user }
      Begin { Then }
        Writeln('New selections have not been sorted.');
        Writeln;
      End; { Then }
    If Expanding Then { Notify the user }
      Begin { Then }
        Writeln('Selections are being expanded.');
        Writeln;
      End; { Then }
    LowVideo;
    Writeln('You can select a sub-listing by:');
    Writeln;
    HighVideo; Write('  H'); LowVideo; Writeln('erschel Class');
    HighVideo; Write('  N'); LowVideo; Writeln('GC Number');
    HighVideo; Write('  R'); LowVideo; Writeln('ight Ascension');
    HighVideo; Write('  D'); LowVideo; Writeln('eclination');
    HighVideo; Write('  M'); LowVideo; Writeln('agnitude');
    HighVideo; Write('  O'); LowVideo; Writeln('bject Type');
    HighVideo; Write('  C'); LowVideo; Writeln('onstellation');
    Writeln;
    Write('Type a letter to select, or to ');
    HighVideo; Write('S'); LowVideo; Write('ort, ');
    HighVideo; Write('T'); LowVideo; Writeln('oggle expansion, ');
    HighVideo; Write('E'); LowVideo; Write('xamine status, ');
    HighVideo; Write('I'); LowVideo; Write('nitialize, ');
    HighVideo; Write('V'); LowVideo; Write('iew, ');
    HighVideo; Write('L'); LowVideo; Write('ist, ');
    HighVideo; Write('P'); LowVideo; Write('recess, or ');
    HighVideo; Write('Q'); LowVideo; Writeln('uit.');
    Writeln;
    Write('You may type '); HighVideo; Write('F1 '); LowVideo;
    Writeln('for help.');
    Writeln;
    Write('Your Choice? ');
    Repeat
      Read(Kbd,Ch);
    Until Upcase(Ch) In ['H','N','R','D','M','C','O','E',
                         #27,'T','I','S','V','L','P','Q'];
    HighVideo; Writeln(Ch); LowVideo;
    Writeln;
    Case Ch Of
      #27 : Begin { Check for PF1 (help) else ignore extended code keys }
              If Keypressed Then
                Read(Kbd,Ch); { Get 2nd character of extended scan code }
                If Ch = #59 Then { PF1 was pressed }
                  MainMenuHelp
                Else
                  Ch := ' '; { Space out unwanted 2nd character }
            End; { Case escape }
      'H','h' : SelectH;
      'N','n' : SelectNGC;
      'R','r' : SelectRA;
      'D','d' : SelectDec;
      'M','m' : SelectMag;
      'O','o' : SelectType;
      'C','c' : SelectCon;
      'E','e' : ExamineStatus;
      'I','i' : InitializeVariables;
      'L','l' : List;
      'P','p' : Precess;
      'V','v' : View;
      'S','s' : Sort;
      'Q','q' : Begin { Case Q }
                  Write('Exit to DOS? (Y/N): ');
                  Repeat { Loop to catch those damn escape codes }
                    Repeat
                      Read(Kbd,Ch);
                    Until Upcase(Ch) In ['Y','N',#27];
                    If (Ch = #27) And Keypressed Then { Escape code pressed }
                      Begin { Then }
                        Read(Kbd,Ch); { Get 2nd char of escape code }
                        Ch := 'a'; { Weed out unwanted "y"s & "n"s }
                      End; { Then }
                  Until Upcase(Ch) In ['Y','N'];
                  Writeln(Ch);
                  Done := Upcase(Ch) = 'Y';
                End; { Case Q }
      'T','t' : Begin { Case T }
                  Expanding := Not Expanding;
                  Selected := False;
                End; { Case T }
    End; { Case }
  End; { Procedure MainMenu }

Begin { Program }
  Initialize;
  While Not Done Do
    MainMenu;
  Terminate;
End. { Program }