Math
  1. Huge Numbers
  2. formatting '1010' to '001010' ???
  3. 32 bit CRC
  4. Raising a number to a power
  5. Number to String
  6. Math formula evaluator
  7. Set and Clear BITS[NEW]
  8. Complex Library[NEW]

Huge Numbers

By: Abe Timmerman; Alkmaar, The Netherlands

Send improvements to: A.Timmerman@beta.hsholland.nl

This unit uses an array of bytes to represent a LARGE number. The number is binairy-stored in the array, with the Least Significant Byte (LSB) first and the Most Significant Byte (MSB) last, like all Intel-integer types.

Arithmetic is not 10-based or 2-based, but 256-based, so that each byte represents one (1) digit.

The HugeInttype numbers are Signed Numbers.

When Compiled with the R+ directive, ADD and MUL wil generate an "Arithmetic Overflow Error" (RunError(215)) when needed. Otherwise use the "HugeIntCarry" variable.

Use the "HugeIntDiv0" variable to check on division by zero.

Use {$DEFINE HugeInt_xx } or "Conditional defines" from the "Compiler options" for sizing, where xx is 64, 32 or 16, otherwhise HugeIntSize will be set to 8 bytes.

unit HugeInts;
interface

const
{$IFDEF HugeInt_64 }
  HugeIntSize = 64;

{$ELSE}{$IFDEF HugeInt_32 }
  HugeIntSize = 32;
{$ELSE}{$IFDEF HugeInt_16 }
  HugeIntSize = 16;
{$ELSE}
  HugeIntSize = 8;
{$ENDIF}{$ENDIF}{$ENDIF}
  HugeIntMSB  = HugeIntSize-1;

type
  HugeInt = array[0..HugeIntMSB] of Byte;

const
  HugeIntCarry: Boolean = False;
  HugeIntDiv0:  Boolean = False;


procedure HugeInt_Min(var a: HugeInt);                 { a := -a }
procedure HugeInt_Inc(var a: HugeInt);                 { a := a + 1 }
procedure HugeInt_Dec(var a: HugeInt);                 { a := a - 1 }

procedure HugeInt_Add(a, b: HugeInt; var R: HugeInt);  { R := a + b }
procedure HugeInt_Sub(a, b: HugeInt; var R: HugeInt);  { R := a - b }
procedure HugeInt_Mul(a, b: HugeInt; var R: HugeInt);  { R := a * b }
procedure HugeInt_Div(a, b: HugeInt; var R: HugeInt);  { R := a div b }
procedure HugeInt_Mod(a, b: HugeInt; var R: HugeInt);  { R := a mod b }

function HugeInt_IsNeg(a: HugeInt): Boolean;
function HugeInt_Zero(a: HugeInt): Boolean;
function HugeInt_Odd(a: HugeInt): Boolean;

function HugeInt_Comp(a, b: HugeInt): Integer;          {-1:a< 0; 1:a>
}
procedure HugeInt_Copy(Src: HugeInt; var Dest: HugeInt);{ Dest := Src }

procedure String2HugeInt(AString: string; var a: HugeInt);
procedure Integer2HugeInt(AInteger: Integer; var a: HugeInt);
procedure HugeInt2String(a: HugeInt; var S: string);

                             implementation

procedure HugeInt_Copy(Src: HugeInt; var Dest: HugeInt);
{ Dest := Src }
begin
  Move(Src, Dest, SizeOf(HugeInt));

end;{ HugeInt_Copy }

function HugeInt_IsNeg(a: HugeInt): Boolean;
begin
  HugeInt_IsNeg := a[HugeIntMSB] and $80 > 0;
end;{ HugeInt_IsNeg }

function HugeInt_Zero(a: HugeInt): Boolean;
var i: Integer;
begin
  HugeInt_Zero := False;
  for i := 0 to HugeIntMSB do
    if a[i] <> 0 then Exit;
  HugeInt_Zero := True;
end;{ HugeInt_Zero }

function HugeInt_Odd(a: HugeInt): Boolean;
begin
  HugeInt_Odd := a[0] and 1 > 0;
end;{ HugeInt_Odd }

function HugeInt_HCD(a: HugeInt): Integer;

var i: Integer;
begin
  i := HugeIntMSB;
  while (i > 0) and (a[i] = 0) do Dec(i);
  HugeInt_HCD := i;
end;{ HugeInt_HCD }

procedure HugeInt_SHL(var a: HugeInt; Digits: Integer);
{ Shift "a" "Digits", digits (bytes) to the left,
  "Digits" bytes will 'fall off' on the MSB side
  Fill the LSB side with 0's }
var t: Integer;
b: HugeInt;
begin
  if Digits > HugeIntMSB then
    FillChar(a, SizeOf(HugeInt), 0)
  else if Digits > 0 then
    begin
      Move(a[0], a[Digits], HugeIntSize-Digits);

      FillChar(a[0], Digits, 0);
    end;{ else if }
end;{ HugeInt_SHL }

procedure HugeInt_SHR(var a: HugeInt; Digits: Integer);
var t: Integer;
begin
  if Digits > HugeIntMSB then
    FillChar(a, SizeOf(HugeInt), 0)
  else if Digits > 0 then
    begin
      Move(a[Digits], a[0], HugeIntSize-Digits);
      FillChar(a[HugeIntSize-Digits], Digits, 0);
    end;{ else if }
end;{ HugeInt_SHR }

procedure HugeInt_Inc(var a: HugeInt);
{ a := a + 1 }
var
  i: Integer;

  h: Word;
begin
  i := 0; h := 1;
  repeat
    h := h + a[i];
    a[i] := Lo(h);
    h := Hi(h);
    Inc(i);
  until (i > HugeIntMSB) or (h = 0);
  HugeIntCarry := h > 0;
  {$IFOPT R+ }
    if HugeIntCarry then RunError(215);
  {$ENDIF}
end;{ HugeInt_Inc }

procedure HugeInt_Dec(var a: HugeInt);
{ a := a - 1 }
var Minus_1: HugeInt;
begin
  { this is the easy way out }
  FillChar(Minus_1, SizeOf(HugeInt), $FF); { -1 }
  HugeInt_Add(a, Minus_1, a);
end;{ HugeInt_Dec }

procedure HugeInt_Min(var a: HugeInt);
{ a := -a }
var i: Integer;
begin
  for i := 0 to HugeIntMSB do
    a[i] := not a[i];
  HugeInt_Inc(a);
end;{ HugeInt_Min }

function HugeInt_Comp(a, b: HugeInt): Integer;
{ a = b: ==0; a > b: ==1; a < b: ==-1 }
var
  A_IsNeg, B_IsNeg: Boolean;
  i:                Integer;
begin
  A_IsNeg := HugeInt_IsNeg(a);
  B_IsNeg := HugeInt_IsNeg(b);
  if A_IsNeg xor B_IsNeg then
    if A_IsNeg then HugeInt_Comp := -1
    else HugeInt_Comp := 1

  else
    begin
      if A_IsNeg then HugeInt_Min(a);
      if B_IsNeg then HugeInt_Min(b);
      i := HugeIntMSB;
      while (i > 0) and (a[i] = b[i]) do Dec(i);
      if A_IsNeg then { both negative! }
        if a[i] > b[i] then HugeInt_Comp := -1
        else if a[i] < b[i] then HugeInt_Comp := 1
        else HugeInt_Comp := 0
      else { both positive }
        if a[i] > b[i] then HugeInt_Comp := 1
        else if a[i] < b[i] then HugeInt_Comp := -1
        else HugeInt_Comp := 0;

    end;{ else }
end;{ HugeInt_Comp }

procedure HugeInt_Add(a, b: HugeInt; var R: HugeInt);
{ R := a + b }
var
  i: Integer;
  h: Word;
begin
  h := 0;
  for i := 0 to HugeIntMSB do
    begin
      h := h + a[i] + b[i];
      R[i] := Lo(h);
      h := Hi(h);
    end;{ for }
  HugeIntCarry := h > 0;
  {$IFOPT R+ }
    if HugeIntCarry then RunError(215);
  {$ENDIF}
end;{ HugeInt_Add }

procedure HugeInt_Sub(a, b: HugeInt; var R: HugeInt);
{ R := a - b }

var
  i: Integer;
  h: Word;
begin
  HugeInt_Min(b);
  HugeInt_Add(a, b, R);
end;{ HugeInt_Sub }

procedure HugeInt_Mul(a, b: HugeInt; var R: HugeInt);
{ R := a * b }
var
  i, j, k:          Integer;
  A_end, B_end:     Integer;
  A_IsNeg, B_IsNeg: Boolean;
  h:                Word;
begin
  A_IsNeg := HugeInt_IsNeg(a);
  B_IsNeg := HugeInt_IsNeg(b);
  if A_IsNeg then HugeInt_Min(a);
  if B_IsNeg then HugeInt_Min(b);
  A_End := HugeInt_HCD(a);
  B_End := HugeInt_HCD(b);

  FillChar(R, SizeOf(R), 0);
  HugeIntCarry := False;
  for i := 0 to A_end do
    begin
      h := 0;
      for j:= 0 to B_end do
        if (i + j) < HugeIntSize then
          begin
            h := h + R[i+j] + a[i] * b[j];
            R[i+j] := Lo(h);
            h := Hi(h);
          end;{ if }
      k := i + B_End + 1;
      while (k < HugeIntSize) and (h > 0) do
        begin
          h := h + R[k];
          R[k] := Lo(h);
          h := Hi(h);

          Inc(k);
        end;{ while }
      HugeIntCarry := h > 0;
     {$IFOPT R+}
        if HugeIntCarry then RunError(215);
     {$ENDIF}
    end;{ for }
  { if all's well... }
  if A_IsNeg xor B_IsNeg then HugeInt_Min(R);
end;{ HugeInt_Mul }

procedure HugeInt_DivMod(var a: HugeInt; b: HugeInt; var R: HugeInt);
{ R := a div b  a := a mod b }
var
  MaxShifts, s, q:  Integer;
  d, e:             HugeInt;
  A_IsNeg, B_IsNeg: Boolean;

begin
  if HugeInt_Zero(b) then

    begin
      HugeIntDiv0 := True;
      Exit;
    end{ if }
  else HugeIntDiv0 := False;
  A_IsNeg := HugeInt_IsNeg(a);
  B_IsNeg := HugeInt_IsNeg(b);
  if A_IsNeg then HugeInt_Min(a);
  if B_IsNeg then HugeInt_Min(b);
  if HugeInt_Comp(a, b) < 0 then
    { a<b; no need to divide }
    FillChar(R, SizeOf(R), 0)
  else
    begin
      FillChar(R, SizeOf(R), 0);
      repeat
        Move(b, d, SizeOf(HugeInt));
        { first work out the number of shifts }

        MaxShifts := HugeInt_HCD(a) - HugeInt_HCD(b);
        s := 0;
        while (s <= MaxShifts) and (HugeInt_Comp(a, d) >= 0) do
          begin
            Inc(s);
            HugeInt_SHL(d, 1);
          end;{ while }
        Dec(s);
        { Make a new copy of b }
        Move(b, d, SizeOf(HugeInt));
        { Shift d as needed }
        HugeInt_ShL(d, S);
        { Use e = -d for addition, faster then  subtracting d }
        Move(d, e, SizeOf(HugeInt));

        HugeInt_Min(e);
        Q := 0;
        { while a >= d do a := a+-d and keep trek of # in Q}
        while HugeInt_Comp(a, d) >= 0 do
          begin
            HugeInt_Add(a, e, a);
            Inc(Q);
          end;{ while }
        { OOps!, one too many subtractions; correct }
        if HugeInt_IsNeg(a) then
          begin
            HugeInt_Add(a, d, a);
            Dec(Q);
          end;{ if }
        HugeInt_SHL(R, 1);
        R[0] := Q;
      until HugeInt_Comp(a, b) < 0;

      if A_IsNeg xor B_IsNeg then HugeInt_Min(R);
    end;{ else }
end;{ HugeInt_Div }

procedure HugeInt_DivMod100(var a: HugeInt; var R: Integer);
{ This works on positive numbers only
  256-Based division: R := a mod 100; a:= a div 100; }
var
  Q: HugeInt;
  S: Integer;
begin
  R := 0; FillChar(Q, SizeOf(Q), 0);
  S := HugeInt_HCD(a);
  repeat
    r := 256*R + a[S];
    HugeInt_SHL(Q, 1);
    Q[0] := R div 100;
    R := R mod 100;
    Dec(S);
  until S < 0;

  Move(Q, a, SizeOf(Q));
end;{  HugeInt_DivMod100 }

procedure HugeInt_Div(a, b: HugeInt; var R: HugeInt);
begin
  HugeInt_DivMod(a, b, R);
end;{ HugeInt_Div }

procedure HugeInt_Mod(a, b: HugeInt; var R: HugeInt);
begin
  HugeInt_DivMod(a, b, R);
  Move(a, R, SizeOf(HugeInt));
end;{ HugeInt_Mod }

procedure HugeInt2String(a: HugeInt; var S: string);
  function Str100(i: Integer): string;
  begin
    Str100 := Chr(i div 10 + Ord('0')) + Chr(i mod 10 + Ord('0'));

  end;{ Str100 }
var
  R:      Integer;
  Is_Neg: Boolean;
begin
  S := '';
  Is_Neg := HugeInt_IsNeg(a);
  if Is_Neg then HugeInt_Min(a);
  repeat
    HugeInt_DivMod100(a, R);
    Insert(Str100(R), S, 1);
  until HugeInt_Zero(a) or (Length(S) = 254);
  while (Length(S) > 1) and (S[1] = '0') do Delete(S, 1, 1);
  if Is_Neg then Insert('-', S, 1);
end;{ HugeInt2String }

procedure String_DivMod256(var S: string; var R: Integer);
{ This works on Positive numbers Only

  10(00)-based division: R := S mod 256; S := S div 256 }
var Q: string;
begin
  FillChar(Q, SizeOf(Q), 0);
  R := 0;
  while S <> '' do
    begin
      R := 10*R + Ord(S[1]) - Ord('0'); Delete(S, 1, 1);
      Q := Q + Chr(R div 256 + Ord('0'));
      R := R  mod 256;
    end;{ while }
  while (Q <> '') and (Q[1] = '0') do Delete(Q, 1, 1);
  S := Q;
end;{ String_DivMod256 }

procedure String2HugeInt(AString: string; var a: HugeInt);
var
  i, h:   Integer;

  Is_Neg: Boolean;
begin
  if AString = '' then AString := '0';
  Is_Neg := AString[1] = '-';
  if Is_Neg then Delete(Astring, 1, 1);
  i := 0;
  while (AString <> '') and (i <= HugeIntMSB) do
    begin
      String_DivMod256(AString, h);
      a[i] := h;
      Inc(i);
    end;{ while }
  if Is_Neg then HugeInt_Min(a);
end;{ String2HugeInt }

procedure Integer2HugeInt(AInteger: Integer; var a: HugeInt);
var Is_Neg: Boolean;
begin
  Is_Neg := AInteger < 0;

  if Is_Neg then AInteger := -AInteger;
  FillChar(a, SizeOf(HugeInt), 0);
  Move(AInteger, a, SizeOf(Integer));
  if Is_Neg then HugeInt_Min(a);
end;{ Integer2HugeInt }

end.

{ This code came from Lloyd's help file! }

formatting '1010' to '001010' ???

From: "Bobby W. Jones II"<ctech@earthlink.net>

Another alternative is to create a function like the one native in Clipper, called PadL(string,width,character), like the following:

function TfrmFunc.PadL(cVal: string; nWide: integer; cChr: char): string;
var
  i1,nStart: integer;
begin
  if length(cVal) < nWide then
    begin
      nStart:=length(cVal);
      for i1:=nStart to nWide-1 do cVal:=cChar+cVal;
    end;
  PadL:=cVal;
end;

This then can be called with any string that you want to make a specific length. As with your example, PadL(A,length(B),'0'); It also gives you the flexibility to pad with any character and to be able to set a fixed length (like making sure your text counters remain the same width -- PadL(A,6,'0');

32 bit CRC

From: "Earl F. Glynn" <EarlGlynn@postoffice.worldnet.att.net>

the Delphi 1.0 UNIT follows (slight changes must be made for Delphi 2.0):

UNIT CRC32;

 {CRC32 calculates a cyclic redundancy code (CRC), known as CRC-32, using
  a byte-wise algorithm.

  (C) Copyright 1989, 1995-1996 Earl F. Glynn, Overland Park, KS.
  All Rights Reserved.

  This UNIT was derived from the CRCT FORTRAN 77 program given in
  "Byte-wise CRC Calculations" by Aram Perez in IEEE Micro, June 1983,
  pp. 40-50.  The constants here are for the CRC-32 generator polynomial,
  as defined in the Microsoft Systems Journal, March 1995, pp. 107-108

  This CRC algorithm emphasizes speed at the expense of the 512 element
  lookup table.}

INTERFACE

  PROCEDURE CalcCRC32 (p:  pointer; nbyte:  WORD; VAR CRCvalue:  LongInt);
  PROCEDURE CalcFileCRC32 (FromName:  STRING; VAR CRCvalue:  LongInt;
              VAR IOBuffer:  pointer;  BufferSize:  WORD; VAR TotalBytes:  LongInt;
              VAR error:  WORD);

IMPLEMENTATION

  CONST
    table:  ARRAY[0..255] OF LongInt =
   ($00000000, $77073096, $EE0E612C, $990951BA,
    $076DC419, $706AF48F, $E963A535, $9E6495A3,
    $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
    $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
    $1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
    $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
    $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
    $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
    $3B6E20C8, $4C69105E, $D56041E4, $A2677172,
    $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
    $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
    $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
    $26D930AC, $51DE003A, $C8D75180, $BFD06116,
    $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
    $2802B89E, $5F058808, $C60CD9B2, $B10BE924,
    $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,

    $76DC4190, $01DB7106, $98D220BC, $EFD5102A,
    $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
    $7807C9A2, $0F00F934, $9609A88E, $E10E9818,
    $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
    $6B6B51F4, $1C6C6162, $856530D8, $F262004E,
    $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
    $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
    $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
    $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
    $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
    $4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
    $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
    $5005713C, $270241AA, $BE0B1010, $C90C2086,
    $5768B525, $206F85B3, $B966D409, $CE61E49F,
    $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
    $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,

    $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
    $EAD54739, $9DD277AF, $04DB2615, $73DC1683,
    $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
    $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
    $F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
    $F762575D, $806567CB, $196C3671, $6E6B06E7,
    $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
    $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
    $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
    $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
    $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
    $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
    $CB61B38C, $BC66831A, $256FD2A0, $5268E236,
    $CC0C7795, $BB0B4703, $220216B9, $5505262F,
    $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
    $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,

    $9B64C2B0, $EC63F226, $756AA39C, $026D930A,
    $9C0906A9, $EB0E363F, $72076785, $05005713,
    $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
    $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
    $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
    $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
    $88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
    $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
    $A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
    $A7672661, $D06016F7, $4969474D, $3E6E77DB,
    $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
    $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
    $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
    $BAD03605, $CDD70693, $54DE5729, $23D967BF,
    $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
    $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);


  TYPE
    buffer = ARRAY[1..65521] OF BYTE;  {largest buffer that can be}
                                       {allocated on heap         }
  VAR
    i:  WORD;
    q:  ^buffer;

  PROCEDURE CalcCRC32 (p:  pointer; nbyte:  WORD; VAR CRCvalue:  LongInt);
   {The following is a little cryptic (but executes very quickly).
    The algorithm is as follows:
      1.  exclusive-or the input byte with the low-order portion of
          the CRC register to get an INDEX
      2.  shift the CRC register eight bits to the right
      3.  exclusive-or the CRC register with the contents of
          Table[INDEX]
      4.  repeat steps 1 through 3 for all bytes}
  BEGIN
    q := p;
    FOR   i := 1 TO nBYTE DO
      CRCvalue := (CRCvalue SHR 8)  XOR
                  Table[ q^[i] XOR (CRCvalue AND $000000FF) ]
  END {CalcCRC32};


  PROCEDURE CalcFileCRC32 (FromName:  STRING; VAR CRCvalue:  LongInt;
            VAR IOBuffer:  pointer;  BufferSize:  WORD; VAR TotalBytes:  LongInt;
            VAR error:  WORD);
    VAR
      BytesRead:  WORD;
      FromFile :  FILE;
      i        :  WORD;
  BEGIN
    FileMode := 0;  {Turbo default is 2 for R/W; 0 is for R/O}
    CRCValue := $FFFFFFFF;
    ASSIGN (FromFile,FromName);
    {$I-} RESET (FromFile,1); {$I+}
    error := IOResult;
    IF   error = 0
    THEN BEGIN
      TotalBytes := 0;

      REPEAT
        BlockRead (FromFile,IOBuffer^,BufferSize,BytesRead);
        CalcCRC32 (IOBuffer,BytesRead,CRCvalue);
        INC (TotalBytes, BytesRead)
      UNTIL BytesRead = 0;
      CLOSE (FromFile)
    END;
    CRCvalue := NOT CRCvalue
  END {CalcFileCRC32};

END {CRC}.

Raising a number to a power

Paul Cunningham (pjcunningham@cix.compulink.co.uk)

 Question[ 
This may sound trivial, but how do you raise a value to a power?
   eg). 2^12 = 4095
          ]
The question is not that trivial. The trouble is that the power function is not that simple. Several distinct situations need to be considered for the function Power(X, N) i.e X^N.

  1. X don't care, N = 0
  2. X = 1, N don't care
  3. X = 0 and N > 0
  4. X = 0 and N < 0
  5. X > 0
  6. X < 0 and N is an odd integer
  7. X < 0 and N is an even integer
  8. X < 0 and N not an integer
Consider the following robust (though not necessarily the most efficient!) power function. 

interface

type
   EPowerException = class(Exception)
end;


implementation

function Power(X, N : real) : extended;
var
  t : longint;
  r : real;
  isInteger : boolean;
begin

   if N = 0 then begin
      result := 1.0;
      exit;
   end;

   if X = 1.0 then begin
      result := 1.0;
      exit;
   end;

   if X = 0.0 then begin
      if N > 0.0 then
         begin
           result := 0.0;
           exit;
         end
      else
        raise EPowerException.Create('Infinite Result');
   end;

   if (X > 0) then
      try
         result := exp(N * ln(X));
         exit;
      except
         raise EPowerException.Create('Overflow/Underflow Result');
   end;


{ X is negative but we still may compute the result if n is an integer}
{ try and get integer portion of n into a longint, it will be quicker to 
}       { compute odd n}
  try
     t := trunc(n);
     if (n - t) = 0 then
        isInteger := true
     else
        isInteger := False;
  except
     {Bit superfluous as result will probably underflow/overflow anyway}
     r := int(n);
     if (n - r) = 0 then
        begin
           isInteger := true;
           if frac(r/2) = 0.5 then
              t := 1
           else
              t := 2;
        end
     else
        isInteger := False;
  end;

  if isInteger then
      begin
         {n is an integer}
         if odd(t) then
            {n is odd}
            try
               result := -exp(N * ln(-X));
               exit;
            except
               raise EPowerException.Create('Overflow/Underflow Result');
            end
         else
            {n is even}
            try
               result := exp(N * ln(-X));
               exit;
            except
               raise EPowerException.Create('Overflow/Underflow Result');
            end;
      end   
   else
      raise EPowerException.Create('Complex Result');

end;

Number to String

From: "Joe E. Healy " jhealy@mindspring.com (Advanced Technology Group) Here's a base that will go up to a million. You can expand it past there if you like. Give credit where credit is due, and dont resell the code! 

unit uNum2Str;

// Possible enhancements
// Move strings out to resource files
// Put in a general num2str utility

interface

function Num2Dollars( dNum: double ) : String;

implementation

uses SysUtils;

function LessThan99( dNum: double ) : String; forward;

// floating point modulus
function FloatMod( i,j: double ): double;
begin
    result := i - (Int(i/j) * j);
end;

function Hundreds( dNum: double ) : String;
var
    workVar: double;
begin
    if ( dNum < 100 ) or ( dNum > 999 ) then
        raise Exception.Create( 'hundreds range exceeded' );

    result := '';

    workVar := Int( dNum / 100 );
    if workVar > 0 then
        result := LessThan99(workVar) + ' Hundred';
end;

function OneToNine( dNum: Double ) : String;
begin
    if ( dNum < 1 ) or (dNum > 9 ) then
        raise exception.create( 'onetonine: value out of range' );

    result := 'woops';

    if dNum = 1 then result := 'One'
    else if dNum = 2 then result := 'Two'
    else if dNum = 3 then result := 'Three'
    else if dNum = 4 then result := 'Four'
    else if dNum = 5.0 then result := 'Five'
    else if dNum = 6 then result := 'Six'
    else if dNum = 7 then result := 'Seven'
    else if dNum = 8 then result := 'Eight'
    else if dNum = 9 then result := 'Nine';

end;

function ZeroTo19( dNum: double ) : String;
begin
    if (dNum < 0) or (dNum > 19) then
        raise Exception.Create( 'Bad value in dNum' );

    result := '';

    if dNum = 0 then result := 'Zero'
    else if (dNum >= 1) and (dNum <= 9) then result := OneToNine( dNum )
    else if dNum = 10 then result := 'Ten'
    else if dNum = 11 then result := 'Eleven'
    else if dNum = 12 then result := 'Twelve'
    else if dNum = 13 then result := 'Thirteen'
    else if dNum = 14 then result := 'Fourteen'
    else if dNum = 15 then result := 'Fifteen'
    else if dNum = 16 then result := 'Sixteen'
    else if dNum = 17 then result := 'Seventeen'
    else if dNum = 18 then result := 'Eighteen'
    else if dNum = 19 then result := 'Nineteen'
    else result := 'woops!';
end;

function TwentyTo99( dNum: double ) : String;
var
    BigNum: String;
begin
    if ( dNum < 20 ) or ( dNum > 99 ) then
        raise exception.Create( 'TwentyTo99: dNum out of range!' );

    BigNum := 'woops';

    if dNum >= 90 then BigNum := 'Ninety'
    else if dNum >= 80 then BigNum := 'Eighty'
    else if dNum >= 70 then BigNum := 'Seventy'
    else if dNum >= 60 then BigNum := 'Sixty'
    else if dNum >= 50 then BigNum := 'Fifty'
    else if dNum >= 40 then BigNum := 'Forty'
    else if dNum >= 30 then BigNum := 'Thirty'
    else if dNum >= 20 then BigNum := 'Twenty';

    // lose the big num
    dNum := FloatMod( dNum, 10 );
    
    if dNum > 0.00 then
        result := BigNum + ' ' + OneToNine( dNum )
    else
        result := BigNum;
end;

function LessThan99( dNum: double ) : String;
begin
    if dNum <= 19 then
        result := ZeroTo19(dNum)
    else
        result := TwentyTo99(dNum);
end;

function Num2Dollars( dNum: double ) : String;
var
    centsString: String;
    cents: double;
    workVar: double;
begin
    result := '';

    if dNum < 0 then
        raise Exception.Create( 'Negative numbers not supported' );

    if dNum > 999999999.99 then
        raise Exception.Create( 'Num2Dollars only supports up to the millions at this point!' );



    cents := (dNum - Int( dNum )) * 100.0;
    if cents = 0.0 then
        centsString := 'and 00/100 Dollars'
    else if cents < 10 then
        centsString := Format( 'and 0%1.0f/100 Dollars', [cents] )
    else
        centsString := Format( 'and %2.0f/100 Dollars', [cents] );

    dNum := Int( dNum - (cents / 100.0) ); // lose the cents

    // deal with million's
    if (dNum >= 1000000 ) and ( dNum <= 999999999 ) then
    begin
        workVar := dNum / 1000000;
        workVar := Int( workVar );
        if (workVar <= 9) then
            result := ZeroTo19(workVar)
        else if ( workVar <= 99 ) then
            result := LessThan99( workVar )
        else if ( workVar <= 999 ) then
            result := Hundreds( workVar )
        else
            result := 'mill fubar';

        result := result + ' Million';

        dNum := dNum - ( workVar * 1000000 );
    end;

    // deal with 1000's
    if (dNum >= 1000 ) and ( dNum <= 999999.99 ) then
    begin
        // doing the two below statements in one line of code yields some really
        // freaky floating point errors
        workVar := dNum/1000;
        workVar := Int( workVar );
        if (workVar <= 9) then
            result := ZeroTo19(workVar)
        else if ( workVar <= 99 ) then
            result := LessThan99( workVar )
        else if ( workVar <= 999 ) then
            result := Hundreds( workVar )
        else
            result := 'thou fubar';

        result := result + ' Thousand';

        dNum := dNum - ( workVar * 1000 );
    end;

    // deal with 100's
    if (dNum >= 100.00 ) and (dNum <= 999.99) then
    begin
        result := result + ' ' + Hundreds( dNum );
        dNum := FloatMod( dNum, 100 );
    end;

    // format in anything less than 100
    if ( dNum > 0) or ((dNum = 0) and (Length( result ) = 0)) then
    begin
        result := result + ' ' + LessThan99( dNum );
    end;
    result := result + ' ' + centsString;
end;

end.

Math formula evaluator

From: "MichaelHensel" <mcmichael@vossnet.de>

Here is a routine (written by a Frank Fetthauer) that I found in a group some days ago:

FORMULA has to be a string containing the formular. Variables x y and z are allowed, as well as the operatins below. Example: 

sin(x)*cos(x^y)+exp(cos(x))
Useage: 
uses EVALCOMP; 

var calc:    EVALVEC ; (evalvec is a pointer to an object defined by evalcomp)
    FORMULA: string;

begin

FORMULA:='x+y+z';

new (calc,init(FORMULA)); (Building the evaluation tree)

writeln ( calc^.eval1d(7) )     ; (x=7 y=0 z=0; result:  7)
writeln ( calc^.eval2d(7,8) )   ; (x=7 y=8 z=0; result: 15)
writeln ( calc^.eval3d(7,8,9) ) ; (x=7 y=8 z=9; result: 24)

dispose(calc,done); (destroing the evaluation tree)

end.
Allowed operations: 
x <l;> y ; Logical operations return 1 if true and 0 if false.
x <l;= y
x >= y
x > y
x <l; y
x = y
x + y
x - y
x eor y ( exclusive or )
x or y
x * y
x / y
x and y
x mod y
x div y
x ^ y ( power )
x shl y
x shr y
not (x)
sinc (x)
sinh (x)
cosh (x)
tanh (x)
coth (x)
sin (x)
cos (x)
tan (x)
cot (x)
sqrt (x)
sqr (x)
arcsinh (x)
arccosh (x)
arctanh (x)
arccoth (x)
arcsin (x)
arccos (x)
arctan (x)
arccot (x)
heavy (x) ; 1 for positive numbers, 0 else
sgn (x) ; 1 for positive, -1 for negative, 0 for 0
frac (x)
exp (x)
abs (x)
trunc (x)
ln (x)
odd (x)
pred (x)
succ (x)
round (x)
int (x)
fac (x) ; x*(x-1)*(x-2)*...*3*2*1
rnd ; Random number in [0,1]
rnd (x) ; Random number in [0,x]
pi
e
-------------------------------------------------------------------- 
unit evalcomp;

interface

type fun= function(x,y:real):real;
     evalvec= ^evalobj;
     evalobj= object
              f1,f2:evalvec;
              f1x,f2y:real;
              f3:fun;
              function eval:real;
              function eval1d(x:real):real;
              function eval2d(x,y:real):real;
              function eval3d(x,y,z:real):real;
              constructor init(st:string);
              destructor done;
              end;
var  evalx,evaly,evalz:real;

implementation

var analysetmp:fun;

function search (text,code:string; var pos:integer):boolean;
var i,count:integer;
    flag:boolean;
    newtext:string;
begin
  if length(text)<l;length(code) then begin search:=false; exit; end;
  flag:=false;
  pos:=length(text)-length(code)+1;
  repeat
    if code=copy(text,pos,length(code))
      then flag:=true
      else dec(pos);
    if flag
      then
       begin
        count:=0;
        for i:= pos+1 to length(text) do
         begin
          if copy(text,i,1) = '(' then inc(count);
          if copy(text,i,1) = ')' then dec(count);
         end;
        if count<l;>0
         then
          begin
           dec(pos);
           flag:=false;
          end;
       end;
  until (flag=true) or (pos=0);
  search:=flag;
end;

function myid(x,y:real):real;
begin
 myid:=x;
end;

function myunequal(x,y:real):real;
begin
 if x<l;>y then
  myunequal:=1
 else
  myunequal:=0;
end;

function mylessequal(x,y:real):real;
begin
 if x<l;=y then
  mylessequal:=1
 else
  mylessequal:=0;
end;

function mygreaterequal(x,y:real):real;
begin
 if x>=y then
  mygreaterequal:=1
 else
  mygreaterequal:=0;
end;

function mygreater(x,y:real):real;
begin
 if x>y then
  mygreater:=1
 else
  mygreater:=0;
end;

function myless(x,y:real):real;
begin
 if x<l;y then
  myless:=1
 else
  myless:=0;
end;

function myequal(x,y:real):real;
begin
 if x=y then
  myequal:=1
 else
  myequal:=0;
end;

function myadd(x,y:real):real;
begin
  myadd:=x+y;
end;

function mysub(x,y:real):real;
begin
  mysub:=x-y;
end;

function myeor(x,y:real):real;
begin
  myeor:=trunc(x) xor trunc(y);
end;

function myor(x,y:real):real;
begin
  myor:=trunc(x) or trunc(y);
end;

function mymult(x,y:real):real;
begin
  mymult:=x*y;
end;

function mydivid(x,y:real):real;
begin
  mydivid:=x/y;
end;

function myand(x,y:real):real;
begin
  myand:=trunc(x) and trunc(y);
end;

function mymod(x,y:real):real;
begin
  mymod:=trunc(x) mod trunc(y);
end;

function mydiv(x,y:real):real;
begin
  mydiv:=trunc(x) div trunc(y);
end;

function mypower(x,y:real):real;
begin
 if x=0 then
  mypower:=0
 else
  if x>0 then
   mypower:=exp(y*ln(x))
  else
   if trunc(y)<l;>y  then
    begin
    writeln (' Fehler in x^y ');
    halt;
    end
   else
    if odd(trunc(y))=true then
     mypower:=-exp(y*ln(-x))
    else
     mypower:=exp(y*ln(-x))
end;

function myshl(x,y:real):real;
begin
  myshl:=trunc(x) shl trunc(y);
end;

function myshr(x,y:real):real;
begin
  myshr:=trunc(x) shr trunc(y);
end;

function mynot(x,y:real):real;
begin
  mynot:=not trunc(x);
end;

function mysinc(x,y:real):real;
begin
if x=0 then
 mysinc:=1
else
 mysinc:=sin(x)/x
end;

function mysinh(x,y:real):real;
begin
mysinh:=0.5*(exp(x)-exp(-x))
end;

function mycosh(x,y:real):real;
begin
mycosh:=0.5*(exp(x)+exp(-x))
end;

function mytanh(x,y:real):real;
begin
mytanh:=mysinh(x,0)/mycosh(x,0)
end;

function mycoth(x,y:real):real;
begin
mycoth:=mycosh(x,0)/mysinh(x,0)
end;

function mysin(x,y:real):real;
begin
mysin:=sin(x)
end;

function mycos(x,y:real):real;
begin
mycos:=cos(x)
end;

function mytan(x,y:real):real;
begin
mytan:=sin(x)/cos(x)
end;

function mycot(x,y:real):real;
begin
mycot:=cos(x)/sin(x)
end;

function mysqrt(x,y:real):real;
begin
mysqrt:=sqrt(x)
end;

function mysqr(x,y:real):real;
begin
mysqr:=sqr(x)
end;

function myarcsinh(x,y:real):real;
begin
myarcsinh:=ln(x+sqrt(sqr(x)+1))
end;

function mysgn(x,y:real):real;
begin
if x=0 then
 mysgn:=0
else
 mysgn:=x/abs(x)
end;

function myarccosh(x,y:real):real;
begin
myarccosh:=ln(x+mysgn(x,0)*sqrt(sqr(x)-1))
end;

function myarctanh(x,y:real):real;
begin
myarctanh:=ln((1+x)/(1-x))/2
end;

function myarccoth(x,y:real):real;
begin
myarccoth:=ln((1-x)/(1+x))/2
end;

function myarcsin(x,y:real):real;
begin
if x=1 then
 myarcsin:=pi/2
else
 myarcsin:=arctan(x/sqrt(1-sqr(x)))
end;

function myarccos(x,y:real):real;
begin
myarccos:=pi/2-myarcsin(x,0)
end;

function myarctan(x,y:real):real;
begin
myarctan:=arctan(x);
end;

function myarccot(x,y:real):real;
begin
myarccot:=pi/2-arctan(x)
end;

function myheavy(x,y:real):real;
begin
myheavy:=mygreater(x,0)
end;

function myfrac(x,y:real):real;
begin
myfrac:=frac(x)
end;

function myexp(x,y:real):real;
begin
myexp:=exp(x)
end;

function myabs(x,y:real):real;
begin
myabs:=abs(x)
end;

function mytrunc(x,y:real):real;
begin
mytrunc:=trunc(x)
end;

function myln(x,y:real):real;
begin
myln:=ln(x)
end;

function myodd(x,y:real):real;
begin
if odd(trunc(x)) then
 myodd:=1
else
 myodd:=0;
end;

function mypred(x,y:real):real;
begin
mypred:=pred(trunc(x));
end;

function mysucc(x,y:real):real;
begin
mysucc:=succ(trunc(x));
end;

function myround(x,y:real):real;
begin
myround:=round(x);
end;

function myint(x,y:real):real;
begin
myint:=int(x);
end;

function myfac(x,y:real):real;
var n : integer;
    r : real;
begin
if x<l;0 then begin writeln(' Fehler in Fakultät '); halt; end;
if x = 0 then myfac := 1
else
 begin
 r := 1;
 for n := 1 to trunc ( x ) do
  r := r * n;
 myfac:= r;
 end;
end;

function myrnd(x,y:real):real;
begin
myrnd:=random;
end;

function myrandom(x,y:real):real;
begin
myrandom:=random(trunc(x));
end;

function myevalx(x,y:real):real;
begin
myevalx:=evalx;
end;

function myevaly(x,y:real):real;
begin
myevaly:=evaly;
end;

function myevalz(x,y:real):real;
begin
myevalz:=evalz;
end;

procedure analyse (st:string; var st2,st3:string);
label start;
    var pos:integer;
    value:real;
    newterm,term:string;
begin
term:=st;
start:
  if term='' then begin analysetmp:=myid; st2:='0'; st3:=''; exit; end;
  newterm:='';
  for pos:= 1 to length(term) do
    if copy(term,pos,1)<l;>' ' then newterm:=newterm+copy(term,pos,1);
  term:=newterm;
  if term='' then begin analysetmp:=myid; st2:='0'; st3:=''; exit; end;
  val(term,value,pos);
  if pos=0 then begin
                  analysetmp:=myid;
                  st2:=term;
                  st3:='';
                  exit;
                end;
  if search(term,'<l;>',pos) then begin
       analysetmp:=myunequal;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+2,length(term)-pos-1);
       exit;
       end;
  if search(term,'<l;=',pos) then begin
       analysetmp:=mylessequal;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+2,length(term)-pos-1);
       exit;
       end;
  if search(term,'>=',pos) then begin
       analysetmp:=mygreaterequal;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+2,length(term)-pos-1);
       exit;
       end;
  if search(term,'>',pos) then begin
       analysetmp:=mygreater;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'<l;',pos) then begin
       analysetmp:=myless;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'=',pos) then begin
       analysetmp:=myequal;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'+',pos) then begin
       analysetmp:=myadd;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'-',pos) then begin
       analysetmp:=mysub;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'eor',pos) then begin
       analysetmp:=myeor;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+3,length(term)-pos-2);
       exit;
       end;
  if search(term,'or',pos) then begin
       analysetmp:=myor;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+2,length(term)-pos-1);
       exit;
       end;
  if search(term,'*',pos) then begin
       analysetmp:=mymult;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'/',pos) then begin
       analysetmp:=mydivid;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'and',pos) then begin
       analysetmp:=myand;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+3,length(term)-pos-2);
       exit;
       end;
  if search(term,'mod',pos) then begin
       analysetmp:=mymod;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+3,length(term)-pos-2);
       exit;
       end;
  if search(term,'div',pos) then begin
       analysetmp:=mydiv;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+3,length(term)-pos-2);
       exit;
       end;
  if search(term,'^',pos) then begin
       analysetmp:=mypower;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'shl',pos) then begin
       analysetmp:=myshl;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+3,length(term)-pos-2);
       exit;
       end;
  if search(term,'shr',pos) then begin
       analysetmp:=myshr;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+3,length(term)-pos-2);
       exit;
       end;
  if copy(term,1,1)='(' then begin
          term:=copy(term,2,length(term)-2);
          goto start;
          end;
  if copy(term,1,3)='not' then begin
          analysetmp:=mynot;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,4)='sinc' then begin
          analysetmp:=mysinc;
          st2:=copy(term,5,length(term)-4);
          st3:='';
          exit;
          end;
  if copy(term,1,4)='sinh' then begin
          analysetmp:=mysinh;
          st2:=copy(term,5,length(term)-4);
          st3:='';
          exit;
          end;
  if copy(term,1,4)='cosh' then begin
          analysetmp:=mycosh;
          st2:=copy(term,5,length(term)-4);
          st3:='';
          exit;
          end;
  if copy(term,1,4)='tanh' then begin
          analysetmp:=mytanh;
          st2:=copy(term,5,length(term)-4);
          st3:='';
          exit;
          end;
  if copy(term,1,4)='coth' then begin
          analysetmp:=mycoth;
          st2:=copy(term,5,length(term)-4);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='sin' then begin
          analysetmp:=mysin;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='cos' then begin
          analysetmp:=mycos;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='tan' then begin
          analysetmp:=mytan;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='cot' then begin
          analysetmp:=mycot;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,4)='sqrt' then begin
          analysetmp:=mysqrt;
          st2:=copy(term,5,length(term)-4);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='sqr' then begin
          analysetmp:=mysqr;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,7)='arcsinh' then begin
          analysetmp:=myarcsinh;
          st2:=copy(term,8,length(term)-7);
          st3:='';
          exit;
          end;
  if copy(term,1,7)='arccosh' then begin
          analysetmp:=myarccosh;
          st2:=copy(term,8,length(term)-7);
          st3:='';
          exit;
          end;
  if copy(term,1,7)='arctanh' then begin
          analysetmp:=myarctanh;
          st2:=copy(term,8,length(term)-7);
          st3:='';
          exit;
          end;
  if copy(term,1,7)='arccoth' then begin
          analysetmp:=myarccoth;
          st2:=copy(term,8,length(term)-7);
          st3:='';
          exit;
          end;
  if copy(term,1,6)='arcsin' then begin
          analysetmp:=myarcsin;
          st2:=copy(term,7,length(term)-6);
          st3:='';
          exit;
          end;
  if copy(term,1,6)='arccos' then begin
          analysetmp:=myarccos;
          st2:=copy(term,7,length(term)-6);
          st3:='';
          exit;
          end;
  if copy(term,1,6)='arctan' then begin
          analysetmp:=myarctan;
          st2:=copy(term,7,length(term)-6);
          st3:='';
          exit;
          end;
  if copy(term,1,6)='arccot' then begin
          analysetmp:=myarccot;
          st2:=copy(term,7,length(term)-6);
          st3:='';
          exit;
          end;
  if copy(term,1,5)='heavy' then begin
          analysetmp:=myheavy;
          st2:=copy(term,6,length(term)-5);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='sgn' then begin
          analysetmp:=mysgn;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,4)='frac' then begin
          analysetmp:=myfrac;
          st2:=copy(term,5,length(term)-4);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='exp' then begin
          analysetmp:=myexp;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='abs' then begin
          analysetmp:=myabs;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,5)='trunc' then begin
          analysetmp:=mytrunc;
          st2:=copy(term,6,length(term)-5);
          st3:='';
          exit;
          end;
  if copy(term,1,2)='ln' then begin
          analysetmp:=myln;
          st2:=copy(term,3,length(term)-2);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='odd' then begin
          analysetmp:=myodd;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,4)='pred' then begin
          analysetmp:=mypred;
          st2:=copy(term,5,length(term)-4);
          st3:='';
          exit;
          end;
  if copy(term,1,4)='succ' then begin
          analysetmp:=mysucc;
          st2:=copy(term,5,length(term)-4);
          st3:='';
          exit;
          end;
  if copy(term,1,5)='round' then begin
          analysetmp:=myround;
          st2:=copy(term,6,length(term)-5);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='int' then begin
          analysetmp:=myint;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if copy(term,1,3)='fac' then begin
          analysetmp:=myfac;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if term='rnd' then begin
          analysetmp:=myrnd;
          st2:='';
          st3:='';
          exit;
          end;
  if copy(term,1,3)='rnd' then begin
          analysetmp:=myrandom;
          st2:=copy(term,4,length(term)-3);
          st3:='';
          exit;
          end;
  if term='x' then begin
          analysetmp:=myevalx;
          st2:='';
          st3:='';
          exit;
          end;
  if term='y' then begin
          analysetmp:=myevaly;
          st2:='';
          st3:='';
          exit;
          end;
  if term='z' then begin
          analysetmp:=myevalz;
          st2:='';
          st3:='';
          exit;
          end;
  if (term='pi') then begin
          analysetmp:=myid;
          str(pi,st2);
          st3:='';
          exit;
          end;
  if term='e' then begin
          analysetmp:=myid;
          str(exp(1),st2);
          st3:='';
          exit;
          end;
  writeln(' WARNING : UNDECODABLE FORMULA ');
  analysetmp:=myid;
  st2:='';
  st3:='';
end;

function evalobj.eval:real;
var tmpx,tmpy:real;
begin
 if f1=nil then
  tmpx:=f1x
 else
  tmpx:=f1^.eval;
 if f2=nil then
  tmpy:=f2y
 else
  tmpy:=f2^.eval;
 eval:=f3(tmpx,tmpy);
end;

function evalobj.eval1d(x:real):real;
begin
evalx:=x;
evaly:=0;
evalz:=0;
eval1d:=eval;
end;

function evalobj.eval2d(x,y:real):real;
begin
evalx:=x;
evaly:=y;
evalz:=0;
eval2d:=eval;
end;

function evalobj.eval3d(x,y,z:real):real;
begin
evalx:=x;
evaly:=y;
evalz:=z;
eval3d:=eval;
end;

constructor evalobj.init(st:string);
var st2,st3:string;
    error:integer;
begin
f1:=nil;
f2:=nil;
analyse(st,st2,st3);
f3:=analysetmp;
val(st2,f1x,error);
if st2='' then
begin
 f1x:=0;
 error:=0;
end;
if error<l;>0 then
 new (f1,init(st2));
val(st3,f2y,error);
if st3='' then
begin
 f2y:=0;
 error:=0;
end;
if error<l;>0 then
 new (f2,init(st3));
end;

destructor evalobj.done;
begin
if f1<l;>nil then
 dispose(f1,done);
if f2<l;>nil then
 dispose(f2,done);
end;

end.

Set and Clear BITS[NEW]

SetWord is the word that contains the bit you want to set. BitNum is the number of the bit you want to set as defined in the const section (Bit0, Bit1, etc...). GetBitStat returns true if the bit is Set, otherwise it returns false.

 { A word is arranged like this...                     }

 { The Word   -  0  0  0  0  0  0 0 0 0 0 0 0 0 0 0 0  }
 { Bit Number - 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0  }

Const
 Bit0 = 1;
 Bit1 = 2;
 Bit2 = 4;
 Bit3 = 8;
 Bit4 = 16;
 Bit5 = 32;
 Bit6 = 64;
 Bit7 = 128;

 Bit8 = 256;
 Bit9 = 512;
 Bit10 = 1024;
 Bit11 = 2048;
 Bit12 = 4096;
 Bit13 = 8192;
 Bit14 = 16384;
 Bit15 = 32768;

Procedure SetBit(SetWord, BitNum : Word);
 Begin
  SetWord := SetWord Or BitNum;     { Set bit }
 End;

Procedure ClearBit(SetWord, BitNum : Word);
 Begin
  SetWord := SetWord Or BitNum;     { Set bit    }
  SetWord := SetWord Xor BitNum;    { Toggle bit }
 End;

Procedure ToggleBit(SetWord, BitNum : Word);
 Begin
  SetWord := SetWord Xor BitNum;    { Toggle bit }
 End;

 Function GetBitStat(SetWord, BitNum : Word) : Boolean;
  Begin
   If SetWord And BitNum = BitNum Then            { If bit is set }
    GetBitStat := True Else GetBitStat := False;
  End;

Complex Library[NEW]

A library for calculations with complex datatype can be found here
Please email me and tell me if you liked this page.