MathgeomGLS

1
{---------------------------------------------------------------------------}
2
{                                                                           }
3
{ File:       Velthuis.FloatUtils.pas                                       }
4
{ Function:   Routines to extract or set the internals of Delphi's floating }
5
{             point types Single, Double and Extended.                      }
6
{ Language:   Delphi version XE3 or later                                   }
7
{ Author:     Rudy Velthuis                                                 }
8
{ Copyright:  (c) 2016 Rudy Velthuis                                        }
9
{                                                                           }
10
{ License:    Redistribution and use in source and binary forms, with or    }
11
{             without modification, are permitted provided that the         }
12
{             following conditions are met:                                 }
13
{                                                                           }
14
{             * Redistributions of source code must retain the above        }
15
{               copyright notice, this list of conditions and the following }
16
{               disclaimer.                                                 }
17
{             * Redistributions in binary form must reproduce the above     }
18
{               copyright notice, this list of conditions and the following }
19
{               disclaimer in the documentation and/or other materials      }
20
{               provided with the distribution.                             }
21
{                                                                           }
22
{ Disclaimer: THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER "AS IS"     }
23
{             AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT     }
24
{             LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND     }
25
{             FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO        }
26
{             EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE     }
27
{             FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,     }
28
{             OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,      }
29
{             PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,     }
30
{             DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED    }
31
{             AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT   }
32
{             LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)        }
33
{             ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF   }
34
{             ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                    }
35
{                                                                           }
36
{---------------------------------------------------------------------------}
37

38
unit Velthuis.FloatUtils;
39

40
{ Note: in newer versions of Delphi, most of these functions are superceded by functions in the
41
        record helpers for floating point types. This unit is made to make provide the
42
        functions for several older versions as well.
43
}
44

45
interface
46

47
uses
48
  System.Math;
49

50
function IsNegativeInfinity(const AValue: Single): Boolean; overload;
51
function IsNegativeInfinity(const AValue: Double): Boolean; overload;
52
function IsNegativeInfinity(const AValue: Extended): Boolean; overload;
53

54
function IsPositiveInfinity(const AValue: Single): Boolean; overload;
55
function IsPositiveInfinity(const AValue: Double): Boolean; overload;
56
function IsPositiveInfinity(const AValue: Extended): Boolean; overload;
57

58
function GetSignificand(const AValue: Single): UInt32; overload;
59
function GetSignificand(const AValue: Double): UInt64; overload;
60
function GetSignificand(const AValue: Extended): UInt64; overload;
61
function GetMantissa(const AValue: Single): UInt32; overload;
62
function GetMantissa(const AValue: Double): UInt64; overload;
63
function GetMantissa(const AValue: Extended): UInt64; overload;
64

65
function GetExponent(const AValue: Single): Integer; overload;
66
function GetExponent(const AValue: Double): Integer; overload;
67
function GetExponent(const AValue: Extended): Integer; overload;
68

69
function IsDenormal(const AValue: Single): Boolean; overload;
70
function IsDenormal(const AValue: Double): Boolean; overload;
71
function IsDenormal(const AValue: Extended): Boolean; overload;
72

73
function MakeSingle(Sign: TValueSign; Significand: UInt32; Exponent: Integer): Single;
74
function MakeDouble(Sign: TValueSign; Significand: UInt64; Exponent: Integer): Double;
75
function MakeExtended(Sign: TValueSign; Significand: UInt64; Exponent: Integer): Extended;
76

77
type
78
  PUInt8  = ^UInt8;
79
  PUInt16 = ^UInt16;
80
  PUInt32 = ^UInt32;
81
  PUInt64 = ^UInt64;
82

83
  PExt80Rec = ^TExt80Rec;
84
  TExt80Rec = packed record
85
    Significand: UInt64;
86
    ExponentAndSign: Word;
87
  end;
88

89
const
90
  CSingleExponentShift   = 23;
91
  CDoubleExponentShift   = 52;
92
  CSingleExponentMask    = $FF;
93
  CDoubleExponentMask    = $7FF;
94
  CExtendedExponentMask  = $7FFF;
95
  CSingleBias            = CSingleExponentMask shr 1;
96
  CDoubleBias            = CDoubleExponentMask shr 1;
97
  CExtendedBias          = CExtendedExponentMask shr 1;
98
  CSingleSignificandMask = UInt32(1) shl CSingleExponentShift - 1;
99
  CDoubleSignificandMask = UInt64(1) shl CDoubleExponentShift - 1;
100
  CSingleSignMask        = UInt32(1) shl 31;
101
  CDoubleSignMask        = UInt64(1) shl 63;
102

103
implementation
104

105
uses
106
  System.SysUtils;
107

108
{$IF CompilerVersion >= 24.0}
109
  {$LEGACYIFEND ON}
110
{$IFEND}
111

112
{$POINTERMATH ON}
113

114
function GetRawSignificand(const AValue: Single): UInt32; overload; inline;
115
begin
116
  Result := PUInt32(@AValue)^ and CSingleSignificandMask;
117
end;
118

119
function GetRawSignificand(const AValue: Double): UInt64; overload; inline;
120
begin
121
  Result := PUInt64(@AValue)^ and CDoubleSignificandMask;
122
end;
123

124
function GetRawExponent(const AValue: Single): Integer; overload; inline;
125
begin
126
  Result := PUInt32(@AValue)^ shr CSingleExponentShift and CSingleExponentMask;
127
end;
128

129
function GetRawExponent(const AValue: Double): Integer; overload; inline;
130
begin
131
  Result := PUInt16(@AValue)[3] shr 4 and CDoubleExponentMask;
132
end;
133

134
function GetRawExponent(const AValue: Extended): Integer; overload; inline;
135
begin
136
  Result := PUInt16(@AValue)[4] and CExtendedExponentMask;
137
end;
138

139
function IsNegativeInfinity(const AValue: Single): Boolean; overload;
140
begin
141
  Result := System.Math.IsInfinite(AValue) and (System.Math.Sign(AValue) < 0);
142
end;
143

144
function IsNegativeInfinity(const AValue: Double): Boolean; overload;
145
begin
146
  Result := System.Math.IsInfinite(AValue) and (Sign(AValue) < 0);
147
end;
148

149
function IsNegativeInfinity(const AValue: Extended): Boolean; overload;
150
begin
151
  Result := System.Math.IsInfinite(AValue) and (Sign(AValue) < 0);
152
end;
153

154
function IsPositiveInfinity(const AValue: Single): Boolean; overload;
155
begin
156
  Result := System.Math.IsInfinite(AValue) and (Sign(AValue) > 0);
157
end;
158

159
function IsPositiveInfinity(const AValue: Double): Boolean; overload;
160
begin
161
  Result := System.Math.IsInfinite(AValue) and (Sign(AValue) > 0);
162
end;
163

164
function IsPositiveInfinity(const AValue: Extended): Boolean; overload;
165
begin
166
  Result := System.Math.IsInfinite(AValue) and (Sign(AValue) > 0);
167
end;
168

169
function GetSignificand(const AValue: Single): UInt32; overload;
170
var
171
  E: Integer;
172
begin
173
  E := GetRawExponent(AValue);
174
  Result := GetRawSignificand(AValue);
175
  if (0 < E) and (E < CSingleExponentMask) then
176
    Result := Result or (UInt32(1) shl CSingleExponentShift);
177
end;
178

179
function GetSignificand(const AValue: Double): UInt64; overload;
180
var
181
  E: Integer;
182
begin
183
  E := GetRawExponent(AValue);
184
  Result := GetRawSignificand(AValue);
185
  if (0 < E) and (E < CDoubleExponentMask) then
186
    Result := Result or ((UInt64(1) shl CDoubleExponentShift));
187
end;
188

189
function GetSignificand(const AValue: Extended): UInt64; overload;
190
begin
191
  Result := PUInt64(@AValue)^;
192
end;
193

194
function GetMantissa(const AValue: Single): UInt32; overload;
195
begin
196
  Result := GetSignificand(AValue);
197
end;
198

199
function GetMantissa(const AValue: Double): UInt64; overload;
200
begin
201
  Result := GetSignificand(AValue);
202
end;
203

204
function GetMantissa(const AValue: Extended): UInt64; overload;
205
begin
206
  Result := GetSignificand(AValue);
207
end;
208

209
function GetExponent(const AValue: Single): Integer; overload;
210
var
211
  M: UInt32;
212
  E: Int32;
213
begin
214
  M := GetRawSignificand(AValue);
215
  E := GetRawExponent(AValue);
216
  if (0 < E) and (E < CSingleExponentMask) then
217
    Result := E - CSingleBias
218
  else if E = 0 then
219
    if M = 0 then
220
      // +/- Zero
221
      Result := 0
222
    else
223
      // Denormal
224
      Result := 1 - CSingleBias
225
  else
226
    // NaN or +/-Infinity
227
    Result := 0;
228
end;
229

230
function GetExponent(const AValue: Double): Integer; overload;
231
var
232
  M: UInt64;
233
  E: Int32;
234
begin
235
  M := GetRawSignificand(AValue);
236
  E := GetRawExponent(AValue);
237
  if (0 < E) and (E < CDoubleExponentMask) then
238
    Result := E - CDoubleBias
239
  else if E = 0 then
240
    if M = 0 then
241
      // +/-Zero
242
      Result := 0
243
    else
244
      // Denormal
245
      Result := 1 - CDoubleBias
246
  else
247
    // NaN or +/-Infinity
248
    Result := 0;
249
end;
250

251
function GetExponent(const AValue: Extended): Integer; overload;
252
var
253
  M: UInt64;
254
  E: Int32;
255
begin
256
  M := PUInt64(@AValue)^;
257
  E := GetRawExponent(AValue);
258
  if (0 < E) and (E < CExtendedExponentMask) then
259
    Result := E - CExtendedBias
260
  else if E = 0 then
261
    if M = 0 then
262
      // +/- Zero
263
      Result := 0
264
    else
265
      // Denormal
266
      Result := 1 - CExtendedBias
267
  else
268
    // NaN or +/-Infinity
269
    Result := 0;
270
end;
271

272
function IsDenormal(const AValue: Single): Boolean; overload;
273
begin
274
  Result := ((PUInt32(@AValue)^ shr CSingleExponentShift and CSingleExponentMask) = 0) and (GetSignificand(AValue) <> 0);
275
end;
276

277
function IsDenormal(const AValue: Double): Boolean; overload;
278
begin
279
  Result := ((PUInt64(@AValue)^ shr 52) = 0) and (GetSignificand(AValue) <> 0);
280
end;
281

282
function IsDenormal(const AValue: Extended): Boolean; overload;
283
begin
284
  Result := ((PUInt16(@AValue)[4] and $7FFF) = 0) and (GetSignificand(AValue) <> 0);
285
end;
286

287
function MakeSingle(Sign: TValueSign; Significand: UInt32; Exponent: Integer): Single;
288
var
289
  U: UInt32;
290
begin
291
  U := (Sign and CSingleSignMask) or
292
       ((UInt32(Exponent + CSingleBias) and CSingleExponentMask) shl CSingleExponentShift) or
293
       (Significand and CSingleSignificandMask);
294
  PUInt32(@Result)^ := U;
295
end;
296

297
function MakeDouble(Sign: TValueSign; Significand: UInt64; Exponent: Integer): Double;
298
var
299
  U: UInt64;
300
begin
301
  U := UInt64(Int64(Sign) and CDoubleSignMask) or
302
       (UInt64((Exponent + CDoubleBias) and CDoubleExponentMask) shl CDoubleExponentShift) or
303
       (Significand and CDoubleSignificandMask);
304
  PUInt64(@Result)^ := U;
305
end;
306

307
function MakeExtended(Sign: TValueSign; Significand: UInt64; Exponent: Integer): Extended;
308
var
309
  E: TExt80Rec;
310
begin
311
  E.Significand := Significand;
312
  E.ExponentAndSign := (Sign and $8000) or ((Exponent + CExtendedBias) and CExtendedExponentMask);
313
  PExt80Rec(@Result)^ := E;
314
end;
315

316
end.
317

318