LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   Miscellaneous support utilities & classes.
6

7
  History :  
8
       02/01/13 - Yar - Added SetGLSceneMediaDir
9
       07/01/11 - Yar - Added SaveModelDialog, OpenModelDialog
10
       04/03/10 - DanB - Now uses CharInSet
11
       27/05/09 - DanB - re-added TryStrToFloat, since it ignores user's locale.
12
       24/03/09 - DanB - removed TryStrToFloat (exists in SysUtils or GLCrossPlatform already)
13
                            changed StrToFloatDef to accept only 1 param + now overloaded
14
       24/03/09 - DanB - Moved Dialog utilities here from GLCrossPlatform, because
15
                            they work on all platforms (with FPC)
16
       16/10/08 - UweR - corrected typo in TryStringToColorAdvanced parameter
17
       16/10/08 - DanB - renamed Save/LoadStringFromFile to Save/LoadAnsiStringFromFile
18
       24/03/08 - DaStr - Removed OpenGL1x dependancy
19
                             Moved TGLMinFilter and TGLMagFilter from GLUtils.pas
20
                              to GLGraphics.pas (BugTracker ID = 1923844)
21
       25/03/07 - DaStr - Replaced StrUtils with GLCrossPlatform
22
       23/03/07 - DaStr - Removed compiler warnings caused by
23
                               SaveComponentToFile and LoadComponentFromFile
24
       22/03/07 - DaStr - Added SaveComponentToFile, LoadComponentFromFile
25
       07/02/07 - DaStr - Added StringToColorAdvanced() functions
26
       05/09/03 - EG - Creation from GLMisc split
27
    
28
}
29
unit GLUtils;
30

31
interface
32

33
{$I GLScene.inc}
34

35
uses
36
  Classes, SysUtils, types,
37
  Graphics, Controls, FileUtil, LazUTF8, 
38
  LazFileUtils, Dialogs, ExtDlgs,
39
  // GLScene
40
  GLVectorGeometry, GLCrossPlatform;
41

42
type
43
  EGLUtilsException = class(Exception);
44

45
  TSqrt255Array = array[0..255] of Byte;
46
  PSqrt255Array = ^TSqrt255Array;
47

48
  // Copies the values of Source to Dest (converting word values to integer values)
49
procedure WordToIntegerArray(Source: PWordArray; Dest: PIntegerArray; Count: Cardinal);
50
// Round ups to the nearest power of two, value must be positive
51
function RoundUpToPowerOf2(value: Integer): Integer;
52
// Round down to the nearest power of two, value must be strictly positive
53
function RoundDownToPowerOf2(value: Integer): Integer;
54
// Returns True if value is a true power of two
55
function IsPowerOf2(value: Integer): Boolean;
56
{ Read a CRLF terminated string from a stream.
57
   The CRLF is NOT in the returned string. }
58
function ReadCRLFString(aStream: TStream): AnsiString;
59
// Write the string and a CRLF in the stream
60
procedure WriteCRLFString(aStream: TStream; const aString: AnsiString);
61
// Similar to SysUtils.TryStrToFloat, but ignores user's locale
62
function TryStrToFloat(const strValue: string; var val: Extended): Boolean;
63
// Similar to SysUtils.StrToFloatDef, but ignores user's locale
64
function StrToFloatDef(const strValue: string; defValue: Extended = 0): Extended;
65

66
// Converts a string into color
67
function StringToColorAdvancedSafe(const Str: string; const Default: TColor): TColor;
68
// Converts a string into color
69
function TryStringToColorAdvanced(const Str: string; var OutColor: TColor): Boolean;
70
// Converts a string into color
71
function StringToColorAdvanced(const Str: string): TColor;
72

73
{ Parses the next integer in the string.
74
   Initial non-numeric characters are skipper, p is altered, returns 0 if none
75
   found. '+' and '-' are acknowledged. }
76
function ParseInteger(var p: PChar): Integer;
77
{ Parses the next integer in the string.
78
   Initial non-numeric characters are skipper, p is altered, returns 0 if none
79
   found. Both '.' and ',' are accepted as decimal separators. }
80
function ParseFloat(var p: PChar): Extended;
81

82
{ Saves "data" to "filename". }
83
procedure SaveAnsiStringToFile(const fileName: string; const data: AnsiString);
84
{ Returns the content of "filename". }
85
function LoadAnsiStringFromFile(const fileName: string): AnsiString;
86

87
{ Saves component to a file. }
88
procedure SaveComponentToFile(const Component: TComponent; const FileName: string; const AsText: Boolean = True);
89
{ Loads component from a file. }
90
procedure LoadComponentFromFile(const Component: TComponent; const FileName: string; const AsText: Boolean = True);
91

92
{ Returns the size of "filename".
93
   Returns 0 (zero) is file does not exists. }
94
function SizeOfFile(const fileName: string): Int64;
95

96
{ Returns a pointer to an array containing the results of "255*sqrt(i/255)". }
97
function GetSqrt255Array: PSqrt255Array;
98

99
{ Pops up a simple dialog with msg and an Ok button. }
100
procedure InformationDlg(const msg: string);
101
{ Pops up a simple question dialog with msg and yes/no buttons.
102
   Returns True if answer was "yes". }
103
function QuestionDlg(const msg: string): Boolean;
104
{ Posp a simple dialog with a string input. }
105
function InputDlg(const aCaption, aPrompt, aDefault: string): string;
106

107
{ Pops up a simple save picture dialog. }
108
function SavePictureDialog(var aFileName: string; const aTitle: string = ''): Boolean;
109
{ Pops up a simple open picture dialog. }
110
function OpenPictureDialog(var aFileName: string; const aTitle: string = ''): Boolean;
111

112
//procedure SetGLSceneMediaDir();
113
Function SetGLSceneMediaDir:string;
114

115
var MediaPath:String;
116
//------------------------------------------------------
117
//------------------------------------------------------
118
//------------------------------------------------------
119
implementation
120
//------------------------------------------------------
121
//------------------------------------------------------
122
//------------------------------------------------------
123

124
uses
125
  GLApplicationFileIO;
126

127

128

129
var
130
  vSqrt255: TSqrt255Array;
131

132
resourcestring
133
  gluInvalidColor = '''%s'' is not a valid color format!';
134

135
  // WordToIntegerArray
136
  //
137
{$IFNDEF GEOMETRY_NO_ASM}
138

139
procedure WordToIntegerArray(Source: PWordArray; Dest: PIntegerArray; Count: Cardinal); assembler;
140
// EAX contains Source
141
// EDX contains Dest
142
// ECX contains Count
143
asm
144
              JECXZ @@Finish
145
              PUSH ESI
146
              PUSH EDI
147
              MOV ESI,EAX
148
              MOV EDI,EDX
149
              XOR EAX,EAX
150
@@1:          LODSW
151
              STOSD
152
              DEC ECX
153
              JNZ @@1
154
              POP EDI
155
              POP ESI
156
@@Finish:
157
end;
158
{$ELSE}
159

160
procedure WordToIntegerArray(Source: PWordArray; Dest: PIntegerArray; Count: Cardinal);
161
var
162
  i: integer;
163
begin
164
  for i := 0 to Count - 1 do
165
    Dest^[i] := Source^[i];
166
end;
167
{$ENDIF}
168

169
// RoundUpToPowerOf2
170
//
171

172
function RoundUpToPowerOf2(value: Integer): Integer;
173
begin
174
  Result := 1;
175
  while (Result < value) do
176
    Result := Result shl 1;
177
end;
178

179
// RoundDownToPowerOf2
180
//
181

182
function RoundDownToPowerOf2(value: Integer): Integer;
183
begin
184
  if value > 0 then
185
  begin
186
    Result := 1 shl 30;
187
    while Result > value do
188
      Result := Result shr 1;
189
  end
190
  else
191
    Result := 1;
192
end;
193

194
// IsPowerOf2
195
//
196

197
function IsPowerOf2(value: Integer): Boolean;
198
begin
199
  Result := (RoundUpToPowerOf2(value) = value);
200
end;
201

202
// ReadCRLFString
203
//
204

205
function ReadCRLFString(aStream: TStream): AnsiString;
206
var
207
  c: AnsiChar;
208
begin
209
  Result := '';
210
  while Copy(Result, Length(Result) - 1, 2) <> #13#10 do
211
  begin
212
    aStream.Read(c, 1);
213
    Result := Result + c;
214
  end;
215
  Result := Copy(Result, 1, Length(Result) - 2);
216
end;
217

218
// WriteCRLFString
219
//
220

221
procedure WriteCRLFString(aStream: TStream; const aString: AnsiString);
222
const
223
  cCRLF: Integer = $0A0D;
224
begin
225
  with aStream do
226
  begin
227
    Write(aString[1], Length(aString));
228
    Write(cCRLF, 2);
229
  end;
230
end;
231

232
// TryStrToFloat
233
//
234

235
function TryStrToFloat(const strValue: string; var val: Extended): Boolean;
236
var
237
  i, j, divider, lLen, exponent: Integer;
238
  c: Char;
239
  v: Extended;
240
begin
241
  if strValue = '' then
242
  begin
243
    Result := False;
244
    Exit;
245
  end
246
  else
247
    v := 0;
248
  lLen := Length(strValue);
249
  while (lLen > 0) and (strValue[lLen] = ' ') do
250
    Dec(lLen);
251
  divider := lLen + 1;
252
  exponent := 0;
253
  for i := 1 to lLen do
254
  begin
255
    c := strValue[i];
256
    case c of
257
      ' ': if v <> 0 then
258
        begin
259
          Result := False;
260
          Exit;
261
        end;
262
      '0'..'9': v := (v * 10) + Integer(c) - Integer('0');
263
      ',', '.':
264
        begin
265
          if (divider > lLen) then
266
            divider := i + 1
267
          else
268
          begin
269
            Result := False;
270
            Exit;
271
          end;
272
        end;
273
      '-', '+': if i > 1 then
274
        begin
275
          Result := False;
276
          Exit;
277
        end;
278
      'e', 'E':
279
        begin
280
          if i + 1 > lLen then
281
          begin
282
            Result := False;
283
            Exit;
284
          end;
285
          for j := i + 1 to lLen do
286
          begin
287
            c := strValue[j];
288
            case c of
289
              '-', '+': if j <> i + 1 then
290
                begin
291
                  Result := False;
292
                  Exit;
293
                end;
294
              '0'..'9': exponent := (exponent * 10) + Integer(c) - Integer('0');
295
            else
296
              Result := False;
297
              Exit;
298
            end;
299
          end;
300
          if strValue[i + 1] <> '-' then
301
            exponent := -exponent;
302
          exponent := exponent - 1;
303
          lLen := i;
304
          if divider > lLen then
305
            divider := lLen;
306
          Break;
307
        end;
308
    else
309
      Result := False;
310
      Exit;
311
    end;
312
  end;
313
  divider := lLen - divider + exponent + 1;
314
  if strValue[1] = '-' then
315
  begin
316
    v := -v;
317
  end;
318
  if divider <> 0 then
319
    v := v * Exp(-divider * Ln(10));
320
  val := v;
321
  Result := True;
322
end;
323

324
// StrToFloatDef
325
//
326

327
function StrToFloatDef(const strValue: string; defValue: Extended = 0): Extended;
328
begin
329
  if not TryStrToFloat(strValue, Result) then
330
    result := defValue;
331
end;
332

333
// StringToColorAdvancedSafe
334
//
335

336
function StringToColorAdvancedSafe(const Str: string; const Default: TColor): TColor;
337
begin
338
  if not TryStringToColorAdvanced(Str, Result) then
339
    Result := Default;
340
end;
341

342
// StringToColorAdvanced
343
//
344

345
function StringToColorAdvanced(const Str: string): TColor;
346
begin
347
  if not TryStringToColorAdvanced(Str, Result) then
348
    raise EGLUtilsException.CreateResFmt(@gluInvalidColor, [Str]);
349
end;
350

351
// TryStringToColorAdvanced
352
//
353

354
function TryStringToColorAdvanced(const Str: string; var OutColor: TColor): Boolean;
355
var
356
  Code, I: Integer;
357
  Temp: string;
358
begin
359
  Result := True;
360
  Temp := Str;
361

362
  Val(Temp, I, Code); //to see if it is a number
363
  if Code = 0 then
364
    OutColor := TColor(I) //Str = $0000FF
365
  else
366
  begin
367
    if not IdentToColor(Temp, Longint(OutColor)) then //Str = clRed
368
    begin
369
      if AnsiStartsText('clr', Temp) then //Str = clrRed
370
      begin
371
        Delete(Temp, 3, 1);
372
        if not IdentToColor(Temp, Longint(OutColor)) then
373
          Result := False;
374
      end
375
      else if not IdentToColor('cl' + Temp, Longint(OutColor)) then //Str = Red
376
        Result := False;
377
    end;
378
  end;
379
end;
380

381
// ParseInteger
382
//
383

384
function ParseInteger(var p: PChar): Integer;
385
var
386
  neg: Boolean;
387
  c: Char;
388
begin
389
  Result := 0;
390
  if p = nil then
391
    Exit;
392
  neg := False;
393
  // skip non-numerics
394
  while not CharInSet(p^, [#0, '0'..'9', '+', '-']) do
395
    Inc(p);
396
  c := p^;
397
  if c = '+' then
398
    Inc(p)
399
  else if c = '-' then
400
  begin
401
    neg := True;
402
    Inc(p);
403
  end;
404
  // Parse numerics
405
  while True do
406
  begin
407
    c := p^;
408
    if not CharInSet(c, ['0'..'9']) then
409
      Break;
410
    Result := Result * 10 + Integer(c) - Integer('0');
411
    Inc(p);
412
  end;
413
  if neg then
414
    Result := -Result;
415
end;
416

417
// ParseFloat
418
//
419

420
function ParseFloat(var p: PChar): Extended;
421
var
422
  decimals, expSign, exponent: Integer;
423
  c: Char;
424
  neg: Boolean;
425
begin
426
  Result := 0;
427
  if p = nil then
428
    Exit;
429
  // skip non-numerics
430
  while not CharInSet(p^, [#0, '0'..'9', '+', '-']) do
431
    Inc(p);
432
  c := p^;
433
  if c = '+' then
434
  begin
435
    neg := False;
436
    Inc(p);
437
  end
438
  else if c = '-' then
439
  begin
440
    neg := True;
441
    Inc(p);
442
  end
443
  else
444
    neg := False;
445
  // parse numbers
446
  while CharInSet(p^, ['0'..'9']) do
447
  begin
448
    Result := Result * 10 + (Integer(p^) - Integer('0'));
449
    Inc(p);
450
  end;
451
  // parse dot, then decimals, if any
452
  decimals := 0;
453
  if (p^ = '.') then
454
  begin
455
    Inc(p);
456
    while CharInSet(p^, ['0'..'9']) do
457
    begin
458
      Result := Result * 10 + (Integer(p^) - Integer('0'));
459
      Inc(p);
460
      Dec(decimals);
461
    end;
462
  end;
463
  // parse exponent, if any
464
  if CharInSet(p^, ['e', 'E']) then
465
  begin
466
    Inc(p);
467
    // parse exponent sign
468
    c := p^;
469
    if c = '-' then
470
    begin
471
      expSign := -1;
472
      Inc(p);
473
    end
474
    else if c = '+' then
475
    begin
476
      expSign := 1;
477
      Inc(p);
478
    end
479
    else
480
      expSign := 1;
481
    // parse exponent
482
    exponent := 0;
483
    while CharInSet(p^, ['0'..'9']) do
484
    begin
485
      exponent := exponent * 10 + (Integer(p^) - Integer('0'));
486
      Inc(p);
487
    end;
488
    decimals := decimals + expSign * exponent;
489
  end;
490
  if decimals <> 0 then
491
    Result := Result * Exp(decimals * Ln(10));
492
  if neg then
493
    Result := -Result;
494
end;
495

496
// SaveStringToFile
497
//
498

499
procedure SaveAnsiStringToFile(const fileName: string; const data: AnsiString);
500
var
501
  n: Cardinal;
502
  fs: TStream;
503
begin
504
  fs := CreateFileStream(fileName, fmCreate);
505
  try
506
    n := Length(data);
507
    if n > 0 then
508
      fs.Write(data[1], n);
509
  finally
510
    fs.Free;
511
  end;
512
end;
513

514
// LoadStringFromFile
515
//
516

517
function LoadAnsiStringFromFile(const fileName: string): AnsiString;
518
var
519
  n: Cardinal;
520
  fs: TStream;
521
begin
522
  if FileExists(fileName) then
523
  begin
524
    fs := CreateFileStream(fileName, fmOpenRead + fmShareDenyNone);
525
    try
526
      n := fs.Size;
527
      SetLength(Result, n);
528
      if n > 0 then
529
        fs.Read(Result[1], n);
530
    finally
531
      fs.Free;
532
    end;
533
  end
534
  else
535
    Result := '';
536
end;
537

538
// SaveComponentToFile
539
//
540

541
procedure SaveComponentToFile(const Component: TComponent; const FileName: string; const AsText: Boolean);
542
var
543
  Stream: TStream;
544
  MemStream: TMemoryStream;
545
begin
546
  Stream := CreateFileStream(FileName, fmCreate);
547
  try
548
    if AsText then
549
    begin
550
      MemStream := TMemoryStream.Create;
551
      try
552
        MemStream.WriteComponent(Component);
553
        MemStream.Position := 0;
554
        ObjectBinaryToText(MemStream, Stream);
555
      finally
556
        MemStream.Free;
557
      end;
558
    end
559
    else
560
      Stream.WriteComponent(Component);
561
  finally
562
    Stream.Free;
563
  end;
564
end;
565

566
// LoadComponentFromFile
567
//
568

569
procedure LoadComponentFromFile(const Component: TComponent; const FileName: string; const AsText: Boolean = True);
570
var
571
  Stream: TStream;
572
  MemStream: TMemoryStream;
573
begin
574
  Stream := CreateFileStream(FileName, fmOpenRead);
575
  try
576
    if AsText then
577
    begin
578
      MemStream := TMemoryStream.Create;
579
      try
580
        ObjectTextToBinary(Stream, MemStream);
581
        MemStream.Position := 0;
582
        MemStream.ReadComponent(Component);
583
      finally
584
        MemStream.Free;
585
      end;
586
    end
587
    else
588
      Stream.ReadComponent(Component);
589
  finally
590
    Stream.Free;
591
  end;
592
end;
593

594
// SizeOfFile
595
//
596

597
function SizeOfFile(const fileName: string): Int64;
598
var
599
  fs: TStream;
600
begin
601
  if FileExists(fileName) then
602
  begin
603
    fs := CreateFileStream(fileName, fmOpenRead + fmShareDenyNone);
604
    try
605
      Result := fs.Size;
606
    finally
607
      fs.Free;
608
    end;
609
  end
610
  else
611
    Result := 0;
612
end;
613

614
// GetSqrt255Array
615
//
616

617
function GetSqrt255Array: PSqrt255Array;
618
const
619
  cOneDiv255 = 1 / 255;
620
var
621
  i: Integer;
622
begin
623
  if vSqrt255[255] <> 255 then
624
  begin
625
    for i := 0 to 255 do
626
      vSqrt255[i] := Integer(Trunc(255 * Sqrt(i * cOneDiv255)));
627
  end;
628
  Result := @vSqrt255;
629
end;
630

631
// InformationDlg
632
//
633

634
procedure InformationDlg(const msg: string);
635
begin
636
  ShowMessage(msg);
637
end;
638

639
// QuestionDlg
640
//
641

642
function QuestionDlg(const msg: string): Boolean;
643
begin
644
  Result := (MessageDlg(msg, mtConfirmation, [mbYes, mbNo], 0) = mrYes);
645
end;
646

647
// InputDlg
648
//
649

650
function InputDlg(const aCaption, aPrompt, aDefault: string): string;
651
begin
652
  Result := InputBox(aCaption, aPrompt, aDefault);
653
end;
654

655
// SavePictureDialog
656
//
657

658
function SavePictureDialog(var aFileName: string; const aTitle: string = ''): Boolean;
659
var
660
  saveDialog: TSavePictureDialog;
661
begin
662
  saveDialog := TSavePictureDialog.Create(nil);
663
  try
664
    with saveDialog do
665
    begin
666
      Options := [ofHideReadOnly, ofNoReadOnlyReturn];
667
      if aTitle <> '' then
668
        Title := aTitle;
669
      FileName := aFileName;
670
      Result := Execute;
671
      if Result then
672
        aFileName := FileName;
673
    end;
674
  finally
675
    saveDialog.Free;
676
  end;
677
end;
678

679
// OpenPictureDialog
680
//
681

682
function OpenPictureDialog(var aFileName: string; const aTitle: string = ''): Boolean;
683
var
684
  openDialog: TOpenPictureDialog;
685
begin
686
  openDialog := TOpenPictureDialog.Create(nil);
687
  try
688
    with openDialog do
689
    begin
690
      Options := [ofHideReadOnly, ofNoReadOnlyReturn];
691
      if aTitle <> '' then
692
        Title := aTitle;
693
      FileName := aFileName;
694
      Result := Execute;
695
      if Result then
696
        aFileName := FileName;
697
    end;
698
  finally
699
    openDialog.Free;
700
  end;
701
end;
702

703
function SetGLSceneMediaDir:string;
704
var
705
  path: UTF8String;
706
  p: integer;
707
begin
708
   result:='';
709

710
   // We need to lower case path because the functions are case sensitive
711
   path := lowercase(ExtractFilePath(ParamStrUTF8(0)));
712
   p := Pos('samples', path);
713
   Delete(path, p + 7, Length(path));
714
   path := IncludeTrailingPathDelimiter(IncludeTrailingPathDelimiter(path) + 'media');
715
   SetCurrentDir(path);
716
   // SetCurrentDirUTF8(path) -->  NOT WORKING ON W10 64Bits !
717
     // We need to store the result in a global var "MediaPath"
718
     // The function SetCurrentDirUTF8 return TRUE but we are always in the application's folder
719
     // NB These functions provide from LazFileUtils unit and not from deprecated functions in FileUtils unit.
720

721
   MediaPath:=Path;
722
   result := path;
723

724
end;
725

726
end.
727

728