home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 November / CDVD1105.ISO / Software / Freeware / programare / graphics32 / Examples / Vcl / ByteMaps_Ex / MainUnit.pas < prev   
Encoding:
Pascal/Delphi Source File  |  2004-07-05  |  7.2 KB  |  285 lines
  1. unit MainUnit;
  2.  
  3. (* ***** BEGIN LICENSE BLOCK *****
  4.  * Version: MPL 1.1
  5.  *
  6.  * The contents of this file are subject to the Mozilla Public License Version
  7.  * 1.1 (the "License"); you may not use this file except in compliance with
  8.  * the License. You may obtain a copy of the License at
  9.  * http://www.mozilla.org/MPL/
  10.  *
  11.  * Software distributed under the License is distributed on an "AS IS" basis,
  12.  * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  13.  * for the specific language governing rights and limitations under the
  14.  * License.
  15.  *
  16.  * The Original Code is Graphics32
  17.  *
  18.  * The Initial Developer of the Original Code is
  19.  * Alex A. Denisov
  20.  *
  21.  * Portions created by the Initial Developer are Copyright (C) 2000-2004
  22.  * the Initial Developer. All Rights Reserved.
  23.  *
  24.  * Contributor(s):
  25.  *
  26.  * ***** END LICENSE BLOCK ***** *)
  27.  
  28. interface
  29.  
  30. uses
  31.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  32.   ExtCtrls, StdCtrls, ComCtrls, Math, Clipbrd, ExtDlgs, GR32, GR32_ByteMaps,
  33.   GR32_RangeBars, GR32_Image, GR32_Layers, ToolWin, ImgList, Menus, JPeg;
  34.  
  35. type
  36.   TForm1 = class(TForm)
  37.     Panel1: TPanel;
  38.     Panel3: TPanel;
  39.     Panel4: TPanel;
  40.     ImageList1: TImageList;
  41.     CoolBar: TCoolBar;
  42.     ToolBar1: TToolBar;
  43.     bNew: TToolButton;
  44.     bOpen: TToolButton;
  45.     bSave: TToolButton;
  46.     bCopy: TToolButton;
  47.     ToolBar2: TToolBar;
  48.     Label2: TLabel;
  49.     Panel2: TPanel;
  50.     ScaleBar: TGaugeBar;
  51.     bLinear: TToolButton;
  52.     ToolButton7: TToolButton;
  53.     Label1: TLabel;
  54.     PaletteCombo: TComboBox;
  55.     ToolBar3: TToolBar;
  56.     ToolButton4: TToolButton;
  57.     ToolButton5: TToolButton;
  58.     MainMenu: TMainMenu;
  59.     mnFile: TMenuItem;
  60.     mnNew: TMenuItem;
  61.     mnOpen: TMenuItem;
  62.     mnSave: TMenuItem;
  63.     N1: TMenuItem;
  64.     mnExit: TMenuItem;
  65.     mnEdit: TMenuItem;
  66.     mnCopy: TMenuItem;
  67.     ToolButton8: TToolButton;
  68.     Image: TImgView32;
  69.     OpenPictureDialog: TOpenPictureDialog;
  70.     SavePictureDialog: TSavePictureDialog;
  71.     procedure PaletteComboChange(Sender: TObject);
  72.     procedure FormCreate(Sender: TObject);
  73.     procedure FormDestroy(Sender: TObject);
  74.     procedure NewClick(Sender: TObject);
  75.     procedure ScaleChange(Sender: TObject);
  76.     procedure CheckBox1Click(Sender: TObject);
  77.     procedure CopyClick(Sender: TObject);
  78.     procedure SaveClick(Sender: TObject);
  79.     procedure ImageMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
  80.     procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
  81.     procedure ImageMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
  82.     procedure mnExitClick(Sender: TObject);
  83.     procedure OpenClick(Sender: TObject);
  84.   private
  85.     procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
  86.   public
  87.     DataSet: TByteMap;
  88.     palGrayscale: TPalette32;
  89.     palGreens: TPalette32;
  90.     palReds: TPalette32;
  91.     palRainbow: TPalette32;
  92.     OldMousePos: TPoint;
  93.     MouseDragging: Boolean;
  94.     procedure GenPalettes;
  95.     procedure GenSampleData(W, H: Integer);
  96.     procedure PaintData;
  97.   end;
  98.  
  99. var
  100.   Form1: TForm1;
  101.  
  102. implementation
  103.  
  104. {$R *.DFM}
  105.  
  106. { TForm1 }
  107.  
  108. procedure TForm1.FormCreate(Sender: TObject);
  109. begin
  110.   PaletteCombo.ItemIndex := 0;
  111.   GenPalettes;
  112.   DataSet := TByteMap.Create;
  113. end;
  114.  
  115. procedure TForm1.FormDestroy(Sender: TObject);
  116. begin
  117.   DataSet.Free;
  118. end;
  119.  
  120. procedure TForm1.GenPalettes;
  121. var
  122.   i: Integer;
  123.   f: Single;
  124. begin
  125.   for i := 0 to 255 do
  126.   begin
  127.     f := i / 255;
  128.     palGrayscale[i] := HSLtoRGB(0, 0, f * 0.9 + 0.1);
  129.     palGreens[i] := HSLtoRGB(f * 0.4, 0.5, f * 0.4 + 0.2);
  130.     palReds[i] := HSLtoRGB(0.8 + f * 0.3 , 0.7 + f * 0.3, f * 0.85 + 0.1);
  131.     palRainbow[i] := HSLtoRGB(0.66 - f * 0.7, 1, 0.4 + 0.4 * f);
  132.   end;
  133. end;
  134.  
  135. procedure TForm1.GenSampleData(W, H: Integer);
  136. var
  137.   i, j: Integer;
  138.  
  139.   function Clamp(FloatVal: Extended): Byte;
  140.   begin
  141.     if FloatVal <= 0 then Result := 0
  142.     else if FloatVal >= 1 then Result := 255
  143.     else Result := Round(FloatVal * 255);
  144.   end;
  145.  
  146. begin
  147.   DataSet.SetSize(W, H);
  148.   for j := 0 to H - 1 do
  149.     for i := 0 to W - 1 do
  150.     begin
  151.       // just some noise
  152.       DataSet[i, j] := Clamp(0.5 +
  153.         0.5 * Sin(i + Random(10)) / 100 +
  154.         0.5 * Cos(j / 11) +
  155.         0.2 * Sin((i + j) / 3));
  156.     end;
  157. end;
  158.  
  159. procedure TForm1.PaintData;
  160. var
  161.   P: PPalette32;
  162. begin
  163.   case PaletteCombo.ItemIndex of
  164.     0: P := @palGrayScale;
  165.     1: P := @palGreens;
  166.     2: P := @palReds;
  167.   else
  168.     P := @palRainbow;
  169.   end;
  170.   DataSet.WriteTo(Image.Bitmap, P^);
  171. end;
  172.  
  173. procedure TForm1.PaletteComboChange(Sender: TObject);
  174. begin
  175.   PaintData;
  176. end;
  177.  
  178. procedure TForm1.NewClick(Sender: TObject);
  179. begin
  180.   GenSampleData(300, 220);
  181.   PaintData;
  182.   mnSave.Enabled := True;
  183.   mnCopy.Enabled := True;
  184.   bSave.Enabled := True;
  185.   bCopy.Enabled := True;
  186. end;
  187.  
  188. procedure TForm1.ScaleChange(Sender: TObject);
  189. var
  190.   NewScale: Single;
  191. begin
  192.   NewScale := Power(10, ScaleBar.Position / 100);
  193.   ScaleBar.Repaint; // update the scale bar before the image is repainted
  194.   Image.Scale := NewScale;
  195. end;
  196.  
  197. procedure TForm1.CheckBox1Click(Sender: TObject);
  198. begin
  199.   if bLinear.Down then Image.Bitmap.StretchFilter := sfLinear
  200.   else Image.Bitmap.StretchFilter := sfNearest;
  201. end;
  202.  
  203. procedure TForm1.CopyClick(Sender: TObject);
  204. begin
  205.   Clipboard.Assign(Image.Bitmap);
  206. end;
  207.  
  208. procedure TForm1.SaveClick(Sender: TObject);
  209. begin
  210.   Application.ProcessMessages;
  211.   with SavePictureDialog do
  212.     if Execute then Image.Bitmap.SaveToFile(FileName);
  213. end;
  214.  
  215. procedure TForm1.ImageMouseDown(Sender: TObject; Button: TMouseButton;
  216.   Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
  217. begin
  218.   if Button = mbLeft then
  219.   begin
  220.     OldMousePos := Point(X, Y);
  221.     MouseDragging := True;
  222.     Image.Cursor := crSizeAll;
  223.   end
  224.   else ReleaseCapture;
  225. end;
  226.  
  227. procedure TForm1.ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
  228.   Y: Integer; Layer: TCustomLayer);
  229. begin
  230.   if MouseDragging then
  231.   begin
  232.     Image.Scroll(OldMousePos.X - X, OldMousePos.Y - Y);
  233.     OldMousePos := Point(X, Y);
  234.     Image.Update;
  235.   end;
  236. end;
  237.  
  238. procedure TForm1.ImageMouseUp(Sender: TObject; Button: TMouseButton;
  239.   Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
  240. begin
  241.   if Button = mbLeft then
  242.   begin
  243.     MouseDragging := False;
  244.     Image.Cursor := crDefault;
  245.   end;
  246. end;
  247.  
  248. procedure TForm1.mnExitClick(Sender: TObject);
  249. begin
  250.   Close;
  251. end;
  252.  
  253. procedure TForm1.OpenClick(Sender: TObject);
  254. var
  255.   B: TBitmap32;
  256. begin
  257.   Application.ProcessMessages;
  258.   with OpenPictureDialog do
  259.     if Execute then
  260.     begin
  261.       { Create a temporary bitmap }
  262.       B := TBitmap32.Create;
  263.       try
  264.         B.LoadFromFile(FileName);
  265.         { Convert it to grayscale values and store it into the byte map }
  266.         DataSet.ReadFrom(B, ctWeightedRGB);
  267.       finally
  268.         B.Free;
  269.       end;
  270.       PaintData;
  271.       mnSave.Enabled := True;
  272.       mnCopy.Enabled := True;
  273.       bSave.Enabled := True;
  274.       bCopy.Enabled := True;
  275.     end;
  276. end;
  277.  
  278. procedure TForm1.WMEraseBkgnd(var Msg: TMessage);
  279. begin
  280.   { Accelerate repainting of the form a little bit }
  281.   Msg.Result := -1;
  282. end;
  283.  
  284. end.
  285.