main.pas

ArtFormula package contains two nonvisual Delphi component for symbolic expression parsing and evalu

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, Grids, ImgList, jpeg,
  ExtCtrls, ToolWin, Menus, ActnList, formula, formulan, Buttons;
                  
type

  TMacro = record          
    name, text : string;
  end;

  TMainForm = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    Label1: TLabel;
    text: TComboBox;
    Button3: TButton;
    Label6: TLabel;
    res: TEdit;
    Label2: TLabel;
    cnt: TEdit;
    Label5: TLabel;
    ud: TUpDown;
    Grd: TStringGrid;
    TestCB: TCheckBox;
    CaseCB: TCheckBox;
    Label4: TLabel;
    Button2: TButton;
    Button1: TButton;
    TabSheet4: TTabSheet;
    ImageList1: TImageList;
    Memo1: TMemo;
    Label3: TLabel;
    NI: TEdit;
    BM: TStringGrid;
    R: TButton;
    Bevel1: TBevel;
    Label7: TLabel;
    Image1: TImage;
    Bevel2: TBevel;
    Label8: TLabel;
    Label9: TLabel;
    Bevel3: TBevel;
    Label10: TLabel;
    Label11: TLabel;
    Label12: TLabel;
    Label13: TLabel;
    Label14: TLabel;
    Label15: TLabel;
    Sel: TComboBox;
    Label16: TLabel;
    Script: TMemo;
    BRun: TButton;
    Label17: TLabel;
    SRes: TMemo;
    Editor: TRichEdit;
    ToolbarImages: TImageList;
    ToolBar1: TToolBar;
    ToolButton1: TToolButton;
    OpenButton: TToolButton;
    SaveButton: TToolButton;
    PrintButton: TToolButton;
    CutButton: TToolButton;
    CopyButton: TToolButton;
    PasteButton: TToolButton;
    UndoButton: TToolButton;
    FontName: TComboBox;
    FontSize: TEdit;
    UpDown1: TUpDown;
    BoldButton: TToolButton;
    ItalicButton: TToolButton;
    UnderlineButton: TToolButton;
    ToolButton16: TToolButton;
    LeftAlign: TToolButton;
    CenterAlign: TToolButton;
    RightAlign: TToolButton;
    ToolButton20: TToolButton;
    BulletsButton: TToolButton;
    ToolButton3: TToolButton;
    ToolButton4: TToolButton;
    ToolButton7: TToolButton;
    ToolButton2: TToolButton;
    ToolButton5: TToolButton;
    ToolButton6: TToolButton;
    Ruler: TPanel;
    FirstInd: TLabel;
    LeftInd: TLabel;
    RulerLine: TBevel;
    RightInd: TLabel;
    Bevel4: TBevel;
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    FontDialog1: TFontDialog;
    PrintDialog: TPrintDialog;
    ToolButton8: TToolButton;
    ToolButton9: TToolButton;
    ActionList1: TActionList;
    FileNewCmd: TAction;
    FileOpenCmd: TAction;
    FileSaveCmd: TAction;
    FilePrintCmd: TAction;
    FileSaveAsCmd: TAction;
    ActionList2: TActionList;
    EditUndoCmd: TAction;
    EditCutCmd: TAction;
    EditCopyCmd: TAction;
    EditPasteCmd: TAction;
    EditFontCmd: TAction;
    PopupMenu1: TPopupMenu;
    Copy1: TMenuItem;
    Cut1: TMenuItem;
    Paste1: TMenuItem;
    N1: TMenuItem;
    Undo1: TMenuItem;
    F: TArtFormula;
    FN: TArtFormulaN;
    EditBoldCmd: TAction;
    EditItalicCmd: TAction;
    EditUnderlineCmd: TAction;
    TabSheet5: TTabSheet;
    Panel1: TPanel;
    Label18: TLabel;
    ftext: TComboBox;
    Sheet: TStringGrid;
    Excel: TArtFormula;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure cntChange(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure RClick(Sender: TObject);
    procedure Label13MouseEnter(Sender: TObject);
    procedure Label13MouseLeave(Sender: TObject);
    procedure Label13Click(Sender: TObject);
    procedure BRunClick(Sender: TObject);
    procedure SelChange(Sender: TObject);
    procedure FileSave(Sender: TObject);
    procedure FileSaveAs(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure SelectionChange(Sender: TObject);
    procedure RulerResize(Sender: TObject);
    procedure FileNew(Sender: TObject);
    procedure FileOpen(Sender: TObject);
    procedure FilePrint(Sender: TObject);
    procedure EditUndo(Sender: TObject);
    procedure EditCut(Sender: TObject);
    procedure EditCopy(Sender: TObject);
    procedure EditPaste(Sender: TObject);
    procedure FontNameChange(Sender: TObject);
    procedure EditFont(Sender: TObject);
    procedure BoldButtonClick(Sender: TObject);
    procedure ItalicButtonClick(Sender: TObject);
    procedure UnderlineButtonClick(Sender: TObject);
    procedure FontSizeChange(Sender: TObject);
    procedure LeftAlignClick(Sender: TObject);
    procedure BulletsButtonClick(Sender: TObject);
    procedure RightIndMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure RightIndMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FirstIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure LeftIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure RightIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ActionList2Update(Action: TBasicAction;
      var Handled: Boolean);
    procedure ToolButton4Click(Sender: TObject);
    procedure TabSheet3Show(Sender: TObject);
    procedure EditBoldCmdExecute(Sender: TObject);
    procedure cute(Sender: TObject);
    procedure EditUnderlineCmdExecute(Sender: TObject);
    procedure SheetClick(Sender: TObject);
    procedure ftextKeyPress(Sender: TObject; var Key: Char);
    procedure SheetKeyPress(Sender: TObject; var Key: Char);
    procedure SheetKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ExcelGetVarsCount(Vname: String; var count: Integer;
      wantnumber: Boolean);
    procedure ExcelGetVarValue(Vname: String; n: Integer; var Val: String;
      wantnumber: Boolean);
    procedure SheetDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure SheetDblClick(Sender: TObject);
  private
    FFileName: string;
    FUpdating: Boolean;
    FDragOfs: Integer;
    FDragging: Boolean;
    formulas : array [1..26] of array [1..64] of string;
    rangename : string;
    range : array of string;
    procedure LoadMacro;
    procedure SaveMacro;
    function CurrText: TTextAttributes;
    procedure GetFontNames;
    procedure CheckFileSave;
    procedure SetupRuler;
    procedure PerformFileOpen(const AFileName: string);
    procedure SetEditRect;
  public
   Run : boolean;
   path : string;
   procedure Eval;
   property FileName : string read FFileName write FFileName;
    { Public declarations }
  end;

var
  MainForm: TMainForm;
  Macro : array of TMacro;

implementation

uses  af_file, math, shellapi, richedit, macros;

{$R *.dfm}

const
 RulerAdj = 4/3;
 GutterWid = 6;
 programs : array [0..5] of string =
(

'begin'#13#10+
' var ''i'' end;'#13#10+
' while 1=1 do'#13#10+
'  $i++;'#13#10+
'  print("("+$i+") Press ""Stop"" button to stop!");'#13#10+ 
' wend'#13#10+
'end',

'begin'#13#10+
' var ''i'', ''t'' end;'#13#10+
' $t := now;'#13#10+
' print(''Wait 5 seconds...'');'#13#10+
' for $i:=1; $i<=5; $i++ do'#13#10+
'  while (now - $t) < 1/(24*60*60) do wend;'#13#10+
'  $t := now;'#13#10+
'  print($i+'' second'');'#13#10+
' next;'#13#10+
' print(''Ok!'');'#13#10+
'end',

'begin'#13#10+
'var "i","c","f","s" end;'#13#10+
'   print(''Centigrade to farenheight temperature table'');'#13#10+
'   print("");'#13#10+
'   for $i := -2; $i <= 12; $i++ do'#13#10+
'      $c := 10*$i;'#13#10+
'      $f := 32 + $c*9 div 5;'#13#10+
'      $s := ''  C ='' + formatf("%4.0f",$c) +'#13#10+
'            ''      F ='' + formatf("%4.0f",$f);'#13#10+
'      if $c = 0 then'#13#10+
'         $s := $s + ''  Freezing point of water'';'#13#10+
'      endif;'#13#10+
'      if $c = 100 then'#13#10+
'         $s := $s + ''  Boiling point of water'';'#13#10+
'      endif;'#13#10+
'      print($s);'#13#10+
'   next;'#13#10+
'end'
,

'begin'#13#10+
' print(''This is a TArtFormula Demo'');'#13#10+
' print(''======================'');'#13#10+
' print('''');'#13#10+
' var ''f'' end;'#13#10+
' $f := file.new;'#13#10+
' file($f).name := ''info'';'#13#10+
' file($f).open(''read'');'#13#10+
' while not file($f).eof do'#13#10+
'  print(file($f).readln);'#13#10+
' wend;'#13#10+
' file.freeall;'#13#10+
'end',

'begin'#13#10+
'  var "n","i","j","k","d" end;'#13#10+
'   $n := input("Input dimension","Dimension of matrix:",3);'#13#10+
#13#10+
'   for $i:=1; $i <= $n; $i++ do'#13#10+
'         for $j:=1; $j <= $n; $j++ do'#13#10+
' 	var "a"+$i+"_"+$j end;'#13#10+
'            $a[$i,$j] := input("Input element","a["+$i+","+$j+"] = ",if $i = $j ; 1 ; 0 end);'#13#10+
'         next;'#13#10+
'   next;'#13#10+
#13#10+
'    for $i:=1; $i <= $n; $i++ do'#13#10+
'       var "b"+$i, "x"+$i end;'#13#10+
'       $b[$i] := input("Input element","b["+$i+"] = ",1);'#13#10+
'    next;'#13#10+
#13#10+
'    for $i:=1; $i < $n; $i++ do'#13#10+
'         for $k:=$i+1; $k <= $n; $k++ do'#13#10+
'             $d:=$a[$k,$i]/$a[$i,$i];'#13#10+
'             for $j:=$i+1; $j <= $n; $j++;'#13#10+
'               $a[$k,$j]:=$a[$k,$j]-$a[$i,$j]*$d;'#13#10+
'             end;'#13#10+
'             $b[$k]:=$b[$k]-$b[$i]*$d;'#13#10+
'         next;'#13#10+
'    next;'#13#10+
#13#10+
'    for $i:=$n; $i >= 1; $i-- do'#13#10+
'         for $j:=$i+1; $j <= $n; $j++;'#13#10+
'            $b[$i]:=$b[$i]-$a[$i,$j]*$x[$j];'#13#10+
'         end;'#13#10+
'         $x[$i]:=$b[$i]/$a[$i,$i];'#13#10+
'    next;'#13#10+
'    print("Result:");'#13#10+
'    for $i:=1; $i <= $n; $i++;  print("x["+$i+"] = "+$x[$i]); end;'#13#10+
#13#10+
'end',


'begin'#13#10+
'var ''in'', ''n'', ''a'', ''b'', ''j'' end;'#13#10+
' $in := input(''Prime test'',''Input positive number'',10);'#13#10+
' if not isnumber($in) or ($in < 1) then'#13#10+
'  msg(''Bad number'',''Error'',$10)'#13#10+
' else'#13#10+
'  $n := 1;'#13#10+
'  for $a := 2; $a <= $in; $a++ do'#13#10+
'   $b := true;'#13#10+
'   for $j := 1; $j < $n; $j++ do'#13#10+
'    if ($a mod $p[$j]) = 0 then'#13#10+
'        $b := false;'#13#10+
'  	 $j := $n+1;'#13#10+
'     endif;'#13#10+
'   next;'#13#10+
'   if $b then'#13#10+
'    define(''p''@$n, $a);'#13#10+
'    $n++;'#13#10+
'   endif;'#13#10+
'  next;'#13#10+
'  print(''Prime numbers in [2..''+$in+''] are:'');'#13#10+
'  for $j:=1; $j<$n; $j++; print(''   ''@$p[$j]) end;'#13#10+
'  print(''Found ''+($n-1)+'' primes'');'#13#10+
' endd;'#13#10+
'end'

);

function myabout(var Calc : TFormulaCalc):TCalcItem;
begin
 MainForm.PageControl1.ActivePageIndex := 3;
 setN(result,0);
end;

function myprint(var Calc : TFormulaCalc):TCalcItem;
begin
 Mainform.SRes.Lines.Add(Calc.TopS);
 setN(result,0);
end;

procedure TMainForm.Button1Click(Sender: TObject);
begin
 grd.RowCount := grd.RowCount + 1;
 ud.Position := grd.RowCount - 1;
end;

procedure TMainForm.Button2Click(Sender: TObject);
begin
 if grd.RowCount > 2 then
  grd.RowCount := grd.RowCount - 1;
 ud.Position := grd.RowCount - 1;
end;

procedure TMainForm.cntChange(Sender: TObject);
begin
 ud.Position := strtointdef(cnt.Text,0);
end;

procedure TMainForm.Button3Click(Sender: TObject);
var vars : array of string;
    vals : TCalcArray;
//    vals : DoubleArray;
    i,num : integer;
begin
 num := ud.Position;
 F.CaseSensitive := casecb.Checked;
 F.TestUsedVars := testcb.Checked;
 if num > 0 then
 begin
  setlength(vals,num);
  setlength(vars,num);
  for i := 0 to num - 1 do
  begin
   vars[i] := grd.Cells[0,i+1];
   setN(vals[i],strtofloatdef(grd.Cells[1,i+1],0));
//   vals[i] := strtofloatdef(grd.Cells[1,i+1],0);
  end;
 end;
 try
  res.Text := F.ComputeStr(text.Text,num, @vars,@vals);
//  res.Text := floattostr(FN.ComputeStr(text.Text,@vars,num,@vals));
 except
  on E:Exception do
  begin
   Application.MessageBox(pchar(E.Message),'Error',mb_iconstop);
   ActiveControl := text;
   text.SelStart := F.ErrPos-1;
  end;
 end;

end;


{$O-}
procedure TMainForm.RClick(Sender: TObject);
var t1, t2 : TTime;
    x : double;
    i,n : integer;
    s : string;
begin
 if run then
 begin
  R.Caption := 'Run';
  run := false;
  F.Stop := true;
 end
 else
 begin
  F.Step := false;
  n := strtointdef(NI.Text,1000000);
  R.Caption := 'Stop';
  run := true;
  BM.RowCount := 2;
  BM.FixedRows := 1;
  BM.Cells[1,0] := '  Machine code';
  BM.Cells[2,0] := '  TArtFormulaN';
  BM.Cells[3,0] := '  TArtFormula';
  BM.Cells[1,1] := '';
  BM.Cells[2,1] := '';
  BM.Cells[3,1] := '';

  s := '  (3-Pi/2)*Pi+3.5^3.2';
  BM.Cells[0,1] := s;
  Application.ProcessMessages;
  if not run then exit;

  t1 := time;
  for i := 1 to n do
  begin
   x := (3-Pi/2)*Pi+power(3.5,3.2);
  end;
  t2 := time;

  BM.Cells[1,1] := formatdatetime('ss:zzz',t2-t1);
  Application.ProcessMessages;
  if not run then exit;

  FN.Compile(s);
  t1 := time;
  for i := 1 to n do
  begin
   FN.Compute(nil);
  end;
  t2 := time;

  BM.Cells[2,1] := formatdatetime('ss:zzz',t2-t1);
  Application.ProcessMessages;
  if not run then exit;

  F.Compile(s);
  t1 := time;
  for i := 1 to n do
  begin
   F.ComputeN;
  end;
  t2 := time;

  BM.Cells[3,1] := formatdatetime('ss:zzz',t2-t1);
  Application.ProcessMessages;
  if not run then exit;


  BM.RowCount := 3;
  BM.Cells[1,2] := '';
  BM.Cells[2,2] := '';
  BM.Cells[3,2] := '';
  s := '  sin(sqrt(atan(3)))';
  BM.Cells[0,2] := s;
  Application.ProcessMessages;
  if not run then exit;

  t1 := time;
  for i := 1 to n do
  begin
    x := sin(sqrt(arctan(3)));
  end;
  t2 := time;

  BM.Cells[1,2] := formatdatetime('ss:zzz',t2-t1);
  Application.ProcessMessages;
  if not run then exit;

  FN.Compile(s);
  t1 := time;
  for i := 1 to n do
  begin
    FN.Compute(nil);
  end;
  t2 := time;

  BM.Cells[2,2] := formatdatetime('ss:zzz',t2-t1);
  Application.ProcessMessages;
  if not run then exit;

  F.Compile(s);
  t1 := time;
  for i := 1 to n do
  begin
   F.ComputeN;
  end;
  t2 := time;

  BM.Cells[3,2] := formatdatetime('ss:zzz',t2-t1);
  Application.ProcessMessages;
  if not run then exit;

  BM.RowCount := 4;
  BM.Cells[1,3] := '';
  BM.Cells[2,3] := '';
  BM.Cells[3,3] := '';
  s := '  midstr(trim(" 12345"@" "),2,3)';
  BM.Cells[0,3] := s;
  Application.ProcessMessages;
  if not run then exit;

  t1 := time;
  for i := 1 to n do
  begin
   copy(trim(' 12345'+' '),2,3);
  end;
  t2 := time;

  BM.Cells[1,3] := formatdatetime('ss:zzz',t2-t1);
  BM.Cells[2,3] := 'Not supported';
  Application.ProcessMessages;
  if not run then exit;

  F.Compile(s);
  t1 := time;
  for i := 1 to n do
  begin
   F.Compute;
  end;
  t2 := time;

  BM.Cells[3,3] := formatdatetime('ss:zzz',t2-t1);
  Application.ProcessMessages;
  if not run then exit;
  run := false;
  R.Caption := 'Run';
 end;

end;
{$O+}

procedure TMainForm.Label13MouseEnter(Sender: TObject);
begin
(sender as TLabel).Font.Style := [fsunderline];
end;