unit _FontPack;

interface

uses
  Windows, SysUtils, Classes, Graphics, QDArc,_PicTools, _filebuf;

var
  Histgram:array[0..$ff] of int64;

type
  TFontData=record
    Enabled:boolean;
    EncMaxPacketSize:byte;
    EncSize:word;
    EncData:array of byte;
    Decorded:boolean;
    DecSize:word;
    DecData:array of byte;
  end;

  TFontSet=record
    ANK_Alpha,ANK_Kana:boolean;
    SJIS_noKanji,SJIS_KanjiLv1,SJIS_AlabiaNum:boolean;
    SJIS_KanjiLv2,SJIS_KanjiEtc:boolean;
    X68kPlus:boolean;
  end;

  TEncordCallback=procedure(pos,max:integer) of object;

  TFontPackDrawMode=record
    TextColor:TRGBPack;
    Transparent:boolean;
    BGColor:TRGBPack;
  end;

type
  TFontPack=class
    FontAdded:boolean;
    FontHeight,FontWidth:byte; // FontWidthΝLoad&SaveΕ³³κά·B
    FontName:string;
    FontSet:TFontSet;
    EnabledAntialias:boolean;
    EncordCallback:TEncordCallback;
    WinFontBM:TBitmap;
    GrayScale:array[0..3] of byte;
    Data:array[$0000..$ffff] of TFontData;
    DrawMode:TFontPackDrawMode;
  public
    constructor Create;
    destructor Destroy; override;
    procedure MakeDecord(const CharCode:word);
    procedure MakeDecordX68kPlus(const CharCode:word);
    function  AutoParamEncord(const CharCode:word):boolean;
    procedure Encord(const CharCode:word);
    procedure Decord(const CharCode:word);
    procedure DrawDecord(const bm:TBitmap;const x,y:integer;const CharCode:word;const isHighLight,isPerticalLine,isUnderLine:boolean);
    procedure DrawDecordStr(const bm:TBitmap;const x,y:integer;const msg:string;const isHighLight,isPerticalLine,isUnderLine:boolean);
    procedure SaveToFile(const Filename:string);
    procedure LoadFromRFB(var rfb:TReadFileBuf);
    procedure LoadFromFile(const Filename:string);
    procedure LoadFromResource(const ResourceName:string);
    function  FullAutoEncord:boolean;
  end;

type
  PFontPack=^TFontPack;

implementation

uses _m_Tools;

constructor TFontPack.Create;
var
  cnt:integer;
begin
  FontAdded:=False;
  FontHeight:=0;
  FontWidth:=0;
  FontName:='';
  with FontSet do begin
    ANK_Alpha:=False;
    ANK_Kana:=False;
    SJIS_noKanji:=False;
    SJIS_KanjiLv1:=False;
    SJIS_AlabiaNum:=False;
    SJIS_KanjiLv2:=False;
    SJIS_KanjiEtc:=False;
    X68kPlus:=False;
  end;

  EnabledAntialias:=True;
  EncordCallback:=nil;
  WinFontBM:=nil;

  GrayScale[0]:=$80;
  GrayScale[1]:=$a0;
  GrayScale[2]:=$c0;
  GrayScale[3]:=$e0;

  for cnt:=$0000 to $ffff do begin
    with Data[cnt] do begin
      Enabled:=False;
      EncMaxPacketSize:=0;
      EncSize:=0;
      SetLength(EncData,0);
      Decorded:=False;
      DecSize:=0;
      SetLength(DecData,0);
    end;
  end;
end;

destructor TFontPack.Destroy;
begin
  FontAdded:=False;
  FontHeight:=0;
  FontName:='';
  with FontSet do begin
    ANK_Alpha:=False;
    ANK_Kana:=False;
    SJIS_noKanji:=False;
    SJIS_KanjiLv1:=False;
    SJIS_AlabiaNum:=False;
    SJIS_KanjiLv2:=False;
    SJIS_KanjiEtc:=False;
    X68kPlus:=False;
  end;

  EnabledAntialias:=True;
  EncordCallback:=nil;
  WinFontBM.Free;
  WinFontBM:=nil;

  GrayScale[0]:=$00;
  GrayScale[1]:=$00;
  GrayScale[2]:=$00;
  GrayScale[3]:=$00;

{
  for cnt:=$0000 to $ffff do begin
    with Data[cnt] do begin
      Enabled:=False;
      EncMaxPacketSize:=0;
      EncSize:=0;
      SetLength(EncData,0);
      Decorded:=False;
      DecSize:=0;
      SetLength(DecData,0);
    end;
  end;
}
end;

procedure TFontPack.MakeDecord(const CharCode:word);
var
  x,y:integer;
  s0,s1,s2:pByteArray;
  pc:byte;
  bright:byte;
begin
  if WinFontBM=nil then begin
    WinFontBM:=TBitmap.Create;
    with WinFontBM do begin
      PixelFormat:=pf8bit;
      Canvas.Brush.Color:=$000000;
      Canvas.Font.Color:=$ffffff;
    end;
  end;

  pc:=byte(CharCode and $ff00 div $100);
  if (pc=$80) or (($f0<=pc) and (pc<=$f3)) then begin
    MakeDecordX68kPlus(CharCode);
    exit;
  end;

  with WinFontBM.Canvas.Font do begin
    if Height<>(-FontHeight)*2 then begin
      WinFontBM.Width:=FontHeight*2;
      WinFontBM.Height:=FontHeight*2;
      Height:=-FontHeight*2;
    end;
    if Name<>FontName then begin
      Name:=FontName;
      Charset:=SHIFTJIS_CHARSET;
    end;
  end;

  with WinFontBM.Canvas do begin
    FillRect(Rect(0,0,FontHeight*2,FontHeight*2));
    if (CharCode and $ff)=$00 then begin
      TextOut(0,0,char(CharCode div $100));
      end else begin
      TextOut(0,0,char(CharCode div $100)+char(CharCode mod $100));
    end;
  end;

  with Data[CharCode] do begin
    Decorded:=True;
    DecSize:=0;
    for y:=0 to FontHeight-1 do begin
      if y=0 then begin
        s0:=WinFontBM.ScanLine[y*2+0];
        end else begin
        s0:=WinFontBM.ScanLine[y*2-1];
      end;
      s1:=WinFontBM.ScanLine[y*2+0];
      s2:=WinFontBM.ScanLine[y*2+1];
      for x:=0 to FontHeight-1 do begin
        SetLength(DecData,DecSize+2);
        bright:=0;
        if s1[x*2+0]<>$00 then inc(bright); // center
        if x=0 then begin // left
          if s1[x*2+0]<>$00 then inc(bright);
          end else begin
          if s1[x*2-1]<>$00 then inc(bright);
        end;
        if s0[x*2+0]<>$00 then inc(bright); // up
        if s1[x*2+1]<>$00 then inc(bright); // right
        if s2[x*2+0]<>$00 then inc(bright); // down
        pc:=$00;
        if EnabledAntialias=True then begin
          case bright of
            0: pc:=$00;
            1: pc:=GrayScale[0];
            2: pc:=GrayScale[1];
            3: pc:=GrayScale[2];
            4: pc:=GrayScale[3];
            5: pc:=$ff;
          end;
          end else begin
          if bright<=2 then begin
            pc:=$00;
            end else begin
            pc:=$ff;
          end;
        end;
        DecData[DecSize]:=pc;
        inc(Histgram[pc]);
        inc(DecSize);
      end;
    end;
  end;
end;

procedure TFontPack.MakeDecordX68kPlus(const CharCode:word);
var
  SJISText:string;
  x,y:integer;
  pc1,pc2:byte;
  s0,s1,s2:pByteArray;
  pc:byte;
  bright:byte;
begin
  if X68kPlusCodeStr='' then SetX68kPlusCode;

  with WinFontBM.Canvas.Font do begin
    if Height<>-FontHeight then begin
      WinFontBM.Width:=FontHeight*2;
      WinFontBM.Height:=FontHeight*2;
      Height:=-FontHeight;
    end;
    if Name<>FontName then begin
      Name:=FontName;
      Charset:=SHIFTJIS_CHARSET;
    end;
  end;

  pc1:=byte(CharCode and $ff00 div $100);
  pc2:=byte(CharCode and $ff);
  SJISText:=X68kPlusCodeStr[pc2*2+1]+X68kPlusCodeStr[pc2*2+2];

  with WinFontBM.Canvas do begin
    FillRect(Rect(0,0,FontHeight*2,FontHeight*2));
    if pc1=$80 then TextOut(0,0,SJISText);
    if (pc1=$f0) or (pc1=$f1) then TextOut(0,0,SJISText);
    if (pc1=$f2) or (pc1=$f3) then TextOut(0,FontHeight,SJISText);
  end;

  if pc1=$80 then begin // ‘ΌͺΆ
    with Data[CharCode] do begin
      Decorded:=True;
      DecSize:=0;
      for y:=0 to FontHeight-1 do begin
        s0:=WinFontBM.ScanLine[y+0];
        s1:=WinFontBM.ScanLine[y+0];
        s2:=WinFontBM.ScanLine[y+1];
        for x:=0 to FontHeight-1 do begin
          SetLength(DecData,DecSize+2);
          bright:=0;
          if s1[x*2+0]<>$00 then inc(bright); // center
          if x=0 then begin // left
            if s1[x*2+0]<>$00 then inc(bright);
            end else begin
            if s1[x*2-1]<>$00 then inc(bright);
          end;
          if s0[x*2+0]<>$00 then inc(bright); // up
          if s1[x*2+1]<>$00 then inc(bright); // right
          if s2[x*2+0]<>$00 then inc(bright); // down
          pc:=$00;
          if EnabledAntialias=True then begin
            case bright of
              0: pc:=$00;
              1: pc:=GrayScale[0];
              2: pc:=GrayScale[1];
              3: pc:=GrayScale[2];
              4: pc:=GrayScale[3];
              5: pc:=$ff;
            end;
            end else begin
            if bright<=2 then begin
              pc:=$00;
              end else begin
              pc:=$ff;
            end;
          end;
          DecData[DecSize]:=pc;
          inc(Histgram[pc]);
          inc(DecSize);
        end;
      end;
    end;
    end else begin // P^SΆ
    with Data[CharCode] do begin
      Decorded:=True;
      DecSize:=0;
      for y:=0 to FontHeight-1 do begin
        if y=0 then begin
          s0:=WinFontBM.ScanLine[y*2+0];
          end else begin
          s0:=WinFontBM.ScanLine[y*2-1];
        end;
        s1:=WinFontBM.ScanLine[y*2+0];
        s2:=WinFontBM.ScanLine[y*2+1];
        for x:=0 to FontHeight-1 do begin
          SetLength(DecData,DecSize+2);
          bright:=0;
          if s1[x*2+0]<>$00 then inc(bright); // center
          if x=0 then begin // left
            if s1[x*2+0]<>$00 then inc(bright);
            end else begin
            if s1[x*2-1]<>$00 then inc(bright);
          end;
          if s0[x*2+0]<>$00 then inc(bright); // up
          if s1[x*2+1]<>$00 then inc(bright); // right
          if s2[x*2+0]<>$00 then inc(bright); // down
          pc:=$00;
          if EnabledAntialias=True then begin
            case bright of
              0: pc:=$00;
              1: pc:=GrayScale[0];
              2: pc:=GrayScale[1];
              3: pc:=GrayScale[2];
              4: pc:=GrayScale[3];
              5: pc:=$ff;
            end;
            end else begin
            if bright<=2 then begin
              pc:=$00;
              end else begin
              pc:=$ff;
            end;
          end;
          DecData[DecSize]:=pc;
          inc(Histgram[pc]);
          inc(DecSize);
        end;
      end;
    end;
  end;
end;

function TFontPack.AutoParamEncord(const CharCode:word):boolean;
var
  FindDataSize:array[$00..$0f] of word;
  MaxPacketCnt:integer;
  MinEncSize:word;
begin
  FontAdded:=True;

  MakeDecord(CharCode);

  if EnabledAntialias=False then begin
    Data[CharCode].EncMaxPacketSize:=$0f;
    Encord(CharCode);
    Result:=True;
    exit;
  end;

  for MaxPacketCnt:=$00 to $0f do begin
    FindDataSize[MaxPacketCnt]:=$ffff;
  end;

  with Data[CharCode] do begin
    for MaxPacketCnt:=$02 to $0e do begin
      EncMaxPacketSize:=MaxPacketCnt;
      Encord(CharCode);
      if Enabled=False then begin
        FindDataSize[MaxPacketCnt]:=$ffff;
        end else begin
        FindDataSize[MaxPacketCnt]:=EncSize;
      end;
    end;
  end;

  MinEncSize:=$ffff;

  for MaxPacketCnt:=$00 to $0f do begin
    if MinEncSize>FindDataSize[MaxPacketCnt] then MinEncSize:=FindDataSize[MaxPacketCnt];
  end;

  if MinEncSize=$ffff then begin
    Result:=False;
    exit;
  end;

  with Data[CharCode] do begin
    EncMaxPacketSize:=$02; // Default
    for MaxPacketCnt:=$00 to $0f do begin
      if MinEncSize=FindDataSize[MaxPacketCnt] then begin
        EncMaxPacketSize:=MaxPacketCnt;
      end;
    end;
  end;

  Encord(CharCode);

  with Data[CharCode] do begin
    Decorded:=False;
    DecSize:=0;
    SetLength(DecData,0);
  end;

  Result:=True;
end;

const ptBlack=0;
const ptWhite=1;
const ptGray=2;

procedure TFontPack.Encord(const CharCode:word);
var
  DecCnt:integer;
  LastColor:byte;
  CopySize:byte;
  wb:byte;
  function GetPixelType(var b:byte):byte;
  begin
    if b=$00 then begin
      Result:=ptBlack;
      end else begin
      if b=$ff then begin
        Result:=ptWhite;
        end else begin
        Result:=ptGray;
      end;
    end;
  end;
  function SetEncByte(b:byte):boolean;
  begin
    with Data[CharCode] do begin
      if EncSize>32767 then begin
        SetLength(EncData,0);
        Enabled:=False;
        Result:=False;
        end else begin
        EncData[EncSize]:=b and $0f;
        inc(EncSize);
        Result:=True;
      end;
    end;
  end;
  function GetCanCopySize(var DecCnt:integer):byte;
  var
    Ajust:integer;
    CanCopy:boolean;
    CompSize:integer;
    nc,bc:byte;
  begin
    if DecCnt<=(FontHeight-1) then begin // ζͺCΝ³
      Result:=0;
      exit;
    end;

    with Data[CharCode] do begin
      Ajust:=0;
      CanCopy:=True;
      CompSize:=0;
      while (CanCopy=True) and (Ajust<$10) and ((DecCnt+Ajust)<=DecSize) do begin
        nc:=DecData[DecCnt+Ajust];
        if nc<>DecData[DecCnt+Ajust-FontHeight] then begin
          CanCopy:=False;
          end else begin
          bc:=DecData[DecCnt+Ajust-1];
          case bc of
            $00: begin
              if nc=$ff then inc(CompSize);
              if (nc<>$00) and (nc<>$ff) then inc(CompSize,2);
            end;
            $ff: begin
              if nc=$00 then inc(CompSize);
              if (nc<>$00) and (nc<>$ff) then inc(CompSize,2);
            end;
            else inc(CompSize);
          end;
          inc(Ajust);
        end;
      end;
    end;

    if CompSize<=2 then begin
      Result:=0;
      end else begin
      Result:=Ajust;
    end;
  end;
  procedure AnalizeCompress(var DecCnt:integer;var LastColor:byte);
  var
    NextFlag:boolean;
    gccnt:integer;
    npt:byte; // NowPixelType
    bpt:byte; // BasePixelType
    PacketSize:integer;
    GrayColor:byte;
    GrayCount:integer;
    GrayColors:array[0..$f] of byte;
  begin
    with Data[CharCode] do begin
      bpt:=GetPixelType(DecData[DecCnt]);
      if bpt=ptGray then begin
        for gccnt:=0 to $f do begin
          GrayColors[gccnt]:=$0;
        end;
      end;
      NextFlag:=True;
      PacketSize:=0;
      while ((DecCnt<=(DecSize-1)) and (NextFlag=True)) do begin
        if bpt=ptGray then begin
          GrayColor:=DecData[DecCnt];
          if GrayColor=GrayScale[0] then GrayColors[PacketSize]:=0;
          if GrayColor=GrayScale[1] then GrayColors[PacketSize]:=1;
          if GrayColor=GrayScale[2] then GrayColors[PacketSize]:=2;
          if GrayColor=GrayScale[3] then GrayColors[PacketSize]:=3;
        end;
        inc(PacketSize);
        inc(DecCnt);
        npt:=GetPixelType(DecData[DecCnt]);
        if bpt=npt then begin
          NextFlag:=True;
          end else begin
          NextFlag:=False;
        end;
        if bpt<>ptGray then begin
          if PacketSize=(EncMaxPacketSize-1) then NextFlag:=False;
          end else begin
          if PacketSize=($0f-EncMaxPacketSize) then NextFlag:=False;
        end;
      end;
    end;

    with Data[CharCode] do begin
      case bpt of
        ptBlack: begin
          if LastColor=$00 then begin
            if SetEncByte($00)=False then exit;
            if SetEncByte(PacketSize)=False then exit;
            end else begin
            if SetEncByte(PacketSize)=False then exit;
            LastColor:=not LastColor;
          end;
        end;
        ptWhite: begin
          if LastColor=$ff then begin
            if SetEncByte($00)=False then exit;
            if SetEncByte(PacketSize)=False then exit;
            end else begin
            if SetEncByte(PacketSize)=False then exit;
            LastColor:=not LastColor;
          end;
        end;
        ptGray: begin
          if SetEncByte(EncMaxPacketSize+PacketSize)=False then exit;
          if (PacketSize mod 2)=1 then inc(PacketSize);
          for GrayCount:=0 to (PacketSize div 2)-1 do begin
            wb:=GrayColors[GrayCount*2+0] shl 2;
            wb:=wb+GrayColors[GrayCount*2+1];
            if SetEncByte(wb)=False then exit;
          end;
        end;
      end;
    end;
  end;
begin
  LastColor:=$00;

  with Data[CharCode] do begin
    Enabled:=True;
    EncSize:=0;
    SetLength(EncData,32767+1);

    DecCnt:=0;
    while (DecCnt<=(DecSize-1)) do begin
      CopySize:=GetCanCopySize(DecCnt);
      if CopySize<>0 then begin
        if SetEncByte(EncMaxPacketSize)=False then exit;
        if SetEncByte(CopySize-1)=False then exit;
        inc(DecCnt,CopySize);
        end else begin
        AnalizeCompress(DecCnt,LastColor);
      end;
    end;

    if (EncSize mod 2)=1 then SetEncByte($00);

    SetLength(EncData,EncSize+1);
  end;
end;

procedure TFontPack.Decord(const CharCode:word);
var
  cnt,wcnt:integer;
  NowColor:byte;
  CopySize:byte;
  rb:byte;
  high:boolean;
begin
  with Data[CharCode] do begin
    Decorded:=True;
    SetLength(DecData,FontHeight*FontHeight+1);
    DecSize:=0;
    NowColor:=$ff;
    cnt:=0;
    while (cnt<=(EncSize-1)) do begin
      if EncData[cnt]<=(EncMaxPacketSize-1) then begin
        for wcnt:=0 to EncData[cnt]-1 do begin
          DecData[DecSize]:=NowColor;
          inc(DecSize);
        end;
        NowColor:=not NowColor;
        end else begin
        if EncData[cnt]=EncMaxPacketSize then begin
          inc(cnt);
          CopySize:=EncData[cnt];
          for wcnt:=0 to CopySize do begin
            DecData[DecSize]:=DecData[DecSize-FontHeight];
            inc(DecSize);
          end;
          end else begin
          rb:=$00;
          high:=True;
          for wcnt:=0 to EncData[cnt]-EncMaxPacketSize-1 do begin
            if high=False then begin
              rb:=rb shl 2;
              high:=True;
              end else begin
              inc(cnt);
              rb:=EncData[cnt];
              high:=False;
            end;
            DecData[DecSize]:=GrayScale[rb and $0c shr 2];
            inc(DecSize);
          end;
        end;
      end;
      inc(cnt);
    end;
  end;
end;

procedure TFontPack.DrawDecord(const bm:TBitmap;const x,y:integer;const CharCode:word;const isHighLight,isPerticalLine,isUnderLine:boolean);
var
  px,py:integer;
  s:pByteArray;
  c:byte;
  cw:word;
  ofs:integer;
  tr,tg,tb,br,bg,bb:word;
begin
  with Data[CharCode] do begin
    if Enabled=False then begin
      Enabled:=True;
      if AutoParamEncord(CharCode)=False then exit;
    end;

    if Decorded=False then begin
      Decord(CharCode);
      if Decorded=False then exit;
    end;

    if x<0 then exit;
    if (x+FontHeight)>bm.Width then exit;
    if y<0 then exit;
    if (y+FontHeight)>bm.Height then exit;

    with DrawMode.TextColor do begin
      tr:=r;
      tg:=g;
      tb:=b;
    end;
    with DrawMode.BGColor do begin
      br:=r;
      bg:=g;
      bb:=b;
    end;

    if isHighLight=False then begin
      if DrawMode.Transparent=True then begin
        if (tr=$ff) and (tg=$ff) and (tb=$ff) then begin
          for py:=0 to FontHeight-1 do begin
            s:=bm.ScanLine[y+py];
            for px:=0 to FontHeight-1 do begin
              ofs:=(x+px)*3;
              c:=DecData[py*FontHeight+px];
              s[ofs+0]:=byte((word($ff-c)*s[ofs+0]) div $100)+c;
              s[ofs+1]:=byte((word($ff-c)*s[ofs+1]) div $100)+c;
              s[ofs+2]:=byte((word($ff-c)*s[ofs+2]) div $100)+c;
            end;
          end;
          end else begin
          if (tr=$00) and (tg=$00) and (tb=$00) then begin
            for py:=0 to FontHeight-1 do begin
              s:=bm.ScanLine[y+py];
              for px:=0 to FontHeight-1 do begin
                ofs:=(x+px)*3;
                c:=DecData[py*FontHeight+px];
                s[ofs+0]:=byte((word($ff-c)*s[ofs+0]) div $100);
                s[ofs+1]:=byte((word($ff-c)*s[ofs+1]) div $100);
                s[ofs+2]:=byte((word($ff-c)*s[ofs+2]) div $100);
              end;
            end;
            end else begin
            for py:=0 to FontHeight-1 do begin // any textcolor
              s:=bm.ScanLine[y+py];
              for px:=0 to FontHeight-1 do begin
                ofs:=(x+px)*3;
                c:=DecData[py*FontHeight+px];
                if c<>$00 then begin
                  s[ofs+0]:=byte((word($ff-c)*s[ofs+0]) div $100)+byte((c*tb) div $100);
                  s[ofs+1]:=byte((word($ff-c)*s[ofs+1]) div $100)+byte((c*tg) div $100);
                  s[ofs+2]:=byte((word($ff-c)*s[ofs+2]) div $100)+byte((c*tr) div $100);
                end;
              end;
            end;
          end;
        end;
        end else begin // not trans
        if (tr=$ff) and (tg=$ff) and (tb=$ff) then begin
          for py:=0 to FontHeight-1 do begin
            s:=bm.ScanLine[y+py];
            for px:=0 to FontHeight-1 do begin
              ofs:=(x+px)*3;
              c:=DecData[py*FontHeight+px];
              s[ofs+0]:=byte((word($ff-c)*bb) div $100)+c;
              s[ofs+1]:=byte((word($ff-c)*bg) div $100)+c;
              s[ofs+2]:=byte((word($ff-c)*br) div $100)+c;
            end;
          end;
          end else begin
          if (tr=$00) and (tg=$00) and (tb=$00) then begin
            for py:=0 to FontHeight-1 do begin
              s:=bm.ScanLine[y+py];
              for px:=0 to FontHeight-1 do begin
                ofs:=(x+px)*3;
                c:=DecData[py*FontHeight+px];
                s[ofs+0]:=byte((word($ff-c)*bb) div $100);
                s[ofs+1]:=byte((word($ff-c)*bg) div $100);
                s[ofs+2]:=byte((word($ff-c)*br) div $100);
              end;
            end;
            end else begin
            for py:=0 to FontHeight-1 do begin // any textcolor
              s:=bm.ScanLine[y+py];
              for px:=0 to FontHeight-1 do begin
                ofs:=(x+px)*3;
                c:=DecData[py*FontHeight+px];
                s[ofs+0]:=byte((word($ff-c)*bb) div $100)+byte((c*tb) div $100);
                s[ofs+1]:=byte((word($ff-c)*bg) div $100)+byte((c*tg) div $100);
                s[ofs+2]:=byte((word($ff-c)*br) div $100)+byte((c*tr) div $100);
              end;
            end;
          end;
        end;
      end;
      end else begin // isHighLight=True
      if DrawMode.Transparent=True then begin
        for py:=0 to FontHeight-1 do begin // any textcolor
          s:=bm.ScanLine[y+py];
          for px:=0 to FontHeight-1 do begin
            ofs:=(x+px)*3;
            if px<>(FontHeight-1) then begin
              cw:=word(DecData[py*FontHeight+px])+word(DecData[py*FontHeight+px+1]);
              if cw<=$ff then begin
                c:=byte(cw);
                end else begin
                c:=$ff;
              end;
              end else begin
              c:=DecData[py*FontHeight+px];
            end;
            s[ofs+0]:=byte((word($ff-c)*s[ofs+0]) div $100)+byte((c*tb) div $100);
            s[ofs+1]:=byte((word($ff-c)*s[ofs+1]) div $100)+byte((c*tg) div $100);
            s[ofs+2]:=byte((word($ff-c)*s[ofs+2]) div $100)+byte((c*tr) div $100);
          end;
        end;
        end else begin // not trans
        for py:=0 to FontHeight-1 do begin // any textcolor
          s:=bm.ScanLine[y+py];
          for px:=0 to FontHeight-1 do begin
            ofs:=(x+px)*3;
            if px<>(FontHeight-1) then begin
              cw:=word(DecData[py*FontHeight+px])+word(DecData[py*FontHeight+px+1]);
              if cw<=$ff then begin
                c:=byte(cw);
                end else begin
                c:=$ff;
              end;
              end else begin
              c:=DecData[py*FontHeight+px];
            end;
            s[ofs+0]:=byte((word($ff-c)*bb) div $100)+byte((c*tb) div $100);
            s[ofs+1]:=byte((word($ff-c)*bg) div $100)+byte((c*tg) div $100);
            s[ofs+2]:=byte((word($ff-c)*br) div $100)+byte((c*tr) div $100);
          end;
        end;
      end;
    end;
  end;

 
  if isPerticalLine=True then begin // any textcolor
    with Data[CharCode] do begin
      for py:=0 to FontHeight-1 do begin
        s:=bm.ScanLine[y+py];
        px:=(FontHeight div 4)*1-1;
        ofs:=(x+px)*3;
        s[ofs+0]:=tb;
        s[ofs+1]:=tg;
        s[ofs+2]:=tr;
        px:=(FontHeight div 4)*3-1;
        ofs:=(x+px)*3;
        s[ofs+0]:=tb;
        s[ofs+1]:=tg;
        s[ofs+2]:=tr;
      end;
    end;
  end;
  if isUnderLine=True then begin // any textcolor
    with Data[CharCode] do begin
      py:=FontHeight-1;
      s:=bm.ScanLine[y+py];
      for px:=0 to FontHeight-1 do begin
        ofs:=(x+px)*3;
        s[ofs+0]:=tb;
        s[ofs+1]:=tg;
        s[ofs+2]:=tr;
      end;
    end;
  end;
end;

procedure TFontPack.DrawDecordStr(const bm:TBitmap;const x,y:integer;const msg:string;const isHighLight,isPerticalLine,isUnderLine:boolean);
var
  cnt:integer;
  b:byte;
  nx:integer;
begin
  if FontWidth=0 then FontWidth:=FontHeight;

  cnt:=1;
  nx:=x;

  while (cnt<=length(msg)) do begin
    b:=byte(msg[cnt]);
    if isAnkChar(b)=True then begin
      DrawDecord(bm,nx,y,word(b) shl 8,isHighLight,isPerticalLine,isUnderLine);
      inc(nx,FontWidth div 2);
      inc(cnt,1);
      end else begin
      DrawDecord(bm,nx,y,word(msg[cnt+1])+(word(b) shl 8),isHighLight,isPerticalLine,isUnderLine);
      inc(nx,FontWidth);
      inc(cnt,2);
    end;
  end;
end;

procedure TFontPack.SaveToFile(const Filename:string);
var
  wfb:TWriteFileBuf;
  cnt,wcnt:word;
begin
  if DirectoryExists(ExtractFilePath(Filename))=False then CreateDir(ExtractFilePath(Filename));

  wfb:=TWriteFileBuf.Create;
  wfb.Init(Filename);

  wfb.SetVByte(FontHeight);
  wfb.SetVMString(FontName);

  with FontSet do begin
    wfb.SetVBoolean(ANK_Alpha);
    wfb.SetVBoolean(ANK_Kana);
    wfb.SetVBoolean(SJIS_noKanji);
    wfb.SetVBoolean(SJIS_KanjiLv1);
    wfb.SetVBoolean(SJIS_AlabiaNum);
    wfb.SetVBoolean(SJIS_KanjiLv2);
    wfb.SetVBoolean(SJIS_KanjiEtc);
    wfb.SetVBoolean(X68kPlus);
  end;

  wfb.SetVByte(GrayScale[0]);
  wfb.SetVByte(GrayScale[1]);
  wfb.SetVByte(GrayScale[2]);
  wfb.SetVByte(GrayScale[3]);

  for cnt:=$0000 to $ffff do begin
    with Data[cnt] do begin
      if Enabled=True then begin
        wfb.SetWord(cnt);
        wfb.SetVByte(EncMaxPacketSize);
        wfb.SetVWord(EncSize);
        for wcnt:=0 to (EncSize div 2)-1 do begin
          wfb.SetByte((EncData[(wcnt*2)+0]*$10)+EncData[(wcnt*2)+1]);
        end;
      end;
    end;
  end;

  wfb.SaveFile;
  wfb.Free;

  FontAdded:=False;
end;

procedure TFontPack.LoadFromRFB(var rfb:TReadFileBuf);
var
  cnt,rcnt:word;
  rb:byte;
begin
  FontHeight:=0;
  FontName:='';

  for cnt:=$0000 to $ffff do begin
    with Data[cnt] do begin
      Enabled:=False;
      EncMaxPacketSize:=0;
      EncSize:=0;
      SetLength(EncData,0);
      Decorded:=False;
      DecSize:=0;
      SetLength(DecData,0);
    end;
  end;

  rfb.GetVByte(FontHeight);
  rfb.GetVMString(FontName);

  with FontSet do begin
    rfb.GetVBoolean(ANK_Alpha);
    rfb.GetVBoolean(ANK_Kana);
    rfb.GetVBoolean(SJIS_noKanji);
    rfb.GetVBoolean(SJIS_KanjiLv1);
    rfb.GetVBoolean(SJIS_AlabiaNum);
    rfb.GetVBoolean(SJIS_KanjiLv2);
    rfb.GetVBoolean(SJIS_KanjiEtc);
    rfb.GetVBoolean(X68kPlus);
  end;

  rfb.GetVByte(GrayScale[0]);
  rfb.GetVByte(GrayScale[1]);
  rfb.GetVByte(GrayScale[2]);
  rfb.GetVByte(GrayScale[3]);

  while (rfb.GetPosition<rfb.GetCount) do begin
    rfb.GetVWord(cnt);
    with Data[cnt] do begin
      Enabled:=True;
      rfb.GetVByte(EncMaxPacketSize);
      rfb.GetVWord(EncSize);
      SetLength(EncData,EncSize+1);
      for rcnt:=0 to (EncSize div 2)-1 do begin
        rfb.GetVByte(rb);
        EncData[(rcnt*2)+0]:=rb div $10;
        EncData[(rcnt*2)+1]:=rb mod $10;
      end;
    end;
  end;

  FontAdded:=False;
end;

procedure TFontPack.LoadFromFile(const Filename:string);
var
  rfb:TReadFileBuf;
begin
  if FileExists(Filename)=False then exit;

  rfb:=TReadFileBuf.Create;
  rfb.Init(Filename);
  rfb.LoadFile;
  LoadFromRFB(rfb);
  rfb.Free;
end;

procedure TFontPack.LoadFromResource(const ResourceName:string);
var
  rfb:TReadFileBuf;
begin
  rfb:=TReadFileBuf.Create;
  rfb.Init(ResourceName);
  rfb.LoadResource;
  LoadFromRFB(rfb);
  rfb.Free;
end;

function TFontPack.FullAutoEncord:boolean;
var
  b1,b2:byte;
  c,cnt,max:integer;
  procedure EnabledFont(b1,b2:byte);
  begin
    Data[word(b1)*$100+b2].Enabled:=True;
  end;
begin
  Result:=True;

  if FontSet.ANK_Alpha=True then begin
    for b1:=$20 to $7e do begin
      EnabledFont(b1,$00);
    end;
  end;

  if FontSet.ANK_Kana=True then begin
    for b1:=$a0 to $df do begin
      EnabledFont(b1,$00);
    end;
  end;

  if FontSet.SJIS_noKanji=True then begin
    for b1:=$81 to $82 do begin
      for b2:=$00 to $ff do begin
        EnabledFont(b1,b2);
      end;
    end;
    for b2:=$00 to $df do begin
      EnabledFont($83,b2);
    end;
    for b2:=$00 to $bf do begin
      EnabledFont($84,b2);
    end;
    for b2:=$00 to $9f do begin
      EnabledFont($87,b2);
    end;
  end;

  if FontSet.SJIS_KanjiLv1=True then begin
    for b2:=$9f to $ff do begin
      EnabledFont($88,b2);
    end;
    for b1:=$89 to $97 do begin
      for b2:=$00 to $ff do begin
        EnabledFont(b1,b2);
      end;
    end;
    for b2:=$00 to $72 do begin
      EnabledFont($98,b2);
    end;
  end;

  if FontSet.SJIS_AlabiaNum=True then begin
    for b2:=$40 to $5b do begin
      EnabledFont($fa,b2);
    end;
  end;

  if FontSet.SJIS_KanjiLv2=True then begin
    for b2:=$9f to $ff do begin
      EnabledFont($98,b2);
    end;
    for b1:=$99 to $9f do begin
      for b2:=$00 to $ff do begin
        EnabledFont(b1,b2);
      end;
    end;
    for b1:=$e0 to $e9 do begin
      for b2:=$00 to $ff do begin
        EnabledFont(b1,b2);
      end;
    end;
    for b2:=$00 to $a4 do begin
      EnabledFont($ea,b2);
    end;
  end;

  if FontSet.SJIS_KanjiEtc=True then begin
    for b1:=$ed to $ee do begin
      for b2:=$00 to $ff do begin
        EnabledFont(b1,b2);
      end;
    end;
    for b1:=$fa to $fb do begin
      for b2:=$00 to $ff do begin
        EnabledFont(b1,b2);
      end;
    end;
    for b2:=$00 to $4b do begin
      EnabledFont($fc,b2);
    end;
  end;

  for b1:=$00 to $ff do begin
    for b2:=$00 to $ff do begin
      if (($01<=b2) and (b2<=$3f)) or (b2=$7f) or ($fd<=b2) then begin
        Data[word(b1)*$100+b2].Enabled:=False;
      end;
    end;
  end;

  if FontSet.X68kPlus=True then begin
    for b2:=$00 to $ff do begin
      EnabledFont($80,b2);
      EnabledFont($f0,b2);
      EnabledFont($f1,b2);
      EnabledFont($f2,b2);
      EnabledFont($f3,b2);
    end;
  end;

  max:=0;

  for c:=$0000 to $ffff do begin
    if Data[c].Enabled=True then inc(max);
  end;

  cnt:=0;

  for c:=$0000 to $ffff do begin
    if Data[c].Enabled=True then begin
      if AutoParamEncord(c)=False then begin
        Result:=False;
        exit;
      end;
      if addr(EncordCallback)<>nil then EncordCallback(cnt,max);
      inc(cnt);
    end;
  end;

  FontAdded:=True;
end;

end.
