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


interface
uses Types,ExtCtrls,Graphics,
     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;


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
 TGraphSys=Class

     beam0:boolean;
     latex,latey:longint;
     BeamMode:TBeamMode;
     clip:boolean;
     Hjustify:tjHorizontal;
     Vjustify:tjVirtical;
     PenStyle:TPenStyle;

     left,right,bottom,top:extended;
     VPleft,VPright,VPbottom,VPtop:extended;
     DWleft,DWright,DWbottom,DWtop:extended;
     DVleft,DVright,DVbottom,DVtop:integer;
     DevRect:TRect;
     ClipRect:TRect;
     MyRgn:LongINT ;

     linecolor,pointcolor,areacolor,textcolor:integer;
     pointstyle:integer;
     textangle:integer; {度}
     linewidth:integer;

     AreaStyleIndex:byte;
     AreaStyle:TAreaStyle;

    constructor create;
    destructor destroy; override;
    function virtualX(vx:integer):extended;
    function VirtualY(vy:integer):extended;
    function deviceX(x:extended):longint;
    function deviceY(y:extended):longint;
    function ConvToDeviceX(x:extended; var i:integer):boolean;
    function ConvToDeviceY(y:extended; var j:integer):boolean;
    function GWidth:extended;
    function GHeight:extended;
    function GetTextHeight:extended;
    procedure setupClipRect; virtual; abstract;
    procedure SetTextHeight(const x:extended);virtual;
    procedure askDeviceSize(var w,h:extended; var s:string);
    procedure clear;                       virtual;
    procedure SetUpCoordinateSubSystem;

    procedure InitGraphic;
    procedure InitCoordinate;
    procedure SetWindow(l,r,b,t:extended);
    procedure SetViewport(l,r,b,t:extended);
    procedure SetDeviceWindow(l,r,b,t:extended);
    function SetDeviceViewport(l,r,b,t:extended):boolean;
    procedure SetClip(c:boolean);
    procedure plotto(x,y: extended);
    procedure putmark(x,y:extended);
    procedure PutText(const n,m:Extended; const s:string);
    procedure GraphText(const n,m:Extended; const s:string);
    procedure PlotText(const n,m:Extended; const s:string);
    procedure PlotLetters(const n,m:Extended; const s:string);

    procedure finish;  virtual;abstract;
    procedure SetBitmapSize(w,h:integer);virtual;
    procedure OpenFile(FileName: string);virtual;
    procedure SaveFile(FileName: string); virtual;
    //procedure saveBMPFile(FileName: string);virtual;
    //procedure SaveEMFFile(FileName:string);virtual;
    //procedure SaveFileFormat(FileName: string; pf:TPixelFormat); virtual;
    //procedure SaveJpegFile(FileName:string; p:integer);virtual;
    //procedure SaveGifFile(FileName:string);virtual;
    procedure putpixel(a,b:longint); virtual;
    procedure line(a1,b1,a2,b2:integer; c:integer; ps:TPenStyle; w:integer); virtual;
    procedure putmark0(a,b:integer);
    procedure setlinecolor(c:integer); virtual;
    procedure settextcolor(c:integer);  virtual;
    procedure SetPenStyle(ps:TPenStyle); virtual;
    procedure setlinewidth(c:integer);   virtual;
    procedure SetTextFont(const name:AnsiString; size:integer);  virtual;
    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;
    procedure SetRasterMode(b:TPenMode);virtual;
    procedure setHiddenDrawMode(b:boolean);virtual;

    function ColorIndexOf(a,b:integer):integer;virtual;
    function setcolormode(s:ansistring):boolean;
    function AskColorMode:Ansistring;
    function textwidth(const s:ansistring):integer;
    function textheight(const s:ansistring):integer;
    procedure AskDeviceViewport(var l,r,b,t:extended);

    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 MSScreen(c:integer);virtual;
    procedure putColor(a,b:longint; c:integer); virtual;

    procedure Flood(x,y:integer);     virtual;
    procedure FloodFill(x,y:integer); virtual;
    procedure Polygon(const Points:array of TPoint); virtual;
    procedure Polyline(const Points:array of TPoint);  virtual;
    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);

    function SetBeamMode(s:AnsiString):boolean;
    function AskBeamMode:AnsiString;

    function xdirection(const x0,y0:extended):integer;
    procedure SetBeam(t:boolean);
    property beam:boolean read beam0 write SetBeam;
    procedure segment(x1,y1,x2,y2:integer); virtual;

   private
     Canvas1:TCanvas;
     HMulti,HShift,VMulti,VShift:extended;
     DevHeight,DevWidth:longint;
     LineBuff:PLineBuff;
     LineBuffCount:integer;

     TextHeightChanged:boolean;
    procedure start; virtual;abstract;
    procedure InitCoordSub;  virtual;
    procedure SetDefaultCoordinate;
    procedure makeClipRect;
    procedure ColorPolyGonSub(Canvas:TCanvas; const Points:array of TPoint; c:integer{色指標});
    procedure PolyGonSub(Canvas:TCanvas; const Points:array of TPoint);
    procedure PolyLineSub(Canvas:TCanvas; const Points:array of TPoint);
    procedure BezierSub(Canvas:TCanvas; const Points:array of TPoint);
    procedure SegmentWinSub(Canvas:TCanvas;  x1,y1,x2,y2:integer);
    procedure SegmentWin(Canvas:TCanvas;  x1,y1,x2,y2:integer);
    procedure SegmentForward(Canvas:TCanvas;  x1,y1,x2,y2:integer);
    procedure StyledLine(x2,y2:integer);
    procedure LineBuffFlush;
    procedure ClearScreen;virtual;
    function PixelsPerMeter:extended;virtual;abstract;
    procedure ProjectiveText(const n,m:Extended; const s:string; PlotStm:boolean);
  end;

type

  TScreenBMPGraphSys=class(TGraphSys)
     Bitmap1:TBitmap;
     {$IFDEF Windows}
     PaintBox1:TPaintBox;
     {$ENDIF}
    procedure setup;
    procedure setupClipRect;override;
    procedure finish; override;

    procedure OpenFile(FileName: string);override;
    procedure saveFile(FileName: string);override;
    //procedure saveBMPFile(FileName: string);override;
    //procedure SaveFileFormat(FileName: string; pf:TPixelFormat);override;
    //procedure SaveJpegFile(FileName:string; p:integer);override;
    //procedure SaveGifFile(FileName:string);override;
    procedure clear; override;
    procedure putpixel(a,b:longint); override;
    procedure line(a1,b1,a2,b2:integer; c:integer; ps:TPenStyle; w:integer); override;
    procedure setlinecolor(c:integer); override;
    procedure settextcolor(c:integer);  override;
    procedure SetPenStyle(ps:TPenStyle); override;
    procedure setlinewidth(c:integer);   override;
    procedure SetTextHeight(const x:extended);override;
    procedure SetTextFont(const name:AnsiString; size:integer);  override;
    procedure TextOutSub(x,y:integer; const s:ansistring; angle:integer);  override;
    procedure getpoint(var a,b:integer);override;
    //function ColorIndexOf(a,b:integer):integer;override;
    procedure MoveMouse(a,b:integer);override;
    procedure MousePol(var a,b:integer; var l,r:boolean); override;
    procedure SetRasterMode(b:TPenMode);override;
    procedure setHiddenDrawMode(b:boolean);override;
    procedure SetBitmapSize(w,h:integer);override;
    procedure MSPaint( x,y:integer; ac, bc:integer);  override;
    procedure MSCircle(x1,y1,x2,y2:integer; lc,ac:integer; f:boolean); override;
    procedure MSMoveTo(a,b:integer);override;
    procedure MSLineTo(a,b:integer);override;
    procedure MSScreen(c:integer);override;
     procedure putColor(a,b:longint; c:integer); override;

    procedure Flood( x,y:integer);     override;
    procedure FloodFill( x,y:integer); override;
    procedure Polygon(const Points:array of TPoint); override;
    procedure Polyline(const Points:array of TPoint);  override;
    procedure PolyBezier(const Points:array of TPoint);  override;
    procedure ColorPolyGon(const Points:array of TPoint; c:integer{色指標});override;
    procedure segment(x1,y1,x2,y2:integer);override;
   private
     procedure start;  override;
     procedure InitCoordSub;  override;
     function PixelsPerMeter:extended;override;
  end;

  TMetaPrtGraphSys=class(TGraphSys)
    procedure setupClipRect;override;
   private
    procedure InitCoordSub;  override;
    procedure SetDefaultMargin;
     function PixelsPerMeter:extended;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:longint):integer;

var
    HiddenDrawMode:boolean = false;
    iBKmode:integer = TRANSPARENT;

var
    ForwardPlot:boolean ={$IFDEF LCLCarbon}true{$ELSE}false{$ENDIF};
    GeometricPenOnly:boolean = false;
    TextProblemCoordinate:boolean=false;
    TextPhysicalCoordinate:boolean = false;

var
   invalidCoordinate:boolean=false;


procedure initGraphics;



implementation

uses Classes, SysUtils, Forms, Math,
{$IFDEF FPC}
 Interfaces, LCLIntf, LCLType, LCLProc,  GraphType,
{$ELSE}
  Windows,
{$ENDIF}
 Printers, printdlg,
 struct,sizedlg,float,paintfrm,colordlg,about,locatefrm,draw;

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


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
   pal[c and 255]:=cl and $ffffff;
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;

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

constructor TGraphSys.create;
begin

   left:=0;
   right:=1;
   bottom:=0;
   top:=1;

   VPleft:=0;
   VPright:=1;
   VPbottom:=0;
   VPtop:=1;

   DWleft:=0;
   DWright:=1;
   DWbottom:=0;
   DWtop:=1;

   clip:=true;

   Hjustify:=tjLEFT;
   Vjustify:=tjBOTTOM;

end;


procedure TScreenBMPGraphSys.setup;
// PaintForm.FormCreateから呼ばれて，set upを完了させる。
begin
   Canvas1:=PaintForm.Bitmap1.Canvas;
   Bitmap1:=PaintForm.Bitmap1;
   {$IFDEF Windows}
   PaintBox1:=PaintForm.PaintBox1;
   {$ENDIF}
end;

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


destructor TGraphSys.destroy;
begin
   if LineBuff<>nil then Dispose(LineBuff);
   inherited destroy
end;

procedure TScreenBMPGraphSys.start;
begin
     TextHeightChanged:=false;
     {$IFNDEF WINDOWS}
     PaintForm.Timer1.enabled:=true;
     {$ENDIF}
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 TPrtDirectGraphSys.start;
begin
   TextHeightChanged:=false;
   MyPalette.PaletteNumber:=0;
   {todo 1 printer}

   with PrintDialog1 do
     begin
       cancelButton.Visible:=false;
       ShowModal;
       cancelButton.Visible:=true;
     end;
   
   printer.BeginDoc;
   Canvas1:=printer.Canvas;
   Canvas1.Font.PixelsPerInch:=Printer.XDPI;
   
end;


procedure TScreenBMPGraphSys.finish;
begin
  LineBuffFlush;
  SelectClipRgn(Canvas1.Handle,0);
  {$IFDEF Windows}
  SelectClipRgn(PaintBox1.Canvas.Handle,0);
  {$ENDIF}
  DeleteObject(MyRgn);
  MyRgn:=0;
  HiddenDrawMode:=false;
  {$IFNDEF WINDOWS}
  PaintForm.Timer1.enabled:=false;
  {$ENDIF}
  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 TScreenBMPGraphSys.Clear;
begin
   LineBuffFlush;

   SelectClipRgn(Canvas1.Handle,0);
   {$IFDEF Windows}
   SelectClipRgn(PaintBox1.Canvas.Handle,0);
   {$ENDIF}
   PaintForm.Clear;
   SelectClipRgn(Canvas1.Handle,MyRgn);
   {$IFDEF Windows}
   SelectClipRgn(PaintBox1.Canvas.Handle,MyRgn);
   {$ENDIF}
end;



procedure TGraphSys.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 TPrtDirectGraphSys.Clear;
begin
   LineBuffFlush;
{todo 1 printer}
   printer.NewPage;
end;

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

   start;

    linecolor:=1;
    pointcolor:=1;
    areacolor:=1;
    textcolor:=1;
    penstyle:=psSolid;
    pointstyle:=3;
    linewidth:=1;
    TextAngle:=0;
    axescolor:=axescolor0;
    Hjustify:=tjLEFT;
    Vjustify:=tjBOTTOM;
    clip:=true;
    BeamMode:=bmRigorous;
    HiddenDrawMode:=false;
    iBKmode:= TRANSPARENT;
    AreaStyle:=asSolid;
    AreaStyleIndex:=1;

   InitCoordinate ;

   setlinecolor(linecolor);
   settextcolor(textcolor);
   setpenstyle(penstyle);
   setlinewidth(linewidth);
   setRasterMode(pmCopy);

end;

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

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

procedure TGraphSys.SetWindow(l,r,b,t:extended);
begin
    beam:=false;
    invalidCoordinate:=true;
      left:=l;
      right:=r;
      bottom:=b;
      top:=t;
      SetUpCoordinateSubSystem;
    invalidCoordinate:=false;
end;

procedure TGraphSys.SetViewport(l,r,b,t:extended);
begin
    beam:=false;
    invalidCoordinate:=true;
      VPleft:=l;
      VPright:=r;
      VPbottom:=b;
      VPtop:=t;
      setupCliprect;
      SetUpCoordinateSubSystem;
    invalidCoordinate:=false;
end;

procedure TGraphSys.SetDeviceWindow(l,r,b,t:extended);
begin
   beam:=false;
   invalidCoordinate:=true;
      DWleft:=l;
      DWright:=r;
      DWbottom:=b;
      DWtop:=t;
      setupCliprect;
      SetUpCoordinateSubSystem;
   invalidCoordinate:=false;
   clearScreen;
end;


procedure TGraphSys.InitCoordSub;
begin
end;

procedure TScreenBMPGraphSys.InitCoordSub;
begin
    //inherited InitCoordSub;
    DevWidth:=PaintForm.BitMap1.width-1;
    DevHeight:=PaintForm.BitMap1.height-1;

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

    SetDefaultCoordinate;
    setUpClipRect;
end;

procedure TMetaPrtGraphSys.InitCoordSub;
begin
    //inherited initCoordsub;

    {ToDo 1 Printer}

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

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

    setDefaultMargin;
    setUpClipRect;
end;



procedure TGraphSys.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 TGraphSys.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 TScreenBMPGraphSys.setupClipRect;
begin
  DevRect.left:=DVleft;
  DevRect.right:=DVright;
  DevRect.top:=DevHeight-DVTop;
  DevRect.bottom:=DevHeight-DVBottom;

  makeClipRect;

  if MyRgn<>0 then
      begin
         SelectClipRgn(Canvas1.Handle,0);
         {$IFDEF Windows}
         SelectClipRgn(PaintBox1.Canvas.Handle,0);
         {$ENDIF}
         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);
  {$IFDEF Windows}
  SelectClipRgn(PaintBox1.Canvas.Handle,MyRgn);
  {$ENDIF}
end;



procedure TMetaPrtGraphSys.setupClipRect;
begin

   DevRect.left:=DVleft + 1;
   DevRect.right:=DVright + 1;
   DevRect.top:=DevHeight-DVTop + 1;
   DevRect.bottom:=DevHeight-DVBottom + 1;

   makeClipRect;

   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:extended;
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 FPUerror:boolean;assembler;
asm
   fstsw  ax
   and    ax, 0Dh
   FCLEX
   jz     @L1
   mov    ax,1
 @L1:
end;

function TGraphSys.deviceX(x:extended):longint;
var
   z:extended;
begin
  z:=(x-left)*HMulti+HShift;

  set8087cw($133f);
  //try
     result:=LongIntRound(z);
  //except
  if FPUError then
     if z>0 then
        result:=maxint
     else
        result:=minint;
  //end;
  set8087cw(controlword);
end;

function TGraphSys.deviceY(y:extended):longint;
var
  z:extended;
begin
  z:=(y-bottom)*VMulti+VShift;

  set8087cw($133f);
  //try
     result:=LongIntRound(z);
  //except
   if FPUError then
       if z>0 then
        result:=maxint
     else
        result:=minint;
  //end;
  set8087cw(controlword)
end;

function TGraphSys.ConvToDeviceX(x:extended; var i:integer):boolean;
var
   z:extended;
begin
  set8087cw($133f);
  z:=(x-left)*HMulti+HShift;
  i:=LongIntRound(z);
  result:=not FPUError;
  set8087cw(controlword);
end;

function TGraphSys.ConvToDeviceY(y:extended; var j:integer):boolean;
var
  z:extended;
begin
  set8087cw($133f);
  z:=(y-bottom)*VMulti+VShift;
  j:=LongIntRound(z);
  result:=not FPUError;
  set8087cw(controlword);
end;



procedure TGraphSys.SetUpCoordinateSubSystem;
begin
  set8087cw($133f);
  //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);
  //except
   if FPUError then
              setexception(SystemErr);
  //end;
  set8087cw(controlword)
end;

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

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



function TGraphSys.GWidth:extended;
begin
    result:=DevRect.right-DevRect.Left;
end;

function TGraphSys.GHeight:extended;
begin
    result:=DevRect.bottom-DevRect.top;
end;


procedure TGraphSys.ColorPolyGonSub(Canvas:TCanvas; const Points:array of TPoint; c:integer);
var
   svBrushColor:TColor;
   svPenColor:TColor;
   svBrushStyle:TBrushStyle;
begin
  if MyRgn<>0 then  SelectClipRgn(Canvas.Handle,MyRgn);

  with Canvas do
  begin
   svBrushColor:=Brush.Color;
   svPenColor:=Pen.Color;
   svBrushStyle:=Brush.Style;

   Brush.Color:=MyPalette[c] ;
   Pen.Color:=MyPalette[c] ;
   pen.width:=1;                   //2008.1.29
   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:=LineWidth;          //2008.1.29
   Brush.Style:=svBrushStyle;
  end;
end;



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




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

procedure TScreenBMPGraphSys.ColorPolyGon(const Points:array of TPoint; c:integer{色指標});
begin
   ColorPolyGonSub(Canvas1,Points,c);
   {$IFDEF Windows}
   if not HiddenDrawMode then
      ColorPolyGonSub(PaintBox1.Canvas,Points,c);
   {$ENDIF}
end;

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

procedure TScreenBMPGraphSys.Polygon(const Points:array of TPoint);
begin
   PolyGonSub(Canvas1,Points);
   {$IFDEF Windows}
   if not HiddenDrawMode then
      PolyGonSub(PaintBox1.Canvas,Points);
   {$ENDIF}
end;


procedure TGraphSys.PolyLineSub(Canvas:TCanvas; const Points:array of TPoint);
begin
   if MyRgn<>0 then  SelectClipRgn(Canvas.Handle,MyRgn);
   with Canvas do
     PolyLine(Points);
end;



procedure TGraphSys.Polyline(const Points:array of TPoint);
begin
   if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   Canvas1.Polyline(Points);
end;

procedure TScreenBMPGraphSys.Polyline(const Points:array of TPoint);
begin
   if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   Canvas1.Polyline(Points);
   {$IFDEF Windows}
   if not HiddenDrawMode then
   begin
       if MyRgn<>0 then  SelectClipRgn(PaintBox1.Canvas.Handle,MyRgn);
       Paintbox1.Canvas.Polyline(Points);
   end;
   {$ENDIF}
end;


procedure TGraphSys.SetTextHeight(const x:extended);
var
   i:integer;
begin
    try
     {$IFDEF ver100}
      i:=System.Round(abs(VMulti*x*TextHeightMulti));
     {$ELSE}
      i:=LongIntRound(abs(VMulti*x*TextHeightMulti));
     {$ENDIF}
      if i<=0 then i:=1;               //2007.5.18　
      Canvas1.Font.height:=-i;
      TextHeightChanged:=true;
    except
    end;
end;



procedure TScreenBMPGraphSys.SetTextHeight(const x:extended);
begin
    inherited SetTextHeight(x);
    {$IFDEF Windows}
    PaintBox1.Canvas.Font.height:=Canvas1.Font.height;
    {$ENDIF}
end;


function TGraphSys.GetTextHeight:extended;
begin
   result:=abs(-Canvas1.Font.Height)/TextHeightMulti/abs(VMulti)
end;


procedure TGraphSys.SetTextFont(const name:AnsiString; size:integer);
begin
    if name<>'' then
       begin
          Canvas1.Font.Charset:=DEFAULT_CHARSET;    //OEM_CHARSET;
          Canvas1.Font.name:=name;
       end;
    if size>0 then
       begin
         Canvas1.Font.size:=size;
         TextHeightChanged:=true;
       end;
end;

procedure TScreenBMPGraphSys.SetTextFont(const name:AnsiString; size:integer);
begin
    inherited SetTextFont(name,size);
{$IFDEF Windows}
    PaintBox1.Canvas.Font.Assign(Canvas1.Font)
{$ENDIF}
end;


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

procedure TGraphSys.putpixel(a,b:longint);
var
   c:TColor;
begin
   if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   
   c:=MyPalette[pointcolor] ;
   With Canvas1 do
        setPixel(Canvas1,a,b,c);
end;

procedure TScreenBMPGraphSys.putpixel(a,b:longint);
var
   c:TColor;
begin
   if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   
   c:=MyPalette[pointcolor] ;
   setPixel(Canvas1,a,b,c);
{$IFDEF WINDOWS}
   if not HiddenDrawMode then
      begin
         if MyRgn<>0 then  SelectClipRgn(PaintBox1.Canvas.Handle,MyRgn);
         with PaintBox1 do
             setPixel(Canvas,a,b,c);
      end
{$ENDIF}
end;


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

procedure TScreenBMPGraphSys.putColor(a,b:longint; c:integer);   //PSET文で使う
var
  c1:TColor;
begin
   c1:=MyPalette[c] ;
   SetPixel(Canvas1,a,b,c1);
{$IFDEF WINDOWS}
  if not HiddenDrawMode then
       with PaintBox1 do
            SetPixel(Canvas,a,b,c1);
{$ENDIF}
end;

(*
procedure TextOutRotate(Canvas: TCanvas; x, y: Integer; const s: AnsiString; a:integer);
begin
    Canvas.Start;
    QPainter_SetBackGroundColor(Canvas.handle, QColor(MyPalette.pal[0]) );
    QPainter_SetBackGroundMode(Canvas.handle,iBkMode);
    QPainter_translate(Canvas.Handle,X,Y);
    QPainter_rotate(Canvas.Handle,-a);
    Canvas.TextOut(0,0,s);
    QPainter_rotate(Canvas.Handle,a);
    QPainter_translate(Canvas.Handle,-X,-Y);
    Canvas.Stop;
end;
*)

(*
procedure TextOutRotate(Canvas: TCanvas; x, y: Integer; const s: AnsiString; a:integer);
begin
     SetBkMode(CanVas.Handle, iBkMode);
    Canvas.TextOut(x,y,s)   //暫定版　角度を無視
end;
*)

procedure TextOutRotate(Canvas: TCanvas; x, y: Integer; const s: AnsiString; a:integer);
var
  lfText: TLOGFONT;
  hfNew, hfOld: HFONT;
begin
  {$IFDEF LclCarbon}    //  bug or unfinshed ?
  FillChar(lfText,SizeOf(TLOGFONT),0);
  lfText.lfHeight:=Canvas.Font.Height;
  {$ENDIF}
  GetObject(Canvas.Font.Handle, sizeof(TLOGFONT), @lfText);

  lfText.lfEscapement := a * 10; // 角度
  lfText.lfOrientation := lfText.lfEscapement;
  hfNew := CreateFontIndirect(lfText);
  hfOld := SelectObject(Canvas.Handle, hfNew);

  Canvas.TextOut(x, y, s);

  SelectObject(Canvas.Handle, hfOld);
  DeleteObject(hfNew);
end;


procedure TGraphSys.textoutSub(x,y:integer; const s:ansistring; angle:integer);
begin
    settextcolor(textcolor);
    SetBkColor(Canvas1.Handle,MyPalette.pal[0] );
    SetBkMode(Canvas1.Handle,iBkMode);
    textOutRotate(Canvas1,x,y,s,Angle);
end;


procedure TScreenBMPGraphSys.TextOutSub(x,y:integer; const s:ansistring; angle:integer);
begin
    if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
    inherited TextOutSub(x,y,s,angle);
{$IFDEF WINDOWS}
    if not HiddenDrawMode then
         PaintBox1.Canvas.Draw(0,0,BitMap1);
{$ENDIF}
end;

procedure TGraphSys.setlinecolor(c:integer);
var
  col:TColor;
begin
    LineBuffFlush;
    linecolor:=c;
    col:=MyPalette[c] ;
    Canvas1.pen.color:=col;
end;

procedure TScreenBMPGraphSys.setlinecolor(c:integer);
begin
  inherited setlinecolor(c);
{$IFDEF WINDOWS}
  PaintBox1.canvas.pen.color:=MyPalette[c];
{$ENDIF}
end;

procedure TGraphSys.settextcolor(c:integer);
begin
    textcolor:=c;
    Canvas1.Font.Color:=MyPalette[textcolor] ;
end;

procedure TScreenBMPGraphSys.settextcolor(c:integer);
begin
    inherited settextcolor(c);
{$IFDEF WINDOWS}
    PaintBox1.canvas.Font.Color:=MyPalette[textcolor] ;
{$ENDIF}
end;

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

procedure TScreenBMPGraphSys.SetPenStyle(ps:TPenStyle);
begin
    inherited SetPenStyle(ps);
{$IFDEF WINDOWS}
    paintbox1.canvas.pen.style:=ps;
{$ENDIF}
end;

procedure TGraphSys.setlinewidth(c:integer);
begin
    LineBuffFlush;
    Canvas1.pen.width:=c;
    LineWidth:=c;
end;

procedure TScreenBMPGraphSys.setlinewidth(c:integer);
begin
    inherited setlinewidth(c);
{$IFDEF WINDOWS}
    paintbox1.canvas.pen.width:=c;
{$ENDIF}
end;

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

procedure TScreenBMPGraphSys.SetRasterMode(b:TPenMode);
begin
     Canvas1.Pen.Mode:=b;
     {$IFDEF WINDOWS}
     PaintBox1.Canvas.Pen.Mode:=b;
     {$ENDIF}
end;


procedure TGraphSys.setHiddenDrawMode(b:boolean);
begin
     //HiddenDrawMode:=b ;
     //if b then setexception(9102);
end;

procedure TScreenBMPGraphSys.setHiddenDrawMode(b:boolean);
begin
     HiddenDrawMode:=b ;
     if not b then
          //PaintBox1.Canvas.Draw(0,0,BitMap1);
          PaintForm.repaint;
end;

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

procedure  ShrinkRange9x(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 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  ShrinkRangeNT(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)>=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;


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

function iabs(n:longint):longint;
begin
    if n>=0 then
       iabs:=n
    else
       iabs:=-n;
end;
procedure TGraphSys.SegmentWinSub(Canvas:TCanvas;  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(Canvas, P);
end;

procedure TGraphSys.SegmentWin(Canvas:TCanvas;  x1,y1,x2,y2:integer);
// 始点を描かず，終点を描く
begin
  if PenStyle<>psSolid then SetBkMode(Canvas.Handle,TRANSPARENT);
  if (x1=x2) and (y1=y2) then
        SetPixel(Canvas,x1,y1,Canvas.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 (PenStyle=psSolid)
            or not GeometricPenOnly
               and ((linewidth=1) and (SetBkMode(Canvas.Handle,TRANSPARENT)<>0))
                                                                           then
            begin
               Canvas.MoveTo(restrict(x2),restrict(y2));
               Canvas.LineTo(restrict(x1),restrict(y1))
            end
        else
           SegmentWinSub(Canvas,x1,y1,x2,y2)
    end;
end;

procedure TGraphSys.segment(x1,y1,x2,y2:integer);
begin
  if ForwardPLot then
    SegmentForward(Canvas1,x1,y1,x2,y2)
  else
    SegmentWin(Canvas1,x1,y1,x2,y2)
end;

procedure TScreenBMPGraphSys.segment(x1,y1,x2,y2:integer);
begin
  if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
  inherited Segment(x1,y1,x2,y2);
{$IFDEF WINDOWS}
  if not HiddenDrawMode then
     begin
         if MyRgn<>0 then  SelectClipRgn(PaintBox1.Canvas.Handle,MyRgn);
         SegmentWin(PaintBox1.Canvas, x1,y1,x2,y2)
     end;
{$ENDIF}
end;


procedure TGraphSys.SegmentForward(Canvas:TCanvas;  x1,y1,x2,y2:integer);
// 始点を描かず，終点を描く
begin
  if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
  if not beam then     //if (x1=x2) and (y1=y2) then
     begin
       Canvas.MoveTo(restrict(x2),restrict(y2));
       SetPixel(Canvas,x2,y2,Canvas.pen.color);
     end
  else if PenStyle<>psSolid then
       SegmentWinSub(Canvas,x2,y2,x1,y1)
  else
    begin
       Canvas.LineTo(restrict(x2),restrict(y2));
      {$IFDEF LCLCarbon}
       SetPixel(Canvas,x2,y2,Canvas.pen.color);
      {$ENDIF}
    end;
end;



(*
procedure TGraphSys.plotto(x,y: extended);
var
   x1,x2,y1,y2:integer;
begin
   x2:=deviceX(x);
   y2:=deviceY(y);
   if beam then
      begin
        x1:=latex;
        y1:=latey
      end
   else
      begin
         x1:=x2;
         y1:=y2
      end;
   segment(x1,y1,x2,y2);
   latex:=x2;
   latey:=y2;
   beam:=true;
end;
*)

procedure TGraphSys.plotto(x,y: extended);
var
   x1,x2,y1,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 and (LineBuffCount=0) then
          StyledLine(latex,latey);
       StyledLine(x2,y2);
     end;
   latex:=x2;
   latey:=y2;
   beam:=true;
end;

procedure TGraphSys.StyledLine(x2,y2:integer);
begin
   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;

procedure TGraphSys.LineBuffFlush;
begin
  if LineBuffCount>0 then
    begin
       PolyLine(Slice(LineBuff^, LineBuffCount));
       LineBuffCount:=0
    end;
end;

procedure TGraphSys.setBeam(t:boolean);
begin
  if t=false then
     LineBuffFlush;
  beam0:=t;
end;

procedure LineSub(Canvas:TCanvas; a1,b1,a2,b2:integer; cl:TColor; ps:TPenStyle; w:integer);
var
   svPenColor:TColor;
   svPenStyle:TPenstyle;
   svWidth:integer;
   svBrushColor:TColor;
begin
 with Canvas do
   begin
    svPenColor:=Pen.Color;
    svPenStyle:=Pen.Style;
    svWidth:=Pen.Width;
    svBrushColor:=Brush.Color;
    Pen.Color:=cl;
    Pen.Style:=ps;
    Pen.Width:=w;
    Brush.Color:=MyPalette.pal[0];
    moveto(a1,b1);
    lineto(a2,b2);
    SetPixel(Canvas,a2,b2,cl);
    Pen.Color:=svPenColor;
    Pen.Style:=svPenStyle;
    Pen.Width:=svWidth;
   end;
end;

procedure TGraphSys.line(a1,b1,a2,b2:integer; c:integer; ps:TPenStyle; w:integer);
var
   cl:TColor;
begin
   cl:=MyPalette[c] ;
   LineSub(CanVas1,a1,b1,a2,b2,cl,ps,w)
end;

procedure TScreenBMPGraphSys.line(a1,b1,a2,b2:integer; c:integer; ps:TPenStyle; w:integer);
var
   cl:TColor;
begin
  if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   cl:=MyPalette[c] ;
   LineSub(CanVas1,a1,b1,a2,b2,cl,ps,w);
{$IFDEF WINDOWS}
   if not HiddenDrawMode then
      begin
         if MyRgn<>0 then  SelectClipRgn(PaintBox1.Canvas.Handle,MyRgn);
         LineSub(PaintBox1.CanVas,a1,b1,a2,b2,cl,ps,w);
      end;
{$ENDIF}

end;


procedure TGraphSys.putmark0(a,b:integer);
  procedure put(dx,dy:integer);
  begin
      putPixel(a+dx,b+dy)
  end;
begin
    case 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;
end;


procedure TGraphSys.putMark(x,y:extended);
var
  i,j:integer;
begin
   //PutMark0(restrict(deviceX(x)),restrict(deviceY(y)));
   if ConvToDeviceX(x,i) and ConvToDeviceY(y,j) then    //2009.6.22
      PutMark0(i,j)
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;

procedure TScreenBMPGraphSys.GetPoint(var a,b:integer);
begin
      PaintForm.GetPoint(a,b)
end;

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

procedure TScreenBMPGraphSys.MousePol(var a,b:integer; var l,r:boolean);
begin
      PaintForm.MousePol(a,b,l,r)
end;

function TGraphSys.ColorIndexOf(a,b:integer):integer;
begin
  try
    ColorIndexOf:=MyPalette.ColorIndex(Canvas1.Pixels[a,b]);
  except
    ColorIndexof:=0;
  end;
end;

type TColorRec=packed record
     red,green,blue, spare:byte
end;


type TBMPRec=packed record
     blue,green,red, spare:byte
end;


(*
function TScreenBMPGraphSys.ColorIndexOf(a,b:integer):integer;
var
   PBMPrec:^TBMPRec;
   BMPRec:TBMPRec;
   Color:TColor;
begin
    PBMPrec:=BitMap1.ScanLine[b] ;
    inc(Cardinal(PBMPrec), 4*a);
    BMPRec:=PBMPrec^;
    TColorRec(Color).red:=BMPrec.red;
    TColorRec(Color).green:=BMPrec.green;
    TColorRec(Color).blue:=BMPrec.blue;
    ColorIndexOf:=MyPalette.ColorIndex(color and $FFFFFF);
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.OpenFile(FileName: string);
begin
      setexception(9102)
end;

procedure TScreenBMPGraphSys.OpenFile(FileName: string);
begin
   try
     if PaintForm.OpenFile(FileName)then
     else
        setexception(9005)
   except
       on E:EExtype do raise
       else
        setexception(9051)
   end;
end;

procedure TScreenBMPGraphSys.saveFile(FileName: string);
begin
   try
     if PaintForm.saveFile(FileName) then
     else
       setexception(9005)
   except
       on E:EExtype do raise
       else
          setexception(9052)
   end;
end;

(*
procedure TScreenBMPGraphSys.saveBMPFile(FileName: string);
begin
    PaintForm.saveFile(FileName)
end;

procedure TScreenBMPGraphSys.SaveFileFormat(FileName: string; pf:TPixelFormat);
begin
     PaintForm.SaveFileFormat(FileName, pf)
end;

procedure TScreenBMPGraphSys.SaveJpegFile(FileName:string; p:integer);
begin
     PaintForm.SaveJpegFile(FileName, p)
end;

procedure TScreenBMPGraphSys.SaveGifFile(FileName:string);
begin
     PaintForm.SaveGifFile(FileName)
end;
*)



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

procedure TGraphSys.SaveFileFormat(FileName: string; pf:TPixelFormat);
begin
      setexception(9102)
end;

procedure TGraphSys.SaveJpegFile(FileName:string; p:integer);
begin
      setexception(9102)
end;

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

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

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

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

procedure TScreenBMPGraphSys.SetBitmapSize(w,h:integer);
begin
   PaintForm.SetBitmapSize(w,h) ;
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 TGraphSys.TextOut(x,y:integer; const s:ansistring; angle:integer);
var
  dx,dy:integer;
begin
  case Hjustify of
    tjLEFT:  dx:=0;
    tjCENTER:dx:=-(textwidth(s) div 2);
    tjRIGHT: dx:=-textwidth(s);
  end;
  case Vjustify of
    tjTOP:   dy:=0;
    tjCAP:   dy:=-(textheight(s) div 8);
    tjHALF:  dy:=-(textheight(s) div 2);
    tjBASE:  dy:=-(textheight(s)*7 div 8);
    tjBOTTOM:dy:=-textheight(s);
  end;
  Rotate(dx,dy,angle);
  x:=x+dx;
  y:=y+dy;
  TextOutSub(x,y,s,angle);
end;

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

function YMulti(const x0,y0:extended):double;
var
  x,y,r,dx,dy:extended;
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:extended):integer;
var
  x,y,r,dx,dy:extended;
begin
  if CurrentTransform=nil then
     result:=0
  else
    //try
    begin
      set8087cw($133f);
      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
      if FPUError then
       result:=0;
      set8087cw(controlword)
    end;
end;

procedure TGraphSys.PlotLetters(const n,m:Extended; const s:string);
var
  x,y:integer;
  svTextHeight:extended;
begin
  svTextHeight:=gettextheight;
  setTextHeight(svTextHeight*ymulti(n,m));
  {$IFDEF WINDOWS}
  x:=restrict(deviceX(n));
  y:=restrict(deviceY(m));
  {$ENDIF}
  if ConvToDeviceX(n,x) and ConvToDeviceY(m,y) then    //2009.6.22
     TextOut(x,y,s,(textangle + XDirection(n,m)) mod 360);
  SettextHeight(svTextHeight);
end;

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

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



procedure TGraphSys.ProjectiveText(const n,m:Extended; 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;
   dx,dy:integer;
   pxmax,pymax:integer;
   x0,y0,x,y:extended;
   px,py,r:extended;
   svDrawMode:boolean;
   TextHeightWhole:extended;
   rt0,rt1:double;
   bmp2:TBitmap;
   NewRect:TRect;

   procedure FontToDevice(i,j:integer; var a,b:integer);
   var
      x1,y1:integer;
      x,y,x2,y2:extended;
   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:=DeviceX(x);
      b:=DeviceY(y);
   end;
label Label1;
begin
   //仮想座標系におけるtextheight を求める
  with Canvas1.Font do
    if Height=0 then //bug?
       size:=9;
  if TextProblemCoordinate and not TextHeightChanged then
    TextHeightWhole:=0.01 *TextHeightMulti
  else
    TextHeightWhole:=GetTextHeight * TextHeightMulti;
  if TextHeightWhole=0 then Exit;

  svDrawMode:=HiddenDrawMode;
  SetHiddenDrawMode(true);

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

  x0:=n;
  y0:=m;
  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}
       {$IFDEF LCLCarbon}
       pixelFormat:=pf8bit;
       case Length(s) of
          1.. 15:Height:=256;
         16.. 31:Height:=128;
         32.. 63:Height:= 64;
         64..127:Height:= 32;
        128..255:Height:= 16;
         else    Height:= 16;
       end;
       {$ELSE}
       pixelFormat:=pf16bit;
       case Length(s) of
          1.. 15:Height:=256;
         16.. 31:Height:=128;
         32.. 63:Height:= 64;
         64..127:Height:= 32;
        128..255:Height:= 16;
         else    Height:= 16;
       end;
       {$ENDIF}
      {$ENDIF}

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

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

         Canvas.Font.Color:=clBlack;
         //Canvas.Font.Style:=[fsBold];
         Canvas.TextOut(0,0,s);
         case Hjustify of
            tjLEFT:  dx:=0;
            tjCENTER:dx:=width div 2;
            tjRIGHT: dx:=width;
         end;
         case 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:=DevWidth-1;
        BMin:=0; BMax:=DevHeight-1;
      end;



    // 描画
    color1:=Canvas1.Font.color;
    color0:=Mypalette.pal[0];      //背景色
    r:=bmp2.Height/TextHeightWhole;
    pxmax:=bmp2.Width-1;
    pymax:=bmp2.Height-1;
    for b:=max(BMin,ClipRect.top)  to Min(Bmax,Cliprect.Bottom) do
      for a:=max(Amin,ClipRect.Left) to Min(AMax,Cliprect.Right) do
        begin
          try
             x:=virtualX(a);
             y:=virtualY(b);
             if PlotStm then currenttransform.invtransform(x,y);
             // この時点で，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:=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;
           except
             on EMathError do ;
             on EInvalidOp do ;
           end;
         end;
  finally
    bmp2.Free;
    MyGraphSys.setHiddenDrawMode(SvDrawMode);
  end;
end;



(*
procedure TGraphSys.ProjectiveText(const n,m:Extended; 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;
   dx,dy:integer;
   x0,y0,x,y:extended;
   px,py,px1,py1:extended;
   svDrawMode:boolean;
   TextHeightWhole:double;
   rt0,rt1:double;
   p:TBitmap;
   NewRect:TRect;

   procedure FontToDevice(i,j:integer; var a,b:integer);
   var
      x1,y1:integer;
      x,y,x2,y2:extended;
   begin
      x1:=i-dx;
      y1:=j-dy;
      x2:= x1*rt0+y1*rt1;
      y2:=-x1*rt1+y1*rt0;
      y:=y0-y2/p.Height*TextHeightWhole;
      x:=x0+x2/p.Height*TextHeightWhole;
      if PlotStm then currentTransform.transform(x,y);
      a:=DeviceX(x);
      b:=DeviceY(y);
   end;
label Label1;
begin
     //仮想座標系におけるtextheight を求める
  if TextProblemCoordinate and not TextHeightChanged then
    TextHeightWhole:=0.01 * TextHeightMulti
  else
    TextHeightWhole:=GetTextHeight * TextHeightMulti;
  if TextHeightWhole=0 then Exit;

  svDrawMode:=HiddenDrawMode;
  SetHiddenDrawMode(true);

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

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

  p:=TBitmap.Create;
  try
    with p 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}
       {$IFDEF LCLCarbon}
       pixelFormat:=pf8bit;
       case Length(s) of
          1.. 15:Height:=256;
         16.. 31:Height:=128;
         32.. 63:Height:= 64;
         64..127:Height:= 32;
        128..255:Height:= 16;
         else    Height:= 16;
       end;
       {$ELSE}
       pixelFormat:=pf32bit;
       case Length(s) of
          1.. 15:Height:=128;
         16.. 31:Height:= 64;
         32.. 63:Height:= 32;
         64..127:Height:= 16;
        128..255:Height:= 16;
         else    Height:= 16;
       end;
       {$ENDIF}
      {$ENDIF}

       Canvas.Font.Assign(Canvas1.Font);
     {$IFDEF Linux}
       Canvas.Font.Height:=(Height div 16)*9;
       Width:=(Canvas.TextWidth(s) div 8)*9;
     {$ELSE}
       Canvas.Font.Height:=Height;
       Width:=Canvas.TextWidth(s);
     {$ENDIF}
         NewRect:=Rect(0,0,width,Height);
         with Canvas do
            begin
              Brush.color:=clWhite;
              FillRect(NewRect);
            end;
         bkcolor:=Canvas.Pixels[0,0];

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

Label1:
    FontToDevice(0,0,a0,b0);
    FontToDevice(p.width-1,0,a1,b1);
    FontToDevice(p.width-1,P.Height-1,a2,b2);
    FontToDevice(0,P.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;
    }
    // 描画
    color0:=MyPalette[0];
    color1:=MyPalette[textcolor];
    for b:=max(BMin,ClipRect.top)  to Min(Bmax,Cliprect.Bottom) do
      for a:=max(Amin,ClipRect.Left) to Min(AMax,Cliprect.Right) do
        begin
             x:=virtualX(a);
             y:=virtualY(b);
             if PlotStm then currenttransform.invtransform(x,y);
             // この時点で，x,yは絵定義中の仮想座標
             // x,yが文字の点であるか否かを調べる。
             py:=(y0-y)*p.height/TextHeightWhole ;
             px:=(x-x0)*p.Height/TextHeightWhole ;
             px1:=px*rt0 - py*rt1;     //text angle の逆算
             py1:=px*rt1 + py*rt0;
             px:=px1+dx;
             py:=py1+dy;
             if (0<=py) and (py<=p.Height-1) and (0<=px) and (px<=p.Width-1) then
             begin
                i:=LongintRound(px);
                j:=LongintRound(py);
                color:=p.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;
  finally
    p.Free;
    MyGraphSys.setHiddenDrawMode(SvDrawMode);
  end;
end;
*)





function restrict9x(n:longint):integer;
begin
   if n>16383 then
      result:=16383
   else if n<-16384 then
      result:=-16384
   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;

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

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

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

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



function TGraphSys.SetDeviceViewport(l,r,b,t:extended):boolean;
var
  ppm:extended;
  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);
  if (l0<r0) and (b0<t0)
      and (l0>=0) and (r0<=DevWidth)
      and (b0>=0) and (t0<=DevHeight) then
    begin
      DVleft:=l0;
      DVright:=r0;
      DVbottom:=b0;
      DVtop:=t0;
      setupClipRect;
      setupCoordinatesubsystem;
      clearScreen;
      result:=true;
    end
  else
    result:=false
end;



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



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

procedure TGraphSys.SetClip(c:boolean);
begin
   clip:=c;
   setupClipRect;
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(Canvas1,Points);
end;

procedure TScreenBMPGraphSys.PolyBezier( const Points:array of TPoint);
begin
   Inherited PolyBezier(Points);
{$IFDEF WINDOWS}
   if not HiddenDrawMode then
     BezierSub(PaintBox1.Canvas,Points);
{$ENDIF}
end;

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

procedure TGraphSys.SetAreaStyleIndex(i:integer);
begin
   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 Floodfill}
 {***************}
 procedure TGraphSys.Flood(x,y:integer);
var
   svBrushColor:TColor;
begin
   with Canvas1 do
     begin
       svBrushColor:=Brush.Color;
       Brush.Color:=MyPalette[areacolor] ;
       FloodFill(x,y,pixels[x,y],fsSurface);
       Brush.Color:=svBrushColor;
     end;
end;


procedure TGraphSys.FloodFill( x,y:integer);
var
   svBrushColor:TColor;
begin
   with Canvas1 do
    begin
       svBrushColor:=Brush.Color;
       Brush.Color:=MyPalette[areacolor] ;
       FloodFill(x,y,MyPalette[linecolor] ,fsBorder);
       Brush.Color:=svBrushColor;
    end;
end;

procedure TScreenBMPGraphSys.Flood( x,y:integer);
begin
   if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   inherited Flood(x,y);
   if not HiddenDrawMode then
      PaintForm.repaint;
end;

procedure TScreenBMPGraphSys.FloodFill( x,y:integer);
begin
   if MyRgn<>0 then  SelectClipRgn(Canvas1.Handle,MyRgn);
   inherited FloodFill(x,y);
   if not HiddenDrawMode then
      PaintForm.repaint;
end;


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

procedure TGraphSys.MSScreen(c:integer);
begin
      setexception(9102)
end;

procedure TScreenBMPGraphSys.MSScreen(c:integer);
begin
   case c of
     2,3,87:
      PaintForm.setBitMapSize(640,400);
     11,12:
      PaintForm.setBitMapSize(640,480);
   end;

   if c in [3,12,87] then
    begin
       case c of
        3 :MyPalette.PaletteNumber:=2;
        12,87:MyPalette.PaletteNumber:=1;
       end;
       PaintForm.clear;
       linecolor:=7;
       setlinecolor(7);
    end;
end;
procedure TGraphSys.MSMoveTo(a,b:integer);
begin
   Canvas1.Moveto(a,b);
end;

procedure TScreenBMPGraphSys.MSMoveTo(a,b:integer);
begin
   Canvas1.Moveto(a,b);
{$IFDEF WINDOWS}
   if not HiddenDrawMode then
         PaintBox1.Canvas.Moveto(a,b);
{$ENDIF}
end;

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

procedure TScreenBMPGraphSys.MSLineTo(a,b:integer);
begin
   Canvas1.lineto(a,b);
{$IFDEF WINDOWS}
   if not HiddenDrawMode then
         PaintBox1.Canvas.lineto(a,b);
{$ENDIF}
end;


procedure TGraphSys.MSPaint( x,y:integer; ac, bc:integer);
var
   svBrushColor:TColor;
   BorderColor:TColor;
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;

procedure TScreenBMPGraphSys.MSPaint( x,y:integer; ac, bc:integer);
begin
   inherited MSPaint(x,y,ac,bc);
{$IFDEF WINDOWS}
   if not HiddenDrawMode then
      PaintBox1.Repaint;
{$ENDIF}
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(Canvas1,x1,y1,x2,y2,lc,ac,F);
end;

procedure TScreenBMPGraphSys.MSCircle(x1,y1,x2,y2:integer; lc,ac:integer; F:boolean);
begin
  MSCircleSub(Canvas1,x1,y1,x2,y2,lc,ac,F);
{$IFDEF WINDOWS}
  if not HiddenDrawMode then
    MSCircleSub(PaintBox1.Canvas,x1,y1,x2,y2,lc,ac,F);
{$ENDIF}
end;


{************}
{InitGraphics}
{************}

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

initialization

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

    ScreenBMPGraphSys:=TScreenBMPGraphSys.create;
    MyGraphSys:=ScreenBMPGraphSys;
    PrtDirectGraphSys:=TPrtDirectGraphSys.create;

    //if longint(Windows.GetVersion)>=0 then
    if true then                // 32ビット座標系ならtrueにする。
       begin
         restrict:=restrictNT;
         ShrinkRange:=ShrinkRangeNT;
       end
    else
       begin
         restrict:=restrict9x;
         ShrinkRange:=ShrinkRange9x;
       end;


finalization

   ScreenBMPGraphSys.Free;
   PrtDirectGraphSys.free;
   MyPalette.Free;

end.
