home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
pascal
/
library
/
windows
/
pchart
/
charts.pas
next >
Wrap
Pascal/Delphi Source File
|
1991-05-02
|
15KB
|
597 lines
{**************************************************}
{ 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.