DataMuseum.dk

top - download

    Length: 6528 (0x1980)
    Types: TextFile
    Names: »RNT.PAS«

└─⟦6cf793dfc⟧ Bits:30003506 JET80 Grafik og fontprogrammering
    └─ ⟦this⟧ »RNT.PAS« 

TextFile

PROGRAM skapa_rnt;

CONST    ant_fnt             = 16;

TYPE     rnt_typ             = (init,norm);
         rnt_dat             = RECORD
                                 height     : Byte;
                                 intra_chr  : Byte;
                                 intra_ln   : Byte;
                               END;
         tkn_rec             = RECORD
                                 CASE rnt_typ OF
                                   init : (init:rnt_dat);
                                   norm : (norm: RECORD
                                                   aktiv : Boolean;
                                                   bredd : Byte;
                                                   rad   : Array(.1..3,
                                                           1..50.) OF Byte;
                                                 END;);
                               END;
         str8                = String(.8.);

VAR      rntfil              : File OF tkn_rec;
         rnt_rec             : tkn_rec;
         error               : Boolean;
         rnt_pek             : Integer;
         t                   : Char;
         fil                 : Array(.1..ant_fnt.) OF String(.8.);
         fnr                 : Integer;
         kol                 : Byte;

PROCEDURE initfil;
BEGIN
  fil(.1.):='ASCII12';
  fil(.2.):='CIRCUS24';
  fil(.3.):='COPR18';
  fil(.4.):='COPR24';
  fil(.5.):='FEANOR18';
  fil(.6.):='GOTH18';
  fil(.7.):='GOTH24';
  fil(.8.):='GOTHB18';
  fil(.9.):='GOTHB24';
  fil(.10.):='ITALIC18';
  fil(.11.):='ITALIC24';
  fil(.12.):='PUNC18';
  fil(.13.):='PUNC24';
  fil(.14.):='ROMAN18';
  fil(.15.):='ROMAN24';
  fil(.16.):='SROMAN24';
END;


PROCEDURE gor_rnt(fontfil:str8;VAR nofnt:Boolean);

VAR      fntfil              : Text;
         rad                 : String(.100.);
         tot_rad             : String(.200.);

PROCEDURE las_init_fnt;
BEGIN
  WITH rnt_rec.init DO
  BEGIN
    Readln(fntfil,rad);                       (* ;;Height *)
    Readln(fntfil,rad);                       (* Numeriskt værde *)
    height:=Ord(rad(.1.))-48;
    Readln(fntfil,rad);                       (* ;;Intra-Character spacing *)
    Readln(fntfil,rad);                       (* Numeriskt værde *)
    intra_chr:=Ord(rad(.1.))-48;
    Readln(fntfil,rad);                       (* ;;Intra-line spacing*)
    Readln(fntfil,rad);                       (* Numeriskt værde *)
    intra_ln:=Ord(rad(.1.))-48;
  END;
  Write(rntfil,rnt_rec);
  rnt_pek:=1;
END;

PROCEDURE las_tkn;
BEGIN
  Readln(fntfil,rad);
  WHILE (rad(.1.)=' ') AND NOT(EOF(fntfil)) DO
  BEGIN
    tot_rad:=tot_rad+Copy(rad,2,Length(rad)-1);
    Readln(fntfil,rad);
  END;
END;

PROCEDURE konv_tkn;
VAR      r,k,pek             : Byte;
         fp                  : Integer;
BEGIN
  Write(tot_rad(.1.):2);
  kol:=Succ(kol);
  IF kol=30 THEN
  BEGIN
    kol:=1;
    Writeln;
  END;

  rnt_rec.norm.aktiv:=False;
  rnt_rec.norm.bredd:=0;
  FOR r:=1 TO 3 DO                        (* Nollstæll raderna          *)
    FOR k:=1 TO 50 DO
      rnt_rec.norm.rad(.r,k.):=0;
  fp:=Ord(tot_rad(.1.))-31;               (* Space hamnar i post 1  *)

  IF fp<>rnt_pek THEN                     (* Initiera odef tecken *)
    REPEAT
      Write(rntfil,rnt_rec);
      rnt_pek:=Succ(rnt_pek);
    UNTIL rnt_pek=fp;

  WITH rnt_rec.norm DO
  BEGIN
    aktiv:=True;                            (* Tecknet finns --> aktiv    *)
    bredd:=Ord(tot_rad(.3.))-48;            (* Plocka ut bredden          *)
    IF tot_rad(.4.) IN (.'0'..'9'.) THEN
      bredd:=bredd*10+Ord(tot_rad(.4.))-48;

    pek:=1;                                 (* Leta efter førsta datatkn  *)
    r:=1;
    REPEAT
      pek:=Succ(pek);
      IF tot_rad(.pek.)=',' THEN r:=Succ(r);
    UNTIL (tot_rad(.pek.) IN (.'?'..'ü'.)) OR (pek > Length(tot_rad));
    r:=r-3;                                 (* Alltid 3 ',' innan rad 1 *)

    k:=1;                                   (* Børja i kolumn 1         *)
    IF NOT (pek > Length(tot_rad)) THEN
    BEGIN
      REPEAT
        CASE r OF
          1 : rad(.1,k.):=(Ord(tot_rad(.pek.))-63);
          2 : BEGIN
                rad(.1,k.):=rad(.1,k.) OR ((Ord(tot_rad(.pek.))-63) SHL 6);
                rad(.2,k.):=((Ord(tot_rad(.pek.))-63) SHR 2);
              END;
          3 : BEGIN
                rad(.2,k.):=rad(.2,k.) OR ((Ord(tot_rad(.pek.))-63) SHL 4);
                rad(.3,k.):=((Ord(tot_rad(.pek.))-63) SHR 4);
              END;
          4 : rad(.3,k.):=rad(.3,k.) OR ((Ord(tot_rad(.pek.))-63) SHL 2);
        END;
        pek:=Succ(pek);
        k:=Succ(k);
        WHILE (tot_rad(.pek.)=',') AND NOT (pek>Length(tot_rad)) DO
        BEGIN
          k:=1;
          r:=Succ(r);
          pek:=Succ(pek);
        END;
      UNTIL (pek>Length(tot_rad));
    END;
  END;
END;


PROCEDURE skriv_tkn;
BEGIN
  Write(rntfil,rnt_rec);
  rnt_pek:=Succ(rnt_pek);
END;


BEGIN
  Assign(fntfil,fontfil+'.FNT');
  (*$I-*)
  Reset(fntfil);
  (*$I+*)
  IF IoResult=0 THEN
  BEGIN
    nofnt:=False;
    Assign(rntfil,fontfil+'.RNT');
    Rewrite(rntfil);
    las_init_fnt;
    Readln(fntfil,tot_rad);                        (* Førsta "dataraden" *)
    WHILE NOT EOF(fntfil) DO
    BEGIN
      las_tkn;
      konv_tkn;
      skriv_tkn;
      tot_rad:=rad;
    END;
    Close(fntfil);
    Close(rntfil);
  END
  ELSE
   nofnt:=True;
END;

BEGIN
  initfil;
  REPEAT
    ClrScr;
    Writeln('           Dessa fonter finns på skivan : ',#10);
    FOR fnr:=1 TO ant_fnt DO
      Writeln('         ',fnr:2,'     -     ',fil(.fnr.));
    Writeln;
    Writeln('Ange med nummer vilken font som skall konverteras till .RNT format !');
    Write(' 0 - Avslutar , ',ant_fnt+1,' - Alla       Nummer ? ');
    REPEAT
      Read(fnr);
    UNTIL (fnr>=0) AND (fnr<=ant_fnt+1);
    ClrScr;
    IF fnr<>0 THEN
      IF fnr<>ant_fnt+1 THEN
      BEGIN
        kol:=1;
        Writeln(#10,#10,#13,fil(.fnr.),' :');
        gor_rnt(fil(.fnr.),error);
        IF error THEN Writeln(fil(.fnr.),' saknas !');
      END
      ELSE
        FOR fnr:=1 TO ant_fnt DO
        BEGIN
          kol:=1;
          Writeln(#10,#10,#13,fil(.fnr.),' :');
          gor_rnt(fil(.fnr.),error);
          IF error THEN Writeln(fil(.fnr.),' saknas !');
        END;
  UNTIL fnr=0;
END.

«eof»