|
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: 26208 (0x6660)
Types: TextFile
Notes: Mikados_K
Names: »NBTORDRE.K«
└─⟦a3d38fea3⟧ Bits:30008985 PRODUKTION NBT.
└─⟦this⟧ »NBTORDRE.K«
PROGRAM ORDREINDTASTNING;
TYPE
PARMARRAY=PACKED ARRAY (1..39) OF CHAR;
NIVEAU=(MENIG,SERGENT,LØJTNANT,KAPTAJN,MAJOR,OBERST,GENERAL,HSM,UMULIUS);
VAR PARM:^PARMARRAY;
QUQ:^INTEGER;
I:INTEGER;
FNAVN:STRING;
(*$P*)
PROCEDURE REGVEDL;
CONST MAXFELTER=26;
MVINDUEZ=292;
MMAXMÅLZ=259;
MGLASZ=245;
MFARVEZ=245;
MOLINIEZ=344;
MORDREHZ=331;
MKOMBIZ=241;
MSYSZ=243;
(*$IISFHEAD*)
VINDUEZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..MVINDUEZ) OF INTEGER;
END;
MAXMÅLZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..MMAXMÅLZ) OF INTEGER;
END;
GLASZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..MGLASZ) OF INTEGER;
END;
OLINIEZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..MOLINIEZ) OF INTEGER;
END;
HOVEDZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..MORDREHZ) OF INTEGER;
END;
KOMBIZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..MKOMBIZ) OF INTEGER;
END;
SYSZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..MSYSZ) OF INTEGER;
END;
ARAR=PACKED ARRAY(-11..-10) OF CHAR;
RAR=ARRAY (0..0) OF REAL;
AR13=ARRAY(1..3) OF INTEGER;
AR14=ARRAY(1..4) OF INTEGER;
AR15=ARRAY(1..5) OF INTEGER;
AR19=ARRAY(1..9) OF INTEGER;
DOBBINT=ARRAY(1..2) OF INTEGER;
TEK=PACKED ARRAY(1..30) OF CHAR;
VINDUEPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
(*NR,
KARMNR,
MAXMÅL:INTEGER;
RAMME:ARRAY(1..16) OF INTEGER;
BESLAG:AR14;
BREDDE,
HØJDE:AR13;*)
C:ARRAY (1..29) OF INTEGER;
TEKST:TEK
END;
MAXMÅLPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
(*AREAL,
BHFORHOL:REAL;
NR,
BREDDE,
HØJDE:INTEGER;*)
C:ARRAY (1..11) OF INTEGER;
TEKST:TEK
END;
GLASPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
(*NR,
KODE:INTEGER;*)
C:ARRAY (1..2) OF INTEGER;
TEKST:TEK
END;
OLINIEPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
(*KOSTPRIS,
SALGPRIS,
RABAT:REAL;
ORDRENR,
POSITION,
ANTAL,
VINDUENR,
FARVE1,
FARVE2,
RAMMENR1,
GLASART1,
RAMMENR2,
GLASART2,
RAMMENR3,
GLASART3,
BLAMBRED,
BLAMHØJD:INTEGER;
BREDDE:AR13;
HØJDE:AR13;
HÆNGSEL:AR14;
MONTER:INTEGER;
STATUS:INTEGER;*)
C:ARRAY (1..38) OF INTEGER
END;
HOVEDPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
(*NR:INTEGER;
DATO:DOBBINT;
TILBUDNR:INTEGER;
TLBUDDATO:DOBBINT;
SAGSNR:INTEGER;
KUNDENR,
POSTNR:DOBBINT;
LEVTERM,
STATUS:INTEGER;
KUNDENAVN,
GADE,
BY,
KONTAKT:TEK;
TELEFON:PACKED ARRAY(1..10) OF CHAR;
LEVSTED:TEK;
INITIAL:PACKED ARRAY(1..4) OF CHAR;*)
C:ARRAY (1..95) OF INTEGER
END;
KOMBIPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
(*NR,
KARMPROFIL,
POST1,
POST2,
RAMMEPROFIL,
F3PROFIL:INTEGER;*)
C:ARRAY (1..6) OF INTEGER
END;
SYSPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
(*NR,
ORDRENR,
SDAT1,SDAT2:INTEGER;*)
C:ARRAY (1..4) OF INTEGER
END;
NFELT=^FELTBESKRIVELSE;
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(31);
INDEKS:INTEGER;
LÆNGDE:INTEGER;
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;
VAR MAXF,VINF,GLAF,FARF,OLIF,HOVF,KOMF,SYSF:ISF;
VINZ:VINDUEZONE;
GLAZ,FARZ:GLASZONE;
OLIZ:OLINIEZONE;
HOVZ:HOVEDZONE;
KOMZ:KOMBIZONE;
SYSZ:SYSZONE;
MAXZ:MAXMÅLZONE;
MAXMÅL:MAXMÅLPOST;
VINDUE:VINDUEPOST;
GLAS,FARVE:GLASPOST;
OLINIE:OLINIEPOST;
HOVED:HOVEDPOST;
KOMBI:KOMBIPOST;
SYSTEM:SYSPOST;
FELT:NFELT;
PICTURE:ARRAY (1..MAXFELTER) OF NFELT;
LINES,OPTION,IER,I,J,ANTALFELTER,FELTNR:INTEGER;
CH:STRING(1);
LINE:STRING;
RESULT:REAL;
HOVEDE:BOOLEAN;
(*$P*)
SEGMENT PROCEDURE LÆSDESC(DESCNR:INTEGER);
VAR DESCNAVN:STRING;
FFIL:FELTFIL;
BEGIN
IF DESCNR=1 THEN
DESCNAVN:='OINDDESC:P2:0:J'
ELSE
DESCNAVN:='OLITDESC:P2:0:J';
REWRITE(FFIL,DESCNAVN);
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;
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*)
(*$L-*)
(*$R-,IFORWARD*)
(*$IIOPEN*)
(*$IICLOSE*)
(*$L+*)
SEGMENT PROCEDURE ERROR(VAR FIL:FILNAVN);
BEGIN
WRITELN('FEJL I REGISTER ',FIL,' FEJLKODE ',IER);
ICLOSE(HOVZ.H,HOVF);
ICLOSE(OLIZ.H,OLIF);
ICLOSE(SYSZ.H,SYSF);
EXIT(REGVEDL)
END;
SEGMENT PROCEDURE OFEJL(VAR FIL:FILNAVN);
VAR I:INTEGER;
BEGIN
GOTOXY(1,20);
WRITELN('REGISTERFEJL ',IER,' I ',FIL,' . SITUATIONEN ER FORSØGT REDDET.');
WRITELN('TAST 0, HVIS DER SKAL FORTSÆTTES');
REPEAT GOTOXY(40,21);READLN;READ(I) UNTIL IORESULT=0;
IF I<>0 THEN ERROR(FIL);
CLEARSCREEN
END;
(*$P*)
SEGMENT PROCEDURE INIT;
BEGIN
CLEARSCREEN;
HOVZ.H.FILENAME:='ORDREHOV';
FNAVN:='ORDREHOV:P2:0000:I';
REWRITE(HOVF,FNAVN);
IOPEN(HOVZ.H,HOVF,SKRIV);IF IER<>0 THEN OFEJL(HOVZ.H.FILENAME);
OLIZ.H.FILENAME:='OLINIE ';
FNAVN:='OLINIE:P2:0000:I';
REWRITE(OLIF,FNAVN);
IOPEN(OLIZ.H,OLIF,SKRIV);IF IER<>0 THEN OFEJL(OLIZ.H.FILENAME);
SYSZ.H.FILENAME:='SYSREG ';
FNAVN:='SYSREG:P2:0000:I';
REWRITE(SYSF,FNAVN);
IOPEN(SYSZ.H,SYSF,SKRIV);IF IER<>0 THEN OFEJL(SYSZ.H.FILENAME);
VINZ.H.FILENAME:='VINDUE ';
FNAVN:='VINDUE:P2:0000:I';
REWRITE(VINF,FNAVN);
IOPEN(VINZ.H,VINF,LÆS);IF IER<>0 THEN OFEJL(VINZ.H.FILENAME);
GLAZ.H.FILENAME:='GLAS ';
FNAVN:='GLAS:P2:0000:I';
REWRITE(GLAF,FNAVN);
IOPEN(GLAZ.H,GLAF,LÆS);IF IER<>0 THEN OFEJL(GLAZ.H.FILENAME);
FARZ.H.FILENAME:='FARVE ';
FNAVN:='FARVE:P2:0000:I';
REWRITE(FARF,FNAVN);
IOPEN(FARZ.H,FARF,LÆS);IF IER<>0 THEN OFEJL(FARZ.H.FILENAME);
KOMZ.H.FILENAME:='KOMBINAT';
FNAVN:='KOMBINAT:P2:0000:I';
REWRITE(KOMF,FNAVN);
IOPEN(KOMZ.H,KOMF,LÆS);IF IER<>0 THEN OFEJL(KOMZ.H.FILENAME);
MAXZ.H.FILENAME:='MAXMÅL ';
FNAVN:='MAXMÅL:P2:0000:I';
REWRITE(MAXF,FNAVN);
IOPEN(MAXZ.H,MAXF,LÆS);IF IER<>0 THEN OFEJL(MAXZ.H.FILENAME)
END;
(*$L-*)
(*$IEXCOMCOP*)
(*$ISÆTØG*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IFORSKYD*)
(*$IPUTGET*)
(*$IINSERT*)
(*$INEXTREC*)
(*$L+*)
(*$P*)
PROCEDURE MOVETOLINE(VAR F:NFELT;VAR A:AR;VAR AA:ARAR;VAR AAA:RAR);
VAR CH:STRING(1);
TAL,DECS,I:INTEGER;
RESULT,DM,DD:REAL;
BEGIN
CH:=' ';
CASE F^.FELTTYPE OF
HELTAL:BEGIN
LINE:='';
TAL:=ABS(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 A(F^.INDEKS)<0 THEN LINE:=CONCAT('-',LINE)
END;
DOBBTAL:BEGIN
LINE:='';
RESULT:=ABS(A(F^.INDEKS)*10000.0+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 A(F^.INDEKS)*10000.0+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):=AA(I);
LINE:=CONCAT(LINE,CH)
END
END;
REEL:BEGIN
RESULT:=ABS(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 AAA(F^.INDEKS)<0.0 THEN LINE:=CONCAT('-',LINE)
END
END
END;
(*$P*)
PROCEDURE SKRIVFELT(VAR F:NFELT);
BEGIN
GOTOXY(F^.UDPOS.X,F^.UDPOS.Y);
WRITE(F^.LEDETEKST,' ');
IF HOVEDE THEN
MOVETOLINE(F,HOVED.A,HOVED.AA,HOVED.AAA)
ELSE
MOVETOLINE(F,OLINIE.A,OLINIE.AA,OLINIE.AAA);
WRITELN(LINE);
END;
PROCEDURE D23;
BEGIN
GOTOXY(1,23);WRITELN(' ':79);GOTOXY(1,23)
END;
(*$P*)
PROCEDURE LÆSFELT(VAR F:NFELT);
VAR I,TAL,TAL1:INTEGER;
VAL:NFELT;
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(1,F^.INDPOS.Y);
WRITELN(' ':79);
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);
LINE:='0';
EDIT(LINE:F^.LÆNGDE);
WHILE LINE(LENGTH(LINE))=' ' DO LINE(0):=CHR(ORD(LINE(0))-1);
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: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;
END
END;
(*$P*)
(*PROCEDURE LÆSFELT*)
BEGIN
REPEAT
BUMMED:=FALSE;
VAL:=F^.NÆSTEVAL;
LÆSLINIE;
IF HOVEDE THEN
BEGIN
IF (RESULT=0.0) AND ((FELTNR=2) OR (FELTNR=4)) THEN
BEGIN
VAL:=NIL;
TAL:=SYSTEM.A(3);
TAL1:=SYSTEM.A(4)
END
END
ELSE
BEGIN
IF (FELTNR=2) AND (TAL=0) THEN VAL:=NIL
END;
WHILE (VAL<>NIL) AND (NOT BUMMED) DO
BEGIN
CHECKVAL;
VAL:=VAL^.NÆSTEVAL
END;
IF (NOT BUMMED) AND (NOT HOVEDE) THEN
BEGIN
D23;
CASE FELTNR OF
4,5:IF TAL=0 THEN TAL:=OLINIE.A(17) ELSE
BEGIN
FARVE.A(1):=TAL;
GETREC(FARZ.H,FARF,FARVE.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR(FARZ.H.FILENAME);
IF IER=-6 THEN
BEGIN
BUMMED:=TRUE;
WRITE('Farve findes ikke, RETURN');READLN
END
ELSE
BEGIN
CH:='J';
WRITE(FARVE.TEKST,' Rigtig farve J/N ');EDIT(CH);
IF CH<>'J' THEN BUMMED:=TRUE
END
END;
7,9,10:IF TAL>0 THEN
BEGIN
GLAS.A(1):=TAL;
GETREC(GLAZ.H,GLAF,GLAS.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR(GLAZ.H.FILENAME);
IF IER=-6 THEN
BEGIN
BUMMED:=TRUE;
WRITE('Glas findes ikke, RETURN');READLN
END
ELSE
BEGIN
CH:='J';
WRITE(GLAS.TEKST,' Rigtig glas J/N ');EDIT(CH);
IF CH<>'J' THEN BUMMED:=TRUE
END
END;
6,8:IF TAL>0 THEN BUMMED:=(VINDUE.A(TAL+3)=0);
2:IF TAL>0 THEN
BEGIN
VINDUE.A(1):=TAL MOD 1000;
GETREC(VINZ.H,VINF,VINDUE.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR(VINZ.H.FILENAME);
IF IER=-6 THEN
BEGIN
WRITE('Vindue/dør findes ikke, RETURN');
READLN;BUMMED:=TRUE
END
ELSE
BEGIN
CH:='J';
WRITE(VINDUE.TEKST,' Rigtigt vindue J/N ');EDIT(CH);
IF CH='J' THEN
BEGIN
KOMBI.A(1):=TAL DIV 1000;
GETREC(KOMZ.H,KOMF,KOMBI.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR(KOMZ.H.FILENAME);
D23;
IF IER=-6 THEN
BEGIN
WRITE('Profilkombinationen findes ikke, RETURN');
READLN;BUMMED:=TRUE
END
ELSE
BEGIN
WRITE(KOMBI.A(2):5,KOMBI.A(3):5,KOMBI.A(4):5,KOMBI.A(5):5,
KOMBI.A(6):5,' Rigtig kombination J/N ');EDIT(CH);
IF CH<>'J' THEN BUMMED:=TRUE
END
END
ELSE BUMMED:=TRUE
END
END
END
END
UNTIL NOT BUMMED;
IF HOVEDE THEN
CASE FELTNR OF
1,3,5,14,16: HOVED.A(F^.INDEKS):=TAL;
2,4,6,9:BEGIN
HOVED.A(F^.INDEKS):=TAL;
HOVED.A(F^.INDEKS+1):=TAL1
END;
7,8,10,11,12,13,15:FOR I:=1 TO F^.LÆNGDE DO
HOVED.AA(I+F^.INDEKS-1):=LINE(I)
END
ELSE
IF FELTNR IN (.23..24.) THEN
OLINIE.AAA(F^.INDEKS):=RESULT
ELSE OLINIE.A(F^.INDEKS):=TAL
END;
(*$P*)
PROCEDURE MAINTAIN;
VAR POSNR:INTEGER;
PROCEDURE Q(I:INTEGER);
BEGIN
FELTNR:=I;
LÆSFELT(PICTURE(FELTNR));
SKRIVFELT(PICTURE(FELTNR))
END;
(*$P*)
PROCEDURE OLINPROC;
PROCEDURE CHECKMAXMÅL;
VAR R:REAL;
BEGIN
CH:='J';
R:=OLINIE.A(25)/1000.0*OLINIE.A(26)/1000.0;
IF R>MAXMÅL.AAA(1) THEN
BEGIN
D23;
WRITE('Max-areal overskredet OK J/N ');EDIT(CH);
IF CH<>'J' THEN EXIT(CHECKMAXMÅL)
END;
R:=1.0*OLINIE.A(25)/OLINIE.A(26);
IF R>MAXMÅL.AAA(2) THEN
BEGIN
D23;
WRITE('Max-bredde/højde-forhold overskredet OK J/N ');EDIT(CH);
IF CH<>'J' THEN EXIT(CHECKMAXMÅL)
END;
IF OLINIE.A(25)>MAXMÅL.A(10) THEN
BEGIN
D23;
WRITE('Max-bredde overskredet OK J/N ');EDIT(CH);
IF CH<>'J' THEN EXIT(CHECKMAXMÅL)
END;
IF OLINIE.A(26)>MAXMÅL.A(11) THEN
BEGIN
D23;
WRITE('Max-højde overskredet OK J/N ');EDIT(CH);
IF CH<>'J' THEN EXIT(CHECKMAXMÅL)
END
END;
(*$P*)
BEGIN (*PROCEDURE OLINPROC*)
FELTNR:=2;
CLEARSCREEN;
LÆSFELT(PICTURE(FELTNR));
WHILE OLINIE.A(16)>0 DO
BEGIN
SKRIVFELT(PICTURE(FELTNR));
OLINIE.A(14):=POSNR;
POSNR:=POSNR+1;
Q(1);Q(4);Q(5);
FOR I:=19 TO 24 DO OLINIE.A(I):=0;
Q(10);
IF OLINIE.A(24)=0 THEN
BEGIN
Q(6);
IF OLINIE.A(19)>0 THEN
BEGIN
Q(7);Q(8);
IF OLINIE.A(20)>0 THEN Q(9)
END;
REPEAT Q(10) UNTIL OLINIE.A(24)>0
END;
MAXMÅL.A(9):=VINDUE.A(3);
GETREC(MAXZ.H,MAXF,MAXMÅL.A);IF IER<>0 THEN ERROR(MAXZ.H.FILENAME);
REPEAT
Q(11);Q(12);
CHECKMAXMÅL
UNTIL CH='J';
FOR I:=27 TO 36 DO OLINIE.A(I):=0;
FOR I:=24 TO 26 DO
IF VINDUE.A(I)=1 THEN Q(13+2*(I-24)) ELSE I:=27;
FOR I:=27 TO 29 DO
IF VINDUE.A(I)=1 THEN Q(14+2*(I-27)) ELSE I:=30;
FOR I:=20 TO 23 DO
IF VINDUE.A(I)=1 THEN Q(I-1);
Q(3);Q(23);Q(24);
OLINIE.A(13):=HOVED.A(1);
OLINIE.A(38):=HOVED.A(13);
OLINIE.AAA(1):=0.0;
D23;CH:='J';
WRITE('Ordrelinie OK J/N ');EDIT(CH);
IF CH='J' THEN
BEGIN
INSERT(OLIZ.H,OLIF,OLINIE.A);
IF IER<>0 THEN ERROR(OLIZ.H.FILENAME)
END
ELSE POSNR:=POSNR-1;
FELTNR:=2;
CLEARSCREEN;
LÆSFELT(PICTURE(FELTNR))
END
END;
(*$P*)
BEGIN (*PROCEDURE MAINTAIN*)
(*$XT*) WRITELN('MEMAVAIL1 ',MEMAVAIL); (*$X-*)
MARK(QUQ);
LÆSDESC(1);
(*$XT*) WRITELN('MEMAVAIL2 ',MEMAVAIL); (*$X-*)
HOVEDE:=TRUE;
CLEARSCREEN;
FELTNR:=16;
LÆSFELT(PICTURE(FELTNR));
IF HOVED.A(13)=1 THEN
BEGIN (*ORDRE*)
FELTNR:=1;
LÆSFELT(PICTURE(FELTNR));
IF HOVED.A(1)>0 THEN
BEGIN
GETREC(HOVZ.H,HOVF,HOVED.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR(HOVZ.H.FILENAME);
IF (IER=0) AND (HOVED.A(13)=0) THEN
BEGIN (*ORDREN VAR OPRETTET*)
CLEARSCREEN;
HOVED.A(13):=1;
FOR FELTNR:=1 TO 16 DO SKRIVFELT(PICTURE(FELTNR));
REPEAT
CH:='J';
D23;
WRITE('Rigtig ordre J/N ');
EDIT(CH)
UNTIL (CH='J') OR (CH='N');
IF CH='J' THEN
BEGIN
Q(2);
REPEAT
REPEAT
D23;
WRITE('Ændring af feltnr (0 for færdig) ');
READLN; IF EOLN THEN SETIORESULT(-1)ELSE READ(FELTNR)
UNTIL (IORESULT=0) AND (FELTNR>=0) AND (FELTNR<=15);
IF FELTNR IN (.2..15.) THEN Q(FELTNR)
UNTIL FELTNR=0;
PUTREC(HOVZ.H,HOVF,HOVED.A);
IF IER<>0 THEN ERROR(HOVZ.H.FILENAME);
OLINIE.A(13):=HOVED.A(1);OLINIE.A(14):=0;
NEXTREC(OLIZ.H,OLIF,OLINIE.A);
IF IER<>-1 THEN ERROR(OLIZ.H.FILENAME); IER:=0;
WHILE (IER=0) AND (OLINIE.A(13)=HOVED.A(1)) DO
BEGIN
OLINIE.A(38):=1;
PUTREC(OLIZ.H,OLIF,OLINIE.A);
IF IER<>0 THEN ERROR(OLIZ.H.FILENAME);
NEXTREC(OLIZ.H,OLIF,OLINIE.A)
END;
IF (IER<>0) AND (IER<>-2) AND (IER<>-9) THEN ERROR(OLIZ.H.FILENAME)
END
END
ELSE
BEGIN
D23;
IF IER=-6 THEN
WRITE('Tilbuddet findes ikke, RETURN')
ELSE
WRITE('Ordren er allerede inde, RETURN');
READLN
END;
END
END;
IF (HOVED.A(13)=0) OR (HOVED.A(1)=0) THEN
BEGIN
HOVED.A(1):= SYSTEM.A(2);
SYSTEM.A(2):=SYSTEM.A(2)+1;
IF HOVED.A(13)=1 THEN
BEGIN
FELTNR:=2;LÆSFELT(PICTURE(FELTNR));
HOVED.A(5):=0;
HOVED.A(6):=0
END
ELSE
BEGIN
FELTNR:=4;LÆSFELT(PICTURE(FELTNR));
HOVED.A(2):=0;
HOVED.A(3):=0
END;
SKRIVFELT(PICTURE(FELTNR));
Q(3);
FOR FELTNR:=5 TO 15 DO Q(FELTNR);
CLEARSCREEN;
FOR FELTNR:=1 TO 16 DO SKRIVFELT(PICTURE(FELTNR));
REPEAT
REPEAT
D23;
WRITE('Ændring af feltnr (0 for færdig) ');
READLN; IF EOLN THEN SETIORESULT(-1)ELSE READ(FELTNR)
UNTIL (IORESULT=0) AND (FELTNR>=0) AND (FELTNR<=15);
IF FELTNR IN (.2..15.) THEN Q(FELTNR)
UNTIL FELTNR=0;
INSERT(HOVZ.H,HOVF,HOVED.A);
IF IER<>0 THEN ERROR(HOVZ.H.FILENAME);
RELEASE(QUQ);
(*$XT*) WRITELN('MEMAVAIL3 ',MEMAVAIL); (*$X-*)
LÆSDESC(2);
(*$XT*) WRITELN('MEMAVAIL4 ',MEMAVAIL); (*$X-*)
HOVEDE:=FALSE;
POSNR:=1;
OLINPROC
END;
(*$XT*) WRITELN('MEMAVAIL5 ',MEMAVAIL); (*$X-*)
RELEASE(QUQ);
(*$XT*) WRITELN('MEMAVAIL6 ',MEMAVAIL); (*$X-*)
END;
(*$P*)
BEGIN
INIT;
SYSTEM.A(1):=1;
GETREC(SYSZ.H,SYSF,SYSTEM.A);
IF IER<>0 THEN ERROR(SYSZ.H.FILENAME);
REPEAT
CLEARSCREEN;
CH:='J';
GOTOXY(1,23);
WRITE('Flere tilbud/ordrer J/N ');
EDIT(CH);
IF CH='J' THEN MAINTAIN
UNTIL CH='N';
PUTREC(SYSZ.H,SYSF,SYSTEM.A);
IF IER<>0 THEN ERROR(SYSZ.H.FILENAME);
ICLOSE(HOVZ.H,HOVF);
ICLOSE(OLIZ.H,OLIF);
ICLOSE(SYSZ.H,SYSF);
WRITELN('ICLOSE ',IER)
END;
(*$P*)
BEGIN
I:=ORD(PARM^(1))-48;
REGVEDL;
FNAVN:=' ';
FNAVN(1):=PARM^(1);
CHAIN('L *1',CONCAT('HOVED:P2,',FNAVN),QUQ);
IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END.