ucommon.pas

这是一个股票盘后数据分析系统基础底层,已经实现了基本的K线图的重现,RIS线,均线图的重现, 是在一个台湾高手发布的原码上修改的,现在支持通达信的股票数据格式.

    end;
  end;
end;

function _calcMDAC_(Data: TArrayOfSingle; EMA: Integer): TArrayOfSingle;
var
  I                 : Integer;
begin
  Result := nil;
  if Length(Data) * EMA = 0 then
    Exit;
  SetLength(Result, Length(Data));
  for I := 0 to Length(Data) - 1 do //Length(UD)-1 do
  begin
    if I = 0 then
    begin
      //初值
      Result[i] := 0 ;
    end
    else
    begin
      Result[I] := Result[I - 1] * (EMA - 1) / (EMA + 1) + Data[i] * 2 / (EMA + 1);
    end;
  end;
end;

function _valid_(Index, loBound, hiBound: Integer): Boolean;
begin
  Result := (Index >= loBound) and (Index <= hiBound);
end;

procedure _setPen_(Canvas: TCanvas; Color: TColor; Width: Integer; Style: TPenStyle; Mode: TPenMode);
begin
  _setPen_(Canvas.Pen, Color, Width, Style, Mode);
end;

procedure _setPen_(Pen: TPen; Color: TColor; Width: Integer; Style: TPenStyle; Mode: TPenMode);
begin
  Pen.Color := Color;
  Pen.Width := Width;
  Pen.Style := Style;
  Pen.Mode := Mode;
end;

procedure _setBrush_(Canvas: TCanvas; Color: TColor; Style: TBrushStyle);
begin
  _setBrush_(Canvas.Brush, Color, Style);
end;

procedure _setBrush_(Brush: TBrush; Color: TColor; Style: TBrushStyle);
begin
  Brush.Color := Color;
  Brush.Style := Style;
end;

function _offset_(R: TRect; dx, dy: Integer): TRect;
begin
  OffsetRect(R, dx, dy);
  Result := R;
end;

function _calcRSI_(UD: TArrayOfSingle; RSIC: Integer): TArrayOfSingle;
var
  I                 : Integer;
  au, ad            : Single; //RSI 最后一笔au, ad
begin
  au := 0;
  ad := 0;
  SetLength(Result, Length(UD));
  if (Length(UD) < 2) or (RSIC < 2) then
    EXIT;

  for I := 0 to Length(UD) - 1 do //Length(UD)-1 do
  begin
    if I = 0 then
    begin
      //初值
      au := Max(0, UD[I]); ad := Max(0, -UD[I]); Result[I] := 50;
    end
    else
    begin
      au := (au * (RSIC - 1) + Max(0, UD[I])) / RSIC;
      ad := (ad * (RSIC - 1) + Max(0, -UD[I])) / RSIC;
      Result[I] := Result[I - 1] * 2 / 3 + _div_(au, au + ad) * 100 / 3
    end;
  end;
end;

function _div_(Value, DivNum: Single; DefaultWhenDivZero: Single): Extended;
begin
  try
    if DivNum <> 0 then
      Result := Value / DivNum
    else
      Result := DefaultWhenDivZero;
  except
    Result := 0;
  end;
end;

procedure DRAW_HORZ_SCALE(C: TCanvas; R: TRect; L, H, LL, HH: Single; LineCount: Integer; RoundToPrice: Boolean);
var
  I, Y              : Integer;
  D                 : Single;
begin
  LineCount := Max(3, LineCount div 2 * 2 + 1);
  D := _div_(H - L, LineCount - 1);
  SetLength(FValueList, LineCount);
  FValueList[0] := H;
  for I := 1 to LineCount - 2 do
    FValueList[I] := H - D * I;
  FValueList[LineCount - 1] := L;

  if RoundToPrice then
  begin
    D := (H + L) / 2;
    for I := 0 to LineCount - 1 do
    begin
      if FValueList[I] > D then
        FValueList[I] := _round_(FValueList[I], 0)
      else if FValueList[I] < D then
        FValueList[I] := _round_(FValueList[I], 1);
    end;
  end;

  _setPen_(C, cl3DDkShadow, 1, psDot, pmCopy);
  _setBrush_(C, clBlack, bsSolid);
  for I := 0 to LineCount - 1 do
  begin
    Y := Fy2Iy(FValueList[I], R, HH, LL);
    C.MoveTo(R.Left + 1, Y);
    C.LineTo(R.Right - 1, Y);
  end;

end;

procedure DRAW_SCALE(C: TCanvas; R: TRect; Values: TArrayOfSingle; L, H, LL, HH: Single);
var
  I, TW, TH, Y, GapX, Precise: Integer;
  Rt                : TRect;
begin
  if Length(Values) = 0 then
    Exit;

  _setBrush_(C, clBlack, bsSolid);
  C.Font.Name := '宋体';
  C.Font.Height := Min(_height_(R) div Length(Values), Round(_width_(R) / 3.5));
  TH := C.TextHeight('0');
  if H > 1500 then
    Precise := 0
  else
    Precise := 2;

  TW := C.TextWidth(_vs_(H, Precise, True, False)) + 4;
  GapX := Max(0, (_width_(R) - TW) div 2);
  for I := 0 to Length(Values) - 1 do
  begin
    Y := Fy2Iy(Values[I], R, HH, LL);
    Rt := Rect(0, 0, TW, TH);
    InflateRect(Rt, -2, 0);
    OffsetRect(Rt, R.Left + GapX - 3, Y - TH div 2);
    if Rt.Bottom < R.Bottom + 2 then
      _textRect_(C, Rt, _vs_(Values[I], Precise, True, false), clred, clBlack, taRightJustify); //这里是画边上的界尺
  end;
end;

procedure DRAW_SCALE(C: TCanvas; R: TRect; Values: TArrayOfSingle; L, H, LL, HH: Single; Vol: Boolean);
var
  I, TW, TH, Y, GapX, Precise: Integer;
  Rt                : TRect;
begin
  if Length(Values) = 0 then
    Exit;

  _setBrush_(C, clBlack, bsSolid);
  C.Font.Name := '宋体';
  C.Font.Height := Min(_height_(R) div Length(Values), Round(_width_(R) / 3.5));
  TH := C.TextHeight('0');
  if H > 1000 then
    Precise := 0
  else
    Precise := 2;

  TW := C.TextWidth(_vs_(H, Precise, True, False)) + 4;
  GapX := Max(0, (_width_(R) - TW) div 2);
  for I := 0 to Length(Values) - 1 do
  begin
    Y := Fy2Iy(Values[I], R, HH, LL);
    Rt := Rect(1, 0, TW, TH);
    InflateRect(Rt, -3, 0);
    OffsetRect(Rt, R.Left + GapX - 2, Y - TH div 2);
    if Rt.Bottom < R.Bottom + 2 then
      if (Vol) then
      begin
        _textRect_(C, Rt, _vs_(Values[I] / 100, Precise, True, false), clred, clBlack, taRightJustify); //这里是画边上的界尺
      end
      else
      begin
        _textRect_(C, Rt, _vs_(Values[I], Precise, True, false), clred, clBlack, taRightJustify); //这里是画边上的界尺
      end;

  end;
end;

procedure DRAW_SCALE(C: TCanvas; R: TRect; L, H, LL, HH: Single; LineCount: Integer; RoundToPrice: Boolean);
var
  I                 : Integer;
  D                 : Single;
begin
  LineCount := Max(3, LineCount div 2 * 2 + 1);
  D := _div_(H - L, LineCount - 1);
  SetLength(FValueList, LineCount);
  FValueList[0] := H;
  for I := 1 to LineCount - 2 do
    FValueList[I] := (H - D * I);

  FValueList[LineCount - 1] := L;

  if RoundToPrice then
  begin
    D := (H + L) / 2;
    for I := 0 to LineCount - 1 do
    begin
      if FValueList[I] > D then
        FValueList[I] := _round_(FValueList[I], 0)
      else if FValueList[I] < D then
        FValueList[I] := _round_(FValueList[I], 1);
    end;
  end;

  DRAW_SCALE(C, R, FValueList, L, H, LL, HH);

end;

procedure DRAW_SCALE(C: TCanvas; R: TRect; L, H, LL, HH: Single; LineCount: Integer; RoundToPrice: Boolean; Vol: Boolean);
var
  I                 : Integer;
  D                 : Single;
begin
  LineCount := Max(3, LineCount div 2 * 2 + 1);
  D := _div_(H - L, LineCount - 1);
  SetLength(FValueList, LineCount);
  FValueList[0] := H;
  for I := 1 to LineCount - 2 do
    FValueList[I] := (H - D * I);

  FValueList[LineCount - 1] := L;

  if RoundToPrice then
  begin
    D := (H + L) / 2;
    for I := 0 to LineCount - 1 do
    begin
      if FValueList[I] > D then
        FValueList[I] := _round_(FValueList[I], 0)
      else if FValueList[I] < D then
        FValueList[I] := _round_(FValueList[I], 1);
    end;
  end;
  if (Vol) then
  begin
    DRAW_SCALE(C, R, FValueList, L, H, LL, HH, True);
  end
  else
  begin
    DRAW_SCALE(C, R, FValueList, L, H, LL, HH);
  end;

end;

function _round_(Price: Single; ued: Integer): Single;

  function DoRound(Price: Single; Precise: Single = 0.01): Single;
  begin
    Result := 0;
    if Precise > 0 then
    begin
      case ued of
        -1: Result := Trunc(Price / Precise) * Precise;
        1: Result := Round((Price + Precise / 2) / Precise) * Precise;
      else
        Result := Trunc((Price + Precise / 2) / Precise) * Precise
      end;
    end;
  end;

begin
  if Price < 10 then
    Result := DoRound(Price, 0.01)
  else if Price < 50 then
    Result := DoRound(Price, 0.05)
  else if Price < 100 then
    Result := DoRound(Price, 0.1)
  else if Price < 500 then
    Result := DoRound(Price, 0.5)
  else if Price < 1000 then
    Result := DoRound(Price, 1)
  else if Price < 5000 then
    Result := DoRound(Price, 5)
  else if Price < 10000 then
    Result := DoRound(Price, 10)
  else
    Result := DoRound(Price, 100);
end;

function ArrayOdSingle(A: array of Single): TArrayOfSingle;
var
  I                 : Integer;
begin
  SetLength(Result, Length(A));
  for I := 0 to Length(A) - 1 do
    Result[I] := A[I];
end;

function Fy2Iy(FY: Single; R: TRect; ScaleHigh, ScaleLow: Single): Integer;
var
  RatioY            : Single;
begin
  Result := 0;
  if (ScaleHigh > ScaleLow) and (_height_(R) > 0) then
  begin
    RatioY := (ScaleHigh - ScaleLow) / _height_(R);
    if RatioY > 0 then
      Result := R.Top + Round((ScaleHigh - FY) / RatioY);
  end;
end;

procedure _textRectBackground_(Canvas: TCanvas;
  Rect: TRect;
  mStr: string;
  FontHeight: Integer = -1;
  fgColor: TColor = clWhite;
  bgColor: TColor = clBlack;
  Alignment: TAlignment = taCenter;
  Layout: TTextLayout = tlCenter;
  Transparent: Boolean = False;
  IsFontBold: Boolean = False);
var
  I, J, P           : Integer;
  bmp               : TBitmap;
  BitmapRect        : TRect;
  S                 : array[0..1] of string;
  AL                : TAlignment;
  TR                : Boolean;
begin
  bmp := TBitmap.Create;
  _setupBitmap_(Canvas, bmp, Rect, BitmapRect);
  bmp.Canvas.Pen.Assign(Canvas.Pen);
  bmp.Canvas.Brush.Assign(Canvas.Brush);
  bmp.Canvas.Font.Assign(Canvas.Font);

  bmp.Canvas.Pen.Assign(Canvas.Pen);
  bmp.Canvas.Pen.Mode := pmCopy;
  bmp.Canvas.Rectangle(BitmapRect);
  BitmapRect := _inflate_(BitmapRect,
    -bmp.Canvas.Pen.Width,
    -bmp.Canvas.Pen.Width);

  if FontHeight = -1 then
    bmp.Canvas.Font.Height := _CalcFontHeight_(BitmapRect, mStr)
  else
    bmp.Canvas.Font.Height := FontHeight;

  if IsFontBold then
    bmp.Canvas.Font.Style := bmp.Canvas.Font.Style + [fsBold];

  P := Pos('|', mStr);
  J := _if_(P > 0, 2, 1);
  S[0] := _if_(P > 0, Trim(Copy(mStr, 1, P - 1)), mStr);
  S[1] := _if_(P > 0, Trim(Copy(mStr, P + 1, Length(mStr) - P - 1)), '');
  AL := Alignment;
  TR := Transparent;
  for I := 0 to J - 1 do
  begin
    if P > 0 then
      AL := _if_(I = 0, taLeftJustify, taRightJustify);

    if P > 0 then
      TR := _if_(I = 0, False, True);

    _textRect_(bmp.Canvas, BitmapRect, S[I], fgColor, bgColor, AL, Layout, TR);
  end;
  Canvas.CopyMode := cmSrcInvert;
  BitmapRect := _inflate_(BitmapRect, bmp.Canvas.Pen.Width, bmp.Canvas.Pen.Width);
  Canvas.CopyRect(Rect, bmp.Canvas, BitmapRect);
  bmp.Free;
end;

procedure _setupBitmap_(Canvas: TCanvas; bmp: TBitmap; Rect: TRect; var BitmapRect: TRect);
begin
  bmp.Width := _width_(Rect);
  bmp.Height := _height_(Rect);
  bmp.Canvas.Pen.Assign(Canvas.Pen);
  bmp.Canvas.Font.Assign(Canvas.Font);
  bmp.Canvas.Brush.Assign(Canvas.Brush);
  BitmapRect := Classes.Rect(0, 0, bmp.Width, bmp.Height);
end;

function _inflate_(R: TRect; dx, dy: Integer): TRect;
begin
  Result := R; InflateRect(Result, dx, dy);
end;

function _CalcFontHeight_(Rect: TRect; const S: string): Integer;
begin
  if Length(S) > 0 then
    Result := Round(Min(_width_(Rect) * 2 / Length(S), _height_(Rect)))
  else
    Result := 0;
end;

end.