convutils3.pas

Yahoo Messenger for Mobile

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

function ConvUnitWithinPrevious(const AValue, ATest: Double; const AType: TConvType;
  const AAmount: Double; const AAmountType: TConvType): Boolean;
begin
  Result := (ATest <= AValue) and
            (ATest >= ConvUnitDec(AValue, AType, AAmount, AAmountType));
end;

function ConvUnitWithinNext(const AValue, ATest: Double; const AType: TConvType;
  const AAmount: Double; const AAmountType: TConvType): Boolean;
begin
  Result := (ATest >= AValue) and
            (ATest <= ConvUnitInc(AValue, AType, AAmount, AAmountType));
end;

function ConvUnitCompareValue(const AValue1: Double; const AType1: TConvType;
  const AValue2: Double; const AType2: TConvType): TValueRelationship;
var
  LType1Info, LType2Info: TConvTypeInfo;
begin
  if not GetConvInfo(AType1, AType2, LType1Info, LType2Info) then
    RaiseConversionError(SConvIncompatibleTypes2,
      [ConvTypeToDescription(AType1),
       ConvTypeToDescription(AType2)]);
  Result := CompareValue(LType1Info.ToCommon(AValue1), LType2Info.ToCommon(AValue2));
end;

function ConvUnitSameValue(const AValue1: Double; const AType1: TConvType;
  const AValue2: Double; const AType2: TConvType): Boolean;
var
  LType1Info, LType2Info: TConvTypeInfo;
begin
  if not GetConvInfo(AType1, AType2, LType1Info, LType2Info) then
    RaiseConversionError(SConvIncompatibleTypes2,
      [ConvTypeToDescription(AType1),
       ConvTypeToDescription(AType2)]);
  Result := SameValue(LType1Info.ToCommon(AValue1), LType2Info.ToCommon(AValue2));
end;


function RegisterConversionType(AConvTypeInfo: TConvTypeInfo;
  out AType: TConvType): Boolean;
begin
  GConvTypeSync.BeginWrite;
  try
    Result := not DescriptionToConvType(AConvTypeInfo.ConvFamily,
                                        AConvTypeInfo.Description, AType);
    if Result then
    begin
      Inc(GLastConvType);
      if GLastConvType > Length(GConvTypeList) - 1 then
        SetLength(GConvTypeList, GLastConvType + CListGrowthDelta);
      AType := GLastConvType;
      AConvTypeInfo.FConvType := AType;
      GConvTypeList[AType] := AConvTypeInfo;
    end;
  finally
    GConvTypeSync.EndWrite;
  end;
end;

function RegisterConversionType(const AFamily: TConvFamily;
  const ADescription: string; const AFactor: Double): TConvType;
var
  LInfo: TConvTypeInfo;
begin
  LInfo := TConvTypeFactor.Create(AFamily, ADescription, AFactor);
  if not RegisterConversionType(LInfo, Result) then
  begin
    LInfo.Free;
    RaiseConversionRegError(AFamily, ADescription);
  end;
end;

function RegisterConversionType(const AFamily: TConvFamily;
  const ADescription: string; const AToCommonProc,
  AFromCommonProc: TConversionProc): TConvType;
var
  LInfo: TConvTypeInfo;
begin
  LInfo := TConvTypeProcs.Create(AFamily, ADescription,
                                 AToCommonProc, AFromCommonProc);
  if not RegisterConversionType(LInfo, Result) then
  begin
    LInfo.Free;
    RaiseConversionRegError(AFamily, ADescription);
  end;
end;

procedure FreeConversionType(const AType: TConvType);
var
  LConvTypeInfo: TConvTypeInfo;
begin
  if GetConvInfo(AType, LConvTypeInfo) then
  begin
    GConvTypeList[AType] := nil;
    LConvTypeInfo.Free;
  end;
end;

procedure UnregisterConversionType(const AType: TConvType);
begin
  GConvTypeSync.BeginWrite;
  try
    FreeConversionType(AType);
  finally
    GConvTypeSync.EndWrite;
  end;
end;

function RegisterConversionFamily(const ADescription: string): TConvFamily;
var
  LFamily: TConvFamily;
begin
  GConvFamilySync.BeginWrite;
  try
    if DescriptionToConvFamily(ADescription, LFamily) then
      RaiseConversionError(SConvDuplicateFamily, [ADescription]);

    Inc(GLastConvFamily);
    if GLastConvFamily > Length(GConvFamilyList) - 1 then
      SetLength(GConvFamilyList, GLastConvFamily + CListGrowthDelta);

    Result := GLastConvFamily;
    GConvFamilyList[Result] := TConvFamilyInfo.Create(Result, ADescription);
  finally
    GConvFamilySync.EndWrite;
  end;
end;

procedure UnregisterConversionFamily(const AFamily: TConvFamily);
var
  I: Integer;
  LConvFamilyInfo: TConvFamilyInfo;
begin
  GConvFamilySync.BeginWrite;
  try
    if GetConvFamilyInfo(AFamily, LConvFamilyInfo) then
    begin
      GConvTypeSync.BeginWrite;
      try
        for I := 0 to Length(GConvTypeList) - 1 do
          if Assigned(GConvTypeList[I]) and
             (GConvTypeList[I].FConvFamily = AFamily) then
            FreeConversionType(I);
      finally
        GConvTypeSync.EndWrite;
      end;
      GConvFamilyList[AFamily] := nil;
      LConvFamilyInfo.Free;
    end;
  finally
    GConvFamilySync.EndWrite;
  end;
end;

procedure CleanUpLists;
var
  I: Integer;
  LConvFamilyInfo: TConvFamilyInfo;
  LConvTypeInfo: TConvTypeInfo;
begin
  GConvTypeSync.BeginWrite;
  try
    for I := 0 to Length(GConvTypeList) - 1 do
    begin
      LConvTypeInfo := GConvTypeList[I];
      if Assigned(LConvTypeInfo) then
      begin
        GConvTypeList[I] := nil;
        LConvTypeInfo.Free;
      end;
    end;
    SetLength(GConvTypeList, 0);
  finally
    GConvTypeSync.EndWrite;
  end;

  GConvFamilySync.BeginWrite;
  try
    for I := 0 to Length(GConvFamilyList) - 1 do
    begin
      LConvFamilyInfo := GConvFamilyList[I];
      if Assigned(LConvFamilyInfo) then
      begin
        GConvFamilyList[I] := nil;
        LConvFamilyInfo.Free;
      end;
    end;
    SetLength(GConvFamilyList, 0);
  finally
    GConvFamilySync.EndWrite;
  end;
end;

{ TConvFamilyInfo }

constructor TConvFamilyInfo.Create(const AConvFamily: TConvFamily; const ADescription: string);
begin
  inherited Create;
  FConvFamily := AConvFamily;
  FDescription := ADescription;
end;

{ TConvTypeInfo }

constructor TConvTypeInfo.Create(const AConvFamily: TConvFamily;
  const ADescription: string);
var
  LConvFamilyInfo: TConvFamilyInfo;
begin
  inherited Create;
  if not GetConvFamilyInfo(AConvFamily, LConvFamilyInfo) then
    RaiseConversionError(SConvUnknownFamily,
                         [Format(SConvUnknownDescription, [AConvFamily])]);

  FConvFamily := AConvFamily;
  FDescription := ADescription;
end;

{ TConvTypeFactor }

constructor TConvTypeFactor.Create(const AConvFamily: TConvFamily;
  const ADescription: string; const AFactor: Double);
begin
  inherited Create(AConvFamily, ADescription);
  if AFactor = 0 then
    raise EZeroDivide.CreateFmt(SConvFactorZero, [ADescription]);
  FFactor := AFactor;
end;

function TConvTypeFactor.FromCommon(const AValue: Double): Double;
begin
  Result := AValue / FFactor;
end;

function TConvTypeFactor.ToCommon(const AValue: Double): Double;
begin
  Result := AValue * FFactor;
end;

{ TConvTypeProcs }

constructor TConvTypeProcs.Create(const AConvFamily: TConvFamily;
  const ADescription: string; const AToCommonProc,
  AFromCommonProc: TConversionProc);
begin
  inherited Create(AConvFamily, ADescription);
  FToCommonProc := AToCommonProc;
  FFromCommonProc := AFromCommonProc;
end;

function TConvTypeProcs.FromCommon(const AValue: Double): Double;
begin
  Result := FFromCommonProc(AValue);
end;

function TConvTypeProcs.ToCommon(const AValue: Double): Double;
begin
  Result := FToCommonProc(AValue);
end;

// Conversion support
function StrToConvUnit(AText: string; out AType: TConvType): Double;
begin
  if not TryStrToConvUnit(AText, Result, AType) then
    RaiseConversionError(SConvStrParseError, [AText]);
end;

function TryStrToConvUnit(AText: string; out AValue: Double; out AType: TConvType): Boolean;
var
  LSpaceAt: Integer;
  LType: string;
  LValue: Extended;
begin
  AText := TrimLeft(AText);
  LSpaceAt := Pos(' ', AText);
  if LSpaceAt > 0 then
  begin
   Try
    Lvalue:=StrToFloat(AText);
      LType := Trim(Copy(AText, LSpaceAt + 1, MaxInt));
      Result := (LType <> '') and DescriptionToConvType(LType, AType);
    Except
   End;
  end
  else
  begin
  Try
    AType := CIllegalConvType;
    LValue:=StrToFloat(AText);
   Except
  End;
  end;
  if Result then
    AValue := LValue;
end;

function ConvUnitToStr(const AValue: Double; const AType: TConvType): string;
begin
  Result := Format(GConvUnitToStrFmt, [AValue, ConvTypeToDescription(AType)]);
end;

// Discovery support functions
procedure GetConvTypes(const AFamily: TConvFamily; out ATypes: TConvTypeArray);
var
  I, LCount: Integer;
begin
  GConvTypeSync.BeginRead;
  try
    LCount := 0;
    for I := 0 to Length(GConvTypeList) - 1 do
      if Assigned(GConvTypeList[I]) and
         (GConvTypeList[I].ConvFamily = AFamily) then
        Inc(LCount);
    SetLength(ATypes, LCount);
    LCount := 0;
    for I := 0 to Length(GConvTypeList) - 1 do
      if Assigned(GConvTypeList[I]) and
         (GConvTypeList[I].ConvFamily = AFamily) then
      begin
        ATypes[LCount] := GConvTypeList[I].ConvType;
        Inc(LCount);
      end;
  finally
    GConvTypeSync.EndRead;
  end;
end;

procedure GetConvFamilies(out AFamilies: TConvFamilyArray);
var
  I, LCount: Integer;
begin
  GConvFamilySync.BeginRead;
  try
    LCount := 0;
    for I := 0 to Length(GConvFamilyList) - 1 do
      if Assigned(GConvFamilyList[I]) then
        Inc(LCount);
    SetLength(AFamilies, LCount);
    LCount := 0;
    for I := 0 to Length(GConvFamilyList) - 1 do
      if Assigned(GConvFamilyList[I]) then
      begin
        AFamilies[LCount] := GConvFamilyList[I].ConvFamily;
        Inc(LCount);
      end;
  finally
    GConvFamilySync.EndRead;
  end;
end;

function ConvTypeToDescription(const AType: TConvType): string;
var
  LConvTypeInfo: TConvTypeInfo;
begin
  if AType = CIllegalConvType then
    Result := SConvIllegalType
  else if GetConvInfo(AType, LConvTypeInfo) then
    Result := LConvTypeInfo.Description
  else
    Result := Format(SConvUnknownDescription, [AType]);
end;

function ConvFamilyToDescription(const AFamily: TConvFamily): string;
var
  LConvFamilyInfo: TConvFamilyInfo;
begin
  if AFamily = CIllegalConvFamily then
    Result := SConvIllegalFamily
  else if GetConvFamilyInfo(AFamily, LConvFamilyInfo) then
    Result := LConvFamilyInfo.Description
  else
    Result := Format(SConvUnknownDescription, [AFamily]);
end;

function DescriptionToConvType(const ADescription: string;
  out AType: TConvType): Boolean;
var
  I: Integer;
begin
  Result := False;
  GConvTypeSync.BeginRead;
  try
    for I := 0 to Length(GConvTypeList) - 1 do
      if Assigned(GConvTypeList[I]) and
         AnsiSameText(ADescription, GConvTypeList[I].Description) then
      begin
        // if duplicate is found
        if Result then
        begin
          Result := False;
          Exit;
        end;
        AType := I;
        Result := True;
      end;
  finally
    GConvTypeSync.EndRead;
  end;
end;

function DescriptionToConvType(const AFamily: TConvFamily;
  const ADescription: string; out AType: TConvType): Boolean;
var
  I: Integer;
begin
  Result := False;
  GConvTypeSync.BeginRead;
  try
    for I := 0 to Length(GConvTypeList) - 1 do
      if Assigned(GConvTypeList[I]) and
         (GConvTypeList[I].ConvFamily = AFamily) and
         AnsiSameText(ADescription, GConvTypeList[I].Description) then
      begin
        AType := I;
        Result := True;
        Break;
      end;
  finally
    GConvTypeSync.EndRead;
  end;
end;

function DescriptionToConvFamily(const ADescription: string;
  out AFamily: TConvFamily): Boolean;
var
  I: Integer;
begin
  Result := False;
  GConvFamilySync.BeginRead;
  try
    for I := 0 to Length(GConvFamilyList) - 1 do
      if Assigned(GConvFamilyList[I]) and
         AnsiSameText(ADescription, GConvFamilyList[I].Description) then
      begin
        AFamily := I;
        Result := True;
        Break;
      end;
  finally
    GConvFamilySync.EndRead;
  end;
end;

initialization
  GConvFamilySync := TMultiReadExclusiveWriteSynchronizer.Create;
  GConvTypeSync := TMultiReadExclusiveWriteSynchronizer.Create;
finalization
  CleanUpLists;
  FreeAndNil(GConvFamilySync);
  FreeAndNil(GConvTypeSync);
end.