{**************************************************}
{  This unit defines the chart types used in the   }
{  Windows charting program PCHART.PAS.            }
{                  Zack Urlocker                   }
{                    05/02/91                      }
{                                                  }
{  Five types are defined:                         }
{       TChart:       formal type for inheritance  }
{       THBarChart:   horizontal bar chart         }
{       TVBarChart:   vertical bar chart           }
{       TV3DBarChart: vertical 3D bar chart        }
{       TPieChart:    pie chart                    }
{  all types have a common protocol that includes  }
{  drawing, rescaling and stream storage           }
{**************************************************}

unit Charts;

{$IFDEF Final}        { Remove debug code for final version}
{$D-,I-,L-,R-,S-}
{$ELSE}
{$D+,I+,L+,R+,S+}
{$ENDIF}
interface

uses WObjects, Dicts, WinTypes, WinProcs, Strings, StdDlgs, WinDOS;

type

{ Abstract type provides inheritance for other chart types }
PChart = ^TChart;
TChart = object(TObject)
{ Object fields }
  Name : PChar;            { title string         }
  Scale : TPoint;          { scaling factor       }
  Area : TPoint;           { size of the chart    }
  Lead : TPoint;           { lead before edges    }
  Space : Integer;         { space between items  }
  Items : PDict;           { key->value pairs     }

{ Functions and procedures }
  constructor Init;        { so that inheritance works }
  destructor Done; virtual;{ to clean up memory }
  procedure Draw(DC : HDC); virtual;
  procedure DrawTitle(DC : HDC); virtual;
  procedure DrawLabels(DC : HDC); virtual;
  procedure DrawData(DC : HDC); virtual;
  procedure ReScale; virtual;
  procedure AdjustScale(max : Integer); virtual;
  function getItem(x, y : integer) : PAssoc; virtual;
  constructor Load(var S: TStream);
  procedure Store(var S: TStream);
  procedure add(Key : PChar; Value : Integer);
  procedure remove(Key : PChar);
  procedure ResetLead; virtual;
  procedure ResetSpace; virtual;
end;  { Chart }

PHBarChart = ^THBarChart;
THBarChart = object(TChart)          { Horizontal bars }
  procedure DrawLabels(DC : HDC); virtual;
  procedure DrawData(DC : HDC); virtual;
  procedure AdjustScale(max : Integer); virtual;
  function getItem(x, y : integer) : PAssoc; virtual;
  procedure ResetLead; virtual;
end;  { THBarChart }

PVBarChart = ^TVBarChart;
TVBarChart = object(TChart)          { Vertical bars }
  procedure DrawLabels(DC : HDC); virtual;
  procedure DrawData(DC : HDC); virtual;
  procedure AdjustScale(max : Integer); virtual;
  function getItem(x, y : integer) : PAssoc; virtual;
  procedure ResetSpace; virtual;
  procedure ResetLead; virtual;
end;  { TVBarChart }

PV3DBarChart = ^TV3DBarChart;        { Vertical 3D bars }
TV3DBarChart = object(TVBarChart)
  procedure DrawData(DC : HDC); virtual;
end;  { V3DBarChart }

PPieChart = ^TPieChart;
TPieChart = object(TChart)           { Pie charts }
  procedure DrawLabels(DC : HDC); virtual;
  procedure DrawData(DC : HDC); virtual;
  procedure AdjustScale(max : Integer); virtual;
  function getItem(x, y : integer) : PAssoc; virtual;
  procedure ResetSpace; virtual;
end;  { TPieChart }


implementation

const
  Black = $000000;       { Windows color constants }
  White = $FFFFFF;
  Blue  = $FF0000;
  Green = $00FF00;
  Red   = $0000FF;


{ *********   Chart  ********* }

constructor TChart.Init;
begin
  GetMem(Name, 255);
  Scale.x := 0;
  Scale.y := 0;
  Area.x := 0;
  Area.y := 0;
  ResetLead;
  ResetSpace;
  new(Items, init(10,5));
end;

{ Dispose of the chart by deallocating memory. }
destructor TChart.Done;
begin
  StrDispose(Name);
  Items^.Done;
end;

{ Draw a chart in the area }
procedure TChart.Draw(DC : HDC);
var s : array[0..16] of char;
begin
  if Name <> nil then
    DrawTitle(DC);
  if items^.size > 0 then
  begin
    DrawLabels(DC);
    DrawData(DC);
  end
  else
  begin
    strPCopy(S, '(Empty chart)');
    TextOut(DC, 1, 2, s, strLen(s));
  end;
end;

{ Draw the title, centered in a custom font}
procedure TChart.DrawTitle(DC : HDC);
var FontInfo: TLogFont;
    oldFont, newFont : HFont;
    x : Integer;
begin
  { set the font }
  with FontInfo do
  begin
    lfHeight := 30;
    lfWidth := 0;
    lfWeight := 700;
    lfItalic := 0;
    lfUnderLine := 0;
    lfStrikeOut := 0;
    lfQuality := Proof_Quality;
    strPcopy(lfFaceName, 'Tms Rmn');
  end;

  newFont := createFontIndirect(FontInfo);
  OldFont := SelectObject(DC, newFont);

  x := area.x div 2 - strLen(Name) * 10;
  TextOut(DC, x, 1, Name, strLen(Name));

  { Reset the font when done }
  selectObject(DC, oldFont);
  DeleteObject(newFont);
end;

{ Force the chart to adjust its scale }
procedure TChart.ReScale;
var Max : Integer;
begin
  Max := Items^.MaxValue;
  If Max > 0 then
  begin
    resetLead;
    resetSpace;
    adjustScale(Max);
  end;
end;

{ Abstract methods that must be implemented in descendant classes. }
procedure TChart.DrawData(DC : HDC);
begin
  abstract;
end;

procedure TChart.DrawLabels(DC : HDC);
begin
  abstract;
end;

procedure TChart.AdjustScale(max:Integer);
begin
  abstract;
end;

function TChart.getItem(x, y : integer) : PAssoc;
begin
  abstract;
end;


{ File and stream I/O methods }

constructor TChart.Load(var S:TStream);
{ Load a chart from a stream. Must be read in same order written. }
begin
  Name := S.StrRead;
  Items := PDict(S.Get);
end;

procedure TChart.Store(var S:TStream);
{ Store a chart onto a stream. Not all object fields are stored.
  For example, scale, area, lead, space are set properly when
  you rescale. Must be read in the exact same order. }
begin
  S.StrWrite(Name);
  S.Put(Items);
end;

{ Miscelaneous access methods }

procedure TChart.add(Key : PChar; Value : Integer);
begin
  Items^.update(Key, Value);
end;

procedure TChart.remove(Key : PChar);
begin
  Items^.remove(Key);
end;

procedure TChart.ResetLead;
begin
  Lead.x := 10;
  Lead.y := 30;
end;

procedure TChart.ResetSpace;
begin
  Space := 10;
end;


{ *********   THBarChart  ********* }

{ Draw labels with a stock font }
procedure THBarChart.DrawLabels(DC : HDC);
var I, x, y : Integer;
    str : PChar;

  procedure DrawLabel(Item : PAssoc); far;
  begin
    y := Lead.y + i*(Scale.y + space);
    str := Item^.key;
    TextOut(DC, x, y, str, strLen(str));
    inc(i);
  end;

begin
  x := 1;
  i := 0;
  selectObject(DC, getStockObject(ansi_fixed_font));
  Items^.ForEach(@DrawLabel);
  selectObject(DC, getStockObject(system_font));
end;

{ Draw the bars in the chart }
procedure THBarChart.DrawData(DC : HDC);
var I, x, y : Integer;

  procedure DrawItem(Item : PAssoc); far;
  begin
    y := Lead.y + i*(Scale.y + space);
    Rectangle(DC, x, y, round(x+Item^.value*scale.x), y+scale.y);
    inc(i);
  end;

begin
  x := lead.x;
  i := 0;
  SelectObject(DC, CreateSolidBrush(Blue));
  Items^.ForEach(@DrawItem);
  DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
end;

{ Adjust the scale horizontally }
procedure THBarChart.AdjustScale(max : Integer);
begin
  scale.x := (area.x - 2 * lead.x) div max;
  scale.y := 25;
end;

{ Return item found at location x, y }
function THBarChart.getItem(x, y : integer) : PAssoc;
var index : Integer;
begin
 index := trunc((y - lead.y)/ (scale.y + space));
 if index < Items^.size then
   getItem := Items^.at(index)
 else
   getItem := nil;
end;

{ Reset the lead for this type of chart }
procedure THBarChart.resetLead;
begin
  lead.x := 60;
  lead.y := 30;
end;


{ *********   TVBarChart  ********* }

{ Draw labels in color font }
procedure TVBarChart.DrawLabels(DC : HDC);
var I, x, y : Integer;
    str : PChar;

  procedure DrawLabel(Item : PAssoc); far;
  begin
    x := i*(Scale.x+space) + lead.x;
    str := Item^.key;
    TextOut(DC, x, y, str, strLen(str));
    inc(i);
  end;

begin
  i := 0;
  y := area.y - lead.y+1;
  setTextColor(DC, Blue);
  Items^.ForEach(@DrawLabel);
  setTextColor(DC, Black);
end;

{ Draw the bars in the chart }
procedure TVBarChart.DrawData(DC : HDC);
var I, x, y : Integer;

  procedure DrawItem(Item : PAssoc); far;
  begin
    x := Lead.x + i*(Scale.x + space);
    Rectangle(DC, x+Scale.x, area.y - lead.y, x,
     round(area.y-lead.y-Item^.value*scale.y));
    inc(i);
  end;

begin
  i := 0;
  SelectObject(DC, CreateSolidBrush(Red));
  Items^.ForEach(@DrawItem);
  DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
end;

{ Adjust the scale vertically }
procedure TVBarChart.AdjustScale(max : Integer);
begin
  scale.x := 30;
  scale.y := (area.y - 2 * lead.y) div max;
end;

{ Return item found at location x, y }
function TVBarChart.getItem(x, y : integer) : PAssoc;
var index : Integer;
begin
 index := trunc((x - lead.x)/ (scale.x + space));
  if index < items^.size then
   getItem := Items^.at(index)
 else
   getItem := nil;
end;

{ Reset the lead for this type of chart }
procedure TVBarChart.resetLead;
begin
  lead.x := 10;
  lead.y := 30;
end;

{ Reset the space for this type of chart }
procedure TVBarChart.ResetSpace;
begin
  Space := 30;
end;


{ *********   V3DBarChart *********}

{ Draw each 3D bar as a vertical bar, side and top polygons }
procedure TV3DBarChart.DrawData(DC : HDC);
var I, x, y : Integer;

  procedure DrawItem(Item : PAssoc); far;
  var points : array[1..4] of TPoint;
  begin
    x := Lead.x + i*(Scale.x + space);
    y := area.y-lead.y-Item^.value*scale.y;
    { regular vertical bar }
     Rectangle(DC, x+Scale.x, area.y - lead.y, x, y);
    { right side }
    points[1].x := x+Scale.x - 1 ;
    points[1].y := area.y - lead.y - 1;
    points[2].x := x+Scale.x + space div 2 - 1;
    points[2].y := area.y - lead.y - space div 2 - 1;
    points[3].x := points[2].x;
    points[3].y := y - space div 2;
    points[4].x := x+Scale.x - 1;
    points[4].y := y;
    Polygon(DC, points, 4);
    { top }
    points[1].x := x;
    points[1].y := points[4].y;
    points[2].x := x + space div 2;
    points[2].y := points[3].y;
    Polygon(DC, points, 4);
    inc(i);
  end;

begin
  i := 0;
  SelectObject(DC, CreateSolidBrush(Green));
  Items^.ForEach(@DrawItem);
  DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
end;


{ *********   TPieChart  ********* }

const
  { This table is used to cycle through RGB values of 0,
    128, 255 for each color.  This provides 27 patterns,
    of which normally any consecutive 10 are unique. }
    colors : array[0..2] of byte = (0, 128, 255);

{ Draw the labels and legends using a custom logical font }
procedure TPieChart.DrawLabels(DC : HDC);
var I, x, y : Integer;
    s : PChar;
    newFont, oldFont : hFont;
    FontInfo : TLogFont;

  procedure DrawLabel(Item : PAssoc); far;
  var color : integer;
  begin
    y := lead.y + i * space;
    s := Item^.key;
    TextOut(DC, x, y, s, strLen(s));

    {$R-  can cause a range error }
    color := RGB(colors[I mod 3],
                 colors[(I div 3) mod 3],
                 colors[(I div 9) mod 3]);
    {$R+  can cause a range error }
    SelectObject(DC, CreateSolidBrush(color));
    Rectangle(DC, x + 60, y, x + 90, y + space div 2);
    DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
    inc(i);
  end;

begin
  { Create a logical font and select it }
  with FontInfo do
  begin
    lfHeight := 18;
    lfWidth := 0;
    lfWeight := 700;
    lfUnderLine := 0;
    lfStrikeOut := 0;
    lfItalic := 0;
    strPcopy(lfFaceName, 'Tms Rmn');
  end;
  newFont := createFontIndirect(FontInfo);
  OldFont := SelectObject(DC, newFont);
  x := scale.x + space;
  i := 0;
  Items^.ForEach(@DrawLabel);
  { Reset the font when done }
  selectObject(DC, oldFont);
  DeleteObject(newFont);
end;

const TWO_PI = Pi * 2.0;

{ Draw the wedges in the pie }
procedure TPieChart.DrawData(DC : HDC);
var i, x, y, total : Integer;
    nsum : array [0..26] of Integer;

  { Accumulate running total for Pies }
  procedure addItems(Item : PAssoc); far;
  begin
    nsum[i+1] := nsum[i] + Item^.Value;
    inc(i);
  end;

  procedure DrawItem(Item : PAssoc); far;
  var color : Integer;
  begin
    {$R-  can cause a range error }
    color := RGB(colors[I mod 3],
                 colors[(I div 3) mod 3],
                 colors[(I div 9) mod 3]);
    {$R+  can cause a range error }
    SelectObject(DC, CreateSolidBrush(color));
    Pie(DC, lead.x, lead.y,
      scale.x+lead.x, scale.y+lead.y,
      round(((x*cos(TWO_PI*nSum[i+1]/total)))+x)+lead.x,
      round(((y*sin(TWO_PI*nSum[i+1]/total)))+y)+lead.y,
      round(((x*cos(TWO_PI*nSum[i]/total)))+x)+lead.x,
      round(((y*sin(TWO_PI*nSum[i]/total)))+y)+lead.y);
    DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
    inc(i);
  end;

begin
  nsum[0] := 0;
  i := 0;
  Items^.ForEach(@AddItems);
  total := nsum[items^.size];
  x := scale.x div 2;
  y := scale.y div 2;
  i := 0;
  Items^.ForEach(@DrawItem);
end;

{ Adjust the scale horizontally }
procedure TPieChart.AdjustScale(max : Integer);
begin
  scale.x := round(0.95 *(area.y - lead.y));
  scale.y := scale.x;
end;

{ Return item found at legend location x, y }
function TPieChart.getItem(x, y : integer) : PAssoc;
var index : Integer;
begin
 index := trunc((y - lead.y)/ (space));
 if (index < items^.size) and (x >= scale.x + space) then
   getItem := Items^.at(index)
 else
   getItem := nil;
end;

{ Adjust the space for this type of chart }
procedure TPieChart.resetSpace;
begin
  space := area.y div 7;
end;


{ Stream Registration records for each chart type }

const
  RChart: TStreamRec = (
    ObjType: 1002;
    VmtLink: Ofs(TypeOf(TChart)^);
    Load: @TChart.load;
    Store: @TChart.store);

  RHBarChart: TStreamRec = (
    ObjType: 1003;
    VmtLink: Ofs(TypeOf(THBarChart)^);
    Load: @THBarChart.load;
    Store: @THBarChart.store);

  RVBarChart: TStreamRec = (
    ObjType: 1004;
    VmtLink: Ofs(TypeOf(TVBarChart)^);
    Load: @TVBarChart.load;
    Store: @TVBarChart.store);

  RV3DBarChart: TStreamRec = (
    ObjType: 1005;
    VmtLink: Ofs(TypeOf(TV3DBarChart)^);
    Load: @TV3DBarChart.load;
    Store: @TV3DBarChart.store);

  RPieChart: TStreamRec = (
    ObjType: 1006;
    VmtLink: Ofs(TypeOf(TPieChart)^);
    Load: @TPieChart.load;
    Store: @TPieChart.store);


{ Initialization }
begin
  RegisterType(RChart);
  RegisterType(RHBarChart);
  RegisterType(RVBarChart);
  RegisterType(RV3DBarChart);
  RegisterType(RPieChart);
end.