home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / ENTERPRS / CPM / UTILS / F / PASCAL.ARC / HBASE.PAS < prev    next >
Pascal/Delphi Source File  |  1992-08-14  |  57KB  |  1,241 lines
  1. Program HerschelCatalogDataBase (Input,Output);
  2.  
  3. { This program is a simple data base manager for the Herschel catalog of
  4.   deep sky objects, for amateur astronomers. }
  5.  
  6. {$C-}  { No user breaks - to speed screen output }
  7.  
  8. Const
  9.   NumberOfRecords = 2510; { Number of records currently in the data file }
  10.   NumberOfConstellations = 88; { Serpens is treated as a single constellation }
  11.   NumberOfSelectionSets = 9; { Used with the merge option - more than enough }
  12.   Heading : String[70] = { The typed constant generates less object code }
  13.   '   H Class   RNGC     R.A.       Dec.   Mag.        Type         Const';
  14.  
  15. Type
  16.   HRecord = Record { The main record description used throughout the program }
  17.               HClass : Byte;    { Byte types are used to save file space }
  18.               HNum   : Integer; { But some fields go over the 0..255 limit }
  19.               NGC    : Integer;
  20.               RAHrs  : Byte;
  21.               RAMins : Byte;
  22.               RASecs : Byte;
  23.               DecDeg : Integer;
  24.               DecMin : Integer; { A neg. DecMin value is used to indicate  }
  25.               Mag    : Byte;    { objects of Dec. 0d.,Xm. which are south  }
  26.               Class  : Byte;    { of the equator by X mins. (needed 'cause }
  27.               Con    : Byte;    { you can't have a DecDeg integer with a   }
  28.             End; { Record }     { value of -0) }
  29.  
  30.   { The following structure is used to build a linked-list which holds the
  31.     entire data file while the program runs. This linked structure is used
  32.     because there is not enough memory left in the data segment for an array. }
  33.  
  34.   HRecordPointer = ^HElement;
  35.                     HElement = Record
  36.                       Data : HRecord;
  37.                       Next : HRecordPointer;
  38.                     End; { Record }
  39.  
  40.   { The following record is used for calling DOS interrupts }
  41.   Register = Record
  42.                AX,BX,CX,DX,Bp,SI,DI,DS,ES,Flags: Integer;
  43.              End; { Record }
  44.  
  45.   HClassSet = Set Of 1..8; { Set used in selecting H classes }
  46.   HTypeSet = Set Of 1..7; { Set used in selecting object types }
  47.   Cons = 0..NumberOfConstellations; { Range of constellation indices }
  48.   ConNames = Array[Cons] Of String[3];
  49.   { ConNames is the type description of the "Names" typed constant below }
  50.   Types = Array[1..7] Of String[16];
  51.   { Types is the type description of the "TypeNames" typed constant below }
  52.   Classes = Array[1..8] Of String[4];
  53.   { Classes is the type description of the "TypeNames" typed constant below }
  54.   ObjectType = Array[1..7] Of Char;
  55.   { ObjectType is the type description of the "ObjectTypes" typed constant }
  56.   HArray = Array[1..NumberOfRecords] Of HRecord;
  57.   PromptString = String[32]; { Parameter type for procedure GetInteger }
  58.  
  59.   SelectionSetType = Record { Used to hold user's selections }
  60.                        ClassSet   : HClassSet;
  61.                        TypeSet    : HTypeSet;
  62.                        LowNGC     : Integer;
  63.                        HighNGC    : Integer;
  64.                        LowRAHr    : Integer;
  65.                        HighRAHr   : Integer;
  66.                        LowRAMin   : Integer;
  67.                        HighRAMin  : Integer;
  68.                        LowDecDeg  : Integer;
  69.                        HighDecDeg : Integer;
  70.                        LowDecMin  : Integer;
  71.                        HighDecMin : Integer;
  72.                        LowMag     : Real;
  73.                        HighMag    : Real;
  74.                        Constel    : Array[Cons] Of Boolean;
  75.                      End; { Record }
  76.  
  77. { Misc. typed constants follow }
  78.  
  79. Const
  80.   { Typed constant array of constellation names (official abbreviations) }
  81.   Names : ConNames=('   ','And','Ant','Aps','Aqr','Aql','Ara','Ari','Aur',
  82.    'Boo','Cae','Cam','Cnc','CVn','CMa','CMi','Cap','Car','Cas','Cen','Cep',
  83.    'Cet','Cha','Cir','Col','Com','CrA','CrB','Crv','Crt','Cru','Cyg','Del',
  84.    'Dor','Dra','Equ','Eri','For','Gem','Gru','Her','Hor','Hya','Hyi','Ind',
  85.    'Lac','Leo','LMi','Lep','Lib','Lup','Lyn','Lyr','Men','Mic','Mon','Mus',
  86.    'Nor','Oct','Oph','Ori','Pav','Peg','Per','Phe','Pic','Psc','PsA','Pup',
  87.    'Pyx','Ret','Sge','Sgr','Sco','Scl','Sct','Ser','Sex','Tau','Tel','Tri',
  88.    'TrA','Tuc','UMa','UMi','Vel','Vir','Vol','Vul');
  89.  
  90.   { Names of object types used for display }
  91.   TypeNames : Types = ('Open Cluster    ','Globular Cluster',
  92.   'Diffuse Nebula  ','Planetary Nebula','Galaxy          ','Cluster/Nebula  ',
  93.   'Nonexistant     ');
  94.  
  95.   { Object type abbreviations used for display }
  96.   ObjectTypes : ObjectType = ('O','C','D','P','G','/','N');
  97.  
  98.   { Typed constant array of Herschel classes in Roman numeral form }
  99.   ClassNames : Classes = ('   I','  II',' III','  IV','   V','  VI',
  100.                         ' VII','VIII');
  101.  
  102. Var { Misc. global variables }
  103.   SelectionFile : File Of HRecord; { See procedure Inp }
  104.   FirstPosition,CurrentPosition : HRecordPointer;
  105.   SelectArray : HArray; { User's selected data }
  106.   Row,Col,SelectPointer,LowNGC,HighNGC,LowDecDeg,EndOfArray,VideoOfs,
  107.   HighDecDeg,LowDecMin,HighDecMin,InCount,Index,LowRAHr,HighRAHr,
  108.   LowRAMin,HighRAMin,SelectionSetIndex,SetChoice,DisplayIndex : Integer;
  109.   LowMag,HighMag,CurrentEpoch,StartTime,FinishTime : Real;
  110.   Constel,TrueConArray : Array[Cons] Of Boolean;
  111.   { The Constel array flags each constellation as selected or not }
  112.   Object : HRecord; { The variable used to hold the current record }
  113.   SortField,Ch : Char; { Variables used for reading key presses }
  114.   OK,AllOK,EndOfInput,Done,Selected,NewSelection,Expanding,Merging,
  115.   DiskInput : Boolean;
  116.   CurrentSelectionSet : SelectionSetType; { See proc. Inp }
  117.   SelectionSetArray : Array[1..NumberOfSelectionSets] Of SelectionSetType;
  118.   Device : Text; { Procedure WriteALine writes to this file (screen or print) }
  119.   ClassSet : HClassSet; { These 2 sets for object selection }
  120.   TypeSet : HTypeSet;
  121.  
  122. Procedure MemoryWrite(Ch: Char);
  123. { This procedure is a user-written I/O driver for screen output. It writes
  124.   output directly to screen memory. This makes screen output much faster.
  125.   Procedure View activates this driver, and de-activates it before returning
  126.   to the main menu. }
  127.   Const
  128.     VideoSeg = $B000; { Video memory segment address }
  129.   Var
  130.     SChar : Integer;
  131.   Begin { Procedure MemoryWrite }
  132.     If Ch = #13 Then { Test for carriage return }
  133.       Begin { Then }
  134.         Row := Succ(Row); { Adjust row & col for new line }
  135.         Col := 0;
  136.       End { Then }
  137.     Else
  138.       Begin { Else }
  139.         Col := Succ(Col); { New column for each character }
  140.         SChar := ((Row-1)*160) + ((Col-1)*2); { Compute starting location }
  141.         Mem[VideoSeg:VideoOfs + SChar] := Ord(Ch); { Put character in memory }
  142.       End; { Else }
  143.   End; { Procedure MemoryWrite }
  144.  
  145. Procedure WaitForSpace; { Wait until user presses space bar }
  146.   Begin { Procedure WaitForSpace }
  147.     Repeat
  148.       Read(Kbd,Ch);
  149.     Until Ch = ' ';
  150.   End; { Procedure WaitForSpace }
  151.  
  152. Function Time: Real; { Get system time for calculating program run time }
  153.   Var
  154.     RecPack:          Register;
  155.     Ah,Al,Ch,Cl,Dh :   Byte;
  156.   Begin { Function Time }
  157.     Ah := $2c; { Initial value before DOS call }
  158.     With RecPack Do
  159.       Ax := Ah Shl 8 + Al; { Prepare register value for interrupt }
  160.     Intr($21,RecPack); { Ask DOS for the time }
  161.     With RecPack Do { Calculate time in seconds }
  162.       Time := (Cx Shr 8) * 3600.0 + (Cx Mod 256) * 60.0 + (Dx Shr 8);
  163.   End; { Function Time }
  164.  
  165. Procedure Terminate;
  166. { This procedure is called when the user Quits the program }
  167.   Var
  168.     ActiveTime,ActiveHours,ActiveMinutes,ActiveSeconds : Real;
  169.   Begin { Procedure Terminate }
  170.     If DiskInput Then { Selection file is open - close it }
  171.       Close(SelectionFile);
  172.     Window(1,1,80,25); { Restore full screen window }
  173.     ClrScr; { Leave the DOS level screen uncluttered except for final message }
  174.     FinishTime := Time; { Used To determine program run time }
  175.     If FinishTime < StartTime Then
  176.       FinishTime := FinishTime + 86400.0; { Add 24 hours after midnight }
  177.     ActiveTime := FinishTime - StartTime; { Program run time in seconds }
  178.     ActiveHours := Int(ActiveTime / 3600);
  179.     ActiveMinutes := Int((ActiveTime - ActiveHours * 3600) / 60);
  180.     ActiveSeconds := ActiveTime - ActiveHours * 3600 - ActiveMinutes * 60;
  181.     Write('Hbase active for ');
  182.     If ActiveHours > 0 Then
  183.       If ActiveHours > 1 Then
  184.         Write(ActiveHours:2:0,' hours ')
  185.       Else
  186.         Write(ActiveHours:2:0,' hour ');
  187.     If ActiveMinutes > 0 Then
  188.       If ActiveMinutes > 1 Then
  189.         Write(ActiveMinutes:2:0,' minutes ')
  190.       Else
  191.         Write(ActiveMinutes:2:0,' minute ');
  192.     If ActiveSeconds > 1 Then
  193.       Write(ActiveSeconds:2:0,' seconds')
  194.     Else
  195.       Write(ActiveSeconds:2:0,' second');
  196.     Writeln(' - returning to DOS ...');
  197.   End; { Procedure Terminate }
  198.  
  199. {$I SORT.BOX}  { Include Borland's SORT.BOX toolbox include file }
  200.  
  201. Procedure AssignSelections(AssignIndex : Integer);
  202. { Assign the raw selection variables to an element of the SelectionSetArray }
  203.   Begin { Procedure AssignSelections }
  204.     If AssignIndex < 10 Then { Valid index - proceed }
  205.       Begin { Then }
  206.         SelectionSetArray[AssignIndex].ClassSet   := ClassSet;
  207.         SelectionSetArray[AssignIndex].TypeSet    := TypeSet;
  208.         SelectionSetArray[AssignIndex].LowNGC     := LowNGC;
  209.         SelectionSetArray[AssignIndex].HighNGC    := HighNGC;
  210.         SelectionSetArray[AssignIndex].LowRAHr    := LowRAHr;
  211.         SelectionSetArray[AssignIndex].HighRAHr   := HighRAHr;
  212.         SelectionSetArray[AssignIndex].LowRAMin   := LowRAMin;
  213.         SelectionSetArray[AssignIndex].HighRAMin  := HighRAMin;
  214.         SelectionSetArray[AssignIndex].LowDecDeg  := LowDecDeg;
  215.         SelectionSetArray[AssignIndex].HighDecDeg := HighDecDeg;
  216.         SelectionSetArray[AssignIndex].LowDecMin  := LowDecMin;
  217.         SelectionSetArray[AssignIndex].HighDecMin := HighDecMin;
  218.         SelectionSetArray[AssignIndex].LowMag     := LowMag;
  219.         SelectionSetArray[AssignIndex].HighMag    := HighMag;
  220.         SelectionSetArray[AssignIndex].Constel    := Constel;
  221.       End { Then }
  222.     Else { Index overflow }
  223.       Begin { Else }
  224.         ClrScr;
  225.         Writeln('Too many selection sets selected. The maximum is 9.');
  226.         Writeln('Program will terminate - press space.');
  227.         WaitForSpace; { Let 'em read before calling Terminate }
  228.         Terminate; { Not the best place to stop }
  229.         Halt; { Terminate returns normally }
  230.       End; { Else }
  231.   End; { Procedure AssignSelections }
  232.  
  233. Procedure ReadList;
  234. { This procedure supplies a single record of input to procedure Inp (below).
  235.   ReadList reads from the static linked list containing the data file. This
  236.   is the normal source of input when the program begins, or after the user
  237.   has done an initialize. }
  238.   Begin { Procedure ReadList }
  239.     Object := CurrentPosition^.Data;          { Place data in Object variable }
  240.     CurrentPosition := CurrentPosition^.Next; { Advance 1 place in the list }
  241.     EndOfInput := CurrentPosition = Nil;      { Test for end-of-list }
  242.   End; { Procedure ReadList }
  243.  
  244. Procedure ReadArray;
  245. { This procedure supplies a single record of input to procedure Inp (below).
  246.   ReadArray reads from the SelectArray, which contains the user's currently
  247.   selected data. This array is the source of input whenever the user does a
  248.   second select-and-sort without first reinitializing. }
  249.   Begin { Procedure ReadArray }
  250.     Object := SelectArray[SelectPointer];     { Place data in Object variable }
  251.     SelectPointer := Succ(SelectPointer);     { Advance 1 place in the array }
  252.     EndOfInput := SelectPointer > EndOfArray; { Test for end-of-array }
  253.   End; { Procedure ReadArray }
  254.  
  255. Procedure ReadDisk;
  256. { This procedure supplies a single record of input to procedure Inp (below).
  257.   ReadDisk reads from the HBASE.DAT disk file, which is slow, but possibly
  258.   a user's only choice if he had insufficient free memory to load the data
  259.   catalog into a linked list. }
  260.   Begin { Procedure ReadDisk }
  261.     Read(SelectionFile,Object);       { Place data in Object variable }
  262.     EndOfInput := EOF(SelectionFile); { Test for end of file }
  263.   End; { Procedure ReadDisk }
  264.  
  265. Function ObjectInCurrentSelectionSet : Boolean;
  266. { This function tests the current object under consideration to see whether
  267.   it passes the tests against the values selcted & stored in the current
  268.   selection set (if you are merging input, then the contents of the
  269.   CurrentSelectionSet variables are being changed in proc. Inp.) }
  270.   Begin { Function ObjectInCurrentSelectionSet }
  271.     ObjectInCurrentSelectionSet := False;
  272.     With Object,CurrentSelectionSet Do
  273.       Begin { With }
  274.         If { This giant if statement is at the heart of the selection process }
  275.           Constel[Con] Then If
  276.           (Class In TypeSet) Then If
  277.           (NGC >= LowNGC) Then If
  278.           (NGC <= HighNGC) Then If
  279.           ((HighRAHr >= LowRAHr) And
  280.           (((RAHrs > LowRAHr) Or
  281.           ((RAHrs = LowRAHr) And
  282.           (RAMins >= LowRAMin))) And
  283.           ((RAHrs < HighRAHr) Or
  284.           ((RAHrs = HighRAHr) And
  285.           (RAMins <= HighRAMin))))) Or
  286.           { The 2nd set of R.A. comparisons are for the "backwards" case
  287.             Of LowRAHr > HighRAHr (to "wrap around" the 0 Hr. line.) }
  288.           ((HighRAHr < LowRAHr) And
  289.           (((RAHrs > LowRAHr) Or
  290.           ((RAHrs = LowRAHr) And
  291.           (RAMins >= LowRAMin))) Or { The "or" lets us select wrapped values }
  292.           ((RAHrs < HighRAHr) Or
  293.           ((RAHrs = HighRAHr) And
  294.           (RAMins <= HighRAMin))))) Then If
  295.           (DecDeg > LowDecDeg) Or
  296.           ((DecDeg = LowDecDeg) And
  297.           (DecDeg >= 0) And
  298.           (DecMin >= LowDecMin)) Or { See comment in Object type desc. }
  299.           ((DecDeg = LowDecDeg) And { concerning neg. DecMin values    }
  300.           (DecDeg < 0) And
  301.           (DecMin <= LowDecMin)) Then If
  302.           ((DecDeg < HighDecDeg) Or
  303.           ((DecDeg = HighDecDeg) And
  304.           (DecMin <= HighDecMin))) Then If
  305.           (Mag >= LowMag) Then If
  306.           (Mag <= HighMag) Then If
  307.           (HClass In ClassSet)
  308.         Then
  309.           ObjectInCurrentSelectionSet := True;
  310.        End; { With }
  311.   End; { Function ObjectInCurrentSelectionSet }
  312.  
  313. Procedure Inp;
  314. { This procedure is called by the Borland sort routines. This is where
  315.   the program compares each object against the values chosen by the user
  316.   creating selected input to the sort. }
  317.   Var
  318.     GoodObject : Boolean;
  319.     SelectionSetCounter : Byte;
  320.   Begin { Procedure Inp }
  321.     SelectPointer := 1; { See proc. ReadArray }
  322.     CurrentPosition := FirstPosition; { See proc. ReadList }
  323.     EndOfInput := False; { For procs. ReadList & ReadArray }
  324.     EndOfArray := InCount; { For proc. ReadArray }
  325.     InCount := 0; { Var. to keep track of # of currently selected objects }
  326.     { The following code advances the SelectionSetArray Index and stores the
  327.       current selection values in the array so it will be accessable.}
  328.     If (SelectionSetIndex = 0) Or Merging Then { Save values to selection set }
  329.       SelectionSetIndex := Succ(SelectionSetIndex);
  330.     AssignSelections(SelectionSetIndex); { In any case, we must save values }
  331.     If DiskInput Then { Prepare to read from disk }
  332.       Reset(SelectionFile); { Assigned in proc. Initialize }
  333.     Writeln('Reading and selecting input data'); { Look familiar? }
  334.     Repeat { Loop to extract all valid input to sort }
  335.       If Expanding Or (Not Selected) Then
  336.         If DiskInput Then
  337.           ReadDisk { Insufficient memory for in-memory operation }
  338.         Else
  339.           ReadList { All new input required - get it from linked list }
  340.       Else { Else we are selecting from pre-sorted data - use SelectArray }
  341.         ReadArray;
  342.       SelectionSetCounter := 0;
  343.       GoodObject := False;
  344.       Repeat { Loop to compare current object against all selections }
  345.         SelectionSetCounter := Succ(SelectionSetCounter); { Check all sets }
  346.         CurrentSelectionSet := SelectionSetArray[SelectionSetCounter];
  347.         GoodObject := ObjectInCurrentSelectionSet; { & look no further }
  348.       Until (SelectionSetCounter = SelectionSetIndex) Or GoodObject;
  349.       If GoodObject Then
  350.         Begin { Then }
  351.           SortRelease(Object); { Release object to Borland's sort }
  352.           InCount := Succ(InCount); { Keep count of objects selected }
  353.         End; { Then }
  354.     Until EndOfInput; { Set in procs. ReadList, ReadArray & ReadDisk }
  355.     Selected := True; { User is creating a select array }
  356.     Merging := False; { So further sorts don't increment SelectionSetIndex }
  357.     Expanding := False; { Either from merge or manual toggle }
  358.     Writeln(Incount,' records input to sort');
  359.     Writeln('Sorting'); { You'll stare at this line during the actual sort }
  360.   End; { Procedure Inp }
  361.  
  362. Procedure Outp;
  363. { This procedure takes the output from the sort and writes it to the select
  364.   array. This is the array on which all further operations will operate,
  365.   until the user "initializes". This procedure is called from Borland's sort
  366.   routines. }
  367.   Begin { Procedure Outp }
  368.     Writeln('Writing selected output data'); { The last sort screen message }
  369.     For Index := 1 To Incount Do
  370.       Begin { For }
  371.         SortReturn(Object); { Return records in order from Borland's sort }
  372.         SelectArray[Index] := Object; { Put 'em in the SelectArray }
  373.       End; { For }
  374.   End; { Procedure Outp }
  375.  
  376. Function Less; { Foward declared from the include file as type boolean }
  377. { This procedure is called by the Borland sort routines. Here is where the
  378.   actual comparison process for the sort takes place. The case statement
  379.   controls the fields sorted on, depending on the user's choice.
  380.   Note how multiple sort fields are used: R.A. is really R.A. Seconds within
  381.   R.A. minutes within R.A. hours, and many fields use R.A. as a default
  382.   secondary sort field. }
  383.   Var
  384.     FirstObject : HRecord Absolute X;  { Records are passed to Borland's sort }
  385.     SecondObject : HRecord Absolute Y; { by these absolute variables.  }
  386.   Begin { Function Less }
  387.     Case SortField Of { The same char. the user asked for in proc. Sort }
  388.       'H','h' : Less := (FirstObject.HClass < SecondObject.HClass) Or
  389.                         ((FirstObject.HClass = SecondObject.HClass) And
  390.                         (FirstObject.HNum < SecondObject.HNum));
  391.       'N','n' : Less := FirstObject.NGC < SecondObject.NGC;
  392.       'R','r' : Less := (FirstObject.RAHrs < SecondObject.RAHrs) Or
  393.                         ((FirstObject.RAHrs = SecondObject.RAHrs) And
  394.                         (FirstObJect.RAMins < SecondObject.RAMins)) Or
  395.                         (((FirstObject.RAHrs = SecondObject.RAHrs) And
  396.                         (FirstObject.RAMins = SecondObject.RAMins) And
  397.                         (FirstObject.RASecs < SecondObject.RASecs)));
  398.       'D','d' : Less := (FirstObject.DecDeg < SecondObject.DecDeg) Or
  399.                         ((FirstObject.DecDeg = SecondObject.DecDeg) And
  400.                         (FirstObject.DecDeg < 0) And
  401.                         (FirstObject.DecMin > SecondObject.DecMin)) Or
  402.                         ((FirstObject.DecDeg = SecondObject.DecDeg) And
  403.                         (FirstObject.DecDeg >= 0) And
  404.                         (FirstObject.DecMin < SecondObject.DecMin));
  405.       'M','m' : Less := (FirstObject.Mag < SecondObject.Mag) Or
  406.                         ((FirstObject.Mag = SecondObject.Mag) And
  407.                         ((FirstObject.RAHrs < SecondObject.RAHrs) Or
  408.                         ((FirstObject.RAHrs = SecondObject.RAHrs) And
  409.                         (FirstObJect.RAMins < SecondObject.RAMins)) Or
  410.                         (((FirstObject.RAHrs = SecondObject.RAHrs) And
  411.                         (FirstObject.RAMins = SecondObject.RAMins) And
  412.                         (FirstObject.RASecs < SecondObject.RASecs)))));
  413.       'O','o' : Less := (FirstObject.Class < SecondObject.Class) Or
  414.                         ((FirstObject.Class = SecondObject.Class) And
  415.                         ((FirstObject.RAHrs < SecondObject.RAHrs) Or
  416.                         ((FirstObject.RAHrs = SecondObject.RAHrs) And
  417.                         (FirstObJect.RAMins < SecondObject.RAMins)) Or
  418.                         (((FirstObject.RAHrs = SecondObject.RAHrs) And
  419.                         (FirstObject.RAMins = SecondObject.RAMins) And
  420.                         (FirstObject.RASecs < SecondObject.RASecs)))));
  421.       'C','c' : Less := (FirstObject.Con < SecondObject.Con) Or
  422.                         ((FirstObject.Con = SecondObject.Con) And
  423.                         ((FirstObject.RAHrs < SecondObject.RAHrs) Or
  424.                         ((FirstObject.RAHrs = SecondObject.RAHrs) And
  425.                         (FirstObJect.RAMins < SecondObject.RAMins)) Or
  426.                         (((FirstObject.RAHrs = SecondObject.RAHrs) And
  427.                         (FirstObject.RAMins = SecondObject.RAMins) And
  428.                         (FirstObject.RASecs < SecondObject.RASecs)))));
  429.     End; { Case }
  430.   End; { Function Less }
  431.  
  432. Procedure Error(ErrorNumber,ErrorAddress : Integer);
  433. { This procedure is a user written error handler. }
  434. { It will execute if an error occurs. }
  435.   Begin { Procedure Error }
  436.     ClrScr;
  437.     Writeln('HBASE has crashed.'); { In case the user hadn't noticed }
  438.     Writeln('Error code = ',ErrorNumber);
  439.     Writeln('Address of error = ',ErrorAddress);
  440.     Writeln('Consult the Turbo Pascal manual for explanation.');
  441.     Halt; { Stop the program "manually" after reporting error }
  442.   End; { Procedure Error }
  443.  
  444. Procedure InitializeVariables;
  445. { This procedure initializes various variables to their origional state. It
  446.   is called from procedure Initialize when the program first begins, and is
  447.   also the procedure called by the initialize option from the main menu. }
  448.   Begin { Procedure InitializeVariables }
  449.     Selected := False; { No data selected yet - can't precess }
  450.     CurrentEpoch := 1975.0; { The epoch of the data file }
  451.     SortField := ' ';
  452.     { The rest of the statements assign values to the selection variables that
  453.       will select for all possible objects. Thus, you get everything until you
  454.       narrow down these values in the selection procedures. }
  455.     ClassSet := [1..8];
  456.     TypeSet := [1..7];
  457.     LowNGC := 0;
  458.     HighNGC := 8000;
  459.     LowRAHr := 0;
  460.     HighRAHr := 24;
  461.     LowRAMin := 0;
  462.     HighRAMin := 0;
  463.     LowDecDeg := -90;
  464.     HighDecDeg := 90;
  465.     LowDecMin := 0;
  466.     HighDecMin := 0;
  467.     LowMag := 0.0;
  468.     HighMag := 170.0;
  469.     Constel := TrueConArray; { Each element = true, all const. selected }
  470.   End; { Procedure InitializeVariables }
  471.  
  472. Procedure Tab(NumberOfSpaces : Byte);
  473. { Tab over a number of spaces rather than writing space constants }
  474.   Begin { Procedure Tab }
  475.     GoToXY(WhereX + NumberOfSpaces,WhereY);
  476.   End; { Procedure Tab }
  477.  
  478. Procedure WriteTitleScreen;
  479. { Please leave this in place - I don't ask for money - just my name in lights }
  480.   Begin { Procedure WriteTitleScreen }
  481.     Clrscr;
  482.     Writeln; Writeln; Writeln;
  483.     Tab(32); Writeln('║   ║ ');
  484.     Tab(32); Writeln('╠═══╣ ');
  485.     Tab(32); Writeln('║   ║  B A S E');
  486.     Writeln; Writeln; LowVideo;
  487.     Tab(13); Writeln('A project in amateur astronomy by G. Dean Williams');
  488.     Writeln;
  489.     Tab(14); Writeln('Data by Sir William Herschel and Dennis Donnelly');
  490.     GoToXY(62,25); Write('Version 08 Mar. 87');
  491.   End; { Procedure WriteTitleScreen }
  492.  
  493. Procedure GetScreenType;
  494. { This procedure determines whether the system uses a monochrome or color
  495.   screen. This information is needed in procedure memorywrite. }
  496.   Var
  497.     Registers : Register;
  498.     Result    : Integer;
  499.     ScreenType : Byte;
  500.   Begin { Procedure GetScreenType }
  501.     INTR($11,Registers); { Interrupt to return screen type }
  502.     Result := Registers.AX; { The raw result is in register AX }
  503.     ScreenType := (Result Shl 10 ) Shr 14; { Extract screen type from result }
  504.     If ScreenType = 2 Then
  505.       VideoOfs := $8000 { Color system }
  506.     Else
  507.       VideoOfs := $0000; { Monochrome system }
  508.   End; { Procedure GetScreenType }
  509.  
  510. Procedure Initialize;
  511. { This procedure is called from the main program when the program starts.
  512.   It initializes a few necessary variables. }
  513.   Var
  514.     InFile : File Of HArray;
  515.     ConIndex : Byte;
  516.   Begin { Procedure Initialize }
  517.     StartTime := Time; { Used to calculate program run time }
  518.     WriteTitleScreen;
  519.     ErrorPtr := Ofs(Error); { Activate the error handler procedure }
  520.     AuxOutPtr := ConOutPtr; { Save ConOutPtr }
  521.     GetScreenType; { Monochrome or color system? }
  522.     Done := False; { See main program block }
  523.     For ConIndex := 0 To NumberOfConstellations Do { Used to select all cons }
  524.       TrueConArray[ConIndex] := True;
  525.     InitializeVariables; { The same proc. called from the main menu }
  526.     Merging := False; { Can't do this in InitializeVariables - catch 22 }
  527.     Expanding := False; { Same here }
  528.     NewSelection := False;
  529.     SelectionSetIndex := 0;
  530.     InCount := 0; { Nothing is selected/sorted yet }
  531.     Assign(InFile,'HBASE.DAT');
  532.     {$I-} Reset(Infile); {SI+} { I/O checking in case it isn't there }
  533.     If IOResult <> 0 Then { I/O error - file not found }
  534.       Begin { Then }
  535.         ClrScr; { The title screen just became unimportant }
  536.         Write(^G); { Ring bell to alert user to error }
  537.         Writeln('ERROR! - The file HBASE.DAT must be present in the current');
  538.         Writeln('directory of the current drive. Replace disk & type "R" to');
  539.         Write('retry, or type "H" to halt execution: ');
  540.         Repeat
  541.           Read(Kbd,Ch);
  542.         Until Upcase(Ch) In ['R','H'];
  543.         If Upcase(Ch) = 'R' Then
  544.           Reset(InFile) { No I/O checking - last chance }
  545.         Else
  546.           Halt; { Not good to have to stop while initializing! }
  547.       End; { Then }
  548.     Read(InFile,SelectArray); { Load the select array with one big disk read }
  549.     Close(InFile);
  550.     DiskInput := False;
  551.     If MemAvail < 4500 Then { Not enough memory to run the program }
  552.       Begin { Then }
  553.         Clrscr;
  554.         Write(^G); { Ring bell to alert user to error }
  555.         Writeln('Insufficient free memory. HBASE requires at least 200K of');
  556.         Writeln('free memory to run free of disk I/O. You may remove any');
  557.         Writeln('memory resident software & type "H" to halt execution for');
  558.         Writeln('a re-boot, or you may type "D" to run the program from disk');
  559.         Write('Your choice: ');
  560.         Repeat
  561.           Read(Kbd,Ch);
  562.         Until Upcase(Ch) In ['H','D'];
  563.         If Upcase(Ch) = 'D' Then
  564.           DiskInput := True
  565.         Else
  566.           Begin { Else }
  567.             Terminate; { Just to get run time & ending message }
  568.             Halt; { Hopefully in preparation for re-boot }
  569.           End; { Else }
  570.       End { Then }
  571.     Else
  572.       Begin { Else }
  573.         New(FirstPosition); { Starting place for linked list }
  574.         CurrentPosition := FirstPosition; { Start at the start }
  575.         For Index := 1 To NumberOfRecords - 1 Do
  576.           Begin { For loop to load the linked list from the select array }
  577.             CurrentPosition^.Data := SelectArray[Index]; { Load object to list }
  578.             New(CurrentPosition^.Next); { Increment position in liked list }
  579.             CurrentPosition := CurrentPosition^.Next; { Increment Position }
  580.           End; { For }
  581.         CurrentPosition^.Data := SelectArray[NumberOfRecords]; { Last object }
  582.         CurrentPosition^.Next := Nil; { The last entry points nowhere }
  583.       End; { Else }
  584.     InCount := NumberOfRecords;   { All objects are selected & sorted by H # }
  585.     If DiskInput Then { Open the data file for duration of run }
  586.       Assign(SelectionFile,'HBASE.DAT'); { We will close at end of run }
  587.   End; { Procedure Initialize }
  588.  
  589.  
  590. Procedure Sort;
  591. { This procedure contains the sort menu, chosen from the main menu }
  592.   Var
  593.     SortFieldHold : Char;
  594.     SortResult : Integer;
  595.   Begin { Procedure Sort }
  596.     ClrScr;
  597.     Window(20,1,80,25); { Center sort menu screen }
  598.     Ch := 'Y'; { In case we skip the following read }
  599.     If ((InCount >= NumberOfRecords) And (Not NewSelection))
  600.       Or (Not (Selected Or NewSelection) And (InCount = 0)) Then
  601.         Begin { Then }
  602.           Writeln;
  603.           Write('Really sort the entire catalog? (Y/N): ');
  604.           Repeat { Outer loop to catch those damn escape codes }
  605.             Repeat
  606.               Read(Kbd,Ch);
  607.             Until Upcase(Ch) In ['Y','N',#27];
  608.             If (Ch = #27) And Keypressed Then { Trap escape codes }
  609.               Begin { Then }
  610.                 Read(Kbd,Ch); { Read 2nd char of escape code }
  611.                 Ch := 'a'; { Look out for escape code with  "y" or "n" }
  612.               End; { Then }
  613.           Until Upcase(Ch) In ['Y','N'];
  614.           Writeln(Ch);
  615.         End; { Then }
  616.     If Upcase(Ch) = 'Y' Then { We are going to sort - proceed }
  617.       Begin { Then }
  618.         { The next line saves SortField in case it gets clobbered with "Q" }
  619.         SortFieldHold := SortField;
  620.         Writeln;
  621.         Writeln('You can sort on the following fields:');
  622.         Writeln;
  623.         HighVideo; Write('  H'); LowVideo; Writeln('erschel Class');
  624.         HighVideo; Write('  N'); LowVideo; Writeln('GC Number');
  625.         HighVideo; Write('  R'); LowVideo; Writeln('ight Ascension');
  626.         HighVideo; Write('  D'); LowVideo; Writeln('eclination');
  627.         HighVideo; Write('  M'); LowVideo; Writeln('agnitude');
  628.         HighVideo; Write('  O'); LowVideo; Writeln('bject Type');
  629.         HighVideo; Write('  C'); LowVideo; Writeln('onstellation');
  630.         Writeln;
  631.         Write('Type a letter to sort or "Q" to quit to previous screen: ');
  632.         Repeat { Outer loop to catch unwanted escape codes }
  633.           Repeat
  634.             Read(Kbd,SortField);
  635.           Until Upcase(SortField) In ['H','N','R','D','M','O','C','Q',#27];
  636.           If (SortField = #27) And Keypressed Then { Trap out escape codes }
  637.             Begin { Then }
  638.               Read(Kbd,SortField); { Get 2nd char of escape code }
  639.               SortField := 'a'; { So it isn't a sort field character }
  640.             End; { Then }
  641.         Until Upcase(SortField) In ['H','N','R','D','M','O','C','Q'];
  642.         HighVideo; Writeln(SortField); LowVideo;
  643.         Writeln;
  644.         If Upcase(SortField) <> 'Q' Then { A real sort field was entered }
  645.           Begin { Then }
  646.             NewSelection := False; { Selections are being sorted }
  647.             { The call to the actual sort is in the next line }
  648.             SortResult := TurboSort(SizeOf(HRecord)); { Call sort function }
  649.             If SortResult <> 0 Then { Report sort error }
  650.               Begin { Then }
  651.                 Writeln('--- Error Occured During Sort ---');
  652.                 Case SortResult Of
  653.                   3 : Writeln('Not enough free memory for sorting');
  654.                   10,11 : Writeln('Probable disk I/O error or disk full');
  655.                   12 : Writeln('Disk directory full');
  656.                 End; { Case SortResult }
  657.                 Write('Press Space To Continue');
  658.                 WaitForSpace;
  659.               End; { Then }
  660.           End { Then }
  661.         Else { The user did a "Q", so restore SortField }
  662.           SortField := SortFieldHold;
  663.       End; { Then }
  664.   End; { Procedure Sort }
  665.  
  666. Procedure WriteALine;
  667. { This procedure writes a single line of output, either to the screen,
  668.   or to the printer. It is called by procedures List and View. }
  669.  Var
  670.    RealMag : Real;
  671.  Begin { Procedure WriteALine }
  672.   With Object Do
  673.     Begin { With }
  674.       Write(Device,'   ',ClassNames[HClass],'-');
  675.       { Classnames are the roman numeral classes stored in ClassNames array }
  676.       If HNum < 10 Then    { We must test for & print all leading zeros so }
  677.         Write(Device,'00') { that all field columns line up evenly. }
  678.       Else
  679.         If HNum < 100 Then
  680.           Write(Device,'0');
  681.       Write(Device,HNum,'   ');
  682.       If NGC < 10 Then
  683.         Write(Device,'000')
  684.       Else
  685.         If NGC < 100 Then
  686.           Write(Device,'00')
  687.         Else
  688.           If NGC < 1000 Then
  689.             Write(Device,'0');
  690.       Write(Device,NGC,'   ');
  691.       If RAHrs < 10 Then
  692.         Write(Device,'0');
  693.       Write(Device,RAHrs,'/');
  694.       If RAMins < 10 Then
  695.         Write(Device,'0');
  696.       Write(Device,RAMins,'/');
  697.       If RASecs < 10 Then
  698.         Begin { Then }
  699.           Write(Device,'0');
  700.           Write(Device,RASecs:1,'   ');
  701.         End { Then }
  702.       Else
  703.         Write(Device,RASecs:2,'   ');
  704.       If (DecDeg < 0) Or (DecMin < 0) Then
  705.         Write(Device,'-')
  706.       Else
  707.         Write(Device,' ');
  708.       DecDeg := Abs(DecDeg); { We print neg. sign manually }
  709.       If Decdeg < 10 Then
  710.         Begin { Then }
  711.           Write(Device,'0');
  712.           Write(Device,DecDeg,'/');
  713.         End { Then }
  714.       Else
  715.         Write(Device,DecDeg,'/');
  716.       DecMin := Abs(DecMin); { See note in HRecord type description }
  717.       If DecMin < 10 Then
  718.         Write(Device,'0');
  719.       Write(Device,DecMin,'   ');
  720.       RealMag := Mag;
  721.       RealMag := RealMag / 10; { Magnitudes are all multiplied by 10 so }
  722.       If RealMag < 10 Then     { they can be stored as bytes & save space }
  723.         Begin { Then }
  724.           Write(Device,'0');
  725.           Write(Device,RealMag:3:1,'   ');
  726.         End { Then }
  727.       Else
  728.         Write(Device,RealMag:4:1,'   ');
  729.       Write(Device,TypeNames[Class]);
  730.       Write(Device,'   ',Names[Con],#13); { Write carriage return at end }
  731.     End; { With }
  732.   End; { Procedure WriteALine }
  733.  
  734. Procedure List;
  735. { This procedure sends the selected data to the printer }
  736.   Const
  737.     FormFeed = #12;
  738.   Var
  739.     NumberOfReports,CopyCount,LineCount : Byte;
  740.   Begin { Procedure List }
  741.     If NewSelection Then
  742.       Sort; { User cannot list data until it is sorted }
  743.     Assign(Device,'Lst:'); { So WriteALine will write to printer }
  744.     Reset(Device);
  745.     If InCount > 0 Then { There is something selected to print }
  746.       Begin { Then }
  747.         NumberOfReports := 1; { Default so user can just hit enter for 1 }
  748.         Writeln;
  749.         Repeat { Loop to get # of listings }
  750.           Write('Enter desired number of copies (default is 1): ');
  751.           {$I-} Readln(NumberOfReports) {$I+};
  752.           OK := (IoResult = 0) And (NumberOfReports > 0) And
  753.                 (NumberOfReports < 251);
  754.           If Not OK Then
  755.             Write(^G); { Ring bell to alert user to entry error }
  756.           If NumberOfReports > 250 Then
  757.             Writeln('The maximum number of listings is 250!');
  758.           Writeln;
  759.         Until OK;
  760.         ClrScr;
  761.         Writeln('Ready printer and press space to proceed');
  762.         Writeln('You can type "Q" at any time to stop printing ');
  763.         WaitForSpace;
  764.         CopyCount := 0;
  765.         Repeat { Loop for number of copies }
  766.           CopyCount := Succ(CopyCount);
  767.           GotoXY(1,4); { So object count will stay put between copies }
  768.           Writeln('List of selected objects going to printer.');
  769.           For LineCount := 1 To 3 Do
  770.             Writeln(Lst);
  771.           Writeln(Lst,' ',Heading);
  772.           Writeln(Lst);
  773.           LineCount := 5;
  774.           SelectPointer := 0;
  775.           Repeat { Loop for writing all selected objects }
  776.             SelectPointer := Succ(SelectPointer);
  777.             GoToXY(1,5); { Position for the following write statements }
  778.             Write(Succ(InCount) - SelectPointer,' objects left to print');
  779.             Write(' on copy ',CopyCount,' of ',NumberOfReports,'.    ');
  780.             If KeyPressed Then
  781.               Begin { Then }
  782.                 Read(Kbd,Ch); { Get the character }
  783.                 If (Ch = #27) And Keypressed Then { Extended scan code? }
  784.                   Begin { Then }
  785.                     Read(Kbd,Ch); { Get 2nd character of scan code }
  786.                     Ch := 'a'; { Trap unwanted "Q"s }
  787.                   End; { Then }
  788.                 If Upcase(Ch) = 'Q' Then
  789.                   SelectPointer := Incount; { Skip to end of list to stop }
  790.               End; { Then }
  791.             Object := SelectArray[SelectPointer]; { Get object to print }
  792.             WriteALine; { Write it to Lst: device }
  793.             Write(Lst,#10); { Line feed after carriage return from WriteALine }
  794.             LineCount := Succ(LineCount); { Keep count of print lines }
  795.             If LineCount > 62 Then { Time for new page }
  796.               Begin { Then }
  797.                 Write(Lst,FormFeed); { Form Feed At End Of Each Page }
  798.                 For LineCount := 1 To 3 Do
  799.                   Writeln(Lst);
  800.                 Writeln(Lst,' ',Heading);
  801.                 Writeln(Lst);
  802.                 LineCount := 5; { Adjust for heading lines }
  803.               End; { Then }
  804.           Until SelectPointer = Incount; { The last object }
  805.           Write(Lst,FormFeed); { Final form feed between copies }
  806.         Until (CopyCount = NumberOfReports) Or (Upcase(Ch) = 'Q');
  807.       End { Then }
  808.     Else
  809.       Begin { Else }
  810.         ClrScr; { So we don't scroll off main menu messages }
  811.         Write('No objects to list - Press Space To Continue ');
  812.         WaitForSpace;
  813.       End; { Else }
  814.   End; { Procedure List }
  815.  
  816. Procedure View;
  817. { This procedure contains the on-screen editor code }
  818.   Const
  819.     Escape = #27;
  820.   Var
  821.     PagePointer : Integer;
  822.     MaxDetailLines,Count : Byte;
  823.     FunKey,TopOfList,BottomOfList : Boolean;
  824.  
  825.   Procedure WriteScreen;
  826.   { This procedure is contained in, and is called by procedure view. It's
  827.     purpose is to write a screenful of output on the screen. }
  828.     Begin { Procedure WriteScreen }
  829.       ClrScr;
  830.       MaxDetailLines := 23; { Maximum detail lines on the view screen }
  831.       TopOfList := (PagePointer = 0);
  832.       If TopOfList Then { Write ** Top Of List ** message at top }
  833.         MaxDetailLines := Pred(MaxDetailLines); { Leave space for message }
  834.       BottomOfList := (InCount - PagePointer < MaxDetailLines);
  835.       If BottomOfList Then { Write ** Bottom Of List message at bottom }
  836.         MaxDetailLines := Pred(MaxDetailLines); { Leave space for message }
  837.       If InCount = 22 Then
  838.         MaxDetailLines := 21; { Don't write all 22 lines without message }
  839.       Row := 1; { For procedure MemoryWrite }
  840.       Col := 1;
  841.       Write(' Seq.',Heading,#13,#13); { Heading, CR, and & blank line }
  842.       If TopOfList Then
  843.         Write('                         *****   Top Of List   *****',#13);
  844.       Count := 0;
  845.       While (Count < MaxDetailLines) And (PagePointer + Count < InCount) Do
  846.         Begin { While loop to write a screenful of object lines }
  847.           Count := Succ(Count); { Index for SelectArray }
  848.           Object := SelectArray[PagePointer + Count]; { Get object to list }
  849.           Write(' ',PagePointer + Count:4); { Sequence # for listing }
  850.           WriteALine; { Write object to Con: device }
  851.         End; { While }
  852.       If BottomOfList Then
  853.         Write('                        *****   Bottom Of List   *****',#13);
  854.     End; { Procedure WriteScreen }
  855.  
  856. Procedure ViewHelp; { Display the viewer on-line help info }
  857.   Begin { Procedure ViewHelp }
  858.     Row := 1; { For procedure memorywrite }
  859.     Col := 1;
  860.     ClrScr;
  861.     Write(#13); { This writes a blank line }
  862.     Write('While in the viewer, the following keys apply:',#13,#13);
  863.     Write('F1 : Display this viewer help information.',#13);
  864.     Write('Page Up / Page Down.',#13);
  865.     Write('Home : to top of list.',#13);
  866.     Write('End  : to end of list.',#13);
  867.     Write('"S"  : seek record of a given sequence number.',#13);
  868.     Write('"E"  : skip halfway from current position to end of file.',#13);
  869.     Write('"B"  : skip halfway from current position to beginning of file.');
  870.     Write(#13,'"Q"  : quit the viewer and return to the main menu.',#13);
  871.     Write(#13);
  872.     Write('Press the space bar to return to the view screen',#13);
  873.     WaitForSpace;
  874.   End; { Procedure ViewHelp }
  875.  
  876.   Begin { Procedure View }
  877.     If NewSelection Then
  878.       Sort; { User cannot view data until it is sorted }
  879.     ConOutPtr := Ofs(MemoryWrite); { Activate screen output driver }
  880.     Assign(Device,'Con:'); { So WriteALine will write to the screen }
  881.     Reset(Device);
  882.     FunKey := False; { A cursor control key has not been pressed }
  883.     Window(1,1,80,25); { Set window size to entire screen }
  884.     If InCount > 0 Then { There is something selected to view }
  885.       Begin { Then }
  886.         PagePointer := 0; { Index to top of SelectArray }
  887.         WriteScreen; { Write initial screenful of output }
  888.         Repeat { Accept keyboard input until user "q"uits }
  889.           Repeat
  890.             Read(Kbd,Ch);
  891.             FunKey := (Ch = Escape) And KeyPressed;
  892.           Until FunKey Or (Upcase(Ch) In ['Q','B','E','S']);
  893.           If FunKey And (InCount > 21) Then { Respond to edit keys }
  894.             Begin { Then }
  895.               Read(Kbd,Ch); { Get 2nd character of code }
  896.               Case Ch Of
  897.                 #59 : Begin { Case F1 (help) }
  898.                         ViewHelp;
  899.                         WriteScreen;
  900.                       End; { Case F1 }
  901.                 #71 : Begin { Case home }
  902.                         PagePointer := 0; { Top of list }
  903.                         WriteScreen;
  904.                       End; { Case home }
  905.                 #79 : Begin { Case end }
  906.                         PagePointer := (InCount - 22); { Bottom of list }
  907.                         If PagePointer < 0 Then
  908.                           PagePointer := 0;
  909.                         If InCount = 22 Then { Special case for TOL message }
  910.                           PagePointer := 1;
  911.                         WriteScreen;
  912.                       End; { Case end }
  913.                 #73 : Begin { Case page up }
  914.                         PagePointer := PagePointer - 23; { Up in list }
  915.                         If PagePointer < 0 Then { Exceeded top of list }
  916.                           PagePointer := 0; { Top }
  917.                         WriteScreen;
  918.                       End; { Case page up }
  919.                 #81 : Begin { Case page down }
  920.                         PagePointer := PagePointer + MaxDetailLines; { Down }
  921.                         If PagePointer > (InCount - 22) Then { Exceeded list }
  922.                           Begin { Then }
  923.                             PagePointer := (InCount - 22); { Bottom }
  924.                             If PagePointer < 0 Then
  925.                               PagePointer := 0;
  926.                           End; { Then }
  927.                         If InCount = 22 Then
  928.                           PagePointer := 1;
  929.                         WriteScreen;
  930.                       End; { Case page down }
  931.               End; { Case }
  932.               Ch := ' '; { Space out values which might be read as input }
  933.             End { Then }
  934.           Else
  935.             If FunKey Then { Incount was < 21 so edit keys were ignored }
  936.               Begin { Then }
  937.                 Read(Kbd,Ch); { Get 2nd char of extended scan code }
  938.                 If Ch = #59 Then { User pressed F1 for help }
  939.                   Begin { Then }
  940.                     ViewHelp; { Display the help info }
  941.                     WriteScreen; { After the help info clobbers the screen }
  942.                   End; { Case F1 }
  943.                 Ch := ' '; { Space out value in Ch }
  944.               End; { Then }
  945.           If (Upcase(Ch) In ['B','E','S']) And (InCount > 21) Then
  946.             Begin { Then } { Skip halfway to beginning or end, }
  947.               Case Ch Of   { or skip to a particular sequence }
  948.                 'B','b' : PagePointer := PagePointer Div 2; { 1/2 way to top }
  949.                 'E','e' : Begin { Case E }
  950.                             PagePointer := PagePointer +
  951.                             (InCount - PagePointer) Div 2; { 1/2 way to end }
  952.                             If PagePointer > (InCount - 21) Then
  953.                               Begin { Then }
  954.                                 PagePointer := (InCount - 21);
  955.                                 If PagePointer < 0 Then
  956.                                   PagePointer := 0;
  957.                               End; { Then }
  958.                           End; { Case E }
  959.                 'S','s' : Begin { Case S }
  960.                             { Restore standard screen output driver }
  961.                             ConOutPtr := AuxOutPtr;
  962.                             { The viewer prints 1 object ahead of the }
  963.                             { pointer, so we'll add 1 for displaying it }
  964.                             PagePointer := Succ(PagePointer);
  965.                             ClrScr;
  966.                             Repeat { 2 repeat loops to get valid seek # }
  967.                               Repeat
  968.                                 Write('The viewer is currently positioned');
  969.                                 Writeln(' at sequence # ',PagePointer);
  970.                                 Write('Enter sequence number between 1 and ');
  971.                                 Write(InCount,' to seek: ');
  972.                                 {$I-} Readln(PagePointer); {$I+}
  973.                                 OK := IOResult = 0;
  974.                                 If Not OK Then
  975.                                   Write(^G); { Beep to indicate entry error }
  976.                                 Writeln;
  977.                               Until OK;
  978.                               AllOK := (PagePointer >= 1) And
  979.                                        (PagePointer <= InCount);
  980.                               If AllOK Then { Set pointer back for viewer }
  981.                                 PagePointer := Pred(PagePointer)
  982.                               Else
  983.                                 Write(^G); { Beep to indicate entry error }
  984.                             Until AllOK;
  985.                             If PagePointer > (InCount - 21) Then
  986.                               Begin { Then }
  987.                                 PagePointer := (InCount - 21);
  988.                                 If PagePointer < 0 Then
  989.                                   PagePointer := 0;
  990.                               End; { Then }
  991.                             { Go back to IO driver for view screen }
  992.                             ConOutPtr := Ofs(MemoryWrite);
  993.                           End; { Case S }
  994.               End; { Case }
  995.               WriteScreen; { After "B","E", or "S" entry }
  996.             End; { Then }
  997.         Until Upcase(Ch) = 'Q'; { Until user quits the viewer }
  998.       End { Then }
  999.     Else
  1000.       Begin { Else }
  1001.         ClrScr; { So we don't scroll off main menu messages }
  1002.         Row := 1; { Row & col for printing error message }
  1003.         Col := 1;
  1004.         Write('No objects to view - Press Space To Continue ');
  1005.         WaitForSpace;
  1006.         ClrScr; { Clear the larger view window before returning to main menu }
  1007.       End; { Else }
  1008.     ConOutPtr := AuxOutPtr; { Restore standard screen output driver }
  1009.   End; { Procedure View }
  1010.  
  1011. {$I SELECTS.INC}  { Include parameter selection procedures }
  1012.  
  1013. Procedure Precess;
  1014. { This procedure precesses the selected data's celestial coordinates to
  1015.   another epoch. The algolrithm is taken from Eric Burgess' CELESTIAL BASIC,
  1016.   and it is not as accurate as I would like. If you improve on it (even at a
  1017.   loss of speed), please let me know, 'cause I could use it myself. }
  1018.   Var
  1019.     R1,D1,T2,ChangeInRA,ChangeInDec,NewEpoch,
  1020.     RealMins,Difference,X,Y,Z,LastYear : Real;
  1021.  
  1022.   Function Tan (AngleInDegrees : Real): Real;
  1023.     { Represents the tangent of its degree-valued argument }
  1024.     Var
  1025.       Angle : Real;
  1026.     Function ConvertToRadians(Angle : Real): Real;
  1027.       Begin { Function ConvertToRadians }
  1028.         ConvertToRadians := Angle * (Pi / 180);
  1029.       End; { Function ConvertToRadians }
  1030.     Begin { Function Tan }
  1031.       Angle := ConvertToRadians(AngleInDegrees);
  1032.       Tan := Sin(Angle) / Cos(Angle);
  1033.     End; { Function Tan }
  1034.  
  1035.   Begin { Procedure Precess }
  1036.     If NewSelection Then
  1037.       Sort; { User cannot precess data until it is sorted }
  1038.     If Selected And (InCount > 0) Then
  1039.       Begin { Then }
  1040.         ClrScr;
  1041.         LastYear := CurrentEpoch;
  1042.         Repeat
  1043.           Write('Enter the new epoch: ');
  1044.           {$I-} Readln(NewEpoch) {$I+};
  1045.           OK := (IOResult = 0);
  1046.           If Not OK Then
  1047.             Write(^G); { Ring bell to alert user to entry error }
  1048.           Writeln;
  1049.         Until OK;
  1050.         ClrScr;
  1051.         Writeln('Selected data being precessed to epoch ',NewEpoch:7:2);
  1052.         Difference := NewEpoch - LastYear;
  1053.         CurrentEpoch := NewEpoch;
  1054.         For Index := 1 To InCount Do
  1055.           Begin { For }
  1056.             Object := SelectArray[Index]; { Get next object to precess }
  1057.             With Object Do { Precess it }
  1058.               Begin { With }
  1059.                 R1 := RAHrs + RAMins / 60 + RASecs / 3600;
  1060.                 D1 := DecDeg + DecMin / 60;
  1061.                 R1 := R1 * 15;
  1062.                 T2 := ((LastYear + NewEpoch) / 2 - 1900) / 100;
  1063.                 X := 3.07234 + (0.00186 * T2);
  1064.                 Y := 20.0468 - (0.0085 * T2);
  1065.                 Z := Y / 15;
  1066.                 ChangeInRA := 0.0042 * Difference *
  1067.                   (X + (Z * Sin(R1/57.29878) * Tan(D1/57.29878)));
  1068.                 R1 := R1 + ChangeInRA;
  1069.                 D1 := D1  + 0.00028 * Difference * Y * Cos(R1 / 57.29878);
  1070.                 R1 := R1 / 15;
  1071.                 If R1 > 24 Then
  1072.                   R1 := R1 - 24;
  1073.                 If R1 < 0 Then
  1074.                   R1 := R1 + 24;
  1075.                 RAHrs := Trunc(Int(R1));
  1076.                 RealMins := (60 * (R1 - Int(R1)));
  1077.                 RASecs := Trunc(60 * (RealMins - Int(RealMins)));
  1078.                 RAMins := Trunc(RealMins);
  1079.                 If D1 > 90 Then
  1080.                   D1 := 90 - (D1 - Int(D1));
  1081.                 DecDeg := Trunc(Int(D1));
  1082.                 DecMin := Trunc((D1 - Int(D1)) * 60);
  1083.                 If D1 < 0 Then
  1084.                   Begin { Then }
  1085.                     DecDeg := Trunc(Int(D1));
  1086.                     D1 := Abs(D1);
  1087.                     DecMin := Trunc(60 * (D1 - Int(D1)));
  1088.                   End; { Then }
  1089.               End; { With }
  1090.             SelectArray[Index] := Object; { Put precessed object back }
  1091.           End; { For }
  1092.       End { Then }
  1093.     Else
  1094.       Begin { Else }
  1095.         If InCount > 0 Then { Selected = False }
  1096.           Writeln('No data has been selected for precession')
  1097.         Else { Incount = 0 }
  1098.           Writeln('  No objects to precess');
  1099.         Write    (' Press space to continue ');
  1100.         WaitForSpace;
  1101.       End; { Else }
  1102.   End; { Procedure Precess }
  1103.  
  1104. {$I HELP.INC}  { Include the online help procedure }
  1105.  
  1106. Procedure MainMenu;
  1107. { This is the main menu called by the main program }
  1108.   Begin { Procedure MainMenu }
  1109.     ClrScr;
  1110.     Window(11,1,80,25); { Center the main menu screen }
  1111.     LowVideo; { Some procedures return in HighVideo mode }
  1112.     Writeln;
  1113.     If InCount <> 1 Then { Test to keep our grammar correct }
  1114.       Writeln('There are currently ',InCount,' objects selected.')
  1115.     Else
  1116.       Writeln('There is currently 1 object selected.');
  1117.     Writeln;
  1118.     HighVideo;
  1119.     If NewSelection Then { New selections not yet sorted - warn the user }
  1120.       Begin { Then }
  1121.         Writeln('New selections have not been sorted.');
  1122.         Writeln;
  1123.       End; { Then }
  1124.     If Expanding Then { Notify the user }
  1125.       Begin { Then }
  1126.         Writeln('Selections are being expanded.');
  1127.         Writeln;
  1128.       End; { Then }
  1129.     If Merging Then { Notify the user }
  1130.       Begin { Then }
  1131.         Write('Selections are being merged to selection set #');
  1132.         If Not Selected Then { SelectionSetIndex is minus 1 }
  1133.           Writeln(Succ(SelectionSetIndex))
  1134.         Else { It's OK after a sort }
  1135.           Writeln(SelectionSetIndex,'.');
  1136.         Writeln;
  1137.       End; { Then }
  1138.     LowVideo;
  1139.     Writeln('You can select a sub-listing by:');
  1140.     Writeln;
  1141.     HighVideo; Write('  H'); LowVideo; Writeln('erschel Class');
  1142.     HighVideo; Write('  N'); LowVideo; Writeln('GC Number');
  1143.     HighVideo; Write('  R'); LowVideo; Writeln('ight Ascension');
  1144.     HighVideo; Write('  D'); LowVideo; Writeln('eclination');
  1145.     HighVideo; Write('  B'); LowVideo; Writeln('rightness');
  1146.     HighVideo; Write('  O'); LowVideo; Writeln('bject Type');
  1147.     HighVideo; Write('  C'); LowVideo; Writeln('onstellation');
  1148.     Writeln;
  1149.     Write('Type a letter to select, or to ');
  1150.     HighVideo; Write('S'); LowVideo; Write('ort, ');
  1151.     HighVideo; Write('T'); LowVideo; Write('oggle expansion, ');
  1152.     HighVideo; Write('M'); LowVideo; Writeln('erge,');
  1153.     HighVideo; Write('E'); LowVideo; Write('xamine status, ');
  1154.     HighVideo; Write('I'); LowVideo; Write('nitialize, ');
  1155.     HighVideo; Write('V'); LowVideo; Write('iew, ');
  1156.     HighVideo; Write('L'); LowVideo; Write('ist, ');
  1157.     HighVideo; Write('P'); LowVideo; Write('recess, or ');
  1158.     HighVideo; Write('Q'); LowVideo; Writeln('uit.');
  1159.     Writeln;
  1160.     Write('You may type '); HighVideo; Write('F1 '); LowVideo;
  1161.     Writeln('for help.');
  1162.     Writeln;
  1163.     Write('Your Choice? ');
  1164.     Repeat
  1165.       Read(Kbd,Ch);
  1166.     Until Upcase(Ch) In ['H','N','R','D','M','C','O','E','B',
  1167.                          #27,'T','I','S','V','L','P','Q'];
  1168.     HighVideo; Writeln(Ch); LowVideo;
  1169.     Writeln;
  1170.     Case Ch Of
  1171.       #27 : Begin { Check for PF1 (help) else ignore extended code keys }
  1172.               If Keypressed Then
  1173.                 Read(Kbd,Ch); { Get 2nd character of extended scan code }
  1174.                 If Ch = #59 Then { PF1 was pressed }
  1175.                   MainMenuHelp
  1176.                 Else
  1177.                   Ch := ' '; { Space out unwanted 2nd character }
  1178.             End; { Case escape }
  1179.       'H','h' : SelectH;
  1180.       'N','n' : SelectNGC;
  1181.       'R','r' : SelectRA;
  1182.       'D','d' : SelectDec;
  1183.       'B','b' : SelectMag;
  1184.       'O','o' : SelectType;
  1185.       'C','c' : SelectCon;
  1186.       'L','l' : List;
  1187.       'P','p' : Precess;
  1188.       'V','v' : View;
  1189.       'S','s' : Sort;
  1190.       'E','e' : Begin { Case E }
  1191.                   If Not Selected Then { SelectionSetIndex is 1 behind }
  1192.                     Begin { Then }
  1193.                       DisplayIndex := Succ(SelectionSetIndex);
  1194.                       AssignSelections(DisplayIndex); { For displaying }
  1195.                     End { Then }
  1196.                   Else { Proc. Inp already incremented it to a proper value }
  1197.                     DisplayIndex := SelectionSetIndex;
  1198.                   ExamineStatus;
  1199.                 End; { Case E }
  1200.       'Q','q' : Begin { Case Q }
  1201.                   Write('Exit to DOS? (Y/N): ');
  1202.                   Repeat { Loop to catch those damn escape codes }
  1203.                     Repeat
  1204.                       Read(Kbd,Ch);
  1205.                     Until Upcase(Ch) In ['Y','N',#27];
  1206.                     If (Ch = #27) And Keypressed Then { Escape code pressed }
  1207.                       Begin { Then }
  1208.                         Read(Kbd,Ch); { Get 2nd char of escape code }
  1209.                         Ch := 'a'; { Weed out unwanted "y"s & "n"s }
  1210.                       End; { Then }
  1211.                   Until Upcase(Ch) In ['Y','N'];
  1212.                   Writeln(Ch);
  1213.                   Done := Upcase(Ch) = 'Y';
  1214.                 End; { Case Q }
  1215.       'T','t' : Expanding := Not Expanding; { Toggle it }
  1216.       'I','i' : Begin { Case I }
  1217.                   Merging := False; { Note following 3 seperate assignments }
  1218.                   Expanding := False;
  1219.                   NewSelection := False;
  1220.                   SelectionSetIndex := 0;
  1221.                   InCount := 0; { Nothing is selected/sorted yet }
  1222.                   InitializeVariables;
  1223.                 End; { Then }
  1224.       'M','m' : Begin { Case M }
  1225.                   Merging := True;
  1226.                   Expanding := True; { User will have to turn it off }
  1227.                   If Not selected Then { The sort hasn't incremented index }
  1228.                     SelectionSetIndex := Succ(SelectionSetIndex);
  1229.                   AssignSelections(SelectionSetIndex); { Save selections }
  1230.                   InitializeVariables; { Prepare for next set of selections }
  1231.                 End; { Case M }
  1232.     End; { Case }
  1233.   End; { Procedure MainMenu }
  1234.  
  1235. Begin { Program }
  1236.   Initialize;
  1237.   While Not Done Do
  1238.     MainMenu;
  1239.   Terminate;
  1240. End. { Program }
  1241.