convutils2.pas

Yahoo Messenger for Mobile

{ *********************************************************************** }
{                                                                         }
{ Delphi Runtime Library                                                  }
{                                                                         }
{ Copyright (c) 1995-2001 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

{*******************************************************}
{   Conversions engine, no built in conversion types    }
{*******************************************************}

unit ConvUtils;

interface

uses
  SysUtils, Math, Types;

type
  TConvFamily = type Word;
  TConvType = type Word;
  TConversionProc = function(const AValue: Double): Double;
  TConvTypeArray = array of TConvType;
  TConvFamilyArray = array of TConvFamily;

// Simple conversion between two measurement types
function Convert(const AValue: Double;
  const AFrom, ATo: TConvType): Double; overload;

// Complex conversion between two double measurement types.  An example of
//  this would be converting miles per hour to meters per minute (speed) or
//  gallons per minute to liters per hour (flow).  There are lots of
//  combinations but not all of them make much sense.
function Convert(const AValue: Double;
  const AFrom1, AFrom2, ATo1, ATo2: TConvType): Double; overload;

// Convert from and to the base unit type for a particular conversion family
function ConvertFrom(const AFrom: TConvType; const AValue: Double): Double;
function ConvertTo(const AValue: Double; const ATo: TConvType): Double;

// Add/subtract two values together and return the result in a specified type
function ConvUnitAdd(const AValue1: Double; const AType1: TConvType;
  const AValue2: Double; const AType2, AResultType: TConvType): Double;
function ConvUnitDiff(const AValue1: Double; const AType1: TConvType;
  const AValue2: Double; const AType2, AResultType: TConvType): Double;

// Increment/decrement a value by a value of a specified type
function ConvUnitInc(const AValue: Double;
  const AType, AAmountType: TConvType): Double; overload;
function ConvUnitInc(const AValue: Double; const AType: TConvType;
  const AAmount: Double; const AAmountType: TConvType): Double; overload;
function ConvUnitDec(const AValue: Double;
  const AType, AAmountType: TConvType): Double; overload;
function ConvUnitDec(const AValue: Double; const AType: TConvType;
  const AAmount: Double; const AAmountType: TConvType): Double; overload;

// Test to see if a given value is within the previous (or next) given units of
//   of a certian type
function ConvUnitWithinPrevious(const AValue, ATest: Double;
  const AType: TConvType; const AAmount: Double;
  const AAmountType: TConvType): Boolean;
function ConvUnitWithinNext(const AValue, ATest: Double; const AType: TConvType;
  const AAmount: Double; const AAmountType: TConvType): Boolean;

// Comparison and Equality testing
function ConvUnitCompareValue(const AValue1: Double; const AType1: TConvType;
  const AValue2: Double; const AType2: TConvType): TValueRelationship;
function ConvUnitSameValue(const AValue1: Double; const AType1: TConvType;
  const AValue2: Double; const AType2: TConvType): Boolean;

// (un)Registation of conversion types.  You should unregister your conversion
//   types when the unit that registered them is finalized or is no longer used.

function RegisterConversionType(const AFamily: TConvFamily;
  const ADescription: string; const AFactor: Double): TConvType; overload;
function RegisterConversionType(const AFamily: TConvFamily;
  const ADescription: string; const AToCommonProc,
  AFromCommonProc: TConversionProc): TConvType; overload;
procedure UnregisterConversionType(const AType: TConvType);

// (un)Registation of conversion families.  You should unregister your
//   conversion families when the unit that registered them is finalized or is
//   no longer used.

function RegisterConversionFamily(const ADescription: string): TConvFamily;
procedure UnregisterConversionFamily(const AFamily: TConvFamily);

// Compatibility testing

function CompatibleConversionTypes(const AFrom, ATo: TConvType): Boolean;
function CompatibleConversionType(const AType: TConvType;
  const AFamily: TConvFamily): Boolean;

// Discovery support functions

procedure GetConvTypes(const AFamily: TConvFamily; out ATypes: TConvTypeArray);
procedure GetConvFamilies(out AFamilies: TConvFamilyArray);

// String parsing support

function StrToConvUnit(AText: string; out AType: TConvType): Double;
function TryStrToConvUnit(AText: string; out AValue: Double;
  out AType: TConvType): Boolean;
function ConvUnitToStr(const AValue: Double; const AType: TConvType): string;

// Description format/parsing function

function ConvTypeToDescription(const AType: TConvType): string;
function ConvFamilyToDescription(const AFamily: TConvFamily): string;
function DescriptionToConvType(const ADescription: string;
  out AType: TConvType): Boolean; overload;
function DescriptionToConvType(const AFamily: TConvFamily;
  const ADescription: string; out AType: TConvType): Boolean; overload;
function DescriptionToConvFamily(const ADescription: string;
  out AFamily: TConvFamily): Boolean;

// ConvType to Family support

function ConvTypeToFamily(const AType: TConvType): TConvFamily; overload;
function TryConvTypeToFamily(const AType: TConvType;
  out AFamily: TConvFamily): Boolean; overload;

function ConvTypeToFamily(const AFrom, ATo: TConvType): TConvFamily; overload;
function TryConvTypeToFamily(const AFrom, ATo: TConvType;
  out AFamily: TConvFamily): Boolean; overload;

// Error procs

procedure RaiseConversionError(const AText: string); overload;
procedure RaiseConversionError(const AText: string;
  const AArgs: array of const); overload;
procedure RaiseConversionRegError(AFamily: TConvFamily;
  const ADescription: string);

type
  EConversionError = class(Exception);

const
  CIllegalConvFamily: TConvFamily = 0;
  CIllegalConvType: TConvType = 0;

var
  GConvUnitToStrFmt: string = '%f %s';

// Custom conversion type support

type
  TConvTypeInfo = class(TObject)
  private
    FDescription: string;
    FConvFamily: TConvFamily;
    FConvType: TConvType;
  public
    constructor Create(const AConvFamily: TConvFamily; const ADescription: string);
    function ToCommon(const AValue: Double): Double; virtual; abstract;
    function FromCommon(const AValue: Double): Double; virtual; abstract;
    property ConvFamily: TConvFamily read FConvFamily;
    property ConvType: TConvType read FConvType;
    property Description: string read FDescription;
  end;
  TConvTypeList = array of TConvTypeInfo;

  TConvTypeFactor = class(TConvTypeInfo)
  private
    FFactor: Double;
  protected
    property Factor: Double read FFactor; 
  public
    constructor Create(const AConvFamily: TConvFamily; const ADescription: string;
      const AFactor: Double);
    function ToCommon(const AValue: Double): Double; override;
    function FromCommon(const AValue: Double): Double; override;
  end;

  TConvTypeProcs = class(TConvTypeInfo)
  private
    FToCommonProc: TConversionProc;
    FFromCommonProc: TConversionProc;
  public
    constructor Create(const AConvFamily: TConvFamily; const ADescription: string;
      const AToCommonProc, AFromCommonProc: TConversionProc);
    function ToCommon(const AValue: Double): Double; override;
    function FromCommon(const AValue: Double): Double; override;
  end;

function RegisterConversionType(AConvTypeInfo: TConvTypeInfo;
  out AType: TConvType): Boolean; overload;

implementation

uses
  RTLConsts;

const
  CListGrowthDelta = 16;

// Comprehension of the following types and functions are not required in
//  order to use this unit.  They are provided as a way to iterate through
//  the declared conversion families and types.
type
  TConvFamilyInfo = class(TObject)
  private
    FDescription: string;
    FConvFamily: TConvFamily;
  public
    constructor Create(const AConvFamily: TConvFamily; const ADescription: string);
    property ConvFamily: TConvFamily read FConvFamily;
    property Description: string read FDescription;
  end;
  TConvFamilyList = array of TConvFamilyInfo;

var
  GConvFamilyList: TConvFamilyList;
  GConvTypeList: TConvTypeList;
  GLastConvFamily: TConvFamily;
  GLastConvType: TConvType;
  GConvFamilySync: TMultiReadExclusiveWriteSynchronizer;
  GConvTypeSync: TMultiReadExclusiveWriteSynchronizer;

procedure RaiseConversionError(const AText: string);
begin
  raise EConversionError.Create(AText);
end;

procedure RaiseConversionError(const AText: string; const AArgs: array of const);
begin
  raise EConversionError.CreateFmt(AText, AArgs);
end;

procedure RaiseConversionRegError(AFamily: TConvFamily;
  const ADescription: string);
begin
  RaiseConversionError(SConvDuplicateType,
    [ADescription, ConvFamilyToDescription(AFamily)]);
end;

function GetConvFamilyInfo(const AFamily: TConvFamily;
  out AConvFamilyInfo: TConvFamilyInfo): Boolean;
begin
  GConvFamilySync.BeginRead;
  try
    Result := AFamily < Length(GConvFamilyList);
    if Result then
    begin
      AConvFamilyInfo := GConvFamilyList[AFamily];
      Result := Assigned(AConvFamilyInfo);
    end;
  finally
    GConvFamilySync.EndRead;
  end;
end;

function GetConvInfo(const AType: TConvType;
  out AConvTypeInfo: TConvTypeInfo): Boolean; overload;
begin
  GConvTypeSync.BeginRead;
  try
    Result := AType < Length(GConvTypeList);
    if Result then
    begin
      AConvTypeInfo := GConvTypeList[AType];
      Result := Assigned(AConvTypeInfo);
    end;
  finally
    GConvTypeSync.EndRead;
  end;
end;

function GetConvInfo(const AType: TConvType; out AConvTypeInfo: TConvTypeInfo;
  out AConvFamilyInfo: TConvFamilyInfo): Boolean; overload;
begin
  Result := GetConvInfo(AType, AConvTypeInfo) and
            GetConvFamilyInfo(AConvTypeInfo.ConvFamily, AConvFamilyInfo);
end;

function GetConvInfo(const AType: TConvType;
  out AConvFamilyInfo: TConvFamilyInfo): Boolean; overload;
var
  LConvTypeInfo: TConvTypeInfo;
begin
  Result := GetConvInfo(AType, LConvTypeInfo) and
            GetConvFamilyInfo(LConvTypeInfo.ConvFamily, AConvFamilyInfo);
end;

function GetConvInfo(const AFrom, ATo: TConvType; out AFromTypeInfo,
  AToTypeInfo: TConvTypeInfo;
  out AConvFamilyInfo: TConvFamilyInfo): Boolean; overload;
var
  LFromFamilyInfo: TConvFamilyInfo;
begin
  Result := GetConvInfo(AFrom, AFromTypeInfo, LFromFamilyInfo) and
            GetConvInfo(ATo, AToTypeInfo, AConvFamilyInfo) and
            (AConvFamilyInfo = LFromFamilyInfo);
end;

function GetConvInfo(const AFrom, ATo: TConvType; out AFromTypeInfo,
  AToTypeInfo: TConvTypeInfo): Boolean; overload;
begin
  Result := GetConvInfo(AFrom, AFromTypeInfo) and
            GetConvInfo(ATo, AToTypeInfo) and
            (AFromTypeInfo.ConvFamily = AToTypeInfo.ConvFamily);
end;

function GetConvInfo(const AFrom, ATo, AResult: TConvType; out AFromTypeInfo,
  AToTypeInfo, AResultTypeInfo: TConvTypeInfo): Boolean; overload;
begin
  Result := GetConvInfo(AFrom, AFromTypeInfo) and
            GetConvInfo(ATo, AToTypeInfo) and
            GetConvInfo(AResult, AResultTypeInfo) and
            (AFromTypeInfo.ConvFamily = AToTypeInfo.ConvFamily) and
            (AToTypeInfo.ConvFamily = AResultTypeInfo.ConvFamily);
end;

function GetConvInfo(const AFrom, ATo: TConvType;
  out AConvFamilyInfo: TConvFamilyInfo): Boolean; overload;
var
  LFromFamilyInfo: TConvFamilyInfo;
begin
  Result := GetConvInfo(AFrom, LFromFamilyInfo) and
            GetConvInfo(ATo, AConvFamilyInfo) and
            (AConvFamilyInfo = LFromFamilyInfo);
end;

function ConvTypeToFamily(const AType: TConvType): TConvFamily;
begin
  if not TryConvTypeToFamily(AType, Result) then
    RaiseConversionError(SConvUnknownType,
                         [Format(SConvUnknownDescription, [AType])]);
end;

function TryConvTypeToFamily(const AType: TConvType; out AFamily: TConvFamily): Boolean;
var
  LTypeInfo: TConvTypeInfo;
begin
  Result := GetConvInfo(AType, LTypeInfo);
  if Result then
    AFamily := LTypeInfo.ConvFamily;
end;

function ConvTypeToFamily(const AFrom, ATo: TConvType): TConvFamily;
begin
  if not TryConvTypeToFamily(AFrom, ATo, Result) then
    RaiseConversionError(SConvIncompatibleTypes2,
      [ConvTypeToDescription(AFrom),
       ConvTypeToDescription(ATo)]);
end;

function TryConvTypeToFamily(const AFrom, ATo: TConvType; out AFamily: TConvFamily): Boolean;
var
  LFromTypeInfo, LToTypeInfo: TConvTypeInfo;
begin
  Result := GetConvInfo(AFrom, LFromTypeInfo) and
            GetConvInfo(ATo, LToTypeInfo) and
            (LFromTypeInfo.ConvFamily = LToTypeInfo.ConvFamily);
  if Result then
    AFamily := LFromTypeInfo.ConvFamily;
end;

function CompatibleConversionTypes(const AFrom, ATo: TConvType): Boolean;
var
  LFamily: TConvFamily;
begin
  Result := TryConvTypeToFamily(AFrom, ATo, LFamily);
end;

function CompatibleConversionType(const AType: TConvType; const AFamily: TConvFamily): Boolean;
var
  LTypeInfo: TConvTypeInfo;
begin
  if not GetConvInfo(AType, LTypeInfo) then
    RaiseConversionError(SConvUnknownType,
                         [Format(SConvUnknownDescription, [AType])]);
  Result := LTypeInfo.ConvFamily = AFamily;
end;

function Convert(const AValue: Double; const AFrom, ATo: TConvType): Double;
var
  LFromTypeInfo, LToTypeInfo: TConvTypeInfo;
begin
  if not GetConvInfo(AFrom, ATo, LFromTypeInfo, LToTypeInfo) then
    RaiseConversionError(SConvIncompatibleTypes2,
      [ConvTypeToDescription(AFrom),
       ConvTypeToDescription(ATo)]);
  Result := LToTypeInfo.FromCommon(LFromTypeInfo.ToCommon(AValue));
end;

function Convert(const AValue: Double;
  const AFrom1, AFrom2, ATo1, ATo2: TConvType): Double;
begin
  Result := Convert(Convert(AValue, AFrom1, ATo1), ATo2, AFrom2);
end;

function ConvertFrom(const AFrom: TConvType; const AValue: Double): Double;
var
  LFromTypeInfo: TConvTypeInfo;
begin
  if not GetConvInfo(AFrom, LFromTypeInfo) then
    RaiseConversionError(SConvUnknownType,
                         [Format(SConvUnknownDescription, [AFrom])]);
  Result := LFromTypeInfo.ToCommon(AValue);
end;

function ConvertTo(const AValue: Double; const ATo: TConvType): Double;
var
  LToTypeInfo: TConvTypeInfo;
begin
  if not GetConvInfo(ATo, LToTypeInfo) then
    RaiseConversionError(SConvUnknownType,
                         [Format(SConvUnknownDescription, [ATo])]);
  Result := LToTypeInfo.FromCommon(AValue);
end;

function ConvUnitAdd(const AValue1: Double; const AType1: TConvType;
  const AValue2: Double; const AType2, AResultType: TConvType): Double;
var
  LType1Info, LType2Info, LResultTypeInfo: TConvTypeInfo;
begin
  if not GetConvInfo(AType1, AType2, AResultType,
                     LType1Info, LType2Info, LResultTypeInfo) then
    RaiseConversionError(SConvIncompatibleTypes3,
      [ConvTypeToDescription(AType1),
       ConvTypeToDescription(AType2),
       ConvTypeToDescription(AResultType)]);
  Result := LResultTypeInfo.FromCommon(LType1Info.ToCommon(AValue1) +
                                       LType2Info.ToCommon(AValue2));
end;

function ConvUnitDiff(const AValue1: Double; const AType1: TConvType;
  const AValue2: Double; const AType2, AResultType: TConvType): Double;
begin
  Result := ConvUnitAdd(AValue1, AType1, -AValue2, AType2, AResultType);
end;

function ConvUnitInc(const AValue: Double;
  const AType, AAmountType: TConvType): Double;
begin
  Result := ConvUnitInc(AValue, AType, 1, AAmountType);
end;

function ConvUnitInc(const AValue: Double; const AType: TConvType;
  const AAmount: Double; const AAmountType: TConvType): Double;
var
  LTypeInfo, LAmountTypeInfo: TConvTypeInfo;
begin
  if not GetConvInfo(AType, AAmountType, LTypeInfo, LAmountTypeInfo) then
    RaiseConversionError(SConvIncompatibleTypes2,
      [ConvTypeToDescription(AType),
       ConvTypeToDescription(AAmountType)]);
  Result := AValue + LTypeInfo.FromCommon(LAmountTypeInfo.ToCommon(AAmount));
end;

function ConvUnitDec(const AValue: Double;
  const AType, AAmountType: TConvType): Double;
begin
  Result := ConvUnitInc(AValue, AType, -1, AAmountType);
end;