Subversion Repositories oidplus

Rev

Rev 733 | Rev 740 | Go to most recent revision | Show entire file | Regard whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 733 Rev 739
Line 1... Line 1...
1 
unit VTSFUNCS;
 1 
unit VTSFUNCS;
2 
 
 2 
 
3 
(************************************************)
 3 
(************************************************)
4 
(* VTSFUNCS.PAS                                 *)
 4 
(* VTSFUNCS.PAS                                 *)
5 
(* Author:   Daniel Marschall                   *)
 5 
(* Author:   Daniel Marschall                   *)
6 
(* Revision: 2022-02-13                         *)
 6 
(* Revision: 2022-02-14                         *)
7 
(* License:  Apache 2.0                         *)
 7 
(* License:  Apache 2.0                         *)
8 
(* This file contains:                          *)
 8 
(* This file contains:                          *)
9 
(* - Various functions                          *)
 9 
(* - Various functions                          *)
10 
(************************************************)
 10 
(************************************************)
11 
 
 11 
 
12 
interface
 12 
interface
13 
 
 13 
 
- 
 
 14 
function Max(a, b: integer): integer;
- 
 
 15 
function Min(a, b: integer): integer;
- 
 
 16 
 
14 
function CompareEqualLengthString(a, b: string): integer;
 17 
function CompareEqualLengthString(a, b: string): integer;
15 
function CompareNumericString(a, b: string): integer;
 18 
function CompareNumericString(a, b: string): integer;
- 
 
 19 
 
16 
procedure Beep;
 20 
procedure Beep;
- 
 
 21 
 
17 
function Trim(s: string): string;
 22 
function Trim(s: string): string;
18 
function IsNumeric(s: string): boolean;
 - 
 
19 
function ZeroPad(i: LongInt; n: integer): string;
 23 
function ZeroPad(i: LongInt; n: integer): string;
- 
 
 24 
function LeftPadStr(s: string; n: integer; ch: char): string;
- 
 
 25 
function RightPadStr(s: string; n: integer; ch: char): string;
- 
 
 26 
 
20 
procedure DeleteFile(filename: string);
 27 
function DeleteFile(filename: string): boolean;
21 
function FileExists(filename: string): boolean;
 28 
function FileExists(filename: string): boolean;
- 
 
 29 
 
- 
 
 30 
function IsPositiveInteger(s: string): boolean;
22 
function StrToInt(s: string): Integer;
 31 
function StrToInt(s: string): Integer;
23 
function IntToStr(Value: Integer): string;
 32 
function IntToStr(Value: Integer): string;
24 
 
 33 
 
25 
implementation
 34 
implementation
26 
 
 35 
 
27 
uses
 36 
uses
28 
  Crt;
 37 
  Crt;
29 
 
 38 
 
- 
 
 39 
function Max(a, b: integer): integer;
- 
 
 40 
begin
- 
 
 41 
  if a > b then
- 
 
 42 
    Max := a
- 
 
 43 
  else
- 
 
 44 
    Max := b;
- 
 
 45 
end;
- 
 
 46 
 
- 
 
 47 
function Min(a, b: integer): integer;
- 
 
 48 
begin
- 
 
 49 
  if a < b then
- 
 
 50 
    Min := a
- 
 
 51 
  else
- 
 
 52 
    Min := b;
- 
 
 53 
end;
- 
 
 54 
 
30 
function CompareEqualLengthString(a, b: string): integer;
 55 
function CompareEqualLengthString(a, b: string): integer;
31 
var
 56 
var
32 
  ao, bo, i: integer;
 57 
  ao, bo, i: integer;
33 
begin
 58 
begin
34 
  CompareEqualLengthString := 0;
 59 
  CompareEqualLengthString := 0;
Line 49... Line 74...
49 
  end;
 74 
  end;
50 
end;
 75 
end;
51 
 
 76 
 
52 
function CompareNumericString(a, b: string): integer;
 77 
function CompareNumericString(a, b: string): integer;
53 
var
 78 
var
54 
  i, maxlen: integer;
 79 
  EqualLength: integer;
55 
  prefix_a, prefix_b: string;
 - 
 
56 
begin
 80 
begin
57 
  maxlen := Length(a);
 - 
 
58 
  if Length(b) > maxlen then maxlen := Length(b);
 81 
  EqualLength := Max(Length(a), Length(b));
59 
 
 - 
 
60 
  prefix_a := '';
 - 
 
61 
  for i := 1 to maxlen-Length(a) do
 82 
  a := LeftPadStr(a, EqualLength, '0');
62 
  begin
 - 
 
63 
    prefix_a := prefix_a + '0';
 - 
 
64 
 end;
 - 
 
65 
 
 - 
 
66 
  prefix_b := '';
 - 
 
67 
  for i := 1 to maxlen-Length(b) do
 83 
  b := LeftPadStr(b, EqualLength, '0');
68 
  begin
 - 
 
69 
    prefix_b := prefix_b + '0';
 - 
 
70 
 end;
 - 
 
71 
 
 - 
 
72 
 CompareNumericString := CompareEqualLengthString(prefix_a+a, prefix_b+b);
 84 
  CompareNumericString := CompareEqualLengthString(a, b);
73 
end;
 85 
end;
74 
 
 86 
 
75 
procedure Beep;
 87 
procedure Beep;
76 
begin
 88 
begin
77 
  Sound(220); (*220Hz*)
 89 
  Sound(220); (*220Hz*)
Line 96... Line 108...
96 
      break;
 108 
      break;
97 
  end;
 109 
  end;
98 
  Trim := s;
 110 
  Trim := s;
99 
end;
 111 
end;
100 
 
 112 
 
101 
function IsNumeric(s: string): boolean;
 113 
function ZeroPad(i: LongInt; n: integer): string;
102 
var
 114 
var
103 
  i: integer;
 115 
  s: string;
104 
begin
 116 
begin
105 
  IsNumeric := false;
 117 
  s := IntToStr(i);
- 
 
 118 
  ZeroPad := LeftPadStr(s, n, '0');
- 
 
 119 
end;
106 
 
 120 
 
107 
  if Length(s) = 0 then exit;
 - 
 
108 
  if (s[1] = '0') and (s <> '0') then exit;
 121 
function LeftPadStr(s: string; n: integer; ch: char): string;
109 
  for i := 1 to Length(s) do
 - 
 
110 
  begin
 122 
begin
111 
    if not (s[i] in ['0'..'9']) then exit;
 123 
  while Length(s) < n do
- 
 
 124 
  begin
- 
 
 125 
    s := ch + s;
112 
  end;
 126 
  end;
113 
 
 - 
 
114 
  IsNumeric := true;
 127 
  LeftPadStr := s;
115 
end;
 128 
end;
116 
 
 129 
 
117 
function ZeroPad(i: LongInt; n: integer): string;
 130 
function RightPadStr(s: string; n: integer; ch: char): string;
118 
var
 - 
 
119 
  s: string;
 - 
 
120 
begin
 131 
begin
121 
  Str(i, s);
 - 
 
122 
  while Length(s) < n do
 132 
  while Length(s) < n do
123 
  begin
 133 
  begin
124 
    s := '0' + s;
 134 
    s := s + ch;
125 
  end;
 135 
  end;
126 
  ZeroPad := s;
 136 
  RightPadStr := s;
127 
end;
 137 
end;
128 
 
 138 
 
129 
procedure DeleteFile(filename: string);
 139 
function DeleteFile(filename: string): boolean;
130 
var
 140 
var
131 
 F:  file;
 141 
  F:  file;
132 
 Ch: Char;
 142 
  Ch: Char;
133 
begin
 143 
begin
134 
 { Get file to delete from command line }
 - 
 
135 
 Assign(F, filename);
 144 
  Assign(F, filename);
136 
 {$I-}
 145 
  {$I-}
137 
 Reset(F);
 146 
  Reset(F);
138 
 {$I+}
 147 
  {$I+}
139 
 (*
 - 
 
140 
 if IOResult <> 0 then
 148 
  if IOResult <> 0 then
- 
 
 149 
  begin
141 
   Writeln('Cannot find ', filename)
 150 
    DeleteFile := false; (* cannot find file *)
- 
 
 151 
  end
142 
 else
 152 
  else
143 
 begin
 153 
  begin
144 
 *)
 - 
 
145 
   Close(F);
 154 
    Close(F);
146 
   (*
 - 
 
147 
   Write('Erase ', filename, '? ');
 - 
 
148 
   Readln(Ch);
 - 
 
149 
   if UpCase(CH) = 'Y' then
 - 
 
150 
   *)
 155 
    {$I-}
151 
     Erase(F);
 156 
    Erase(F);
152 
 (*
 157 
    {$I+}
- 
 
 158 
    DeleteFile := IOResult = 0;
153 
 end;
 159 
  end;
154 
 *)
 - 
 
155 
end;
 160 
end;
156 
 
 161 
 
157 
function FileExists(filename: string): boolean;
 162 
function FileExists(filename: string): boolean;
158 
var
 163 
var
159 
  F: Text;
 164 
  F: Text;
Line 163... Line 168...
163 
  Reset(F);
 168 
  Reset(F);
164 
  {$I+}
 169 
  {$I+}
165 
  FileExists := IoResult = 0;
 170 
  FileExists := IoResult = 0;
166 
end;
 171 
end;
167 
 
 172 
 
- 
 
 173 
function IsPositiveInteger(s: string): boolean;
- 
 
 174 
var
- 
 
 175 
  i: integer;
- 
 
 176 
begin
- 
 
 177 
  IsPositiveInteger := false;
- 
 
 178 
 
- 
 
 179 
  if Length(s) = 0 then exit;
- 
 
 180 
  if (s[1] = '0') and (s <> '0') then exit;
- 
 
 181 
  for i := 1 to Length(s) do
- 
 
 182 
  begin
- 
 
 183 
    if not (s[i] in ['0'..'9']) then exit;
- 
 
 184 
  end;
- 
 
 185 
 
- 
 
 186 
  IsPositiveInteger := true;
- 
 
 187 
end;
- 
 
 188 
 
168 
function StrToInt(s: string): Integer;
 189 
function StrToInt(s: string): Integer;
169 
var
 190 
var
170 
  i, Error: Integer;
 191 
  i, Error: Integer;
171 
begin
 192 
begin
172 
  Val(s, i, Error);
 193 
  Val(s, i, Error);