DEFINITION MODULE RADECSTG;
TYPE Greek=(alpha,beta,gamma,
         delta,epsilon,eta,zeta,
         theta,kappa,lambda,omicron,notgreek);
     speclet=(o,b,a,f,g,k,m,r,n,s);
     spectype=RECORD L:speclet;N:[0..10] END;
PROCEDURE WRRA(RA:REAL3);
PROCEDURE WRDEC(DEC:REAL3);
PROCEDURE STRTORADEC(S:ARRAY OF CHAR;VAR OK:BOOLEAN):REAL3;
PROCEDURE WRSPECT(ST:spectype);
PROCEDURE STRTOSPECT(S:ARRAY OF CHAR;VAR ST:spectype;VAR OK:BOOLEAN);
PROCEDURE COMPST(P,Q:spectype):BOOLEAN;
PROCEDURE WRGREEK(C:Greek);
PROCEDURE STRTOGREEK(S:ARRAY OF CHAR):Greek;
END RADECSTG.
IMPLEMENTATION MODULE RADECSTG;
FROM STDIO IMPORT WRCHAR,WRSTR;
FROM NUMIO IMPORT WRCARD0,WRCARD,SUBSTRTOCARD,SUBSTRTOINT,STRTOCARD;
FROM STRINGS IMPORT CAPS,LENGTH;
FROM SYSTEM IMPORT ADR;
FROM DATA IMPORT SEARCHA;
CONST SIXTY=RL3(60.0);
 
PROCEDURE WR60(X:REAL3);
VAR M,S:CARDINAL;
    T:REAL3;
BEGIN
T:=SIXTY*X;
M:=CARD(T);
WRCARD0(M,2);WRCHAR('m');
S:=INT(SIXTY*(T-RL3(M)));
WRCARD0(S,2);WRCHAR('s');
END WR60;
 
PROCEDURE WRRA(RA:REAL3);
VAR H:CARDINAL;
BEGIN
H:=CARD(RA);
WRCARD0(H,2);WRCHAR('h');
WR60(RA-RL3(H))
END WRRA;
 
PROCEDURE WRDEC(DEC:REAL3);
VAR D:CARDINAL;
BEGIN
IF DEC<RL3(0) THEN 
  DEC:=-DEC;WRCHAR('-') END;
D:=CARD(DEC);
WRCARD(D,2);WRCHAR('d');
WR60(DEC-RL3(D));
END WRDEC;
 
PROCEDURE STRTORADEC(S:ARRAY OF CHAR;VAR OK:BOOLEAN):REAL3;
VAR P,M,Sec,L:CARDINAL;
    negative:BOOLEAN;
    X:REAL3;
BEGIN
P:=0;L:=LENGTH(S);
WHILE S[P]=' ' DO INC(P) END;
negative:=S[P]='-';
IF negative THEN INC(P) END;
X:=RL3(SUBSTRTOCARD(S,P,OK));
INC(P);
IF P<L THEN 
  M:=SUBSTRTOCARD(S,P,OK);
  INC(P);
  IF P<L THEN 
    Sec:=SUBSTRTOCARD(S,P,OK) 
   ELSE Sec:=0 END;
  IF (Sec>=60) OR (M>=60) THEN 
    OK:=FALSE END;
  X:=X+(RL3(M)+RL3(Sec)/SIXTY)/SIXTY END;
IF negative THEN RETURN -X
 ELSE RETURN X END
END STRTORADEC;
 
VAR spectchs:ARRAY [0..9] OF CHAR;

PROCEDURE WRSPECT(ST:spectype);
BEGIN WITH ST DO
WRCHAR(spectchs[ORD(L)]);
WRCARD(N,1)
END END WRSPECT;
 
PROCEDURE STRTOSPECT(S:ARRAY OF CHAR;VAR ST:spectype;VAR OK:BOOLEAN);
VAR I:CARDINAL;
BEGIN WITH ST DO
I:=0;
LOOP
  IF spectchs[I]=S[0] THEN 
    L:=VAL(speclet,I);
    OK:=TRUE;EXIT END;
  INC(I);
  IF I=10 THEN 
    OK:=FALSE;RETURN END END;
N:=STRTOCARD(S[1],OK);
END END STRTOSPECT;
 
PROCEDURE COMPST(P,Q:spectype):BOOLEAN;
BEGIN
IF (P.L=Q.L) THEN RETURN P.N>=Q.N
ELSE RETURN P.L>Q.L END
END COMPST;
 
TYPE GLNAME=ARRAY [0..6] OF CHAR;
VAR G:ARRAY Greek OF GLNAME;

PROCEDURE WRGREEK(C:Greek);
BEGIN
WRSTR(G[C])
END WRGREEK;

PROCEDURE STRTOGREEK(S:ARRAY OF CHAR):Greek;
CONST GSIZ=ORD(MAX(Greek));
VAR P:POINTER TO GLNAME;
    N:CARDINAL;
BEGIN
CAPS(S);P:=ADR(G);N:=GSIZ;
IF (LENGTH(S)=1) AND (S[0]='H') THEN 
  RETURN eta
 ELSIF SEARCHA(P,N,7,ADR(S[0]),LENGTH(S)) THEN
  RETURN VAL(Greek,GSIZ-N)
 ELSE RETURN notgreek END
END STRTOGREEK;
 
PROCEDURE initgreek;
BEGIN
G[alpha]:='ALPHA';
G[beta]:='BETA';
G[gamma]:='GAMMA';
G[delta]:='DELTA';
G[epsilon]:='EPSILON';
G[zeta]:='ZETA';
G[eta]:='ETA';
G[theta]:='THETA';
G[kappa]:='KAPPA';
G[lambda]:='LAMBDA';
G[omicron]:='OMICRON';
G[notgreek]:=''
END initgreek;
 
BEGIN
initgreek;
spectchs:='OBAFGKMRNS';
END RADECSTG.
