unit graphsys;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}
(***************************************)
(* Copyright (C) 2013, SHIRAISHI Kazuo *)
(***************************************)


interface
uses Types,ExtCtrls,Graphics,LCLType,
     base,MyUtils;

type
  GraphModeType=(ScreenBitMapMode,SizeMetaFileMode,PrtMetaFileMode,PrtDirectMode);
var 
   NextGraphMode:GraphmodeTYpe=ScreenBitmapMode;
var
   AlignTop:boolean=false;
   AdditionalMargin:integer=0;
   MymmWidth:integer=10000;
   MymmHeight:integer=10000;

   var
   BitMapHeight:integer=801;
   BitMapWidth:integer=801;
   FontCharSet:Tfontcharset=1;
   FontSize:longint=10;
   FontName:string;
   FontStyle:TFontstyles;

type
   tjHorizontal=(tjLEFT,tjCENTER,tjRIGHT);
   tjVirtical=(tjTOP,tjCAP,tjHALF,tjBASE,tjBOTTOM);
const
   Hjustification:array[tjHorizontal]of string[6]=('LEFT','CENTER','RIGHT');
   Vjustification:array[tjVirtical]of string[6]=('TOP','CAP','HALF','BASE','BOTTOM');


const
   TextHeightMulti=1.25;

const
   maxcolor=255;
var
   axescolor0:integer=15;
   axescolor:integer=15;

{**********}
{TMyPalette}
{**********}

const
   White=$00FFFFFF;
   Black=$00000000;
   Blue= $00FF0000;
   Green=$0000FF00;
   Red  =$000000FF;
   Cyan =Blue+Green;
   Yellow=Green+Red;
   Magenta=Red+Blue;

type
  TMyPalette=class
     private
        PrivatePaletteNumber :integer ; {0～2}
        function getPal(c:integer):TColor;
        procedure setPal(c:integer; cl:TColor);
        procedure InitMyPalette(n:integer);
     public
        pal: array[0..maxcolor]of TColor;
        PaletteDisabled:boolean;
        function ColorIndex(color:TColor):integer;
        property palette[c:integer]:TColor read getPal write setPal ; default;
        property PaletteNumber :integer read privatePaletteNumber write InitMyPalette;
   end;

  TMyPalette16=array[0..15]of TColor;

const
   MyPalette0:TMyPalette16=(White,Black,Blue,Green,Red,Cyan,Yellow,Magenta,
               clGray,clNavy,clGreen,clTeal,clMaroon,clOlive,clPurple,clSilver);

   MyPalette1:TMyPalette16=(Black,Blue,Green,Cyan,Red,Magenta,Yellow,White,
               clGray,clNavy,clGreen,clTeal,clMaroon,clPurple,clOlive,clSilver);

   MyPalette2:TMyPalette16=(Black,Blue,Red,Magenta,Green,Cyan,Yellow,White,
                  clGray,clNavy,clPurple,clMaroon,clGreen,clTeal,clOlive,clSilver);
var
     MyPalette:TMyPalette;

type
   TAreaStyle=(asHollow, asSolid, asHatch);




{***********}
{ TGraphSys }
{***********}

type
 TBeamMode=(bmRigorous, bmImmortal);
const
 s_Rigorous='RIGOROUS';
 s_Immortal='IMMORTAL';
type
  TLineBuff=Array[0..247]of TPoint;
  PLineBuff=^TLineBuff;



type
 TGraphBase=class
    clip:boolean;
     DVleft,DVright,DVbottom,DVtop:integer;
     DWleft,DWright,DWbottom,DWtop:double;
     VPleft,VPright,VPbottom,VPtop:double;
     DevHeight,DevWidth:integer;
     DevRect:TRect;
     ClipRect:TRect;
     MyRgn:HRGN;
     Canvas1:TCanvas;
     Bitmap1:TBitMap;
     AreaStyleIndex:byte;
     AreaStyle:TAreaStyle;
     iBKmode:integer;
    constructor create;
    procedure setup;
    procedure SetSize1;
    procedure PaintPaintbox;
    procedure start;
    procedure finish;
    procedure clear;
    procedure putpixel(a,b:integer; c:TColor);
    procedure putColor(a,b:integer; c:integer);
    procedure SegmentWinSub(  x1,y1,x2,y2:integer);
    procedure SegmentWin(x1,y1,x2,y2:integer);
    procedure StyledLine(x2,y2:integer);
    procedure SetPenStyle(ps:TPenStyle);
    procedure SetPenWidth(c:integer);
    procedure setHiddenDrawMode(b:boolean);
    procedure SetRasterMode(b:TPenMode);
    function GWidth:double;
    function GHeight:double;
    function textwidth(const s:ansistring):integer;
    function textheight(const s:ansistring):integer;
    function ColorIndexOf(a,b:integer):integer;
    procedure Flood(x,y:integer; cl:TColor);
    procedure FloodFill(x,y:integer; cl:TColor);
    Procedure SetTextBack(bk:integer);
 private
    LineBuff:PLineBuff;
    LineBuffCount:integer;
     procedure setBMPsize(init:boolean);
     procedure InitCoordSub;
     procedure SetDefaultCoordinate;
     procedure makeClipRect;
     procedure setupClipRect;
     procedure PolyLineSub( const Points:array of TPoint);
     procedure LineBuffFlush;
     function OpenFile(const Filename:string):boolean;


end;

var GraphBase:TGraphBase;

type
 TGraphSys=Class

     BeamMode:TBeamMode;
     Hjustify:tjHorizontal;
     Vjustify:tjVirtical;

     left,right,bottom,top:double;

     linecolor,pointcolor,areacolor,textcolor:integer;
     pointstyle:integer;
     PenStyle:TPenStyle;
     linewidth:integer;
     textangle:integer; {度}
     TextHeight0:double;

    constructor create;
    destructor destroy; override;
    function virtualX(vx:integer):double;
    function VirtualY(vy:integer):double;
    function deviceX(x:double):integer;
    function deviceY(y:double):integer;
    function ConvToDeviceX(x:double; var i:integer):boolean;
    function ConvToDeviceY(y:double; var j:integer):boolean;
    procedure SetTextHeight(const x:double);
    function AskTextHeight:double;
    procedure askDeviceSize(var w,h:double; var s:string);
    procedure SetUpCoordinateSubSystem;
    procedure SetViewport(l,r,b,t:double);
    procedure SetDeviceWindow(l,r,b,t:double);
    function SetDeviceViewport(l,r,b,t:double):boolean;
    procedure SetClip(c:boolean);
    //procedure ClearScreen;virtual;
    procedure InitGraphic;
    procedure InitCoordinate;
    procedure SetWindow(l,r,b,t:double);
    procedure plotto(x,y: double);
    procedure putmark(x,y:double);
    procedure PutText(const n,m:double; const s:string);
    procedure GraphText(const n,m:double; const s:string);
    procedure PlotText(const n,m:double; const s:string);
    procedure PlotLetters(const n,m:double; const s:string);

    procedure SetBitmapSize(w,h:integer);virtual;
    function OpenFile(FileName: string):boolean;virtual;
    procedure SaveFile(FileName: string);virtual;

    procedure line(a1,b1,a2,b2:integer; c:integer; ps:TPenStyle; pw:integer); virtual;
    procedure putmark0(a,b:integer; c:TColor; ps:integer);
    procedure setlinecolor(c:integer);
    procedure settextcolor(c:integer);  virtual;
    procedure SetTextFont(name0:AnsiString; size:integer);  virtual;
    procedure AskTextFont(var name1:AnsiString; var size:integer);
    procedure getpoint(var a,b:integer);virtual;
    procedure MoveMouse(a,b:integer);virtual;
    procedure MousePol(var a,b:integer; var l,r:boolean); virtual;
    procedure TextOut(x,y:integer; const s:ansistring; angle:integer);
    procedure TextOutSub(x,y:integer; const s:ansistring; angle:integer);  virtual;


    function setcolormode(s:ansistring):boolean;
    function AskColorMode:Ansistring;
    procedure AskDeviceViewport(var l,r,b,t:double);
    {
    procedure MSPaint( x,y:integer; ac, bc:integer);  virtual;
    procedure MSCircle(x1,y1,x2,y2:integer; lc,ac:integer; f:boolean); virtual;
    procedure MSMoveTo(a,b:integer);virtual;
    procedure MSLineTo(a,b:integer);virtual;
    }
    procedure Polyline(const Points:array of TPoint);
    procedure Polygon(const Points:array of TPoint);
    procedure ColorPolyGon(const Points:array of TPoint; c:integer{色指標});virtual;
    procedure PolyBezier(const Points:array of TPoint);  virtual;

    procedure SetAreaStyle(s:TAreaStyle);
    procedure SetAreaStyleIndex(i:integer);
    procedure SetLineStyle(ps:TpenStyle);
    procedure SetlineWidth(c:integer);
    function SetBeamMode(s:AnsiString):boolean;
    function AskBeamMode:AnsiString;
    function xdirection(const x0,y0:double):integer;

   private
     beam0:boolean;
     latex,latey:integer;
     HMulti,HShift,VMulti,VShift:double;
     TextHeightChanged:boolean;

    procedure start; virtual;abstract;
    procedure segment(x1,y1,x2,y2:integer);
    procedure PolyGonSub(const Points:array of TPoint);
    procedure BezierSub(Canvas:TCanvas; const Points:array of TPoint);
    procedure ProjectiveText(const n,m:double; const s:string; PlotStm:boolean);
    function PixelsPerMeter:double;virtual;abstract;
    procedure SetCanvasTextHeight(const x:double);virtual;
    function GetCanvasTextHeight:double;
    procedure SetBeam(t:boolean);inline;
    public property beam:boolean read Beam0 write SetBeam;

   end;

type

  TScreenBMPGraphSys=class(TGraphSys)
      constructor create;
     //procedure InitCoordSub;  override;
     function PixelsPerMeter:double;override;
     procedure getpoint(var a,b:integer);override;
     procedure MoveMouse(a,b:integer);override;
     procedure MousePol(var a,b:integer; var l,r:boolean); override;
     function OpenFile(FileName: string):boolean;override;
     procedure SaveFile(FileName: string);override;
     procedure SetBitmapSize(w,h:integer); override;
    //procedure Clear;override;

  end;
{
  TMetaPrtGraphSys=class(TGraphSys)
    procedure setupClipRect;override;
   private
    procedure InitCoordSub;  override;
    procedure SetDefaultMargin;
    function PixelsPerMeter:double;override;
  end;
}

 {
  TPrtDirectGraphSys=class(TMetaPrtGraphSys)
    constructor create;
    procedure clear; override;
    procedure start;  override;
    procedure finish; override;
   private
    procedure ClearScreen;override;
  end;
}
var
   ScreenBMPGraphSys:TScreenBMPGraphSys;
   //PrtDirectGraphSys:TPrtDirectGraphSys;
   MyGraphSys : TGraphSys;

{*************}
{miscellaneous}
{*************}

var restrict: function(n:integer):integer;

var
    HiddenDrawMode:boolean = false;
    RepaintRequest:boolean = false;

var
    ForwardPlot:boolean = true;
    GeometricPenOnly:boolean = false;
    TextProblemCoordinate:boolean = false;
var
   invalidCoordinate:boolean=false;

procedure initGraphics;

procedure RepaintExec;

procedure WaitReady;


implementation

uses
Classes, SysUtils, Forms, Math,
Interfaces, LCLIntf,  GraphType, GraphUtil,
Printers, printdlg,
{$IFDEF Windows}
 Winlib,
{$ENDIF}
base2, affine,paintfrm,locatefrm,mythread,GraphQue;

{$MAXFPUREGISTERS Default}
{**********}
{TMyPalette}
{**********}

//var PaletteCriticalSection:TRTLCriticalSection;

function TMyPalette.getPal(c:integer):TColor;
begin
   if PaletteDisabled then
      result:=c
   else
      result:=pal[c and 255] or $2000000
end;


procedure TMyPalette.setPal(c:integer; cl:TColor);
begin
   //EnterCriticalSection(PaletteCriticalSection);
   pal[c and 255]:=cl and $ffffff;
   //LeaveCriticalSection(PaletteCriticalSection);
end;

function TMyPalette.ColorIndex(color:TColor):integer;
var
  i:integer;
begin
  if color=-1 then
     result:=-1
  else
  begin
  color:=color and $ffffff;
  if PaletteDisabled then
     result:=color
  else
     begin
       result:=-1;
       i:=0;
       while i<=maxcolor do
          if Pal[i]=color then
                begin
                  result:=i;
                  break
                end
           else
                inc(i);
     end;
  end;   
end;

procedure TMyPalette.InitMyPalette(n:integer);
var
   i,j,k:integer;
   r,g,b:byte;
   P:^TMyPalette16;
begin
   PaletteDisabled:=false;

   for j:=0 to 63 do
      begin
          r:=255-( ( (j       and 1)*2 + ((j shr 3) and 1))*85);
          g:=255-( (((j shr 1)and 1)*2 + ((j shr 4) and 1))*85);
          b:=255-( (((j shr 2)and 1)*2 + ((j shr 5) and 1))*85);
          Palette[j]:=RGB(r,g,b);
          Palette[j+64]:=RGB(r xor 128,g xor 128 ,b xor 128);
          Palette[j+128]:=RGB(r xor 192,g xor 192 ,b xor 192);
          Palette[j+192]:=RGB(r xor 140,g xor 140 ,b xor 143);
      end;

   P:=@MyPalette0;
   case n of
     0: ;
     1:P:=@MyPalette1;
     2:P:=@MyPalette2;
   end;

   for i:=0 to 15 do
   begin
       k:=self.ColorIndex(P^[i]);
       for j:=k downto i+1 do
              Palette[j]:=Palette[j-1];
       Palette[i]:=P^[i];
   end;

(*
   for i:=16 to 255 do
      begin
          Palette[i]:=(i mod 7)*42 + (i mod 6)*51 *256 + (i mod 5)*63 * 65536;
          //Palette[i]:=(i mod 7)*42 + (i mod 4)*85 *256 + (i mod 3)*127 * 65536;
      end;
*)


end;

{********************}
{BitMap GetPixelColor}
{********************}
type TColorRec=packed record
     red,green,blue,spare:byte
end;
type TPixelData=array[0..3]of byte;
     PPixeldata=^TPixelData;

function GetPixelColor(BitMap1:TBitmap; x,y:integer):TColor;
var
   RawImage: TRawImage;
   PixelPtr:PPixelData;
   PixelData:TColorRec;
   redIx,greenIx,blueIx:byte;
   BytePerPixel: byte;
begin
  if bitmap1.PixelFormat=pf24bit then
   begin
      with Bitmap1 do                                             //2014.1.1
        if (x<0) or (y<0) or (x>=width) or (y>=height) then
           begin result:=-1; exit end;

     RawImage := Bitmap1.RawImage;
     PixelPtr:=PPixelData(RawImage.Data);
     with  RawImage.Description do
       begin
         BytePerPixel:=BitsPerPixel div 8;
         Inc(PByte(PixelPtr),BytesPerLine * y + BytePerPixel * x);
         RedIx  :=RedShift div 8;
         GreenIx:=GreenShift div 8;
         BlueIx :=BlueShift div 8;
         if ByteOrder=riboMSBFirst then
             begin
               RedIx:=BytePerPixel-1-RedIx;
               GreenIx:=BytePerPixel-1-GreenIx;
               BlueIx:=BytePerPixel-1-BlueIx;
             end;
         Pixeldata.red:=PixelPtr^[RedIx];
         Pixeldata.green:=PixelPtr^[GreenIx];
         Pixeldata.blue:=PixelPtr^[BlueIx];
         PixelData.spare:=0;
       end;
     result:=TColor(PixelData);
   end
  else
    result:=bitmap1.Canvas.Pixels[x,y];
end;

{**********}
{TGraphBase}
{**********}
constructor TGraphBase.create;
begin
  inherited create;
  BitMap1:= TBitMap.Create;
  Canvas1:=Bitmap1.Canvas;
  DWleft:=0;
  DWright:=1;
  DWbottom:=0;
  DWtop:=1;
  VPleft:=0;
  VPright:=1;
  VPbottom:=0;
  VPtop:=1;

  clip:=true;
  iBKmode:= TRANSPARENT;


end;


{*********}
{TGraphSys}
{*********}

constructor TGraphSys.create;
begin
   inherited create;
   left:=0;
   right:=1;
   bottom:=0;
   top:=1;

   Hjustify:=tjLEFT;
   Vjustify:=tjBOTTOM;
   HMulti:=1;
   VMulti:=1;

end;

constructor TScreenBMPGraphSys.create;
begin
  inherited create;


end;

procedure TGraphBase.setup;
// MyThread.createから呼ばれて，set upを完了させる。

begin
 SetSize1;
 SetBMPsize(true);
 //MyPalette.PaletteDisabled:=false;
end;

procedure TGraphBase.SetSize1;
begin
     if BmpSize >=BMP321 then
        begin
          case BmpSize of
             BMP321:  BitMapHeight:= 321;
             BMP401:  BitMapHeight:= 401;
             BMP501:  BitMapHeight:= 501;
             BMP641:  BitMapHeight:= 641;
             BMP801:  BitMapHeight:= 801;
             BMP1001: BitMapHeight:=1001;
             BMP1281: BitMapHeight:=1281;
             BMP1601: BitMapHeight:=1601;
             BMP2001: BitMapHeight:=2001;
          end;
          BitMapWidth:=BitMapHeight;
        end
     else
        begin
          BitMapWidth:=640;
          case BmpSize of
             BMPpc9801: BitMapHeight:=400;
             BMPdosv: BitMapHeight:=480;
          end;
        end;
 end;

procedure TGraphBase.setBMPsize(init:boolean);
var
     NewRect:TRect;
begin
  with Bitmap1 do
            begin
                width:=bitmapwidth;
                height:=bitmapHeight;
                NewRect:=Rect(0,0,width,Height);
                Canvas.Brush.color:=MyPalette[0];
            end;
  if init then
    begin
       Bitmap1.Canvas.FillRect(NewRect);
       with Canvas1.font do
            begin
              CharSet:=FontCharSet;
              Size:=FontSize;
              Name:=FontName;
              Style:=TFontStyles(FontStyle)
            end;
   end;

  HiddenDrawMode:=false;

end;

{
constructor TPrtDirectGraphSys.create;
begin
   inherited create;
   //Canvas1:=printer.Canvas;
end;
}

destructor TGraphSys.destroy;
begin
   inherited destroy
end;



procedure SetFont(y,x:TFont);
begin
   y.Charset:=x.Charset;
   y.Color:=x.Color;
   y.Name:=x.Name;
   y.Style:=x.Style;
   y.Size:=x.Size;
end;


procedure TGraphBase.start;
begin

end;

(*
procedure TPrtDirectGraphSys.start;
begin


   MyPalette.PaletteNumber:=0;
   {todo 1 printer}

   with TPrintDialog1.create(application.mainform) do
     begin
       cancelButton.Visible:=false;
       ShowModal;
       free;
     end;
   
   printer.BeginDoc;
   Canvas1:=printer.Canvas;
   Canvas1.Font.PixelsPerInch:=Printer.XDPI;
   
end;
*)

//var
//   SetWindowCriticalSection:TRtlCriticalSection;
//   ClipRectCriticalSection :TRtlCriticalSection;




procedure TGraphBase.PaintPaintbox;
begin

      repeat until Canvas1.tryLock;
      PaintForm.PaintBox1.Canvas.Draw(0,0,BitMap1);
      Canvas1.Unlock;

end;


procedure TGraphBase.finish;
begin
  RepaintRequest:=false;
  LineBuffFlush;
  SelectClipRgn(Canvas1.Handle,0);
  DeleteObject(MyRgn);
  MyRgn:=0;
  HiddenDrawMode:=false;
  PaintForm.Repaint;

end;
(*
procedure TPrtDirectGraphSys.finish;
begin
  LineBuffFlush;
{todo 1 printer}

  with printer do
   if printing then
     begin
        SelectClipRgn(Canvas1.Handle,0);
        DeleteObject(MyRgn);
        MyRgn:=0;
        EndDoc;
     end;

end;
*)

procedure TGraphBase.clear;
var
    NewRect:TRect;
    svBrushColor:TColor;
begin
  LineBuffFlush;
  SelectClipRgn(Canvas1.Handle,0);
  NewRect:=Rect(0,0,DevWidth+1,DevHeight+1);
  with Canvas1 do
    begin
      svBrushColor:=Brush.Color;
      Brush.color:=Mypalette.pal[0] ;
      FillRect(NewRect);
      Brush.Color:=svBrushColor;
    end;
  SelectClipRgn(Canvas1.Handle,MyRgn);
 end;



procedure TGraphSys.initGraphic;
begin
   MyPalette.PaletteDisabled:=false;
   TextHeightChanged:=false;

  // start;
    GraphBase.clip:=true;

    linecolor:=1;
    pointcolor:=1;
    areacolor:=1;
    textcolor:=1;
    penstyle:=psSolid;
    pointstyle:=3;
    TextHeight0:=0.01;
    TextAngle:=0;
    axescolor:=axescolor0;
    Hjustify:=tjLEFT;
    Vjustify:=tjBOTTOM;
    BeamMode:=bmRigorous;
    HiddenDrawMode:=false;
    GraphBase.AreaStyle:=asSolid;
    GraphBase.AreaStyleIndex:=1;
    linewidth:=1;

   InitCoordinate ;

   setlinecolor(linecolor);
   settextcolor(textcolor);
   with GraphBase do setpenstyle(penstyle);
   with GraphBase do SetPenWidth(linewidth);
   GraphBase.setRasterMode(pmCopy);


end;

procedure TGraphSys.InitCoordinate;
begin
    with GraphBase do
    begin
    VPleft:=0; VPright:=1; VPbottom:=0; VPtop:=1;
    DWleft:=0; DWright:=1; DWbottom:=0; DWtop:=1;
    end;
    GraphBase.InitCoordSub;

    if permitMicrosoft then
      with GraphBase do SetWindow(0,GWidth,GHeight,0)
    else
      SetWindow(0,1,0,1)
end;

procedure TGraphSys.SetWindow(l,r,b,t:double);
begin
    //EnterCriticalSection(SetWindowCriticalSection);
    beam:=false;
    invalidCoordinate:=true;
      left:=l;
      right:=r;
      bottom:=b;
      top:=t;
      SetUpCoordinateSubSystem;
    invalidCoordinate:=false;
    //LeaveCriticalSection(SEtWindowCriticalSection);
end;

type
    TSetWindow=class(TResetBoolean)
      l,r,b,t:double;
      constructor create(l0,r0,b0,t0:double);
    end;

constructor TSetWindow.create(l0,r0,b0,t0:double);
begin
  inherited create;
  l:=l0;
  r:=r0;
  b:=b0;
  t:=t0;
end;

type
    TSetViewPort=Class(TSetWindow)
      procedure execute;override;
    end;

procedure TSEtViewport.execute;
begin
  with GraphBase do
    begin
      VPleft:=l;
      VPright:=r;
      VPbottom:=b;
      VPtop:=t;
      setupCliprect;
    end;
end;

procedure TGraphSys.SetViewport(l,r,b,t:double);
begin
    //EnterCriticalSection(SetWindowCriticalSection);
    invalidCoordinate:=true;
    beam:=false;
    AddQueueWait(TSetViewPort.create(l,r,b,t));
    SetUpCoordinateSubSystem;
    invalidCoordinate:=false;
    //LeaveCriticalSection(SEtWindowCriticalSection);
end;

type
    TSetDeviceWindow=Class(TSetWindow)
      procedure execute;override;
    end;

procedure TSetDeviceWindow.execute;
begin
  with GraphBase do
    begin
      DWleft:=l;
      DWright:=r;
      DWbottom:=b;
      DWtop:=t;
      setupCliprect;
      clear;
    end;
end;


procedure TGraphSys.SetDeviceWindow(l,r,b,t:double);
begin
   //EnterCriticalSection(SetWindowCriticalSection);
   invalidCoordinate:=true;
   beam:=false;
   AddQueueWait(TSetDeviceWindow.create(l,r,b,t));
   SetUpCoordinateSubSystem;
   invalidCoordinate:=false;
   //LeaveCriticalSection(SEtWindowCriticalSection);
   //clearScreen;
end;


procedure TGraphBase.InitCoordSub;
begin
    //inherited InitCoordSub;
    DevWidth:=BitMap1.width-1;
    DevHeight:=Bitmap1.Height-1;

    DVleft:=0;
    DVright:=DevWidth;
    DVbottom:=0;
    DVtop:=DevHeight;

    SetDefaultCoordinate;
    setUpClipRect;
end;

{
procedure TMetaPrtGraphSys.InitCoordSub;
begin
    //inherited initCoordsub;

    DevWidth:=printer.PageWidth-1-2;
    DevHeight:=printer.PageHeight-1-2;

    DVleft:=0;
    DVright:=DevWidth;
    DVbottom:=0;
    DVtop:=DevHeight;

    setDefaultMargin;
    setUpClipRect;
end;
}


procedure TGraphBase.SetDefaultCoordinate;
begin
   DwLeft:=0;
   DwRight:=1;
   DwBottom:=0;
   DwTop:=1;
   if DvRight>=DvTop then
        DwTop:=DvTop/DvRight
   else
        DwRight:=DvRight/DvTop;
   VpLeft:=DwLeft;
   VpRight:=DwRight;
   VpBottom:=DwBottom;
   VpTop:=DwTop;
end;


function intersection(rect1,rect2:TRect):TRect;
begin
   result:=rect2;
   if rect1.left>result.left then result.left:=rect1.left;
   if rect1.right<result.right then result.right:=rect1.right;
   if rect1.top>result.top then result.top:=rect1.top;
   if rect1.bottom<result.bottom then result.bottom:=rect1.bottom;
end;

procedure TGraphBase.makeClipRect;
var
   rect2:TRect;
begin

   {DevRect を装置窓の縦横比に一致させる}

    with DevRect do
      begin
         if (bottom-top)/(right-left)>(DWtop-DWbottom)/(DWright-DWleft) then
            top:=bottom-round((right-left)*(DWtop-DWbottom)/(DWright-DWleft))
         else if (bottom-top)/(right-left)<(DWtop-DWbottom)/(DWright-DWleft) then
            right:=left+round((bottom-top)*(DWright-DWleft)/(DWtop-DWbottom))
      end;

  {ClipRectの設定}
  ClipRect:=DevRect;
  rect2:=ClipRect;
  if clip then
   with ClipRect do
     begin
       Rect2.left:=  left + floor((right- left)*(VPleft -DWleft)/(DWright-DWleft));
       Rect2.right:= left +  ceil((right- left)*(VPright-DWleft)/(DWright-DWleft));
       Rect2.top:=   bottom+floor((top-bottom)*(VPtop   -DWbottom)/(DWtop-DWbottom));
       Rect2.bottom:=bottom +ceil((top-bottom)*(VPBottom-DWbottom)/(DWtop-DWbottom));
     end;
  ClipRect:=intersection(Cliprect,rect2);

end;



procedure TGraphBase.setupClipRect;
begin
  //EnterCriticalSection(ClipRectCriticalSection);
  with GrapHBase do
  begin
  DevRect.left:=DVleft;
  DevRect.right:=DVright;
  DevRect.top:=DevHeight-DVTop;
  DevRect.bottom:=DevHeight-DVBottom;
  makeClipRect;
  //LeaveCriticalSection(ClipRectCriticalSection);


  if MyRgn<>0 then
      begin
         SelectClipRgn(Canvas1.Handle,0);
         DeleteObject(MyRgn);
      end;

  if (ClipRect.left=0) and (ClipRect.Right=DevWidth)
      and (ClipRect.Top=0) and (ClipRect.Bottom=DevHeight)then
     MyRgn:=0
  else
     MyRgn := CreateRectRgn(ClipRect.left, ClipRect.top, ClipRect.right+1, ClipRect.bottom+1) ;

  SelectClipRgn(Canvas1.Handle,MyRgn);
  end;

end;


{
procedure TMetaPrtGraphSys.setupClipRect;
begin
   EnterCriticalSection(ClipRectCriticalSection);
   DevRect.left:=DVleft + 1;
   DevRect.right:=DVright + 1;
   DevRect.top:=DevHeight-DVTop + 1;
   DevRect.bottom:=DevHeight-DVBottom + 1;
   makeClipRect;
   LeaveCriticalSection(ClipRectCriticalSection);

   if MyRgn<>0 then
      begin
         SelectClipRgn(Canvas1.Handle,0);
         DeleteObject(MyRgn);
      end;
   MyRgn := CreateRectRgn(ClipRect.left -1 ,ClipRect.top -1 , ClipRect.right +2 , ClipRect.bottom +2 );

   SelectClipRgn(Canvas1.Handle,MyRgn);
end;


procedure TMetaPrtGraphSys.setDefaultMargin;
var
  dvL,dvR,dvB,dvT,a,h,w:double;
begin
  a:=AdditionalMargin/1000;
  AskDeviceViewport(dvL,dvR,dvB,dvT);
  dvL:=dvL+a;
  dvR:=dvR-a;
  dvB:=dvB+a;
  dvT:=dvT-a;
  if AlignTop then
    begin
      h:=dvT-dvB;
      w:=dvR-dvL;
      if h>w then
         dvB:=dvT-w;
    end;
  setDeviceViewPort(dvL,dvR,dvB,dvT);

end;
}

function TGraphSys.deviceX(x:double):integer;
var
   z:double;
begin
  z:=(x-left)*HMulti+HShift;
  try
     result:=LongIntRound(z);
  except
     {$IFNDEF Windows} RecoverFloatException; {$ENDIF}
     if z>0 then
        result:=maxint
     else
        result:=minint
  end;
end;

function TGraphSys.deviceY(y:double):integer;
var
  z:double;
begin
  z:=(y-bottom)*VMulti+VShift;
  try
     result:=LongIntRound(z);
  except
    {$IFNDEF Windows} RecoverFloatException; {$ENDIF}
     if z>0 then
        result:=maxint
     else
        result:=minint
  end;
end;

function TGraphSys.ConvToDeviceX(x:double; var i:integer):boolean;
var
   z:double;
begin
  z:=(x-left)*HMulti+HShift;
  try
      i:=LongIntRound(z);
      result:=true;
  except
     {$IFNDEF Windows} RecoverFloatException; {$ENDIF}
      result:=false;
      i:=minint
  end;
end;

function TGraphSys.ConvToDeviceY(y:double; var j:integer):boolean;
var
  z:double;
begin
  z:=(y-bottom)*VMulti+VShift;
  try
      j:=LongIntRound(z);
      result:=true;
  except
      {$IFNDEF Windows} RecoverFloatException; {$ENDIF}
      result:=false;
      j:=minint
  end;
end;


procedure TGraphSys.SetUpCoordinateSubSystem;
begin
  with GraphBase do
  try
     HMulti:=(DevRect.right- DevRect.left)/(DWright-DWleft)*(VPright-VPleft)/(right-left);
     HShift:=DevRect.left + (VPleft-DWleft)*(DevRect.right- DevRect.left)/(DWright-DWleft);
     VMUlti:=(DevRect.top- DevRect.bottom)/(DWtop-DWbottom)*(VPtop-VPbottom)/(top-bottom);
     VShift:=DevRect.bottom + (VPbottom-DWbottom)*(DevRect.top- DevRect.bottom)/(DWtop-DWbottom);
     If TextHeightChanged then
        SetCanvasTextHeight(TextHeight0);

  except
      {$IFNDEF Windows} RecoverFloatException; {$ENDIF}
        setexception(SystemErr);
  end;
end;

function TGraphSys.virtualX(vx:integer):double;
begin
   virtualX:=(vx-HShift)/HMulti + left;
end;

function TGraphSys.VirtualY(vy:integer):double;
begin
   virtualY:=(vy-VShift)/VMulti + bottom;
end;



function TGraphBase.GWidth:double;
begin
    result:=DevRect.right-DevRect.Left;
end;

function TGraphBase.GHeight:double;
begin
    result:=DevRect.bottom-DevRect.top;
end;

{***********}
{  PolyGon  }
{***********}
 type
      TColorPolyGonSub=class(TGraphCommand)
       Points:array of TPoint;
       c:TColor;
       constructor create(const p0:Array of TPoint; c0:TColor);
       destructor destroy;override;
       procedure execute;override;
      end;

procedure TGraphSys.Polygon(const Points:array of TPoint);
begin
   PolyGonSub(Points);
end;

procedure ColorPolyGonSub(const Points:array of TPoint; c:integer{色指標});
begin
   AddQueue(TColorPolygonSub.create( Points, MyPalette[c])) ;

end;

procedure TGraphSys.PolyGonSub(const Points:array of TPoint);
begin
  ColorPolyGonSub(Points,areacolor)
end;

procedure TGraphSys.ColorPolyGon(const Points:array of TPoint; c:integer{色指標});
begin
   ColorPolyGonSub(Points,c);
end;



constructor TColorPolygonSub.create( const p0:Array of TPoint; c0:TColor);
var
   i:integer;
begin
  inherited create;
  SetLength(points,length(p0));
  for i:=0 to High(p0)
     do points[i]:=p0[i];
  c:=c0;
end;

 destructor TColorPolyGonSub.destroy;
 begin
   SEtLength(points,0);
   inherited destroy;
 end;

procedure TColorPolygonSub.execute;
var
   svBrushColor:TColor;
   svPenColor:TColor;
   svBrushStyle:TBrushStyle;
   svPenStyle:TpenStyle;
   svPenWidth:integer;
begin
  with GraphBase do
  begin
  //if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
  with Canvas1 do
    begin
     svBrushColor:=Brush.Color;
     svPenColor:=Pen.Color;
     svBrushStyle:=Brush.Style;
     svPenStyle:=Pen.Style;          //2018.12.03
     svPenWidth:=Pen.Width;

     Brush.Color:=c ;
     Pen.Color:=c ;
     pen.width:=1;                   //2008.1.29
     Pen.Style:=psSolid;             //2018.12.03
     case AreaStyle of
       asSolid: Brush.Style:=bsSolid;
       asHollow:Brush.Style:=bsClear;
       asHatch: Brush.Style:=TBrushStyle( AreaStyleIndex + 1);
     end;
     SetBkColor(Canvas1.Handle,MyPalette.pal[0] );
     Polygon(Points);

     Brush.Color:=svBrushColor;
     Pen.Color:=svPenColor;
     Pen.Width:=SvPenWidth;          //2008.1.29
     Brush.Style:=svBrushStyle;
     Pen.Style:= svPenStyle;        //2018.12.03
    end;
   end;
  RepaintRequest:=true;
end;


{**********}
{ PolyLine }
{**********}


procedure TGraphBase.PolyLineSub( const Points:array of TPoint);
begin
   //if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   Canvas1.PolyLine(Points);
 end;

type
      TPolyLineSub=class(TGraphCommand)
       Points:array of TPoint;
       constructor create(  const p0:Array of TPoint);
       procedure execute;override;
       destructor destroy;override;
      end;

 constructor TPolyLineSub.create( const p0:Array of TPoint);
  var
     i:integer;
  begin
    inherited create;
    SetLength(points,length(p0));
    for i:=0 to High(p0)
       do points[i]:=p0[i];
  end;

 destructor TPolyLineSub.destroy;
 begin
   SEtLength(points,0);
   inherited destroy;
 end;

procedure TPolyLineSub.execute;
begin
  GraphBase.PolyLineSub(Points);
end;

procedure TGraphSys.Polyline(const Points:array of TPoint);
begin
 addQueue(TPolyLineSub.create(points));
end;

{**********}
{TextHeight}
{**********}

procedure TGraphSys.SetTextHeight(const x:double);
begin
   TextHeight0:=x;
   SetCanvasTextHeight(x);
   TextHeightChanged:=true;
end;

function TGraphSys.AskTextHeight:double;   //2013.12.21
begin
  if textheightchanged then
     result:=TextHeight0
  else
     result:=GetCanvasTextHeight;
end;

type
     TSetCanvasFontHeight=class(TReSetBoolean)
      i:integer;
      constructor create(i0:integer);
      procedure execute;override;
     end;

constructor TSetCanvasFontHeight.create( i0:integer);
begin
  inherited create;
  i:=i0
end;

procedure TSetCanvasFontHeight.execute;
begin
    GraphBase.Canvas1.Font.height:=i;
    //inherited execute;
end;

procedure TGraphSys.SetCanvasTextHeight(const x:double);
var
   i:integer;
begin
    try
      i:=LongIntRound(abs(VMulti*x*TextHeightMulti));
      if i<=0 then i:=1;               //2007.5.18　
      //Canvas1.Font.height:=-i;
      AddQueueWait( TSetCanvasFontHeight.create(-i));
      TextHeightChanged:=true;
    except
     {$IFNDEF Windows} RecoverFloatException; {$ENDIF}
    end;
end;


function TGraphSys.GetCanvasTextHeight:double;
begin
  with GraphBase do
   result:=abs(-Canvas1.Font.Height)/TextHeightMulti/abs(VMulti)
end;

{*********}
{Text Font}
{*********}


procedure TGraphSys.SetTextFont(name0:AnsiString; size:integer);
begin
  with GraphBase do
  begin
    if length(name0)>0 then
       begin
          Canvas1.Font.Charset:=DEFAULT_CHARSET;
          Canvas1.Font.name:=name0;
       end;
    if size>0 then
       begin
         Canvas1.Font.size:=size;
         TextHeightChanged:=false;    //2013.12.21
       end;
  end;
 end;


procedure TGraphSys.AskTextFont(var name1:AnsiString; var size:integer);
begin
  with GraphBase do
  begin
    name1:=Canvas1.Font.name;
    size:=Canvas1.Font.size
  end;
end;

{*****}
{Pixel}
{*****}

procedure SetPixel(canvas:TCanvas; a,b:integer; c:TColor); inline;
begin
    canvas.Pixels[a,b]:=c;
end;

procedure TGraphBase.putpixel(a,b:integer; c:TColor);
begin
   //if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   setPixel(Canvas1,a,b,c);
end;



procedure TGraphBase.putColor(a,b:integer; c:integer);
var
  c1:TColor;
begin
   c1:=MyPalette[c] ;
   SetPixel(Canvas1,a,b,c1);
end;

type
    TSetColor=class(TGraphCommand)
      col:TColor;
      constructor create(c1:tColor);
    end;

constructor TSetColor.create(c1:tColor);
begin
  inherited create;
  col:=c1;
end;

type
    TSetLineColorSub=class(TSetColor)
      procedure execute;override;
    end;

procedure TSetLineColorSub.execute;
begin
  with GraphBase do
  begin
      LineBuffFlush;
      Canvas1.pen.color:=col;
  end;
end;


procedure TGraphSys.setlinecolor(c:integer);
var
  col:TColor;
begin
    linecolor:=c;
    col:=MyPalette[c] ;
    AddQueue(TSetLineColorSub.create(col))
end;


procedure TGraphSys.settextcolor(c:integer);
begin
    textcolor:=c;
end;


procedure TGraphBase.SetPenStyle(ps:TPenStyle);
begin
    LineBuffFlush;
    Canvas1.pen.style:=ps;
end;

type
  TSetPenStyle=class(TGraphCommand)
    ps:TPenStyle;
    constructor create(ps0:TpenStyle);
    procedure execute;override;
  end;

constructor TSetPenStyle.create(ps0:TpenStyle);
begin
  inherited create;
  ps:=ps0
end;

procedure TSetpenStyle.execute;
begin
    GraphBase.setPenStyle(ps);
end;

procedure TGraphSys.setLineStyle(ps:TpenStyle);
begin
   PenStyle:=ps;
   AddQueue(TSetPenStyle.create(ps))
end;

type
  TSetPenWidth=class(TGraphCommand)
   c:integer;
   constructor create(c0:integer);
   procedure execute;override;
 end;

constructor TSetPenWidth.create(c0:integer);
begin
 inherited create;
 c:=c0
end;

procedure TSetpenWidth.execute;
begin
   GraphBase.setPenWidth(c);
end;

procedure TGraphBase.SetPenWidth(c:integer);
begin
    LineBuffFlush;
    Canvas1.pen.width:=c;
end;


procedure TGraphSys.SetLineWidth(c:integer);
begin
    AddQueue(TSetpenWidth.create(c));
    LineWidth:=c;
end;

Procedure TGraphBase.SetTextBack(bk:integer);
begin
  iBkMode:=bk;
end;

procedure TGraphBase.SetRasterMode(b:TPenMode);
begin
   Canvas1.Pen.Mode:=b;
end;




procedure TGraphBase.setHiddenDrawMode(b:boolean);

begin
   if not (HiddenDrawMode and b) then
      RepaintExec;
   HiddenDrawMode:=b ;
end;






function restrict9x(n:integer):integer;
begin
   if n>16383 then
      result:=16383
   else if n<-16384 then
      result:=-16384
   else
      result:=n
end;

function restrict16(n:longint):integer;
begin
   if n>32767 then
      result:=32767
   else if n<-32768 then
      result:=-32768
   else
      result:=n
end;

function restrictNT(n:longint):integer;    //  2009.4.18  ver 7.3.1
begin
   if n>134217727 then
      result:=134217727
   else if n<-134217728 then
      result:=-134217728
   else
      result:=n
end;

function restrictNone(n:longint):integer;
begin
      result:=n
end;


var
   ShrinkRange: procedure(var lx,ly,vx,vy:integer);

procedure  ShrinkRange9x(var lx,ly,vx,vy:integer);
var
  x,x1,x2,y,y1,y2: double;
begin
  x1:=lx;y1:=ly;x2:=vx;y2:=vy;
  if abs(x2-x1)>=16364 then
     begin
        if x2<x1 then
            begin
                 x:=x1; x1:=x2; x2:=x; y:=y1; y1:=y2; y2:=y;
            end;
        if (x1<-8192) then
           begin
              x:=-8192;y:=round((y2-y1)/(x2-x1)*(x-x1)+y1);
              x1:=x;y1:=y
           end;
        if (x2>8192) then
           begin
              x:=8192;y:=round((y2-y1)/(x2-x1)*(x-x2)+y2);
              x2:=x;y2:=y
           end;
     end;
  if abs(y2-y1)>=16364 then
     begin
        if y2<y1 then
            begin
                 x:=x1; x1:=x2; x2:=x; y:=y1; y1:=y2; y2:=y;
            end;
        if (y1<-8192) then
           begin
              y:=-8192;x:=round((x2-x1)/(y2-y1)*(y-y1)+x1);
              y1:=y;x1:=x
           end;
        if (y2>8192) then
           begin
              y:=8192;x:=round((x2-x1)/(y2-y1)*(y-y2)+x2);
              y2:=y;x2:=x
           end;
     end;
  lx:=round(x1);
  ly:=round(y1);
  vx:=round(x2);
  vy:=round(y2);
end;

procedure  ShrinkRange16(var lx,ly,vx,vy:longint);
var
  x,x1,x2,y,y1,y2: double;
begin
  x1:=lx;y1:=ly;x2:=vx;y2:=vy;
  if abs(x2-x1)>=16364*2 then
     begin
        if x2<x1 then
            begin
                 x:=x1; x1:=x2; x2:=x; y:=y1; y1:=y2; y2:=y;
            end;
        if (x1<-8192*2) then
           begin
              x:=-8192*2;y:=round((y2-y1)/(x2-x1)*(x-x1)+y1);
              x1:=x;y1:=y
           end;
        if (x2>8192*2) then
           begin
              x:=8192*2;y:=round((y2-y1)/(x2-x1)*(x-x2)+y2);
              x2:=x;y2:=y
           end;
     end;
  if abs(y2-y1)>=16364*2 then
     begin
        if y2<y1 then
            begin
                 x:=x1; x1:=x2; x2:=x; y:=y1; y1:=y2; y2:=y;
            end;
        if (y1<-8192*2) then
           begin
              y:=-8192*2;x:=round((x2-x1)/(y2-y1)*(y-y1)+x1);
              y1:=y;x1:=x
           end;
        if (y2>8192*2) then
           begin
              y:=8192*2;x:=round((x2-x1)/(y2-y1)*(y-y2)+x2);
              y2:=y;x2:=x
           end;
     end;
  lx:=round(x1);
  ly:=round(y1);
  vx:=round(x2);
  vy:=round(y2);
end;

procedure  ShrinkRangeNT(var lx,ly,vx,vy:integer);
var
  x,x1,x2,y,y1,y2: double;
begin
  x1:=lx;y1:=ly;x2:=vx;y2:=vy;
  if abs(x2-x1)>=67108864 then
     begin
        if x2<x1 then
            begin
                 x:=x1; x1:=x2; x2:=x; y:=y1; y1:=y2; y2:=y;
            end;
        if (x1<-67108864) then
           begin
              x:=-67108864;y:=round((y2-y1)/(x2-x1)*(x-x1)+y1);
              x1:=x;y1:=y
           end;
        if (x2>67108864) then
           begin
              x:=67108864;y:=round((y2-y1)/(x2-x1)*(x-x2)+y2);
              x2:=x;y2:=y
           end;
     end;
  if abs(y2-y1)>=67108864 then
     begin
        if y2<y1 then
            begin
                 x:=x1; x1:=x2; x2:=x; y:=y1; y1:=y2; y2:=y;
            end;
        if (y1<-67108864) then
           begin
              y:=-67108864;x:=round((x2-x1)/(y2-y1)*(y-y1)+x1);
              y1:=y;x1:=x
           end;
        if (y2>67108864) then
           begin
              y:=67108864;x:=round((x2-x1)/(y2-y1)*(y-y2)+x2);
              y2:=y;x2:=x
           end;
     end;
  lx:=round(x1);
  ly:=round(y1);
  vx:=round(x2);
  vy:=round(y2);
end;

procedure  ShrinkRangeNone(var lx,ly,vx,vy:longint);
begin
  //Do Nothing
end;


type
   longrec=record
       low:word;
       high:smallint;
   end;

function iabs(n:integer):integer;
begin
    if n>=0 then
       iabs:=n
    else
       iabs:=-n;
end;
procedure TGraphBase.SegmentWinSub( x1,y1,x2,y2:integer);
var
   P:array[0..1]of TPoint;
begin
   P[0].X:=x2;
   P[0].Y:=y2;
   P[1].X:=x1;
   P[1].Y:=y1;
   PolyLineSub(P);
end;

procedure TGraphBase.SegmentWin(x1,y1,x2,y2:integer);
// 始点を描かず，終点を描く
begin
  with Canvas1 do
  begin
    if pen.style<>psSolid then SetBkMode(Handle,TRANSPARENT);
    if (x1=x2) and (y1=y2) then
          SetPixel(Canvas1,x1,y1,pen.color)
    else
      begin
         if (  ((longrec(x1).high+1) shr 1)
            or ((longrec(y1).high+1) shr 1)
            or ((longrec(x2).high+1) shr 1)
            or ((longrec(y2).high+1) shr 1) =0)
          and (iabs(x2-x1)<16384) and (iabs(y2-y1)<16384) then
          else
             ShrinkRange(x1,y1,x2,y2);
          if (pen.style=psSolid)
              or not GeometricPenOnly
                 and ((pen.Width=1) and (SetBkMode(Handle,TRANSPARENT)<>0))
                                                                             then
              begin
                 MoveTo(restrict(x2),restrict(y2));
                 LineTo(restrict(x1),restrict(y1));
              end
          else
             SegmentWinSub(x1,y1,x2,y2)
      end;
  end;
end;

type
   TMoveTo=class(TGraphCommand)
     x,y:integer;
     constructor create(x0,y0:integer);
     procedure execute;override;
   end;

constructor TMoveTo.create(x0,y0:integer);
begin
 inherited create;
 x:=x0;y:=y0
end;

procedure TMoveTo.execute;
begin
 with GraphBase do
 begin
       //if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
       Canvas1.MoveTo(x,y);
       SetPixel(Canvas1,x,y,Canvas1.pen.color);
 end;
    repaintRequest:=true;
end;

type
  TSegmentForward=class(TGraphCommand)
    x1,y1,x2,y2:integer;
    constructor create(x10,y10,x20,y20:integer);
    procedure execute;override;
 end;

 constructor TSegmentForward.create(x10,y10,x20,y20:integer);
 begin
   inherited create;
   x1:=x10;y1:=y10;x2:=x20;y2:=y20
 end;

procedure TSegmentForward.execute;
begin
  with GraphBase do
   if Canvas1.pen.style<>psSolid then
   begin
       //if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
       SegmentWinSub(x2,y2,x1,y1)
   end
  else
    begin
       //if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
       Canvas1.LineTo(restrict(x2),restrict(y2)) ;
    end;
    RepaintRequest:=true;
end;

type
  TSegmentWin=Class(TSegmentForward)
    procedure execute;override;
  end;

procedure TsegmentWin.execute;
begin
  with GraphBase do SegmentWin(x1,y1,x2,y2) ;
  RepaintRequest:=true;
end;

procedure TGraphSys.segment(x1,y1,x2,y2:integer);
begin
  if ForwardPLot then   // 始点を描かず，終点を描く
      if not beam then     //if (x1=x2) and (y1=y2) then
         addQueue(TMoveTo.create(restrict(x2),restrict(y2)))
      else
         addQueue(TSegmentForward.create(x1,y1,x2,y2))
  else
    AddQueue(TSegmentWin.create(x1,y1,x2,y2))
end;

type
  TStyledLines=class(TGraphCommand)
    latex,latey,x2,y2:integer;
    constructor create(lx0,ly0,x20,y20:integer);
    procedure execute;override;
  end;

constructor TStyledLines.create(lx0,ly0,x20,y20:integer);
begin
  inherited create;
  latex:=lx0; latey:=ly0; x2:=x20; y2:=y20;
end;

procedure TStyledLines.execute;
begin
  with GraphBase do
  begin
    if (LineBuffCount=0) then
       StyledLine(latex,latey);
    StyledLine(x2,y2);
    repaintRequest:=true;
  end;
end;

procedure TGraphSys.plotto(x,y: double);
var x1,y1,x2,y2:integer;
begin
  x2:=deviceX(x);
  y2:=deviceY(y);
  if PenStyle=psSolid then
     begin
       if beam then
          begin
            x1:=latex;
            y1:=latey
          end
       else
          begin
             x1:=x2;
             y1:=y2
          end;
        segment(x1,y1,x2,y2);
     end
   else
     begin
       if beam then
       addQueue(TStyledLines.create(latex,latey,x2,y2))
    end;
   latex:=x2;
   latey:=y2;
   beam:=true;
end;



procedure TGraphBase.StyledLine(x2,y2:integer);
begin
  {$IFDEF LCLGTK2}
   x2:=restrict(x2);
   y2:=restrict(y2);
  {$ENDIF}
   if LineBuff=nil then New(LineBuff);
   if LineBuffCount>High(TLineBuff) then LineBuffFlush;
   with LineBuff^[LineBuffCount] do
      begin x:=x2; y:=y2 end;
   inc(LineBuffCount);
end;

//var LineBuffCriticalSection: TRtlCriticalSection;
procedure TGraphBase.LineBuffFlush;
begin
  if LineBuffCount>0 then
    begin
       //EnterCriticalSection(LineBuffCriticalSection);
       if LineBuffCount>0 then
          begin
             PolyLineSub(Slice(LineBuff^, LineBuffCount));
             LineBuffCount:=0
          end;
       //LeaveCriticalSection(LineBuffCriticalSection);
    end;
end;

type
  TLineBuffFlush=Class(TGraphCommand)
     procedure execute;override;
  end;

procedure TLineBuffFlush.execute;
begin
   GraphBase.LineBuffFlush;
end;



procedure TGraphSys.setBeam(t:boolean);
begin
  if (beam0=True) and (t=false) then
     addQueue(TLineBuffFlush.create);
  beam0:=t;
end;

type
   TLineSub=class(TGraphCommand)
      a1,b1,a2,b2:integer; cl:TColor; ps:TPenStyle; pw:integer;
      constructor create(a10,b10,a20,b20:integer; cl0:TColor; ps0:TPenStyle; pw0:integer);
      procedure execute;override;
   end;

constructor TLineSub.create(a10,b10,a20,b20:integer; cl0:TColor; ps0:TPenStyle; pw0:integer);
begin
  inherited create;
  a1:=a10; b1:=b10; a2:=a20; b2:=b20; cl:=cl0; ps:=ps0;
end;

procedure TLineSub.execute;
var
   svPenColor:TColor;
   svPenStyle:TPenstyle;
   svWidth:integer;
   svBrushColor:TColor;
begin
 with GraphBase do
  with Canvas1 do
   begin
    svPenColor:=Pen.Color;
    svPenStyle:=Pen.Style;
    svWidth:=Pen.Width;
    svBrushColor:=Brush.Color;
    Pen.Color:=cl;
    Pen.Style:=ps;
    Pen.Width:=pw;
    Brush.Color:=MyPalette.pal[0];
    moveto(a1,b1);
    lineto(a2,b2);
    SetPixel(Canvas1,a2,b2,cl);
    Pen.Color:=svPenColor;
    Pen.Style:=svPenStyle;
    Pen.Width:=svWidth;
    Brush.Color := svBrushColor;   //2013.12.28
   end;
   RepaintRequest:=true;
end;

procedure TGraphSys.line(a1,b1,a2,b2:integer; c:integer; ps:TPenStyle; pw:integer);
var
   cl:TColor;
begin
   cl:=MyPalette[c] ;
   AddQueue(TLineSub.create(a1,b1,a2,b2,cl,ps,pw))
end;

type
 TPutMark0=Class(TGraphCommand)
    a,b:integer;
    c:TColor;
    ps:integer;
   constructor create( a0,b0:integer; c0:TColor; ps0:integer);
   procedure execute;override;
 end;

constructor TPutMark0.create( a0,b0:integer; c0:TColor; ps0:integer);
begin
  inherited create;
  a:=a0; b:=b0; c:=c0; ps:=ps0
end;

procedure TPutMark0.execute;
  procedure put(dx,dy:integer);
  begin
      GraphBase.putPixel(a+dx,b+dy,c)
  end;
begin
  case ps{pointstyle} of
    1:  {･}
               put(0,0);
    2:  {+}
         begin
               put(0,0);
               put(0,1);
               put(0,2);
               put(0,-1);
               put(0 , -2);
               put( -1,0 );
               put( +1,0 );
               put( -2,0 );
               put( +2,0 );
        end;
    3: {*}
        begin
               put(0 ,0 )  ;
               put(0 , +1);
               put(0 , +2);
               put(0 , -1);
               put(0 , -2);
               put( -1, 0);
               put( +1, 0);
               put( -2, +1);
               put( -2, -1);
               put( +2, +1);
               put( +2, -1);
        end;
     4: {o}
        begin
               put( +2, -1);
               put( +2,  0 );
               put( +2, +1);
               put( -2, -1);
               put( -2,  0 );
               put( -2, +1);
               put( -1, +2);
               put( 0 , +2);
               put( +1, +2);
               put( -1, -2);
               put( 0 , -2);
               put( +1, -2);
        end;
     5: {x}
         begin
               put( 0, 0)  ;
               put( -1, +1);
               put( -2, +2);
               put( -1, -1);
               put( -2, -2);
               put( +1, +1);
               put( +2, +2);
               put( +1, -1);
               put( +2, -2);
         end;
     6: {■}
        begin
               put( +1, +1);
               put( +1,  0);
               put( +1, -1);
               put(  0, +1);
               put(  0,  0);
               put(  0, -1);
               put( -1, +1);
               put( -1,  0);
               put( -1, -1);
        end;
     7: {●}
        begin
               put( +2, +1);
               put( +2,  0);
               put( +2, -1);
               put( +1, +2);
               put( +1, +1);
               put( +1,  0);
               put( +1, -1);
               put( +1, -2);
               put(  0, +2);
               put(  0, +1);
               put(  0,  0);
               put(  0, -1);
               put(  0, -2);
               put( -1, +2);
               put( -1, +1);
               put( -1,  0);
               put( -1, -1);
               put( -1, -2);
               put( -2, +1);
               put( -2,  0);
               put( -2, -1);
        end;
  end;
  RepaintRequest:=true;
end;


procedure TGraphSys.putmark0(a,b:integer; c:TColor; ps:integer);
begin
   addQueue(TPutMark0.create(a,b,c,ps))
end;


procedure TGraphSys.putMark(x,y:double);
var
   i,j:integer;
begin
   if ConvToDeviceX(x,i) and ConvToDeviceY(y,j) then    //2009.6.22
      PutMark0(i,j,MyPalette[pointcolor],PointStyle)
end;

type
   PPointlist=^pointlist;
   pointlist=record
        size :integer;
        count:integer;
        list:array[0..8190] of integer;
   end;

function newlist(n:integer):PPointlist;
begin
   GetMem(Pointer(result),sizeof(integer)*(2+n));
   result^.size:=n;
   result^.count:=0;
end;

procedure disposelist(p:PPointlist);
begin
   if p<>nil then FreeMem(pointer(p),sizeof(integer)*(2+p^.size))
end;

procedure insertlist(p:PPointList;n:integer);
var
   i,k:integer;
begin
  with p^ do
    begin
       k:=0;
       while  (k<count) and (list[k]<n) do inc(k);
       for i:=count-1 downto k do list[i+1]:=list[i];
       list[k]:=n;
       inc(count);
    end;
end;

procedure TGraphSys.GetPoint(var a,b:integer);
begin
      Setexception(11140);
end;

procedure TGraphSys.MoveMouse(a,b:integer);
begin
end;

procedure TGraphSys.MousePol(var a,b:integer; var l,r:boolean);
begin
      Setexception(11140);
end;

type
   TGetPoint=Class(TResetBoolean)
    a,b:Pinteger;
    constructor create(var a0,b0:integer);
    procedure execute;override;
end;

constructor TGetPoint.create(var a0,b0:integer);
begin
  inherited create;
  a:=@a0;b:=@b0
end;

procedure TGetPoint.execute;
begin
   with paintform do
    begin
     paintform.getpoint;
     a^:=MouseXIntf; b^:=MouseYIntf;
    end;
end;

procedure TScreenBMPGraphSys.GetPoint(var a,b:integer);
begin
   addQueueWait(TGetPoint.create(a,b) )
end;


type
    TMoveMouse=Class(TGraphCommand)
      a,b:integer;
      constructor create(a0,b0:integer);
      procedure execute;override;
    end;

constructor TMoveMouse.create(a0,b0:integer);
begin
  inherited create;
  a:=a0;  b:=b0;
end;

procedure TMoveMouse.execute;
begin
   with paintform do
     begin
        MouseXIntf:=a; MouseYIntf:=b;
        Paintform.MoveMouse;
     end;
end;

procedure TScreenBMPGraphSys.MoveMouse(a,b:integer);
begin
    addQueue(TMoveMouse.create(a,b))
end;


type
   TMousePoll=Class(TResetBoolean)
    a,b:Pinteger;
    l,r:PBoolean;
    constructor create(var a0,b0:integer; var l0,r0:boolean);
    procedure execute;override;
end;

constructor TMousePoll.create(var a0,b0:integer; var l0,r0:boolean);
begin
  inherited create;
  a:=@a0;b:=@b0 ; l:=@l0; r:=@r0
end;

procedure TMousePoll.execute;
begin
   PaintForm.MousePol(a^,b^,l^,r^)
end;

procedure TScreenBMPGraphSys.MousePol(var a,b:integer; var l,r:boolean);
begin
   //WaitReady;
   //PaintForm.MousePol(a,b,l,r)
  sleep(20);
  addQueueWait(TMousePoll.create(a,b,l,r))
end;

function TGraphBase.ColorIndexOf(a,b:integer):integer;
begin
   //repeat until Canvas1.TryLock;
   ColorIndexOf:=MyPalette.ColorIndex(Canvas1.Pixels[a,b]);
   //Canvas1.Unlock;
end;




function TGraphSys.setcolormode(s:ansistring):boolean;
begin
    result:=true;
    s:=AnsiUpperCase(s);
    if s='NATIVE' then
      if MyPalette.PaletteDisabled=false then
         begin
           MyPalette.PaletteDisabled:=true;
           PointColor:=MyPalette.pal[PointColor] and $ffffff;
           SetLineColor(MyPalette.pal[lineColor] and $ffffff);
           AreaColor:=MyPalette.pal[AreaColor] and $ffffff;
           SetTextColor(MyPalette.pal[textColor] and $ffffff);
           axescolor:=MyPalette.pal[15] and $ffffff;
         end
      else
    else if s='REGULAR' then
      if MyPalette.PaletteDisabled=true then
         begin
           MyPalette.PaletteDisabled:=false;
           PointColor:=1;
           SetLineColor(1);
           AreaColor:=1;
           SetTextColor(1);
           axescolor:=axescolor0
         end
      else
    else
       result:=false;
end;

function TGraphSys.AskColorMode:Ansistring;
begin
    if MyPalette.PaletteDisabled then
       Result:='NATIVE'
    else
       Result:='REGULAR'
end;


procedure TGraphSys.SetBitmapSize(w,h:integer);
begin
      setexception(9102)
end;

type
    TSetBitMapSize=class(TResetBoolean)
     w,h:integer;
     PExtype:PInteger;
     constructor create(w0,h0:integer; var extype:integer);
     procedure execute;override;
    end;

 constructor TSetBitMapSize.create(w0,h0:integer; var extype:integer);
 begin
   inherited create;
   w:=w0;h:=h0;PExtype:=@extype;
 end;

 procedure TSetBitMapSize.execute;
begin
  try
     Bitmapwidth:=w; BitmapHeight:=h;
     GraphBase.SetBMPsize(false);
     paintform.setSize2;
     MyGraphSys.InitCoordinate;         // Ver. 1.2.0.2
     //RepaintRequest:=true;
  except
   PExtype^:=9050;
  end;
end;

procedure TScreenBMPGraphSys.SetBitmapSize(w,h:integer);
var
   extype:integer;
begin
   extype:=0;
   AddQueueWait(TSetBitMapSize.create(w,h,extype));
   //InitCoordinate;       // Ver. 1.2.0.2
end;

procedure TextOutRotate(Canvas: TCanvas; x, y: Integer; const s: AnsiString; a:integer);
var
  lfText: TLOGFONT;
  hfNew, hfOld: HFONT;
begin
{$IFDEF Windows}
  GetObject(Canvas.Font.Handle, sizeof(TLOGFONT), @lfText);
{$ELSE}  // bug or unfinished?
  with lfText do
  begin
     lfHeight:=Canvas.Font.Height;
     lfWidth:=0;
     lfEscapement := a * 10; // 角度
     lfOrientation := lfEscapement;
     lfWeight:=0;
     lfItalic:=0;
     lfUnderline:=0;
     lfStrikeOut:=0;
     lfCharSet:=OEM_CHARSET;
     lfOutPrecision:=OUT_DEFAULT_PRECIS;
     lfClipPrecision:=CLIP_DEFAULT_PRECIS;
     lfQuality:=DEFAULT_QUALITY;
     lfPitchAndFamily:=DEFAULT_PITCH or FF_DONTCARE;
     lfFaceName:=Canvas.Font.Name;
  end;
{$ENDIF}
  try
    hfNew := CreateFontIndirect(lfText);       //This may cause divide by zero error.
    try
        hfOld := SelectObject(Canvas.Handle, hfNew);
        Canvas.TextOut(x, y, s);
      finally
        SelectObject(Canvas.Handle, hfOld);
        DeleteObject(hfNew);
    end;
  except
     Canvas.TextOut(x, y, s);
  end;
end;

type
  TtextoutSub=class(TGraphCommand)
         x, y: Integer;
         s: AnsiString;
         angle:integer; {angle}
         c:TColor;
         Hjustify:tjHorizontal;
         Vjustify:tjVirtical;
         constructor create(x0,y0:integer; const s0:ansistring;
                          a0:integer; c0:TColor;hj0:tjHorizontal;Vj0:tjVirtical);
         procedure execute; override;
     end;

constructor TtextoutSub.create( x0,y0:integer; const s0:ansistring;
                        a0:integer; c0:TColor;hj0:tjHorizontal;Vj0:tjVirtical);
begin
  inherited create;
  x:=x0; y:=y0; s:=s0; angle:=a0;c:=c0; HJustify:=hj0; VJustify:=Vj0;
end;

procedure rotate(var x,y:integer; a:integer);
var
  xx,yy,c,s:single;
begin
  c:=cos(a*PI/180);
  s:=sin(a*Pi/180);
  xx:=x*c + y*s;
  yy:=y*c - x*s;
  x:=System.Round(xx);
  y:=System.Round(yy);
end;

procedure TtextoutSub.execute;
var
  dx,dy:integer;
begin
  case Hjustify of
    tjLEFT:  dx:=1;
    tjCENTER:dx:=-(GraphBase.textwidth(s) div 2);
    tjRIGHT: dx:=-GraphBase.textwidth(s);
  end;
  case Vjustify of
    tjTOP:   dy:=1;
    tjCAP:   dy:=-(GraphBase.textheight(s) div 8);
    tjHALF:  dy:=-(GraphBase.textheight(s) div 2);
    tjBASE:  dy:=-(GraphBase.textheight(s)*7 div 8);
    tjBOTTOM:dy:=-GraphBase.textheight(s);
  end;
  Rotate(dx,dy,angle);
  x:=x+dx;
  y:=y+dy;
  with GraphBase do
   begin
    Canvas1.Font.Color:=c;
    SetBkColor(Canvas1.Handle,MyPalette.pal[0] );
    SetBkMode(Canvas1.Handle,iBkMode);
    textOutRotate(Canvas1,x,y,s,Angle);
   end;
  RepaintRequest:=true;
end;

procedure TGraphSys.textoutSub(x,y:integer; const s:ansistring; angle:integer);
begin
    addQueue(Ttextoutsub.create(x,y,s,angle, MyPalette[textcolor],HJustify, VJustify))
end;


procedure TGraphSys.TextOut(x,y:integer; const s:ansistring; angle:integer);
begin
  TextOutSub(x,y,s,angle);
end;

procedure TGraphSys.PutText(const n,m:double; const s:string);
var
  x,y:integer;
begin
  //x:=restrict(deviceX(n));
  //y:=restrict(deviceY(m));
  if ConvToDeviceX(n,x) and ConvToDeviceY(m,y) then    //2009.6.22
     TextOut(x,y,s,textangle);
end;

function YMulti(const x0,y0:double):double;
var
  x,y,r,dx,dy:double;
begin
  if CurrentTransForm=nil then
     result:=1
   else
     with CurrentTransform do
       begin
          x := x0*xx + y0*xy + xo;
          y := x0*yx + y0*yy + yo;
          r := x0*ox + y0*oy + oo;
          dx:=xy/r - x*oy/r/r;      // xのy0に関する偏微係数
          dy:=yy/r - y*oy/r/r;      // yのy0に関する偏微係数　
          result:=Sqrt(sqr(dx)+sqr(dy))
      end;
end;

function TGraphSys.xdirection(const x0, y0:double):integer;
var
  x,y,r,dx,dy:double;
begin
  if CurrentTransform=nil then
     result:=0
  else
    try
      with CurrentTransform do
       begin
          x := x0*xx + y0*xy + xo;
          y := x0*yx + y0*yy + yo;
          r := x0*ox + y0*oy + oo;
          dx:=xx/r - x*ox/r/r;      // xのx0に関する偏微係数
          dy:=yx/r - y*ox/r/r;      // yのx0に関する偏微係数　
          result:=System.Round(ArcTan2(dy*(-VMulti), dx*HMulti)*180/pi)
       end
    except
      {$IFNDEF Windows} RecoverFloatException; {$ENDIF}
       result:=0
    end;
end;


procedure ProjectiveText(GrpSys:TGraphSys; const n,m:double; const s:string; PlotStm:boolean);
var
   a,b,i,j:integer;
   a0,b0,a1,b1,a2,b2,a3,b3,aMin,aMax,bMin,bMax:integer;
   color,bkcolor,color0,color1:TColor;
   //color00,color01,color02,color10,color11,color12:byte;
   dx,dy:integer;
   TextHeightWhole:double;
   x0,y0,x,y:double;
   rt0,rt1:double;
   px,py,r:double;
   pxmax,pymax:integer;
   svDrawMode:boolean;
   bmp2:TBitMap;
   NewRect:tRect;

   procedure FontToDevice(i,j:integer; var a,b:integer);
   var
      x1,y1:integer;
      x,y,x2,y2:double;
   begin
      x1:=i-dx;
      y1:=j-dy;
      x2:= x1*rt0+y1*rt1;
      y2:=-x1*rt1+y1*rt0;
      y:=y0-y2/bmp2.Height*TextHeightWhole;
      x:=x0+x2/bmp2.Height*TextHeightWhole;
      if PlotStm then currentTransform.transform(x,y);
      a:=GrpSys.DeviceX(x);
      b:=GrpSys.DeviceY(y);
   end;
label Label1;
begin
   //仮想座標系におけるtextheight を求める
  with GraphBase.Canvas1.Font do
    if Height=0 then //bug?
       size:=9;
  {
  if TextProblemCoordinate and not TextHeightChanged then
    TextHeightWhole:=0.01 *TextHeightMulti
  else
    TextHeightWhole:=GetCanvasTextHeight * TextHeightMulti;
  }
  if  GrpSys.TextHeightChanged then                            //2013.12.27
       TextHeightWhole:=GrpSys.TextHeight0 *TextHeightMulti
  else
     if TextProblemCoordinate then
        TextHeightWhole:=0.01 *TextHeightMulti
     else
        TextHeightWhole:=GrpSys.GetCanvasTextHeight *TextHeightMulti ;

  if TextHeightWhole=0 then Exit;

  svDrawMode:=HiddenDrawMode;
  GraphBase.SetHiddenDrawMode(true);

  rt0:=cos(Pi*GrpSys.TextAngle/180);
  rt1:=sin(Pi*GrpSys.TextAngle/180);

  x0:=n;
  y0:=m;
  if PlotStm then currenttransform.invtransform(x0,y0);
  // x0, y0は絵定義の中の仮想座標系における描画開始点

  bmp2:=TBitmap.Create;
  try
    with bmp2 do
      begin
      {$IFDEF windows}
        pixelFormat:=pf1bit;
        Monochrome:=true;
        case Length(s) of
           1.. 15:Height:=2048;
          16.. 31:Height:=1024;
          32.. 63:Height:= 512;
          64..127:Height:= 256;
         128..255:Height:= 128;
          else    Height:=  64;
        end;
      {$ELSE}
        //pixelFormat:=pf16bit;
        case Length(s) of
           1.. 15:Height:= 512;
          16.. 31:Height:= 256;
          32.. 63:Height:= 128;
          64..127:Height:=  64;
         128..255:Height:=  32;
          else    Height:=  16;
        end;
       {$ENDIF}

        Canvas.Font.Assign(GraphBase.Canvas1.Font);

       {$IFNDEF Linux}
        Canvas.Font.Height:=Height;
        Width:=Canvas.TextWidth(s);
       {$ELSE}
         Canvas.Font.Height:=(Height div 16)*9;
         Width:=(Canvas.TextWidth(s) div 8)*9;
       {$ENDIF}

         NewRect:=Rect(0,0,width,Height);
         with Canvas do
            begin
              Brush.color:=clWhite;
              FillRect(NewRect);
            end;
         bkcolor:=GetPixelColor(bmp2,0,0) {Canvas.Pixels[0,0]};

         Canvas.Font.Color:=clBlack;
         //Canvas.Font.Style:=[fsBold];
         Canvas.TextOut(0,0,s);
         case GrpSys.Hjustify of
            tjLEFT:  dx:=0;
            tjCENTER:dx:=width div 2;
            tjRIGHT: dx:=width;
         end;
         case GrpSys.Vjustify of
            tjTOP:   dy:=0;
            tjCAP:   dy:=(height div 8);
            tjHALF:  dy:=(height div 2);
            tjBASE:  dy:=(height * 7) div 8;
            tjBOTTOM:dy:= height -1;
         end;
      end;

Label1:
    FontToDevice(0,0,a0,b0);
    FontToDevice(bmp2.width-1,0,a1,b1);
    FontToDevice(bmp2.width-1,bmp2.Height-1,a2,b2);
    FontToDevice(0,bmp2.Height-1,a3,b3);
    Amin:=min(min(a0,a1),min(a2,a3));
    Amax:=max(max(a0,a1),max(a2,a3));
    Bmin:=min(min(b0,b1),min(b2,b3));
    Bmax:=max(max(b0,b1),max(b2,b3));
    {
    // 文字サイズの下限を定める
    if (AMax-AMin)+(BMax-Bmin)<length(s)+2 then
      begin
        TextHeightWhole:=TextHeightWhole*1.25;
        Goto Label1;
      end;
    }
    FontToDevice(bmp2.width div 2,bmp2.Height div 2,a0,b0);
    if (a0<AMin) or (a0>AMax) or (b0<BMin) or (b0>bmax) then
      begin
        AMin:=0; AMax:=GraphBase.DevWidth-1;
        BMin:=0; BMax:=GraphBase.DevHeight-1;
      end;

    // 描画
    color1:=GraphBase.Canvas1.Font.color;
    color0:=Mypalette.pal[0];      //背景色
    r:=bmp2.Height/TextHeightWhole;
    pxmax:=bmp2.Width-1;
    pymax:=bmp2.Height-1;
    with GraphBase do
    for b:=max(BMin,ClipRect.top)  to Min(Bmax,Cliprect.Bottom) do
      for a:=max(Amin,ClipRect.Left) to Min(AMax,Cliprect.Right) do
        try
             x:=GrpSys.virtualX(a);
             y:=GrpSys.virtualY(b);
             if not PlotStm or currenttransform.invtransform(x,y) then
                begin
                   // この時点で，x,yは絵定義中の仮想座標
                   // x,yが文字の点であるか否かを調べる。
                   py:=(y0-y)*r ;
                   px:=(x-x0)*r ;
                   i:=System.Round(px*rt0 - py*rt1 + dx);
                   j:=System.Round(px*rt1 + py*rt0 + dy);
                   if (0<=j) and (j<=pymax) and (0<=i) and (i<=pxmax) then
                   begin
                      color:=GetPixelColor(bmp2,i,j) {bmp2.Canvas.Pixels[i,j]};
                      if (color<>bkColor) then
                           Canvas1.Pixels[a,b]:=color1
                      else if iBkMode=OPAQUE then
                           Canvas1.Pixels[a,b]:=color0
                   end;
                end;
        except
              on EMathError do
                begin
                 {$IFNDEF Windows} RecoverFloatException; {$ENDIF}
                end ;
              on EInvalidOp do
                begin
                 {$IFNDEF Windows} RecoverFloatException; {$ENDIF}
                end;
        end;
  finally
    bmp2.Free;
    GraphBase.setHiddenDrawMode(SvDrawMode);
  end;
end;

type
  TProjectiveText=Class(TResetBoolean)
    GrpSys:TGraphSys;
    n,m:double;
    s:string;
    PlotStm:boolean;
    constructor create(GrpSys0:TGrapHSys;const n0,m0:double; const s0:string; PlotStm0:boolean);
    procedure execute;override;
  end;

constructor TProjectiveText.create(GrpSys0:TGrapHSys;const n0,m0:double; const s0:string; PlotStm0:boolean);
begin
  inherited create;
  GrpSys:=GrpSys0; n:=n0; m:=m0; s:=s0; PlotStm:=PlotStm0
end;

procedure  TProjectiveText.execute;
begin
  ProjectiveText(GrpSys,n,m,s,PlotStm)
end;

procedure TGraphSys.ProjectiveText(const n,m:double; const s:string; PlotStm:boolean);
begin
   AddQueueWait(TProjectiveText.create(self,n,m,s,PlotStm))
 end;

procedure TGraphSys.GraphText(const n,m:double; const s:string);
begin
  if TextProblemCoordinate then
    ProjectiveText(n,m,s,false)
  else
    PutText(n,m,s)
end;

procedure TGraphSys.PlotText(const n,m:double; const s:string);
begin
 if (CurrentTransForm<>nil)
     and not (currentTransform.IsSimilarPositive and (ABS(1+VMulti/HMulti)<1e-2))
  or TextProblemCoordinate
  or (GraphBase.Canvas1.pen.Mode<>pmCopy) then      //2014.1.6
     ProjectiveText(n,m,s,true)
 else
     PlotLetters(n,m,s)
end;

procedure TGraphSys.PlotLetters(const n,m:double; const s:string);
var
  x,y:integer;
  svTextHeight:double;
begin
  svTextHeight:=GetCanvasTextHeight;
  if TextHeightChanged then
      SetCanvasTextHeight(svTextHeight*ymulti(n,m));
  //x:=restrict(deviceX(n));
  //y:=restrict(deviceY(m));
  if ConvToDeviceX(n,x) and ConvToDeviceY(m,y) then    //2009.6.22
     TextOut(x,y,s,(textangle + XDirection(n,m)) mod 360);
  if TextHeightChanged then
     SetCanvasTextHeight(svTextHeight);
end;




function TGraphBase.textwidth(const s:ansistring):integer;
begin
   textwidth:=Canvas1.textwidth(s)
end;

function TGraphBase.textheight(const s:ansistring):integer;
begin
   textheight:=Canvas1.textheight(s)
end;

function TScreenBMPGraphSys.PixelsPerMeter:double;
begin
  result:=Screen.PixelsPerInch*10000/254;
end;

(*
function TMetaPrtGraphSys.PixelsPerMeter:double;
begin
  { TODO 1 : 要修正 }
    //  result:=Canvas1.Font.PixelsPerInch;
    result:=printer.XDPI*10000/254;
end;
*)

type
   TSetDeviceViewport=class(TResetBoolean)
      l,r,b,t:integer;
      p:PBoolean;
      constructor create(l0,r0,b0,t0:integer; var s0:boolean);
      procedure execute;override;
    end;

constructor TSetDeviceViewport.create(l0,r0,b0,t0:integer; var s0:boolean);
begin
  inherited create;
  l:=l0;
  r:=r0;
  b:=b0;
  t:=t0;
  p:=@s0;
end;

procedure TSetDeviceViewport.execute;
begin
  with GraphBase do
    if (l<r) and (b<t)
        and (l>=0) and (r<=DevWidth)
        and (b>=0) and (t<=DevHeight) then
    begin
      DVleft:=l;
      DVright:=r;
      DVbottom:=b;
      DVtop:=t;
      setupCliprect;
      clear;
      p^:=true;
    end
    else
      p^:=false;
end;

function TGraphSys.SetDeviceViewport(l,r,b,t:double):boolean;
var
  ppm:double;
  l0,r0,b0,t0:integer;
begin
  ppm:=PixelsPerMeter;
  l0:=system.round(l*ppm);
  r0:=system.round(r*ppm);
  b0:=system.round(b*ppm);
  t0:=system.round(t*ppm);
  beam:=false;
  addQueueWait(TSetDeviceViewport.create(l0,r0,b0,t0,result));
  if result then
      setupCoordinatesubsystem;
end;



procedure TGraphSys.askDeviceSize(var w,h:double; var s:string);
var
  ppm:double;
begin
  WaitReady;
  ppm:=PixelsPerMeter;
  w:=GraphBase.DevWidth/ppm;
  h:=GraphBase.DevHeight/ppm;
  s:='METERS';
end;



procedure TGraphSys.AskDeviceViewport(var l,r,b,t:double);
var
  ppm:double;
begin
  WaitReady;
  ppm:=PixelsPerMeter;
  with GraphBase do
  begin
  l:=DVleft/ppm;
  r:=DVright/ppm;
  b:=DVbottom/ppm;
  t:=DVtop/ppm;
  end;
end;


type
  TsetClip=class(TGraphCommand)
     OnOff:Boolean;
     constructor create(s:boolean);
     procedure execute;override;
   end;

constructor TSetClip.create(s:boolean);
begin
  inherited create;
  OnOff:=s;
end;

procedure TSetClip.execute;
begin
   GraphBase.clip:=OnOff;
   GraphBase.setupClipRect;
end;

procedure TGraphSys.SetClip(c:boolean);
begin
  addQueue(TSetclip.create(c));
end;

{
procedure TGraphSys.ClearScreen;
begin
  clear;
end;

procedure TPrtDirectGraphSys.ClearScreen;
begin
end;
}

procedure TGraphSys.BezierSub(Canvas:TCanvas; const Points:array of TPoint);
begin
   with Canvas do
     PolyBezier(Points);
end;

procedure TGraphSys.PolyBezier( const Points:array of TPoint);
begin
   BezierSub(GraphBase.Canvas1,Points);
end;



procedure TGraphSys.SetAreaStyle(s:TAreaStyle);
begin
   GraphBase.AreaStyle:=s;
end;

procedure TGraphSys.SetAreaStyleIndex(i:integer);
begin
   GraphBase.AreaStyleIndex:=i
end;


function TGraphSys.SetBeamMode(s:AnsiString):boolean;
begin
   result:=true;
   s:=AnsiUpperCase(s);
   if s=s_Rigorous then
      BeamMode:=bmRigorous
   else if s=s_Immortal then
      BeamMode:=bmImmortal
   else
      result:=false;
end;

function TGraphSys.AskBeamMode:AnsiString;
begin
   case BeamMode of
      bmRigorous: result:=s_Rigorous;
      else result:=s_Immortal;
   end;

end;

{************}
{FLOOD, PAINT}
{************}



procedure TGraphBase.Flood( x,y:integer; cl:TColor);
var
   svBrushColor:TColor;
begin
   //if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   with Canvas1 do
   begin
   svBrushColor:=Brush.Color;
   Brush.Color:=cl;
   FloodFill(x,y,GetPixelColor(bitmap1,x,y),fsSurface);
   Brush.Color:=svBrushColor;
  end;
end;

procedure TGraphBase.FloodFill( x,y:integer; cl:TColor);
var
   svBrushColor:TColor;
begin
   //if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
with Canvas1 do
 begin
    svBrushColor:=Brush.Color;
    Brush.Color:=cl;
    FloodFill(x,y,Pen.Color,fsBorder);
    Brush.Color:=svBrushColor;
 end;
end;

{***************}
{Microsoft BASIC}
{***************}

(*
procedure TGraphSys.MSLineTo(a,b:integer);
begin
   GraphBase.Canvas1.lineto(a,b);
end;

procedure TGraphSys.MSPaint( x,y:integer; ac, bc:integer);
var
   svBrushColor:TColor;
   BorderColor:TColor;
begin
  with GraphBase do
  begin
   svBrushColor:=Canvas1.Brush.Color;
   Canvas1.Brush.Color:=MyPalette[ac] ;
   BorderColor:=MyPalette[bc] ;
   Canvas1.FloodFill(x,y,BorderColor,fsBorder);
   Canvas1.Brush.Color:=svBrushColor;
   Canvas1.MoveTo(x,y);
  end;
end;

procedure MSCircleSub(Canvas:TCanvas;
                                x1,y1,x2,y2:integer; lc,ac:integer; f:boolean);

var
   svBrushColor,svPenColor:TColor;
   svBrushStyle:TBrushStyle;
begin
 with Canvas do
 begin
   svPenColor:=Pen.Color;
   svBrushColor:=Brush.Color;
   Pen.Color:=MyPalette[lc] ;
   Brush.Color:=MyPalette[ac] ;
   svBrushStyle:=Brush.Style;
   if F then
      Brush.Style:=BSSolid
   else
      Brush.Style:=BSClear;
   Ellipse(x1,y1,x2,y2);
   Pen.Color:=svPenColor;
   Brush.Color:=svBrushColor;
   Brush.Style:=svBrushStyle;
 end;
end;

procedure TGraphSys.MSCircle(x1,y1,x2,y2:integer; lc,ac:integer; F:boolean);
begin
  MSCircleSub(GraphBase.Canvas1,x1,y1,x2,y2,lc,ac,F);
end;

procedure TGraphSys.MSMoveTo(a,b:integer);
begin
   GraphBase.Canvas1.Moveto(a,b);
end;
*)


{***********************}
{**** OPEN and SAVE ****}
{***********************}

function TGraphSys.OpenFile(FileName: string):boolean;
begin
      result:=false;
      setexception(9102)
end;

procedure TGraphSys.SaveFile(FileName: string);
begin
      setexception(9102)
end;



function TGraphbase.OpenFile(const Filename:string):boolean;
 var
   ext:string;
   gra:TGraphic;
 begin
     result:=true;
     ext:=UpperCase( ExtractFileExt(FileName));
     with GraphBase do
     begin
     if ext='' then
           Bitmap1.LoadFromFile(FileName+'.bmp')
     else if (ext='.BMP') then
           Bitmap1.LoadFromFile(FileName)
     else
         begin
            gra:=nil;
            if ext='.PNG' then
                 gra:=TPortableNetworkGraphic.create
            else if (ext='.JPG') or (ext='.JPEG') or (ext='.JPE') then
                 gra:=TJpegImage.Create
            else if (ext='.TIFF') or (ext='.TIF') then
                 gra:=TTiffImage.create
            else if ext='.GIF' then
                 gra:=TGifImage.create
            else if ext='.XPM' then
                 gra:=TPixmap.create
            else
                 result:=false;
            if gra<>nil then
            begin
              gra.LoadFromFile(FileName);
              Bitmap1.assign(gra);
              gra.free;
            end;
         end;
      HiddenDrawMode:=false;
      Bitmapwidth:=Bitmap1.Width;
      BitmapHeight:=Bitmap1.Height;
      paintform.setSize2;
     end;

end;

type
  TOpenFile=class(TResetBoolean)
    FileName: string;
    PExtype:Pinteger;
    constructor create(name0:string; var extype:integer);
    procedure execute;override;
  end;

constructor TOpenFile.create(name0:string; var extype:integer);
begin
  inherited create;
  FileName:=name0;
  PExtype:=@extype;
end;

procedure TOpenFile.execute;
begin
   try
     if  GraphBase.OpenFile(FileName) then
     else
       PExtype^:=9005;
       MyGraphSys.InitCoordinate;         // Ver. 1.2.0.2
   except
       on E:EExtype do
          Pextype^:=E.Extype;
       else
          PExtype^:=9051;
   end;
end;

function TScreenBMPGraphSys.OpenFile(FileName: string):boolean;
var
   extype:integer;
begin
   extype:=0;
   addQueueWait(TOpenFile.create(FileName,extype));
   if extype<>0 then setexception(extype);
   //InitCoordinate;         // Ver. 1.2.0.2
 end;

type
  TSaveFile=class(TOpenFile)
    procedure execute;override;
  end;

procedure TSaveFile.execute;
begin
   try
     if PaintForm.saveFile(FileName) then
     else
       PExtype^:=9005;
   except
       on E:EExtype do
          Pextype^:=E.Extype;
       else
          PExtype^:=9052
   end;
end;

procedure TScreenBMPGraphSys.saveFile(FileName: string);
 var
    extype:integer;
 begin
    extype:=0;
    addQueueWait(TSaveFile.create(FileName,extype));
    if extype<>0 then setexception(extype);

end;

{***********}
{RepaintExec}
{***********}
procedure RepaintExec;
begin
if RepaintRequest then
   begin
     RepaintRequest:=false;
     {$IFDEF Windows}
      PaintForm.PaintBox1Paint(nil);
     {$ELSE}
      PaintForm.RePaint;
      Application.ProcessMessages;
     {$ENDIF}
   end;
 end;
{************}
{InitGraphics}
{************}

procedure initGraphics;
begin
  case NextGraphMode of
    ScreenBitmapMode:
      MyGraphSys:=ScreenBMPGraphSys;
    //PrtDirectMode:
    //  begin
    //  MyGraphSys:=PrtDirectGraphSys ;
    //  end;
    end;
  MyGraphSys.initGraphic;
end;

{*********}
{WaitReady}
{*********}

procedure WaitReady;
begin
    addQueueWait(TReSetBoolean.create);
end;


initialization
   //InitCriticalSection(LineBuffCriticalSection);
   //InitCriticalSection(SetWindowCriticalSection);
   //InitCriticalSection(ClipRectCriticalSection);
   //InitCriticalSection(PaletteCriticalSection);

    MyPalette:=TMyPalette.create;
    MyPalette.PaletteNumber:=0;

    GraphBase:=TGraphBase.create;
    ScreenBMPGraphSys:=TScreenBMPGraphSys.create;
    MyGraphSys:=ScreenBMPGraphSys;
    //PrtDirectGraphSys:=TPrtDirectGraphSys.create;

{$IFDEF Windows}
    restrict:=restrictNT;
    ShrinkRange:=ShrinkRangeNT;
{$ELSE}
  {$IFDEF LCLGtk2}
    restrict:=restrict16;
    ShrinkRange:=ShrinkRange16;
  {$ELSE}
    restrict:=restrictNone;
    ShrinkRange:=ShrinkRangeNone;
  {$ENDIF}
{$ENDIF}



finalization
   //DoneCriticalSection(LineBuffCriticalSection);
   //DoneCriticalSection(SetWindowCriticalSection);
   //DoneCriticalSection(ClipRectCriticalSection);
   //DoneCriticalSection(PaletteCriticalSection);
   ScreenBMPGraphSys.Free;
   //PrtDirectGraphSys.free;
   Graphbase.Free;
   MyPalette.Free;
end.
