unit matexpr;

{$mode Delphi}

interface

uses
  Classes, SysUtils,  Contnrs,
  base, base0, struct, variabl, express;



 type
  TMatExp=class(TMyObject)
         dim:longint;
         //trndim:shortint;
         optionbase:shortint;
      constructor create;
      function OverflowErCode:integer;override;
      function OpName:string;override;
      procedure AskSize(var d:integer; var lb,ub:array4);virtual;abstract;
      //procedure evalA(const a:TArray);virtual;abstract;
      function Code:ansistring;virtual;abstract;
      function CodeA:ansistring;virtual;abstract;
      function name:ansistring; virtual;
     private
        idrec:TIdRec;
      function isRowVector:boolean;virtual;
      function isColumnVector:Boolean;virtual;
      function isSqareMatrix:boolean;virtual;

  end;

 function MatExp:TmatExp;
 function CompositeMat(prev,eld:TStatement):TStatement;
 function CombinedMatOperation(prev,eld:TStatement;mat1:TMatrix):TStatement;
 function TRNmatst(prev,eld:TStatement):TStatement;
 function ROWCOLUMNst(prev,eld:TStatement):TStatement;

implementation
uses
   texthand, HelpCtex,  mat,  sconsts;

//type
//   TArrayClass = class of TArray;

var
   SeqCounter:cardinal=0;
function HiddenArrayName:string;
begin
   result:='_HiddenArray_'+Format('%5.5u',[SeqCounter]);
   inc(SeqCounter)
end;

{*****************}
{Matrix Expression}
{*****************}

 constructor TMatExp.create;
 begin
   inherited create;
   optionbase:=programunit.ArrayBase;
   {    保留
   case programunit.arithmetic of
       PrecisionNormal              :classtype:=TNArray;
       PrecisionNative              :classtype:=TFArray;
       PrecisionComplex             :classtype:=TCArray;
       PrecisionRational            :classtype:=TRArray;
   end;
   }
 end;

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

function TMatExp.OpName:string;
begin
   result:='Matrix exppression'
end;

function TMatExp.isRowVector:boolean;
begin
   result:=false;
end;

function TMatExp.isColumnVector:Boolean;
begin
   result:=false;
end;

function TMatExp.isSqareMatrix:boolean;
begin
   result:=false;
end;

function TMatExp.name:ansistring;
begin
  result:=idrec.literal;
end;

{**********}
{TMatMatrix}
{**********}
type
  TMatMatrix=class(TMatExp)
      mat1:TMatrix;
     constructor create(mat01:TMatrix);
     destructor destroy;override;
     //procedure evalA(const a:TArray);override;
     procedure AskSize(var d:integer; var lb,ub:array4);override;
     function Code:ansistring;   override;
     function CodeA:ansistring;   override;
     function name:ansistring; override;
  private
     function isRowVector:boolean;override;
     function isColumnVector:Boolean;override;
     function isSqareMatrix:boolean;override;
   end;

 constructor TMatMatrix.create(mat01:TMatrix);
 begin
   inherited create;
   mat1:=mat01;
   dim:=mat1.idr.dim;
   //name:=mat1.code;
 end;

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

{
procedure  TMatMatrix.evalA(const a:TArray);
begin
  a.matsubst(mat1.ptr as TArray);               //copyを返す
end;
}

procedure TMatMatrix.AskSize(var d:integer; var lb,ub:array4);
begin
   with mat1.idr  do
      begin
         d:= dim;
        lb:=lbound;
        ub:=ubound;
      end;
    if d<2 then
       begin
        lb[2]:=optionbase;
        ub[2]:=lb[2]
       end;
    if d<3 then
       begin
        lb[3]:=optionbase;
        ub[3]:=lb[3]
       end;
    if d<4 then
       begin
        lb[4]:=optionbase;
        ub[4]:=lb[4]
       end;
    if mat1.idr.PRM then
      begin
        ub[1]:=lb[1]-1; ub[2]:=lb[1]-1; ub[3]:=lb[3]-1; ub[4]:=lb[4]-1
      end;

end;

function TMatMatrix.Code:ansistring;
begin
    result:=mat1.code;
end;

function TMatMatrix.CodeA:ansistring;
begin
    result:='';
end;

function TMatMatrix.name:ansistring;
begin
   result:=mat1.idr.Literal;
end;

function TMatMatrix.isRowVector:boolean;
begin
   with mat1.idr do
      result:=(dim=1) or (dim=2) and (ubound[1]=lbound[1]);
end;

function TMatMatrix.isColumnVector:Boolean;
begin
  with mat1.idr do
      result:=(dim=1) or (dim=2) and (ubound[2]=lbound[2]);
end;

function TMatMatrix.isSqareMatrix:boolean;
begin
   with mat1.idr do
      result:=(dim=2) and (ubound[1]-lbound[1]=ubound[2]-lbound[2]);
end;

{****************}
{TCompositeMatrix}
{****************}

type TVarList=class( Contnrs.TobjectList);

type
  TCompositeMatrix=Class(Tmatexp)
     VarList:TVarList;
     constructor create(VarList0:TvarList);
     destructor destroy;override;
     procedure AskSize(var d:integer; var lb,ub:array4);override;
  private
      function isRowVector:boolean;override;
   end;


 TCompositeMatrixF=Class(TCompositeMatrix)
  // procedure evalA(const a:TArray);override;
    function Code:ansistring;override;
    function codeA:ansistring;override;
  end;

 TCompositeMatrixC=Class(TCompositeMatrixF)
    function Code:ansistring;override;
 end;

 TCompositeMatrixN=Class(TCompositeMatrix)
   // procedure evalA(const a:TArray);override;
  function Code:ansistring;override;
  function codeA:ansistring;override;
  end;




constructor TCompositeMatrix.create(VarList0:TvarList);
var
    nam:ansistring;
    vari:TVariable;
    exp:TPrincipal;
    d,i,j:integer;
    lb,ub:array4;
    proc:TRoutine;
begin
  inherited create;
  VarList:=VarList0;
  dim:=1;

  if pass=2 then
       begin
          AskSize(d,lb,ub);
          nam:=HiddenArrayName;
          idrec:=TIdRec.InitArray(nam,d, lb,ub, intern,maxint);
          if localroutine<>nil then
             proc:=localroutine
          else
             proc:=ProgramUnit;
          Proc.VarTable.add(idrec);
          //name:='_'+nam;
       end;
end;

destructor TCompositeMatrix.destroy;
begin
  VarList.free;
  inherited destroy;
end;

procedure TCompositeMatrix.AskSize(var d:integer; var lb,ub:array4);
begin
  d:=dim;
  lb[1]:=optionbase;;
  lb[2]:=lb[1];
  lb[3]:=lb[1];
  lb[4]:=lb[1];
  ub[1]:=lb[1]+VarList.count-1;
  ub[2]:=lb[2];
  ub[3]:=lb[3];
  ub[4]:=lb[4];
end;


function TCompositeMatrix.isRowVector:boolean;
begin
   result:=true;
end;

function TCompositeMatrixF.code:ansistring;
var
    i:integer;
    exp:TPrincipal;
begin
  exp:=VarList[0] as TPrincipal;
  result:='matrixInit('+name+',['+exp.Code;
  for i:=1 to VarList.count -1 do
     begin
           exp:=VarList[i] as TPrincipal;
           result:=result + ',' +exp.code;
     end;
  result:=result+'])';

end;

function TCompositeMatrixC.code:ansistring;
var
    i:integer;
    exp:TPrincipal;
begin
  exp:=VarList[0] as TPrincipal;
  result:='matrixInit('+name+',['+'TComplex.create('+exp.code+')';
  for i:=1 to VarList.count -1 do
     begin
           exp:=VarList[i] as TPrincipal;
           result:=result + ',' +'TComplex.create('+exp.code+')';
     end;
  result:=result+'])';
end;

function TCompositeMatrixN.code:ansistring;
var
    i:integer;
    exp:TPrincipal;
begin
  exp:=VarList[0] as TPrincipal;
  result:='matrixInit('+name+',['+'TNumber.create('+exp.code+')';
  for i:=1 to VarList.count -1 do
     begin
           exp:=VarList[i] as TPrincipal;
           result:=result + ',' +'TNumber.create('+exp.code+')';
     end;
  result:=result+'])';
end;


function  TCompositeMatrixF.codeA:ansistring;
var
    exp:TPrincipal;
    d,i,j:integer;
    lb,ub:array4;

begin
  // 隠れた配列に，VarListから数値を逐次代入する。
AskSize(d,lb,ub);
result:='';
for i:=0 to VarList.Count -1 do
   begin
      exp:=VarList[i] as TPrincipal;
      j:=i+lb[1];
      result:=result+EOL
             +name + '.elements^[' + name + '.index(' + strint(j) + ')]:=' + exp.Code + ';';
   end;
end;



function  TCompositeMatrixN.codeA:ansistring;
var
    exp:TPrincipal;
    d,i,j:integer;
    lb,ub:array4;

begin
  // 隠れた配列に，VarListから数値を逐次代入する。
  AskSize(d,lb,ub);
  result:='';
for i:=0 to VarList.Count -1 do
   begin
      exp:=VarList[i] as TSubstance;
      j:=i+lb[1];
      result:=result+EOL
            + 'LETD([@'+name+',_A.elements^['+name+'.index(' + strint(j) + ')]],' + exp.Code + ');'
   end;

end;

type
  TMatOPIDN=class(TMatExp)
        exp:TPrincipal;
   constructor create(e:TPrincipal);
   procedure AskSize(var d:integer; var lb,ub:array4);override;
   function Code:ansistring;   override;
   function CodeA:AnsiString;override;
   //procedure evalA(const a:TArray);override;
  private
    function isSqareMatrix:boolean;override;
  end;

constructor TMatOPIDN.create(e:TPrincipal);
var
   d:integer;
   lb,ub:array4;
   proc:TRoutine;
   nam:ansistring;
begin
  inherited create;
  dim:=2;
  exp:=e;
  if e=nil then
       seterr('IDN must be accompanied by (numeral 2 or bigger)',IDH_MAT);

  if pass=2 then
       begin
          AskSize(d,lb,ub);
          nam:=HiddenArrayName;
          idrec:=TIdRec.InitArray(nam,d, lb,ub, intern,maxint);
          //own1:=idrec.subs;
          if localroutine<>nil then
             proc:=localroutine
          else
             proc:=ProgramUnit;
          Proc.VarTable.add(idrec);
          //name:='_'+nam;
       end;                                ;
end;


procedure TMatOPIDN.AskSize(var d:integer;  var lb,ub:array4);
var
   i:integer;
begin
  d:=2;
  i:=0;
  if (exp<>nil) and exp.isConstant then
     i:=exp.evalLongInt;
  lb[1]:=optionbase;;
  lb[2]:=lb[1];
  lb[3]:=lb[1];
  lb[4]:=lb[1];
  ub[1]:=lb[1]+i-1;
  ub[2]:=lb[2]+i-1;
  ub[3]:=lb[3];
  ub[4]:=lb[4];
end;

function TMatOPIDN.isSqareMatrix:boolean;
begin
   result:=true;
end;



function TMatOPIDN.Code:AnsiString;
begin
  result:='matrixIDN('+name+','+exp.code+')';
end;


function TMatOPIDN.CodeA:AnsiString;
begin
  result:=name+'.IDN;';
end;


type
  TmatOp1=Class(TmatExp)
     matexp1:TMatExp;
    constructor create(matexp01:TMatExp);
    destructor destroy;override;
    procedure AskSize(var d:integer; var lb,ub:array4);override;
  private
      function isRowVector:boolean;override;
      function isColumnVector:Boolean;override;
      function isSqareMatrix:boolean;override;
   end;

constructor TmatOp1.create(matexp01:TMatExp);
var
   d:integer;
   lb,ub:array4;
   proc:TRoutine;
   nam:ansistring;
begin
   inherited create;
   matexp1:=matexp01;
   dim:=matexp1.dim;
   if pass=2 then
      begin
         AskSize(d,lb,ub);
         nam:=HiddenArrayName;
         idrec:=TIdRec.InitArray(nam,d, lb,ub, intern,maxint);
         //own1:=idrec.subs;
         if localroutine<>nil then
            proc:=localroutine
         else
            proc:=ProgramUnit;
         Proc.VarTable.add(idrec);
         //name:='_'+nam;
      end;
end;

destructor TmatOp1.destroy;
begin
  matexp1.free;
  inherited destroy;
end;

procedure TmatOp1.AskSize(var d:integer; var lb,ub:array4);
begin
   matexp1.asksize(d,lb,ub);
end;

function TmatOp1.isRowVector:boolean;
begin
  result:=matexp1.isRowVector;
end;

function TmatOp1.isColumnVector:Boolean;
begin
  result:=matexp1.isColumnVector;
end;

function TmatOp1.isSqareMatrix:boolean;
begin
  result:=matexp1.isSqareMatrix;
end;


type
  TMatOpTRN=class(TMatOp1)
    constructor create(matexp01:TMatExp);
    procedure AskSize(var d:integer; var lb,ub:array4);override;
    //procedure evalA(const a:TArray);override;
    function Code:ansistring;   override;
    function codeA:ansistring;override;
  private
     function isRowVector:boolean;override;
     function isColumnVector:Boolean;override;
  end;

constructor TMatOpTRN.create(matexp01:TMatExp);
var
   d:integer;
   lb,ub:array4;
   nam:ansistring;
begin
  inherited create(matexp01);
  if dim=1 then
       begin dim:=2; {trndim:=1} end;
  if dim<>2 then
         seterrDimension(IDH_MAT);

end;

procedure TMatOpTRN.AskSize(var d:integer; var lb,ub:array4);
var
  t:integer;
begin
  matexp1.AskSize(d,lb,ub);
  if d=2 then
     begin
         t:=ub[1];
         ub[1]:=ub[2];
         ub[2]:=t
     end
  else if d=1 then
     begin
        d:=2;
        //ub[2]:=ub[1];
        //ub[1]:=1;
     end
  else
     seterrDimension(IDH_MAT);
end;


function TMatOpTRN.isRowVector:Boolean;
begin
  result:=matexp1.isColumnVector;
end;

function TMatOpTRN.isColumnVector:boolean;
begin
  result:=matexp1.isRowVector;
end;



function TmatOpTRN.Code:ansistring;
begin
   result:='matrixTRN('+name+','+matexp1.code+')'
end;

function TmatOpTRN.CodeA:ansistring; //隠れた配列を追加し，転置行列を代入する

begin
   result:=matexp1.CodeA+EOL
          +name + '.trn('+matexp1.name+');';
 end;



type
  TMatOpInv=class(TMatOp1)
    constructor create(matexp01:TMatExp);
    //procedure evalA(const a:TArray);override;
    function codeA:ansistring;override;
    function Code:ansistring;   override;
    function InvalidErCode:integer;override;
    function OpName:string;override;
  end;

constructor TMatOpInv.create(matexp01:TMatExp);

begin
     inherited create(matexp01);
     if dim<>2 then
         seterrDimension(IDH_MAT);
end;

function TMatOpINV.code:ansistring;
begin
    result:='matrixINV('+name+','+matexp1.code+')';
end;

function TmatOpINV.CodeA:ansistring;
//隠れた配列を追加し，転置行列を代入する

begin
  result:=matexp1.CodeA+EOL
         +name + '.inv('+matexp1.name+');';
 end;



function TMatOpInv.InvalidErCode:integer;
begin
   result:=3009
end;

function TMatOpInv.OpName:string;
begin
  result:='MAT INV'
end;

type
  TMatOpCnj=class(TMatOp1)
      function Code:ansistring; override;
      function codeA:ansistring;override;
   // procedure evalA(const a:TArray);override;
  end;

 function TmatOpCNJ.Code:ansistring;
  begin
    result:='matrixCNJ('+name +','+matexp1.code+')';
   end;

  function TmatOpCNJ.CodeA:ansistring;
  //隠れた配列に，転置行列を代入する
  begin
    result:=matexp1.CodeA+EOL
           +name + '.conj('+matexp1.name+');';
   end;




type
  TMatPower=Class(TmatOp1)
     exp1:TPrincipal;          //指数
     constructor create(matexp01:TMatexp; exp01:TPrincipal);
     function Code:ansistring;   override;
     function codeA:ansistring;override;
     destructor destroy;override;
     //procedure evalA(const a:TArray);override;
  end;

constructor TMatPower.create(matexp01:TMatexp; exp01:TPrincipal);
begin
  inherited create(Matexp01);
  if (dim<>2) or not isSqareMatrix then
      seterrDimension(IDH_MAT);
  exp1:=exp01;
end;

destructor TMatPower.destroy;
begin
  exp1.free;
  inherited destroy
end;


function TMatPower.Code:ansistring;
begin
   result:='matrixPOWER('+name +','+matexp1.code+','+exp1.Code+')';
 end;

function TMatPower.CodeA:ansistring;
begin
   result:=matexp1.CodeA+EOL
         +name + '.power('+matexp1.name+','+exp1.Code+');';
 end;


type
    TMatScalar=Class(TmatOp1)
     exp1:TPrincipal;          //スカラー
     constructor create(exp01:TPrincipal; matexp01:TMatexp);
     destructor destroy;override;
     function Code: ansistring;override;
     function CodeA:ansistring;override;
    // procedure evalA(const a:TArray);override;
    end;

constructor TMatScalar.create(exp01:TPrincipal; matexp01:TMatexp);
begin
  inherited create(matexp01);
  exp1:= exp01
end;

destructor TMatScalar.destroy;
begin
  exp1.free;
  inherited destroy;
end;

function TMatScalar.Code:ansistring;
begin
   result:='matrixScalar('+name+','+exp1.Code+','+matexp1.code+')';
end;


function TMatScalar.CodeA:ansistring;
begin
   result:=matexp1.CodeA+EOL
         +name + '.scalar('+exp1.Code+','+matexp1.name+');';
end;



type
    TmatOp2=Class(TmatExp)
      matexp1,matexp2:TMatExp;
     constructor create(matexp01,matexp02:TMatExp);
     destructor destroy;override;
    private
         function isRowVector:boolean;override;
         function isColumnVector:Boolean;override;
         function isSqareMatrix:boolean;override;
   end;

    TMatMulti=Class(TmatOp2)
     constructor create(matexp01,matexp02:TMatExp);
     procedure AskSize(var d:integer; var lb,ub:array4);override;
     function Code:ansistring;   override;
     function codeA:ansistring;override;
     //procedure evalA(const a:TArray);override;
    end;

    TMatAdd=Class(TmatOp2)
     constructor create(matexp01,matexp02:TMatExp);
     procedure AskSize(var d:integer; var lb,ub:array4);override;
     function Code:ansistring;   override;
     function codeA:ansistring;override;
     //procedure evalA(const a:TArray);override;
    end;

    TMatSbt=Class(TMatAdd)
     function Code:ansistring;   override;
     function codeA:ansistring;override;
     //procedure evalA(const a:TArray);override;
    end;

constructor TmatOp2.create(matexp01,matexp02:TMatExp);
var
   d:integer;
   lb,ub:array4;
   proc:TRoutine;
   nam:ansistring;
begin
   inherited create;
   matexp1:=matexp01;
   matexp2:=matexp02;
   dim:=matexp1.dim;
   if pass=2 then
      begin
         AskSize(d,lb,ub);
         nam:=HiddenArrayName;
         idrec:=TIdRec.InitArray(nam,d, lb,ub, intern,maxint);
         //own1:=idrec.subs;
         if localroutine<>nil then
            proc:=localroutine
         else
            proc:=ProgramUnit;
         Proc.VarTable.add(idrec);
         //name:='_'+nam;
      end;
end;

destructor TmatOp2.destroy;
begin
  matexp1.free;
  matexp2.free;
  inherited destroy;
end;


function TmatOp2.isRowVector:boolean;
begin
  result:=matexp1.isRowVector;
end;

function TmatOp2.isColumnVector:Boolean;
begin
  result:=matexp2.isColumnVector;
end;

function TmatOp2.isSqareMatrix:boolean;
begin
  result:=matexp1.isSqareMatrix and matexp2.isSqareMatrix
end;


constructor TmatMulti.create(matexp01,matexp02:TMatExp);
begin
  inherited create(matexp01,matexp02);
  if (matexp1.dim=1) and (matexp2.dim=2) then
     dim:=1
  else if (matexp1.dim=2)  and (matexp2.dim=2) then
     begin
        dim:=2;
        //if matexp2.trndim=1 then
        //   trndim:=1;
     end
  else
     seterrDimension(IDH_MAT);
end;

constructor TmatAdd.create(matexp01,matexp02:TMatExp);
begin
  inherited create(matexp01,matexp02);
  dim:=matexp1.dim;
  if dim<>matexp2.dim then
     seterrDimension(IDH_MAT);
end;

procedure TMatMulti.AskSize(var d:integer; var lb,ub:array4);
var
    d1,d2:integer;
    lb1,ub1,lb2,ub2:array4;
begin

    matexp1.asksize(d1,lb1,ub1);
    matexp2.asksize(d2,lb2,ub2);
    if d1=1 then
       begin
         d:=1;
         lb:=lb1;
         ub:=ub1
       end
    else
       begin
          d:=2;
          lb:=lb1;
          ub:=ub1;
          ub[2]:=lb[2]+ub2[2]-lb2[2];
          if (ub1[2]-lb1[2])<>(ub2[1]-lb2[1]) then
             seterrDimension(IDH_MAT);
      end;
end;

function TMatMulti.code:ansistring;
begin
  result:='matrixProd('+name +','+matexp1.code+','+matexp2.code+')';
end;

function TMatAdd.code:ansistring;
begin
   result:='matrixAdd('+name +','+matexp1.code+','+matexp2.code+')';

end;

function TMatSbt.code:ansistring;
begin
   result:='matrixSbt('+name +','+matexp1.code+','+matexp2.code+')';

end;

function TMatMulti.codeA:ansistring;
begin
  result:=matexp1.CodeA+EOL+matexp2.CodeA+EOL
         +name + '.Prod('+matexp1.name+','+matexp2.name+');';
end;

function TMatAdd.codeA:ansistring;
begin
  result:=matexp1.CodeA+EOL+matexp2.CodeA+EOL
         +name + '.Add('+matexp1.name+','+matexp2.name+');';
end;

function TMatSbt.codeA:ansistring;
begin
  result:=matexp1.CodeA+EOL+matexp2.CodeA+EOL
         +name + '.Sub('+matexp1.name+','+matexp2.name+');';
end;


{
function SameSize(d:integer; var size1,size2:array4):boolean;
var
  i:integer;
begin
  result:=true;
  for i:=1 to d do
      if size1[i]<>size2[i] then result:=false
end;
}

procedure TMatAdd.AskSize(var d:integer; var lb,ub:array4);
var
    d2:integer;
    lb2,ub2:array4;
begin
    matexp1.asksize(d,lb,ub);
    matexp2.asksize(d2,lb2,ub2);
    if (d<>d2) {or not samesize(d,lb,lb2)  or not samesize(d,ub,ub2)} then
       seterrDimension(IDH_MAT);
end;


function CompositeMatrix:TMatExp;
var
  VarList:TVarList;
  exp:TPrincipal;
begin
  VarList:=TVarList.create;
  try
     repeat
         exp:= NExpression ;
         VarList.add(exp);
     until not test(',');
     case programunit.arithmetic of
        PrecisionNormal              :result:=TCompositeMatrixN.create(VarList);
        PrecisionNative              :result:=TCompositeMatrixF.create(VarList);
        PrecisionComplex             :result:=TCompositeMatrixC.create(VarList);
     end;
  except
     VarList.free;
     result:=nil;
  end;
end;


{*******************}
{MAT ROW, MAT COLUMN}
{*******************}

type
   TMatRow1=class(TMatMatrix)                       //単一行を抽出した1次元ベクトル
      exp1:TPrincipal;
     constructor create(mat0:TMatrix; exp01:TPrincipal);
     destructor destroy;override;
     procedure AskSize(var d:integer; var lb,ub:array4);override;
     function Code:ansistring;   override;
     function name:ansistring; override;
     //procedure evalA(const a:TArray);override;
     //procedure AskActSize(var d:integer; var sz:array4);override;
  private
     procedure checkdim;
   end;

   TMatColumn1=class(TMatRow1)                   //単一列を抽出した1次元ベクトル
      procedure AskSize(var d:integer; var lb,ub:array4);override;
      function Code:ansistring;   override;
     //procedure evalA(const a:TArray);override;
     //procedure AskActSize(var d:integer; var sz:array4);override;
   private
   end;



constructor TMatRow1.create(mat0:TMatrix; exp01:TPrincipal);
var
  d:integer;
  lb,ub:array4;
  nam:ansistring;
  proc:TRoutine;
begin
    inherited  create(mat0);
    dim:=1;
    exp1:=exp01;
    checkDim;
    if pass=2 then
      begin
         AskSize(d,lb,ub);
         nam:=HiddenArrayName;
         idrec:=TIdRec.InitArray(nam,d, lb,ub, intern,maxint);
         if localroutine<>nil then
            proc:=localroutine
         else
            proc:=ProgramUnit;
         Proc.VarTable.add(idrec);
         //name:='_'+nam;
      end;
end;

destructor TMatRow1.destroy;
begin
   exp1.free;
   inherited destroy
end;

procedure TMatRow1.checkDim;
begin
  if  mat1.idr.dim=2 then
  else
       seterrDimension(IDH_MAT)
 end;

procedure TMatRow1.AskSize(var d:integer; var lb,ub:array4);
begin
     with mat1.idr  do
      begin
        lb:=lbound;
        ub:=ubound;
      end;
  d:=1;
  ub[1]:=ub[2];
  ub[2]:=lb[2];
  if mat1.idr.PRM then
    begin lb[1]:=optionbase; ub[1]:=lb[1]-1 end;
end;

function TMatRow1.name:ansistring;
begin
  result:=idrec.literal;
end;

function TMatRow1.code:ansistring;
begin
  result:='matrixRow1('+name +','+mat1.code+','+exp1.code+')';
end;

procedure TMatColumn1.AskSize(var d:integer; var lb,ub:array4);
begin
   with mat1.idr  do
    begin
      lb:=lbound;
      ub:=ubound;
    end;
   d:=1;
  //ub[1]:=ub[1];
  ub[2]:=lb[2];
  if mat1.idr.PRM then
    begin lb[1]:=optionbase; ub[1]:=lb[1]-1 end;
end;

function TMatColumn1.code:ansistring;
begin
result:='matrixColumn1('+name +','+mat1.code+','+exp1.code+')';
end;

type
 TMatRow2=class(TMatMatrix)                        //複数行を抽出した2次元配列
     mat2:TMatrix;
     exp1:TPrincipal;
     exp2:tPrincipal;
  constructor create(mat0:TMatrix; exp01,exp02:TPrincipal);
  destructor destroy;override;
  procedure AskSize(var d:integer; var lb,ub:array4);override;
  function Code:ansistring;   override;
  function name:ansistring; override;
 //procedure AskActSize(var d:integer; var sz:array4);override;
  //procedure evalA(const a:TArray);override;
  private procedure checkdim;
end;

TMatColumn2=class(TMatRow2)                   //複数列を抽出した2次元配列
 procedure AskSize(var d:integer; var lb,ub:array4);override;
 function Code:ansistring;   override;
 //procedure AskActSize(var d:integer; var sz:array4);override;
 //procedure evalA(const a:TArray);override;
end;

constructor TMatRow2.create(mat0:TMatrix; exp01,exp02:TPrincipal);
var
  d:integer;
  lb,ub:array4;
  nam:ansistring;
  proc:TRoutine;
begin
  inherited  create(mat0);
  dim:=2;
  exp1:=exp01;
  exp2:=exp02;
  checkDim;
  if pass=2 then
    begin
       AskSize(d,lb,ub);
       nam:=HiddenArrayName;
       idrec:=TIdRec.InitArray(nam,d, lb,ub, intern,maxint);
       if localroutine<>nil then
          proc:=localroutine
       else
          proc:=ProgramUnit;
       Proc.VarTable.add(idrec);
       //name:='_'+nam;
    end;
end;

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

procedure TMatRow2.checkDim;
begin
     if  mat1.idr.dim=2  then
     else
       seterrDimension(IDH_MAT)
end;

procedure TMatRow2.AskSize(var d:integer; var lb,ub:array4);
begin
  inherited AskSize(d,lb,ub); //このサイズを超えることはない。
end;

function TMatRow2.name:ansistring;
begin
  result:=idrec.literal;
end;

function TMatRow2.code:ansistring;
begin
  result:='matrixRow2('+name +','+mat1.code+','+exp1.code+','+exp2.code+')';
end;

procedure TMatColumn2.AskSize(var d:integer; var lb,ub:array4);
begin
  inherited AskSize(d,lb,ub); //このサイズを超えることはない。
end;

function TMatColumn2.code:ansistring;
begin
  result:='matrixColumn2('+name +','+mat1.code+','+exp1.code+','+exp2.code+')';
end;


function RowOrColumnFnc:TMatExp;
var
  token0:string;
  mat2:TMatrix;
  exp1,exp2:TPrincipal;
begin
  token0:=token; //'ROW' or 'COLUMN'
  gettoken;
  gettoken;      //'('
  mat2:=NMatrix;
  check(',',IDH_MAT);
  exp1:=NExpression;
  if token<>':' then
     begin
       if token0='ROW' then
          result:=TMatRow1.create(mat2,exp1)
       else
          result:=TMatColumn1.create(mat2,exp1)
     end
  else  // token=':'
     begin
       gettoken;
       exp2:=NExpression;
       if token0='ROW' then
          result:=TMatRow2.create(mat2,exp1,exp2)
       else
          result:=TMatColumn2.create(mat2,exp1,exp2)
     end;
  check(')',IDH_MAT);
end;

{****************}
{Matrix Operation}
{****************}

function matPrimary:TMatExp;
var
   svcp:TokenSave;

begin
   if token='(' then
     begin
       gettoken;
       result:=matexp;
       checktoken(')',IDH_MAT);
     end
   else if token='['  then
     begin
        gettoken;
        result:=Compositematrix;
        checktoken(']',IDH_MAT);
     end
   else if tokenspec=NIdf then
           if (token='IDN') then
              begin
                 gettoken;
                 if token='(' then
                    begin
                       gettoken;
                       result:=TMatOpIDN.create(NExpression);
                       checkToken(')',IDH_MAT);
                    end
                 else
                     result:=TMatOpIDN.create(nil);

              end
           else if (token='TRN') and (nextToken='(') then
              begin
                 gettoken;
                 gettoken;
                 result:=TMatOpTRN.create(MatExp) ;
                 checktoken(')',IDH_MAT);
              end
           else if (token='INV') and (nextToken='(') then
              begin
                 gettoken;
                 gettoken;
                 result:=TMatOpINV.create(MatExp);
                 checktoken(')',IDH_MAT);
               end
           else if (token='CNJ') and (nextToken='(') then
               begin
                  gettoken;
                  gettoken;
                  if programunit.arithmetic=PrecisionComplex then
                     result:=TMatOpCNJ.create(MatExp)
                  else
                     result:=MatExp;
                  checktoken(')',IDH_MAT);
                 end
           else if ((token='ROW') or (token='COLUMN')) and (nexttoken='(') then
                result:=RowOrColumnFnc
           else
                result:=TMatMatrix.create(matrix)

   else
     seterr(token + s_CantBelongHere  , IDH_MAT)   ;


end;


 function MatFactor:TMatExp ;
 var
    exp:TMatExp;
 begin
    exp:=MatPrimary;
    while (Token='^') and (exp<>nil)  do
          begin
            gettoken;
            exp:=TMatPower.create(exp,Primary);
          end;
    result:=exp;
end;

function MatTerm:TMatExp;
var
    pri:Tprincipal;
    exp:TMatExp ;
    svcp:TokenSave;
 begin
    try
       savetoken(svcp);
       pri:=primary;
       if token='*' then
          gettoken
       else
          begin
             restoretoken(svcp);
             pri:=nil;
          end;
    except
       restoretoken(svcp);
       statusmes.clear;            // ver.8.1.5.1
       pri:=nil;
    end;

    exp:=MatFactor;
    while (token='*')  and (exp<>nil)  do
       begin
           gettoken;
           exp:=TMatMulti.create(exp, MatFactor);
        end;
    if pri=nil then
       result:=exp
    else
       result:=TMatScalar.create(pri,exp)
 end;


function MatExp:TmatExp;
var
   exp:TMatExp;
   op:char;
 begin
   exp:=MatTerm;
   while ((token='+') or (token='-')) and (exp<>nil)  do
        begin
           op:=token[1];
           gettoken;
           case  op of
               '+': exp:=TMatAdd.create(exp,MatTerm);
               '-': exp:=TMatSbt.create(exp,MatTerm);
           end;
        end;
   result:=exp
end;



{***********************}
{Complete MAT Operartion}     //ver.8.1.5.0
{***********************}
type
    TMatSubst=class(Tmat)
       MatExp1:TMatExp;
     constructor create(prev,eld:TStatement; m1:TMatrix; e1:TMatExp);
     function code:AnsiString;override;
     destructor destroy;override;
     private
      procedure CreateDimTest;virtual;
    end;

type
    TTRNMatSubst=class(TMatSubst)
      function code:AnsiString;override;
    private
      procedure CreateDimTest;Override;
    end;

constructor TMatSubst.create(prev,eld:TStatement; m1:TMatrix; e1:TMatExp);
begin
  inherited create(prev,eld);
  mat1:=m1;
  MatExp1:=e1;
  CreateDimTest;
end;

procedure  TMatSubst.createDimTest;
begin
   if  mat1.idr.dim = MatExp1.dim then
       exit;
   if (mat1.idr.dim=1) and (MatExp1.dim=2) then
      if matexp1.isRowVector then
            exit;
   if (mat1.idr.dim=2) and (MatExp1.dim=1) then
       with mat1.idr do
         if ubound[1]=lbound[1] then                //Row Vector
             exit;
   seterrDimension(IDH_MAT);
end;


procedure  TTRNMatSubst.createDimTest;
begin
   if (mat1.idr.dim=1) and (MatExp1.dim=2) then
      if matexp1.isColumnVector then
            exit;
   if (mat1.idr.dim=2) and (MatExp1.dim=2) then
            exit;
   if (mat1.idr.dim=2) and (MatExp1.dim=1) then
        with mat1.idr do
         if ubound[2]=lbound[2] then                //Column Vector
             exit;
   seterrDimension(IDH_MAT);
end;

{
procedure  TMatSubst.createDimTest;
var
  d:integer;
  lb,ub:array4;
begin
   if (mat1.idr.dim=1) and (MatExp1.dim=2) then
      begin
         MatExp1.asksize(d,lb,ub);
         if lb[1]=ub[1] then exit;
      end;
   seterrDimension(IDH_MAT);
end;

procedure  TTRNMatSubst.createDimTest;
var
  d:integer;
  lb,ub:array4;
begin
   if (mat1.idr.dim=1) and (MatExp1.dim=2) then
      begin
         MatExp1.asksize(d,lb,ub);
         if lb[2]=ub[2] then exit;
      end;
   seterrDimension(IDH_MAT);
end;
}

destructor TMatSubst.destroy;
begin
  MatExp1.free;
  mat1.free;
  inherited destroy;
end;

function TMatSubst.code:ansistring;
begin
      result:=mat1.code + '.Subst('+matexp1.code+');'
end;

function TTRNMatSubst.code:ansistring;
begin
      result:=mat1.code + '.trn('+matexp1.code+');';
end;


function CombinedMatOperation(prev,eld:TStatement;mat1:TMatrix):TStatement;
var
   matexp1:TMatExp;
begin
  if token='=' then
     begin
      gettoken;
      matexp1:=MatExp;
      result:=TmatSubst.create(prev,eld, mat1, matexp1)
     end
end;


{********}
{TRNMatst}
{********}
function CompositeTRNMatst(prev,eld:TStatement):TStatement; forward;
function TRNmatst(prev,eld:TStatement):TStatement;
var
      mat1:TMatrix;
      matexp1:TMatExp;
begin
   gettoken;  //'TRN'
   gettoken;  //'('
   if token='[' then
      result:=CompositeTRNMatst(prev,eld)
   else
      begin
         mat1:=matrix;
         checktoken(')',IDH_MAT);
         if token='=' then
              begin
               gettoken;
               matexp1:=MatExp;
               result:=TTRNmatSubst.create(prev,eld, mat1, matexp1)
              end
      end;
   end;

{***************}
{Composite MATst}
{***************}
type TCompositeMatSubst=class(TStatement)
    VarList:TVarList;
    matexp1:TMatExp;
    trn:boolean;
      constructor create(prev,eld:TStatement; VarList0:TVarList; matexp0:TMatExp; trn0:boolean);
      //procedure exec;override;
      function code:ansistring;override;
      destructor destroy;override;
    end;

constructor TCompositeMatSubst.create(prev,eld:TStatement; VarList0:TVarList; matexp0:TMatExp; trn0:boolean);
begin
  inherited create(prev,eld);
  VarList:=VarList0;
  matexp1:=matexp0;
  trn:=trn0;
end;

destructor TCompositeMatSubst.destroy;
begin
   matexp1.free;
   VarList.Free;
   inherited destroy;
end;

function TCompositeMatSubst.code:ansistring;
 var
     i,j:Integer;
     vari:TVariable;
     d:integer;
     lb,ub:array4;
     s,t:string;
 begin
      result:='';
      if not (matexp1 is TMatMatrix) then
          result:=matexp1.Code+';'+EOL;
      matexp1.AskSize(d,lb,ub);
      s:='';
      t:='';
      if trn then
         s:=','+strint(lb[2])
      else if d=2 then
           if lb[1]=ub[1] then
             t:= strint(lb[1])+','
           else
              seterrDimension(IDH_MAT);
      for i:=0 to VarList.Count -1 do
         begin
            vari:=VarList[i] as TSubstance;
            j:=i+lb[1];
            result:=result+EOL
                  +vari.code+':='+MatExp1.name+'.elements^['+MatExp1.Name+'.index('+t+Strint(j)+s+')];';
         end;
 end;


function CompositeMat(prev,eld:TStatement):TStatement;
var
   VarList: TVarList;
   matexp1:TMatExp;
begin
    VarList:=TVarList.create;
    gettoken;  //'['
    VarList.add(NVariable);
    while test(',') do
           VarList.add(NVariable);
    checkToken(']',IDH_MAT);
    if token='=' then
       begin
        gettoken;
        matexp1:=MatExp;
        if matexp1=nil then
           seterror('Matrix error',IDH_MAT)
        else
           result:=TCompositeMatSubst.create(prev,eld, VarList, matexp1,false)
       end
end;

function CompositeTRNMatst(prev,eld:TStatement):TStatement;
var
   VarList: TVarList;
   matexp1:TMatExp;
begin
    VarList:=TVarList.create;
    gettoken;  //'['
    VarList.add(NVariable);
    while test(',') do
           VarList.add(NVariable);
    checkToken(']',IDH_MAT);
    checktoken(')',IDH_MAT);
    if token='=' then
       begin
        gettoken;
        matexp1:=MatExp;
        if matexp1=nil then
           seterror('Matrix error',IDH_MAT)
        else
           result:=TCompositeMatSubst.create(prev,eld, VarList, matexp1,true)
       end
end;


{********************}
{ROWMatst COLUMNMatst}
{********************}
type
    TROWCOLUMNmatst=Class(TMAT)
        matexp1:TMatExp;
        exp1:TPrincipal;
        exp2:TPrincipal;
       constructor create(prev,eld:TStatement; mat0:TMatrix;
                                matexp0:TMatExp;exp01,exp02:Tprincipal);
       destructor destroy;override;
      private
         procedure checkDim;virtual;abstract;
     end;

    TROWmatst=class(TROWCOLUMNmatst)               //行挿入
       //procedure exec;override;
       function Code:Ansistring;override;
     private
     procedure checkDim;override;
    end;

    TCOLUMNmatst=class(TROWCOLUMNmatst)            //列挿入
    //procedure exec;override;
    function Code:Ansistring;override;
     private
     procedure checkDim;override;
    end;

 constructor TROWCOLUMNmatst.create(prev,eld:TStatement; mat0:TMatrix;
                          matexp0:TMatExp;exp01,exp02:Tprincipal);
begin
  inherited create(prev,eld);
  mat1:=mat0;
  matexp1:=matexp0;
  exp1:=exp01;
  exp2:=exp02;
  checkDim;
end;

 destructor TROWCOLUMNmatst.destroy;
 begin
   exp2.Free;
   exp1.free;
   matexp1.Free;
   inherited destroy;
  end;

 procedure TROWmatst.checkDim;
 begin
   if (mat1.idr.dim=2)
     and  ((exp2<>nil)and (matexp1.dim=2)
         or (exp2=nil)and (matexp1.dim=1)) then
      exit
   else
   seterrDimension(IDH_MAT)
 end;

 procedure TCOLUMNmatst.checkDim;
 begin
   if (mat1.idr.dim=2)
      and    ((exp2<>nil)and (matexp1.dim=2)
          or ((exp2=nil) and (matexp1.dim=1))) then
         exit
      else
      seterrDimension(IDH_MAT)
  end;

 function TRowMatst.Code:ansistring;
 begin
   if exp2=nil then
      result:=mat1.code+'.substRow1('+exp1.code+','+matexp1.code+');'
   else
      result:=mat1.code+'.substRow2('+exp1.code+','+exp2.code+','+matexp1.code+');'
 end;

  function TColumnMatst.Code:ansistring;
 begin
   if exp2=nil then
      result:=mat1.code+'.substColumn1('+exp1.code+','+matexp1.code+');'
   else
      result:=mat1.code+'.substColumn2('+exp1.code+','+exp2.code+','+matexp1.code+');'
 end;
 {
 procedure TROWmatst.exec;
 var
   m,n:integer;
   i,j:integer;
   p1,p2:Tvar;
   a1,a2,a3:TArray;
   d:integer;
   sz:Array4;
begin
  TVar(a1):=mat1.point;
  MatExp1.AskActSize(d,sz);
  m:=exp1.evalLongint;
  if exp2=nil then    //matexp1.dim=1
     begin
           if a1.size[2]<>sz[1] then //列数不一致
             setexception(6001);
           a2:=TArrayClass(MatExp1.ArrayClassType).createnative(1,sz);
           try
            MatExp1.evalA(a2);
            if a2.amount<=a1.size[2] then
               begin
                for i:=0 to a2.amount -1 do
                    begin
                       p2:=a2.ItemSubstance0(i,false);
                       with a1 do
                          p1:=ItemSubstance0(position2(m,lbound[2]+i) ,false);
                       p1.copyfrom(p2);
                       a1.DisposeSubstance0(p1,false);
                       a2.DisposeSubstance0(p2,false);
                     end;
                end
            else
               setexception(6001);
           finally
            a2.free;
           end;
     end
  else                 //matexp1.dim=2
     begin
      if a1.size[2]<>sz[2] then //列数不一致
         setexception(6001);
       n:=exp2.evalLongint;
       m:=m-a1.lbound[1];   //インデックスm,nを0ベースに変換
       n:=n-a1.lbound[1];
       a2:=TArrayClass(MatExp1.ArrayClassType).createMatrix(sz[1],sz[2]);
       try
          MatExp1.evalA(a2);
          a3:=TArrayClass(MatExp1.ArrayClassType).createMatrix(a1.size[1]+sz[1]+m-n-1,sz[2]);
          if a3.amount>a1.maxsize then
             setexception(5001);
          for i:=0 to a3.size[1]-1 do
              for j:=0 to a3.size[2]-1 do
                  begin
                     with a3 do p1:=ItemSubstance0(position2(lbound[1]+i,lbound[2]+j),false);
                     if i<m then
                        begin
                           with a1 do
                             p2:=ItemSubstance0(position2(lbound[1]+i,lbound[2]+j),false);
                           p1.copyfrom(p2);
                           a1.DisposeSubstance0(p2,false);
                        end
                     else if i<m+sz[1] then
                        begin
                          with a2 do
                            p2:=ItemSubstance0(position2(lbound[1]+i-m,lbound[2]+j),false);
                          p1.copyfrom(p2);
                          a2.DisposeSubstance0(p2,false);
                        end
                     else
                       begin
                          with a1 do
                            p2:=ItemSubstance0(position2(lbound[1]+i+n-m+1-sz[1],lbound[2]+j),false);
                          p1.copyfrom(p2);
                          a1.DisposeSubstance0(p2,false);
                       end;
                     a3.DisposeSubstance0(p1,false);
                   end;
          a1.matsubst(a3);
       finally
          a3.free;
          a2.free;
       end;

     end;
end;
}
{
procedure TCOLUMNmatst.exec;
 var
   m,n:integer;
   i,j:integer;
   p1,p2:Tvar;
   a1,a2,a3:TArray;
   d:integer;
   sz:Array4;
begin
  TVar(a1):=mat1.point;
  MatExp1.AskActSize(d,sz);
  m:=exp1.evalLongint;
  if exp2=nil then    //matexp1.dim=1
     begin
           if a1.size[1]<>sz[1] then //行数不一致
             setexception(6001);
           a2:=TArrayClass(MatExp1.ArrayClassType).createnative(1,sz);
           try
            MatExp1.evalA(a2);
            if a2.amount<=a1.size[1] then
               begin
                for i:=0 to a2.amount -1 do
                    begin
                       p2:=a2.ItemSubstance0(i,false);
                       with a1 do
                          p1:=ItemSubstance0(position2(lbound[1]+i,m) ,false);
                       p1.copyfrom(p2);
                       a1.DisposeSubstance0(p1,false);
                       a2.DisposeSubstance0(p2,false);
                     end;
                end
            else
               setexception(6001);
           finally
            a2.free;
           end;
     end
  else                 //matexp1.dim=2
     begin
      if a1.size[1]<>sz[1] then //行数不一致
         setexception(6001);
       n:=exp2.evalLongint;
       m:=m-a1.lbound[1];   //インデックスm,nを0ベースに変換
       n:=n-a1.lbound[1];
       a2:=TArrayClass(MatExp1.ArrayClassType).createMatrix(sz[1],sz[2]);
       try
          MatExp1.evalA(a2);
          a3:=TArrayClass(MatExp1.ArrayClassType).createMatrix(sz[1],a1.size[2]+sz[2]+m-n-1);
          if a3.amount>a1.maxsize then
             setexception(5001);
              for j:=0 to a3.size[2]-1 do
                for i:=0 to a3.size[1]-1 do
                  begin
                     with a3 do p1:=ItemSubstance0(position2(lbound[1]+i,lbound[2]+j),false);
                     if j<m then
                        begin
                           with a1 do
                             p2:=ItemSubstance0(position2(lbound[1]+i,lbound[2]+j),false);
                           p1.copyfrom(p2);
                           a1.DisposeSubstance0(p2,false);
                        end
                     else if j<m+sz[2] then
                        begin
                          with a2 do
                            p2:=ItemSubstance0(position2(lbound[1]+i,lbound[2]+j-m),false);
                          p1.copyfrom(p2);
                          a2.DisposeSubstance0(p2,false);
                        end
                     else
                       begin
                          with a1 do
                            p2:=ItemSubstance0(position2(lbound[1]+i,lbound[2]+j+n-m+1-sz[2]),false);
                          p1.copyfrom(p2);
                          a1.DisposeSubstance0(p2,false);
                       end;
                     a3.DisposeSubstance0(p1,false);
                   end;
          a1.matsubst(a3);
       finally
          a3.free;
          a2.free;
       end;

     end;
end;
}

function ROWCOLUMNst(prev,eld:TStatement):TStatement;
var
      mat1:TMatrix;
      matexp1:TMatExp;
      exp1,exp2:TPrincipal;
      Rowst:boolean;
begin
   Rowst:=(token='ROW');
   gettoken;  //'ROW' ,'COLUMN'
   gettoken;  //'('
   mat1:=matrix;
   checktoken(',',IDH_MAT);
   exp1:=NExpression;
   if token=':' then
     begin
      gettoken;
      exp2:=NExpression;
     end
   else
      exp2:=nil;
   checktoken(')',IDH_MAT);
   checktoken('=',IDH_MAT);
   matexp1:=MatExp;
   if Rowst then
      result:=TROWmatst.create(prev,eld, mat1, matexp1,exp1,exp2)
   else
      result:=TCOLUMNmatst.create(prev,eld, mat1, matexp1,exp1,exp2)

end;

procedure statementTableinit;
begin
       SeqCounter:=0;
end;


initialization
 tableInitProcs.accept(statementTableinit);

end.
