svn/view/draw.pas

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

{$X+}

interface
uses affine,objlist,variabl,express;

type
   TTransformTerm=class
       //procedure exec(p:Taffine);virtual;abstract;
       function Code:Ansistring;virtual;abstract;
   end;

type
   TTransFormList=class(TObjectList)
       //procedure make(a:Taffine);
       function Code1:ansistring;
       function Code2:ansistring;
       function Code0(m:TMatrix):AnsiString; // for TransForm-mat statement
   end;


function transformation:TTransformList;


implementation

uses  Types, SysUtils,Graphics,
      arithmet, base,base0,float,mathc, texthand,
      graphic,struct,confopt,helpctex,plottext,sconsts,graphsys,gridaxes;

      (*
procedure TTransFormList.make(a:TAffine);
var
   i:integer;
   p:TTransformTerm;
begin
  i:=0;
  while (i<count)  do
    begin
        TObject(p):=items[i];
        p.exec(a);
        inc(i)
    end;
end;
*)

type
   TTransformMatrix=class(TTransformTerm)
          mat:TMatrix;
       constructor  create;
       //procedure exec(p:Taffine);override;
       destructor  destroy;override;
       function Code:ansistring;override;
   end;

   TTransformFunction=class(TTransformTerm)
          exp1,exp2:TPrincipal;
       destructor  destroy;override;
       function Code:ansistring;override;
   end;

   TSHIFT=class(TTransformFunction)
       constructor  create;
       //procedure exec(p:Taffine);override;
       function Code:ansistring;override;
   end;

   TSCALE=class(TTransformFunction)
       constructor  create(e1:TPrincipal);
       //function Code:ansistring;override;
   end;

   TSCALE1=class(TSCALE)
       //procedure exec(p:Taffine);override;
       function Code:ansistring;override;
   end;

   TSCALEC=class(TSCALE)
       //procedure exec(p:Taffine);override;
       function Code:ansistring;override;
   end;

   TSCALE2=class(TSCALE)
       constructor create(e1:TPrincipal);
       //procedure exec(p:Taffine);override;
       function Code:ansistring;override;
   end;

   TROTATE=class(TTransformFunction)
        rad:extended;
        cost,sint:extended;
       constructor  create;
       //procedure exec(p:Taffine);override;
       function Code:ansistring;override;
   end;

   TSHEAR=class(TTransformFunction)
        rad:extended;
       constructor  create;
       //procedure exec(p:Taffine);override;
       function Code:ansistring;override;
   end;


   TcurrentTransform=class(TTransformFunction)
       //procedure exec(p:Taffine);override;
       function Code:ansistring;override;
   end;


type
   ESyntaxError=class(Exception);

constructor TTransformMatrix.create;
begin
    inherited create;
    mat:=NMatrix;
    if mat=nil then raise ESyntaxError.create('');
    if mat.idr.dim<>2 then begin seterrdimension(IDH_PICTURE);raise ESyntaxError.create('') end
end;


constructor TSHIFT.create;
begin
    inherited create;
    gettoken;    { keyword }
    gettoken;    { '(' }
    exp1:=NExpression;
    if (ProgramUnit.arithmetic=PrecisionComplex) and (token<>',') then exit;
    check(',',IDH_PICTURE);
    exp2:=NExpression;
end;

constructor TSCALE.create(e1:TPrincipal);
begin
    inherited create;
    exp1:=e1;
end;

constructor TSCALE2.create(e1:TPrincipal);
begin
    inherited create(e1);
    gettoken;
    exp2:=NExpression;
end;


function scale:TSCALE;
var
   exp1:TPrincipal;
begin
    gettoken;    { keyword }
    gettoken;    { '(' }
    exp1:=NExpression;
    if token=',' then
       result:=TSCALE2.create(exp1)
    else if ProgramUnit.arithmetic=PrecisionComplex then
       result:=TSCALEC.create(exp1)
    else
       result:=TSCALE1.create(exp1)
end;

constructor TROTATE.create;
var
   x:extended;
begin
    inherited create;
    gettoken;    { keyword }
    gettoken;    { '(' }
    exp1:=NExpression;
    if confirmedDegrees then
       rad:=pi/180
    else
       rad:=1;
    if (exp1=nil) then begin raise ESyntaxError.create('') end;
    if (exp1.isConstant) then
       begin
           x:=exp1.evalX;
           cost:=cos(x*rad);
           sint:=sin(x*rad);
           exp1.free;
           exp1:=nil;
        end;
end;

constructor TShear.create;
begin
    inherited create;
    gettoken;    { keyword }
    gettoken;    { '(' }
    exp1:=NExpression;
    if confirmedDegrees then
       rad:=pi/180
    else 
       rad:=1;
    if (exp1=nil) then
                  begin raise ESyntaxError.create('') end;
end;

destructor TTransformmatrix.destroy;
begin
    mat.free;
    inherited destroy;
end;

destructor TTransformFunction.destroy;
begin
    exp1.free;
    exp2.free;
    inherited destroy;
end;
(*
procedure TSHIFT.exec(p:Taffine);
var
   c:complex;
begin
   if (exp2=nil) then
      begin
         exp1.evalC(c);
         p.shift(c.x, c.y)
      end
   else
      p.shift(exp1.evalX,exp2.evalX) ;
end;

procedure TSCALE1.exec(p:TAffine);
begin
   p.scale1(exp1.evalX) ;
end;

procedure TSCALE2.exec(p:TAffine);
begin
   p.scale(exp1.evalX,exp2.evalX)
end;

procedure TSCALEC.exec(p:TAffine);
var
   c:complex;
begin
  exp1.evalC(c);
  p.cmlt(c)
end;


procedure TROTATE.exec(p:TAffine);
begin
   if exp1=nil then
      p.rotate2(cost,sint)
   else
      p.rotate(exp1.evalX*rad)
end;

procedure TSHEAR.exec(p:TAffine);
begin
    p.shear(exp1.evalX * rad)
end;


procedure TTRansformMatrix.exec(p:Taffine);
var
   NArray:TArray;
   m:TAffine;
begin
   NArray:=TArray(mat.point);
   if (NArray<>nil) and (NArray.dim=2)
       and (NArray.size[1]=4) and (NArray.size[2]=4) then
       begin
          m:=TAffine.create;
          try
            with NArray do
             try
               ItemGetF(0,          m.xx);
               ItemGetF(1*size[2],  m.xy);
               ItemGetF(2*size[2],  m.xz);
               ItemGetF(3*size[2],  m.xo);
               ItemGetF(          1,m.yx);
               ItemGetF(1*size[2]+1,m.yy);
               ItemGetF(2*size[2]+1,m.yz);
               ItemGetF(3*size[2]+1,m.yo);
               ItemGetF(          2,m.zx);
               ItemGetF(1*size[2]+2,m.zy);
               ItemGetF(2*size[2]+2,m.zz);
               ItemGetF(3*size[2]+2,m.zo);
               ItemGetF(          3,m.ox);
               ItemGetF(1*size[2]+3,m.oy);
               ItemGetF(2*size[2]+3,m.oz);
               ItemGetF(3*size[2]+3,m.oo);
             except
               setexception(-3009)
             end;
            p.mlt(m);
          finally
            m.free;
          end;
      end
   else
       setexception(6201);
end;


procedure TCurrentTransform.exec(p:Taffine);
begin
  if CurrentTransform<>nil then  p.mlt(currenttransform);
end;
*)


type
   TDRAW=class(TCALL)
           transform:TTransformList;   {collection of PTransformterm }
           substitution: function(x,y:extended):boolean;   {AXES,GRID}
           exp1,exp2:TPrincipal;
           NoBeamOff:boolean;
       constructor create(prev,eld:TStatement);
       destructor destroy;override;
      // procedure exec;override;
        function OverflowErCode:integer;override;
        function InvalidErCode:integer;override;
        function OpName:string;override;
       {for Code Gen.}
       function Code:AnsiString;override;


   end;

function DRAWst(prev,eld:TStatement):TStatement;far;
begin
    DRAWst:=TDRAW.create(prev,eld{,idr});
    graphmode:=true;
end;

function transformation:TTransformList;
var
   p:TTransformTerm;
   s:boolean;
begin
   result:=TTransformList.create(4);
   try
           s:=true;
           repeat
              p:=nil;
              if nexttoken='(' then
                 begin
                    if token='SHIFT' then
                       p:=TSHIFT.create
                    else if token='SCALE' then
                       p:=scale
                    else if token='ROTATE' then
                       p:=TROTATE.create
                    else if token='SHEAR' then
                       p:=TSHEAR.create
                    else
                       seterrillegal(token,IDH_PICTURE);
                    check(')',IDH_PICTURE);
                 end
              else if token='TRANSFORM' then
                 begin
                    gettoken;
                    p:=TCurrentTransform.create
                 end
              else
                 p:=TTransformMatrix.create;
              if p<>nil then result.add(p);
              if token='*' then
                  gettoken
              else
                  s:=false;
           until s=false;
    except
      on syntaxError do
        begin
          result.free;
          result:=nil;
        end;
    end;
end;

constructor TDRAW.create(prev,eld:TStatement);
begin
    transform:=nil;

    try
          inherited create(prev,eld,'P')
    except
       on SyntaxError do
       begin
          inherited TStatementCreate(prev,eld);
          {reseterr; }
          if token='AXES0' then
               substitution:=drawaxes0
          else if token='GRID0' then
               substitution:=drawgrid0
          else if token='AXES' then
               substitution:=drawaxes2
          else if token='GRID' then
               substitution:=drawgrid2
          else if token='CIRCLE' then
               substitution:=drawcircle
          else if token='DISK' then
              begin
               substitution:=drawdisk;
               NoBeamOff:=true;
              end 
          else
             raise;

          gettoken;
          if token='(' then
             begin
                check('(',IDH_DRAW_axes);
                exp1:=NExpression;
                check(',',IDH_DRAW_axes);
                exp2:=NExpression;
                check(')',IDH_DRAW_axes);
             end;
          statusmes.clear;
          HelpContext:=0;
       end;
    end;

    if token='WITH' then
       begin
           gettoken;
           transform:=Transformation;
           if transform=nil then seterr('',IDH_PICTURE);
      end;
end;

destructor TDRAW.destroy;
begin
   transform.free;
   inherited destroy;
end;
(*
procedure TDRAW.exec;
var
  a:TAffine;
begin
   try
    if transform<>nil then
       begin
         a:=Taffine.create;
         a.push;              //  a���currenttransform���������
         currentoperation:=self;
         transform.make(a);
         if a.next<>nil then
                      a.mlt(a.next);
         currentoperation:=nil;
       end;

     MyGraphSys.beam:=MyGraphSys.beam
                    and (    (MyGraphSys.BeamMode=bmImmortal)
                          or (Routine<>nil) and Routine.NoBeamOff
                          or (Routine=nil) and NobeamOff         );

    if @substitution=nil then
       inherited exec
     else if exp1=nil then
       substitution(1,1)
     else
       substitution(abs(exp1.evalX),abs(exp2.evalX));

    MyGraphSys.beam:=MyGraphSys.beam
                    and (    (MyGraphSys.BeamMode=bmImmortal)
                          or (Routine<>nil) and Routine.NoBeamOff
                          or (Routine=nil) and NobeamOff         );

   finally
    if transform<>nil then
            pop;
   end;
end;
*)
function TDRAW.OverflowErCode:integer;
begin
  result:=-1005
end;

function TDRAW.InvalidErCode:integer;
begin
   result:=-3009
end;

function TDRAW.OpName:string;
begin
   result:=s_TDrawOpName;
end;


function TTransformMatrix.code:ansistring;
   begin
     result:=' mlt('+mat.code+');'
   end;

function TTransformFunction.Code:ansistring;
begin
  result:='('+exp1.Code+','+exp2.Code+');'
end;

function TSHIFT.Code:Ansistring;
begin
  if exp2<>nil then
     result:=' shift'+inherited code
  else
     result:=' shift('+exp1.Code+');'
end;


function TSCALE1.code:ansistring;
begin
   result:=' scale1('+exp1.Code+');'
end;

function TSCALEC.code:ansistring;
begin
   result:=' cmlt('+exp1.Code+');'
end;

function TSCALE2.Code:ansistring;
begin
  result:=' scale'+inherited code;
end;

function TROTATE.Code:ansistring;
begin
  if exp1=nil then
      result:=' rotate2('+Format20(cost)+','+Format20(sint)+');'
  else if rad=1 then
      result:=' rotate('+exp1.code+');'
  else
      result:=' rotate(('+exp1.code+')*PI/180);'
end;

function TSHEAR.Code:ansistring;
begin
  if rad=1 then
      result:=' shear('+exp1.code+');'
  else
      result:=' shear(('+exp1.code+')*PI/180);'
end;


function TcurrentTransform.Code:ansistring;
begin
  result:=' mlt(CurrentTransform);'
end;

function TTransformList.Code1:ansistring;
var
  i:integer;
begin
  result:='With Taffine.create do'+EOL
         +'begin'+EOL
         +' push;'+EOL;
  for i:=0 to Count-1 do
    result := result+(items[i] as TTransformTerm).code;
    result:=result +' if next<>nil then mlt(next);'+EOL  //next���currenttransform������������
                 +'end;'+EOL
end;

function TTransFormList.Code2:ansistring;
begin
   result:='pop;'+EOL
end;

function TTransformList.Code0(m:TMatrix):ansistring;
var
  i:integer;
begin
  result:='With Taffine.create do'+EOL
         +'begin'+EOL;
     for i:=0 to Count-1 do
        result:=result+(items[i] as TTransformTerm).code;
        result:=result +' store(' + m.Code +');'+EOL
               +' free;'+EOL
               +'end;'+EOL
end;


function TDraw.Code:ansistring;
var
  i:integer;
begin
  result:='';
  if Transform<>nil then
     result:=result+Transform.Code1+EOL;

  if not( NoBeamoff or (Routine<>nil) and (Routine.NoBeamOff)) then
     result:=result
       +'MyGraphSys.beam:=MyGraphSys.beam and (MyGraphSys.BeamMode=bmImmortal);'+EOL;


  if @substitution=nil then
     result:=result+inherited code
  else
     begin
       if      @substitution=@drawaxes0 then
          result:=result+'drawaxes0('
       else if @substitution=@drawgrid0 then
          result:=result+'drawgrid0('
       else if @substitution=@drawaxes2 then
          result:=result+'drawaxes2('
       else if @substitution=@drawgrid2 then
          result:=result+'drawgrid2('
       else if @substitution=@drawcircle then
          result:=result+'drawcircle('
       else if @substitution=@drawdisk then
          result:=result+'drawdisk(';
       if exp1<>nil then
          result:=result+exp1.code+','
       else
          result:=result+'1,';

       if exp2<>nil then
           result:=result+exp2.code+');'
       else
           result:=result+'1);';
     end;

  if Transform<>nil then
     result:=result+Transform.Code2+EOL;

  if not( NoBeamoff or (Routine<>nil) and (Routine.NoBeamOff)) then
     result:=result
       +'MyGraphSys.beam:=MyGraphSys.beam and (MyGraphSys.BeamMode=bmImmortal);'+EOL;
end;


{
function transformInv(var x,y:extended):boolean;far;
begin
   result:=currenttransform.invtransform(x,y);
end;
}

procedure statementTableinit;far;
begin
          StatementTableInitImperative('DRAW',DRAWst);
end;

begin
    tableInitProcs.accept(statementTableinit) ;
    //graphic.transform:=transform;
    //graphic.inversetransform:=transforminv;

end.

