bmfed.pas

将bmf在DOS下显示出来

{TMT Pascal compilee
 name: BMFED - BitMap Font EDitor
 author: crs/broncs
 last modification: 2004-07-14 18:47
}
uses dpmi;
{$DEFINE useGFX}
{$DEFINE usershutdown}
{$DEFINE bmfchange}
{$DEFINE loadbmfwithpal}
{$I SYST.INC}
{$I GFX.INC}
{$I STREAM.INC}
{$I BUF2D.INC}
{$I BMCHAR.INC}
{$I BMFONT.INC}
{$I OPENGFX.INC}
{$I GFXEDIT.INC}
{$I EVENTS.INC}
{$I FONT8.INC}
const
  WINX      =8;
  WINY      =20;
  WINW      =255;
  WINH:dword=170;
  PALDOT    =3;
  CHARBELTY =20;
  fontpals:array[0..3] of string[32]=('','','','');
  fpBLUE    =0;
  fpGREEN   =1;
  fpRED     =2;
  fpSYSTEM  =0;
  fpNORMAL  =1;
  fpMAIN    =3;
  zoom:byte =1;
  selected:array[byte] of boolean=(false,...);

var
  ed:TGFXEdit;
  tb,tc,undo:TBMChar;

procedure UserShutdown;
var i:integer;
begin
  {$IFDEF usershutdown}
  scr.done;
  ed.done;
  tc.done;
  tb.done;
  undo.done;
  {$ENDIF}
end;  {UserShutdown}

procedure grayscalepal(total:dword);
var i:longint;
begin
  for i:=0 to total do
    setRGB(i,63*i div total,63*i div total,63*i div total);
end;  {grayscalepal}

procedure fw(x,y:TCoordinate;s:string;color,f:byte);
var i,j,k:longint;
begin
  if f and $80<>0 then scr.quad(x,y,length(s) shl either(f=0,3,2),7,0);
  f:=f and 1;
  for k:=1 to length(s) do
    for j:=0 to 7 do
      for i:=0 to either(f=0,7,3) do
        if font8[f][ord(s[k]) shl 3+j] and ($80 shr i)<>0 then scr.setpoint(x+pred(k) shl (2+byte(f=0))+i,y+j,color);
end;  {fw}

var color:byte:=31;

procedure drawPalBelt;
var i:longint;
begin
  scr.quad(0,WINY-1,PALDOT,32*PALDOT+2,244);
  for i:=0 to 31 do begin
    scr.quad(0,WINY+i*PALDOT,PALDOT,PALDOT,i);
    if color=i then scr.setpoint(0,WINY+i*PALDOT,253);
  end;
end;  {drawPalBelt}

var
  c:char:='A';
  cbak:char;
  bmf:TBMFont;

procedure changePar(mx,n:longint);
begin
  with bmf.tablo[c] do
  if n<>65536 then begin
    case (mx-48) div 28 of
    0: relx:=bounded(relx+n,-128,127);
    1: rely:=bounded(rely+n,-128,127);
    2: resize(width+n,height);
    3: resize(width,height+n);
    4: shift:=bounded(shift+n,0,255);
    5: bmf.addspace:=bounded(bmf.addspace+n,0,255);
    6: bmf.sizeover:=bounded(bmf.sizeover+n,-128,127);
    7: bmf.sizeunder:=bounded(bmf.sizeunder+n,-128,127);
    8: bmf.lineheight:=bounded(bmf.lineheight+n,1,255);
    end;
    if mx in [131..135] then resize(width+n,height+n);
  end else
    case (mx-48) div 28 of
    0: relx:=bmf.tablo[cbak].relx;
    1: rely:=bmf.tablo[cbak].rely;
    2: resize(bmf.tablo[cbak].w,height);
    3: resize(width,bmf.tablo[cbak].h);
    4: shift:=bmf.tablo[cbak].shift;
    end;
end;  {changepar}

procedure BMFont_save_palette(var f:TStream);
var i:longint;
begin
  for i:=0 to $2FF do pal[i]:=pal[i] and 63;
  color:=bmf.colorsUsed shr 16;
  f.write(color,1);
  for i:=1 to color do
    f.write(pal[i*3],3);
end;  {BMFont_save_palette}

var
  mx,my:longint;
  inside:boolean;
  e:TEvent;

procedure xorcursor(mx,my:longint);
var i,j:longint;
begin
  for j:=0 to 10 do
    for i:=0 to 7 do
      if ((j<=7) and (i<=j)) or ((j>7) and (i<11-j)) then
        scr.xorpoint(mx+i,my+j,$3F);
end;  {xorcursor}

procedure showchar(c:char);
var i,j:integer;
begin
  with bmf.tablo[c] do
  if d<>nil then
    for j:=0 to pred(h) do
      for i:=0 to pred(w) do
        scr.quad(WINX+i*zoom,WINY+j*zoom,zoom,zoom,getpoint(i,j));
end;

procedure cz_macro;
const
  CZMAX=44;
  ca:array[0..CZMAX-1] of char=
  (#$88,#$A8,#$87,#$A9,#$91,#$98,#$A0,#$A1,#$82,#$A3,#$96,#$9F,#$A4,#$83,#$A2,#$84,#$8C,#$8D,#$93,#$AA,#$81,#$94,
   #$89,#$9B,#$80,#$9E,#$92,#$9D,#$8F,#$8B,#$90,#$97,#$A6,#$86,#$A5,#$85,#$95,#$8E,#$9C,#$8A,#$A7,#$AB,#$9A,#$99);
  cb:array[0..CZMAX-1] of char=
  ('e','s','c','r','z','y','a','i','e','u','u','t','n','d','o','a','l','l','o','r','u','o',
   'E','S','C','R','Z','Y','A','I','E','U','U','T','N','D','O','A','L','L','O','R','U','O');
  cc:array[0..CZMAX shr 1-1] of byte=
  ( 2 , 2 , 2 , 2 , 2 , 1 , 1 , 1 , 1 , 1 , 3 , 5 , 2 , 5 , 1 , 4 , 2 , 5 , 6 , 6 , 4 , 4);
  cp:array[0..6] of byte=(0,25,30,34,20,8,28);
  {1=carka, 2=hacek, 3=krouzek, 4=prehlaska, 5=apostrof, 6=striska}
var
  i,t:integer;
  clone:array[0..CZMAX-1] of TBmChar;
begin
  for i:=0 to CZMAX-1 do begin
    clone[i].init0;
    clone[i].copyToMe(@bmf.tablo[cb[i]]);
  end;
  for i:=0 to CZMAX-1 do with bmf.tablo[ca[i]] do begin
    copyToMe(@clone[i]);
    t:=clone[i].h*cp[cc[i]] shr 7;
    resize(w,h+t);
    shiftV(t);
    dec(rely,t);
  end;
end;

procedure cz_macro2; //transforms diacritics chars from Latin-2 to windows-1250
const
  CZMAX=38;
  iso:string[CZMAX]=#$EC#$9A#$E8#$F8#$9E#$FD#$E1#$ED#$E9#$F3#$FA#$F9#$EF#$9D#$F2+#$CC#$8A#$C8#$D8#$8E#$DD#$C1#$CD#$C9#$D3#$DA#$D9#$CF#$8D#$D2#$E4#$EB#$F6#$FC#$E5#$C5#$F4#$D4;
  dos:string[CZMAX]=#$88#$A8#$87#$A9#$91#$98#$A0#$A1#$82#$A2#$A3#$96#$83#$9F#$A4+#$89#$9B#$80#$9E#$92#$9D#$8F#$8B#$90#$95#$97#$A6#$85#$86#$A5#$C4#$DB#$D6#$DC#$8B#$8C#$93#$A7;

var
  i:integer;
  clone:array[1..CZMAX] of TBmChar;
begin
  for i:=1 to CZMAX do begin
    clone[i].init0;
    clone[i].copyToMe(@bmf.tablo[dos[i]]);
    bmf.tablo[dos[i]].free;
  end;
  for i:=1 to CZMAX do
    bmf.tablo[iso[i]].copyToMe(@clone[i]);
end;

procedure dowithchar(what:string11);
var i,j:longint;
begin
  with bmf.tablo[c] do
  if length(what)=1 then
    case what[1] of
    #38: cycleH(-1);
    #19: cycleH(1);
    #22: cycleV(-1);
    #32: cycleV(1);
    #35: if mem[ROM_KEYFLAGS] and (kfANYSHIFT or kfCAPSLOCK)=0 then flipH else softenH;
    #47: if mem[ROM_KEYFLAGS] and (kfANYSHIFT or kfCAPSLOCK)=0 then flipV else softenV;
    #16: begin cycleV(-1); resize(w,h-1); end;
    #20: turnRight;
    #30: resize(w,h-1);
    #31: resize(w-1,h);
    #49: minimize;
    'S': begin free; if mem[ROM_KEYFLAGS] and (kfANYSHIFT or kfCAPSLOCK)<>0 then init0; end;
    's': shift:=bounded(shift-1,-128,127);
    't': shift:=bounded(shift+1,-128,127);
    #127:if not empty then fillchar(d^,w*h,0);
    #128:replace(color,(my-WINY) div PALDOT,e.keyflags and kfANYSHIFT<>0);
    #21: flood((mx-WINX) div zoom,(my-WINY) div zoom,color);
    #23: if not empty then
         for j:=0 to h-1 do
           for i:=0 to w-1 do
             setpoint(i,j,color-getpoint(i,j));
    #25: if mx>=WINX then
           if not empty then shift:=w+relx else
         else
           if color>=2 then grayscalepal(color);
    '0': if not empty then
           for j:=pred(h) downto 0 do
             for i:=pred(w) downto 0 do
               if (getPoint(i,j)=0) and (getPoint(i-1,j)<>0) then
                 setPoint(i,j,getPoint(i-1,j));
//               if getPoint(i,j)=0 then begin
//                 if (getPoint(i,j-1)=0) or (getPoint(i-1,j)=0) then addPoint(i,j,1);
//                 if (getPoint(i,j+1)=0) or (getPoint(i+1,j)=0) then addPoint(i,j,-1);
//               end;
    #18: if not empty then {alt-e}
           for j:=pred(h) downto 0 do
             for i:=pred(w) downto 0 do
               if (getPoint(i,j)=0) and (getPoint(i-1,j-1)<>0) then
                 setPoint(i,j,color);
    end
  else if what='81' then changePar(mx,-10)
  else if what='82' then dec(rely)
  else if what='83' then resize(w,h-1)
  else if what='21' then changePar(mx,10)
  else if what='22' then inc(rely)
  else if what='23' then resize(w,h+1)
  else if what='41' then changePar(mx,-1)
  else if what='42' then dec(relx)
  else if what='43' then resize(w-1,h)
  else if what='31' then changePar(mx,65536)
  else if what='61' then changePar(mx,1)
  else if what='62' then inc(relx)
  else if what='63' then resize(w+1,h)
  else if what='5-' then setPoint((mx-WINX) div zoom,(my-WINY) div zoom,Max(getPoint((mx-WINX) div zoom,(my-WINY) div zoom)-1,0))
  else if what='5+' then setPoint((mx-WINX) div zoom,(my-WINY) div zoom,getPoint((mx-WINX) div zoom,(my-WINY) div zoom)+1)
  else if (what='f*') and (w*h<>0) then begin
    resize(w+2,h+2); shiftH(1); shiftV(1);
    for j:=0 to h-1 do
      for i:=0 to w-1 do
        if ((getpoint(i-1,j)<>0) or (getpoint(i+1,j)<>0) or (getpoint(i,j-1)<>0) or (getpoint(i,j+1)<>0))
          and (getpoint(i,j)=0) then
          setpoint(i,j,color);
  end else if what='fL' then
    for j:=0 to h-1 do
      for i:=0 to w-1 do
        if getpoint(i,j)<>0 then setpoint(i,j,color) else
  else if what='5*' then
    for j:=0 to h-1 do
      for i:=0 to w-1 do
        setpoint(i,j,getpoint(i,j)*color div 16)
  else if (what='O/') and not empty then begin
    resize(w+2,h+2);
    shiftH(1); shiftV(1);
    undo.copyToMe(@bmf.tablo[c]);
    for j:=0 to pred(h) do
      for i:=0 to pred(w) do
        if (undo.getpoint(i,j)=0) and ((undo.getpoint(i-1,j)<>0) or (undo.getpoint(i,j-1)<>0) or (undo.getpoint(i+1,j)<>0) or (undo.getpoint(i,j+1)<>0)) then
          setpoint(i,j,color);
    undo.shiftH(-1); undo.shiftV(-1);
    undo.resize(w-2,h-2);
  end;
end;  {dowithchar}

procedure dowithchars(what:string11);
var i,j:longint;
begin
  if mem[ROM_KEYFLAGS] and kfSCROLLLOCK=0 then
    dowithchar(what)
  else begin
    cbak:=c;
    if (mx>=188) and ((what='41') or (what='61') or (what='21') or (what='81'))
    then dowithchar(what)
    else for c:=#0 to #255 do dowithchar(what);
    c:=cbak;
  end;
end;  {dowithchars}

var
  filename:string;
  str:TFileStream;
  i,j,k,l,m:longint;
  moving:boolean:=false;
begin
  clearRegs;
  filename:=paramstr(1);
  if fileExists(filename+'.bmf') then filename:=filename+'.bmf';
  scr.init(0,0,0,0);
  bmf.init0; tc.init0; undo.init0; tb.init0; ed.init0;
  if paramstr(2)<>'-create' then begin
    if not fileExists(filename) then die(errFileNotExists);
    str.init(filename);
    if (paramstr(2)='-savequit') or (paramstr(3)='-savequit') then begin
      if paramstr(2)='-fn' then begin
        bmf.loadAsFN(str);
        filename:=system.copy(filename,1,length(filename)-3)+'.bmf';
      end else bmf.load(str);
      if not str.ok then die(errBMFLoad);
      str.done; str.init(filename);
      if bmf.save(str) then i:=0 else i:=2;
      str.truncate;
      bioswriteln(eitherS(i=0,'ok','not ok'));
      str.done; bmf.done;
      die(i);
    end;
  end;
  OpenGFX('320x200x8');
  for i:=0 to 63 do begin
    setRGB(i,i,i,i);
    if i>0 then fontpals[fpMAIN]:=fontpals[fpMAIN]+chr(i);
  end;
  for i:=0 to 4 do begin
    setRGB(240+i,3+i*6,3+i*8,3+i*15); fontpals[fpBLUE]:=fontpals[fpBLUE]+chr(240+i);
    setRGB(245+i,3+i*8,3+i*15,3+i*8); fontpals[fpNORMAL]:=fontpals[fpNORMAL]+chr(245+i);
    setRGB(250+i,3+i*15,3+i*8,3+i*8); fontpals[fpSYSTEM]:=fontpals[fpSYSTEM]+chr(250+i);
  end;
  grayscalepal(32);
  fillpal;
  if paramstr(2)<>'-create' then begin
    if paramstr(2)='-fn' then begin