PROGRAM NEWHEX; { Konvertuje dump soubor .DMP do binarniho souboru .CIL }
{ (C) LZR Soft, 1991 }
CONST
 DEFNME	='DK:DCD42G ';
 EXTINP	='DMP';
 EXTOUT	='CIL';
 ADRMEZ	=17777B; { 1FFFH - 0 001 111 111 111 111B }
 XMEZ	=56;
TYPE
 VSTTXT	=ARRAY [0..7] OF CHAR;
VAR
 VALERR	:BOOLEAN;
 LEN,
 ADR	:INTEGER;
 ZNAK   :CHAR;
 JMENO	:ARRAY [0..9] OF CHAR;
 INF	:FILE OF TEXT;
 OUF	:FILE OF CHAR;
 HEXA	:VSTTXT;
 PROM	:ARRAY [0..ADRMEZ] OF CHAR;
 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 {(ROUND(DELI)>0) OR (true) and} (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 RADEK[I]:=' ';
I:=0;
WHILE NOT(EOLN(INF)) AND NOT(EOF(INF)) AND (I<=XMEZ) DO
 BEGIN
 READ(INF,RADEK[I]);
 I:=I+1;
 END;
READLN(INF);
END;
{----------------------------------------------------------------------------}

PROCEDURE PRECTIPOUKY;
VAR I:INTEGER;
 PROCEDURE DEKODUJRADEK;
 VAR J,K,STCHR:INTEGER;
 BEGIN
 WRITE('	',CHR(13),'Adresa:',PREVOD(ADR,16,TRUE),'	');
 IF ADR>ADRMEZ THEN
  BEGIN
   ADR:=17760B;				{ 1FF0H - 0 001 111 111 110 000B }
   WRITELN(' je mimo meze!');
  END;
 FOR J:=0 TO 15 DO
  BEGIN
  FOR K:=0 TO 2 DO HEXA[K]:=RADEK[K+J*3+7];
  PROM[ADR]:=CHR(VAL(HEXA,16));
  IF VALERR OR (HEXA[1]=' ') THEN
   WRITELN(CHR(13),'Spatny kod na adrese ',PREVOD(ADR,16,TRUE),':',HEXA);
  ADR:=ADR+1;
  END;
 END;

BEGIN
REPEAT
FOR I:=4 TO 7 DO HEXA[I]:=' ';
 REPEAT
  PRECTIRADEK;
  FOR I:=0 TO 3 DO HEXA[I]:=RADEK[I];
  ADR:=VAL(HEXA,16);
 UNTIL (NOT(VALERR) AND (RADEK[0]<>' ')) OR EOF(INF);
FOR I:=0 TO 7 DO HEXA[I]:=' ';
IF NOT(EOF(INF)) THEN DEKODUJRADEK;
UNTIL EOF(INF);
END;

PROCEDURE KONVERZE;
VAR M:INTEGER;
BEGIN
RESET(INF,JMENO,EXTINP,LEN);
IF (LEN<1) THEN
 WRITELN('Nenalezen vstupni soubor             : ',PJMEN,EXTINP)
ELSE
 BEGIN
 M:=LEN DIV 3;
 REWRITE(OUF,JMENO,EXTOUT,M);
 IF (M<1) THEN
  WRITELN('Neni misto vystupni soubor           : ',PJMEN,EXTOUT)
 ELSE
  BEGIN
  FOR M:=0 TO ADRMEZ DO PROM[M]:=CHR(0);
  ADR:=0;
  PRECTIPOUKY;
  FOR M:=0 TO ADRMEZ DO
   BEGIN
   OUF^:=PROM[M];
   PUT(OUF);
   END;
  CLOSE(OUF);
  END;
 CLOSE(INF);
 END;
END;
{----------------------------------------------------------------------------}
BEGIN
WRITELN('Prevod DUMP souboru do binarni formy');
WRITELN('====================================');
WRITE('Jmeno souboru fontu [',DEFNME,'.',EXTINP,'] : ');
READLN(JMENO);IF JMENO='          ' THEN JMENO:=DEFNME;
FOR LEN:=0 TO 8 DO
 IF (JMENO[LEN]=':') AND (JMENO[LEN+1]=' ') THEN JMENO:=DEFNME;
WRITELN;
WRITELN('Je pouzit vstupni soubor             : ',PJMEN,EXTINP);
WRITELN('Generuje se vystupni soubor          : ',PJMEN,EXTOUT);
WRITELN;
KONVERZE;
WRITELN;
WRITELN(CHR(10),'Konec prace. (C) 1991, LZR Soft, POLDI Kladno');
END.
{----------------------------------------------------------------------------}