graphdrawu.pas

   1 { Copyright (C) 2005 Bas Steendijk and Peter Green\r
   2   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   3     which is included in the package\r
   4       ----------------------------------------------------------------------------- }\r
   5 \r
   6 //main unit for graph drawing demo\r
   7 \r
   8 //draws a sine and cosine graph into a 2 bit per pixel\r
   9 //array.\r
  10 //Copies it into a truecolor tbitmap (that is visible on the main form).\r
  11 //saves the graph from the original buffer to a 2 bit palleted png\r
  12 //saves the graph from the original buffer to a 2 bit greyscale png\r
  13 //saves the graph from the tbitmap into a 24 bit truecolor bitmap\r
  14 \r
  15 unit graphdrawu;\r
  16 \r
  17 interface\r
  18 \r
  19 uses\r
  20   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,\r
  21   ExtCtrls,pngwrite,pngwritetbitmap;\r
  22 \r
  23 type\r
  24   TForm1 = class(TForm)\r
  25     Image1: TImage;\r
  26     procedure FormCreate(Sender: TObject);\r
  27   private\r
  28     { Private declarations }\r
  29   public\r
  30     { Public declarations }\r
  31   end;\r
  32 \r
  33 var\r
  34   Form1: TForm1;\r
  35   pal : array[0..11] of byte;\r
  36 implementation\r
  37 \r
  38 {$R *.DFM}\r
  39 \r
  40 type\r
  41   tlinedata = array[word] of byte;\r
  42   plinedata = ^tlinedata;\r
  43   timagedata = array[word] of plinedata;\r
  44   pimagedata = ^timagedata;\r
  45 var\r
  46   imagedata : pimagedata;\r
  47 procedure TForm1.FormCreate(Sender: TObject);\r
  48 var\r
  49   counter : integer;\r
  50   inner : integer;\r
  51   y : integer;\r
  52   bitmapscanline : plinedata;\r
  53   tempfloat : extended;\r
  54   currentindex : integer;\r
  55   fracpart : integer;\r
  56   f : tpngwrite;\r
  57   stream : tfilestream;\r
  58 begin\r
  59   //black\r
  60   pal[ 0] := 0;\r
  61   pal[ 1] := 0;\r
  62   pal[ 2] := 0;\r
  63 \r
  64   //blue\r
  65   pal[ 3] := 0;\r
  66   pal[ 4] := 0;\r
  67   pal[ 5] := $FF;\r
  68 \r
  69   //red\r
  70   pal[ 6] := $FF;\r
  71   pal[ 7] := 0;\r
  72   pal[ 8] := 0;\r
  73 \r
  74   //white\r
  75   pal[ 9] := $ff;\r
  76   pal[10] := $ff;\r
  77   pal[11] := $FF;\r
  78 \r
  79   imagedata := allocmem(image1.height*sizeof(plinedata));\r
  80   image1.width := (image1.width div 4)*4;\r
  81   image1.width := image1.width;\r
  82   for counter := 0 to image1.height-1 do begin\r
  83 \r
  84     imagedata[counter] := allocmem(image1.width div 4);\r
  85     imagedata[counter][image1.width div 8] := imagedata[counter][image1.width div 8] or $C0;\r
  86 \r
  87   end;\r
  88   fillchar(imagedata[image1.height div 2]^,image1.width div 4,#$FF);\r
  89   for counter := 0 to image1.width-1 do begin\r
  90 //    tempfloat := ;\r
  91     for fracpart := 0 to 15 do begin\r
  92       y := round(  -sin((( (counter+(fracpart/15)) / image1.width){+0.5}) *2*pi  ) *((image1.height-20)div 2) )+((image1.height)div 2);\r
  93       //writeln(y);\r
  94       imagedata[y][counter div 4] := (imagedata[y][counter div 4]) or  (1 shl (((counter and $3)xor$3)*2)  );\r
  95 \r
  96       y := round(  -cos((( (counter+(fracpart/15)) / image1.width){+0.5}) *2*pi  ) *((image1.height-20)div 2) )+((image1.height)div 2);\r
  97       //writeln(y);\r
  98       imagedata[y][counter div 4] := (imagedata[y][counter div 4]) or  (2 shl (((counter and $3)xor$3)*2)  );\r
  99     end ;\r
 100   end;\r
 101   image1.Picture.Bitmap.PixelFormat :=pf24bit;\r
 102   image1.picture.bitmap.width := image1.width;\r
 103   image1.picture.bitmap.height := image1.height;\r
 104 \r
 105 \r
 106   for counter := 0 to image1.height-1 do begin\r
 107     bitmapscanline := image1.picture.bitmap.ScanLine[counter];\r
 108     for inner := 0 to image1.width-1 do begin\r
 109 \r
 110       currentindex := (imagedata[counter][inner div 4] shr (((inner and $3)xor$3)*2)   ) and $3;\r
 111       //if (counter=0) and (imagedata[counter][inner div 4] <> 0) then begin\r
 112       //  writeln(imagedata[counter][inner div 4]);\r
 113       //  writeln(currentindex);\r
 114       //  writeln;\r
 115       //end;\r
 116       bitmapscanline[(inner*3)  ] := pal[(currentindex*3)+2];\r
 117       bitmapscanline[(inner*3)+1] := pal[(currentindex*3)+1];\r
 118       bitmapscanline[(inner*3)+2] := pal[(currentindex*3)  ];\r
 119 \r
 120     end;\r
 121   end;\r
 122   image1.invalidate;\r
 123 \r
 124   stream := tfilestream.Create('truecolor.png',fmCreate{fmOpenWrite} or fmShareDenyNone );\r
 125   try\r
 126     savetbitmaptopng(image1.picture.Bitmap,stream);\r
 127   finally\r
 128     stream.Free;\r
 129   end;\r
 130 \r
 131   stream := tfilestream.Create('4grey.png',fmCreate{fmOpenWrite} or fmShareDenyNone     );\r
 132   try\r
 133     pngstart(f,stream,2,ctgreyscale ,image1.picture.Bitmap.Height,image1.Picture.Bitmap.Width);\r
 134     pngstartdata(f);\r
 135 \r
 136     for counter := 0 to image1.picture.Bitmap.Height-1 do begin\r
 137       pngwritescanline(f,imagedata[counter]);\r
 138     end;\r
 139     pngfinishdata(f);\r
 140     pngfinish(f);\r
 141   finally\r
 142     stream.Free;\r
 143   end;\r
 144 \r
 145   stream := tfilestream.Create('4color.png',fmCreate{fmOpenWrite} or fmShareDenyNone    );\r
 146   try\r
 147     pngstart(f,stream,2,ctpallette ,image1.picture.Bitmap.Height,image1.Picture.Bitmap.Width);\r
 148     pngwritepal(f,@pal,4);\r
 149     pngstartdata(f);\r
 150 \r
 151     for counter := 0 to image1.picture.Bitmap.Height-1 do begin\r
 152       pngwritescanline(f,imagedata[counter]);\r
 153     end;\r
 154     pngfinishdata(f);\r
 155     pngfinish(f);\r
 156   finally\r
 157     stream.Free;\r
 158   end;\r
 159 \r
 160 \r
 161 \r
 162 end;\r
 163 \r
 164 end.\r