⟦4d0ca2077⟧

TextFile


(* Type definitions, functions and procedures for processing of RcFont
   generated character sets.  JZ NOVEMBER 1985 *)

(*$R-*)

TYPE

 FILENAME    = STRINGÆ14Å;

 FONT_IO_TYPE= (FONT_INPUT, FONT_OUTPUT);

 CHARSET     = RECORD
                fontfile     : FILE;
                operation    : FONT_IO_TYPE;
                headr, headc : BYTE;
                buffer       : ARRAYÆ1..128Å OF BYTE;
                index        : 1..128;
                count        : INTEGER;
                checksum     : INTEGER;
               END;

 FONTRECORD  = RECORD
                rows, cols   : BYTE;
                character    : CHAR;
                charfont     : ARRAYÆ1..16Å OF INTEGER;
               END;

 ALPHANO     = 1..4;

 PRINTERTYPE = (RC603, RC604, RC605);

 STR255      = STRINGÆ255Å;
 STR8        = STRINGÆ8Å;

 FONTQUEUE   =
   RECORD
    dummy1   : INTEGER;
    queueid  : INTEGER;
    dummy2   : INTEGER;
    buf_ptr  : INTEGER;
    name     : STR8;
    buffer   : STR255;
   END;
 
VAR
 fqresult: INTEGER;
 fqrecord: FONTQUEUE; 
   
FUNCTION open_charset(VAR filedescr: CHARSET;
                          name     : FILENAME;
                          io_type  : FONT_IO_TYPE): BOOLEAN;
 VAR
  c_count: INTEGER;
 BEGIN (* opens and prepare a font file for input *)
  open_charset := true;
  WITH filedescr DO
   BEGIN
    count := 0;
    assign(fontfile, name);
    operation := io_type;
    (*$I-*) reset(fontfile) (*$I+*);
    IF operation = FONT_OUTPUT THEN
     BEGIN (* font output *)
      IF iores > 0 THEN
       rewrite(fontfile);
      bufferÆ1Å := 255;
      bufferÆ2Å := 255;
      index := 3;
     END 
    ELSE
     BEGIN (* font input *) 
      blockread(fontfile, buffer, 1,c_count);
      IF c_count<> 1 THEN
       open_charset := FALSE;
      headr := bufferÆ1Å;
      headc := bufferÆ2Å;
      index := 2;
      IF NOT (    ((headr=255) AND (headc=255))
              OR  ((headr>  0) AND (headr<=16)
              AND  (headc>  0) AND (headc<=16))
             ) THEN
       BEGIN (* format error *)
        close(fontfile);
        open_charset := false;
       END;
     END;
   END;
 END; (* open_charset *)


PROCEDURE close_charset(VAR filedescr: CHARSET);
 VAR
  c_count: INTEGER;
 BEGIN
  WITH filedescr DO
   BEGIN
    IF operation = FONT_OUTPUT THEN
     BEGIN
      bufferÆindexÅ := 0;
      blockwrite(fontfile, buffer, 1, c_count);
     END;
    close(fontfile);
   END;
 END; (* close_charset *)


FUNCTION read_font(VAR filedescr: CHARSET; VAR fontrec: FONTRECORD): BYTE;
 VAR
  i, b       : BYTE;
  sum, sum1  : INTEGER;
 FUNCTION read_byte: BYTE;
  VAR
   c_count: INTEGER;
   b      : BYTE;
  BEGIN (* get next byte from fontfile *)
   WITH filedescr DO
    BEGIN
     IF index = 128 THEN
      BEGIN (* buffer empty *)
       blockread(fontfile, buffer, 1,c_count);
       index := 1;
      END
     ELSE index := index + 1;
     b := bufferÆindexÅ;
     read_byte := b;      
     checksum := checksum + b;
    END;
  END; (*read_byte *)
BEGIN (* get next character font from fontfile *)
 read_font := 0; (* a priori ok result *)
 WITH filedescr DO
  WITH fontrec DO
   BEGIN
    checksum := 0;
    IF headr = 255 THEN
     BEGIN (* new format *)
      rows := read_byte;
      cols := read_byte;
     END ELSE
     BEGIN (* old format *)
      rows := headr;
      cols := headc;
     END;
    character := CHAR(read_byte);
    IF ( (character <> CHAR(0)) OR (count=0)) AND (rows <> 0) THEN
     BEGIN (* move the font to parameter *)
      FOR i := 1 TO rows DO
       BEGIN
        IF cols > 8 THEN
         BEGIN (* broad format *)
          sum := read_byte;
          charfontÆiÅ := swap(read_byte) OR sum;
         END
        ELSE  charfontÆiÅ := swap(read_byte); (* high byte *)
       END;
      FOR i := rows + 1 TO 16 DO
       charfontÆiÅ := 0;
      count := count + 1;
      IF headr = 255 THEN
       BEGIN (* only checksum in new format *)
        sum  := checksum;
        b    := read_byte;
        sum1 := swap(read_byte) + b;
        IF (sum + sum1) <> 0 THEN
         read_font := 2; (* checksum error *)
       END; (* checksum *)
     END ELSE read_font := 1; (* end of fontfile *)
   END; (* WITH *)
 END; (* read_font *)

PROCEDURE write_font(VAR filedescr: CHARSET; VAR fontrec: FONTRECORD);
 VAR
  fontrow, mask, sum: INTEGER;
  i                 : BYTE;
 PROCEDURE write_byte(b: BYTE);
  VAR
   c_count: INTEGER;
  BEGIN (* put next byte into fontfile *)
   WITH filedescr DO
    BEGIN
     bufferÆindexÅ := b;
     checksum := checksum + b;
     IF index = 128 THEN
      BEGIN (* buffer full *)
       blockwrite(fontfile, buffer, 1,c_count);
       index := 1;
      END ELSE index := index + 1;

    END;
  END; (* write byte *)
BEGIN (* put next character font into fontfile *)
 WITH filedescr DO
  WITH fontrec DO
   BEGIN
    checksum := 0;
    write_byte(rows);
    write_byte(cols);
    write_byte(ORD(character));
    mask := $FFFF shl (16-cols);
    FOR i := 1 TO rows DO
     BEGIN
      fontrow := charfontÆiÅ AND mask;
      IF cols <= 8 THEN (* small format *)
       write_byte(hi(fontrow))
      ELSE (* broad format *)
       BEGIN
        write_byte(lo(fontrow));
        write_byte(hi(fontrow));
       END;  
     END;
    sum := -checksum;
    write_byte(lo(sum));
    write_byte(hi(sum));
   END; (* WITH *)
 END; (* write_font *)


PROCEDURE define_screen_font(destination: ALPHANO; VAR fontrec: FONTRECORD);
 CONST
  xios        = $28;
  define_font = 52 ;
 VAR
  reg: RECORD ax,bx,cx,dx,bp,si,di,ds,es,flags: INTEGER; END;
  i, mask, ones : INTEGER;
 BEGIN
  WITH fontrec DO
   BEGIN (* define the font in proper alphabet *)
    mask := $FFFF shl (16-cols);
    ones := (NOT mask) shr 1;
    FOR i := 1 TO rows DO
     charfontÆiÅ := charfontÆiÅ AND mask OR ones;
    reg.ax := define_font; (* xios function no *)
    reg.cx := (destination-1)*256 + ORD(character);
    reg.dx := ofs (charfontÆ1Å);
    reg.ds := seg(charfontÆ1Å);
    swint(xios, reg); (* call xios extra function: define_font *)
   END
 END; (* define_screen_font *)


PROCEDURE get_screen_font(source: ALPHANO; VAR fontrec: FONTRECORD);
 CONST
  xios        = $28;
  get_font    = 51 ;
  get_conf    =  4 ;
 VAR
  reg: RECORD ax,bx,cx,dx,bp,si,di,ds,es,flags: INTEGER; END;
  i, mask, ones : INTEGER;
  monitor_type  : ^BYTE;
 BEGIN
  WITH fontrec DO
   BEGIN (* get the font from proper alphabet *)
    reg.ax := get_conf;
    swint(xios, reg); (* get configuration vector *)
    monitor_type := PTR(reg.es, reg.si + 18);
    IF (monitor_type^ AND 2) = 0 
     THEN rows := 10 ELSE rows := 14;
    reg.ax := get_font; (* xios function no *)
    reg.cx := (source-1)*256 + ORD(character);
    reg.dx := ofs (charfontÆ1Å);
    reg.ds := seg(charfontÆ1Å);
    swint(xios, reg); (* call xios extra function: get_font *)
    ones := charfontÆ1Å;
    cols := 15;
    WHILE (cols > 0) AND ODD(ones) DO
     BEGIN
      cols := cols - 1;
      ones := ones shr 1;
     END; 
    mask := $FFFF shl (16-cols);
    FOR i := 1 TO rows DO
     charfontÆiÅ := charfontÆiÅ AND mask;
   END
 END; (* define_screen_font *)


FUNCTION open_printer_charset(printer: PRINTERTYPE): BOOLEAN;

 VAR
  reg: RECORD ax,bx,cx,dx,bp,si,di,ds,es,flags: INTEGER; END;

 FUNCTION lcattach: BOOLEAN;
  CONST
   ccpm        = 224;
   l_cattach   = 161;
  BEGIN
   reg.cx := l_cattach;
   swint(ccpm, reg);
   lcattach := reg.ax=0;
  END; (* lcattach *)
    
 PROCEDURE open_603;
  CONST
   ccpm        = 224;
   s_sysdat    = 154;
   p_delay     = 141;
   ticks_off   = $51;
  VAR
   ticks_ptr : ^BYTE;
  BEGIN (* Only usefull for RC603/604 printers *)
   write(lst, @27, @63, '1600'); (* reserve cg buffer in RC603/604 *)
   reg.cx := s_sysdat;
   swint(ccpm, reg); (* get sysdat segment *)
   ticks_ptr := PTR(reg.es, ticks_off);
   reg.dx := ticks_ptr^;
   reg.cx := p_delay;
   swint(ccpm, reg); (* delay process one second *)
   write(lst, @27, @117); (* cg copy *)
  END; (* open_RC603 *)

 PROCEDURE open_605;
  BEGIN (* only usefull for RC605 printer *)
   write(lst, @27, '$');
  END;
  
 BEGIN
  IF lcattach THEN
   BEGIN
    open_printer_charset := TRUE;
    CASE printer OF
     RC603, RC604: open_603;
     RC605:        open_605;
    OTHERWISE open_printer_charset := FALSE;
    END (* case printer *)
   END ELSE open_printer_charset := FALSE;
  END; (* open_printer_charset *) 
     
PROCEDURE close_printer_charset(printer: PRINTERTYPE);
 CONST
  ccpm        = 224;
  l_detach    = 159;
 VAR
  reg : RECORD ax,bx,cx,dx,bp,si,di,ds,es,flags: INTEGER; END;
 BEGIN
  CASE printer OF (* enable soft character set *)
   RC603, RC604: write(lst, @27, @39); 
   RC605:        write(lst, @27, '2');
  END;
  reg.cx := l_detach;
  swint(ccpm, reg);
  close(lst);
 END; (* close_printer_charset *) 


PROCEDURE define_printer_font(printer: PRINTERTYPE; VAR fontrec: FONTRECORD);
 VAR
  first_row, chrlength: BYTE;
  descent: BOOLEAN;
  
 PROCEDURE send_printer_font(first, n_cols: BYTE);
  VAR
   i, j, chr: BYTE;
  BEGIN
   WITH fontrec DO
    BEGIN
     FOR j := 0 TO n_cols-1 DO 
      BEGIN 
       chr := 0;
       FOR i := first+7 DOWNTO first DO
        BEGIN
         chr := chr shl 1;
         IF (charfontÆiÅ shl j) < 0 THEN
          chr := chr + 1;
        END;
       write(lst, CHAR(chr));
      END;
    END (* width fontrec *)
  END; (* send_printer_font *)
  
  BEGIN 
   WITH fontrec DO
    BEGIN
     descent := (rows = 9) AND (charfontÆ9Å AND ($FFFF shl (16-cols)) <> 0); 
     CASE printer OF
  
      RC603, RC604:
       IF (character >= CHAR(32)) AND (character <=CHAR(126)) THEN
        BEGIN
         IF descent THEN 
          BEGIN chrlength := cols + 32; first_row := 2; END
         ELSE
          BEGIN chrlength := cols; first_row := 1; END;
         write(lst, @27, '+', character, CHAR(chrlength));     
         send_printer_font(first_row, cols);
         write(lst, CHAR(4)); (* write EOT *)
        END; (* RC603 and RC604 *)
  
      RC605:
       IF (character >= CHAR(32)) AND (character <= CHAR(127))
       OR (character >=CHAR(160)) AND (character <= CHAR(223)) THEN
        BEGIN
         IF descent THEN
          BEGIN write(lst, @27, '%D', character); first_row := 3; END
         ELSE
          BEGIN write(lst, @27, '%A', character); first_row := 1; END;
         send_printer_font(first_row, 11);
        END (* RC605 *)  
     
     END (* case *)
    END (* WIDTH fontrec *)    
  END; (* define_printer_font *)
 
PROCEDURE open_queue(VAR fq: FONTQUEUE; queuename: STR8); 
 CONST
  q_open     = 135;
  q_write    = 139;
  ccpm       = 224;
 VAR 
  reg: RECORD ax,bx,cx,dx,bp,si,di,ds,es,flags: INTEGER; END;       
  i  : INTEGER;
 BEGIN (* open the queue: FONTWAIT *)
  WITH fq DO
   BEGIN
    dummy1 := 0;
    queueid:= 0;
    dummy2 := 0;
    buf_ptr:= ofs(buffer);
    FOR i:=0 TO 7 DO
     nameÆiÅ := queuenameÆi+1Å;
    reg.dx := ofs(fq);
    reg.ds := seg(fq);
    reg.cx := q_open;
    swint(ccpm, reg);
   END;
  IF reg.ax = 0 THEN fqresult := 0
  ELSE fqresult := reg.cx;
 END; 
 
PROCEDURE writequeue(VAR fq: FONTQUEUE; func: INTEGER; str: STR255);
CONST
 q_write  = 139;
 q_cwrite = 140;
 ccpm     = 224;
VAR
 reg: RECORD ax,bx,cx,dx,bp,si,di,ds,es,flags: INTEGER; END;       
BEGIN
 reg.dx := ofs(fq);
 reg.ds := seg(fq);
 IF func = 0 THEN reg.cx := q_write
             ELSE reg.cx := q_cwrite;
 fq.buffer := str;
 swint(ccpm, reg);
 IF (reg.ax = 0) OR (func <> 0) THEN fqresult := 0
 ELSE fqresult := reg.cx; 
END; 
  
PROCEDURE open_font_graphics;
BEGIN
 open_queue(fqrecord, 'FONTWAIT');
END;



PROCEDURE writefg(str: STR255);
CONST
 l_attach = 158;
 l_detach = 159;
 ccpm     = 224;
VAR
 reg: RECORD ax,bx,cx,dx,bp,si,di,ds,es,flags: INTEGER; END;       
BEGIN (* write message to fontqueue *)
 reg.cx:=l_detach;
 swint(ccpm, reg); (* detach printer *)
 writequeue(fqrecord, 0, str);
END; 

PROCEDURE stop_font_graphics;
VAR
 fs: FONTQUEUE;
BEGIN (* stop fontgraphics fileprint *)
 open_queue(fs, 'FONTSTOP');
 writequeue(fs, 1, 'S');
END; 
«eof»
DataMuseum.dk

CP/M

⟦4d0ca2077⟧ TextFile

Derivation

TextFile
