{*******************************************************}
{                                                       }
{       WHY not a compiler? by Y [05-04-00]             }
{       String/integer/float lists                      }
{                                                       }
{       Copyright (c) 1999-2000 CROWELL, Inc.           }
{       All Rights Reserved.                            }
{                                                       }
{*******************************************************}

unit CLists;

{$I CDEFINES.PAS} {$IFDEF TPC} {$N+} {$ENDIF}

interface

uses Objects, CConstants;

type
  PUnsortedCollection = ^TUnsortedCollection;
  TUnsortedCollection = object(TCollection)
    Duplicates: Boolean;
    constructor Init(ALimit, ADelta: Integer);
    function Compare(Key1, Key2: Pointer): Integer; virtual;
    function KeyOf(Item: Pointer): Pointer; virtual;
    function Search(Key: Pointer; var Index: Integer): Boolean; virtual;
    procedure Insert(Item: Pointer); virtual;
 end;

  PUnsortedStringList = ^TUnsortedStringList;
  TUnsortedStringList = object(TUnsortedCollection)
    CaseSensitive: Boolean;
    constructor Init(ALimit, ADelta: Integer);
    function Add(S: String): Integer;
    function Compare(Key1, Key2: Pointer): Integer; virtual;
    procedure FreeItem(Item: Pointer); virtual;
    procedure Clear;
  end;

  PUnsortedIntegerList = ^TUnsortedIntegerList;
  TUnsortedIntegerList = object(TUnsortedCollection)
  end;

  PUnsortedFloatList = ^TUnsortedFloatList;
  TUnsortedFloatList = object(TUnsortedCollection)
    function Add(F: Float): Integer;
    function Compare(Key1, Key2: Pointer): Integer; virtual;
    procedure FreeItem(Item: Pointer); virtual;
  end;

implementation

{TUnsortedCollection}

constructor TUnsortedCollection.Init(ALimit, ADelta: Integer);
begin
  inherited Init(ALimit, ADelta);
  Duplicates := False;
end; {TUnsortedCollection.Init}

function TUnsortedCollection.Compare(Key1, Key2: Pointer): Integer;
begin
  Abstract;
  {disable FPC warnings}
  Compare := Integer(Key1 = Key2);
end; {TUnsortedCollection.Compare}

procedure TUnsortedCollection.Insert(Item: Pointer);
var
  I: Integer;
begin
  if not Search(KeyOf(Item), I) then
    AtInsert(I, Item)
  else if Duplicates then
    AtInsert(Count, Item);
end; {TUnsortedCollection.Insert}

function TUnsortedCollection.KeyOf(Item: Pointer): Pointer;
begin
  KeyOf := Item;
end; {TUnsortedCollection.KeyOf}

function TUnsortedCollection.Search(Key: Pointer; var Index: Integer): Boolean;
var
  i: Integer;
  Temp: Boolean;
begin
  Temp := False;
  i := 0;
  while (not Temp) and (i < Count) do
  begin
    if (Compare(KeyOf(Items^[i]), Key) = 0) then
    begin
      Temp := True;
      Index := i;
    end;
    Inc(i);
  end;
  if not Temp then
    Index := i;
  Search := Temp;
end; {TUnsortedCollection.Search}

{TUnsortedStringList}

constructor TUnsortedStringList.Init(ALimit, ADelta: Integer);
begin
  inherited Init(ALimit, ADelta);
  CaseSensitive := False;
end;

function TUnsortedStringList.Add(S: String): Integer;
var
  i: Integer;
  Item: Pointer;
begin
  Item := NewStr(S);
  if Duplicates then
  begin
    i := Count;
    AtInsert(Count, Item);
  end
  else
    if not Search(KeyOf(Item), i) then
      AtInsert(i, Item)
    else
      DisposeStr(Item);
  Add := i;
end; {TUnsortedStringList.Add}

function CompareStringPointers(Key1, Key2: Pointer; CaseSensitive: Boolean):
  Integer; {Don't try to compare Nil pointers}
var
  i, j: Integer;
  P1, P2: PString;
  C1, C2: Char;
  L1, L2: Integer;
begin
  P1 := PString(Key1);
  P2 := PString(Key2);

  if (Length(P1^) < Length(P2^)) then
    J := Length(P1^)
  else
    J := Length(P2^);

  I := 1;

  if CaseSensitive then
  begin
    while (I < J) and (P1^[I] = P2^[I]) do
      Inc(I);
    C1 := P1^[I];
    C2 := P2^[I];
  end
  else
  begin
    while (I < J) and (LoCase(P1^[I]) = LoCase(P2^[I])) do
      Inc(I);
    C1 := LoCase(P1^[I]);
    C2 := LoCase(P2^[I]);
  end;

  if (I = J) then
  begin
    L1 := Length(P1^);
    L2 := Length(P2^);

    if (C1 < C2) then
      CompareStringPointers := -1
    else if (C1 > C2) then
      CompareStringPointers := 1
    else if (L1 > L2) then
      CompareStringPointers := 1
    else If (L1 < L2) then
      CompareStringPointers := -1
    else
      CompareStringPointers := 0;
  end
  else
    if (C1 < C2) then
      CompareStringPointers := -1
    else
      CompareStringPointers := 1;
end;

(*function CompareStringPointers(Key1, Key2: Pointer; CaseSensitive: Boolean):
  Integer; assembler; {Don't try to compare Nil pointers}
asm
        PUSH    DS
        CLD
        LDS     SI,Key1
        LES     DI,Key2
        LODSB
        MOV     AH,ES:[DI]
        INC     DI
        MOV     CL,AL
        CMP     CL,AH
        JBE     @@1
        MOV     CL,AH
@@1:    XOR     CH,CH
        CALL    @CompareStrings
        SUB     AL,AH
        SBB     AH,AH
        POP     DS
        JMP     @Finish

{-----------------------------------}

@CompareStrings:
        CMP     CaseSensitive, TRUE
        JE      @CompareCaseSens
        PUSH    AX
        PUSH    CX
@CompareLoop:
        MOV     AL, ES:[DI]
        INC     DI
        CALL    @LoCase
        MOV     AH, AL
        LODSB
        CALL    @LoCase
        CMP     AL, AH
        JNE     @CompareStop
        DEC     CX
        JNZ     @CompareLoop
@CompareStop:
        POP     CX
        POP     AX
        JE      @CompareFinish
        MOV     AL,ES:[DI-1]
        CALL    @LoCase
        MOV     AH, AL
        MOV     AL,DS:[SI-1]
        CALL    @LoCase
        JMP     @CompareFinish
@CompareCaseSens:
        REP     CMPSB
        JE      @CompareFinish
        MOV     AL,DS:[SI-1]
        MOV     AH,ES:[DI-1]
@CompareFinish:
        RETN

{-----------------------------------}

@LoCase:
        CMP     AL, 'A'
        JB      @LoCaseFin
        CMP     AL, 'Z'
        JA      @LoCaseFin
        OR      AL, 20h
@LoCaseFin:
        RETN

{-----------------------------------}

@Finish:
end; {CompareStringPointers}*)

function TUnsortedStringList.Compare(Key1, Key2: Pointer): Integer;
var
  Temp: Integer;
begin
  if Key1 = nil then
    if Key2 = nil then
      Temp := 0
    else
      Temp := -1
  else
    if Key2 = nil then
      Temp := 1
    else
      Temp := CompareStringPointers(Key1, Key2, CaseSensitive);
  Compare := Temp;
end; {TUnsortedStringList.Compare}

procedure TUnsortedStringList.FreeItem(Item: Pointer);
begin
  DisposeStr(Item);
end; {TUnsortedStringList.FreeItem}

procedure TUnsortedStringList.Clear;
var
  i: Integer;
begin
  for i := Count - 1 downto 0 do
    FreeItem(At(i));
  Count := 0;
end; {TUnsortedStringList.Clear}

{TUnsortedFloatList}

function NewFloat(Value: Float): Pointer;
var
  Temp: PFloat;
begin
  New(Temp);
  Float(Temp^) := Value;
  NewFloat := Temp;
end; {NewFloat}

procedure DisposeFloat(Item: Pointer);
begin
  New(PFloat(Item));
end; {DisposeFloat}

function TUnsortedFloatList.Add(F: Float): Integer;
var
  i: Integer;
  Item: Pointer;
begin
  Item := NewFloat(F);
  if not Search(KeyOf(Item), i) then
    AtInsert(i, Item)
  else
    if Duplicates then
    begin
      AtInsert(Count, Item);
      i := Count;
    end
    else
      DisposeFloat(Item);
  Add := i;
end; {TUnsortedFloatList.Add}

function TUnsortedFloatList.Compare(Key1, Key2: Pointer): Integer;
var
  Temp: Integer;
begin
  if (Float(Key1^) = Float(Key2^)) then
    Temp := 0
  else
    if (Float(Key1^) > Float(Key2^)) then
      Temp := 1
    else
      Temp := -1;
  Compare := Temp;
end; {TUnsortedFloatList.Compare}

procedure TUnsortedFloatList.FreeItem(Item: Pointer);
begin
  DisposeFloat(Item);
end; {TUnsortedFloatList.FreeItem}

end.