PROGRAM NEWFON; { Konvertuje soubor fontu *.FON do binarniho souboru - pouzitelne POUZE s obsahem EPROM s firmwarem DATACOOP DCD PRT-42G }
{ (C) LZR Soft, 1991 }
CONST
 DEFNME	='DK:DCD42G ';
 EXTSOU ='EXE';
 EXTINP	='FON';
 EXTOUT	='NEW';
 ADRMEZ	=8191;
 XMEZ	=70;
TYPE
 VSTTXT	=ARRAY [0..7] OF CHAR;
VAR
 BYLACHYBA,
 VALERR	:BOOLEAN;
 PRV,
 LEN,ADR,
 L	:INTEGER;
 SOURCE,
 ZNAK   :CHAR;
 JMENO	:ARRAY [0..9] OF CHAR;
 POLE	:ARRAY [0..XMEZ,0..8] OF CHAR;
 INF	:FILE OF TEXT;
 SOU,
 OUF	:FILE OF CHAR;
 BINARNI:VSTTXT;
 PROM	:ARRAY [0..8700] OF CHAR;
 INFORM,
 RADEK	:ARRAY [0..XMEZ] OF CHAR;
{----------------------------------------------------------------------------}
FUNCTION PJMEN:CHAR;
VAR I:INTEGER;
BEGIN
FOR I:=0 TO 9 DO IF JMENO[I]>' ' THEN WRITE(JMENO[I]);
PJMEN:='.';
END;
{----------------------------------------------------------------------------}
FUNCTION PREVOD(NUM,ZAKL:INTEGER;FORM:BOOLEAN):CHAR;
VAR
 CIS:INTEGER;
 ZN:CHAR;
 PREV:REAL;
 PROCEDURE DIGIT(CO:REAL);
 VAR
  ZBYT:INTEGER;
  DELI:REAL;
 BEGIN
 CIS:=CIS-1;
  DELI:=TRUNC(CO/ZAKL);
 ZBYT:=ROUND(CO-DELI*ZAKL);
 IF CIS>0 THEN DIGIT(DELI);
 IF ZBYT<10 THEN ZBYT:=ZBYT+48
            ELSE ZBYT:=ZBYT+55;
 WRITE(CHR(ZBYT))
 END;
BEGIN
CASE ZAKL OF
  2:BEGIN CIS:=16;ZN:='B' END;
  8:BEGIN CIS:=06;ZN:='Q' END;
 10:BEGIN CIS:=05;ZN:='T' END;
 16:BEGIN CIS:=04;ZN:='H' END;
ELSE
    BEGIN CIS:=20-ZAKL;ZN:='\' END
END;
IF NOT(FORM) THEN CIS:=(CIS+1) DIV 2;
PREV:=NUM;
IF NUM<0 THEN PREV:=65536.0+PREV;
DIGIT(PREV);
PREVOD:=ZN;
END;
{----------------------------------------------------------------------------}
FUNCTION VAL(NUM:VSTTXT;ZAKL:INTEGER):INTEGER;
VAR I,J,CISLO:INTEGER;
    PREV:REAL;
BEGIN
VALERR:=FALSE;
VAL:=0;
IF NUM[0]<>' ' THEN
 BEGIN
 I:=0;
 IF ZAKL<>2 THEN WHILE (NUM[I]<>' ') DO I:=I+1 ELSE I:=8;
 PREV:=0.0;
 FOR J:=0 TO I-1 DO
  BEGIN
  CISLO:=ORD(NUM[J])-48;
  IF CISLO>9 THEN CISLO:=CISLO-7;
  VALERR:=VALERR OR (CISLO>=ZAKL) OR (CISLO<0);
  PREV:=PREV*ZAKL+CISLO;
  END;
 VALERR:=VALERR OR (PREV>65535.0);
 IF NOT(VALERR) THEN
  BEGIN
  IF PREV>32767.0 THEN PREV:=PREV-65536.0;
  IF PREV<-32767.0 THEN VAL:=-32768 ELSE VAL:=ROUND(PREV);
  END;
 END;
END;
{----------------------------------------------------------------------------}
FUNCTION ASC(CON:CHAR):INTEGER;
VAR I:INTEGER;
BEGIN
 I:=ORD(CON);
 IF I<0 THEN I:=256+I;
 ASC:=I
END;
{----------------------------------------------------------------------------}
PROCEDURE PRECTIRADEK;
VAR I:INTEGER;
BEGIN
FOR I:=0 TO XMEZ DO INFORM[I]:=' ';
I:=0;
WHILE NOT(EOLN(INF)) AND NOT(EOF(INF)) AND (I<=XMEZ) DO
 BEGIN
 READ(INF,INFORM[I]);
 I:=I+1;
 END;
READLN(INF);
END;
{----------------------------------------------------------------------------}
PROCEDURE KONTROLATVARU;
BEGIN
IF VALERR THEN
 BEGIN
 IF NOT(BYLACHYBA) THEN WRITELN;
 WRITELN('Spatny tvar:',BINARNI);
 BYLACHYBA:=TRUE;
 END;
END;
{----------------------------------------------------------------------------}
PROCEDURE FONTY;
 PROCEDURE KONVERZE;
 VAR J,K,STCHR:INTEGER;
 BEGIN
 RADEK:=INFORM;
 PRECTIRADEK;
 FOR K:=0 TO 8 DO
  BEGIN
  FOR J:=0 TO XMEZ DO
   BEGIN  
   READ(INF,ZNAK);
   CASE ZNAK OF
   ' ':BEGIN POLE[J,K]:='0'; END;
   '*':BEGIN POLE[J,K]:='1'; END;
   ELSE
    BEGIN POLE[J,K]:='*'; END
   END;{CASE}
   END;
   READLN(INF);
  END;
 PRECTIRADEK;
 FOR STCHR:=0 TO 6 DO
  BEGIN
  PRV:=STCHR*10+1;
  FOR J:=PRV TO PRV+4 DO BINARNI[J-PRV]:=RADEK[J];
  ADR:=VAL(BINARNI,16);
  IF VALERR THEN
   WRITELN(CHR(13),CHR(7),
           'Spatna adresa:',BINARNI[0],BINARNI[1],BINARNI[2],BINARNI[3])
  ELSE
   WRITE('	',CHR(13),'Adresa:',PREVOD(ADR,16,TRUE),'	');
  IF (ADR<4300B) OR		{ 08C0H - 0 000 100 011 000 000B }
     (ADR>20441B) THEN		{ 2121H - 0 010 000 100 100 001B }
   BEGIN
   ADR:=17770B;			{ 1FF8H - 0 001 111 111 111 000B }
   IF NOT(VALERR) THEN WRITELN(' je mimo meze!');
   VALERR:=TRUE;
   END;
  BYLACHYBA:=VALERR;
  FOR J:=0 TO 8 DO
   BEGIN
   FOR K:=0 TO 7 DO BINARNI[7-K]:=POLE[PRV+J,K];
   PROM[ADR]:=CHR(VAL(BINARNI,2));
   KONTROLATVARU;
   ADR:=ADR+1;
   END;
  FOR J:=0 TO 7 DO BINARNI[7-J]:=POLE[PRV+J,8];
  PROM[ADR]:=CHR(VAL(BINARNI,2));
  KONTROLATVARU;
  ADR:=ADR+1;
  FOR J:=0 TO 2 DO BINARNI[J]:=RADEK[PRV+J+7];
  PROM[ADR]:=CHR(VAL(BINARNI,16)+ORD(POLE[PRV+8,8])-48);
  IF VALERR THEN
   BEGIN
   IF NOT(BYLACHYBA) THEN WRITELN;
   WRITELN('Spatny kod:',BINARNI[0],BINARNI[1]);
   END;
  ADR:=ADR+1;
  END;
 END;

BEGIN
REPEAT
 REPEAT
  PRECTIRADEK;
 UNTIL ((INFORM[6]=':') AND (INFORM[66]=':')) OR EOF(INF);
 IF NOT(EOF(INF)) THEN KONVERZE;;
UNTIL EOF(INF);
END;

PROCEDURE TVARY;
VAR M:INTEGER;
BEGIN
RESET(INF,JMENO,EXTINP,LEN);
IF (LEN<1) THEN
 WRITELN('Nenalezen vstupni soubor             : ',PJMEN,EXTINP)
ELSE
 RESET(SOU,JMENO,EXTSOU,LEN);
 IF (LEN<1) THEN
  WRITELN('Nenalezen vstupni soubor             : ',PJMEN,EXTSOU)
 ELSE
 BEGIN
 L:=LEN;
 REWRITE(OUF,JMENO,EXTOUT,L);
 IF (L<1) THEN
  WRITELN('Neni misto vystupni soubor           : ',PJMEN,EXTOUT)
 ELSE
  BEGIN
  FOR L:=0 TO ADRMEZ DO PROM[L]:=CHR(0);
  ADR:=37777B;
  FONTY;
  FOR L:=0 TO ADRMEZ DO
   BEGIN
   SOURCE:=SOU^;
   GET(SOU);
   IF (L<4300B) OR		{ 08C0H - 0 000 100 011 000 000B }
      ((L>7767B) AND		{ 0FF7H - 0 000 111 111 110 111B }
      (L<14300B)) OR		{ 18C0H - 0 001 100 011 000 000B }
      (L>17767B) THEN		{ 1FF7H - 0 001 111 111 110 111B }
    OUF^:=SOURCE
   ELSE
    OUF^:=PROM[L];
   PUT(OUF);
   END;
  CLOSE(OUF);
  END;
 CLOSE(SOU);
 CLOSE(INF);
 END;
END;
{----------------------------------------------------------------------------}
BEGIN
WRITELN('Prevod souboru fontu pro EPROM tiskarny DATACOOP DCD PRT42G');
WRITELN('===========================================================');
WRITE('Jmeno souboru fontu [',DEFNME,'.',EXTINP,'] : ');
READLN(JMENO);IF JMENO='          ' THEN JMENO:=DEFNME;
FOR L:=0 TO 8 DO IF (JMENO[L]=':') AND (JMENO[L+1]=' ') THEN JMENO:=DEFNME;
WRITELN;
WRITELN('Jsou pouzity vstupni soubory         : ',PJMEN,EXTINP);
WRITELN('                                     : ',PJMEN,EXTSOU);
WRITELN('Generuje se vystupni soubor          : ',PJMEN,EXTOUT);
WRITELN;
TVARY;
WRITELN;
WRITELN(CHR(10),'Konec prace. (C) 1991, LZR Soft, POLDI Kladno');
END.
{----------------------------------------------------------------------------}