DataMuseum.dk

top - download

    Length: 6240 (0x1860)
    Types: TextFile
    Notes: Mikados_K
    Names: »TOLDVEDL.K«

└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
    └─⟦this⟧ »TOLDVEDL.K« 

Mikados K File

PROGRAM TOLDVEDL;
(*$IISFHEAD*)
TOLDPOPOST=RECORD
       A:AR;
  NR1,NR2:INTEGER;
  TEKST:PACKED ARRAY (1..30) OF CHAR
END;
ZONE= RECORD
       H:ISFHEAD;
       T:ARRAY(1..1000) OF INTEGER
 END;
SYSPOST=RECORD
HELTAL:ARRAY(1..24) OF INTEGER;
KGB:ARRAY (1..5) OF REAL;
BETADAT:PACKED ARRAY (1..13) OF CHAR;
KODE:ARRAY (1..2) OF PACKED ARRAY (1..10) OF CHAR
END;
SYSFILE=FILE OF SYSPOST;
VAR    F:ISF;
       TPZ:ZONE;
FILNAVN1,FILNAVN2:STRING(20);
       ÆNDRE,IER,I:INTEGER;
       TOLDPO:TOLDPOPOST;
       SYSFIL:SYSFILE;
       QUQ:^INTEGER;
       KODE1,KODE2:STRING(10);
 
       R:REAL;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$IIOPEN*)
(*$ISÆTØG*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IFORSKYD*)
(*$IICLOSE*)
(*$IPUTGET*)
(*$IINSERT*)
(*$INEXTREC*)
(*$IDELETE*)
(*$R+*)
(*$L+*)
PROCEDURE PRVAROPL;
BEGIN
WITH TOLDPO DO
BEGIN
    CLEARSCREEN;
    GOTOXY(1,1);WRITE('1 TOLDPOSITIONSNR');GOTOXY(30,1);
    WRITELN((NR1*1000.0+NR2)/1000.0:10:3);
    GOTOXY(1,2);WRITE('2 TEKST');GOTOXY(30,2);WRITELN(TEKST)
END
END;
PROCEDURE STOP;
VAR I:INTEGER;
BEGIN I:=I DIV 0 END;
PROCEDURE VAREOPL(O:INTEGER);
VAR STRENG:STRING;
    I:INTEGER;
    R:REAL;
BEGIN
  WITH TOLDPO DO
  CASE O OF
    1: BEGIN REPEAT
       GOTOXY(20,1);READLN;READ(R)
       UNTIL (R>=1000.0) AND (R<10000.0) AND (IORESULT=0);
       NR1:=TRUNC(R);
       NR2:=TRUNC(1000.0*(R-NR1))
       END;
    2: BEGIN REPEAT
       GOTOXY(30,2);READLN;READ(STRENG)
       UNTIL LENGTH(STRENG)<31;
       FILLCHAR(TEKST,30,' ');
       FOR I:=1 TO LENGTH(STRENG) DO TEKST(I):=STRENG(I) END;
    END
END;
PROCEDURE ZERREC;
BEGIN
  WITH TOLDPO DO
  BEGIN
           NR1:=0;
           NR2:=0;
       FILLCHAR(TEKST,30,' ');
  END
END;
PROCEDURE ERROR;
BEGIN
  WRITELN('FEJL I TOLDPOREG ',IER);
  ICLOSE(TPZ.H,F);
  WRITELN('ICLOSE ',IER);
  STOP
END;
PROCEDURE MAINTAIN;
VAR I,O,P,KODE:INTEGER;
    CHANGED:BOOLEAN;
    STRENG:STRING;
    STRENG1:STRING(10);
BEGIN
  (*INDLÆS KODE1 OG KODE2 FRA SYSREG*)
  CLEARSCREEN;
  GOTOXY(1,1);WRITELN('ADGANGSKODE');
  GOTOXY(20,1);READLN;READ(STRENG1);
  KODE:=0;
  IF STRENG1=KODE1 THEN KODE:=1;
  IF STRENG1=KODE2 THEN KODE:=2;
  REPEAT
  CLEARSCREEN;
  REPEAT
 GOTOXY(1,22);WRITELN('OPRETTE, KIKKE ELLER SLETTE (1/2/3), 0 FOR STOP   ');
       GOTOXY(50,22);READLN;READ(P)
  UNTIL (IORESULT=0) AND((P=1) OR (P=2) OR (P=0) OR (P=3));
  CASE P OF
    1: IF ÆNDRE=1 THEN BEGIN
        ZERREC;
        PRVAROPL;
        FOR I:=1 TO 2 DO VAREOPL(I);
        PRVAROPL;
        REPEAT
         GOTOXY(1,22);WRITELN('ÆNDRINGER, 0 FOR NEJ ELLERS FELTNR         ');
         GOTOXY(40,22);READLN;READ(O);
         IF ((O>=1) AND (O<=2))  THEN VAREOPL(O);
         PRVAROPL
        UNTIL O=0;
        REPEAT
        INSERT(TPZ.H,F,TOLDPO.A);
        IF IER=-7 THEN
        BEGIN
         GOTOXY(1,23);WRITELN('TOLDPONR FINDES I FORVEJEN ');
         VAREOPL(1)
        END
        ELSE
        IF IER<>0 THEN ERROR
        UNTIL IER=0;
       END;
    2: BEGIN
         REPEAT
          GOTOXY(1,23);WRITELN('TOLDPOSITIONSNR                           ');
          GOTOXY(30,23);READLN;READ(R)
         UNTIL (IORESULT=0) AND (R>=1000.0) AND (R<10000.0);
         TOLDPO.NR1:=TRUNC(R);
         TOLDPO.NR2:=TRUNC(1000.0*(R-TOLDPO.NR1));
         GETREC(TPZ.H,F,TOLDPO.A);
         IF IER=-6 THEN WRITELN('TOLDPOSITIONSNR EKSISTERER IKKE')
         ELSE
         IF IER<>0 THEN ERROR
         ELSE
         BEGIN
         PRVAROPL;
         CHANGED:=FALSE;
         REPEAT
         REPEAT
          GOTOXY(1,22);WRITELN('HVILKET FELT SKAL ÆNDRES, 0 FOR SLUT      ');
          GOTOXY(40,22);READLN;READ(O)
         UNTIL (IORESULT=0) AND ((O=0) OR (ÆNDRE=1));
         IF O=2 THEN BEGIN VAREOPL(2);CHANGED:=TRUE END;
        PRVAROPL
        UNTIL O=0;
        IF CHANGED THEN PUTREC(TPZ.H,F,TOLDPO.A)
       END
      END;
   3: IF ÆNDRE=1 THEN BEGIN
        REPEAT
          GOTOXY(1,23);WRITELN('TOLDPOSITIONSNR                           ');
          GOTOXY(30,23);READLN;READ(R)
        UNTIL (IORESULT=0) AND (R>=1000.0) AND (R<10000.0);
        TOLDPO.NR1:=TRUNC(R);
        TOLDPO.NR2:=TRUNC(1000.0*(R-TOLDPO.NR1));
        GETREC(TPZ.H,F,TOLDPO.A);
        IF IER=-6 THEN WRITELN('TOLDPOSITIONSNR EKSISTERER IKKE')
        ELSE
        IF IER<>0 THEN ERROR
        ELSE
        BEGIN
          PRVAROPL;
          IF KODE=2 THEN
          WITH TOLDPO DO
          BEGIN
               REPEAT
               GOTOXY(1,23);WRITELN('SKAL SLETNING UDFØRES (1), 0 FOR NEJ ');
               GOTOXY(40,23);READLN;READ(O)
               UNTIL (IORESULT=0) AND ((O=0) OR (O=1));
               IF O=1 THEN
               BEGIN
                 DELETE(TPZ.H,F,A);
                 PRVAROPL;
                 IF IER<>0 THEN ERROR
               END
            END
            ELSE
            BEGIN
               GOTOXY(1,23);
               WRITELN('SLETNING MÅ IKKE UDFØRES MED OPGIVEN NØGLE')
            END
         END
      END
   END
   UNTIL P=0
END;
BEGIN
  FILNAVN1:='SYSREG:P2:1:I';
  REWRITE(SYSFIL,FILNAVN1);
  SEEK(SYSFIL,1);
  GET(SYSFIL);
  KODE1:='          ';
  KODE2:=KODE1;
  FOR I:=1 TO 10 DO
  BEGIN
    KODE1(I):=SYSFIL^.KODE(1,I);
    KODE2(I):=SYSFIL^.KODE(2,I)
  END;
  CLOSE(SYSFIL);
  CLEARSCREEN;
  WRITELN('0 Kikke, 1 Ændre');
  REPEAT
    GOTOXY(18,1);
    READLN;READ(ÆNDRE)
  UNTIL (IORESULT=0) AND (ÆNDRE>=0) AND (ÆNDRE<=1);
  FILNAVN2:='TOLDPORG:P2:0000:I';
  IF ÆNDRE=1 THEN
   REWRITE(F,FILNAVN2) ELSE RESET(F,FILNAVN2);
  I:=IORESULT;
IF I<>0 THEN BEGIN WRITELN('REWRITE ',I);STOP END;
  IF ÆNDRE=1 THEN
    IOPEN(TPZ.H,F,SKRIV) ELSE IOPEN(TPZ.H,F,LÆS);
IF IER<>0 THEN WRITE('IOPEN ',IER) ELSE
BEGIN
  MAINTAIN;
END;
  ICLOSE(TPZ.H,F);
  CLEARSCREEN;
  WRITELN('ICLOSE ',IER);
  CHAIN('INTRE   *1','HOVSA:P1',QUQ)
END.