← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/rtl/objpas/convutil.inc

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/rtl/objpas/convutil.inc
 
1
{
 
2
   This file is part of the Free Pascal run time library.
 
3
   Copyright (c) 2004 by Marco van de Voort
 
4
   member of the Free Pascal development team.
 
5
 
 
6
   An implementation for unit convutils, which converts between
 
7
   units and simple combinations of them.
 
8
 
 
9
   Based on a guessed interface derived from some programs on the web. (Like
 
10
   Marco Cantu's EuroConv example), so things can be a bit Delphi
 
11
   incompatible. Also part on Delphibasics.co.uk.
 
12
 
 
13
   Quantities are mostly taken from my HP48g/gx or the unix units program
 
14
 
 
15
   This program is distributed in the hope that it will be useful,
 
16
   but WITHOUT ANY WARRANTY;without even the implied warranty of
 
17
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
18
 
 
19
**********************************************************************}
 
20
 
 
21
unit convutils;
 
22
 
 
23
interface
 
24
 
 
25
{$mode objfpc}
 
26
{$H+}
 
27
 
 
28
Type TConvType        = type Integer;
 
29
     TConvFamily      = type Integer;
 
30
     TConvFamilyArray = array of TConvFamily;
 
31
     TConvTypeArray   = array of TConvType;
 
32
     TConversionProc  = function(const AValue: Double): Double;
 
33
 
 
34
 
 
35
Type  TConvUtilFloat = double;
 
36
 
 
37
Function RegisterConversionFamily(Const S : String):TConvFamily;
 
38
Function RegisterConversionType(Fam:TConvFamily;Const S:String;Value:TConvUtilFloat):TConvType;
 
39
 
 
40
function Convert ( const Measurement  : Double; const FromType, ToType  : TConvType ) :TConvUtilFloat;
 
41
function Convert ( const Measurement  : Double; const FromType1, FromType2, ToType1, ToType2  : TConvType ) :TConvUtilFloat;
 
42
 
 
43
function ConvFamilyToDescription(const AFamily: TConvFamily): string;
 
44
function ConvTypeToDescription(const AType: TConvType): string;
 
45
procedure GetConvFamilies(out AFamilies: TConvFamilyArray);
 
46
procedure GetConvTypes(const AFamily: TConvFamily; out ATypes: TConvTypeArray);
 
47
 
 
48
Type
 
49
  TConvTypeInfo = Class(Tobject)
 
50
  private
 
51
     FDescription : String;
 
52
     FConvFamily  : TConvFamily;
 
53
     FConvType    : TConvType;
 
54
  public
 
55
     Constructor Create(Const AConvFamily : TConvFamily;const ADescription:String);
 
56
     function ToCommon(const AValue: Double) : Double; virtual; abstract;
 
57
     function FromCommon(const AValue: Double) : Double; virtual; abstract;
 
58
     property ConvFamily : TConvFamily read FConvFamily;
 
59
     property ConvType   : TConvType   read FConvType;
 
60
     property Description: String      read FDescription;
 
61
  end;
 
62
 
 
63
  TConvTypeFactor = class(TConvTypeInfo)
 
64
  private
 
65
    FFactor: Double;
 
66
  protected
 
67
    property Factor: Double read FFactor;
 
68
  public
 
69
    constructor Create(const AConvFamily: TConvFamily; const ADescription: string;
 
70
      const AFactor: Double);
 
71
    function ToCommon(const AValue: Double): Double; override;
 
72
    function FromCommon(const AValue: Double): Double; override;
 
73
  end;
 
74
 
 
75
  TConvTypeProcs = class(TConvTypeInfo)
 
76
  private
 
77
    FToProc: TConversionProc;
 
78
    FFromProc: TConversionProc;
 
79
  public
 
80
    constructor Create(const AConvFamily: TConvFamily; const ADescription: string;
 
81
      const AToProc, AFromProc: TConversionProc);
 
82
    function ToCommon(const AValue: Double): Double; override;
 
83
    function FromCommon(const AValue: Double): Double; override;
 
84
  end;
 
85
 
 
86
Implementation
 
87
 
 
88
Type ResourceData = record
 
89
                      Description : String;
 
90
                      Value       : TConvUtilFloat;
 
91
                      Fam         : TConvFamily;
 
92
                     end;
 
93
 
 
94
 
 
95
var TheUnits    : array of ResourceData =nil;
 
96
    TheFamilies : array of string =nil;
 
97
 
 
98
function ConvFamilyToDescription(const AFamily: TConvFamily): string;
 
99
 
 
100
begin
 
101
  result:='';
 
102
  if AFamily<length(TheFamilies) then
 
103
    result:=TheFamilies[AFamily];
 
104
end;
 
105
 
 
106
procedure GetConvFamilies(out AFamilies: TConvFamilyArray);
 
107
 
 
108
var i : integer;
 
109
begin
 
110
 setlength(AFamilies,length(thefamilies));
 
111
 for i:=0 to length(TheFamilies)-1 do
 
112
   AFamilies[i]:=i;
 
113
end;
 
114
 
 
115
procedure GetConvTypes(const AFamily: TConvFamily; out ATypes: TConvTypeArray);
 
116
 
 
117
var i,j,nrTypes:integer;
 
118
 
 
119
begin
 
120
  nrTypes:=0;
 
121
  for i:=0 to length(TheUnits)-1 do
 
122
    if TheUnits[i].fam=AFamily Then
 
123
     inc(nrTypes);
 
124
  setlength(atypes,nrtypes);
 
125
  j:=0;
 
126
  for i:=0 to length(TheUnits)-1 do
 
127
    if TheUnits[i].fam=AFamily Then
 
128
     begin
 
129
       atypes[j]:=i;
 
130
       inc(j);
 
131
     end;       
 
132
end;
 
133
 
 
134
function ConvTypeToDescription(const AType: TConvType): string;
 
135
 
 
136
Begin
 
137
  result:='';
 
138
  if AType<length(TheUnits) then
 
139
    result:=TheUnits[AType].Description;
 
140
end;
 
141
 
 
142
Function RegisterConversionFamily(Const S:String):TConvFamily;
 
143
 
 
144
var i,l : Longint;
 
145
 
 
146
begin
 
147
  l:=Length(TheFamilies);
 
148
  If l=0 Then
 
149
    begin
 
150
      SetLength(TheFamilies,1);
 
151
      TheFamilies[0]:=S;
 
152
      Result:=0;
 
153
    end
 
154
  else
 
155
    begin
 
156
      i:=0;
 
157
      while (i<l) and (s<>TheFamilies[i]) do inc(i);
 
158
      if i=l Then
 
159
         begin
 
160
           SetLength(TheFamilies,l+1);
 
161
           TheFamilies[l]:=s;
 
162
         end;
 
163
       Result:=i;
 
164
    end;
 
165
end;
 
166
 
 
167
Function CheckFamily(i:TConvFamily):Boolean;
 
168
 
 
169
begin
 
170
  Result:=i<Length(TheFamilies);
 
171
end;
 
172
 
 
173
const macheps=1E-9;
 
174
 
 
175
Function RegisterConversionType(Fam:TConvFamily;Const S:String;Value:TConvUtilFloat):TConvType;
 
176
 
 
177
var l1 : Longint;
 
178
 
 
179
begin
 
180
  If NOT CheckFamily(Fam) Then exit(-1); // family not registered.
 
181
  if (value+1.0)<macheps then            // not properly defined yet.
 
182
    exit(-1);
 
183
  l1:=length(theunits);
 
184
  Setlength(theunits,l1+1);
 
185
  theunits[l1].description:=s;
 
186
  theunits[l1].value:=value;
 
187
  theunits[l1].fam:=fam;
 
188
  Result:=l1;
 
189
end;
 
190
 
 
191
function SearchConvert(TheType:TConvType; var r:ResourceData):Boolean;
 
192
 
 
193
var l1 : longint;
 
194
 
 
195
begin
 
196
  l1:=length(TheUnits);
 
197
  if thetype>=l1 then
 
198
    exit(false);
 
199
  r:=theunits[thetype];
 
200
  result:=true;
 
201
end;
 
202
 
 
203
function Convert ( const Measurement  : Double; const FromType, ToType  : TConvType ) :TConvUtilFloat;
 
204
 
 
205
var
 
206
  fromrec,torec :   resourcedata;
 
207
 
 
208
begin
 
209
  if not SearchConvert(fromtype,fromrec) then
 
210
   exit(-1.0);                                  // raise exception?
 
211
  if not SearchConvert(totype,torec) then
 
212
   exit(-1.0);                                  // raise except?
 
213
  if fromrec.fam<>torec.fam then
 
214
   exit(-1.0);
 
215
  result:=Measurement*fromrec.value/torec.value;
 
216
end;
 
217
 
 
218
function Convert ( const Measurement  : Double; const FromType1, FromType2, ToType1, ToType2  : TConvType ) :TConvUtilFloat;
 
219
var
 
220
  fromrec1,fromrec2,torec1 ,
 
221
  torec2 :   resourcedata;
 
222
 
 
223
begin
 
224
  if not SearchConvert(fromtype1,fromrec1) then
 
225
   exit(-1.0);                                  // raise exception?
 
226
  if not SearchConvert(totype1,torec1) then
 
227
   exit(-1.0);                                  // raise except?
 
228
  if not SearchConvert(fromtype2,fromrec2) then
 
229
   exit(-1.0);                                  // raise exception?
 
230
  if not SearchConvert(totype2,torec2) then
 
231
   exit(-1.0);                                  // raise except?
 
232
  if (fromrec1.fam<>torec1.fam) or (fromrec1.fam<>torec1.fam) then
 
233
   exit(-1.0);
 
234
  result:=Measurement*(fromrec1.value/fromrec2.value)/(torec1.value/torec2.value);
 
235
end;
 
236
 
 
237
Constructor TConvTypeInfo.Create(Const AConvFamily : TConvFamily;const ADescription:String);
 
238
 
 
239
begin
 
240
  FDescription:=ADescription;
 
241
  FConvFamily :=AConvFamily;
 
242
end;
 
243
 
 
244
 
 
245
constructor TConvTypeFactor.Create(const AConvFamily: TConvFamily; const ADescription: string;const AFactor: Double);
 
246
begin
 
247
  inherited create(AConvFamily,ADescription);
 
248
  FFactor:=AFactor;
 
249
end;
 
250
 
 
251
function TConvTypeFactor.ToCommon(const AValue: Double): Double; 
 
252
begin
 
253
  result:=AValue * FFactor;
 
254
end;
 
255
 
 
256
function TConvTypeFactor.FromCommon(const AValue: Double): Double; 
 
257
begin
 
258
  result:=AValue / FFactor;
 
259
end;
 
260
 
 
261
constructor TConvTypeProcs.Create(const AConvFamily: TConvFamily; const ADescription: string; const AToProc, AFromProc: TConversionProc);
 
262
begin
 
263
  inherited create(AConvFamily,ADescription);
 
264
  ftoproc:=AToProc;
 
265
  ffromproc:=AFromProc;
 
266
end;
 
267
 
 
268
function TConvTypeProcs.ToCommon(const AValue: Double): Double; 
 
269
begin
 
270
  result:=FTOProc(Avalue);
 
271
end;
 
272
 
 
273
function TConvTypeProcs.FromCommon(const AValue: Double): Double; 
 
274
begin
 
275
  result:=FFromProc(Avalue);
 
276
end;
 
277
 
 
278
finalization
 
279
  setlength(theunits,0);
 
280
  setlength(thefamilies,0);
 
281
end.