ArenaZ

1
unit uParser;
2

3

4
{ This parser is used only for z = f(x,y) heightfield 3D graphs }
5

6
interface
7

8
uses
9
  Classes;
10

11
const
12
  Pi: extended = 3.1415926535897932385;
13
  PiOn2: extended = 1.5707963267948966192;
14
  twoPi: extended = 6.2831853071795864769;
15
  PiOn180: extended = 0.017453292519943296;
16

17
  ParseSet: Set of Char =
18
           [' ', '!', '(', ')', '*', '+', '-', '.', ',', '/', '0'..'9',
19
            'A'..'E', 'G'..'I', 'L', 'N'..'U', 'X', 'Y', '^', '`', #8];
20

21
type
22
  TFuncDef = class
23
  public
24
    function DefName: string; virtual; abstract;
25
    function Eval(x: extended): extended; virtual; abstract;
26
  end;
27

28
  TVarDef = class
29
  public
30
    VarName: string;
31
    Value: extended;
32
  end;
33

34
  TCalculus = class
35
  public
36
    function Eval: extended; virtual; abstract;
37
  end;
38

39
  TfxyParser = class(TObject)
40
    constructor Create(x, y: extended);
41
    destructor Destroy; override;
42
  private
43
    FunctionList: TList;
44
    VariableList: TList;
45
    function FunctionOf(i: integer): TFuncDef;
46
    function VariableOf(i: integer): TVarDef;
47
    function CheckBrackets(const s: string): Boolean;
48
    function CompileExpresion(const s: string; var Error: byte): TCalculus;
49
    function FactorCompile(const s: string; var Error: byte): TCalculus;
50
    function SimpleCompile(const s: string; var Error: byte): TCalculus;
51
    procedure ClearLists;
52
  public
53
    VarX, VarY: TVarDef;
54
    Calculus: TCalculus;
55
    ErrorByte: byte;
56
    function Compile(s: string; var Error: byte): TCalculus;
57
    procedure AddVar(v: TVarDef);
58
    procedure ConstructLists;
59
  end;
60

61
  TConst = class(TCalculus)
62
    constructor Create(c: extended);
63
  public
64
    function Eval: extended; override;
65
  private
66
    Val: extended;
67
  end;
68

69
  TVar = class(TCalculus)
70
  public
71
    constructor Create(v: TVarDef);
72
    function Eval: extended; override;
73
  protected
74
    Def: TVarDef;
75
  end;
76

77
  TFunc = class(TCalculus)
78
    constructor Create(v: TCalculus; f: TFuncDef);
79
    destructor Destroy; override;
80
  public
81
    function Eval: extended; override;
82
  protected
83
    Variable: TCalculus;
84
    Def: TFuncDef;
85
  end;
86

87
  TOperator = class(TCalculus)
88
    constructor Create(c1, c2: TCalculus);
89
    destructor Destroy; override;
90
  public
91
  protected
92
    e1, e2: TCalculus;
93
  end;
94

95
  TMinus = class(TOperator)
96
  public
97
    function Eval: extended; override;
98
  end;
99

100
  TSum = class(TOperator)
101
  public
102
    function Eval: extended; override;
103
  end;
104

105
  TProduct = class(TOperator)
106
  public
107
    function Eval: extended; override;
108
  end;
109

110
  TDivision = class(TOperator)
111
  public
112
    function Eval: extended; override;
113
  end;
114

115
  TPower = class(TOperator)
116
  public
117
    function Eval: extended; override;
118
  end;
119

120
  TFactorial = class(TOperator)
121
  public
122
    function Eval: extended; override;
123
  end;
124

125
  TDegToRad = class(TOperator)
126
  public
127
    function Eval: extended; override;
128
  end;
129

130
  TAbs = class(TFuncDef)
131
  public
132
    function DefName: string; override;
133
    function Eval(x: extended): extended; override;
134
  end;
135

136
  TInt = class(TFuncDef)
137
  public
138
    function DefName: string; override;
139
    function Eval(x: extended): extended; override;
140
  end;
141

142
  TRound = class(TFuncDef)
143
  public
144
    function DefName: string; override;
145
    function Eval(x: extended): extended; override;
146
  end;
147

148
  TSqr = class(TFuncDef)
149
  public
150
    function DefName: string; override;
151
    function Eval(x: extended): extended; override;
152
  end;
153

154
  TSqrt = class(TFuncDef)
155
  public
156
    function DefName: string; override;
157
    function Eval(x: extended): extended; override;
158
  end;
159

160
  TSin = class(TFuncDef)
161
  public
162
    function DefName: string; override;
163
    function Eval(x: extended): extended; override;
164
  end;
165

166
  TCos = class(TFuncDef)
167
  public
168
    function DefName: string; override;
169
    function Eval(x: extended): extended; override;
170
  end;
171

172
  TTan = class(TFuncDef)
173
  public
174
    function DefName: string; override;
175
    function Eval(x: extended): extended; override;
176
  end;
177

178
  TCsc = class(TFuncDef)
179
  public
180
    function DefName: string; override;
181
    function Eval(x: extended): extended; override;
182
  end;
183

184
  TSec = class(TFuncDef)
185
  public
186
    function DefName: string; override;
187
    function Eval(x: extended): extended; override;
188
  end;
189

190
  TCot = class(TFuncDef)
191
  public
192
    function DefName: string; override;
193
    function Eval(x: extended): extended; override;
194
  end;
195

196
  TArcSin = class(TFuncDef)
197
  public
198
    function DefName: string; override;
199
    function Eval(x: extended): extended; override;
200
  end;
201

202
  TArcCos = class(TFuncDef)
203
  public
204
    function DefName: string; override;
205
    function Eval(x: extended): extended; override;
206
  end;
207

208
  TArcTan = class(TFuncDef)
209
  public
210
    function DefName: string; override;
211
    function Eval(x: extended): extended; override;
212
  end;
213

214
  TArcCsc = class(TFuncDef)
215
  public
216
    function DefName: string; override;
217
    function Eval(x: extended): extended; override;
218
  end;
219

220
  TArcSec = class(TFuncDef)
221
  public
222
    function DefName: string; override;
223
    function Eval(x: extended): extended; override;
224
  end;
225

226
  TArcCot = class(TFuncDef)
227
  public
228
    function DefName: string; override;
229
    function Eval(x: extended): extended; override;
230
  end;
231

232
  TLn = class(TFuncDef)
233
  public
234
    function DefName: string; override;
235
    function Eval(x: extended): extended; override;
236
  end;
237

238
  TExp = class(TFuncDef)
239
  public
240
    function DefName: string; override;
241
    function Eval(x: extended): extended; override;
242
  end;
243

244
  TExp1 = class(TFuncDef)
245
  public
246
    function DefName: string; override;
247
    function Eval(x: extended): extended; override;
248
  end;
249

250
  TLog10 = class(TFuncDef)
251
  public
252
    function DefName: string; override;
253
    function Eval(x: extended): extended; override;
254
  end;
255

256
  TLog2 = class(TFuncDef)
257
  public
258
    function DefName: string; override;
259
    function Eval(x: extended): extended; override;
260
  end;
261

262
  TSinh = class(TFuncDef)
263
  public
264
    function DefName: string; override;
265
    function Eval(x: extended): extended; override;
266
  end;
267

268
  TCosh = class(TFuncDef)
269
  public
270
    function DefName: string; override;
271
    function Eval(x: extended): extended; override;
272
  end;
273

274
  TTanh = class(TFuncDef)
275
  public
276
    function DefName: string; override;
277
    function Eval(x: extended): extended; override;
278
  end;
279

280
  TCsch = class(TFuncDef)
281
  public
282
    function DefName: string; override;
283
    function Eval(x: extended): extended; override;
284
  end;
285

286
  TSech = class(TFuncDef)
287
  public
288
    function DefName: string; override;
289
    function Eval(x: extended): extended; override;
290
  end;
291

292
  TCoth = class(TFuncDef)
293
  public
294
    function DefName: string; override;
295
    function Eval(x: extended): extended; override;
296
  end;
297

298
  TArcSinh = class(TFuncDef)
299
  public
300
    function DefName: string; override;
301
    function Eval(x: extended): extended; override;
302
  end;
303

304
  TArcCosh = class(TFuncDef)
305
  public
306
    function DefName: string; override;
307
    function Eval(x: extended): extended; override;
308
  end;
309

310
  TArcTanh = class(TFuncDef)
311
  public
312
    function DefName: string; override;
313
    function Eval(x: extended): extended; override;
314
  end;
315

316
  TArcCsch = class(TFuncDef)
317
  public
318
    function DefName: string; override;
319
    function Eval(x: extended): extended; override;
320
  end;
321

322
  TArcSech = class(TFuncDef)
323
  public
324
    function DefName: string; override;
325
    function Eval(x: extended): extended; override;
326
  end;
327

328
  TArcCoth = class(TFuncDef)
329
  public
330
    function DefName: string; override;
331
    function Eval(x: extended): extended; override;
332
  end;
333

334
function ScanText(const s: string): string;
335
function ParseAndEvaluate(const aText: string; var e: byte): extended;
336
function ParseEvaluateFxy(const aVarX, aVarY: extended;
337
                          const aText: string; var e: byte): extended;
338

339
implementation
340

341
uses
342
  uGlobal,
343
  Main,
344
  Math,
345
  GLVectorGeometry,
346
  SysUtils;
347

348
{ TCalculus Class }
349
constructor TConst.Create(c: extended);
350
begin
351
  Val := c;
352
end;
353

354
function TConst.Eval: extended;
355
begin
356
  Result := Val;
357
end;
358

359
constructor TVar.Create(v: TVarDef);
360
begin
361
  Def := v;
362
end;
363

364
function TVar.Eval: extended;
365
begin
366
  Result := Def.value;
367
end;
368

369
constructor TFunc.Create(v: TCalculus; f: TFuncDef);
370
begin
371
  Variable := v;
372
  Def := f;
373
end;
374

375
destructor TFunc.Destroy;
376
begin
377
  Variable.Free;
378
end;
379

380
function TFunc.Eval: extended;
381
begin
382
  Result := Def.Eval(Variable.Eval);
383
end;
384

385
constructor TOperator.Create(c1, c2: TCalculus);
386
begin
387
  e1 := c1;
388
  e2 := c2;
389
end;
390

391
destructor TOperator.Destroy;
392
begin
393
  e1.Free;
394
  e2.Free;
395
end;
396
{ TCalculus Class }
397

398
{ TfxyParser }
399
constructor TfxyParser.Create(x, y: extended);
400
begin
401
  inherited Create;
402
  FunctionList := TList.Create;
403
  VariableList := TList.Create;
404

405
  ConstructLists;
406

407
  VarX := TVarDef.Create;
408
  VarX.VarName := 'x';
409
  VarX.Value := x;
410
  addVar(VarX);
411

412
  VarY := TVarDef.Create;
413
  VarY.VarName := 'y';
414
  VarY.Value := y;
415
  addVar(VarY);
416
end;
417

418
destructor TfxyParser.Destroy;
419
begin
420
  ClearLists;
421
  inherited Destroy;
422
end;
423

424
function TfxyParser.FunctionOf(i: integer): TFuncDef;
425
begin
426
  Result := TFuncDef(FunctionList.Items[i]);
427
end;
428

429
function TfxyParser.VariableOf(i: integer): TVarDef;
430
begin
431
  Result := TVarDef(VariableList.Items[i]);
432
end;
433

434
function TfxyParser.CheckBrackets(const s: string): Boolean;
435
var
436
  i, j, c1, c2: integer;
437

438
begin
439
  c1 := 0;
440
  c2 := 0;
441
  i := 1;
442
  j := Length(s);
443
  while i <= j do
444
  begin
445
    if s[i] = '(' then Inc(c1);
446
    if s[i] = ')' then Inc(c2);
447
    Inc(i);
448
  end;
449
  Result := c1 = c2;
450
end;
451

452
function TfxyParser.CompileExpresion(const s: string; var Error: byte): TCalculus;
453
var
454
  i: integer;
455
  e1: byte;
456
  e2: byte;
457
  c1, c2: TCalculus;
458

459
begin
460
  if s = '' then
461
  begin
462
    Error := 3;
463
    Result := nil;
464
    Exit;
465
  end;
466

467
  if not CheckBrackets(s) then
468
  begin
469
    Error := 1;
470
    Result := nil;
471
    Exit;
472
  end;
473

474
 {----- -factor -----}
475
  if s[1] = '-' then
476
  begin
477
    c1 := FactorCompile(copy(s, 2, length(s)-1), e1);
478
    if e1 = 0 then
479
    begin
480
      c2 := TConst.Create(0);
481
      Result := TMinus.Create(c2, c1);
482
      Error := 0;
483
      Exit;
484
    end;
485
  end;
486

487
 {----- exp+factor -----}
488
 {----- exp-factor -----}
489
 {----- exp!factor -----}
490
 {----- exp°factor -----}
491
  for i := length(s) downto 1 do
492
  begin
493
    case s[i] of
494
 '+': begin
495
        c1 := CompileExpresion(copy(s, 1, i -1), e1);
496
        if e1 = 0 then
497
        begin
498
          c2 := FactorCompile(copy(s, i +1, length(s) -i), e2);
499
          if e2 = 0 then
500
          begin
501
            Result := TSum.Create(c1, c2);
502
            Error := 0;
503
            Exit;
504
          end
505
          else c1.Free;
506
        end;
507
      end;
508
 '-': begin
509
        c1 := CompileExpresion(copy(s, 1, i -1), e1);
510
        if e1 = 0 then
511
        begin
512
          c2 := FactorCompile(copy(s, i +1, length(s) -i), e2);
513
          if e2 = 0 then
514
          begin
515
            Result := TMinus.Create(c1, c2);
516
            Error := 0;
517
            Exit;
518
          end
519
          else c1.Free;
520
        end;
521
      end;
522
 '!': begin
523
        c1 := CompileExpresion(copy(s, 1, i -1), e1);
524
        if e1 = 0 then
525
        begin
526
          c2 := FactorCompile(copy(s, 1, i -1), e2);
527
          if e2 = 0 then
528
          begin
529
            Result := TFactorial.Create(c1, c2);
530
            Error := 0;
531
            Exit;
532
          end
533
          else c1.Free;
534
        end;
535
      end;
536
 char(#176): begin
537
        c1 := CompileExpresion(copy(s, 1, i -1), e1);
538
        if e1 = 0 then
539
        begin
540
          c2 := FactorCompile(copy(s, 1, i -1), e2);
541
          if e2 = 0 then
542
          begin
543
            Result := TDegToRad.Create(c1, c2);
544
            Error := 0;
545
            Exit;
546
          end
547
          else c1.Free;
548
        end;
549
      end;
550
    end;  { case s[i] of... }
551
  end;  { for i := length(s) downto 1 do... }
552
  Result := FactorCompile(s, Error);
553
end;
554

555
function TfxyParser.FactorCompile(const s: string; var Error: byte): TCalculus;
556
var
557
  i: integer;
558
  e1, e2: byte;
559
  c1, c2: TCalculus;
560

561
begin
562
  if s = '' then
563
  begin
564
    Error := 3;
565
    Result := nil;
566
    Exit;
567
  end;
568

569
  if not CheckBrackets(s) then
570
  begin
571
    Error := 1;
572
    Result := nil;
573
    Exit;
574
  end;
575

576
 {----- factor*simple -----}
577
 {----- factor/simple -----}
578
  for i := length(s) downto 1 do
579
  begin
580
    case s[i] of
581
 '*': begin
582
        c1 := FactorCompile(copy(s, 1, i -1), e1);
583
        if e1 = 0 then
584
        begin
585
          c2 := SimpleCompile(copy(s, i +1, length(s) -i), e2);
586
          if e2 = 0 then
587
          begin
588
            Result := TProduct.Create(c1, c2);
589
            Error := 0;
590
            Exit;
591
          end
592
          else c1.Free;
593
        end;
594
      end;
595
 '/': begin
596
        c1 := FactorCompile(copy(s, 1, i -1), e1);
597
        if e1 = 0 then
598
        begin
599
          c2 := SimpleCompile(copy(s, i +1, length(s) -i), e2);
600
          if e2 = 0 then
601
          begin
602
            Result := TDivision.Create(c1, c2);
603
            Error := 0;
604
            Exit;
605
          end
606
          else c1.Free;
607
        end;
608
      end;
609
    end;  { case s[i] of... }
610
  end;  { for i := length(s) downto 1 do... }
611
  Result := SimpleCompile(s, Error);
612
end;
613

614
function TfxyParser.SimpleCompile(const s: string; var Error: byte): TCalculus;
615
var
616
  i: integer;
617
  e1, e2: byte;
618
  c1, c2: TCalculus;
619
  d: extended;
620

621
begin
622
  if s = '' then
623
  begin
624
    Error := 3;
625
    Result := nil;
626
    Exit;
627
  end;
628

629
  if not CheckBrackets(s) then
630
  begin
631
    Error := 1;
632
    Result := nil;
633
    Exit;
634
  end;
635

636
 {----- const -----}
637
  Val(s, d, i);
638
  if i = 0 then
639
  begin
640
    Result := TConst.Create(d);
641
    Error := 0;
642
    Exit;
643
  end;
644

645
 {----- (exp) -----}
646
  if (s[1] = '(') and (s[length(s)] = ')') then
647
  begin
648
    c1 := CompileExpresion(copy(s, 2, length(s)-2), e1);
649
    if e1 = 0 then
650
    begin
651
      Result := c1;
652
      Error := 0;
653
      Exit;
654
    end;
655
  end;
656

657
 {----- VarName -----}
658
  for i := 0 to VariableList.Count -1 do
659
  begin
660
    if s = VariableOf(i).VarName then
661
    begin
662
      Result := TVar.Create(VariableOf(i));
663
      Error := 0;
664
      Exit;
665
    end;
666
  end;
667

668
 {----- DefNameFunc(exp) -----}
669
  for i := 0 to FunctionList.Count -1 do
670
  begin
671
    if (Pos(FunctionOf(i).DefName + '(', s) = 1) and (s[length(s)] = ')')
672
    then
673
    begin
674
      c1 := CompileExpresion(copy(s, length(FunctionOf(i).DefName) +2,
675
                         length(s) - length(FunctionOf(i).DefName) -2), e1);
676
      if e1 = 0 then
677
      begin
678
        Result := TFunc.Create(c1, FunctionOf(i));
679
        Error := 0;
680
        Exit;
681
      end;
682
    end;
683
  end;
684

685
 {----- simple^simple -----}
686
  for i := 1 to length(s) do
687
  begin
688
    case s[i] of
689
 '^': begin
690
        c1 := SimpleCompile(copy(s, 1, i -1), e1);
691
        if e1 = 0 then
692
        begin
693
          c2 := SimpleCompile(copy(s, i +1, length(s) -i), e2);
694
          if e2 = 0 then
695
          begin
696
            Result := TPower.Create(c1, c2);
697
            Error := 0;
698
            Exit;
699
          end
700
          else c1.Free;
701
        end;
702
      end;
703
    end;  { case s[i] of... }
704
  end;  { for i := 1 to length(s) do... }
705

706
  Error := 2;
707
  Result := nil;
708
end;
709

710
function TfxyParser.Compile(s: string; var Error: byte): TCalculus;
711
begin
712
  Result := CompileExpresion(s, Error);
713
end;
714

715
procedure TfxyParser.AddVar(v: TVarDef);
716
begin
717
  VariableList.Add(v);
718
end;
719

720
procedure TfxyParser.ConstructLists;
721
var
722
  v: TVarDef;
723
begin
724
  with FunctionList do
725
  begin
726
    Add(TAbs.Create);
727
    Add(TInt.Create);
728
    Add(TRound.Create);
729
    Add(TSqr.Create);
730
    Add(TSqrt.Create);
731
    Add(TSin.Create);
732
    Add(TCos.Create);
733
    Add(TTan.Create);
734
    Add(TCsc.Create);
735
    Add(TSec.Create);
736
    Add(TCot.Create);
737

738
    Add(TArcSin.Create);
739
    Add(TArcCos.Create);
740
    Add(TArcTan.Create);
741
    Add(TArcCsc.Create);
742
    Add(TArcSec.Create);
743
    Add(TArcCot.Create);
744

745
    Add(TLn.Create);
746
    Add(TExp.Create);
747
    Add(TExp1.Create);
748
    Add(TLog10.Create);
749
    Add(TLog2.Create);
750

751
    Add(TSinh.Create);
752
    Add(TCosh.Create);
753
    Add(TTanh.Create);
754
    Add(TCsch.Create);
755
    Add(TSech.Create);
756
    Add(TCoth.Create);
757

758
    Add(TArcSinh.Create);
759
    Add(TArcCosh.Create);
760
    Add(TArcTanh.Create);
761
    Add(TArcCsch.Create);
762
    Add(TArcSech.Create);
763
    Add(TArcCoth.Create);
764
  end;
765

766
  v := TVarDef.Create;
767
  v.VarName := 'pi';
768
  v.Value := Pi;
769
  VariableList.Add(v);
770
  v := TVarDef.Create;
771
  v.VarName := '2pi';
772
  v.Value := twoPi;
773
  VariableList.Add(v);
774
end;
775

776
procedure TfxyParser.ClearLists;
777
var
778
  i: integer;
779

780
begin
781
  for i := 0 to FunctionList.Count -1 do TFuncDef(FunctionList[i]).Free;
782
  FunctionList.Free;
783
  for i := 0 to VariableList.Count -1 do TVarDef(VariableList[i]).Free;
784
  VariableList.Free;
785
end;
786
{ TfxyParser }
787

788
{ TOperator Class }
789
function TMinus.Eval: extended;
790
begin
791
  Result := e1.Eval - e2.Eval;
792
end;
793

794
function TSum.Eval: extended;
795
begin
796
  Result := e1.Eval + e2.Eval;
797
end;
798

799
function TProduct.Eval: extended;
800
begin
801
  Result := e1.Eval * e2.Eval;
802
end;
803

804
function TDivision.Eval: extended;
805
begin
806
  if IsInfinite(e2.Eval) then Result := NaN else Result := e1.Eval/e2.Eval;
807
end;
808

809
function TPower.Eval: extended;
810
{ For fractional exponents or exponents greater than MaxInt,
811
  base must be greater than 0. }
812
begin
813
{ e1.Eval base/mantissa e2.Eval exponent }
814
  if e1.Eval = 0 then Result := 0 else Result := Power(e1.Eval, e2.Eval)
815
end;
816

817
function TFactorial.Eval: extended;
818
var
819
  i, j: integer;
820

821
begin
822
  j := round(e1.Eval);
823
  if (j < 0) or (j > 1754) then Result := 0.0
824
  else
825
  begin
826
    Result := 1.0;
827
    for i := 2 to j do Result := i*Result;
828
  end;
829
end;
830

831
function TDegToRad.Eval: extended;
832
begin
833
  Result := e1.Eval*PiOn180;
834
end;
835

836
function TAbs.DefName: string;
837
begin
838
  Result := 'abs';
839
end;
840

841
function TAbs.Eval(x: extended): extended;
842
begin
843
  Result := Abs(x);
844
end;
845

846
function TInt.DefName: string;
847
begin
848
  Result := 'int';
849
end;
850

851
function TInt.Eval(x: extended): extended;
852
begin
853
  Result := Int(x);
854
end;
855

856
function TRound.DefName: string;
857
begin
858
  Result := 'round';
859
end;
860

861
function TRound.Eval(x: extended): extended;
862
begin
863
  Result := round(x);
864
end;
865

866
function TSqr.DefName: string;
867
begin
868
  Result := 'sqr';
869
end;
870

871
function TSqr.Eval(x: extended): extended;
872
begin
873
  Result := Sqr(x);
874
end;
875

876
function TSqrt.DefName: string;
877
begin
878
  Result := 'sqrt';
879
end;
880

881
function TSqrt.Eval(x: extended): extended;
882
begin
883
  Result := Sqrt(x);
884
end;
885

886
function TSin.DefName: string;
887
begin
888
  Result := 'sin';
889
end;
890

891
function TSin.Eval(x: extended): extended;
892
begin
893
  Result := Sin(x);
894
end;
895

896
function TCos.DefName: string;
897
begin
898
  Result := 'cos';
899
end;
900

901
function TCos.Eval(x: extended): extended;
902
begin
903
  Result := Cos(x);
904
end;
905

906
function TTan.DefName: string;
907
begin
908
  Result := 'tan';
909
end;
910

911
function TTan.Eval(x: extended): extended;
912
begin
913
  Result := Tan(x);
914
end;
915

916
function TCsc.DefName: string;
917
begin
918
  Result := 'csc';
919
end;
920

921
function TCsc.Eval(x: extended): extended;
922
begin
923
  Result := Csc(x);
924
end;
925

926
function TSec.DefName: string;
927
begin
928
  Result := 'sec';
929
end;
930

931
function TSec.Eval(x: extended): extended;
932
begin
933
  Result := Sec(x);
934
end;
935

936
function TCot.DefName: string;
937
begin
938
  Result := 'cot';
939
end;
940

941
function TCot.Eval(x: extended): extended;
942
begin
943
  Result := Cot(x);
944
end;
945

946
function TArcSin.DefName: string;
947
begin
948
  Result := 'arcsin';
949
end;
950

951
function TArcSin.Eval(x: extended): extended;
952
begin
953
  Result := ArcSin(x);
954
end;
955

956
function TArcCos.DefName: string;
957
begin
958
  Result := 'arccos';
959
end;
960

961
function TArcCos.Eval(x: extended): extended;
962
begin
963
  Result := ArcCos(x);
964
end;
965

966
function TArcTan.DefName: string;
967
begin
968
  Result := 'arctan';
969
end;
970

971
function TArcTan.Eval(x: extended): extended;
972
begin
973
  Result := ArcTan(x);
974
end;
975

976
function TArcCsc.DefName: string;
977
begin
978
  Result := 'arccsc';
979
end;
980

981
function TArcCsc.Eval(x: extended): extended;
982
begin
983
  Result := ArcCsc(x);
984
end;
985

986
function TArcSec.DefName: string;
987
begin
988
  Result := 'arcsec';
989
end;
990

991
function TArcSec.Eval(x: extended): extended;
992
begin
993
  Result := ArcSec(x);
994
end;
995

996
function TArcCot.DefName: string;
997
begin
998
  Result := 'arccot';
999
end;
1000

1001
function TArcCot.Eval(x: extended): extended;
1002
begin
1003
  Result := ArcCot(x);
1004
  if (Result > Pion2) or (Result < -Pion2)
1005
  then Result := NaN;
1006
end;
1007

1008
function TLn.DefName: string;
1009
begin
1010
  Result := 'ln';
1011
end;
1012

1013
function TLn.Eval(x: extended): extended;
1014
begin
1015
  Result := Ln(x);
1016
  if isNaN(Result) then
1017
  begin
1018
    case Sign(Result) of
1019
   -1:Result := NegInfinity;
1020
    0:Result := 0;
1021
    1:Result := Infinity;
1022
    end;
1023
  end;
1024
end;
1025

1026
function TExp.DefName: string;
1027
begin
1028
  Result := 'exp';
1029
end;
1030

1031
function TExp.Eval(x: extended): extended;
1032
begin
1033
  Result := Exp(x);
1034
end;
1035

1036
function TExp1.DefName: string;
1037
begin
1038
  Result := 'e^';
1039
end;
1040

1041
function TExp1.Eval(x: extended): extended;
1042
begin
1043
  Result := Exp(x);
1044
end;
1045

1046
function TLog10.DefName: string;
1047
begin
1048
  Result := 'log';
1049
end;
1050

1051
function TLog10.Eval(x: extended): extended;
1052
begin
1053
  Result := Log10(x);
1054
  if isNaN(Result) then
1055
  begin
1056
    case Sign(Result) of
1057
   -1:Result := NegInfinity;
1058
    0:Result := 0;
1059
    1:Result := Infinity;
1060
    end;
1061
  end;
1062
end;
1063

1064
function TLog2.DefName: string;
1065
begin
1066
  Result := 'log2';
1067
end;
1068

1069
function TLog2.Eval(x: extended): extended;
1070
begin
1071
  Result := Log2(x);
1072
  if isNaN(Result) then
1073
  begin
1074
    case Sign(Result) of
1075
   -1:Result := NegInfinity;
1076
    0:Result := 0;
1077
    1:Result := Infinity;
1078
    end;
1079
  end;
1080
end;
1081

1082
function TSinh.DefName: string;
1083
begin
1084
  Result := 'sinh';
1085
end;
1086

1087
function TSinh.Eval(x: extended): extended;
1088
begin
1089
  Result := Sinh(x);
1090
end;
1091

1092
function TCosh.DefName: string;
1093
begin
1094
  Result := 'cosh';
1095
end;
1096

1097
function TCosh.Eval(x: extended): extended;
1098
begin
1099
  Result := Cosh(x);
1100
end;
1101

1102
function TTanh.DefName: string;
1103
begin
1104
  Result := 'tanh';
1105
end;
1106

1107
function TTanh.Eval(x: extended): extended;
1108
begin
1109
  Result := Tanh(x);
1110
end;
1111

1112
function TCsch.DefName: string;
1113
begin
1114
  Result := 'csch';
1115
end;
1116

1117
function TCsch.Eval(x: extended): extended;
1118
begin
1119
  Result := Csch(x);
1120
end;
1121

1122
function TSech.DefName: string;
1123
begin
1124
  Result := 'sech';
1125
end;
1126

1127
function TSech.Eval(x: extended): extended;
1128
begin
1129
  Result := Sech(x);
1130
end;
1131

1132
function TCoth.DefName: string;
1133
begin
1134
  Result := 'coth';
1135
end;
1136

1137
function TCoth.Eval(x: extended): extended;
1138
begin
1139
  Result := Coth(x);
1140
end;
1141

1142
function TArcSinh.DefName: string;
1143
begin
1144
  Result := 'arcsinh';
1145
end;
1146

1147
function TArcSinh.Eval(x: extended): extended;
1148
begin
1149
  Result := ArcSinh(x);
1150
end;
1151

1152
function TArcCosh.DefName: string;
1153
begin
1154
  Result := 'arccosh';
1155
end;
1156

1157
function TArcCosh.Eval(x: extended): extended;
1158
begin
1159
  Result := ArcCosh(x);
1160
end;
1161

1162
function TArcTanh.DefName: string;
1163
begin
1164
  Result := 'arctanh';
1165
end;
1166

1167
function TArcTanh.Eval(x: extended): extended;
1168
begin
1169
  Result := ArcTanh(x)
1170
end;
1171

1172
function TArcCsch.DefName: string;
1173
begin
1174
  Result := 'arccsch';
1175
end;
1176

1177
function TArcCsch.Eval(x: extended): extended;
1178
begin
1179
  if x = 0 then Result := Infinity else Result := ArcCsch(x);
1180
{ it would seem that Delphi 7 personal calculates ArcCsch incorrectly }
1181
end;
1182

1183
function TArcSech.DefName: string;
1184
begin
1185
  Result := 'arcsech';
1186
end;
1187

1188
function TArcSech.Eval(x: extended): extended;
1189
begin
1190
  if x <= 0 then Result := Infinity else Result := ArcSech(x);
1191
end;
1192

1193
function TArcCoth.DefName: string;
1194
begin
1195
  Result := 'arccoth';
1196
end;
1197

1198
function TArcCoth.Eval(x: extended): extended;
1199
begin
1200
  if (x >= -1) and (x < 0) then Result := NegInfinity else
1201
  if (x > 0) and (x <= 1) then Result := Infinity else
1202
  if x = 0 then Result := NaN else Result := ArcCoth(x);
1203
end;
1204
{ TOperator Class }
1205

1206
function ScanText(const s: string): string;
1207
  function DropSpaces_Commas(const s: string): string;
1208
  var
1209
    i: integer;
1210

1211
  begin
1212
    Result := '';
1213
    for i := 1 to Length(s) do
1214
    if (s[i] <> ' ') and (s[i] <> ',') then Result := Result + s[i];
1215
  end;   { DropSpaces_Commas }
1216

1217
var
1218
  i, j: integer;
1219
  c0, c1, c2: char;
1220
  cc, ccc, isStr: string;
1221
  nostar: Boolean;
1222
  isExp: Boolean;
1223
  isLog: Boolean;
1224
  isPwr: Boolean;
1225
  t: string;
1226

1227
begin  { ScanText }
1228
  t := DropSpaces_Commas(s);
1229
  i := 1;
1230
  j := 1;
1231
  Result := t;
1232
  while i < Length(t) do
1233
  begin
1234
    c0 := UpCase(t[i]);
1235
    c1 := UpCase(t[i +1]);
1236
    if i < Length(t) - 1 then c2 := UpCase(t[i +2]) else c2 := #0;
1237

1238
    cc  := c0+c1;
1239
    ccc := c0+c1+c2;
1240

1241
    isExp := ccc = 'XP(';
1242
    isStr := '';
1243
    isLog := false;
1244

1245
    if (i > 3) and ((cc = '0(') or (cc = '2(')) then
1246
    begin
1247
      if cc = '0('
1248
      then isStr := UpperCase(Copy(t, i -4, 3))    { Log10 }
1249
      else isStr := UpperCase(Copy(t, i -3, 3));   { Log2 }
1250
      isLog := isStr = 'LOG';
1251
    end;
1252

1253
    isPwr := CharInSet(c0, ['+', '-', '0'..'9']) and (UpCase(c1) = 'E') and
1254
             CharInSet(c2, ['+', '-', '0'..'9']);
1255
    nostar := isExp or isLog or isPwr;
1256

1257
    if not nostar and
1258
      CharInSet(c0, ['X', 'Y', 'I', '0'..'9', ')']) and
1259
      CharInSet(c1, ['A'..'C', 'E', 'L', 'P', 'S', 'T', 'X', 'Y', '(']) then
1260
    begin
1261
      Insert('*', Result, i + j);
1262
      Inc(j);
1263
    end;
1264
    Inc(i);
1265
  end;
1266
end;   { ScanText }
1267

1268
function ParseAndEvaluate(const aText: string; var e: byte): extended;
1269
var
1270
  aParser: TfxyParser;
1271

1272
begin
1273
  aParser := TfxyParser.Create(0, 0);
1274
  with aParser do
1275
  begin
1276
    Calculus.Free;
1277
    ErrorByte := 0;
1278
    ViewForm.StatusBar.Panels[4].Text := '';
1279
    Calculus := Compile(AnsiLowerCase(aText), ErrorByte);
1280
    e := ErrorByte;
1281
    if ErrorByte > 0 then
1282
    begin
1283
      with ViewForm.StatusBar.Panels[4] do
1284
      case ErrorByte of
1285
      1:Text := 'Check Brackets for "'+ aText+'"';
1286
      2:Text := 'Unable to Parse "'+aText+'"';
1287
      end;
1288
      Result := 0;
1289
    end
1290
    else Result := Calculus.Eval;
1291
    Calculus.Free;
1292
    Calculus := nil;
1293
    Free;
1294
  end;
1295
end;
1296

1297
function ParseEvaluateFxy(const aVarX, aVarY: extended;
1298
                          const aText: string; var e: byte): extended;
1299
var
1300
  aParser: TfxyParser;
1301

1302
begin
1303
  aParser := TfxyParser.Create(0, 0);
1304
  with aParser do
1305
  begin
1306
    Calculus.Free;
1307
    ErrorByte := 0;
1308
    ViewForm.StatusBar.Panels[4].Text := '';
1309
    Calculus := Compile(AnsiLowerCase(aText), ErrorByte);
1310
    VarX.Value := aVarX;
1311
    VarY.Value := aVarY;
1312
    e := ErrorByte;
1313
    if ErrorByte > 0 then
1314
    begin
1315
      with ViewForm.StatusBar.Panels[4] do
1316
      case ErrorByte of
1317
      1:Text := 'Check Brackets for "'+ aText+'"';
1318
      2:Text := 'Unable to Parse "'+aText+'"';
1319
      end;
1320
      Result := 0;
1321
    end
1322
    else Result := Calculus.Eval;
1323
    Calculus.Free;
1324
    Calculus := nil;
1325
    Free;
1326
  end;
1327
end;
1328

1329
Initialization
1330
{ Avoids arithmetic exceptions in the above code }
1331
SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide,
1332
                  exOverflow, exUnderflow, exPrecision]);
1333

1334
end.
1335

1336