teesurfa.pas

BCB第三方组件

end;

procedure TCustom3DPaletteSeries.ReadPalette(Stream: TStream);
var t    : Integer;
    tmpL : Integer;

    {$IFDEF CLR}
    tmp  : Integer;
    {$ENDIF}
begin
  Stream.Read(tmpL,SizeOf(tmpL));
  SetLength(FPalette,tmpL);

  for t:=0 to Length(FPalette)-1 do
  with FPalette[t] do
  begin
    Stream.Read(UpToValue,SizeOf(UpToValue));

    {$IFDEF CLR}
    Stream.Read(tmp,Sizeof(tmp));
    Color:=TColor(tmp);
    {$ELSE}
    Stream.Read(Color,SizeOf(Color));
    {$ENDIF}
  end;
end;

procedure TCustom3DPaletteSeries.WritePalette(Stream: TStream);
var t    : Integer;
    tmpL : Integer;
begin
  tmpL:=Length(FPalette);
  Stream.Write(tmpL,SizeOf(tmpL));

  for t:=0 to tmpL-1 do
  with FPalette[t] do
  begin
    Stream.Write(UpToValue,SizeOf(UpToValue));
    Stream.Write(Color,SizeOf(Color));
  end;
end;

Procedure TCustom3DPaletteSeries.DefineProperties(Filer:TFiler);
begin
  inherited;
  Filer.DefineBinaryProperty('CustomPalette',ReadPalette,WritePalette,PaletteStyle=psCustom);
end;

Procedure TCustom3DPaletteSeries.DoBeforeDrawChart;
begin
  inherited;
  CheckPaletteEmpty;
  CalcValueRange;
end;

Procedure TCustom3DPaletteSeries.DrawLegendShape(ValueIndex:Integer;
                                                 Const Rect:TRect);
var R : TRect;
begin
  if (ValueIndex=-1) and UseColorRange then
  begin
    ParentChart.Canvas.Brush.Style:=bsClear;
    ParentChart.Canvas.Rectangle(Rect);  { <-- rectangle }

    with TTeeGradient.Create(nil) do
    try
      // set inverted colors
      StartColor:=Self.EndColor;
      MidColor:=Self.MidColor;
      EndColor:=Self.StartColor;

      // draw
      R:=Rect;
      InflateRect(R,-1,-1);
      Draw(ParentChart.Canvas,R);
    finally
      Free;
    end;
  end
  else inherited;
end;

class Function TCustom3DPaletteSeries.GetEditorClass:String;
Begin
  result:='TGrid3DSeriesEditor'; { <-- dont translate ! }
end;

Procedure TCustom3DPaletteSeries.Clear;
begin
  inherited;

  if FUsePalette then
     if PaletteStyle<>psCustom then
        ClearPalette;
end;

Procedure TCustom3DPaletteSeries.AddValues(Source:TChartSeries);
Begin
  inherited;
  CreateDefaultPalette;
end;

class procedure TCustom3DPaletteSeries.CreateSubGallery(
  AddSubChart: TChartSubGalleryProc);
begin
  inherited;
  AddSubChart(TeeMsg_ColorRange);
end;

class procedure TCustom3DPaletteSeries.SetSubGallery(ASeries: TChartSeries;
  Index: Integer);
begin
  With TCustom3DPaletteSeries(ASeries) do
  Case Index of
    1: begin
         UseColorRange:=True;
         UsePalette:=False;
       end;
  else
    inherited;
  end;
end;

procedure TCustom3DPaletteSeries.CreateRangePalette;
var tmp     : Double;
    Delta   : Double;
    t       : Integer;
begin
  Delta:=MandatoryValueList.Range;

  ClearPalette;

  tmp:=Delta/PaletteSteps;

  for t:=1 to PaletteSteps do
      if Delta>0 then
         AddPalette(MandatoryValueList.MinValue+tmp*t,RangePercent(tmp*t/Delta))
      else
         AddPalette(MandatoryValueList.MinValue,RGB(IEndRed,IEndGreen,IEndBlue));
end;

Procedure TCustom3DPaletteSeries.GalleryChanged3D(Is3D:Boolean);
Const Rots:Array[Boolean] of Integer=(0,335);
      Elev:Array[Boolean] of Integer=(270,340);
      Pers:Array[Boolean] of Integer=(0,160);
begin
  ParentChart.View3D:=True;

  With ParentChart.View3DOptions do
  begin
    Zoom:=60;
    VertOffset:=-2;
    Rotation:=Rots[Is3D];
    Elevation:=Elev[Is3D];
    Perspective:=Pers[Is3D];
  end;

  SetGalleryPalette;
end;

procedure TCustom3DPaletteSeries.SetPaletteStyle(
  const Value: TTeePaletteStyle);
begin
  if FPaletteStyle<>Value then
  begin
    FPaletteStyle:=Value;

    if PaletteStyle<>psCustom then
       ClearPalette;

    Repaint;
  end;
end;

procedure TCustom3DPaletteSeries.SetPaletteMin(const Value: Double);
begin
  FPaletteMin:=Value;
  CreateDefaultPalette;
end;

procedure TCustom3DPaletteSeries.SetPaletteStep(const Value: Double);
begin
  FPaletteStep:=Value;
  CreateDefaultPalette;
end;

procedure TCustom3DPaletteSeries.SetUsePaletteMin(const Value: Boolean);
begin
  FUsePaletteMin:=Value;
  CreateDefaultPalette;
end;

procedure TCustom3DPaletteSeries.SetLegendEvery(const Value: Integer);
begin
  SetIntegerProperty(FLegendEvery,Max(1,Value));
end;

procedure TCustom3DPaletteSeries.GeneratePalette;
var t : Integer;
begin
  for t:=0 to Length(Palette)-1 do
      Palette[t].Color:=GetValueColorValue(Palette[t].UpToValue);
end;

procedure TCustom3DPaletteSeries.InvertPalette;
var t   : Integer;
    tmp : TColor;
begin
  // Invert palette
  for t:=0 to (Length(Palette) div 2)-1 do
  begin
    tmp:=Palette[t].Color;
    Palette[t].Color:=Palette[Length(Palette)-t-1].Color;
    Palette[Length(Palette)-t-1].Color:=tmp;
  end;

  Repaint;
end;

procedure TCustom3DPaletteSeries.SetPalette(const Value: TCustom3DPalette);
var tmp : Integer;
    t   : Integer;
begin
  tmp:=Length(Value);
  SetLength(FPalette,tmp);
  for t:=0 to tmp-1 do
      FPalette[t]:=Value[t];
end;

{ TCustom3DGridSeries }
Constructor TCustom3DGridSeries.Create(AOwner: TComponent);
Begin
  inherited;
  FNumXValues:=10;
  FNumZValues:=10;
  Clear;
End;

Procedure TCustom3DGridSeries.Clear;
begin
  inherited;
  XValues.Order:=loNone;
  InitGridIndex(NumXValues,NumZValues);
end;

Procedure TCustom3DGridSeries.InitGridIndex(XCount,ZCount:Integer);
var x : Integer;
    z : Integer;
begin
  {$IFDEF CLR}  // CLR NET RTL bug
  GridIndex:=nil;
  {$ENDIF}

  SetLength(GridIndex,XCount+1,ZCount+1);

  if not ReuseGridIndex then  // 7.0 speed optimization
     for x:=0 to XCount do
         for z:=0 to ZCount do GridIndex[x,z]:=-1;
end;

Procedure TCustom3DGridSeries.FillGridIndex;
begin
  FillGridIndex(0);
end;

// StartIndex means the first point to start
Procedure TCustom3DGridSeries.FillGridIndex(StartIndex:Integer);
Var XCount : Integer;
    ZCount : Integer;

  Procedure FillIrregularGrid;
  type
    TIrregValues=packed Array of TChartValue;

    Procedure SortValues(const ACount:Integer; Var Values:TIrregValues);
    var t    : Integer;
        tt   : Integer;
        tmp  : TChartValue;
        tmp2 : TChartValue;
    begin
      for t:=1 to ACount-2 do // min value already at index 0
      begin
        tmp:=Values[t];

        for tt:=t to ACount-1 do
            if Values[tt]<tmp then
            begin
              tmp2:=Values[tt];
              Values[tt]:=tmp;
              Values[t]:=tmp2;
            end;
      end;
    end;

    function SearchSorted(const Value:TChartValue; const ACount:Integer; Var Values:TIrregValues): Integer;
    var L : Integer;
        H : Integer;
    begin
      L:=0;
      H:=Pred(ACount);

      while L <= H do
      begin
        result:=(L + H) shr 1;

        if Values[result]<Value then
           L:=Succ(result)
        else
        begin
          if Values[result]=Value then
             Exit;

          H:=Pred(result);
        end;
      end;

      result:=-1;
    end;

  var
    XVals : TIrregValues;
    ZVals : TIrregValues;

    // Adds unique values of "AValue" to "Values" array.
    // Repeated values aren't allowed.
    Procedure SearchXValue(const Value:TChartValue);
    begin
      if SearchSorted(Value,XCount,XVals)=-1 then
      begin
        XVals[XCount]:=Value;
        Inc(XCount);
      end;
    end;

    // Adds unique values of "AValue" to "Values" array.
    // Repeated values aren't allowed.
    Procedure SearchZValue(const Value:TChartValue);
    begin
      if SearchSorted(Value,ZCount,ZVals)=-1 then
      begin
        ZVals[ZCount]:=Value;
        Inc(ZCount);
      end;
    end;

    procedure SetGridIndex(const Index:Integer);
    var tmpX : Integer;
        tmpZ : Integer;
    begin
      tmpX:=SearchSorted(XValues.Value[Index],XCount,XVals);

      if tmpX<>-1 then
      begin
        tmpZ:=SearchSorted(ZValues.Value[Index],ZCount,ZVals);

        if tmpZ<>-1 then
           GridIndex[Succ(tmpX),Succ(tmpZ)]:=Index;
      end;
    end;

  const
    MaxAllowedCells = 20000;

  var t : Integer;
  begin
    SetLength(XVals,MaxAllowedCells);
    SetLength(ZVals,MaxAllowedCells);

    try
      XCount:=1;
      XVals[0]:=XValues.MinValue;

      ZCount:=1;
      ZVals[0]:=ZValues.MinValue;

      // Adds all unique X and Z values to XVals and ZVals arrays
      // XCount and ZCount are updated to maximum number of non-repeated values
      for t:=StartIndex to Count-1 do
      begin
        SearchXValue(XValues.Value[t]);
        SearchZValue(ZValues.Value[t]);
      end;

      // Sort X and Z array values in ascending order
      SortValues(XCount,XVals);
      SortValues(ZCount,ZVals);

      InitGridIndex(Max(NumXValues+1,XCount),Max(NumZValues+1,ZCount));

      // Use sorted XVals and ZVals to index Mandatory ValueList in grid
      for t:=StartIndex to Count-1 do
          SetGridIndex(t);

    finally
      XVals:=nil;
      ZVals:=nil;
    end;
  end;

  Procedure FillRegularGrid;
  var t : Integer;
      tmpMinX,
      tmpMinZ : Integer;
  begin
    tmpMinX:=Round(XValues.MinValue)-1;
    tmpMinZ:=Round(ZValues.MinValue)-1;

    XCount:=Round(XValues.MaxValue)-tmpMinX;
    ZCount:=Round(ZValues.MaxValue)-tmpMinZ;

    InitGridIndex(XCount,ZCount);

    for t:=StartIndex to Count-1 do
        GridIndex[ Round(XValues.Value[t])-tmpMinX,
                   Round(ZValues.Value[t])-tmpMinZ]:=t;
  end;

begin
  if FIrregularGrid then FillIrregularGrid
                    else FillRegularGrid;

  if XCount<>NumXValues then FNumXValues:=XCount;
  if ZCount<>NumZValues then FNumZValues:=ZCount;
end;

Function TCustom3DGridS