home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / WINDOWS / PROGRAM / PCHART.ZIP / CHARTS.PAS next >
Encoding:
Pascal/Delphi Source File  |  1991-05-02  |  14.6 KB  |  597 lines
  1. {**************************************************}
  2. {  This unit defines the chart types used in the   }
  3. {  Windows charting program PCHART.PAS.            }
  4. {                  Zack Urlocker                   }
  5. {                    05/02/91                      }
  6. {                                                  }
  7. {  Five types are defined:                         }
  8. {       TChart:       formal type for inheritance  }
  9. {       THBarChart:   horizontal bar chart         }
  10. {       TVBarChart:   vertical bar chart           }
  11. {       TV3DBarChart: vertical 3D bar chart        }
  12. {       TPieChart:    pie chart                    }
  13. {  all types have a common protocol that includes  }
  14. {  drawing, rescaling and stream storage           }
  15. {**************************************************}
  16.  
  17. unit Charts;
  18.  
  19. {$IFDEF Final}        { Remove debug code for final version}
  20. {$D-,I-,L-,R-,S-}
  21. {$ELSE}
  22. {$D+,I+,L+,R+,S+}
  23. {$ENDIF}
  24. interface
  25.  
  26. uses WObjects, Dicts, WinTypes, WinProcs, Strings, StdDlgs, WinDOS;
  27.  
  28. type
  29.  
  30. { Abstract type provides inheritance for other chart types }
  31. PChart = ^TChart;
  32. TChart = object(TObject)
  33. { Object fields }
  34.   Name : PChar;            { title string         }
  35.   Scale : TPoint;          { scaling factor       }
  36.   Area : TPoint;           { size of the chart    }
  37.   Lead : TPoint;           { lead before edges    }
  38.   Space : Integer;         { space between items  }
  39.   Items : PDict;           { key->value pairs     }
  40.  
  41. { Functions and procedures }
  42.   constructor Init;        { so that inheritance works }
  43.   destructor Done; virtual;{ to clean up memory }
  44.   procedure Draw(DC : HDC); virtual;
  45.   procedure DrawTitle(DC : HDC); virtual;
  46.   procedure DrawLabels(DC : HDC); virtual;
  47.   procedure DrawData(DC : HDC); virtual;
  48.   procedure ReScale; virtual;
  49.   procedure AdjustScale(max : Integer); virtual;
  50.   function getItem(x, y : integer) : PAssoc; virtual;
  51.   constructor Load(var S: TStream);
  52.   procedure Store(var S: TStream);
  53.   procedure add(Key : PChar; Value : Integer);
  54.   procedure remove(Key : PChar);
  55.   procedure ResetLead; virtual;
  56.   procedure ResetSpace; virtual;
  57. end;  { Chart }
  58.  
  59. PHBarChart = ^THBarChart;
  60. THBarChart = object(TChart)          { Horizontal bars }
  61.   procedure DrawLabels(DC : HDC); virtual;
  62.   procedure DrawData(DC : HDC); virtual;
  63.   procedure AdjustScale(max : Integer); virtual;
  64.   function getItem(x, y : integer) : PAssoc; virtual;
  65.   procedure ResetLead; virtual;
  66. end;  { THBarChart }
  67.  
  68. PVBarChart = ^TVBarChart;
  69. TVBarChart = object(TChart)          { Vertical bars }
  70.   procedure DrawLabels(DC : HDC); virtual;
  71.   procedure DrawData(DC : HDC); virtual;
  72.   procedure AdjustScale(max : Integer); virtual;
  73.   function getItem(x, y : integer) : PAssoc; virtual;
  74.   procedure ResetSpace; virtual;
  75.   procedure ResetLead; virtual;
  76. end;  { TVBarChart }
  77.  
  78. PV3DBarChart = ^TV3DBarChart;        { Vertical 3D bars }
  79. TV3DBarChart = object(TVBarChart)
  80.   procedure DrawData(DC : HDC); virtual;
  81. end;  { V3DBarChart }
  82.  
  83. PPieChart = ^TPieChart;
  84. TPieChart = object(TChart)           { Pie charts }
  85.   procedure DrawLabels(DC : HDC); virtual;
  86.   procedure DrawData(DC : HDC); virtual;
  87.   procedure AdjustScale(max : Integer); virtual;
  88.   function getItem(x, y : integer) : PAssoc; virtual;
  89.   procedure ResetSpace; virtual;
  90. end;  { TPieChart }
  91.  
  92.  
  93. implementation
  94.  
  95. const
  96.   Black = $000000;       { Windows color constants }
  97.   White = $FFFFFF;
  98.   Blue  = $FF0000;
  99.   Green = $00FF00;
  100.   Red   = $0000FF;
  101.  
  102.  
  103. { *********   Chart  ********* }
  104.  
  105. constructor TChart.Init;
  106. begin
  107.   GetMem(Name, 255);
  108.   Scale.x := 0;
  109.   Scale.y := 0;
  110.   Area.x := 0;
  111.   Area.y := 0;
  112.   ResetLead;
  113.   ResetSpace;
  114.   new(Items, init(10,5));
  115. end;
  116.  
  117. { Dispose of the chart by deallocating memory. }
  118. destructor TChart.Done;
  119. begin
  120.   StrDispose(Name);
  121.   Items^.Done;
  122. end;
  123.  
  124. { Draw a chart in the area }
  125. procedure TChart.Draw(DC : HDC);
  126. var s : array[0..16] of char;
  127. begin
  128.   if Name <> nil then
  129.     DrawTitle(DC);
  130.   if items^.size > 0 then
  131.   begin
  132.     DrawLabels(DC);
  133.     DrawData(DC);
  134.   end
  135.   else
  136.   begin
  137.     strPCopy(S, '(Empty chart)');
  138.     TextOut(DC, 1, 2, s, strLen(s));
  139.   end;
  140. end;
  141.  
  142. { Draw the title, centered in a custom font}
  143. procedure TChart.DrawTitle(DC : HDC);
  144. var FontInfo: TLogFont;
  145.     oldFont, newFont : HFont;
  146.     x : Integer;
  147. begin
  148.   { set the font }
  149.   with FontInfo do
  150.   begin
  151.     lfHeight := 30;
  152.     lfWidth := 0;
  153.     lfWeight := 700;
  154.     lfItalic := 0;
  155.     lfUnderLine := 0;
  156.     lfStrikeOut := 0;
  157.     lfQuality := Proof_Quality;
  158.     strPcopy(lfFaceName, 'Tms Rmn');
  159.   end;
  160.  
  161.   newFont := createFontIndirect(FontInfo);
  162.   OldFont := SelectObject(DC, newFont);
  163.  
  164.   x := area.x div 2 - strLen(Name) * 10;
  165.   TextOut(DC, x, 1, Name, strLen(Name));
  166.  
  167.   { Reset the font when done }
  168.   selectObject(DC, oldFont);
  169.   DeleteObject(newFont);
  170. end;
  171.  
  172. { Force the chart to adjust its scale }
  173. procedure TChart.ReScale;
  174. var Max : Integer;
  175. begin
  176.   Max := Items^.MaxValue;
  177.   If Max > 0 then
  178.   begin
  179.     resetLead;
  180.     resetSpace;
  181.     adjustScale(Max);
  182.   end;
  183. end;
  184.  
  185. { Abstract methods that must be implemented in descendant classes. }
  186. procedure TChart.DrawData(DC : HDC);
  187. begin
  188.   abstract;
  189. end;
  190.  
  191. procedure TChart.DrawLabels(DC : HDC);
  192. begin
  193.   abstract;
  194. end;
  195.  
  196. procedure TChart.AdjustScale(max:Integer);
  197. begin
  198.   abstract;
  199. end;
  200.  
  201. function TChart.getItem(x, y : integer) : PAssoc;
  202. begin
  203.   abstract;
  204. end;
  205.  
  206.  
  207. { File and stream I/O methods }
  208.  
  209. constructor TChart.Load(var S:TStream);
  210. { Load a chart from a stream. Must be read in same order written. }
  211. begin
  212.   Name := S.StrRead;
  213.   Items := PDict(S.Get);
  214. end;
  215.  
  216. procedure TChart.Store(var S:TStream);
  217. { Store a chart onto a stream. Not all object fields are stored.
  218.   For example, scale, area, lead, space are set properly when
  219.   you rescale. Must be read in the exact same order. }
  220. begin
  221.   S.StrWrite(Name);
  222.   S.Put(Items);
  223. end;
  224.  
  225. { Miscelaneous access methods }
  226.  
  227. procedure TChart.add(Key : PChar; Value : Integer);
  228. begin
  229.   Items^.update(Key, Value);
  230. end;
  231.  
  232. procedure TChart.remove(Key : PChar);
  233. begin
  234.   Items^.remove(Key);
  235. end;
  236.  
  237. procedure TChart.ResetLead;
  238. begin
  239.   Lead.x := 10;
  240.   Lead.y := 30;
  241. end;
  242.  
  243. procedure TChart.ResetSpace;
  244. begin
  245.   Space := 10;
  246. end;
  247.  
  248.  
  249. { *********   THBarChart  ********* }
  250.  
  251. { Draw labels with a stock font }
  252. procedure THBarChart.DrawLabels(DC : HDC);
  253. var I, x, y : Integer;
  254.     str : PChar;
  255.  
  256.   procedure DrawLabel(Item : PAssoc); far;
  257.   begin
  258.     y := Lead.y + i*(Scale.y + space);
  259.     str := Item^.key;
  260.     TextOut(DC, x, y, str, strLen(str));
  261.     inc(i);
  262.   end;
  263.  
  264. begin
  265.   x := 1;
  266.   i := 0;
  267.   selectObject(DC, getStockObject(ansi_fixed_font));
  268.   Items^.ForEach(@DrawLabel);
  269.   selectObject(DC, getStockObject(system_font));
  270. end;
  271.  
  272. { Draw the bars in the chart }
  273. procedure THBarChart.DrawData(DC : HDC);
  274. var I, x, y : Integer;
  275.  
  276.   procedure DrawItem(Item : PAssoc); far;
  277.   begin
  278.     y := Lead.y + i*(Scale.y + space);
  279.     Rectangle(DC, x, y, round(x+Item^.value*scale.x), y+scale.y);
  280.     inc(i);
  281.   end;
  282.  
  283. begin
  284.   x := lead.x;
  285.   i := 0;
  286.   SelectObject(DC, CreateSolidBrush(Blue));
  287.   Items^.ForEach(@DrawItem);
  288.   DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  289. end;
  290.  
  291. { Adjust the scale horizontally }
  292. procedure THBarChart.AdjustScale(max : Integer);
  293. begin
  294.   scale.x := (area.x - 2 * lead.x) div max;
  295.   scale.y := 25;
  296. end;
  297.  
  298. { Return item found at location x, y }
  299. function THBarChart.getItem(x, y : integer) : PAssoc;
  300. var index : Integer;
  301. begin
  302.  index := trunc((y - lead.y)/ (scale.y + space));
  303.  if index < Items^.size then
  304.    getItem := Items^.at(index)
  305.  else
  306.    getItem := nil;
  307. end;
  308.  
  309. { Reset the lead for this type of chart }
  310. procedure THBarChart.resetLead;
  311. begin
  312.   lead.x := 60;
  313.   lead.y := 30;
  314. end;
  315.  
  316.  
  317. { *********   TVBarChart  ********* }
  318.  
  319. { Draw labels in color font }
  320. procedure TVBarChart.DrawLabels(DC : HDC);
  321. var I, x, y : Integer;
  322.     str : PChar;
  323.  
  324.   procedure DrawLabel(Item : PAssoc); far;
  325.   begin
  326.     x := i*(Scale.x+space) + lead.x;
  327.     str := Item^.key;
  328.     TextOut(DC, x, y, str, strLen(str));
  329.     inc(i);
  330.   end;
  331.  
  332. begin
  333.   i := 0;
  334.   y := area.y - lead.y+1;
  335.   setTextColor(DC, Blue);
  336.   Items^.ForEach(@DrawLabel);
  337.   setTextColor(DC, Black);
  338. end;
  339.  
  340. { Draw the bars in the chart }
  341. procedure TVBarChart.DrawData(DC : HDC);
  342. var I, x, y : Integer;
  343.  
  344.   procedure DrawItem(Item : PAssoc); far;
  345.   begin
  346.     x := Lead.x + i*(Scale.x + space);
  347.     Rectangle(DC, x+Scale.x, area.y - lead.y, x,
  348.      round(area.y-lead.y-Item^.value*scale.y));
  349.     inc(i);
  350.   end;
  351.  
  352. begin
  353.   i := 0;
  354.   SelectObject(DC, CreateSolidBrush(Red));
  355.   Items^.ForEach(@DrawItem);
  356.   DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  357. end;
  358.  
  359. { Adjust the scale vertically }
  360. procedure TVBarChart.AdjustScale(max : Integer);
  361. begin
  362.   scale.x := 30;
  363.   scale.y := (area.y - 2 * lead.y) div max;
  364. end;
  365.  
  366. { Return item found at location x, y }
  367. function TVBarChart.getItem(x, y : integer) : PAssoc;
  368. var index : Integer;
  369. begin
  370.  index := trunc((x - lead.x)/ (scale.x + space));
  371.   if index < items^.size then
  372.    getItem := Items^.at(index)
  373.  else
  374.    getItem := nil;
  375. end;
  376.  
  377. { Reset the lead for this type of chart }
  378. procedure TVBarChart.resetLead;
  379. begin
  380.   lead.x := 10;
  381.   lead.y := 30;
  382. end;
  383.  
  384. { Reset the space for this type of chart }
  385. procedure TVBarChart.ResetSpace;
  386. begin
  387.   Space := 30;
  388. end;
  389.  
  390.  
  391. { *********   V3DBarChart *********}
  392.  
  393. { Draw each 3D bar as a vertical bar, side and top polygons }
  394. procedure TV3DBarChart.DrawData(DC : HDC);
  395. var I, x, y : Integer;
  396.  
  397.   procedure DrawItem(Item : PAssoc); far;
  398.   var points : array[1..4] of TPoint;
  399.   begin
  400.     x := Lead.x + i*(Scale.x + space);
  401.     y := area.y-lead.y-Item^.value*scale.y;
  402.     { regular vertical bar }
  403.      Rectangle(DC, x+Scale.x, area.y - lead.y, x, y);
  404.     { right side }
  405.     points[1].x := x+Scale.x - 1 ;
  406.     points[1].y := area.y - lead.y - 1;
  407.     points[2].x := x+Scale.x + space div 2 - 1;
  408.     points[2].y := area.y - lead.y - space div 2 - 1;
  409.     points[3].x := points[2].x;
  410.     points[3].y := y - space div 2;
  411.     points[4].x := x+Scale.x - 1;
  412.     points[4].y := y;
  413.     Polygon(DC, points, 4);
  414.     { top }
  415.     points[1].x := x;
  416.     points[1].y := points[4].y;
  417.     points[2].x := x + space div 2;
  418.     points[2].y := points[3].y;
  419.     Polygon(DC, points, 4);
  420.     inc(i);
  421.   end;
  422.  
  423. begin
  424.   i := 0;
  425.   SelectObject(DC, CreateSolidBrush(Green));
  426.   Items^.ForEach(@DrawItem);
  427.   DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  428. end;
  429.  
  430.  
  431. { *********   TPieChart  ********* }
  432.  
  433. const
  434.   { This table is used to cycle through RGB values of 0,
  435.     128, 255 for each color.  This provides 27 patterns,
  436.     of which normally any consecutive 10 are unique. }
  437.     colors : array[0..2] of byte = (0, 128, 255);
  438.  
  439. { Draw the labels and legends using a custom logical font }
  440. procedure TPieChart.DrawLabels(DC : HDC);
  441. var I, x, y : Integer;
  442.     s : PChar;
  443.     newFont, oldFont : hFont;
  444.     FontInfo : TLogFont;
  445.  
  446.   procedure DrawLabel(Item : PAssoc); far;
  447.   var color : integer;
  448.   begin
  449.     y := lead.y + i * space;
  450.     s := Item^.key;
  451.     TextOut(DC, x, y, s, strLen(s));
  452.  
  453.     {$R-  can cause a range error }
  454.     color := RGB(colors[I mod 3],
  455.                  colors[(I div 3) mod 3],
  456.                  colors[(I div 9) mod 3]);
  457.     {$R+  can cause a range error }
  458.     SelectObject(DC, CreateSolidBrush(color));
  459.     Rectangle(DC, x + 60, y, x + 90, y + space div 2);
  460.     DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  461.     inc(i);
  462.   end;
  463.  
  464. begin
  465.   { Create a logical font and select it }
  466.   with FontInfo do
  467.   begin
  468.     lfHeight := 18;
  469.     lfWidth := 0;
  470.     lfWeight := 700;
  471.     lfUnderLine := 0;
  472.     lfStrikeOut := 0;
  473.     lfItalic := 0;
  474.     strPcopy(lfFaceName, 'Tms Rmn');
  475.   end;
  476.   newFont := createFontIndirect(FontInfo);
  477.   OldFont := SelectObject(DC, newFont);
  478.   x := scale.x + space;
  479.   i := 0;
  480.   Items^.ForEach(@DrawLabel);
  481.   { Reset the font when done }
  482.   selectObject(DC, oldFont);
  483.   DeleteObject(newFont);
  484. end;
  485.  
  486. const TWO_PI = Pi * 2.0;
  487.  
  488. { Draw the wedges in the pie }
  489. procedure TPieChart.DrawData(DC : HDC);
  490. var i, x, y, total : Integer;
  491.     nsum : array [0..26] of Integer;
  492.  
  493.   { Accumulate running total for Pies }
  494.   procedure addItems(Item : PAssoc); far;
  495.   begin
  496.     nsum[i+1] := nsum[i] + Item^.Value;
  497.     inc(i);
  498.   end;
  499.  
  500.   procedure DrawItem(Item : PAssoc); far;
  501.   var color : Integer;
  502.   begin
  503.     {$R-  can cause a range error }
  504.     color := RGB(colors[I mod 3],
  505.                  colors[(I div 3) mod 3],
  506.                  colors[(I div 9) mod 3]);
  507.     {$R+  can cause a range error }
  508.     SelectObject(DC, CreateSolidBrush(color));
  509.     Pie(DC, lead.x, lead.y,
  510.       scale.x+lead.x, scale.y+lead.y,
  511.       round(((x*cos(TWO_PI*nSum[i+1]/total)))+x)+lead.x,
  512.       round(((y*sin(TWO_PI*nSum[i+1]/total)))+y)+lead.y,
  513.       round(((x*cos(TWO_PI*nSum[i]/total)))+x)+lead.x,
  514.       round(((y*sin(TWO_PI*nSum[i]/total)))+y)+lead.y);
  515.     DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  516.     inc(i);
  517.   end;
  518.  
  519. begin
  520.   nsum[0] := 0;
  521.   i := 0;
  522.   Items^.ForEach(@AddItems);
  523.   total := nsum[items^.size];
  524.   x := scale.x div 2;
  525.   y := scale.y div 2;
  526.   i := 0;
  527.   Items^.ForEach(@DrawItem);
  528. end;
  529.  
  530. { Adjust the scale horizontally }
  531. procedure TPieChart.AdjustScale(max : Integer);
  532. begin
  533.   scale.x := round(0.95 *(area.y - lead.y));
  534.   scale.y := scale.x;
  535. end;
  536.  
  537. { Return item found at legend location x, y }
  538. function TPieChart.getItem(x, y : integer) : PAssoc;
  539. var index : Integer;
  540. begin
  541.  index := trunc((y - lead.y)/ (space));
  542.  if (index < items^.size) and (x >= scale.x + space) then
  543.    getItem := Items^.at(index)
  544.  else
  545.    getItem := nil;
  546. end;
  547.  
  548. { Adjust the space for this type of chart }
  549. procedure TPieChart.resetSpace;
  550. begin
  551.   space := area.y div 7;
  552. end;
  553.  
  554.  
  555. { Stream Registration records for each chart type }
  556.  
  557. const
  558.   RChart: TStreamRec = (
  559.     ObjType: 1002;
  560.     VmtLink: Ofs(TypeOf(TChart)^);
  561.     Load: @TChart.load;
  562.     Store: @TChart.store);
  563.  
  564.   RHBarChart: TStreamRec = (
  565.     ObjType: 1003;
  566.     VmtLink: Ofs(TypeOf(THBarChart)^);
  567.     Load: @THBarChart.load;
  568.     Store: @THBarChart.store);
  569.  
  570.   RVBarChart: TStreamRec = (
  571.     ObjType: 1004;
  572.     VmtLink: Ofs(TypeOf(TVBarChart)^);
  573.     Load: @TVBarChart.load;
  574.     Store: @TVBarChart.store);
  575.  
  576.   RV3DBarChart: TStreamRec = (
  577.     ObjType: 1005;
  578.     VmtLink: Ofs(TypeOf(TV3DBarChart)^);
  579.     Load: @TV3DBarChart.load;
  580.     Store: @TV3DBarChart.store);
  581.  
  582.   RPieChart: TStreamRec = (
  583.     ObjType: 1006;
  584.     VmtLink: Ofs(TypeOf(TPieChart)^);
  585.     Load: @TPieChart.load;
  586.     Store: @TPieChart.store);
  587.  
  588.  
  589. { Initialization }
  590. begin
  591.   RegisterType(RChart);
  592.   RegisterType(RHBarChart);
  593.   RegisterType(RVBarChart);
  594.   RegisterType(RV3DBarChart);
  595.   RegisterType(RPieChart);
  596. end.
  597.