|
DataMuseum.dkPresents historical artifacts from the history of: MIKADOS |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about MIKADOS Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 32864 (0x8060)
Types: TextFile
Notes: Mikados_K
Names: »SKÆRMBIM.K«
└─⟦5630b2e42⟧ Bits:30009005 START APRIL 1985 aft april 1985 (PASCAL kildetekster)
└─⟦this⟧ »SKÆRMBIM.K«
PROGRAM SKÆRMBILLEDGENERATOR;
CONST MAXFELTER=45;
MAXPOST=250;
TYPE
PARMARRAY=PACKED ARRAY (1..39) OF CHAR;
NFELT=^FELTBESKRIVELSE;
NIVEAU=(MENIG,SERGENT,LØJTNANT,KAPTAJN,MAJOR,OBERST,GENERAL,HSM,UMULIUS);
SKÆRMPOS=RECORD
X,Y:INTEGER
END;
FTYPE=(HELTAL,DOBBTAL,REEL,TEKST);
VTYPE=(HINTERVAL,DINTERVAL,RINTERVAL,DATO,CPR);
BESKRIVELSESTYPE=(FELTDESC,VALIDESC);
FELTBESKRIVELSE=RECORD
NÆSTEVAL:NFELT;
FELTNAVN:STRING(8);
CASE DESCTYPE:BESKRIVELSESTYPE OF
FELTDESC:
(INDPOS,UDPOS:SKÆRMPOS;
KIKKENIVEAU,ÆNDRENIVEAU:NIVEAU;
EDITERING:INTEGER;
LEDETEKST,FØLGETEKST:STRING;
INDEKS:INTEGER;
LÆNGDE:INTEGER;
HÆGTE,
FORAN0:INTEGER;
CASE FELTTYPE:FTYPE OF
REEL:(DEC:INTEGER);
HELTAL,DOBBTAL,TEKST:());
VALIDESC:
(CASE VALIDITETSTYPE:VTYPE OF
HINTERVAL:(MIN,MAX:INTEGER);
DINTERVAL:(MIN1,MIN2,MAX1,MAX2:INTEGER);
RINTERVAL:(RMIN,RMAX:REAL);
DATO,CPR:())
END;
FELTFIL=FILE OF FELTBESKRIVELSE;
AR=ARRAY (-4..-4) OF INTEGER;
ARAR=PACKED ARRAY (-11..-10) OF CHAR;
RAR=ARRAY (0..0) OF REAL;
OPERATIONSPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
CONTENTS: ARRAY (1..MAXPOST) OF INTEGER
END;
FILDESC=RECORD
FILNAVN:STRING(18); (*ISF-FILENS NAVN*)
DESCNAVN:STRING(18); (*NAVNET PÅ DEN ENKELTE ISF-FILS BESKRIVELSESFIL*)
POSTNAVN:STRING(18); (*NAVNET PÅ ET INDIVID I FILEN*)
REGNAVN:STRING(18); (*FILENS BETEGNELSE*)
VEDLNIVEAU:NIVEAU;(*ADGANGSNIVEAU FOR GENERELT VEDLIGEHOLDELSESPROGRAM*)
ZONESIZE:INTEGER
END;
FILEDESC=FILE OF FILDESC;(*FORTEGNELSE OVER ALLE ISF-FILER*)
VAR PARM:^PARMARRAY;
QUQ:^INTEGER;
FELT:NFELT;
USERNIVEAU,HUSKNIV:NIVEAU;
PICTURE:ARRAY (1..MAXFELTER) OF NFELT;
I,ANTALFELTER:INTEGER;
LINE:STRING;
POST:OPERATIONSPOST;
FFIL:FELTFIL;
FNAVN:STRING;
NIVEAUD:ARRAY (0..9) OF STRING(8);
FTYPED: ARRAY (0..4) OF STRING(8);
VTYPED: ARRAY (0..5) OF STRING(9);
PROCEDURE IOC;
VAR CH:STRING(1);
BEGIN
IF IORESULT<>0 THEN
BEGIN
CLEARSCREEN;
GOTOXY(1,10);
WRITELN('Pladefejl ',IORESULT:5,' RETURN');
CH:=' ';
EDIT(CH);
IF CH<>'R' THEN EXIT(SKÆRMBIL)
END
END;
(*$R-*)
(*$P*)
PROCEDURE OPRET;
TYPE ISF=FILE OF ARRAY (1..232) OF INTEGER;
KEYDESCRIPTION=ARRAY (1..9) OF ARRAY (1..3) OF INTEGER;
VAR NREC,RECSIZE,KEYFLDS,IER,L,POSI,OUTOFRANGE,FKEYS,LEDIGFIL:INTEGER;
FILNAVN:STRING;
KEYDESC:KEYDESCRIPTION;
CH:STRING(1);
ISFFILES:FILEDESC;
ISFFNAVN:STRING(18);
(*$ICREATE*)
BEGIN
ISFFNAVN:='ISFFILES:P2:0000:S';
REWRITE(ISFFILES,ISFFNAVN);IOC;
SEEK(ISFFILES,1);IOC;
LEDIGFIL:=0;
REPEAT
GET(ISFFILES);IOC;
LEDIGFIL:=LEDIGFIL+1
UNTIL ISFFILES^.FILNAVN(1)='@';
CLEARSCREEN;
WRITELN('Datafilnavn:Pn');
GOTOXY(16,1);
READLN;READ(FILNAVN);
WRITELN('Antal poster');
GOTOXY(16,2);
READLN;READ(NREC);
WRITELN('Postnavn');
GOTOXY(10,3);
READLN;READ(ISFFILES^.POSTNAVN);
GOTOXY(40,3);WRITELN('Filbetegnelse');
GOTOXY(55,3);READLN;READ(ISFFILES^.REGNAVN);
REPEAT
GOTOXY(1,4);
WRITELN('Vedligeholdelsesniveau');
GOTOXY(24,4);
READLN;READ(NIVEAUD(9));
I:=0;
WHILE NIVEAUD(I)<>NIVEAUD(9) DO I:=I+1
UNTIL (I>=0) AND (I<=8);
CASE I OF
0:ISFFILES^.VEDLNIVEAU:=MENIG;
1:ISFFILES^.VEDLNIVEAU:=SERGENT;
2:ISFFILES^.VEDLNIVEAU:=LØJTNANT;
3:ISFFILES^.VEDLNIVEAU:=KAPTAJN;
4:ISFFILES^.VEDLNIVEAU:=MAJOR;
5:ISFFILES^.VEDLNIVEAU:=OBERST;
6:ISFFILES^.VEDLNIVEAU:=GENERAL;
7:ISFFILES^.VEDLNIVEAU:=HSM;
8:ISFFILES^.VEDLNIVEAU:=UMULIUS
END;
FOR I:=1 TO MAXPOST DO POST.CONTENTS(I):=0;
RECSIZE:=0;OUTOFRANGE:=0;FKEYS:=0;KEYFLDS:=0;
FOR I:=1 TO ANTALFELTER DO
WITH PICTURE(I)^ DO
BEGIN
CASE FELTTYPE OF
HELTAL :BEGIN
POSI:=INDEKS;
L:=1
END;
DOBBTAL:BEGIN
POSI:=INDEKS;
L:=2
END;
REEL :BEGIN
POSI:=1+(INDEKS-1)*4;
L:=4
END;
TEKST :BEGIN
POSI:=(INDEKS+1) DIV 2;
L:=(LÆNGDE+1) DIV 2
END
END;
IF (POSI<1) OR (POSI+L-1>MAXPOST) THEN
OUTOFRANGE:=OUTOFRANGE+1
ELSE
BEGIN
RECSIZE:=RECSIZE+L;
IF ÆNDRENIVEAU=UMULIUS THEN
BEGIN
IF FELTTYPE=REEL THEN
FKEYS:=FKEYS+1
ELSE
BEGIN
KEYFLDS:=KEYFLDS+1;
KEYDESC(KEYFLDS,1):=POSI;
KEYDESC(KEYFLDS,2):=L;
IF FELTTYPE=TEKST THEN
KEYDESC(KEYFLDS,3):=2
ELSE
KEYDESC(KEYFLDS,3):=1
END
END;
REPEAT
POST.CONTENTS(POSI):=POST.CONTENTS(POSI)+1;
POSI:=POSI+1;
L:=L-1
UNTIL L=0
END
END;
FOR I:=1 TO RECSIZE DO
IF POST.CONTENTS(I)>1 THEN
WRITELN('OVERLAPNING',I:5)
ELSE
IF POST.CONTENTS(I)<1 THEN WRITELN('HUL',I:5);
FOR I:=RECSIZE+1 TO MAXPOST DO
IF POST.CONTENTS(I)<>0 THEN WRITELN('FORBIER',I:5);
IF OUTOFRANGE>0 THEN WRITELN('OUTOFRANGE',OUTOFRANGE:5);
IF FKEYS>0 THEN WRITELN('IKKE-IMPLEMENTEREDE NØGLER',FKEYS:5);
WRITELN('Nøglebeskrivelse');
FOR I:=1 TO KEYFLDS DO
WRITELN(KEYDESC(I,1):10,KEYDESC(I,2):10,KEYDESC(I,3):10);
REPEAT
GOTOXY(1,22);
WRITE('Faldende orden for nøgle nr ');
READLN;
IF EOLN THEN I:=0 ELSE READ(I);
IF (I>0) AND (I<=KEYFLDS) THEN KEYDESC(I,3):=-KEYDESC(I,3)
UNTIL I=0;I:=1;
GOTOXY(1,23);
WRITELN('Skal filen oprettes J/N');
GOTOXY(27,23);
CH:='N';
EDIT(CH);
IF CH='J' THEN
BEGIN
CREATE(FILNAVN,NREC,RECSIZE,KEYFLDS,KEYDESC,ISFFILES^.ZONESIZE,IER);
FNAVN:=CONCAT(COPY(FILNAVN,1,4),'DESC:P');
FNAVN:=CONCAT(FNAVN,COPY(FILNAVN,POS(':P',FILNAVN)+2,1),':05:J');
WRITELN('IER : ',IER);
ISFFILES^.FILNAVN:=FILNAVN;
ISFFILES^.DESCNAVN:=FNAVN;
SEEK(ISFFILES,LEDIGFIL);IOC;
PUT(ISFFILES);IOC;
ISFFILES^.FILNAVN(1):='@';
PUT(ISFFILES);IOC
END
END;
(*$P*)
PROCEDURE INIT;
BEGIN
NIVEAUD(0):='M';
NIVEAUD(1):='S';
NIVEAUD(2):='L';
NIVEAUD(3):='K';
NIVEAUD(4):='MA';
NIVEAUD(5):='O';
NIVEAUD(6):='G';
NIVEAUD(7):='H';
NIVEAUD(8):='U';
FTYPED(0):='H';
FTYPED(1):='D';
FTYPED(2):='R';
FTYPED(3):='T';
VTYPED(0):='H';
VTYPED(1):='D';
VTYPED(2):='R';
VTYPED(3):='DATO';
VTYPED(4):='CPR'
END;
(*$P*)
PROCEDURE LÆSDESC;
BEGIN
REWRITE(FFIL,FNAVN);
GET(FFIL);
I:=0;
WHILE FFIL^.INDPOS.X>0 DO
BEGIN
I:=I+1;
CASE FFIL^.FELTTYPE OF
REEL:NEW(PICTURE(I),FELTDESC,REEL);
HELTAL,DOBBTAL,TEKST:NEW(PICTURE(I),FELTDESC,HELTAL)
END;
FELT:=PICTURE(I);
WITH PICTURE(I)^ DO
BEGIN
DESCTYPE:=FELTDESC;
FELTNAVN:=FFIL^.FELTNAVN;
INDPOS.X:=FFIL^.INDPOS.X;
INDPOS.Y:=FFIL^.INDPOS.Y;
UDPOS.X:=FFIL^.UDPOS.X;
UDPOS.Y:=FFIL^.UDPOS.Y;
KIKKENIVEAU:=FFIL^.KIKKENIVEAU;
ÆNDRENIVEAU:=FFIL^.ÆNDRENIVEAU;
LEDETEKST:=FFIL^.LEDETEKST;
FØLGETEKST:=FFIL^.FØLGETEKST;
EDITERING:=FFIL^.EDITERING;
FELTTYPE:=FFIL^.FELTTYPE;
INDEKS:=FFIL^.INDEKS;
LÆNGDE:=FFIL^.LÆNGDE;
HÆGTE:=FFIL^.HÆGTE;
FORAN0:=FFIL^.FORAN0;
IF FELTTYPE=REEL THEN DEC:=FFIL^.DEC;
WHILE FFIL^.NÆSTEVAL<>NIL DO
BEGIN
GET(FFIL);
WITH FELT^ DO
CASE FFIL^.VALIDITETSTYPE OF
HINTERVAL:BEGIN
NEW(NÆSTEVAL,VALIDESC,HINTERVAL);
NÆSTEVAL^.MIN:=FFIL^.MIN;
NÆSTEVAL^.MAX:=FFIL^.MAX
END;
DINTERVAL:BEGIN
NEW(NÆSTEVAL,VALIDESC,DINTERVAL);
NÆSTEVAL^.MIN1:=FFIL^.MIN1;NÆSTEVAL^.MIN2:=FFIL^.MIN2;
NÆSTEVAL^.MAX1:=FFIL^.MAX1;NÆSTEVAL^.MAX2:=FFIL^.MAX2
END;
RINTERVAL:BEGIN
NEW(NÆSTEVAL,VALIDESC,RINTERVAL);
NÆSTEVAL^.RMIN:=FFIL^.RMIN;
NÆSTEVAL^.RMAX:=FFIL^.RMAX
END;
DATO,CPR:NEW(NÆSTEVAL,VALIDESC,DATO)
END;
FELT:=FELT^.NÆSTEVAL;
FELT^.DESCTYPE:=VALIDESC;
FELT^.VALIDITETSTYPE:=FFIL^.VALIDITETSTYPE
END;
FELT^.NÆSTEVAL:=NIL
END;
GET(FFIL)
END;
CLOSE(FFIL);
ANTALFELTER:=I
END;
(*$P*)
PROCEDURE READDESC;
BEGIN
REWRITE(FFIL,FNAVN);
GET(FFIL);
I:=0;
WHILE FFIL^.INDPOS.X>0 DO
BEGIN
I:=I+1;
CASE FFIL^.FELTTYPE OF
REEL:NEW(PICTURE(I),FELTDESC,REEL);
HELTAL,DOBBTAL,TEKST:NEW(PICTURE(I),FELTDESC,HELTAL)
END;
FELT:=PICTURE(I);
WITH PICTURE(I)^ DO
BEGIN
DESCTYPE:=FELTDESC;
FELTNAVN:=FFIL^.FELTNAVN;
INDPOS.X:=FFIL^.INDPOS.X;
INDPOS.Y:=FFIL^.INDPOS.Y;
UDPOS.X:=FFIL^.UDPOS.X;
UDPOS.Y:=FFIL^.UDPOS.Y;
KIKKENIVEAU:=FFIL^.KIKKENIVEAU;
ÆNDRENIVEAU:=FFIL^.ÆNDRENIVEAU;
LEDETEKST:=FFIL^.LEDETEKST;
FØLGETEKST:=FFIL^.FØLGETEKST;
EDITERING:=FFIL^.EDITERING;
FELTTYPE:=FFIL^.FELTTYPE;
INDEKS:=FFIL^.INDEKS;
LÆNGDE:=FFIL^.LÆNGDE;
HÆGTE:=FFIL^.HÆGTE;
FORAN0:=FFIL^.FORAN0;
IF FELTTYPE=REEL THEN DEC:=FFIL^.DEC;
WHILE FFIL^.NÆSTEVAL<>NIL DO
BEGIN
GET(FFIL);
WITH FELT^ DO
CASE FFIL^.VALIDITETSTYPE OF
HINTERVAL:BEGIN
NEW(NÆSTEVAL,VALIDESC,HINTERVAL);
NÆSTEVAL^.MIN:=FFIL^.MIN;
NÆSTEVAL^.MAX:=FFIL^.MAX
END;
DINTERVAL:BEGIN
NEW(NÆSTEVAL,VALIDESC,DINTERVAL);
NÆSTEVAL^.MIN1:=FFIL^.MIN1;NÆSTEVAL^.MIN2:=FFIL^.MIN2;
NÆSTEVAL^.MAX1:=FFIL^.MAX1;NÆSTEVAL^.MAX2:=FFIL^.MAX2
END;
RINTERVAL:BEGIN
NEW(NÆSTEVAL,VALIDESC,RINTERVAL);
NÆSTEVAL^.RMIN:=FFIL^.RMIN;
NÆSTEVAL^.RMAX:=FFIL^.RMAX
END;
DATO,CPR:NEW(NÆSTEVAL,VALIDESC,DATO)
END;
FELT:=FELT^.NÆSTEVAL;
FELT^.DESCTYPE:=VALIDESC;
FELT^.VALIDITETSTYPE:=FFIL^.VALIDITETSTYPE
END;
FELT^.NÆSTEVAL:=NIL
END;
GET(FFIL)
END;
CLOSE(FFIL);
ANTALFELTER:=I
END;
(*$P*)
PROCEDURE SKRIVDESC;
BEGIN
REWRITE(FFIL,FNAVN);
FOR I:=1 TO ANTALFELTER DO
BEGIN
FELT:=PICTURE(I);
REPEAT
FFIL^:=FELT^;
PUT(FFIL);
FELT:=FELT^.NÆSTEVAL
UNTIL FELT=NIL
END;
FFIL^.DESCTYPE:=FELTDESC;
FFIL^.INDPOS.X:=0;
PUT(FFIL);
CLOSE(FFIL)
END;
(*$P*)
PROCEDURE MOVETOLINE(VAR F:NFELT);
VAR CH:STRING(1);
TAL,DECS,I:INTEGER;
RESULT,DM,DD:REAL;
BEGIN
CH:=' ';
CASE F^.FELTTYPE OF
HELTAL:BEGIN
LINE:='';
TAL:=ABS(POST.A(F^.INDEKS));
REPEAT
CH(1):=CHR(TAL MOD 10+48);
LINE:=CONCAT(CH,LINE);
TAL:=TAL DIV 10
UNTIL TAL=0;
WHILE LENGTH(LINE)<F^.FORAN0 DO LINE:=CONCAT('0',LINE);
IF POST.A(F^.INDEKS)<0 THEN LINE:=CONCAT('-',LINE)
END;
DOBBTAL:BEGIN
LINE:='';
RESULT:=ABS(POST.A(F^.INDEKS)*10000.0+POST.A(F^.INDEKS+1));
DM:=100000000.0;
REPEAT
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10
UNTIL (I>48) OR (DM<1.0);
REPEAT
CH(1):=CHR(I);
LINE:=CONCAT(LINE,CH);
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10.0
UNTIL DM<0.09;
WHILE LENGTH(LINE)<F^.FORAN0 DO LINE:=CONCAT('0',LINE);
IF POST.A(F^.INDEKS)*10000.0+POST.A(F^.INDEKS+1)<0.0 THEN
LINE:=CONCAT('-',LINE)
END;
TEKST:BEGIN
LINE:='';
FOR I:=F^.INDEKS TO F^.INDEKS+F^.LÆNGDE-1 DO
BEGIN
CH(1):=POST.AA(I);
LINE:=CONCAT(LINE,CH)
END
END;
REEL:BEGIN
RESULT:=ABS(POST.AAA(F^.INDEKS));
DECS:=F^.DEC;
IF DECS=0 THEN
DD:=0.0
ELSE
BEGIN
DD:=0.1;
FOR I:=1 TO DECS DO BEGIN RESULT:=RESULT*10.0;DD:=DD*10 END
END;
LINE:='';
IF F^.FORAN0=0 THEN
BEGIN
DM:=100000000000.0;
REPEAT
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10.0
UNTIL (I>48) OR (DM<1.0) OR (DM=DD)
END
ELSE
BEGIN
DM:=1.0;
FOR I:=2 TO F^.FORAN0 DO DM:=DM*10.0;
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10.0
END;
REPEAT
CH(1):=CHR(I);
LINE:=CONCAT(LINE,CH);
IF DM=DD THEN LINE:=CONCAT(LINE,'.');
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10.0
UNTIL DM<0.09;
IF POST.AAA(F^.INDEKS)<0.0 THEN LINE:=CONCAT('-',LINE)
END
END
END;
(*$P*)
PROCEDURE NULPOST;
VAR I,J:INTEGER;
BEGIN
FOR J:=1 TO ANTALFELTER DO WITH PICTURE(J)^ DO
BEGIN
CASE FELTTYPE OF
HELTAL:POST.A(INDEKS):=0;
DOBBTAL:BEGIN
POST.A(INDEKS):=0;
POST.A(INDEKS+1):=0
END;
REEL:POST.AAA(INDEKS):=0.0;
TEKST:FOR I:=INDEKS TO LÆNGDE+INDEKS-1 DO
POST.AA(I):=' ';
END
END
END;
PROCEDURE SKRIVFELT(VAR F:NFELT);
VAR I:INTEGER;
R,DF:REAL;
BEGIN
IF USERNIVEAU>=F^.KIKKENIVEAU THEN
BEGIN
GOTOXY(F^.UDPOS.X,F^.UDPOS.Y);
WRITE(F^.LEDETEKST,' ');
IF (F^.FELTTYPE=REEL) AND (F^.EDITERING=0) THEN
WRITELN(POST.AAA(F^.INDEKS):F^.LÆNGDE+2:F^.DEC)
ELSE
BEGIN
MOVETOLINE(F);
WRITELN(LINE)
END
END
END;
PROCEDURE SKRIVPOST;
VAR I:INTEGER;
BEGIN
CLEARSCREEN;
FOR I:=1 TO ANTALFELTER DO SKRIVFELT(PICTURE(I));
END;
(*$P*)
PROCEDURE LÆSFELT(VAR F:NFELT);
VAR I,TAL,TAL1:INTEGER;
VAL:NFELT;
RESULT:REAL;
BUMMED:BOOLEAN;
(*$P*)
PROCEDURE LÆSLINIE;
VAR OK:BOOLEAN;
DECS,I,FORTEGN:INTEGER;
DM:REAL;
BEGIN
REPEAT
OK:=FALSE;
RESULT:=0.0;
TAL:=0;
TAL1:=0;
GOTOXY(F^.INDPOS.X,F^.INDPOS.Y);
WRITELN(F^.LEDETEKST,' ':F^.LÆNGDE+2,F^.FØLGETEKST);
GOTOXY(F^.INDPOS.X+LENGTH(F^.LEDETEKST)+1,F^.INDPOS.Y);
IF F^.EDITERING=0 THEN
BEGIN
READLN;READ(LINE)
END
ELSE
BEGIN
MOVETOLINE(F);
EDIT(LINE:F^.LÆNGDE);
WHILE LINE(LENGTH(LINE))=' ' DO LINE(0):=CHR(ORD(LINE(0))-1)
END;
CASE F^.FELTTYPE OF
TEKST:
IF LENGTH(LINE)<=F^.LÆNGDE THEN
BEGIN
OK:=TRUE;
WHILE LENGTH(LINE)<F^.LÆNGDE DO
IF F^.FORAN0=0 THEN
LINE:=CONCAT(LINE,' ')
ELSE
LINE:=CONCAT(' ',LINE)
END;
HELTAL,DOBBTAL:
IF LENGTH(LINE)>0 THEN
BEGIN
I:=0;
FORTEGN:=1;
IF LINE(1)='-' THEN
BEGIN
FORTEGN:=-1;
I:=1
END;
WHILE LENGTH(LINE)>I DO
BEGIN
OK:=TRUE;
I:=I+1;
IF NOT (LINE(I) IN (.'0'..'9'.)) THEN
BEGIN
OK:=FALSE;
I:=LENGTH(LINE)
END;
RESULT:=10*RESULT+ORD(LINE(I))-48
END;
RESULT:=RESULT*FORTEGN;
IF OK THEN
CASE F^.FELTTYPE OF
HELTAL:IF ABS(RESULT)<=32767 THEN TAL:=TRUNC(RESULT) ELSE OK:=FALSE;
DOBBTAL:IF ABS(RESULT)<=327679999.0 THEN
BEGIN
TAL:=TRUNC(RESULT/10000.0);
TAL1:=TRUNC(RESULT-10000.0*TAL)
END
ELSE OK:=FALSE
END
END ELSE OK:=TRUE;
REEL:
IF LENGTH(LINE)>0 THEN
BEGIN
I:=0;
FORTEGN:=1;
DECS:=-1;
IF LINE(1)='-' THEN
BEGIN
FORTEGN:=-1;
I:=1
END;
WHILE (LENGTH(LINE)>I) AND (DECS<0) DO
BEGIN
OK:=TRUE;
I:=I+1;
IF LINE(I) IN (.'0'..'9'.) THEN
RESULT:=10*RESULT+ORD(LINE(I))-48
ELSE
IF (LINE(I)='.') OR (LINE(I)=',') THEN
DECS:=0
ELSE
BEGIN
OK:=FALSE;
I:=LENGTH(LINE)
END
END;
DM:=1.0;
WHILE LENGTH(LINE)>I DO
BEGIN
I:=I+1;
DM:=DM/10.0;
IF LINE(I) IN (.'0'..'9'.) THEN
BEGIN
RESULT:=RESULT+DM*(ORD(LINE(I))-48);
DECS:=DECS+1
END
ELSE
BEGIN
OK:=FALSE;
I:=LENGTH(LINE)
END
END;
RESULT:=FORTEGN*RESULT;
IF DECS>F^.DEC THEN OK:=FALSE
END
ELSE OK:=TRUE
END
UNTIL OK
END;
(*$P*)
PROCEDURE CHECKVAL;
VAR I,DAT0,MÅNED,ÅR,MODULC:INTEGER;
CPN:ARRAY (1..10) OF INTEGER;
BEGIN
CASE VAL^.VALIDITETSTYPE OF
HINTERVAL:
BUMMED:=((TAL<VAL^.MIN) OR (TAL>VAL^.MAX));
DINTERVAL:
BUMMED:=((TAL*10000.0+TAL1<VAL^.MIN1*10000.0+VAL^.MIN2) OR
(TAL*10000.0+TAL1>VAL^.MAX1*10000.0+VAL^.MAX2));
RINTERVAL:
BUMMED:=((RESULT<VAL^.RMIN) OR (RESULT>VAL^.RMAX));
DATO:
IF LENGTH(LINE)=6 THEN
BEGIN
ÅR:=10*(ORD(LINE(1))-48)+ORD(LINE(2))-48;
MÅNED:=10*(ORD(LINE(3))-48)+ORD(LINE(4))-48;
DAT0:=10*(ORD(LINE(5))-48)+ORD(LINE(6))-48;
IF (DAT0<1) OR (MÅNED<1) OR (MÅNED>12) OR (DAT0>31) THEN BUMMED:=TRUE;
IF NOT BUMMED THEN
CASE MÅNED OF
4,6,9,11: IF DAT0>30 THEN BUMMED:=TRUE;
2: IF (DAT0>29) OR ((DAT0=29) AND (ÅR MOD 4 <>0)) THEN BUMMED:=TRUE
END
END
ELSE BUMMED:=TRUE;
CPR:
IF LENGTH(LINE)=10 THEN
BEGIN
FOR I:=1 TO 10 DO CPN(I):=ORD(LINE(I))-48;
DAT0:=CPN(1)*10+CPN(2);
MÅNED:=CPN(3)*10+CPN(4);
ÅR:=CPN(5)*10+CPN(6);
IF (DAT0<1) OR (MÅNED<1) OR (MÅNED>12) OR (DAT0>31) THEN BUMMED:=TRUE;
IF NOT BUMMED THEN
CASE MÅNED OF
4,6,9,11: IF DAT0>30 THEN BUMMED:=TRUE;
2: IF (DAT0>29) OR ((DAT0=29) AND (ÅR MOD 4<>0)) THEN BUMMED:=TRUE
END;
IF NOT BUMMED THEN
BEGIN
MODULC:=CPN(1)*4+CPN(2)*3+CPN(3)*2+CPN(4)*7+CPN(5)*6+CPN(6)*5+CPN(7)*4+
CPN(8)*3+CPN(9)*2+CPN(10);
IF MODULC MOD 11<>0 THEN BUMMED:=TRUE
END
END
ELSE BUMMED:=TRUE;
END
END;
(*$P*)
(*PROCEDURE LÆSFELT*)
BEGIN
IF USERNIVEAU>=F^.ÆNDRENIVEAU THEN
BEGIN
REPEAT
LÆSLINIE;
VAL:=F^.NÆSTEVAL;
BUMMED:=FALSE;
WHILE (VAL<>NIL) AND (NOT BUMMED) DO
BEGIN
CHECKVAL;
VAL:=VAL^.NÆSTEVAL
END
UNTIL NOT BUMMED;
CASE F^.FELTTYPE OF
HELTAL:POST.A(F^.INDEKS):=TAL;
DOBBTAL:BEGIN
POST.A(F^.INDEKS):=TAL;
POST.A(F^.INDEKS+1):=TAL1
END;
REEL:POST.AAA(F^.INDEKS):=RESULT;
TEKST:FOR I:=1 TO F^.LÆNGDE DO
POST.AA(I+F^.INDEKS-1):=LINE(I)
END
END
END;
(*$P*)
PROCEDURE SKRIVVALI(VAR F:NFELT);
BEGIN
CLEARSCREEN;
WRITELN('Validitetstype',' ':6,VTYPED(ORD(F^.VALIDITETSTYPE)));
CASE F^.VALIDITETSTYPE OF
HINTERVAL:
WRITELN('Minimum',' ':13,F^.MIN:10,' ':10,'Maksimum',' ':12,F^.MAX:10);
DINTERVAL:
WRITELN('Minimum',' ':13,F^.MIN1*10000.0+F^.MIN2:10:-2,' ':10,
'Maksimum',' ':12,F^.MAX1*10000.0+F^.MAX2:10:-2);
RINTERVAL:
WRITELN('Minimum',' ':13,F^.RMIN:10:2,' ':10,'Maksimum',' ':12,
F^.RMAX:10:2);
DATO,CPR:WRITELN
END
END;
(*$P*)
PROCEDURE INDVALI(VAR F:NFELT);
VAR I:INTEGER;
R:REAL;
BEGIN
REPEAT
GOTOXY(1,3);
WRITELN('Validitetstype');
GOTOXY(20,3);
READLN;READ(VTYPED(5));
I:=0;
WHILE VTYPED(I)<>VTYPED(5) DO I:=I+1
UNTIL (I>=0) AND (I<=4);
CASE I OF
0:BEGIN
F^.VALIDITETSTYPE:=HINTERVAL;
GOTOXY(1,5);
WRITELN('Minimum');
GOTOXY(20,5);
READLN;READ(F^.MIN);
GOTOXY(31,5);
WRITELN('Maksimum');
GOTOXY(50,5);
READLN;READ(F^.MAX)
END;
1:BEGIN
F^.VALIDITETSTYPE:=DINTERVAL;
GOTOXY(1,5);
WRITELN('Minimum');
GOTOXY(20,5);
READLN;READ(R);
F^.MIN1:=TRUNC(R/10000.0);
F^.MIN2:=TRUNC(R-F^.MIN1*10000.0);
GOTOXY(31,5);
WRITELN('Maksimum');
GOTOXY(50,5);
READLN;READ(R);
F^.MAX1:=TRUNC(R/10000.0);
F^.MAX2:=TRUNC(R-F^.MAX1*10000.0)
END;
2:BEGIN
F^.VALIDITETSTYPE:=RINTERVAL;
GOTOXY(1,5);
WRITELN('Minimum');
GOTOXY(20,5);
READLN;READ(F^.RMIN);
GOTOXY(31,5);
WRITELN('Maksimum');
GOTOXY(50,5);
READLN;READ(F^.RMAX)
END;
3:F^.VALIDITETSTYPE:=DATO;
4:F^.VALIDITETSTYPE:=CPR
END
END;
(*$P*)
PROCEDURE SKRIVPARAMS(VAR F:NFELT);
BEGIN
CLEARSCREEN;
WITH F^ DO
BEGIN
WRITELN(' 1 Indpos X Y',' ':10,INDPOS.X:10,INDPOS.Y:10);
WRITELN(' 2 Udpos X Y',' ':10,UDPOS.X:10,UDPOS.Y:10);
WRITELN(' 3 Kikkeniveau',' ':9,NIVEAUD(ORD(KIKKENIVEAU)));
WRITELN(' 4 Ændreniveau',' ':9,NIVEAUD(ORD(ÆNDRENIVEAU)));
WRITELN(' 5 Ledetekst',' ':11,LEDETEKST);
WRITELN(' 6 Følgetekst',' ':10,FØLGETEKST);
WRITELN(' 7 Editering',' ':11,EDITERING:10);
WRITELN(' 8 Indeks',' ':14,INDEKS:10);
WRITELN(' 9 Længde',' ':14,LÆNGDE:10);
WRITELN('10 Hægte',' ':15,HÆGTE:10);
WRITELN('11 Foran0',' ':14,FORAN0:10);
WRITE('12 Felttype',' ':12,FTYPED(ORD(FELTTYPE)));
IF FELTTYPE=REEL THEN WRITELN(' ':10,'Dec',DEC:5) ELSE WRITELN;
WRITELN('13 Feltnavn',' ':12,FELTNAVN)
END
END;
(*$P*)
PROCEDURE INDPARAM(VAR F:NFELT;PARAMNR:INTEGER);
VAR I:INTEGER;
BEGIN
CASE PARAMNR OF
1:BEGIN
GOTOXY(4,1);
WRITELN('Indpos X Y');
GOTOXY(20,1);
READLN;READ(F^.INDPOS.X,F^.INDPOS.Y)
END;
2:BEGIN
GOTOXY(4,2);
WRITELN('Udpos X Y');
GOTOXY(20,2);
READLN;READ(F^.UDPOS.X,F^.UDPOS.Y)
END;
3:BEGIN
REPEAT
GOTOXY(4,3);
WRITELN('Kikkeniveau');
GOTOXY(20,3);
READLN;READ(NIVEAUD(9));
I:=0;
WHILE NIVEAUD(I)<>NIVEAUD(9) DO I:=I+1
UNTIL (I>=0) AND (I<=8);
CASE I OF
0:F^.KIKKENIVEAU:=MENIG;
1:F^.KIKKENIVEAU:=SERGENT;
2:F^.KIKKENIVEAU:=LØJTNANT;
3:F^.KIKKENIVEAU:=KAPTAJN;
4:F^.KIKKENIVEAU:=MAJOR;
5:F^.KIKKENIVEAU:=OBERST;
6:F^.KIKKENIVEAU:=GENERAL;
7:F^.KIKKENIVEAU:=HSM;
8:F^.KIKKENIVEAU:=UMULIUS
END
END;
4:BEGIN
REPEAT
GOTOXY(4,4);
WRITELN('Ændreniveau');
GOTOXY(20,4);
READLN;READ(NIVEAUD(9));
I:=0;
WHILE NIVEAUD(I)<>NIVEAUD(9) DO I:=I+1
UNTIL (I>=0) AND (I<=8);
CASE I OF
0:F^.ÆNDRENIVEAU:=MENIG;
1:F^.ÆNDRENIVEAU:=SERGENT;
2:F^.ÆNDRENIVEAU:=LØJTNANT;
3:F^.ÆNDRENIVEAU:=KAPTAJN;
4:F^.ÆNDRENIVEAU:=MAJOR;
5:F^.ÆNDRENIVEAU:=OBERST;
6:F^.ÆNDRENIVEAU:=GENERAL;
7:F^.ÆNDRENIVEAU:=HSM;
8:F^.ÆNDRENIVEAU:=UMULIUS
END
END;
5:BEGIN
GOTOXY(4,5);
WRITELN('Ledetekst');
GOTOXY(20,5);
READLN;READ(F^.LEDETEKST)
END;
6:BEGIN
GOTOXY(4,6);
WRITELN('Følgetekst');
GOTOXY(20,6);
READLN;READ(F^.FØLGETEKST)
END;
7:BEGIN
GOTOXY(4,7);
WRITELN('Editering 0-1');
GOTOXY(20,7);
READLN;READ(F^.EDITERING)
END;
8:BEGIN
GOTOXY(4,8);
WRITELN('Indeks');
GOTOXY(20,8);
READLN;READ(F^.INDEKS)
END;
9:BEGIN
GOTOXY(4,9);
WRITELN('Længde');
GOTOXY(20,9);
READLN;READ(F^.LÆNGDE)
END;
10:BEGIN
GOTOXY(4,10);
WRITELN('Hægte');
GOTOXY(20,10);
READLN;READ(F^.HÆGTE)
END;
11:BEGIN
GOTOXY(4,11);
WRITELN('Foran0');
GOTOXY(20,11);
READLN;READ(F^.FORAN0)
END;
12:BEGIN
REPEAT
GOTOXY(4,12);
WRITELN('Felttype');
GOTOXY(20,12);
READLN;READ(FTYPED(4));
I:=0;
WHILE FTYPED(I)<>FTYPED(4) DO I:=I+1
UNTIL (I>=0) AND (I<=3);
CASE I OF
2:BEGIN
F^.FELTTYPE:=REEL;
GOTOXY(30,12);
WRITELN('Dec');
GOTOXY(40,12);
READLN;READ(F^.DEC)
END;
0:F^.FELTTYPE:=HELTAL;
1:F^.FELTTYPE:=DOBBTAL;
3:F^.FELTTYPE:=TEKST
END
END;
13:BEGIN
GOTOXY(4,13);
WRITELN('Feltnavn');
GOTOXY(20,13);
READLN;READ(F^.FELTNAVN)
END
END
END;
(*$P*)
PROCEDURE VEDLFD(VAR F:NFELT);
VAR I:INTEGER;
BEGIN
REPEAT
SKRIVPARAMS(F);
GOTOXY(1,23);
WRITELN('Feltnr, 0 for færdig');
GOTOXY(22,23);
READLN;READ(I);
IF (USERNIVEAU>=HSM) OR ((I<>8) AND (I<>9) AND (I<>12) AND
((I<>3) OR (USERNIVEAU>=F^.KIKKENIVEAU)) AND
((I<>4) OR (USERNIVEAU>=F^.ÆNDRENIVEAU))) THEN
INDPARAM(F,I)
UNTIL I=0
END;
(*$P*)
PROCEDURE MAINPD;
VAR I:INTEGER;
CH:STRING(1);
NF,F:NFELT;
BEGIN
REPEAT
CLEARSCREEN;
FOR I:=1 TO ANTALFELTER DO
WRITELN(I:3,' ':5,PICTURE(I)^.LEDETEKST);
GOTOXY(1,23);
WRITELN('Feltnr, 0 for færdig');
GOTOXY(22,23);
READLN;READ(I);
IF (I>0) AND (I<=ANTALFELTER) THEN
BEGIN
VEDLFD(PICTURE(I));
F:=PICTURE(I);
CH:='J';
WHILE (F^.NÆSTEVAL<>NIL) AND (CH='J') DO
BEGIN
GOTOXY(1,23);
WRITELN('Næste validitet J/N',' ':58);
GOTOXY(21,23);
EDIT(CH);
IF CH='J' THEN
BEGIN
F:=F^.NÆSTEVAL;
SKRIVVALI(F);
GOTOXY(1,23);
WRITELN('Ændres J/N',' ':68);
GOTOXY(12,23);
EDIT(CH);
IF (CH='J') AND (USERNIVEAU>=HSM) THEN
INDVALI(F)
ELSE
CH:='J'
END
END;
GOTOXY(1,23);
WRITELN('Slet: S, Tilføj: T, Færdig: F');
CH:='F';
GOTOXY(34,23);
EDIT(CH);
IF USERNIVEAU>=HSM THEN
CASE CH(1) OF
'S':IF F^.NÆSTEVAL<>NIL THEN F^.NÆSTEVAL:=F^.NÆSTEVAL^.NÆSTEVAL;
'T':BEGIN
NEW(NF,VALIDESC);
NF^.DESCTYPE:=VALIDESC;
INDVALI(NF);
NF^.NÆSTEVAL:=F^.NÆSTEVAL;
F^.NÆSTEVAL:=NF
END
END
END
UNTIL I=0
END;
(*$P*)
PROCEDURE CREATEPD;
VAR FRA,TIL,I:INTEGER;
CH:STRING(1);
F:NFELT;
BEGIN
GOTOXY(1,23);
WRITELN('Tilføjelse: T, Sletning: S, Flytning: F, Afslutning: A');
GOTOXY(56,23);
CH:='T';
EDIT(CH);
WHILE CH<>'A' DO
BEGIN
CASE CH(1) OF
'T':BEGIN
CLEARSCREEN;
ANTALFELTER:=ANTALFELTER+1;
NEW(PICTURE(ANTALFELTER),FELTDESC);
F:=PICTURE(ANTALFELTER);
F^.DESCTYPE:=FELTDESC;
FOR I:=1 TO 13 DO INDPARAM(F,I);
VEDLFD(F);
REPEAT
GOTOXY(1,23);
WRITELN('Flere validitetscheck J/N');
GOTOXY(30,23);
CH:='J';
EDIT(CH);
IF CH='J' THEN
BEGIN
NEW(F^.NÆSTEVAL,VALIDESC);
F^.DESCTYPE:=VALIDESC;
F:=F^.NÆSTEVAL;
REPEAT
CLEARSCREEN;
INDVALI(F);
SKRIVVALI(F);
GOTOXY(1,23);
WRITELN('Validitetscheck OK J/N',' ':56);
GOTOXY(30,23);
EDIT(CH)
UNTIL CH='J'
END
UNTIL CH<>'J';
F^.NÆSTEVAL:=NIL;
END;
'S':BEGIN
PICTURE(ANTALFELTER):=NIL;
ANTALFELTER:=ANTALFELTER-1
END;
'F':BEGIN
GOTOXY(1,20);
WRITELN('FRA TIL');
GOTOXY(9,20);
READLN;READ(FRA,TIL);
F:=PICTURE(FRA);
IF FRA<TIL THEN
FOR I:=FRA TO TIL-1 DO PICTURE(I):=PICTURE(I+1)
ELSE
FOR I:=FRA DOWNTO TIL+1 DO PICTURE(I):=PICTURE(I-1);
PICTURE(TIL):=F
END
END;
GOTOXY(1,23);
WRITELN('Tilføjelse: T, Sletning: S, Flytning: F, Afslutning: A');
GOTOXY(56,23);
CH:='T';
EDIT(CH)
END
END;
(*$P*)
PROCEDURE LISTDESC;
BEGIN
WRITELN(LIST);
WRITELN(LIST,FNAVN);
WRITELN(LIST);
WRITELN(LIST,'Felt Ledetekst',' ':21,'Følgetekst');
WRITELN(LIST,' ':5,'Kikkeniveau Indpos Edit Ændreniveau',
' Udpos Længde Foran0');
WRITELN(LIST,' ':5,'Felttype Indeks Decimaler Feltnavn Hægte');
WRITELN(LIST,' ':15,'Validitetstype Minimum Maximum');
WRITELN(LIST);
WRITELN(LIST);
FOR I:=1 TO ANTALFELTER DO
BEGIN
FELT:=PICTURE(I);
WITH FELT^ DO
BEGIN
WRITELN(LIST,I:4,' ',LEDETEKST,' ':30-LENGTH(LEDETEKST),FØLGETEKST);
WRITELN(LIST,' ':5,NIVEAUD(ORD(KIKKENIVEAU)),
' ':10-LENGTH(NIVEAUD(ORD(KIKKENIVEAU))),INDPOS.X:5,INDPOS.Y:5,
EDITERING:5,
' ':5,NIVEAUD(ORD(ÆNDRENIVEAU)),
' ':11-LENGTH(NIVEAUD(ORD(ÆNDRENIVEAU))),UDPOS.X:5,UDPOS.Y:5,
LÆNGDE:7,FORAN0:7);
WRITE(LIST,' ':5,FTYPED(ORD(FELTTYPE)),
' ':11-LENGTH(FTYPED(ORD(FELTTYPE))),INDEKS:4);
IF FELTTYPE=REEL THEN WRITE(LIST,DEC:12) ELSE WRITE(LIST,' ':12);
WRITELN(LIST,' ':8,FELTNAVN,HÆGTE:5);
END;
FELT:=FELT^.NÆSTEVAL;
WHILE FELT<>NIL DO
BEGIN
WRITE(LIST,' ':15,VTYPED(ORD(FELT^.VALIDITETSTYPE)),
' ':15-LENGTH(VTYPED(ORD(FELT^.VALIDITETSTYPE))));
CASE FELT^.VALIDITETSTYPE OF
HINTERVAL:WRITELN(LIST,FELT^.MIN:12,FELT^.MAX:17);
DINTERVAL:WRITELN(LIST,FELT^.MIN1*10000.0+FELT^.MIN2:12:-2,
FELT^.MAX1*10000.0+FELT^.MAX2:17:-2);
RINTERVAL:WRITELN(LIST,FELT^.RMIN:12:2,FELT^.RMAX:17:2);
DATO,CPR: WRITELN(LIST)
END;
FELT:=FELT^.NÆSTEVAL
END;
WRITELN(LIST)
END;
PAGE(LIST)
END;
(*$P*)
(*HOVEDPROGRAM*)
BEGIN
INIT;
USERNIVEAU:=MENIG;
I:=ORD(PARM^(1))-48;
WHILE I>0 DO
BEGIN
USERNIVEAU:=SUCC(USERNIVEAU);
I:=I-1
END;
CLEARSCREEN;
ANTALFELTER:=0;
FNAVN:='NONE';
WRITELN('Input-fil');
GOTOXY(11,1);
EDIT(FNAVN:16);
IF POS('NONE',FNAVN)<>1 THEN LÆSDESC;
REPEAT
CLEARSCREEN;
WRITELN('1 Opbygning af feltbeskrivelse');
WRITELN('2 Ændring af eksisterende feltbeskrivelse');
WRITELN('3 Simulering');
WRITELN('4 Oprettelse af datafil');
WRITELN('5 Printerudskrift af feltbeskrivelse');
WRITELN('Vælg 0-5');
REPEAT
GOTOXY(12,6);
READLN;READ(I)
UNTIL (I>=0) AND (I<=5);
CASE I OF
1:IF USERNIVEAU>=HSM THEN CREATEPD;
2:MAINPD;
3:BEGIN
HUSKNIV:=USERNIVEAU;
USERNIVEAU:=UMULIUS;
NULPOST;
SKRIVPOST;
REPEAT
READLN;
FOR I:=1 TO ANTALFELTER DO
LÆSFELT(PICTURE(I));
READLN;READ(I);
IF I<>-1 THEN SKRIVPOST
UNTIL I=-1;
USERNIVEAU:=HUSKNIV
END;
4:IF USERNIVEAU>=HSM THEN OPRET;
5:LISTDESC
END
UNTIL I=0;
CLEARSCREEN;
WRITELN('Output-fil');
GOTOXY(12,1);
EDIT(FNAVN:16);
IF FNAVN<>' ' THEN SKRIVDESC;
FNAVN:=' ';
FOR I:=1 TO 7 DO FNAVN(I):=PARM^(I);
CHAIN('HOVED *1',FNAVN,QUQ);
IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END.