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

interface
uses SysUtils,
     variabl,struct,express;

type
    TMatRedim=class(TObject)
         constructor create(m1:TMatrix; idn:boolean);
         destructor destroy;override;
         //function exec:boolean;
         function Code:ansistring;
         function ReSizeCode:AnsiString;
         function CreateCode:Ansistring;
       private
         mat1:TMatrix;             {copy pointer; cannot dispose}
         lb,ub:array[1..4] of TPrincipal;
         optionbase:integer;
         //function execute(a:TArray):boolean;
      end;

function MatRedim(m1:TMatrix; idn:boolean):TMatRedim;

implementation
uses
     base,base0,TextHand,HelpCtex,io,print,graphic,draw,supplied;

type
   TMAT=class(TStatement)
          mat1:TMatrix;
        destructor destroy;override;
        function OverflowErCode:integer;override;
        //function TraceResultCode:AnsiString;override;
      end;

   TMATTransformation=class(TMAT)
       transform:TTransformList;
     constructor create(prev,eld:TStatement; m1:TMatrix);
     destructor destroy;override;
     //procedure exec;override;
     function Code:Ansistring;override;
    end;

type
   TMAToperation=class(TMAT)
       mat2:TMatrix;
       mat3:TMatrix;
       op:char;
     constructor create(prev,eld:TStatement; m1,m2:TMatrix);
     destructor destroy;override;
     //procedure exec;override;
     function Code:Ansistring;override;
    end;

    TMATConst=class(TMAT)
        exp:TPrincipal;
        redim:TMatRedim;
        direction:string[3];
      constructor create(prev,eld:TStatement; m1:TMatrix; e:TPrincipal);
      destructor destroy;override;
      //procedure exec;override;
      function Code:Ansistring;override;
      end;

    TMatScalarMulti=class(Tmat)
        exp:TPrincipal;
        mat2:TMatrix;
      constructor create(prev,eld:TStatement; m1,m2:TMatrix; e:TPrincipal);
      //procedure exec;override;
      destructor destroy;override;
      function Code:Ansistring;override;
    end;


   TMatFunction=class(TMat)    {abstarct}
         mat2:TMatrix;
      constructor create(prev,eld:TStatement; m1:TMatrix);
      destructor destroy;override;
   end;

   TMatInv=class(TMatFunction)
      //procedure exec;override;
      function Code:Ansistring;override;
   end;

   TMatTRN=class(TMatFunction)
      //procedure exec;override;
      function Code:Ansistring;override;
   end;

   TMatCross=class(TMat)
         mat2,mat3:TMatrix;
      constructor create(prev,eld:TStatement; m1:TMatrix);
      destructor destroy;override;
      //procedure exec;override;
      function Code:Ansistring;override;
   end;


function MatOperation(prev,eld:TStatement;  mat1:TMatrix):TStatement;forward;

function MATstring(prev,eld:TStatement; mat1:TMatrix):TStatement;forward;


function MatOperation1(prev,eld:TStatement):TStatement;
var
   mat1:TMatrix;
   svcp:TokenSave;
begin
   result:=nil;
   savetoken(svcp);
   mat1:=matrix;
   if mat1=nil then exit;
   if mat1.kind='n' then
   begin
      inc(trying);
      try
         result:=MatOperation(prev,eld,mat1);
      except
         on E:SyntaxError do
           begin
             restoretoken(svcp);
             mat1:=matrix;
             result:=TMatTransformation.create(prev,eld,mat1);
             statusmes.clear;
             HelpContext:=0;
           end;
      end;
      dec(trying);
   end
   else
     result:=MatString(prev,eld,mat1);
end;

function MatRedim(m1:TMatrix; idn:boolean):TMatRedim;
begin
   if token='(' then
         matredim:=TMatRedim.create(m1,idn)
   else
         MatRedim:=nil
end;

destructor TMAT.destroy;
begin
    mat1.free;
    inherited destroy
end;

{*****************}
{MATRIX operations}
{*****************}

function scalarMulti:TPrincipal; {nilのこともある}
var
  func: SimpleFunction;
  idr:TIdRec;
begin
   scalarMulti:=nil;
   if tokenspec=Nidf then
      begin
         if ReservedWordTable.find(token,func)
                      and (@func=@RESERVEDWORDfnc) then     //CON, IDN, ZER
               exit;
         idr:=IdRecord(false);
         if (idr<>nil) then
            begin
              if (idr.dim>0) and (nexttoken<>'(') then    //数値配列名
               exit
            end
         else if (NextToken='(')
              and not SuppliedFunctionTable.find(token,func) then  //数値配列関数
                  exit;
      end;
   scalarMulti:=primary;
end;



function MatOperation(prev,eld:TStatement; mat1:TMatrix):TStatement;
var
   mat2:TMatrix;
   exp:TPrincipal;
begin
   MatOperation:=nil;

   try
      check('=',IDH_MAT);
   except
       mat1.free;
       exit
   end;


   if (token='INV') and (nexttoken='(') and (NextTokenBeyondParenthesis<>'*') then
      MatOperation:=TMatINV.create(prev,eld,mat1)

   else if (token='TRN') and (nexttoken='(') and (NextTokenBeyondParenthesis<>'*')then
      MatOperation:=TMatTRN.create(prev,eld,mat1)

   else if (token='CROSS') and (nexttoken='(')and (NextTokenBeyondParenthesis<>'*') then
      MatOperation:=TMatCROSS.create(prev,eld,mat1)

   else
      begin
         exp:=scalarMulti;
         if exp<>nil then
                check('*',IDH_MAT);
         if (token='ZER') or (token='IDN') or (token='CON') then  {reserved words}
            MatOperation:=TMatConst.create(prev,eld, mat1,exp)
         else
           begin
             mat2:=Nmatrix;
             if (exp=nil) and ((token='+') or (token='-') or (token='*')) then
                    MatOperation:=TMAToperation.create(prev,eld,mat1,mat2)
             else
                    MatOperation:=TMatScalarMulti.create(prev,eld,mat1,mat2,exp);
             if token='*' then seterrillegal(token,IDH_MAT); //変形指示MAT文かも？
           end;
      end;
end;


constructor TMAToperation.create(prev,eld:TStatement; m1,m2:TMatrix);
begin
    inherited create(prev,eld);
    mat1:=m1;
    mat2:=m2;
    op:=token[1];
    gettoken;
    mat3:=Nmatrix;
    case op of
      '+','-': if (mat1.idr.dim=mat2.idr.dim) and (mat2.idr.dim=mat3.idr.dim) then
               else begin seterrDimension(IDH_MAT) ; {done; fail} end;
      '*':  if (mat1.idr.dim=1) and (mat2.idr.dim=1) and (mat3.idr.dim=2)
            or (mat1.idr.dim=1) and (mat2.idr.dim=2) and (mat3.idr.dim=1)
            or (mat1.idr.dim=2) and (mat2.idr.dim=2) and (mat3.idr.dim=2) then
            else begin seterrDimension(IDH_MAT) ; {done; fail} end;
    end;
end;

destructor TMAToperation.destroy;
begin
    mat3.free;
    mat2.free;
    inherited destroy
end;



function TMatOperation.Code:AnsiString;
var
  opName:string;
begin
  case op of
      '+' : opName:='.add(';
      '-' : opname:='.sub(';
      '*' : opname:='.prod(';
    end;
  result:=mat1.Code+opname+mat2.Code+','+mat3.Code+');';
end;


function TMAT.OverflowErCode:integer;
begin
  result:=1005
end;



constructor TMatRedim.create(m1:TMatrix; idn:boolean);
var
   i:integer;
begin
   inherited create;
   optionbase:=programunit.ArrayBase;
   mat1:=m1;

          gettoken;
          i:=1;
          repeat
                  ub[i]:=nexpression;
                  if token='TO' then
                      begin
                         gettoken;
                         lb[i]:=ub[i];
                         ub[i]:=nexpression;
                     end;
                  inc(i);
          until (i>mat1.idr.dim) or (test(',')=false);
          check(')',IDH_MAT);
          //if idn and (i=2) then begin i:=3; lb[2]:=lb[1]; ub[2]:=ub[1] end;
          //if (i<>mat1.idr.dim+1) or (idn and (mat1.idr.dim<>2))  then
          if (idn and ((mat1.idr.dim<>2) or (i>3)))
             or (not idn and (i<>mat1.idr.dim+1)) then
                                      begin seterrdimension(IDH_MAT);fail end;
end;


destructor TMatRedim.destroy;
var
   i:integer;
begin
   if ub[1]=ub[2] then
   begin
      lb[1].free;
      ub[1].free;
   end
   else
    for i:=1 to 4 do
       begin
          lb[i].free;
          ub[i].free;
       end;
    inherited destroy;
end;


function TMatRedim.Code:AnsiString;
var
  i:integer;
begin
  result:=mat1.Code+'.ReDim(';
  for i:=1 to mat1.idr.dim do
    begin
      if i>1 then result:=result+',';
      if lb[i]=nil then
         result:=result+ strint(optionbase)
      else
         result:=result+ lb[i].Code;
      result:=result+','+ub[i].Code;
    end;
  result:=result+');'
end;

function TMatRedim.ReSizeCode:AnsiString;
var
  i:integer;
begin
  result:=mat1.Code+'.ReSize(';
  for i:=1 to mat1.idr.dim do
    begin
      if ub[i]<>nil then
         begin
            if i>1 then result:=result+',';
            result:=result+ub[i].Code;
            if lb[i]<>nil then
               result:=result+ '-' + lb[i].Code +'+1'
            else if optionbase =0 then
                  result:=result+'+1'
         end;
    end;
  result:=result+');'
end;

function TMatRedim.CreateCode:ansistring;
var
  i:integer;
begin
  with mat1 do
    result:='TArray'+IntToStr(idr.dim)+UpperCase(idr.kindchar)+'.create(';
  for i:=1 to mat1.idr.dim do
    begin
      if i>1 then result:=result+',';
      if lb[i]=nil then
         result:=result+ strint(optionbase)
      else
         result:=result+ lb[i].Code;
      result:=result+','+ub[i].Code;
    end;
  result:=result+')'
end;




constructor Tmatconst.create(prev,eld:TStatement; m1:TMatrix; e:TPrincipal);
begin
    inherited create(prev,eld);
    mat1:=m1;
    exp:=e;
    direction:=token;
    if (direction='IDN') and (mat1.idr.dim<>2) then seterrDimension(IDH_MAT);
    gettoken;
    redim:=MatRedim(m1,(direction ='IDN'));
    {if  err then begin done;fail end;}
end;

destructor TMatconst.destroy;
begin
     exp.free;
     redim.free;
    inherited destroy;
end;


function TMatConst.Code:ansistring;
begin
  result:='';
  if redim<>nil then result:=redim.ResizeCode;
  result :=result+ mat1.Code+'.'+direction;
  if exp<>nil then result:=result+'('+exp.Code+')';
  result:=result+';'
end;

constructor TMatScalarMulti.create(prev,eld:TStatement; m1,m2:TMatrix; e:TPrincipal);
begin
    inherited create(prev,eld);
    mat1:=m1;
    mat2:=m2;
    exp:=e;
    (*    if (mat2=nil) then begin done;fail end; *)
    if (mat1.idr.dim<>mat2.idr.dim) then
                 begin seterrdimension(IDH_MAT); {done;fail} end;
end;

destructor TMatScalarMulti.destroy;
begin
    mat2.free;
    exp.free;
    inherited destroy;
end;

function TMatScalarMulti.Code:AnsiString;
begin
  if exp<>nil then
     result:=mat1.code + '.Scalar('+exp.code+','+mat2.code+');'
  else
     result:=mat1.code + '.Subst('+mat2.code+');'

end;


constructor TMatFunction.create(prev,eld:TStatement; m1:TMatrix);
begin
    inherited  create(prev,eld);
    mat1:=m1;
    gettoken; {'INV' or 'TRN'}
    gettoken; {'('}
    mat2:=NMatrix;
    check(')',IDH_MAT);
    if (mat1.idr.dim=2) and (mat2.idr.dim=2) then
    else begin seterrDimension(IDH_MAT) ; {done; fail} end;
end;

destructor TMatFunction.destroy;
begin
   mat2.free;
   inherited destroy
end;

constructor TMatCross.create(prev,eld:TStatement; m1:TMatrix);
begin
    inherited  create(prev,eld);
    mat1:=m1;
    gettoken; {'CROSS'}
    gettoken; {'('}
    mat2:=NMatrix;
    check(',',IDH_MAT);
    mat3:=NMatrix;
    check(')',IDH_MAT);
    if (mat1.idr.dim=1) and (mat2.idr.dim=1) and (mat3.idr.dim=1) then
    else  seterrDimension(IDH_MAT)
end;

destructor TMatCross.destroy;
begin
   mat3.free;
   mat2.free;
   inherited destroy
end;

function TMatInv.Code:Ansistring;
begin
   result:=mat1.Code+'.INV('+mat2.Code+');'
end;

function TMatTrn.Code:Ansistring;
begin
   result:=mat1.Code+'.TRN('+mat2.Code+');'
end;

function TMatCross.Code:Ansistring;
begin
   result:=mat1.Code+'.cross('+mat2.Code+','+mat3.Code+');'
end;



constructor TMatTransformation.create(prev,eld:TStatement; m1:TMatrix);
begin
   inherited create(prev,eld);
   mat1:=m1;
   check('=',IDH_MAT);
   transform:=transformation;
   if (mat1.idr.dim<>2) or (transform=nil) then
                         seterr('',IDH_MAT_TRANSFORM);
end;

destructor TMatTransformation.destroy;
begin
   transform.free;
   inherited destroy
end;

function TMATTransformation.Code:Ansistring;
begin
  result:=transform.code0(mat1)
end;

{********}
{redim st}
{********}
type
     TREDIM=class(TMAT)
           redim:TMatRedim;
         constructor create(prev,eld:TStatement);
         destructor destroy;override;
         //procedure exec;override;
         function Code:AnsiString;override;
     end;

constructor TREDIM.create(prev,eld:TStatement);
begin
    inherited TStatementCreate(prev,eld);
    mat1:=matrix;
    redim:=Matredim(mat1,false);
    if redim=nil then seterr('',IDH_MAT_REDIM);
end;
(*
procedure  TREDIM.exec;
begin
   redim.exec;
end;
*)
destructor TREDIM.destroy;
begin
   redim.free;
   inherited destroy;
end;

function TRedim.code:ansistring;
begin
  result:=redim.code
end;


function REDIMst(prev,eld:TStatement):TStatement;
begin
     Redimst:=TREDIM.create(prev,eld)
end;

{*************}
{string MAT st}
{*************}

function StringScalar:TPrincipal; {nilのこともある}
var
   svcp:tokensave;
   p:TPrincipal;
begin
   p:=nil;
   savetoken(svcp);
   inc(trying);
   try
       p:=StringPrimary;
   except
       on SyntaxError do
         begin
            restoretoken(svcp);
            p.free;
            p:=nil;
         end;
   else
      dec(trying);
      raise;
   end;
   StringScalar:=p;
end;


type
   TArrayOp=Class
     //function get:TArray;virtual;abstract;
     function ArrayCode:AnsiString;virtual;abstract;
   end;

   TStringArray=class(TArrayOp)
       mat2:TMatrix;
      constructor create(m2:TMatrix);
      //function get:TArray;override;
      destructor destroy;override;
      function ArrayCode:AnsiString;override;
    end;

    TStringArraySubstring=class(TStringArray)
       exp1,exp2:TPrincipal;
       CharacterByte:Boolean;
      constructor create(m2:TMatrix);
      //function get:TArray;override;
      destructor destroy;override;
      function ArrayCode:AnsiString;override;
    end;

   TStringNullArray=Class(TArrayOp)
       mat1:TMatrix;          //copy pointer. should not be FREEed.
      constructor create(m1:TMatrix);
      //function get:TArray;override;
     function ArrayCode:AnsiString;override;
    end;

   TStringNullArrayRedim=Class(TStringNullArray)
       redim:TMatRedim;
      constructor create(m1:TMatrix);
      //function get:TArray;override;
      destructor destroy;override;
     function ArrayCode:AnsiString;override;
    end;

   TStringArrayConcatLeft=class(TArrayOp)
       exp1:TPrincipal;
       Array2:TArrayOp;
      constructor create(e1:TPrincipal; a2:TArrayOp);
      //function get:TArray;override;
      destructor destroy;override;
     function ArrayCode:AnsiString;override;
   end;

   TStringArrayConcatRight=class(TArrayOp)
       Array1:TArrayOp;
       exp2:TPrincipal;
      constructor create(a1:TArrayOp; e2:TPrincipal);
      //function get:TArray;override;
      destructor destroy;override;
     function ArrayCode:AnsiString;override;
   end;

   TStringArrayConcat=class(TArrayOp)
       Array1,Array2:TArrayOp;
      constructor create(a1,a2:TArrayOp);
      //function get:TArray;override;
      destructor destroy;override;
     function ArrayCode:AnsiString;override;
   end;


constructor TStringArray.create(m2:TMatrix);
begin
  inherited create;
  mat2:=m2;
end;

destructor TStringArray.destroy;
begin
    mat2.free;
    inherited destroy;
end;

constructor TStringArraySubstring.create(m2:TMatrix);
begin
    inherited create(m2);
    SubstringQualifier(exp1,exp2);
    CharacterByte:=ProgramUnit.CharacterByte;
end;


destructor TStringArraySubstring.destroy;
begin
   exp1.free;
   exp2.free;
   inherited destroy;
end;

constructor TStringNullArray.create(m1:TMatrix);
begin
   inherited create;
   mat1:=m1;
end;

constructor TStringNullArrayRedim.create(m1:TMatrix);
begin
  inherited create(m1);
  redim:=MatRedim(mat1,false);
end;

destructor TStringNullArrayRedim.destroy;
begin
 redim.free;
 inherited destroy;
end;

constructor TStringArrayConcatLeft.create(e1:TPrincipal; a2:TArrayOp);
begin
   inherited create;
   exp1:=e1;
   Array2:=a2;
end;


destructor  TStringArrayConcatLeft.destroy;
begin
  exp1.free;
  Array2.free;
  inherited destroy;
end;

constructor TStringArrayConcatRight.create(a1:TArrayOp; e2:TPrincipal);
begin
   inherited create;
   Array1:=a1;
   exp2:=e2;
end;

destructor TStringArrayConcatRight.destroy;
begin
  Array1.free;
  exp2.free;
  inherited destroy;
end;

constructor TStringArrayConcat.create(a1,a2:TArrayOp);
begin
   inherited create;
   Array1:=a1;
   Array2:=a2;
end;

destructor TStringArrayConcat.destroy;
begin
   Array1.free;
   Array2.free;
   inherited destroy;
end;

function StringArrayPrimary(mat1:TMatrix):TArrayOp;
var
   mat2:TMatrix;
begin
   if token='NUL$' then
      begin
         gettoken;
         if token='(' then
            result:=TStringNullArrayRedim.create(mat1)
         else
            result:=TStringNullArray.create(mat1)
      end
   else
      begin
         mat2:=SMatrix;
         if mat2.idr.dim<>mat1.idr.dim then seterrDimension(IDH_MAT_STRING);
         if token='(' then
            result:=TStringArraySubstring.create(mat2)
         else
            result:=TStringArray.create(mat2)
      end;
   //gettoken;
end;

function StringArrayOperation(mat1:TMatrix):TArrayOp;
var
   exp1,exp2:TPrincipal;
begin
   exp1:=StringScalar;
   if exp1<>nil then
      begin
         check('&',IDH_MAT_STRING);
         result:=TStringArrayConcatLeft.create(exp1,StringArrayPrimary(mat1))
      end
   else
      begin
         result:=StringArrayPrimary(mat1);
         if token='&' then
            begin
                gettoken;
                exp2:=StringScalar;
                if exp2<>nil then
                   result:=TStringArrayConcatRight.create(result,exp2)
                else
                   result:=TStringArrayConcat.create(result,StringArrayPrimary(mat1))
            end;
      end;
   //gettoken;
end;

{Gen Code}

function TStringArray.ArrayCode:AnsiString;
begin
   result:=mat2.code+'.newcopy '
end;

function TStringArraySubstring.ArrayCode:AnsiString;
begin
   if CharacterByte then
      result:=mat2.code+'.newcopySubstringByte('+exp1.code+','+exp2.code+')'
   else
      result:=mat2.code+'.newcopySubstring('+exp1.code+','+exp2.code+')'
end;



function TStringNullArray.ArrayCode:AnsiString;
begin
   result:=mat1.Code+'.NulCopy '
end;

function TStringNullArrayRedim.ArrayCode:AnsiString;
begin
   Result:=redim.CreateCode;
end;


function TStringArrayConcatLeft.ArrayCode:AnsiString;
begin
  result:='ConCatArray('+exp1.code+','+Array2.ArrayCode+')'
end;

function TStringArrayConcatRight.ArrayCode:AnsiString;
begin
  result:='ConCatArray('+Array1.Arraycode+','+exp2.Code+')'
end;


function TStringArrayConcat.ArrayCode:AnsiString;
begin
  result:='ConCatArray('+Array1.Arraycode+','+Array2.ArrayCode+')'
end;



type
   TStringMAT=class(TMat)
      ArrayOp:TArrayOp;
      constructor create(prev,eld:TStatement; m1:TMatrix);
      procedure createsub;virtual;
      //procedure exec;override;
      destructor destroy;override;
     function Code:AnsiString;override;
   end;

   TStringMatSubstring=Class(TStringMat)
      exp1,exp2:TPrincipal; // substring
      procedure createsub;override;
      //procedure exec;override;
      destructor destroy;override;
      function Code:AnsiString;override;
    end;

constructor TStringMat.create(prev,eld:TStatement; m1:TMatrix);
begin
   inherited Create(prev,eld);
   mat1:=m1;
   createsub;
   ArrayOp:=StringArrayOperation(mat1);
end;

procedure TStringMat.CreateSub;
begin
   check('=',IDH_MAT_STRING);
end;

procedure TStringMatSubstring.CreateSub;
begin
   SubstringQualifier(exp1,exp2);
   check('=',IDH_MAT_STRING);
end;

function TStringMat.Code:Ansistring;
begin
     result:=mat1.code+'.Subst('+ArrayOp.ArrayCode+');'
end;

function TStringMatSubstring.Code:Ansistring;
begin
   if Punit.CharacterByte then
       result:=mat1.code+'.SubstSubstringByte('+exp1.code+','+exp2.code+','+ArrayOp.ArrayCode+');'
   else
       result:=mat1.code+'.SubstSubstring('+exp1.code+','+exp2.code+','+ArrayOp.ArrayCode+');'
end;

destructor TStringMAT.destroy;
begin
      ArrayOp.free;
      inherited destroy;
end;

destructor TStringMatSubstring.destroy;
begin
   exp1.free;
   exp2.free;
   inherited destroy;
end;

function MATstring(prev,eld:TStatement; mat1:TMatrix):TStatement;
begin
   if token='(' then
      result:=TStringMatSubstring.create(prev,eld,mat1)
   else
      result:=TStringMat.create(prev,eld,mat1);
end;



{**************}
{MAT statements}
{**************}

function MATst(prev,eld:TStatement):TStatement;
begin
  MATst:=nil;
  if (nexttoken='=') {or (nexttoken='.')} or (tokenspec=SIdf) then
          MATst:=MAToperation1(prev,eld)
  else if token='READ' then
           begin
                gettoken;
                MATst:=MatReadst(prev,eld)
           end
  else if token='INPUT' then
           begin
                 gettoken;
                 MATst:=MatINPUTst(prev,eld)
           end
  else if token='LINE' then
           begin
                 gettoken;
                 checktoken('INPUT',IDH_MAT_INPUT);
                 MATst:=MatLineINPUTst(prev,eld)
           end
  else if token='PRINT' then
           begin
                  gettoken;
                  MatSt:=MatPrintst(prev,eld);
           end
  else if token='WRITE' then
           begin
                  gettoken;
                  MatSt:=MatWritest(prev,eld);
           end
  else  if (token='PLOT') or (token='GRAPH') then
          begin
                  gettoken;
                  matst:=MATPLOTst(prev,eld)
          end
  else  if (token='LOCATE') or (token='GET') then
          begin
                  gettoken;
                  matst:=MATLOCATEst(prev,eld)
          end
  else if token='REDIM' then
           begin
                gettoken;
                MATst:=Redimst(prev,eld)
           end
  else
          begin
             seterrillegal(token,IDH_MAT);
          end;
end;

procedure statementTableinit;
begin
   StatementTableInitImperative('MAT',MATst);
   StatementTableInitImperative('REDIM',REDIMst);
end;

begin
   tableInitProcs.accept(statementTableinit);
end.
