{***************************************************************}
{***               FVision Unit Version1.0                   ***}
{***                    蓝蚂蚁工作室                         ***}
{***************************************************************}
{***                    图形支持单元                         ***}
{***************************************************************}
{$O+,F+,X+,I-,S-}
Unit FGraph;
Interface
Const
  MaxImgSaveBlock = 20;

Type
  ImageSaveType=record
   Size:array[0..MaxImgSaveBlock-1] of Word;
   Y:array[0..MaxImgSaveBlock-1] of Integer;
  end;

Const
  SVGA256 :Integer= 15;
  Color256Flag:Boolean=False;

Var
  GraphDriver,GraphMode,ErrorCode  :Integer;

Procedure IcCritical;
Procedure IcQuestion;
Procedure IcExcalamation;
Procedure IcInformation;

Procedure Graph_Initialize(Driver,Mode:Integer);
Procedure GraphDrivers;
Function  SaveImage(x1,y1,x2,y2:integer;var size:word):pointer;
Function  SaveImageXms(x1,y1,x2,y2:Integer;var Img:ImageSaveType):Word;
Procedure PutImageXms(x1,y1:Integer;Handle:Word;var Img:ImageSaveType);
Procedure Full(x1,y1,x2,y2,Color:Integer);
Procedure DrawRect(x1,y1,x2,y2,Color:Integer;Sty:Word);
Procedure DrawBroad(x1,y1,x2,y2,Dir:Integer);
Procedure DrawBroadc(x1,y1,x2,y2,Dir:Integer;Color:Byte);
Procedure SignBroad(x1,y1,x2,y2,Dir:Integer);
Procedure SignBroadc(x1,y1,x2,y2,Dir:Integer;Color:Byte);
Procedure TitBroad(x1,y1,x2,y2:Integer;S:string;Col:Byte);
Procedure DoubleBroad(X1,Y1,X2,Y2:Integer);
Procedure DoubleLine(x1,y1,x2,y2:Integer);
Procedure DrawShadow(x1,y1,x2,y2,Wid:Integer);
Implementation
Uses
  Dos,Graph,FTool,FWrite,FXmsDrv,FView;


Procedure IcCritical; external;
{$L CRITICAL.OBJ }
Procedure IcQuestion; external;
{$L QUESTION.OBJ }
Procedure IcExcalamation; external;
{$L EXCLAMAT.OBJ }
Procedure IcInformation; external;
{$L INFORMA.OBJ }

Procedure EgaVgaDriverProc; external;
{$L EGAVGA.OBJ }

Procedure GraphDrivers;
Begin
 if RegisterBGIdriver(@EGAVGADriverProc)<0 then begin
 Writeln('vga: ',GraphErrorMsg(GraphResult));halt(1);end;
End;

Function DetectVGA256 : integer;
begin
  DetectVGA256:=SVGA256;
end;

Procedure Graph_Initialize(Driver,Mode:Integer);
Begin
  GraphDriver:= Driver;
  GraphMode := Mode ;
  Color256Flag:=False;
  if Driver=SVGA256 then
  begin
    GraphDriver:=InstallUserDriver('svga256',@DetectVga256);
    Color256Flag:=True;
  end;
  InitGraph(GraphDriver,GraphMode,ExePath);
  if GraphResult <> grOk then
  Begin
    Writeln('Graphics Error of '+ GraphErrorMsg(GraphDriver));
    Halt(1);
  End;
End;

Function SaveImage(x1,y1,x2,y2:Integer;var Size:Word):Pointer;
Var
  Ima:Pointer;
begin
  Ima:=nil;
  if x2>GetMaxx then x2:=GetMaxx;
  if y2>GetMaxy then y2:=GetMaxy;
  Size:=ImageSize(x1,y1,x2,y2);
  if (GraphResult=0)and(MemAvail>Size) then
  begin
    GetMem(Ima,Size);
    GetImage(x1,y1,x2,y2,Ima^);
  end;
  SaveImage:=Ima;
end;

Function SaveImageXms(x1,y1,x2,y2:Integer;var Img:ImageSaveType):Word;
Var
  Handle:Word;
  Ima:Pointer;
  Size_:Word;
  i,ColBit,SizeY,CurY,CountY:Integer;
  CountSize:Longint;
begin
  if not XmsCanUse then
  begin
    SaveImageXms:=0;
    Exit;
  end;
  if x1<0 then x1:=0;
  if y1<0 then y1:=0;
  if x2>GetMaxx then x2:=GetMaxx;
  if y2>GetMaxy then y2:=GetMaxy;
  if Color256Flag then ColBit:=1024 else ColBit:=2048;
  Size_:=Word(Longint(x2-x1+1)*Longint(y2-y1+1) div ColBit + 3);
  Handle:=MallocXms(Size_);
  for i:=0 to MaxImgSaveBlock-1 do Img.Size[i]:=0;
  if Size_<50 then
  begin
    Img.Y[0]:=0;
    Img.Size[0]:=ImageSize(x1,y1,x2,y2);
    GetMem(Ima,Img.Size[0]);
    GetImage(x1,y1,x2,y2,Ima^);
    MoveXms(nil,Handle,Ima,0,Img.Size[0]);
    FreeMem(Ima,Img.Size[0]);
  end else
  begin
    SizeY:=(y2-y1) div (Size_ div 30);
    if Odd(SizeY) then Inc(SizeY);
    i:=0;
    CountY:=0;
    CountSize:=0;
    while (CountY<y2-y1+1) and (i<MaxImgSaveBlock) do
    begin
      Img.Y[i]:=i*SizeY;
      if CountY+SizeY>y2-y1+1 then
        CurY:=y2-y1+1-CountY
      else
        CurY:=SizeY;
      Img.Size[i]:=ImageSize(x1,y1+CountY,x2,y1+CountY+CurY-1);
      GetMem(Ima,Img.Size[i]);
      GetImage(x1,y1+CountY,x2,y1+CountY+CurY-1,Ima^);
      MoveXms(Pointer(CountSize),Handle,Ima,0,Img.Size[i]);
      FreeMem(Ima,Img.Size[i]);
      Inc(CountSize,Img.Size[i]);
      Inc(CountY,SizeY);
      Inc(i);
    end;
  end;
  SaveImageXms:=Handle;
end;

Procedure PutImageXms(x1,y1:Integer;Handle:Word;var Img:ImageSaveType);
Var
  Ima:Pointer;
  i:Integer;
  CountSize:Longint;
begin
  if (not XmsCanUse) or (Handle=0) then Exit;
  CountSize:=0;
  for i:=0 to MaxImgSaveBlock-1 do
  if Img.Size[i]<>0 then
  begin
    GetMem(Ima,Img.Size[i]);
    MoveXms(Ima,0,Pointer(CountSize),Handle,Img.Size[i]);
    PutImage(x1,y1+Img.Y[i],Ima^,COPYPUT);
    FreeMem(Ima,Img.Size[i]);
    Inc(CountSize,Img.Size[i]);
  end;
end;

Procedure Full(x1,y1,x2,y2,Color:Integer);
begin
  PutPixel(0,0,0);
  SetFillStyle(1,Color);
  Bar(x1,y1,x2,y2);
end;

Procedure DrawRect(x1,y1,x2,y2,Color:Integer;Sty:Word);
begin
  SetColor(Color);
  SetLineStyle(Sty, 0, NormWidth);
  SetWriteMode(1);
  Rectangle(x1,y1,x2,y2);
  SetWriteMode(0);
  SetLineStyle(0, 0, NormWidth);
end;

Procedure DrawBroadc(x1,y1,x2,y2,Dir:Integer;Color:Byte);
Var
  C1,C2,C3:Integer;
Begin
  PutPixel(0,0,0);
  SetLineStyle(SolidLn,0,NormWidth);
  if (Dir=1) then
  Begin c1:=Color; c2:=15; c3:=8; End
  else
  Begin c1:=Color; c2:=8; c3:=15; End;
  SetFillStyle(1,c1);
  Bar (x1+2,y1+2,x2-2,y2-2);
  Setcolor(c2);
  Line(x1,y1,x2,y1);
  Line(x1,y1,x1,y2);
  Line(x1+1,y1+1,x2-1,y1+1);
  Line(x1+1,y1+1,x1+1,y2-1);
  Setcolor(c3);
  Line(x1,y2,x2,y2);
  Line(x2,y1,x2,y2);
  Line(x1+1,y2-1,x2-1,y2-1);
  Line(x2-1,y1+1,x2-1,y2-1);
End;

Procedure DrawBroad(x1,y1,x2,y2,Dir:Integer);
Begin
  DrawBroadc(x1,y1,x2,y2,Dir,7);
End;

Procedure SignBroadc(x1,y1,x2,y2,Dir:Integer;Color:Byte);
Var
  C1,C2,C3:Integer;
Begin
  PutPixel(0,0,0);
  SetLineStyle(SolidLn,0,NormWidth);
  if (Dir=1) then
  Begin c1:=Color; c2:=15; c3:=8; End
  else
  Begin c1:=Color; c2:=8; c3:=15; End;
  SetFillStyle(1,c1);
  Bar (x1+1,y1+1,x2-1,y2-1);
  SetColor(c2);
  Line(x1,y1,x2,y1);
  Line(x1,y1,x1,y2);
  SetColor(c3);
  Line(x1,y2,x2,y2);
  Line(x2,y1,x2,y2);
End;

Procedure SignBroad(x1,y1,x2,y2,Dir:Integer);
Begin
  SignBroadc(x1,y1,x2,y2,Dir,7);
End;

Procedure TitBroad(x1,y1,x2,y2:Integer;S:string;Col:Byte);
begin
  SignBroad(X1,Y1,X2,Y2,0);
  SignBroad(X1+1,Y1+1,X2-1,Y2-1,1);
  if Length(S)>0 then
  begin
   Full(x1+10,y1-8,x1+9+8*length(s),y1+7,7);
   Writecs(x1+10,y1-8,s,Col);
  end;
end;

Procedure DoubleBroad(X1,Y1,X2,Y2:Integer);
Begin
  SignBroad(X1,Y1,X2,Y2,0);
  SignBroad(X1+1,Y1+1,X2-1,Y2-1,1);
end;

Procedure DoubleLine(x1,y1,x2,y2:Integer);
begin
  PutPixel(0,0,0);
  if y1=y2 then
  begin
    SetColor(8);
    Line(x1,y1,x2,y1);
    SetColor(15);
    Line(x1,y1+1,x2,y1+1);
  end else
  begin
    SetColor(8);
    Line(x1,y1,x1,y2);
    SetColor(15);
    Line(x1+1,y1,x1+1,y2);
  end;
end;

Procedure DrawShadow(x1,y1,x2,y2,Wid:Integer);
var
  i,j:Integer;
begin
  for i:=x2+1 to x2+Wid do
  for j:=y1+Wid to y2 do
  if Odd(i+j) then PutPixel(i,j,0);
  for j:=y2+1 to y2+Wid do
  if j<=GroundMaxy then
  for i:=x1+Wid to x2+Wid do
  if Odd(i+j) then PutPixel(i,j,0);
end;

end.