bmfont.inc

bmf汉字预览显示

{$IFNDEF bmfont}
{$DEFINE bmfont}
{$I OBJECT.INC}
{$I SYST.INC}
{$I BMCHAR.INC}
{$I OPENGFX.INC}
{$IFDEF loadbmfwithpal}
 {$I PALS.INC}
{$ENDIF}
const
  BMFMAGIC:dword=$1AD5E6E1;
  BMFHEADERSIZE=16;
type
  PBMFont=^TBMFont;
  TBMFont=object
  private
    tablo:array[char] of TBMChar;
    addspace:byte;
    lineheight,sizeover,sizeunder,sizeinner:longint;
    curx,cury:TCoordinate;
    dest:PBuf2d;
    delay:longint;
    name:string;
  public
    Constructor init0;
    Function  load(var f:TStream):boolean;
    Function  loadAsFN(var f:TStream):boolean;
    Procedure setup(_dest:PBuf2d; _method,_delay:longint);
    Procedure writechar(c:char; breakable:boolean);
    Procedure write(s:string);
    Procedure writexy(_curx,_cury:TCoordinate; s:string);
    Procedure newrow(n:longint);
    Procedure newline;
    Function  textwidth(s:string; space:boolean):longint;
    Procedure gotoxy(_curx,_cury:TCoordinate);
    Function  colorsUsed:dword; {loword=count, hiword=max}
    Function  charsUsed:word;
    Procedure free;
    Destructor done;
    {$IFDEF bmfchange}
    Function  save(var f:TStream):boolean;
    {$ENDIF}
  end;  {TBMFont}

Constructor TBMFont.init0;
var c:char;
begin
  for c:=#0 to #255 do tablo[c].init0;
  addspace:=0;
  lineheight:=0;
  sizeover:=0;
  sizeunder:=0;
  sizeinner:=0;
  gotoxy(0,0);
  dest:=nil;
  delay:=0;
end;  {TBMFont.init0}

Procedure TBMFont.setup(_dest:PBuf2d;_method,_delay:longint);
var c:char;
begin
  for c:=#255 downto #0 do begin
    if @tablo[c]=nil then tablo[c].init0;
    tablo[c].method:=_method;
  end;
  dest:=_dest;
  delay:=_delay;
end;  {TBMFont.setup}

Procedure TBMFont.writexy(_curx,_cury:TCoordinate; s:string);
var i:longint;
begin
  curx:=_curx;
  cury:=_cury;
  for i:=1 to length(s) do
    with tablo[s[i]] do begin
      pasteMeTo(dest,curx+relx,cury+rely);
      inc(curx,shift+addspace);
    end;
end;  {TBMFont.writexy}

Procedure TBMFont.writechar(c:char; breakable:boolean); {not for c=CR,LF}
const writecharacc:dword=0;
begin
  with tablo[c] do begin
    if breakable and (curx+relx+w>dest^.w) then begin
      newrow(1);
      flip;
    end;
    pasteMeTo(dest,curx+relx,cury+rely);
    inc(curx,shift+addspace);
    if delay>0 then begin
      if d<>nil then dest^.pasteMeTo(@screen,dest^.x,dest^.y);
      if (mem[ROM_KEYFLAGS] and kfSCROLLLOCK<>0) and (writecharacc mod delay=0) then waitticks(1);
      inc(writecharacc);
    end;
  end;
end;  {TBMFont.writechar}

Procedure TBMFont.write(s:string);
var i,rigid,reach:longint; {i=index, rigid=non-breakable chars#, reach=length}
begin {TBMFont.write}
  if dest=nil then exit;
  i:=1;
  while i<=length(s) do begin
    {get the following word (its width and reach)}
    rigid:=0; reach:=curx;
    while (i+rigid<=length(s)) and not(s[i+rigid] in WORDBREAKERS) do with tablo[s[i+rigid]] do begin
      inc(reach,shift+addspace);
      inc(rigid);
    end;
    {some characters following the word are allowed to be "rigid"}
    if (i+rigid<=length(s)) and (s[i+rigid] in ['.',',',':',';','-','!','?',')',']','%']) then with tablo[s[i+rigid]] do begin
      inc(reach,shift+addspace);
      inc(rigid);
    end;
    {a case when the word exceedes the row width..}
    if reach>dest^.w then {if breaking the line helps, breaks the line}
      if reach-curx<=dest^.w then begin
        newline;
        if rigid>0 then continue;
      end else rigid:=0; {..otherwise makes the extra-long word "non-rigid" (breakable)}
    {draws "rigid" chars (chars appropriating to the word)}
    while rigid>0 do begin
      writechar(s[i],false);
      inc(i);
      dec(rigid);
    end;
    {provides casual after-word space not to break to the next line}
    if (i<=length(s)) and (s[i]=' ') then begin
      inc(curx,tablo[' '].shift+addspace);
      inc(i);
    end;
    {draws all other chars (that don't constitute words)}
    while (i<=length(s)) and (s[i] in WORDBREAKERS) do begin
      if s[i]=CR then begin
        curx:=dest^.w+1;
        inc(i);
        if i>length(s) then break;
      end;
      if s[i]=LF then begin
        newline;
        inc(i);
        if i>length(s) then break;
      end;
      writechar(s[i],true);
      inc(i);
    end;
  end;
end;  {TBMFont.write}

Procedure TBMFont.newline;
begin
  curx:=0;
  newrow(1);
  if dest<>nil then dest^.flashline;
end;  {TBMFont.newline}

Procedure TBMFont.newrow(n:longint);
begin
  if dest=nil then exit;
  if dest^.empty then exit;
  curx:=0;
  for n:=n downto 1 do begin
    inc(cury,lineheight);
    if cury+lineheight>dest^.h then begin
      if lineheight<dest^.h
      then dest^.shiftV(dest^.h-cury-lineheight)
      else dest^.shiftV(-lineheight);
      cury:=dest^.h-lineheight;
    end;
  end;
end;  {TBMFont.newrow}

Function  TBMFont.textwidth(s:string; space:boolean):longint;
var i:longint;
begin
  result:=0;
  i:=length(s);
  if not space then
    while (i>0) and (s[i]=' ') do dec(i);
  for i:=i downto 1 do
    inc(result,tablo[s[i]].shift+addspace);
end;  {TBMFont.textwidth}

Procedure TBMFont.gotoxy(_curx,_cury:TCoordinate);
begin
  curx:=_curx;
  cury:=_cury;
end;  {TBMFont.gotoxy}

Function  TBMFont.colorsUsed:dword;
var
  c:char;
  buf:array[byte] of byte;
  i:dword;
begin
  result:=0;
  fillchar(buf,sizeof(buf),0);
  for c:=#0 to #255 do
    tablo[c].countcolors(buf);
  for i:=0 to 255 do
    if buf[i]<>0 then begin
      inc(memw[ofs(result)]);
      if i>hiword(result) then mem[ofs(result)+2]:=word(i);
    end;
end;  {TBMFont.colorsused}

Function  TBMFont.charsUsed:word;
var c:char;
begin
  result:=0;
  for c:=#0 to #255 do
    if not tablo[c].empty then
      inc(result);
end;  {TBMFont.charsUsed}

Function  TBMFont.load(var f:TStream):boolean;
var
  c:char;
  buf:array[0..BMFHEADERSIZE-1] of byte;
  buf0d:dword absolute buf;
begin
  result:=false;
  for c:=#0 to #255 do tablo[c].init0;
  dest:=nil;
  addspace:=0;
  curx:=0; cury:=0;
  delay:=0;
  if @f=nil then exit;
  lineheight:=0;
  f.read(buf,BMFHEADERSIZE);
  if buf0d<>BMFMAGIC then begin
    f.seek(f.position-BMFHEADERSIZE);
    c:=' ';
    repeat
      with tablo[c] do begin
        if not load(f) then break;
        if d<>nil then if rely+height>lineheight then lineheight:=rely+height;
      end;
      inc(c);
    until not f.ok;
    name:='';
    result:=f.ok;
  end
  else begin
    lineheight:=buf[5];
    sizeover:=shortint(buf[6]);
    sizeunder:=shortint(buf[7]);
    addspace:=buf[8];
    sizeinner:=shortint(buf[9]);
    f.read(buf[4],1);
    buf[3]:=1;
    while buf[3]<=buf[4] do begin
      f.read(buf,3);
{$IFDEF loadbmfwithpal}
      if buf[3]<240 then setRGB(buf[3],buf[0],buf[1],buf[2]);
{$ENDIF}
      inc(buf[3]);
    end;
    f.read(name[0],1);
    f.read(name[1],ord(name[0]));
    buf0d:=0; f.read(buf,2);
    while (f.ok) and (buf0d>0) do begin
      dec(buf0d);
      f.read(c,1);
      result:=tablo[c].load(f) and result;
    end;
    result:=f.ok;
  end;
end;  {TBMFont.load}

Function  TBMFont.loadAsFN(var f:TStream):boolean;
var
  i,j,pos0,pos1:longint;
  buf:array[0..8] of byte;
  bufstr:string[7] absolute buf;
begin
  result:=false;
  for pos0:=0 to 255 do tablo[char(pos0)].init0;
  pos0:=f.position;
  if not f.read(buf[1],7) then exit;
  dest:=nil;
  buf[0]:=7;
  if bufstr<>#$EB#$6D#$D5#$6F#$6E#$E7#$20 then exit;
  name:='';
  repeat
    f.read(buf,1);
    if buf[0]=0 then break;
    name:=concat(name,chr(buf[0]));
  until false;
  f.read(buf,6);
  sizeover:=buf[2];
  sizeunder:=buf[3];
  addspace:=buf[4];
  if buf[0]<buf[1] then
  repeat
    f.read(buf[2],7);
    with tablo[char(buf[0])] do begin
      init(buf[4],buf[5]);
      relx:=buf[2];
      rely:=buf[3];
      shift:=buf[6];
      if (w<>0) and (h<>0) then begin
        pos1:=f.position;
        f.seek(pos0+buf[8] shl 8+buf[7]);
        for j:=0 to pred(h) do
          for i:=0 to pred(w) do begin
            if i and 7=0 then f.read(buf[2],1);
            if buf[2] and ($80 shr (i and 7))<>0 then
              setpoint(i,j,31);
          end;
        f.seek(pos1);
      end;
    end;
    if buf[0]=buf[1] then begin
      result:=true;
      break;
    end;
    inc(buf[0]);
  until false;
end;  {TBMFont.loadAsFN}

{$IFDEF bmfchange}
Procedure BMFont_save_palette(var f:TStream); forward;
Function  TBMFont.save(var f:TStream):boolean;
var
  c:char;
  colors:dword;
  buf:array[0..BMFHEADERSIZE-1] of byte;
  buf0w:word absolute buf;
  buf0d:dword absolute buf;
begin
  if @f=nil then exit;
  buf0d:=BMFMAGIC;
  buf[4]:=$11;
  buf[5]:=lineheight;
  buf[6]:=sizeover;
  buf[7]:=sizeunder;
  buf[8]:=addspace;
  buf[9]:=sizeinner;
  colors:=colorsUsed;
  buf[10]:=byte(colors);
  buf[11]:=byte(colors shr 16);
  f.write(buf,BMFHEADERSIZE);
  if @BMFont_save_palette<>nil then BMFont_save_palette(f);
  f.write(name[0],1); f.write(name[1],ord(name[0]));
  buf0w:=charsUsed; f.write(buf0w,2);
  for c:=#0 to #255 do
    if not tablo[c].empty then begin
      f.write(c,1);
      tablo[c].save(f);
    end;
  result:=f.ok;
end;  {TBMFont.save}
{$ENDIF}

Procedure TBMFont.free;
var c:char;
begin
  for c:=#0 to #255 do
    tablo[c].free;
end;  {TBMFont.free}

Destructor TBMFont.done;
begin
  free;
end;  {TBMFont.done}
{$ENDIF}