{***************************************************************}
{***               FVision Unit Version1.0                   ***}
{***                    蓝蚂蚁工作室                         ***}
{***************************************************************}
{***                    文字显示单元                         ***}
{***************************************************************}
{$O+,F+,X+,I-}
Unit FWrite;
Interface
Uses
  Dos,FTool,Graph,FGraph,FXmsDrv,FVesa;

Const
  StrLong = 121;

Type
  Hz8 =array[0..15] of Byte;
  Hz16=array[0..31]of Byte;
  AscType=array[0..255] of Hz8;
  AsciiTabPtr=^AscType;
  StringStrLong=string[StrLong];
  ColType=array[1..StrLong] of Byte;

Var
  Hzk16:File;
  StrQu:array[1..89] of Boolean;

function  SetLib(S:string):Boolean;
procedure TsrHzk;
procedure UnTsrHzk;
procedure Writecs(x,y:Integer;S:string;Color:Byte);
procedure WritecMap(x,y:Integer;S:string;Col,ColH:Byte);
procedure WriteShe(x,y:Integer;S:string;Color,ColShe:Byte);
procedure WritecStr(x,y:Integer;S:string;Col,Cols:Byte);
procedure Writec(ox,oy:Integer;S:string;Col:Byte);
procedure Writec16(ox,oy:Integer;S:string;Col:Byte);
procedure Writec16s(x,y:Integer;S:string;Col,Cols:Byte);
procedure Write16(ox,oy,Ind,Len:Integer;S:string;Col:Byte);
procedure CWrite16(ox,oy,Ind,Len:Integer;S:string;Col:ColType);
Implementation
Type
  Node=record xx:array[0..79]of Byte end;
  Screen=array[0..479]of ^Node;
  Wei94=record Wei:array[1..94]of Hz16; end;
  Qu89=array[1..89]of ^Wei94;

var
  Ascii:AsciiTabPtr;
  Scr:Screen;
  Hzk:Qu89;
  HzkName:PathStr;
  HzkInXms:Boolean;

Const
  HzkHandle:Word=0;

procedure SelectRPlane(N:Integer);
begin
  Port[$3CE]:=$04;
  Port[$3CF]:=N;
end;

procedure SelectWPlane(N:Integer);
begin
  Port[$3C4]:=$02;
  Port[$3C5]:=1 shl N;
end;

procedure Build;
var
  i:Integer;
begin
  for i:=0 to 479 do
{r-}Scr[i]:=Ptr($A000,80*i);
end;

function SetLib(S:string):Boolean;
begin
  SetLib:=True;
  HzkName:=S;
  Assign(Hzk16,HzkName);
  Reset(Hzk16,1);
  if IOResult<>0 then
    SetLib:=False;
end;

procedure TsrHzk;
var
  M:LongInt;
  Result:Word;
begin
  if XmsCanUse and (GetXmsSize>300) then
    HzkHandle:=ReadFileToXms(HzkName,0,0,rxEnd);
  if HzkHandle<>0 then
  begin
    Close(Hzk16);
    Exit;
  end;
  for M:=1 to 55 do
  if MaxAvail>94*32 then
  begin
    Seek(Hzk16,94*32*(M-1));
    GetMem(Hzk[M],94*32);
    BlockRead(Hzk16,Hzk[M]^.Wei,94*32,Result);
    StrQu[M]:=True;
  end;
end;

procedure UnTsrHzk;
var
  M:Integer;
begin
  if HzkHandle<>0 then
  begin
    FreeXms(HzkHandle);
    HzkHandle:=0;
  end;
  for M:=1 to 89 do
  if StrQu[M] then
  begin
    FreeMem(Hzk[M],94*32);
    StrQu[M]:=False;
  end;
end;

procedure Read16(Hi,Lo:Char;var Buf:Hz16);
var
  N,Result:Word;
  L:LongInt;
begin
  if HzkHandle<>0 then
  begin
    N:=Word(Byte(Hi)-$A1)*94+(Byte(Lo)-$A1);
    L:=Longint(N) shl 5;
    MoveXms(@Buf,0,Pointer(L),HzkHandle,32);
  end else
  if StrQu[Byte(Hi)-$A0] then
    Buf:=Hzk[Ord(Hi)-$A0]^.Wei[Ord(Lo)-$A0]
  else
  begin
    N:=Word(Byte(Hi)-$A1)*94+(Byte(Lo)-$A1);
    L:=Longint(N) shl 5;
    Seek(Hzk16,L);
    BlockRead(Hzk16,Buf,32,Result);
  end;
end;

Procedure  WriteAscii(x,y:Integer;Ch:Char);
var
  i:Integer;
begin
  for i:=0 to 15 do
  begin
    SetLineStyle(USERBITLN,Ascii^[Byte(Ch),i],NORMWIDTH);
    Graph.Line(X+7,Y+i,X,Y+i);
  end;
end;

procedure Writecs(x,y:Integer;S:string;Color:Byte);
var
  i,y1:Integer;
  Dot_Buffer:Hz16;
begin
  Graph.SetColor(Color);
  i:=1;
  while i<=Length(S) do
  if (Byte(S[i]) in [$A1..$A0+89]) and (i<Length(S))
     and (Byte(S[i+1]) in [$A0..$A0+94]) then
  begin
    Read16(S[i],S[i+1],Dot_Buffer);
    for y1:=0 to 15 do
    begin
      SetLineStyle(USERBITLN,Dot_Buffer[y1*2],NORMWIDTH);
      Graph.Line(x+i*8-1,y+y1,x+i*8-8,y+y1);
      SetLineStyle(USERBITLN,Dot_Buffer[y1*2+1],NORMWIDTH);
      Graph.Line(x+i*8+7,y+y1,x+i*8,y+y1);
    end;
    Inc(i,2);
  end else
  begin
    WriteAscii(x+i*8-8,y,S[i]);
    Inc(i);
  end;
  SetLineStyle(0,0,1);
end;

procedure WritecMap(x,y:Integer;S:string;Col,ColH:Byte);
begin
  Writecs(x+1,y+1,S,Col);
  Writecs(x,y,S,ColH);
end;

procedure WriteShe(x,y:Integer;S:string;Color,ColShe:Byte);
begin
  Writecs(x+1,y,S,ColShe);
  Writecs(x,y,S,Color);
end;

procedure Writec(Ox,Oy:Integer;S:string;Col:Byte);
var
  i,y1:Integer;
  Dot_Buffer:Hz16;
begin
  Ox:=Ox div 8;
  i:=1;
  SelectWPlane(Col);
  while i<=Length(S) do
  if (Byte(S[i]) in [$A1..$A0+89]) and (i<Length(S))
     and (Byte(S[i+1]) in [$A0..$A0+94]) then
  begin
    Read16(S[i],S[i+1],Dot_Buffer);
    for y1:=0 to 15 do
    begin
      Scr[y1+oy]^.Xx[ox+i-1]:=Dot_Buffer[y1*2];
      Scr[y1+oy]^.Xx[ox+i]:=Dot_Buffer[y1*2+1];
    end;
    Inc(i,2);
  end else
  begin
    for y1:=0 to 15 do
    Scr[y1+oy]^.xx[ox+i-1]:=Ascii^[Byte(S[i]),y1];
    Inc(i);
  end;
end;

procedure WriteByte(ox,oy:Integer;var By:Hz8;At:Byte);
var
  i,y1:Byte;
begin
  if Color256Flag then
  begin
    Full(Ox*8,Oy,Ox*8+7,Oy+15,At shr 4);
    for i:=0 to 15 do
    begin
      SetColor(At and $0F);
      SetLineStyle(USERBITLN,By[i],NORMWIDTH);
      Line(Ox*8+7,Oy+i,Ox*8,Oy+i);
      SetLineStyle(0,0,1);
    end;
  end else
  for i:=0 to 3 do
  begin
    SelectWPlane(i);
    if ((At and (1 shl i))<>0) then
    begin
      if (at and (1 shl (i+4))<>0) then
        for y1:=0 to 15 do
        Scr[y1+oy]^.xx[ox]:=$FF
      else
        for y1:=0 to 15 do
        Scr[y1+oy]^.xx[ox]:=By[y1]
    end else
    if (At and (1 shl (i+4))<>0) then
      for y1:=0 to 15 do
      Scr[y1+oy]^.xx[ox]:=not By[y1]
    else
      for y1:=0 to 15 do
      Scr[y1+oy]^.xx[ox]:=0;
  end;
end;

procedure Writec16(ox,oy:Integer;S:string;Col:Byte);
var
  i,j:Integer;
  Hzl,Hzr:Hz8;
  Dot_Buffer:Hz16;
begin
  i:=1;
  while i<=Length(S) do
  if (Byte(S[i]) in [$A1..$A0+89]) and (i<Length(S))
     and (Byte(S[i+1]) in [$A0..$A0+94]) then
  begin
    Read16(S[i],S[i+1],Dot_Buffer);
    for j:=0 to 15 do
    begin
      Hzl[j]:=Dot_Buffer[j*2];
      Hzr[j]:=Dot_Buffer[j*2+1];
    end;
    WriteByte(ox+i-1,oy,Hzl,Col);
    WriteByte(ox+i,oy,Hzr,Col);
    Inc(i,2);
  end else
  begin
    WriteByte(ox+i-1,oy,Ascii^[Byte(S[i])],Col);
    Inc(i);
  end;
end;

procedure Write16(ox,oy,Ind,Len:Integer;S:string;Col:Byte);
var
  i,j:Integer;
  Hzl,Hzr:Hz8;
  Dot_Buffer:Hz16;
begin
  i:=1;
  while i<Ind-1 do
  if (Byte(S[i]) in [$A1..$A0+89])
     and (Byte(S[i+1]) in [$A0..$A0+94]) then
    Inc(i,2)
  else
    Inc(i);
  if i=Ind-1 then
  begin
    if (Byte(S[i]) in [$A1..$A0+87]) and
       (Byte(S[i+1]) in [$A0..$A0+94]) then
    begin
      Read16(S[i],S[i+1],Dot_Buffer);
      for j:=0 to 15 do
      Hzr[j]:=Dot_Buffer[j*2+1];
      WriteByte(ox+i-Ind+1,oy,Hzr,Col);
      Inc(i,2);
    end else
      Inc(i);
  end;
  while i<Ind+Len do
  if (Byte(S[i]) in [$A1..$A0+89]) and (i<Length(S))
     and (Byte(S[i+1]) in [$A0..$A0+94]) then
  begin
    Read16(S[i],S[i+1],Dot_Buffer);
    for j:=0 to 15 do
    begin
      Hzl[j]:=Dot_Buffer[j*2];
      Hzr[j]:=Dot_Buffer[j*2+1];
    end;
    WriteByte(ox+i-Ind,oy,Hzl,Col);
    if i<Ind+Len-1 then
      WriteByte(ox+i-Ind+1,oy,Hzr,Col);
    Inc(i,2);
  end else
  begin
    WriteByte(ox+i-Ind,oy,Ascii^[Byte(S[i])],Col);
    Inc(i);
  end;
end;

procedure CWrite16(ox,oy,Ind,Len:integer;S:string;Col:ColType);
var
  i,j:Integer;
  Hzl,Hzr:Hz8;
  Dot_Buffer:Hz16;
begin
  i:=1;
  while i<Ind-1 do
  if (Byte(S[i]) in [$A1..$A0+89]) and
     (Byte(S[i+1]) in [$A0..$A0+94]) then
    Inc(i,2)
  else
    Inc(i);
  if i=Ind-1 then
  begin
    if (Byte(S[i]) in [$A1..$A0+89]) and
       (Byte(S[i+1]) in [$A0..$A0+94]) then
    begin
      Read16(S[i],S[i+1],Dot_Buffer);
      for j:=0 to 15 do
      Hzr[j]:=Dot_Buffer[j*2+1];
      WriteByte(ox+i-Ind+1,oy,Hzr,Col[i+1]);
      Inc(i,2);
    end else
      Inc(i);
  end;
  while i<Ind+Len do
  if i>Byte(S[0]) then
  begin
    WriteByte(ox+i-Ind,oy,Ascii^[32],Col[i]);
    Inc(i);
  end else
  if (Byte(S[i]) in [$A1..$A0+89]) and (i<Length(S))
     and (Byte(S[i+1]) in [$A0..$A0+94]) then
  begin
    Read16(S[i],S[i+1],Dot_Buffer);
    for j:=0 to 15 do
    begin
      Hzl[j]:=Dot_Buffer[j*2];
      Hzr[j]:=Dot_Buffer[j*2+1];
    end;
    WriteByte(ox+i-Ind,oy,Hzl,Col[i]);
    if i<Ind+Len-1 then
      WriteByte(ox+i-Ind+1,oy,Hzr,Col[i+1]);
    Inc(i,2);
  end else
  begin
    WriteByte(ox+i-Ind,oy,Ascii^[Byte(S[i])],Col[i]);
    Inc(i);
  end;
end;

procedure Writec16s(x,y:Integer;S:string;Col,Cols:Byte);
var
  i,Si:Integer;
  Ts:string;
  Sigs:string[40];
begin
  Si:=Pos('~',S);
  if Si=0 then
    Writec16(x,y,S,Col)
  else
  begin
    Sigs:='';
    i:=Si+1;
    while(i<=Length(S))and(S[i]<>'~') do
    begin
      Sigs:=Sigs+S[i];
      Inc(i);
    end;
    Ts:='';
    i:=1;
    while i<=Length(S) do
    begin
      if S[i]<>'~' then Ts:=Ts+S[i];
      Inc(i);
    end;
    Writec16(x,y,Ts,Col);
    Writec16(x+Si-1,y,Sigs,Cols);
  end;
end;

procedure WritecStr(x,y:Integer;S:string;Col,Cols:Byte);
var
  TempStr:string;
  i,Si:Integer;
  Sign:Boolean;
begin
  Sign:=False;
  TempStr:='';
  for i:=1 to Length(S) do
  if S[i]<>'~' then
    TempStr:=TempStr+S[i];
  Writecs(x,y,TempStr,Col);
  TempStr:='';
  i:=0;
  Si:=0;
  while (i<Length(S)) do
  begin
    Inc(i);
    if Sign and (S[i]<>'~') then TempStr:=TempStr+S[i];
    if S[i]='~' then
    begin
      if Sign then
        Writecs(x+(Si-Length(TempStr))*8,y,TempStr,Cols);
      TempStr:='';
      Sign:=not Sign;
    end else
      Inc(Si);
  end;
end;

var
  R:Registers;
  i:Integer;
begin
  Build;
  HzkInXms:=False;
  HzkHandle:=0;
  for i:=1 to 89 do
  StrQu[i]:=False;
  R.AX:=$1130;
  R.BH:=6;
  Intr($10,R);
  Ascii:=Ptr(R.ES,R.BP);
end.