Unit VolumeWeightedData;

Interface

  Uses
    Classes;

  Const
    MaxVolumeBlocks = 2048;  { Somewhat arbitrary, just to keep us from running
                               out of memory killing the process. }

  Type
    TVolumeBlock =
      Record
        ExtremeHigh, High, Middle, Low, ExtremeLow : Double;
        StartTime, EndTime : TDateTime;
      End;

    TVolumeBlocks = Array Of TVolumeBlock;

    TVolumeBlockFactory =
      Class(TObject)
      Private
        FOverflow : Boolean;
        FGroupBy : Integer;
        VolumeBlocks : TVolumeBlocks;
        CurrentVolumeBlock : Integer;
        CurrentBlockShares : Integer;
        CurrentStartTime, CurrentEndTime : TDateTime;
        InProcessList : Array Of
          Record
            Price : Double;
            Size : Integer;
          End;
        InProcessCount : Integer;
        Procedure AddToBlock(Price : Double; Size : Integer; Time : TDateTime);
        Procedure InitBlock;
        Procedure NextBlock;
        Procedure SignalOverflow;
      Public
        Constructor Create(GroupBy : Integer);
        Procedure InitializeWith(VolumeBlocks : TVolumeBlocks);
        Procedure AddPrint(Price : Double; Size : Integer; Time : TDateTime);
        Function GetBlocks : TVolumeBlocks;
        Function GetBlockCount : Integer;
        Property Overflow : Boolean Read FOverflow;
      End;

  Function VolumeBlockToString(VolumeBlock : TVolumeBlock) : String;
  Function VolumeBlockFromString(S : String) : TVolumeBlock;
  Function VolumeBlocksToString(VolumeBlocks : TVolumeBlocks; Reverse : Boolean) : String;
  Function VolumeBlocksFromString(S : String) : TVolumeBlocks;

Implementation

  Uses
    DebugOutput,
    Math, SysUtils;

  Function VolumeBlockToString(VolumeBlock : TVolumeBlock) : String;
    Begin
      With VolumeBlock Do
        Result := Format('%g:%g:%g:%g:%g:%g:%g',
                         [ExtremeHigh, High, Middle, Low, ExtremeLow,
                          StartTime, EndTime]);
    End;

  Function VolumeBlockFromString(S : String) : TVolumeBlock;
    Var
      Items : TStringList;
    Begin
      Items := TStringList.Create;
      Try
        Items.Delimiter := ':';
        Items.DelimitedText := S;
        Assert(Items.Count = 7);
        Result.ExtremeHigh := StrToFloat(Items[0]);
        Result.High := StrToFloat(Items[1]);
        Result.Middle := StrToFloat(Items[2]);
        Result.Low := StrToFloat(Items[3]);
        Result.ExtremeLow := StrToFloat(Items[4]);
        Result.StartTime := StrToFloat(Items[5]);
        Result.EndTime := StrToFloat(Items[6]);
      Finally
        Items.Free
      End
    End;

  Function VolumeBlocksToString(VolumeBlocks : TVolumeBlocks; Reverse : Boolean) : String;
    Var
      I : Integer;
      OneBlock : String;
    Begin
      Result := '';
      For I := Low(VolumeBlocks) To High(VolumeBlocks) Do
        Begin
          OneBlock := VolumeBlockToString(VolumeBlocks[I]);
          If Result = '' Then
            Result := OneBlock
          Else
            If Reverse Then
              Result := OneBlock + ';' + Result
            Else
              Result := Result + ';' + OneBlock
        End
    End;

  Function VolumeBlocksFromString(S : String) : TVolumeBlocks;
    Var
      Items : TStringList;
      I : Integer;
    Begin
      Items := TStringList.Create;
      Try
        Items.Delimiter := ';';
        Items.DelimitedText := S;
        SetLength(Result, Items.Count);
        For I := Low(Result) To High(Result) Do
          Result[I] := VolumeBlockFromString(Items[I])
      Finally
        Items.Free
      End
    End;

  ////////////////////////////////////////////////////////////////////////
  // TVolumeBlockFactory
  ////////////////////////////////////////////////////////////////////////

  Procedure TVolumeBlockFactory.SignalOverflow;
    Begin
      DebugOutputWindow.AddMessage('Cutting off volume block list due to overflow.');  { Shouldn't happen too often, I hope! }
      FOverflow := True;
      SetLength(VolumeBlocks, 0);
      CurrentVolumeBlock := 0;
      SetLength(InProcessList, 0)
    End;

  Constructor TVolumeBlockFactory.Create(GroupBy : Integer);
    Begin
      FGroupBy := GroupBy;
      InitBlock
    End;

  Procedure TVolumeBlockFactory.InitializeWith(VolumeBlocks : TVolumeBlocks);
    Begin
      Self.VolumeBlocks := VolumeBlocks;
      CurrentVolumeBlock := Length(VolumeBlocks);
      InitBlock
    End;

  Procedure TVolumeBlockFactory.AddPrint(Price : Double; Size : Integer; Time : TDateTime);
    Var
      SizeOfPiece : Integer;
    Begin
      While Not FOverflow Do
        Begin
          SizeOfPiece := Min(Size, FGroupBy - CurrentBlockShares);
          If SizeOfPiece <= 0 Then
            Break;
          AddToBlock(Price, SizeOfPiece, Time);
          Inc(Size, -SizeOfPiece);
          Assert(CurrentBlockShares <= FGroupBy);
          If CurrentBlockShares = FGroupBy Then
            If Succ(CurrentVolumeBlock) >= MaxVolumeBlocks Then
              SignalOverflow
            Else
              NextBlock
        End
    End;

  Function TVolumeBlockFactory.GetBlockCount : Integer;
    Begin
      Result := CurrentVolumeBlock
    End;

  Function TVolumeBlockFactory.GetBlocks : TVolumeBlocks;
    Begin
      Try
        Result := Copy(VolumeBlocks, 0, CurrentVolumeBlock)
      Except
        On E : Exception Do
          Raise Exception.CreateFmt('%s:  %s, while copying %d of %d blocks',
                                    [E.ClassName, E.Message,
                                     CurrentVolumeBlock,
                                     Length(VolumeBlocks)])
      End
    End;

  Procedure TVolumeBlockFactory.AddToBlock(Price : Double; Size : Integer; Time : TDateTime);
    Var
      State : (KeepLooking, InsertHere, IncrementHere);
      Index : Integer;
    Begin
      If Time < CurrentStartTime Then
        CurrentStartTime := Time;
      If Time > CurrentEndTime Then
        CurrentEndTime := Time;
      Index := -1;
      State := KeepLooking;
      Repeat
        Inc(Index);
        If Index = InProcessCount Then
          State := InsertHere
        Else If Price < InProcessList[Index].Price Then
          State := InsertHere
        Else If Price = InProcessList[Index].Price Then
          State := IncrementHere
      Until State <> KeepLooking;
      If State = InsertHere Then
        Begin
          If InProcessCount = Length(InProcessList) Then
            SetLength(InProcessList, Max(32, 2*InProcessCount));
          Move(InProcessList[Index], InProcessList[Succ(Index)], (InProcessCount - Index) * SizeOf(InProcessList[0]));
          Inc(InProcessCount);
          InProcessList[Index].Price := Price;
          InProcessList[Index].Size := Size
        End
      Else
        Inc(InProcessList[Index].Size, Size);
      Inc(CurrentBlockShares, Size)
    End;

  Procedure TVolumeBlockFactory.InitBlock;
    Begin
      If CurrentVolumeBlock = Length(VolumeBlocks) Then
        SetLength(VolumeBlocks, Max(32, Length(VolumeBlocks)*2));
      CurrentBlockShares := 0;
      CurrentStartTime := MaxDouble;
      CurrentEndTime := 0
    End;

  Procedure TVolumeBlockFactory.NextBlock;
    Var
      SharesPassed, Index : Integer;
    Procedure ProceedTo(Goal : Integer);
      Var
        CurrentShares : Integer;
      Begin
        Repeat
          CurrentShares := InProcessList[Index].Size;
          If SharesPassed + CurrentShares >= Goal Then
            Break;
          Inc(SharesPassed, CurrentShares);
          Inc(Index)
        Until False
      End;
    Var
      LowShares, MidShares, HighShares : Integer;
    Begin
      Assert(CurrentBlockShares = FGroupby);
      LowShares := CurrentBlockShares Div 4;
      MidShares := CurrentBlockShares Div 2;
      HighShares := (CurrentBlockShares * 3) Div 4;
      With VolumeBlocks[CurrentVolumeBlock] Do
        Begin
          StartTime := CurrentStartTime;
          EndTime := CurrentEndTime;
          ExtremeLow := InProcessList[0].Price;
          ExtremeHigh := InProcessList[Pred(InProcessCount)].Price;
          Index := 0;
          SharesPassed := 0;
          ProceedTo(LowShares);
          Low := InProcessList[Index].Price;
          ProceedTo(MidShares);
          Middle := InProcessList[Index].Price;
          ProceedTo(HighShares);
          High := InProcessList[Index].Price
        End;
      Inc(CurrentVolumeBlock);
      InProcessCount := 0;
      //SetLength(InProcessList, 0);
      InitBlock
    End;

End.