TEXTFONT.PAS

{
  Lea's alte Pascal-Unit, um den Zeichensatz im Textmode zu ändern. Es hat auch Funktionen um die Rasterfont 
  im BIOS auszulesen :)
}


Unit Textfont;

INTERFACE
 const          punkte:byte=16; {Zeichenhîhe}
                abstand:byte=1; {Zeichen-Abstand (nur Graphikmodus)}
                paper:word=256; {Hintergrundfarbe        -"-
                                 256=Hgrund lassen}
                o14:word=0;   {offset 8x14-font}
                o16:word=0;   {offset 8x16-font}
                xmax:word=0;  {grafik-x-auflîsung}
                txmax:byte=0;{text-x-auflîsung}
                ymax:word=0;  {grafik-y-auflîsung}
                tymax:byte=0; {text-y-auflîsung}
                aktmod:byte=0;{aktueller modus}

 var            fontbuf:array[1..$2000] of byte;
                videobank:byte;

 procedure Scanline(b:byte);               {Scanline : 0=200;1=350;2=400}
 procedure setmode(b:byte);                {Videomodus wÑhlen}
 procedure Schrift8;                       {8x8-Schrift laden}
 procedure Schrift14;                      {8x14-Schrift laden}
 procedure Schrift16;                      {8x16-Schrift laden}
 procedure LoadFont(s:string);             {Gespeicherte Schrift-Datei laden}
 procedure SaveFont(s:string);             {Schrift speichern}


 procedure Schrift;                        {Schift benutzen}

 procedure Symbol(nr,anz,segm,offs:word);   {weiter ausgearbeitete Version
                                             von PROCEDURE SCHRIFT         }

 procedure GetInt1fh(var segm,offs:word);   {Interruptvektor $1f ermitteln}

 procedure putpix(x,y:word;col:byte);       {PutPixel
                                             (lÑuft am besten in Modus $13)}

 procedure getmodusdata;                    {aktualisiert modusdaten}

 procedure gtext(t:string;x,y:word;f:byte); {Text mit akt. Schrift ausgeben.}



IMPLEMENTATION

uses dos;

procedure GetInt1fh(var segm,offs:word);
begin
 offs:=word(mem[0:$7c]+(mem[0:$7d]*256));
 segm:=word(mem[0:$7e]+(mem[0:$7f]*256));
end;

procedure Schrift;
 var r:registers;
begin
 r.es:=seg(fontbuf);
 r.bp:=ofs(fontbuf);
 r.ax:=$1110;
 r.bl:=0;
 r.bh:=punkte;
 r.cx:=$100; r.dx:=0;
 intr($10,r);
end;

procedure Symbol(nr,anz,segm,offs:word);
{ segm,offs = Segment-/Offsetadresse der Zeichentabelle }
 var r:registers;
begin
 r.es:=segm;
 r.bp:=offs;
 r.ax:=$1110;
 r.bl:=0;
 r.bh:=punkte;
 r.cx:=anz;
 r.dx:=nr;
 intr($10,r);
end;

procedure Scanline(b:byte); assembler;
asm
 mov ah,$12
 mov al,b
 mov bx,$30
 int $10
end;

procedure getmodusdata;
begin
 asm
  push ax
  push bx
  push cx
  push dx
  push es
  push bp
  mov ax,$1130
  xor bx,bx
  xor cx,cx
  xor dx,dx
  int $10;
  mov punkte,cl
  mov tymax,dl
  inc tymax

  mov ah,15
  int $10
  mov aktmod,al
  mov txmax,ah


  pop bp
  pop es
  pop dx
  pop cx
  pop bx
  pop ax
 end;
 xmax:=word(txmax*8);
 ymax:=word(tymax*punkte);
end;

procedure setmode(b:byte);
 var tx:byte;
begin
 asm
  mov ah,0
  mov al,b
  int $10
 end;
 getmodusdata;
end;

procedure LoadFont(s:string);
 var f:text; f1:file of byte;
     c:char; size,i:word;
begin
 assign(f1,s);
 reset(f1);
 size:=filesize(f1);
 close(f1);
 punkte:=size div 256;
 assign(f,s);
 reset(f);
 for i:=1 to size do
 begin
  read(f,c);
  fontbuf[i]:=ord(c);
 end;
 close(f);
end;

procedure SaveFont(s:string);
 var f:text;
     size,i:word;
begin
 size:=$100*punkte;
 assign(f,s);
 rewrite(f);
 for i:=1 to size do
  write(f,chr(fontbuf[i]));
 close(f);
end;


procedure Schrift8;
var r:registers; segm,offs,i:word;
begin
 getint1fh(segm,offs);
 punkte:=8; offs:=offs-$400;
 for i:=1 to $800 do fontbuf[i]:=mem[segm:offs+i-1];
end;

procedure Schrift14;
var r:registers; segm,offs,i:word;
begin
 getint1fh(segm,offs);
 dec(offs,$400);
 offs:=offs+o14;
 punkte:=14;
 for i:=1 to $e00 do fontbuf[i]:=mem[segm:offs+i-1];
end;

procedure Schrift16;
var r:registers; segm,offs,i:word;
begin
 getint1fh(segm,offs);
 dec(offs,$400);
 offs:=offs+o16;
 punkte:=16;
 for i:=1 to $1000 do fontbuf[i]:=mem[segm:offs+i-1];
end;

procedure putpix(x,y:word;col:byte);
var l:longint;
begin
   if xmax=0 then getmodusdata;
   if not((x<0)or(y<0)or(x>=xmax)) then
   begin
     l:=longint(xmax)*longint(y)+longint(x);
     if aktmod<>$13 then
     begin
       asm
        mov ah,$0C;
        mov al,col;
        mov bh,0;
        mov cx,x;
        mov dx,y;
        int $10;
       end;
     end else
       mem[$A000:word(l)]:=Col;
   end;
end;


procedure gtext(t:string;x,y:word;f:byte);
 var xx,yy,zz,x1,y1,w:longint;
     chseg,chofs,xw,yw:word;
begin
 y1:=0; x1:=0;
 for zz:=0 to length(t)-1 do
 begin
  if t[zz+1]=#13 then begin x1:=0; inc(y1,punkte); end else
  begin
   for yy:=0 to punkte-1 do
   begin
    w:=fontbuf[1+ord(t[zz+1])*punkte+yy];
    for xx:=0 to 7 do if (w and (128 shr xx))>0 then
    begin
      putpix(x+xx+x1,y+yy+y1,f);
    end else
    begin
     if paper<256 then putpix(x+xx+x1,y+yy+y1,paper);
    end;
   end;
   x1:=x1+8+abstand;
  end;
 end;
end;



function suche:word;
{Sucht nach den 3 SchriftsÑtzen,
bei 8x14 und 8x16 gehts nicht immer (bei Tridentkarten schon...)}
 var segm,offs,o1,i:word;
     gefunden:boolean;
begin
 GetInt1fh(segm,offs);
 dec(offs,$400);
 o1:=0; gefunden:=false;
 repeat
  for i:=o1 to o1+punkte-1 do
   if mem[segm:offs+i]<>$ff then break;
  if i=o1+punkte-1 then
  begin
   o1:=o1-219*punkte;
   for i:=o1 to o1+punkte-1 do
    if mem[segm:offs+i]<>$00 then break;
   if i=o1+punkte-1 then
   gefunden:=true else o1:=o1+219*punkte;
  end;
  if not(gefunden) then inc(o1);
 until gefunden;
  suche:=o1;
end;


begin
 punkte:=14; o14:=suche;
 punkte:=16; o16:=suche;
 getmodusdata;
end.