DataMuseum.dk

top - download

    Length: 10112 (0x2780)
    Notes: Mikados TextFile, Mikados_K
    Names: »FILETEST«

└─⟦ec8c1e0b0⟧ Bits:30007442 8" floppy ( MIKPROG vol. 1-3, MIKREL vol. 1-3, PCSE 4.7.80 vol 1-3, GL.SYS )
    └─ ⟦this⟧ »FILETEST« 

Text

PROGRAM FILETEST;
 
       (***************************************************)
       (*                                                 *)
       (*   OPRETTELSE OG AJOURFØRING AF PERSONKARTOTEK   *)
       (*                                                 *)
       (* DEMONSTRATION AF DIREKTE FILER OG ANVENDELSE AF *)
       (* EDIT PROCEDUREN I MIKADOS PASCAL                *)
       (***************************************************)
 
 
TYPE STATUS = ( GIFT, ENKE, FRASKILT, UNGKARL );
     ALFA = STRING(30);
     TEKST = STRING(18);
     DATO = RECORD DAG: 1..31;
                   MÅNED: 1..12;
                   ÅR: INTEGER
            END;
     PERSON = RECORD
                NAVN: RECORD
                        FORNAVN, EFTERNAVN: ALFA
                      END;
                KØN: (MAND, KVINDE, UKENDT);
                FØDSELSDATO: DATO;
                CASE ÆGTESKABELIGSTATUS: STATUS OF
                  GIFT, ENKE: (GIFTEDATO: DATO);
                  FRASKILT:   (SKILSMISSEDATO: DATO;
                               ANTALSKILSMISSER: INTEGER);
                  UNGKARL:    (UAFHÆNGIG: BOOLEAN)
              END (*PERSON*);
 
VAR  REGISTER: FILE OF PERSON;
     ÆSTATUS, KODE: ALFA;
     FINISHED, OK: BOOLEAN;
     OPKODE, SVAR : CHAR;
     POSTNUMMER: INTEGER;
     IOVAL: INTEGER;
 
 
       (***************************************************)
       (* GENERELT ANVENDELIG PROCEDURE SOM ILLUSTRERER   *)
       (* HVORLEDES EDIT PROCEDUREN KAN ANVENDES TIL      *)
       (* REDIGERING AF HELTAL.                           *)
       (* HVIS OPKODE<>'R' INDTASTES NYT HELTAL           *)
       (* HVIS OPKODE ='R' PRÆSENTERES DET NUVÆRENDE      *)
       (*      INDHOLD AF HELTAL PÅ SKÆRMEN MED HENBLIK   *)
       (*      PÅ REDIGERING                              *)
       (***************************************************)
 
PROCEDURE ENTERINTEGER( LEDETEKST: TEKST;
                        VAR HELTAL: INTEGER );
  VAR STØRRELSESORDEN,INDEX: INTEGER;
      INTSTRING: STRING(6);
      SIGN, CH: CHAR;
      DIGITS, FINISHED: BOOLEAN;
BEGIN
  INDEX := 18;
  WHILE LEDETEKST(INDEX)=' ' DO INDEX:=INDEX-1;
  WRITE( LEDETEKST:INDEX, ' ' );
  INTSTRING := '      ';
  IF OPKODE='R' THEN
    BEGIN
    INDEX:=0;
    IF HELTAL<0 THEN
      BEGIN
      HELTAL:=-HELTAL;
      INDEX:=1;
      INTSTRING(1):='-'
      END;
    STØRRELSESORDEN:=10000;
    WHILE HELTAL<STØRRELSESORDEN DO
      STØRRELSESORDEN := STØRRELSESORDEN DIV 10;
    REPEAT
      BEGIN
      INDEX:=INDEX+1;
      INTSTRING(INDEX):= CHR( HELTAL DIV STØRRELSESORDEN + ORD('0'));
      HELTAL := HELTAL MOD STØRRELSESORDEN;
      STØRRELSESORDEN := STØRRELSESORDEN DIV 10;
      END;
    UNTIL STØRRELSESORDEN=0;
    END;
  EDIT( INTSTRING:6 );
  INDEX := 1;
  FINISHED := FALSE;
  DIGITS := FALSE;
  SIGN := ' ';
  HELTAL := 0;
  REPEAT
    BEGIN
    CH := INTSTRING(INDEX);
    IF CH IN (.'+','-'.) THEN
      IF DIGITS OR (SIGN<>' ') THEN FINISHED:=TRUE
      ELSE SIGN:= CH
    ELSE
      IF CH IN (.'0'..'9'.) THEN
        BEGIN
        HELTAL := HELTAL*10 + ORD(CH) - ORD('0');
        DIGITS := TRUE
        END
      ELSE FINISHED:=TRUE;
    INDEX := INDEX + 1;
    END;
  UNTIL FINISHED OR (INDEX>6);
  IF SIGN='-' THEN HELTAL:=-HELTAL;
END  (*ENTERINTEGER*);
 
PROCEDURE ENTERSTRING( LEDETEKST: TEKST;
                       VAR EDITSTRING: ALFA;
                       LÆNGDE: INTEGER );
  VAR INDEX: INTEGER;
BEGIN
  INDEX:=18;
  WHILE LEDETEKST(INDEX)=' ' DO INDEX:=INDEX-1;
  WRITE( LEDETEKST:INDEX, ' ' );
  IF OPKODE='O' THEN
    BEGIN
    FILLCHAR( EDITSTRING(1), LÆNGDE, ' ' );
    (*$R-*)  EDITSTRING(0) := CHR(LÆNGDE);  (*$R+*)
    END;
  EDIT( EDITSTRING:LÆNGDE )
END (*ENTERSTRING*);
 
PROCEDURE ENTERDATO( LEDETEKST: TEKST;
                     VAR EDITDATO: DATO );
  VAR INDEX: INTEGER;
BEGIN
  INDEX:= 18;
  WHILE LEDETEKST(INDEX)=' ' DO INDEX:=INDEX-1;
  WRITE( LEDETEKST:INDEX, ' ' );
  WITH EDITDATO DO
    BEGIN
    ENTERINTEGER( 'DAG               ', DAG );
    ENTERINTEGER( 'MÅNED             ', MÅNED );
    ENTERINTEGER( 'ÅR                ', ÅR );
    END;
END  (*ENTERDATO*);
 
PROCEDURE ENTERCOMMAND;
BEGIN
  REPEAT
    BEGIN
    WRITE( 'OPERATIONSKODE (O-OPRET, R-RET, A-AFSLUT) ' );
    WHILE EOLN DO READLN;
    READ( OPKODE );
    END;
  UNTIL OPKODE IN (.'O','R','A'.);
END;
 
PROCEDURE ENTERSTATUS;
BEGIN
  IF OPKODE='R' THEN
    CASE REGISTER^.ÆGTESKABELIGSTATUS OF
      GIFT:     ÆSTATUS := 'GIFT    ';
      ENKE:     ÆSTATUS := 'ENKE    ';
      FRASKILT: ÆSTATUS := 'FRASKILT';
      UNGKARL:  ÆSTATUS := 'UNGKARL';
    END
  ELSE ÆSTATUS := '    ';
  REPEAT
    BEGIN
    WRITE( 'INDTAST ÆGTESKABELIG STATUS (G/F/E/U) ' );
    EDIT( ÆSTATUS );
    END;
  UNTIL ÆSTATUS(1) IN (.'G','F','E','U'.);
END;
 
 
BEGIN
REWRITE( REGISTER, 'PERSDATA:P2:10' );
FINISHED := FALSE;
REPEAT
  BEGIN
  CLEARSCREEN;
  OK := TRUE;
  ENTERCOMMAND;
  IF OPKODE<>'A' THEN
    BEGIN
    WRITELN;
    WRITE( 'INDTAST POSTNUMMER ' );
    READ( POSTNUMMER );
    SEEK( REGISTER, POSTNUMMER );
    IF IORESULT<>0 THEN
      BEGIN
      IOVAL:=IORESULT;
      WRITE( 'FEJL ', IOVAL, ' VED OPSLAG I FIL' );
      WRITE(' - TAST RETURN:');
      READLN;
      OK := FALSE
      END;
    IF OK AND (OPKODE='R') THEN
      BEGIN
      GET( REGISTER );
      IF IORESULT<>0 THEN
        BEGIN
        WRITELN( 'FEJL ', IORESULT, ' VED INDLÆSNING AF POST');
        OK := FALSE
        END
      ELSE SEEK( REGISTER, POSTNUMMER );
      END;
    IF OK THEN
      BEGIN
      WITH REGISTER^,NAVN DO
        BEGIN
        ENTERSTRING('FORNAVN           ', FORNAVN, 30 );
        ENTERSTRING('EFTERNAVN         ', EFTERNAVN, 30 );
        KODE := ' ';
        REPEAT
          BEGIN
          IF OPKODE='R' THEN
            CASE KØN OF
              MAND:   KODE := 'M';
              KVINDE: KODE := 'K';
              UKENDT: KODE := 'U';
            END;
          ENTERSTRING('KØN (M/K/U)       ', KODE, 1 );
          END;
        UNTIL KODE(1) IN (.'M','K','U'.);
        CASE KODE(1) OF
          'M': KØN := MAND;
          'K': KØN := KVINDE;
          'U': KØN := UKENDT;
        END;
        ENTERDATO( 'FØDSELSDATO       ', FØDSELSDATO );
        ENTERSTATUS;
        CASE ÆSTATUS(1) OF
          'G','E': BEGIN
                 IF ÆSTATUS(1)='G' THEN ÆGTESKABELIGSTATUS:=GIFT
                                ELSE ÆGTESKABELIGSTATUS:=ENKE;
                 WRITE( 'DATO FOR ÆGTESKABETS ');
                 ENTERDATO('INDGÅELSE         ',GIFTEDATO);
               END;
          'F': BEGIN
                 ÆGTESKABELIGSTATUS:=FRASKILT;
                 ENTERDATO('SKILSMISSEDATO    ', SKILSMISSEDATO );
                 ENTERINTEGER('ANTAL SKILSMISSER ',ANTALSKILSMISSER);
               END;
          'U': BEGIN
                 ÆGTESKABELIGSTATUS:=UNGKARL;
                 REPEAT
                   BEGIN
                   WRITE('UAFHÆNGIG (J/N) ');
                   WHILE EOLN DO READLN;
                   READ( SVAR )
                   END;
                 UNTIL SVAR IN (.'J','N'.);
                 UAFHÆNGIG := SVAR = 'J';
               END;
        END (*CASE ÆGTESKABELIGSTATUS*);
        END (*WITH REGISTER^*);
      PUT( REGISTER );
      END  (*IF OK*);
    END (*OPKODE<>'A'*);
  END (*REPEATSÆTNING*);
UNTIL OPKODE='A';
WRITELN('FILETEST SLUT')
END (*FILETEST*).