MODULE STARBASE;
FROM SYSTEM IMPORT ADDRESS,ADR,TSIZE;
FROM GRAPH0 IMPORT SETATTRS;
FROM FASTO IMPORT FASTOUT,WRITEAT;
FROM MAINREAD IMPORT EDITPREP,EDITL,BLANK,entrych,exitch,EDIT;
FROM RADECSTG IMPORT spectype,STRTORADEC,STRTOSPECT,
      Greek,WRRA,WRGREEK,WRDEC,WRSPECT,STRTOGREEK,COMPST;
FROM STDIO IMPORT WRSTR,GOTOXY,WRSTRLEN,GETXY,WAITKEY,
      PRINTABLE,STDOUT,WRSPS,CLS,WRSUBSTR,WRCHAR;
FROM R3IO IMPORT WRR3,STRTOR3,WRR3FIX;
FROM STRINGS IMPORT COPY,LENGTH,COMPARE;
FROM DATA IMPORT QSORT,SEARCHA,MATCH,GPROC,CLEAR,MOVE;
FROM NUMIO IMPORT WRCARD,WRINT;
FROM DRIVES IMPORT LOAD,SAVE,FileLen;
CONST maxstarno=512;
CONST edit  =07I;
      left  =08I;
      right =09I;
      down  =0AI;
      up    =0BI;
      delete=0CI;
      enter =0DI;
TYPE tstarno=[1..maxstarno];
  STARINFO=RECORD
   CONSTEL:ARRAY [0..2] OF CHAR;
   PNAME:ARRAY [0..15] OF CHAR;
   LETTER:Greek;
   MAG:REAL3;
   RA,Dec:REAL3;
   SPECT:spectype;
  END;
  starif=
  (let,con,pnam,mag,ra,dec,spt);
  starifs=SET OF starif;
  LOHI=(lo,hi);
CONST SISIZ=TSIZE(STARINFO);
VAR [0C000H]
  listno,starno:[0..maxstarno];
  StarBase:ARRAY tstarno OF STARINFO;
VAR ch:CHAR;

PROCEDURE PTITLES;
VAR s:starif;
BEGIN
FOR s:= let TO spt DO 
  GOTOXY(1,2*ORD(s)+2);
  FTITLE(s) END;
END PTITLES;

PROCEDURE FTITLE(N:starif);
BEGIN CASE N OF
let:WRSTR('Gr. Letter: ')|
con:WRSTR('Constellation: ')|
pnam:WRSTR('Proper Name: ')|
mag:WRSTR('Magnitude: ')|
ra:WRSTR('RA: ')|
dec:WRSTR('DEC: ')|
spt:WRSTR('Spectral Type: ')|
END END FTITLE;

PROCEDURE PRINTINFO(S:STARINFO);
BEGIN WITH S DO
CLS;PTITLES;
GOTOXY(13,2);WRGREEK(LETTER);
WRITEAT(16,4,CONSTEL);
WRITEAT(14,6,PNAME);
GOTOXY(12,8);WRR3FIX(MAG,6,2);
GOTOXY(9,10);WRRA(RA);
GOTOXY(8,12);WRDEC(Dec);
GOTOXY(16,14);WRSPECT(SPECT);
END END PRINTINFO;
 
VAR L:ARRAY starif OF CARDINAL;
PX:ARRAY starif OF 
       ARRAY LOHI OF SHORTCARD;
PROCEDURE SETPXL;
VAR c:starif;
BEGIN
PX[let,lo]:=13;L[let]:=7;
PX[con,lo]:=16;L[con]:=3;
PX[pnam,lo]:=14;L[pnam]:=16;
PX[mag,lo]:=12;L[mag]:=6;
PX[ra,lo]:=9;L[ra]:=9;
PX[dec,lo]:=8;L[dec]:=10;
PX[spt,lo]:=16;L[spt]:=2;
FOR c:=let TO spt DO
  PX[c,hi]:=PX[c,lo]+L[c]+4 END
END SETPXL;

VAR TS:ARRAY [0..15] OF CHAR;
PROCEDURE TSTOITEM(VAR S:STARINFO; N:starif):BOOLEAN;
VAR OK:BOOLEAN;
BEGIN OK:=TRUE;
WITH S DO CASE N OF
   let:LETTER:=STRTOGREEK(TS);
    RETURN LETTER<>notgreek|
   con:COPY(TS,CONSTEL);|
   pnam:COPY(TS,PNAME);|
   mag:MAG:=STRTOR3(TS,OK)|
   ra:RA:=STRTORADEC(TS,OK)|
   dec:Dec:=STRTORADEC(TS,OK)|
   spt:STRTOSPECT(TS,SPECT,OK) 
    END END;
RETURN OK
END TSTOITEM;
VAR fgiven:starifs;
PROCEDURE EDITINFO(VAR S:STARINFO);
VAR N:starif;
    CH:CHAR;
    PXN,PY,LN:CARDINAL;
BEGIN PRINTINFO(S);N:=let;
WITH S DO
  LOOP PXN:=PX[N,lo];
    PY:=2*ORD(N)+2;LN:=L[N];
    SETATTRS(PXN,PY,LN,30H);
    GOTOXY(PXN,PY);
    CH:=WAITKEY();
    SETATTRS(PXN,PY,LN,38H);
    IF (CH=edit) 
        OR PRINTABLE(CH) THEN 
      EDITPREP(LN);entrych:=CH;
      IF N=con THEN 
        COPY(CONSTEL,TS)
       ELSIF N=pnam THEN 
        COPY(PNAME,TS)
       ELSE BLANK(PXN,PY,LN);
       CLEAR(TS) END;
      LOOP EDITL(TS);CH:=exitch;
        IF TSTOITEM(S,N) THEN 
          INCL(fgiven,N);
          EXIT END;
        MESSAGE(5);
        entrych:=WAITKEY();
        MESSAGE(0) END END;
    CASE CH OF
     up:IF N>let THEN 
        DEC(N) END|
     enter,down:IF N<spt THEN 
        INC(N)
       ELSIF con IN fgiven THEN 
        EXIT END END END END
END EDITINFO;

PROCEDURE PRINTLINE(S:STARINFO);
BEGIN WITH S DO
STDOUT(3);
WRSTR('Name: ');WRGREEK(LETTER);
WRSTRLEN(CONSTEL,5);
FTITLE(pnam);WRSTR(PNAME);
WRSPS(2);
FTITLE(mag);WRR3(MAG,6,2);
FTITLE(ra);WRRA(RA);WRDEC(Dec);
FTITLE(dec);WRSPECT(SPECT);
FASTOUT;
END END PRINTLINE;
VAR LIMS:ARRAY LOHI OF STARINFO; 
PROCEDURE GETLIMS;
 
PROCEDURE NULLITEM(N:starif;r:LOHI);
BEGIN IF r=hi THEN
  WITH LIMS[hi] DO CASE N OF
     let:LETTER:=LIMS[lo].LETTER|
     mag:MAG:=LIMS[lo].MAG|
     dec:Dec:=LIMS[lo].Dec|
     spt:SPECT:=LIMS[lo].SPECT|
     ra:RA:=LIMS[lo].RA END END
 ELSE EXCL(fgiven,N);
  WRSPS(14) END
END NULLITEM;

VAR OK:BOOLEAN;
    PY,PXN,X,LN:CARDINAL;
    CH:CHAR;
    r:LOHI;
    N:starif;
    higiven:starifs;
CONST FRANGE=starifs{let,mag..spt};
BEGIN WITH LIMS[lo] DO
CLS;fgiven:=starifs{};
higiven:=fgiven;CLEAR(LIMS[lo]);
N:=let;r:=lo;
PTITLES;
LOOP PY:=2*ORD(N)+2;
  PXN:=PX[N,r];LN:=L[N];
  IF r=hi THEN 
    WRITEAT(PX[N,lo]+LN,PY,' To') END;
  SETATTRS(PXN,PY,LN,30H);
  GOTOXY(PXN,PY);
  CH:=WAITKEY();
  SETATTRS(PXN,PY,LN,38H);
  IF (CH=edit) OR 
     PRINTABLE(CH) THEN 
    entrych:=CH;
    IF N=con THEN 
      COPY(CONSTEL,TS)
     ELSIF N=pnam THEN 
      COPY(PNAME,TS)
     ELSE BLANK(PXN,PY,LN);
      CLEAR(TS) END;
    EDITPREP(LN);
    LOOP EDIT(TS);CH:=exitch;
      IF LENGTH(TS)=0 THEN 
        NULLITEM(N,r);EXIT
       ELSIF TSTOITEM(LIMS[r],N) THEN
        IF r=hi THEN 
          INCL(higiven,N)
         ELSIF N IN FRANGE THEN
          INCL(fgiven,N);
          IF NOT (N IN higiven) THEN
            NULLITEM(N,hi) END END;
        EXIT END;
      MESSAGE(5);entrych:=WAITKEY();
      MESSAGE(0) END END;
  IF (r=hi) AND 
     NOT (N IN higiven) THEN
    WRITEAT(PX[N,lo]+LN,PY,'   ') END;
  CASE CH OF
    up:IF N>let THEN DEC(N) END|
    down:IF N<spt THEN INC(N) 
      ELSE EXIT END|
    right,enter:
     IF (r=lo)AND (N IN fgiven) THEN 
       r:=hi
      ELSIF N<spt THEN 
       INC(N);r:=lo 
      ELSE EXIT END|
    left:IF r=hi THEN 
       r:=lo 
      ELSIF N>let THEN 
       DEC(N);r:=hi END END;
  IF (r=hi) AND NOT (N IN fgiven) THEN 
    r:=lo END;
END
END END GETLIMS;
 
PROCEDURE ADDSTARS;
BEGIN WHILE starno<maxstarno DO
INC(starno);CLS;
CLEAR(StarBase[starno]);
fgiven:=starifs{};
EDITINFO(StarBase[starno]);
IF starno=maxstarno THEN 
  RETURN END;
MESSAGE(4);
IF WAITKEY()=' ' THEN 
  RETURN END;
END END ADDSTARS;
 
VAR l:ARRAY tstarno OF tstarno;
 
PROCEDURE DISPLAY;
VAR i,j:tstarno;
    ch:CHAR;
    P:ADDRESS;
BEGIN 
i:=1;
WHILE i<=listno DO
  CLS;PRINTINFO(StarBase[l[i]]);
  MESSAGE(4);
  IF i<listno THEN
    WRITEAT(0,20,'Press ENTER for next record') END;
  WRITEAT(0,21,'Press EDIT to alter record');
  WRITEAT(0,22,'Press DELETE to delete record');
  ch:=WAITKEY();
  BLANK(0,20,128);
  IF ch=edit THEN 
    fgiven:=starifs{let..spt};
    EDITINFO(StarBase[l[i]]);
    INC(i);
   ELSIF ch=delete THEN
    P:=ADR(StarBase[l[i]]);
    MOVE(P+SISIZ,P,(starno-l[i])*SISIZ);
    FOR j:=1 TO listno DO
      IF l[j]>l[i] THEN 
        DEC(l[j]) END END;
    P:=ADR(l[i]);
    MOVE(P+TSIZE(tstarno),P,(listno-i)*TSIZE(tstarno));
    DEC(starno);DEC(listno);
   ELSIF ch=' ' THEN RETURN 
   ELSE INC(i) END END;
END DISPLAY;
 

PROCEDURE FGRT(VAR S1,S2:STARINFO):BOOLEAN;
VAR r:INTEGER;
BEGIN CASE COMPN OF
 let:RETURN S1.LETTER>S2.LETTER|
(* con orders by constellation 
 & letter, not constel. alone *)
 con:
  r:=COMPARE(S1.CONSTEL,S2.CONSTEL);
  IF r=0 THEN 
    RETURN S1.LETTER>S2.LETTER 
   ELSE RETURN r>0 END|
 pnam:RETURN COMPARE(S1.PNAME,S2.PNAME)>0|
 mag:RETURN S1.MAG>S2.MAG|
 ra:RETURN S1.RA>S2.RA|
 dec:RETURN S1.Dec>S2.Dec|
 spt:RETURN COMPST(S1.SPECT,S2.SPECT)
END END FGRT;

VAR COMPN:starif;
PROCEDURE AFGRT(i,j:CARDINAL):BOOLEAN;
BEGIN
RETURN FGRT(StarBase[l[i]],StarBase[l[j]])
END AFGRT;

PROCEDURE SWAP(i,j:CARDINAL);
VAR t:tstarno;
BEGIN
t:=l[i];l[i]:=l[j];l[j]:=t
END SWAP;

PROCEDURE MESSAGE(n:SHORTCARD);
BEGIN
BLANK(0,23,32);
CASE n OF
1:WRSTR('   Press Required number')|
2:WRSTR('****** Sorting ******')|
3:WRSTR('***** Searching *****')|
4:WRSTR('Press SPACE to exit to menu')|
5:WRSTR('Invalid entry - Please re-enter')
END
END MESSAGE;

PROCEDURE SEARCH;
VAR P:POINTER TO STARINFO;
    n:CARDINAL;
    accept:BOOLEAN;
BEGIN
GETLIMS;
MESSAGE(3);
P:=ADR(StarBase);
n:=starno;
listno:=0;
WRITEAT(15,0,'No Stars Found');
WITH LIMS[lo] DO
  WHILE SEARCHA(P,n,SISIZ,ADR(CONSTEL),LENGTH(CONSTEL)) DO
    accept:=MATCH(ADR(P^.PNAME),ADR(PNAME),LENGTH(PNAME));
    FOR COMPN:=let TO spt DO 
      IF COMPN IN fgiven THEN
        accept:=accept AND NOT FGRT(LIMS[lo],P^) AND NOT FGRT(P^,LIMS[hi]) END E
ND;
    IF accept THEN INC(listno);
      l[listno]:=starno+1-n;
      GOTOXY(14,0);
      WRCARD(listno,3) END;
    P:=ADDRESS(ADDRESS(P)+SISIZ);
    DEC(n) END END;
MESSAGE(0)
END SEARCH;
 
PROCEDURE MAINPRT;
BEGIN
CLS;
WRITEAT(8,2,'MAIN MENU');
WRITEAT(1,4,'0: Exit from program');
WRITEAT(1,6,'1: Load Database from drive');
WRITEAT(1,8,'2: Search Database');
WRITEAT(1,10,'3: Add stars to database');
WRITEAT(1,12,'4: Save database to drive');
END MAINPRT;

VAR GRT:GPROC;
PROCEDURE SORTLIST;
BEGIN
MESSAGE(2);
QSORT(1,listno,GRT,SWAP)
END SORTLIST;
VAR G1:ARRAY [0..10] OF CHAR;
PROCEDURE LISTLINE(VAR S:STARINFO);

PROCEDURE SPACE;
BEGIN WRCHAR(' ') END SPACE;

BEGIN WITH S DO
WRCHAR(G1[ORD(LETTER)]);
WRSTRLEN(CONSTEL,4);SPACE;
WRSUBSTR(PNAME,0,10);SPACE;
WRR3FIX(MAG,4,1);SPACE;
WRCARD(CARD(RA),2);SPACE;
WRINT(INT(Dec),3);SPACE;
WRSPECT(SPECT)
END END LISTLINE;
 
PROCEDURE SHORTLIST;
VAR i:tstarno;ln:SHORTCARD;
    ch:CHAR;
BEGIN
MESSAGE(0);ln:=0;CLS;
FOR i:=1 TO listno DO
  IF ln=22 THEN MESSAGE(4);
    IF WAITKEY()=' ' THEN RETURN 
     ELSE CLS;ln:=0 END END;
  GOTOXY(0,ln);
  LISTLINE(StarBase[l[i]]);
  INC(ln) END;
MESSAGE(4);ch:=WAITKEY()
END SHORTLIST;
 
PROCEDURE OPTPRT;
BEGIN
WRITEAT(1,3,'0: Return to Main Menu');
WRITEAT(1,5,'1: Display records 1 at a time');
WRITEAT(1,7,'2: List records in short form');
WRITEAT(1,9,'3: List records to printer');
WRITEAT(1,11,'4: Sort list by name');
WRITEAT(1,13,'5: Sort list by proper name');
WRITEAT(1,15,'6: Sort list by magnitude');
WRITEAT(1,17,'7: Sort list by R.A.');
WRITEAT(1,19,'8: Sort list by Dec.');
WRITEAT(1,21 ,'9: Sort list by Spectral type');
END OPTPRT;

PROCEDURE OPTIONS;
VAR ch:CHAR;i:tstarno;
BEGIN
REPEAT
  CLS;
  OPTPRT;
  GOTOXY(14,0);WRCARD(listno,3);
  WRSTR(' stars selected');
  IF listno=1 THEN 
    WRITEAT(22,0,' ') END;
  MESSAGE(1);
  REPEAT ch:=WAITKEY() 
    UNTIL (ch>='0') AND (ch<='9');
  CASE ch OF 
   '1':CLS;DISPLAY|
   '2':SHORTLIST|
   '3':FOR i:=1 TO listno DO 
      PRINTLINE(StarBase[l[i]]) END|
   '4':GRT:=AFGRT;
    COMPN:=con;SORTLIST|
   '5'..'9':GRT:=AFGRT;
    COMPN:=VAL(starif,ORD(ch)-(ORD('5')-ORD(pnam)));
    SORTLIST END;
  CLS 
UNTIL ch='0' 
END OPTIONS;

BEGIN
starno:=0;
G1:='ABGDEHZTKLO';SETPXL;
LOOP
 MAINPRT;
 GOTOXY(23,0);WRCARD(starno,3);
 WRSTR(' Stars');
 IF starno=1 THEN 
   WRITEAT(31,0,' ') END;
 MESSAGE(1);
 REPEAT ch:=WAITKEY() 
  UNTIL (ch>='0') AND (ch<='4');
 CASE ch OF 
  '0':EXIT|
  '1':LOAD(1,'STARS',ADR(starno))|
  '2':SEARCH;OPTIONS|
  '3':ADDSTARS|
  '4':SAVE(1,'STARS',ADR(starno),2+starno*SISIZ) END END
END STARBASE.
