home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / unity / d56 / DW / DW10242.ZIP / NumWorks.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-08-08  |  6.2 KB  |  242 lines
  1. (*-------------------------------NumWorks.pas--------------------------
  2.  V1.0.240 - 09.08.2002 - current release
  3. *)
  4.  
  5. unit NumWorks;
  6.  
  7. interface
  8.  
  9. uses Windows, SysUtils, StringWorks;
  10.  
  11. (*1.0.239*)
  12. function DecToRoman(iDecimal: LongInt): String;
  13. function Expon(const Value, Exponent: Integer): Integer;
  14. function FreeNotationToFreeNotation(const Value, SrcNotationConfig, DstNotationConfig: String): String;
  15. function FreeNotationToInt(const Value, NotationConfig: String): Integer;
  16. function IntToFreeNotation(const Value: Integer; const NotationConfig: String): String;
  17. function ValidateValueForFreeNotation(const Value, NotationConfig: String): Boolean;
  18.  
  19. (*1.0.238*)
  20. function SimpleChecksum(const Str: String): Integer;
  21.  
  22. (*1.0.237*)
  23. function Diff(const Value1, Value2: Integer): Integer;
  24.  
  25. function RoundUp(X: Real): Integer;
  26. function RoundDown(X: Real): Integer;
  27. function RndBetween(const RangeMinor, RangeMajor: Integer): Integer;
  28. function HexToInt(HexStr: String): Integer;
  29. function ExtractBits(const Value, Start, Count: Integer): Integer;
  30. function CountBits(const Value: Integer): Integer;
  31. function BitIsSet(w : DWord; Bitnr:integer):Boolean;
  32. procedure SetBit(var w : DWord; Bitnr:integer);
  33. procedure ResetBit(var w : DWord; Bitnr:integer);
  34.  
  35. const
  36.    DW_NOTATION_BIN: String = '01';
  37.    DW_NOTATION_DEC: String = '0123456789';
  38.    DW_NOTATION_HEX: String = '0123456789ABCDEF';
  39.  
  40. implementation
  41.  
  42. function DecToRoman(iDecimal: LongInt): String;
  43. const
  44.   aRomans: array [ 1..13 ] of String = ( 'I', 'IV', 'V',
  45.    'IX', 'X', 'XL','L', 'XC', 'C', 'CD', 'D', 'CM', 'M' );
  46.   aArabics: array [ 1..13 ] of Integer = ( 1, 4, 5,
  47.    9, 10, 40, 50, 90, 100, 400, 500, 900, 1000 );
  48. var
  49.    I: Integer;
  50. begin
  51.    for I := 13 downto 1 do begin
  52.       while (iDecimal >= aArabics[I]) do begin
  53.          iDecimal := iDecimal - aArabics[I];
  54.          result := result + aRomans[I];
  55.       end;
  56.    end;
  57. end;
  58.  
  59. function Expon(const Value, Exponent: Integer): Integer;
  60. var i: Integer;
  61.     wert: Integer;
  62. begin
  63.   wert:=Value;
  64.   if Exponent=0 then
  65.     begin
  66.     result:=1;
  67.     exit;
  68.     end
  69.   else
  70.     begin
  71.     for i:=1 to Exponent-1 do
  72.       begin
  73.       wert:=wert*Value;
  74.       end; {for}
  75.     result:=wert;
  76.     end;
  77. end;
  78.  
  79. function FreeNotationToFreeNotation(const Value, SrcNotationConfig, DstNotationConfig: String): String;
  80. begin
  81.    result:= IntToFreeNotation(FreeNotationToInt(
  82.                                  Value,
  83.                                  SrcNotationConfig),
  84.                                  DstNotationConfig);
  85. end;
  86.  
  87. function FreeNotationToInt(const Value, NotationConfig: String): Integer;
  88. var
  89.    iBase, iPot, iVal, iValue, I: Integer;
  90.    sValue: String;
  91. begin
  92.    iValue:= 0;
  93.    sValue:= ReverseStr(Value);
  94.    iBase:= Length(NotationConfig);
  95.    for I:= 0 to Length(sValue) - 1 do begin
  96.       iVal:= Pos(sValue[I+1], NotationConfig) - 1;
  97.       iPot:= Expon(iBase, I);
  98.       iValue:= iValue + (iVal*(iPot));
  99.    end;
  100.    result:= iValue;
  101. end;
  102.  
  103. function IntToFreeNotation(const Value: Integer; const NotationConfig: String): String;
  104. var
  105.    iBase, iDiv, iMod, iValue: Integer;
  106. begin
  107.    iDiv:= -1;
  108.    iValue:= Value;
  109.    iBase:= Length(NotationConfig);
  110.    while iDiv <> 0 do begin
  111.       iMod:= iValue mod iBase;
  112.       iDiv:= iValue div iBase;
  113.       result:= result + NotationConfig[iMod+1];
  114.       iValue:= iDiv;
  115.    end;
  116.    result:= ReverseStr(result);
  117. end;
  118.  
  119. function ValidateValueForFreeNotation(const Value, NotationConfig: String): Boolean;
  120. var
  121.    I: Integer;
  122. begin
  123.    result:= FALSE;
  124.    for I:= 1 to Length(Value) do begin
  125.       result:= (Pos(Value[I], NotationConfig) <> 0);
  126.       if not result then Break;
  127.    end;
  128. end;
  129.  
  130. function SimpleChecksum(const Str: String): Integer;
  131. var
  132.    I, Value: Integer;
  133.    Chk: Boolean;
  134. begin
  135.    Chk:= FALSE;
  136.    result:= 0;
  137.    Value:= 0;
  138.    if Length(Str) < 1 then exit;
  139.    for I:= 1 to Length(Str) do begin
  140.       if Chk then Value:= Value + (Ord(Str[I]) * 7) else
  141.                   Value:= Value + (Ord(Str[I]) * 3);
  142.       Chk:= not Chk;
  143.    end;
  144.    result:= Value;
  145. end;
  146.  
  147. function Diff(const Value1, Value2: Integer): Integer;
  148. begin
  149.    if (Value1 > Value2) then
  150.       result:= Value1 - Value2
  151.    else
  152.       result:= Value2 - Value1;
  153. end;
  154.  
  155. function RoundUp(X: Real): Integer;
  156. begin
  157.    if Trunc(X)<>X then begin
  158.       result:=Trunc(X)+1;
  159.       exit;
  160.    end else result:= Trunc(X);
  161. end;
  162.  
  163. function RoundDown(X: Real): Integer;
  164. begin
  165.    if Trunc(X)<>X then begin
  166.       result:=Trunc(X)-1;
  167.       exit;
  168.    end else result:= Trunc(X);
  169. end;
  170.  
  171. function RndBetween(const RangeMinor, RangeMajor: Integer): Integer;
  172. var
  173.    Rnd: Integer;
  174. begin
  175.    Rnd:= RangeMinor + Random(RangeMajor - RangeMinor);
  176.    result:= Rnd;
  177. end;
  178.  
  179. function HexToInt(HexStr: String): Integer;
  180. begin
  181.   result:= StrToInt('$' + HexStr);
  182. end;
  183.  
  184. function ExtractBits(const Value, Start, Count: Integer): Integer;
  185. const
  186.   {basiert auf Guido Gybels, http://www.optimalcode.com/Guido/basmex6.html}
  187.   Mask: array[0..31] of Int64 =
  188.             ($01,$03,$07,$0F,$1F,$3F,$7F,$FF,
  189.             $01FF,$03FF,$07FF,$0FFF,$1FFF,$3FFF,$7FFF,$FFFF,
  190.             $01FFFF,$03FFFF,$07FFFF,$0FFFFF,
  191.             $1FFFFF,$3FFFFF,$7FFFFF,$FFFFFF,
  192.             $01FFFFFF,$03FFFFFF,$07FFFFFF,$0FFFFFFF,
  193.             $1FFFFFFF,$3FFFFFFF,$7FFFFFFF,$FFFFFFFF);
  194. asm
  195.   xchg ecx,edx
  196.   test edx,edx
  197.   jnz @@isoke
  198.   xor eax,eax
  199.   jmp @@ending
  200.  @@isoke:
  201.   dec edx
  202.   and edx,31
  203.   shr eax,cl
  204.   and eax,dword ptr [Mask+edx*4]
  205.  @@ending:
  206. end;
  207.  
  208. function CountBits(const Value: Integer): Integer;
  209. asm
  210.   {basiert auf Guido Gybels, http://www.optimalcode.com/Guido/basmex6.html}
  211.   mov ecx,eax
  212.   xor eax,eax
  213.   test ecx,ecx
  214.   jz @@ending
  215.  @@counting:
  216.   shr ecx,1
  217.   adc eax,0
  218.   test ecx,ecx
  219.   jnz @@counting
  220.  @@ending:
  221. end;
  222.  
  223. function BitIsSet(w : DWord; Bitnr:integer):Boolean;
  224. begin
  225.    {basiert auf WernerSt, Spotlight Delphi Forum, 17.12.2001}
  226.    result:=(w and (1 shl Bitnr))<>0;
  227. end;
  228.  
  229. procedure SetBit(var w : DWord; Bitnr:integer);
  230. begin
  231.    {basiert auf WernerSt, Spotlight Delphi Forum, 17.12.2001}
  232.    w:=w or (1 shl Bitnr);
  233. end;
  234.  
  235. procedure ResetBit(var w : DWord; Bitnr:integer);
  236. begin
  237.    {basiert auf WernerSt, Spotlight Delphi Forum, 17.12.2001}
  238.    w:=w and ($FFFFFFFF xor (1 shl Bitnr));
  239. end;
  240.  
  241. end.
  242.