Chip 2001 September/Chip_2001-09_cd1.bin/zkuste/delphi/kolekce/d12345/MISC.ZIP/Misc.pas

Pascal/Delphi Source File | 2001-05-10 | 32KB | 1,117 lines

unit Misc;

{$I Misc.inc}

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at

http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License.


The Original Code is: PlotMisc.pas, released 1 July 2000.

The Initial Developer of the Original Code is Mat Ballard.
Portions created by Mat Ballard are Copyright (C) 1999 Mat Ballard.
Portions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.
All Rights Reserved.

Contributor(s): Mat Ballard                 e-mail: [e-mail].

Last Modified: 02/25/2001
Current Version: 2.00

You may retrieve the latest version of this file from:

        http://Chemware.hypermart.net/

This work was created with the Project JEDI VCL guidelines:

        http://www.delphi-jedi.org/Jedi:VCLVCL

in mind.


Purpose:
Collection of miscellaneous routines and type definitions, mostly poor clones
of those from the Math unit in the Pro versions.

Known Issues:
-----------------------------------------------------------------------------}

interface

uses
  Classes, SysUtils, TypInfo,
{$IFDEF NO_MATH}
  NoMath,
{$ELSE}
  Math,
{$ENDIF}
{$IFDEF WINDOWS}
  WinTypes, WinProcs,
  Controls, Dialogs, Forms, Graphics, ShellApi
{$ENDIF}
{$IFDEF WIN32}
  Windows,
  Clipbrd, Controls, Dialogs, Forms, Graphics, ShellApi
{$ENDIF}
{$IFDEF LINUX}
  Libc, Types, Qt,
  QControls, QDialogs, QForms, QGraphics
{$ENDIF}
  ;

type
  pSingle = ^Single;
  pDouble = ^Double;

{dynamic matrix definitions:}
{$IFDEF DELPHI1}
  TIntegerArray = array[0..MaxInt - 1] of Integer;
  TSingleArray = array[0..MaxInt div 2 - 1] of Single;
  TDoubleArray = array[0..MaxInt div 4 - 1] of Double;
{$ELSE}
  TIntegerArray = array[0..MaxInt div SizeOf(Integer) - 1] of Integer;
  TSingleArray = array[0..MaxInt div SizeOf(Single) -1] of Single;
  TDoubleArray = array[0..MaxInt div SizeOf(Double) - 1] of Double;
{$ENDIF}

{NOTE: Multidimensional dynamic arrays DON'T WORK !
  TIntegerMatrix = array[0..0] of array[0..0] of Integer;
  TSingleMatrix = array[0..0] of array[0..0] of Single;
  TDoubleMatrix = array[0..0] of array[0..0] of Double;}

{dynamic matrix definitions - pointers thereto:}
  pIntegerArray = ^TIntegerArray;
  pSingleArray = ^TSingleArray;
  pDoubleArray = ^TDoubleArray;
  {pIntegerMatrix = ^TIntegerMatrix;
  pSingleMatrix = ^TSingleMatrix;
  pDoubleMatrix = ^TDoubleMatrix;}

{$IFDEF LINUX}
{$ENDIF}

  TPercent = 0..100;

  TXYPoint = record
    X: Single;
    Y: Single;
  end;
  pXYPoint = ^TXYPoint;
{$IFDEF DELPHI1}
  TXYArray = array[0..MaxInt div 4 - 1] of TXYPoint;
{$ELSE}
  TXYArray = array[0..MaxInt div SizeOf(Double) - 1] of TXYPoint;
{$ENDIF}
  pXYArray = ^TXYArray;

  TIdentMapEntry = record
    Value: TColor;
    Name: String;
  end;

{$IFDEF LINUX}
  TRGBTriple = packed record
    rgbtBlue: Byte;
    rgbtGreen: Byte;
    rgbtRed: Byte;
  end;
{$ENDIF}
  TRGBArray    = array[0..20000] OF TRGBTriple;
  pRGBArray    = ^TRGBArray;

  TRainbowColor = record
    R: Integer;
    G: Integer;
    B: Integer;
  end;

  TFileList = class(TStringList)
    private
    protected
    public
      procedure AppendToFile(const FileName: string); virtual;
    published
  end;

  TMemoryStreamEx = class(TMemoryStream)
    private
    protected
    public
      procedure AppendToFile(const FileName: string); virtual;
  end;

  function GetLineLengthFromStream(AStream: TMemoryStream): Integer;
  function ReadLine(AStream: TMemoryStream): String;
  function FindStringInStream(TheString: String; AStream: TMemoryStream): Boolean;
  function CleanString(AString: String; TheChar: Char): String;
  function StrRev(TheStr: String): String;

  procedure DeSci(ExtNumber: Extended; var Mantissa: Extended; var Exponent: Integer);
{This method breaks a number down into its mantissa and exponent.
 Eg: 0.00579 has a mantissa of 5.79, and an exponent of -3.}

  function GetWord (var This_Line: String; Delimiter: String): String;
{The GetWord function returns all the characters up to Delimiter in This_Line,
 and removes all characters up to and including Delimiter from ThisLine.}
{}
{This is very useful for extracting comma or tab-seperated strings (numbers)
 from text data.}

  function IndexOfColorValue(Value: TColor): Integer;
  function IndexOfColorName(Name: String): Integer;
  function GetDarkerColor(Value: TColor; Brightness: Integer): TColor;
  function GetInverseColor(Value: TColor): TColor;
  function GetPalerColor(Value: TColor; Brightness: Integer): TColor;
  function Rainbow(Fraction: Single): TColor;
  function InputColor(var AColor: TColor): Boolean;
  function BinToInt(Value: String): {$IFDEF DELPHI1}Longint{$ELSE}{$IFDEF BCB}Longint{$ELSE}Longword{$ENDIF}{$ENDIF};
  function IntToBin(Value: {$IFDEF DELPHI1}Longint{$ELSE}{$IFDEF BCB}Longint{$ELSE}Longword{$ENDIF}{$ENDIF}): string;
  function IsInteger(Value: String): Boolean;
  function IsFixed(Value: String): Boolean;
  function IsReal(Value: String): Boolean;

  procedure SetDialogGeometry(AForm: TForm; AButton: TControl; BorderWidth: Integer);

{$IFDEF MSWINDOWS}
  procedure TextOutAnglePersist(
    ACanvas: TCanvas;
    Angle, Left, Top: Integer;
    TheText: String);
{$ENDIF}
  procedure TextOutAngle(
    ACanvas: TCanvas;
    Angle, Left, Top: Integer;
    TheText: String);
  procedure ShellExec(Cmd: String);
  {function FormOnHelp(
    HelpType: THelpType;
    HelpContext: Integer;
    HelpKeyword: string;
    HelpFile: string;
    var Handled: Boolean): Boolean;}

{$IFDEF DELPHI1}
  function GetCurrentDir: String;
{$ENDIF}

const
  TWO_PI = 6.28318530717958; {6476925286766559}
  CRLF = #13+#10;
  MY_COLORS_MAX = 15;
{The number of MyColors runs from 0..15.}

{MyColors is based on the Colors definition in Graphics.pas,
 restricted the the basic 16 colors, and in a different order
 more suitable for graphs.}
  MyColorValues: array[0..15] of TColor = (
    clBlack,
    clRed,
    clBlue,
    clGreen,
    clPurple,
    clFuchsia,
    clAqua,
    clMaroon,
    clOlive,
    clNavy,
    clTeal,
    clGray,
    clSilver,
    clLime,
    clYellow,
    clWhite);

  MAX_RAINBOW_COLORS = 5;
  RainbowColors: array[0..MAX_RAINBOW_COLORS, 0..2] of Integer =
    ({(0, 0, 0),          //black}
     (255, 0, 0),        {red}
     (255, 255, 0),      {yellow}
     (0, 255, 0),        {green}
     (0, 255, 255),      {aqua}
     (0, 0, 255),        {blue}
     (255, 0, 255));      {purple}
     {(255, 255, 255));   //white}
{Note: Black and white have been removed to avoid confusion with the background.}

implementation

{------------------------------------------------------------------------------
    Procedure: TFileList.AppendToFile
  Description: appends this stringlist to an existing file
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: saving data to disk
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TFileList.AppendToFile(const FileName: string);
var
  Stream: TStream;
begin
  if (FileExists(FileName)) then
  begin
    Stream := TFileStream.Create(FileName, fmOpenReadWrite);
    Stream.Seek(0, soFromEnd);
  end
  else
  begin
    Stream := TFileStream.Create(FileName, fmCreate);
  end;

  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;
{end TFileList ----------------------------------------------------------------}

{------------------------------------------------------------------------------
    Procedure: TMemoryStreamEx.AppendToFile
  Description: appends this MemoryStream to an existing file
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: saving data to disk
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TMemoryStreamEx.AppendToFile(const FileName: string);
var
  Stream: TStream;
begin
  if (FileExists(FileName)) then
  begin
    Stream := TFileStream.Create(FileName, fmOpenReadWrite);
    Stream.Seek(0, soFromEnd);
  end
  else
  begin
    Stream := TFileStream.Create(FileName, fmCreate);
  end;

  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

{end TMemoryStreamEx ----------------------------------------------------------------}

{------------------------------------------------------------------------------
     Function: GetLineLengthFromStream
  Description: gets the length of the line (of text) at AStream.Position
       Author: Mat Ballard
 Date created: 08/09/2000
Date modified: 08/09/2000 by Mat Ballard
      Purpose: Stream manipulation
 Return Value: the length of the line, up to CRLF
 Known Issues:
 ------------------------------------------------------------------------------}
function GetLineLengthFromStream(AStream: TMemoryStream): Integer;
var
  pCR,
  pLF: PChar;
  i: Longint;
begin
  pCR := AStream.Memory;
  Inc(pCR, AStream.Position);
{default is the entire stream:}
  GetLineLengthFromStream := AStream.Size - AStream.Position;
  for i := AStream.Position to AStream.Size-1 do
  begin
    if (pCR^ = #13) then
    begin
      pLF := pCR;
      Inc(pLF);
      if (pLF^ = #10) then
      begin
        GetLineLengthFromStream := i - AStream.Position;
        break;
      end;
    end;
    Inc(pCR);
  end;
end;

{------------------------------------------------------------------------------
     Function: ReadLine
  Description: gets line (of text) at AStream.Position
       Author: Mat Ballard
 Date created: 08/09/2000
Date modified: 04/28/2001 by Mat Ballard
      Purpose: Stream manipulation
 Return Value: the line as a string
 Known Issues: does not work against TBlobStream
 ------------------------------------------------------------------------------}
function ReadLine(AStream: TMemoryStream): String;
var
  LineLength: Integer;
  pLine: array [0..1023] of char;
begin
  LineLength := GetLineLengthFromStream(AStream);
{get the line of text:}
{$IFDEF DELPHI1}
  AStream.Read(pLine, LineLength);
  Result := StrPas(pLine);
{$ELSE}
  SetString(Result, PChar(nil), LineLength);
  AStream.Read(Pointer(Result)^, LineLength);
{$ENDIF}
{get the CRLF:}
  AStream.Read(pLine, 2);
end;

{------------------------------------------------------------------------------
     Function: FindStringInStream
  Description: Finds the first occurrence of TheString in AStream from
               AStream.Position onwards
       Author: Mat Ballard
 Date created: 08/09/2000
Date modified: 08/09/2000 by Mat Ballard
      Purpose:
 Return Value: TRUE if successful, FALSE otherwise
 Known Issues:
 ------------------------------------------------------------------------------}
function FindStringInStream(TheString: String; AStream: TMemoryStream): Boolean;
var
  pStart,
  pTheChar: PChar;
  i,
  j: Longint;
  FoundIt: Boolean;
begin
  pStart := AStream.Memory;
  Inc(pStart, AStream.Position);
{default is the entire stream:}
  FindStringInStream := FALSE;
  for i := AStream.Position to AStream.Size-1 do
  begin
    pTheChar := pStart;
    FoundIt := TRUE;
    for j := 1 to Length(TheString) do
    begin
      if (pTheChar^ <> TheString[j]) then
      begin
        FoundIt := FALSE;
        break;
      end;
      Inc(pTheChar);
    end;

    if (FoundIt) then
    begin
      AStream.Position := i;
      FindStringInStream := TRUE;
      break;
    end;

    Inc(pStart);
  end;
end;

{------------------------------------------------------------------------------
     Function: CleanString
  Description: removes offending characters from a string
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: menu manipulation
 Return Value: the cleaned string
 Known Issues:
 ------------------------------------------------------------------------------}
function CleanString(AString: String; TheChar: Char): String;
var
  i: Integer;
  NewString: String;
begin
  NewString := '';
  for i := 1 to Length(AString) do
  begin
    if (AString[i] <> TheChar) then
    begin
      NewString := NewString + AString[i];
    end;
  end;
  CleanString := NewString;
end;

{------------------------------------------------------------------------------
     Function: StrRev
  Description: reverses a string
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: string manipulation
 Return Value: the reverse of a string
 Known Issues:
 ------------------------------------------------------------------------------}
function StrRev(TheStr: String): String;
var
  i,
  l: Integer;
  RevStr: String;
begin
  l := Length(TheStr);
{$IFDEF DELPHI1}
  RevStr := TheStr;
{$ELSE}
  SetLength(RevStr, l);
{$ENDIF}

  for i := 1 to l do
  begin
    RevStr[i] := TheStr[l-i+1];
  end;
  StrRev := RevStr;
end;

{------------------------------------------------------------------------------
    Procedure: DeSci
  Description: breaks a number up into its Mantissa and Exponent
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: Tick and Label scaling
 Known Issues: Why not use Math.Frexp() - because that works on POWERS OF TWO !
 ------------------------------------------------------------------------------}
procedure DeSci(ExtNumber: Extended; var Mantissa: Extended; var Exponent: Integer);
var
  TheLog: Extended;
  TheSign: Extended;
begin
  TheSign := 1;

  if (ExtNumber = 0) then
  begin
    Mantissa := 0;
    Exponent := 0;
    exit;
  end;

  if (ExtNumber < 0) then
  begin
    TheSign := -1;
    ExtNumber := -ExtNumber;
  end;

  TheLog := Log10(ExtNumber);
  Exponent := Floor(TheLog);
  Mantissa := TheLog - Exponent;
  Mantissa := Power(10.0, Mantissa);
  if (TheSign < 0) then Mantissa := -Mantissa;
end;

{------------------------------------------------------------------------------
     Function: GetWord
  Description: splits a phrase into two at the delimiter
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: string manipulation
 Return Value: the left side
 Known Issues:
 ------------------------------------------------------------------------------}
Function GetWord (var This_Line: String; Delimiter: String): String;
var
  Delimiter_Position: Integer;
begin
  Delimiter_Position := Pos(Delimiter, This_Line);
  If (Delimiter_Position > 0) Then
  begin
    GetWord := Copy(This_Line, 1, Delimiter_Position-1);
    This_Line := Copy(This_Line, Delimiter_Position + Length(Delimiter), Length(This_Line));
  end
  Else
  begin
    GetWord := This_Line;
    This_Line := '';
  end;
end;

{------------------------------------------------------------------------------
     Function: IndexOfColorValue
  Description: gets the index of a color
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: color manipulation
 Return Value: Index of a color
 Known Issues:
 ------------------------------------------------------------------------------}
function IndexOfColorValue(Value: TColor): Integer;
var
  i: Integer;
begin
  IndexOfColorValue := -1;
  for i := 0 to MY_COLORS_MAX do
  begin
    if (MyColorValues[i] = Value) then
    begin
      IndexOfColorValue := i;
      break;
    end;
  end;
end;

{------------------------------------------------------------------------------
     Function: IndexOfColorName
  Description: gets the name of a color
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: color manipulation
 Return Value: string containing the color name
 Known Issues:
 ------------------------------------------------------------------------------}
function IndexOfColorName(Name: String): Integer;
var
  i: Integer;
begin
  IndexOfColorName := -1;
  for i := 0 to MY_COLORS_MAX do
  begin
    if (ColorToString(MyColorValues[i]) = Name) then
    begin
      IndexOfColorName := i;
      break;
    end;
  end;
end;

{------------------------------------------------------------------------------
     Function: GetPalerColor
  Description: gets a paler shade of the input color
       Author: Mat Ballard
 Date created: 09/25/2000
Date modified: 09/25/2000 by Mat Ballard
      Purpose: color manipulation
 Return Value: TColor
 Known Issues:
 ------------------------------------------------------------------------------}
function GetPalerColor(Value: TColor; Brightness: Integer): TColor;
var
  iColor,
  iRed,
  iBlue,
  iGreen: Longint;
begin
  iColor := ColorToRGB(Value);

  iRed := (iColor and $000000FF);
  iRed := iRed + Brightness * ($FF-iRed) div 100;

  iGreen := (iColor and $0000FF00) shr 8;
  iGreen := iGreen + Brightness * ($FF-iGreen) div 100;

  iBlue := (iColor and $00FF0000) shr 16;
  iBlue := iBlue + Brightness * ($FF-iBlue) div 100;

  GetPalerColor := TColor(iRed  or (iGreen shl 8) or (iBlue shl 16));
end;

{------------------------------------------------------------------------------
     Function: GetDarkerColor
  Description: gets a darker shade of the input color
       Author: Mat Ballard
 Date created: 09/25/2000
Date modified: 09/25/2000 by Mat Ballard
      Purpose: color manipulation
 Return Value: TColor
 Known Issues:
 ------------------------------------------------------------------------------}
function GetDarkerColor(Value: TColor; Brightness: Integer): TColor;
var
  iColor,
  iRed,
  iBlue,
  iGreen: Longint;
begin
  iColor := ColorToRGB(Value);

  iRed := (iColor and $000000FF);
  iRed := iRed * Brightness div 100;

  iGreen := (iColor and $0000FF00) shr 8;
  iGreen := iGreen * Brightness div 100;

  iBlue := (iColor and $00FF0000) shr 16;
  iBlue := iBlue * Brightness div 100;

  GetDarkerColor := TColor(iRed  or (iGreen shl 8) or (iBlue shl 16));
end;

{------------------------------------------------------------------------------
     Function: GetInverseColor
  Description: gets the inverse of the input color
       Author: Mat Ballard
 Date created: 09/25/2000
Date modified: 09/25/2000 by Mat Ballard
      Purpose: color manipulation
 Return Value: TColor
 Known Issues: does not return an inverse if Value is close to grey, because the
               inverse of gray is gray !
 ------------------------------------------------------------------------------}
function GetInverseColor(Value: TColor): TColor;
var
  iColor,
  iRed,
  iBlue,
  iGreen,
  Difference: Longint;
begin
  iColor := ColorToRGB(Value);

  iRed := (iColor and $000000FF);
  iRed := 255 - iRed;

  iGreen := (iColor and $0000FF00) shr 8;
  iGreen := 255 - iGreen;

  iBlue := (iColor and $00FF0000) shr 16;
  iBlue := 255 - iBlue;

  Difference := Abs(255 - (2*iRed + 2*iGreen + 2*iBlue) div 3);

  if (Difference > 26) then
    GetInverseColor := TColor(iRed  or (iGreen shl 8) or (iBlue shl 16))
   else
    GetInverseColor := clBlack;
end;

{------------------------------------------------------------------------------
     Function: Rainbow
  Description: returns a rainbow color, depending on the Fraction
       Author: Mat Ballard
 Date created: 02/15/2001
Date modified: 02/15/2001 by Mat Ballard
      Purpose: color manipulation for contour graphs
 Return Value: TColor
 Known Issues:
 ------------------------------------------------------------------------------}
function Rainbow(Fraction: Single): TColor;
var
  i,
  LowIndex,
  HighIndex: Integer;
  RainbowColor: array [0..2] of Integer;
  HighFraction,
  LowFraction,
  CellWidth: Single;
begin
  CellWidth := 1 / MAX_RAINBOW_COLORS;
  LowIndex := Trunc(Fraction / CellWidth);
  HighIndex := LowIndex + 1;
  HighFraction := (Fraction - LowIndex * CellWidth) / CellWidth;
  LowFraction := 1.0 - HighFraction;

  if (LowIndex = MAX_RAINBOW_COLORS) then
  begin
    for i := 0 to 2 do
      RainbowColor[i] := 255;
  end
  else
  begin
    for i := 0 to 2 do
    RainbowColor[i] := Round(
      LowFraction * RainbowColors[LowIndex, i] +
      HighFraction * RainbowColors[HighIndex, i]);
  end;
  Result := TColor(
    RainbowColor[0] +
    RainbowColor[1] shl 8 +
    RainbowColor[2] shl 16);
end;

{------------------------------------------------------------------------------
     Function: InputColor
  Description: prompts the user for a color
       Author: Mat Ballard
 Date created: 01/15/2001
Date modified: 01/15/2001 by Mat Ballard
      Purpose: color management
 Return Value: Boolean
 Known Issues:
 ------------------------------------------------------------------------------}
function InputColor(var AColor: TColor): Boolean;
var
  ColorDialog: TColorDialog;
begin
  InputColor := FALSE;
  ColorDialog := TColorDialog.Create(nil);
{$IFDEF MSWINDOWS}
  ColorDialog.Options := [cdFullOpen];
{$ENDIF}
  ColorDialog.Color := AColor;
  ColorDialog.CustomColors.Add('Current=' + IntToHex(ColorToRGB(AColor), 6));

  if (ColorDialog.Execute) then
  begin
    AColor := ColorDialog.Color;
    InputColor := TRUE;
  end;
  ColorDialog.Free;
end;

{------------------------------------------------------------------------------
    Procedure: SetDialogGeometry
  Description: sets the dialog Geometry under Windows and Linux
      Authors: Mat Ballard
 Date created: 04/03/2001
Date modified: 04/03/2001 by Mat Ballard
      Purpose: Dialog Geometry control
 Known Issues: an alternative approach is:

  Scaled := FALSE;
  AutoScroll := FALSE;
// DESIGNSCREENWIDTHPIX is a constant depending on the width at design time, eg: 1024
  ScaleBy(Screen.Width, DESIGNSCREENWIDTHPIX);
 ------------------------------------------------------------------------------}
procedure SetDialogGeometry(AForm: TForm; AButton: TControl; BorderWidth: Integer);
begin
{$IFDEF MSWINDOWS}
  {AForm.PixelsPerInch := 96;}
  AForm.BorderStyle := bsDialog;
{$ENDIF}
{$IFDEF LINUX}
  {AForm.PixelsPerInch := 75;}
  AForm.BorderStyle := fbsDialog;
{$ENDIF}
  AForm.Scaled := FALSE;
  AForm.HorzScrollBar.Visible := FALSE;
  AForm.VertScrollBar.Visible := FALSE;

  AForm.Left := 10;
  AForm.Top := 10;
  AForm.ClientHeight := AButton.Top + 3 * AButton.Height div 2;
  AForm.ClientWidth := AButton.Left + AButton.Width + BorderWidth;
end;


{------------------------------------------------------------------------------}
function BinToInt(Value: String): {$IFDEF DELPHI1}Longint{$ELSE}{$IFDEF BCB}Longint{$ELSE}Longword{$ENDIF}{$ENDIF};
var
  i: Integer;
  Pow2,
  TheResult: {$IFDEF DELPHI1}Longint{$ELSE}{$IFDEF BCB}Longint{$ELSE}Longword{$ENDIF}{$ENDIF};
begin
  Pow2 := 1;
  TheResult := 0;
  for i := 1 to Length(Value) do
  begin
    if (Value[i] = '1') then
      TheResult := TheResult + Pow2;
    Pow2 := Pow2 shl 1;
  end;
  BinToInt := TheResult;
end;

function IntToBin(Value: {$IFDEF DELPHI1}Longint{$ELSE}{$IFDEF BCB}Longint{$ELSE}Longword{$ENDIF}{$ENDIF}): string;
var
  i: Integer;
  StrResult: String;

{$IFDEF DELPHI1}
  function LTrim(Const Str: String): String;
  var
    len: Byte absolute Str;
    i: Integer;
  begin
    i := 1;
    while (i <= len) and (Str[i] = ' ') do Inc(i);
    LTrim := Copy(Str,i,len)
  end ;
{$ENDIF}

begin
  i := 1;
{$IFDEF DELPHI1}
  StrResult := '                                ';
{$ELSE}
  SetLength(StrResult, 32);
{$ENDIF}
  repeat
    if ((Value and 1) > 0) then
      StrResult[i] := '1'
     else
      StrResult[i] := '0';
    Value := Value shr 1;
    Inc(i);
  until (Value = 0);
{$IFDEF DELPHI1}
  StrResult := LTrim(StrResult);
{$ELSE}
  SetLength(StrResult, i-1);
{$ENDIF}
  StrResult := StrRev(StrResult);

  IntToBin := StrResult;
end;

function IsInteger(Value: String): Boolean;
var
  i: Integer;
  TheStart: Integer;
begin
  Result := FALSE;
  TheStart := 1;
  if (Value[1] = '-') then
    TheStart := 2;

  for i := TheStart to Length(Value) do
  begin
    if ((Value[i] < '0') or
        (Value[i] > '9')) then
      exit;
  end;
  Result := TRUE;
end;

function IsFixed(Value: String): Boolean;
var
  i: Integer;
  TheStart: Integer;
  DotCount: Integer;
begin
  Result := FALSE;
  TheStart := 1;
  DotCount := 0;

  if (Value[1] = '-') then
    TheStart := 2;

  for i := TheStart to Length(Value) do
  begin
    if ((Value[i] < '0') or
        (Value[i] > '9')) then
      if (Value[i] = '.') then
      begin
        Inc(DotCount);
        if (DotCount > 1) then
          exit;
      end
      else
      begin
        exit;
      end;
  end;
  Result := TRUE;
end;

function IsReal(Value: String): Boolean;
var
  i: Integer;
  TheStart: Integer;
  DotCount: Integer;
  ECount: Integer;
  NegCount: Integer;
begin
  Result := FALSE;

  if (Length(Value) = 0) then
    exit;

  TheStart := 1;
  DotCount := 0;
  ECount := 0;
  NegCount := 0;

  if (Value[1] = '-') then
    TheStart := 1;

  for i := TheStart to Length(Value) do
  begin
    if ((Value[i] < '0') or
        (Value[i] > '9')) then
      if (Value[i] = '.') then
      begin
        Inc(DotCount);
        if (DotCount > 1) then
          exit;
      end
      else if (Value[i] = '-') then
      begin
        Inc(NegCount);
        if (NegCount > 1) then
          exit;
        if (Value[i-1] <> 'E') then
          exit;
      end
      else if ((Value[i] = 'e') or (Value[i] = 'E')) then
      begin
        Inc(ECount);
        if (ECount > 1) then
          exit;
        if(i = Length(Value)) then
          exit;
        Value[i] := 'E';
      end
      else
      begin
        exit;
      end;
  end;
  Result := TRUE;
end;


{$IFDEF DELPHI1}
function GetCurrentDir: String;
var
  ThisDir: String;
begin
  GetDir(0, ThisDir);
end;
{$ENDIF}

{------------------------------------------------------------------------------
    Procedure: TextOutAngle
  Description: draws text on the input canvas, at an angle
      Authors: Borland Developer Support Staff (Creating a rotated font, FAQ615D.txt), modified by Mat Ballard
 Date created: 02/15/2001
Date modified: 02/15/2001 by Mat Ballard
      Purpose: Vertical and angular fonts
 Known Issues: ACanvas.Font remains rotated until re-assigned ?
 ------------------------------------------------------------------------------}
{$IFDEF MSWINDOWS}
procedure TextOutAnglePersist(
  ACanvas: TCanvas;
  Angle, Left, Top: Integer;
  TheText: String);
var
  lf: TLogFont;
  tf: TFont;
begin
  tf := TFont.Create;
  tf.Assign(ACanvas.Font);
  {Windows.}GetObject(tf.Handle, sizeof(lf), @lf);
  lf.lfEscapement := 10*Angle;;
  lf.lfOrientation := lf.lfEscapement;
  tf.Handle := {Windows.}CreateFontIndirect(lf);
  ACanvas.Font.Assign(tf);
  tf.Free;
  ACanvas.TextOut(Left, Top, TheText);
end;
{$ENDIF}

{------------------------------------------------------------------------------
    Procedure: TextOutAngle
  Description: draws angled text on the input canvas
      Authors: Mat Ballard
 Date created: 04/15/2000
Date modified: 04/15/2000 by Mat Ballard
      Purpose: Vertical fonts
 Known Issues: derived from the very early GPC work;
               ACanvas.Font does not remain rotated
               Note: Angle of rotation is Anti-Clockwise in Winxx,
               Clockwise in Qt/Linux
 ------------------------------------------------------------------------------}
procedure TextOutAngle(
  ACanvas: TCanvas;
  Angle, Left, Top: Integer;
  TheText: String);
{$IFDEF MSWINDOWS}
var
  LogRec: TLogFont;
  OldFontHandle, NewFontHandle: hFont;
{$ENDIF}
{$IFDEF LINUX}
{$ENDIF}

begin
{$IFDEF MSWINDOWS}
{Gotta use Windows GDI functions to rotate the font:}
  {Windows.}GetObject(ACanvas.Font.Handle, SizeOf(LogRec), Addr(LogRec));
  LogRec.lfEscapement := 10*Angle;
  LogRec.lfOrientation := LogRec.lfEscapement;
  NewFontHandle := {Windows.}CreateFontIndirect(LogRec);
{select the new font:}
  OldFontHandle := {Windows.}SelectObject(ACanvas.Handle, NewFontHandle);
{Print the text:}
  ACanvas.TextOut(Left, Top, TheText);
{go back to original font:}
  NewFontHandle := {Windows.}SelectObject(ACanvas.Handle, OldFontHandle);
{and delete the old one:}
  {Windows.}DeleteObject(NewFontHandle);
{$ENDIF}

{$IFDEF LINUX}
{this code is courtesy of Jon Shemitz <[e-mail]>}
{Outside of a Paint handler, bracket QPainter_ calls with a Start/Stop}
  ACanvas.Start;
  try
    Qt.QPainter_save(ACanvas.Handle);
{Move 0,0 to the center of the form}
    Qt.QPainter_translate(ACanvas.Handle, Left, Top);
{Rotate; note negative angle:}
    QPainter_rotate(ACanvas.Handle, -Angle);
    ACanvas.TextOut(0, 0, TheText);
  finally
    Qt.QPainter_restore(ACanvas.Handle);
    ACanvas.Stop;
  end;
{$ENDIF}
end;

{------------------------------------------------------------------------------
    Procedure: ShellExec
  Description: wrapper for the windows "ShellExecute" API call, extended to Linux
      Authors: Mat Ballard
 Date created: 04/15/2000
Date modified: 03/28/2001 by Mat Ballard
      Purpose: Execute an external program with arguments
 Known Issues: does not cope properly with spaces in arguments (eg: "My File.txt")
 ------------------------------------------------------------------------------}
procedure ShellExec(Cmd: String);
{$IFDEF WINDOWS} {Delphi 1}
var
  sObjectPath: array[0..1023] of Char;
{$ENDIF}
begin
{$IFDEF WINDOWS} {Delphi 1}
  StrPCopy(sObjectPath, Cmd);
  ShellExecute(0, Nil, sObjectPath, Nil, Nil, 3);  {?SW_SHOW ?}
{$ENDIF}
{$IFDEF WIN32}
  ShellExecute(0, Nil, PChar(Cmd), Nil, Nil, SW_NORMAL);
{$ENDIF}
{$IFDEF LINUX}
  Libc.system(PChar(Cmd));
{$ENDIF}
end;

{------------------------------------------------------------------------------
     Function: FormOnHelp
  Description: displays a topic from a HTML-based help website
       Author: Mat Ballard
 Date created: 05/10/2001
Date modified: 05/10/2001 by Mat Ballard
      Purpose: help management
 Return Value: Boolean
 Known Issues:
 ------------------------------------------------------------------------------}
{function FormOnHelp(
  HelpType: THelpType;
  HelpContext: Integer;
  HelpKeyword: string;
  HelpFile: string;
  var Handled: Boolean): Boolean;
var
  MyHTMLHelpTopicFile: String;
  HelpPath: String;
begin
  HelpPath := ExtractFilePath(HelpFile);
  MyHTMLHelpTopicFile := HelpPath + 'hs' + IntToStr(HelpContext) + '.htm';
  if FileExists(MyHTMLHelpTopicFile) then
  begin
    ShellExec('konqueror ' + MyHTMLHelpTopicFile);
    Handled := TRUE;
  end;
end;}

end.