Карта высот картинки

{
 вы знаете что такое карта высот?
 можно создать супер эффект на простом Canvas
 к сожалению мой код моргает при перерисовке,
 но вы уж поковыряйтесь.... :)
}
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 ExtCtrls, StdCtrls, ExtDlgs, math, ComCtrls, ShellApi;
type
 TForm1 = class(TForm)
 Image1: TImage;
 OpenDialog1: TOpenDialog;
 Timer1: TTimer;
 PageControl1: TPageControl;
 Specular: TTabSheet;
 sRed: TEdit;
 Label1: TLabel;
 ScrollBar1: TScrollBar;
 Label2: TLabel;
 sGreen: TEdit;
 ScrollBar2: TScrollBar;
 ScrollBar3: TScrollBar;
 sBlue: TEdit;
 Label3: TLabel;
 Label4: TLabel;
 Edit1: TEdit;
 ScrollBar4: TScrollBar;
 Diffuse: TTabSheet;
 Ambient: TTabSheet;
 Label5: TLabel;
 Label6: TLabel;
 Label7: TLabel;
 dGreen: TEdit;
 dBlue: TEdit;
 dRed: TEdit;
 ScrollBar5: TScrollBar;
 ScrollBar6: TScrollBar;
 ScrollBar7: TScrollBar;
 Label8: TLabel;
 Label9: TLabel;
 Label10: TLabel;
 aBlue: TEdit;
 aGreen: TEdit;
 aRed: TEdit;
 ScrollBar8: TScrollBar;
 ScrollBar9: TScrollBar;
 ScrollBar10: TScrollBar;
 Label11: TLabel;
 Label12: TLabel;
 Edit2: TEdit;
 Label13: TLabel;
 procedure FormCreate(Sender: TObject);
 procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
 Y: Integer);
 procedure ScrollBarChange(Sender: TObject);
 procedure Label11Click(Sender: TObject);
 procedure Timer1Timer(Sender: TObject);
 private
 { Private declarations }
 public
 { Public declarations }
 end;
type
 TNormal = record
 x: Integer;
 y: Integer;
 end;
type
 rgb32 = record
 b: Byte;
 g: Byte;
 r: Byte;
 t: Byte;
 end;
type
 rgb24 = record
 r: Integer;
 g: Integer;
 b: Integer;
 end;
var
 Form1: TForm1;
 BumpImage: TBitmap;
 Current_X, Current_Y: Integer;
var
 Bump_Map: array[0..255, 0..255] of TNormal;
 Environment_map: array[0..255, 0..255] of Integer;
 Palette: array[0..256] of rgb24;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
type
 image_array = array[0..255, 0..255] of Byte;
var
 x, y: Integer;
 Buffer: image_array;
 Bump_File: file of image_array;
 ny2, nx, nz: Double;
 c: Integer;
 ca, cap: Double;
begin
 AssignFile(Bump_File, 'bump.raw');
 reset(Bump_File);
 Read(Bump_File, Buffer);
 for y := 1 to 254 do
 begin
 for x := 1 to 254 do
 begin
 Bump_Map[x, y].x := Buffer[y + 1, x] - Buffer[y + 1, x + 2];
 Bump_Map[x, y].y := Buffer[y, x + 1] - Buffer[y + 2, x + 1];
 end;
 end;
 CloseFile(Bump_File);
 for y := -128 to 127 do
 begin
 nY2 := y / 128;
 nY2 := nY2 * nY2;
 for X := -128 to 127 do
 begin
 nX := X / 128;
 nz := 1 - SQRT(nX * nX + nY2);
 c := Trunc(nz * 255);
 if c < = 0 then
 c := 0;
 Environment_Map[x + 128, y + 128] := c;
 end;
 end;
 nx := pi / 2;
 ny2 := nx / 256;
 for y := 0 to 255 do
 begin
 ca := Cos(nx);
 cap := Power(ca, 35);
 nx := nx - ny2;
 Palette[y].r := Trunc((128 * ca) + (235 * cap));
 if Palette[y].r > 255 then
 Palette[y].r := 255;
 Palette[y].G := Trunc((128 * ca) + (245 * cap));
 if Palette[y].g > 255 then
 Palette[y].g := 255;
 Palette[y].B := Trunc(5 + (170 * ca) + (255 * cap));
 
 if Palette[y].b > 255 then
 Palette[y].b := 255;
 end;
 BumpImage := TBitmap.Create;
 BumpImage.Width := 255;
 BumpImage.Height := 255;
 BumpImage.PixelFormat := pf32bit;
 Image1.Picture.Bitmap := BumpImage;
 Image1MouseMove(Self, [], 128, 128);
 Application.ProcessMessages();
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
 Current_X := x;
 Current_Y := y;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
 x, y, x2, y2, y3: Integer;
 Scan: ^Scanline;
 bx, by: LongInt;
 c: Byte;
begin
 x := Current_X;
 y := Current_Y;
 for y2 := 0 to 253 do
 begin
 scan := image1.Picture.Bitmap.ScanLine[y2];
 y3 := 128 + y2 - y;
 for x2 := 0 to 253 do
 begin
 bx := Bump_Map[x2, y2].x + 128 + x2 - x;
 by := Bump_Map[x2, y2].y + y3;
 if (bx < 255) and (bx > 0) and (by < 255) and (by > 0) then
 begin
 c := Environment_Map[bx, by];
 scan^[x2].r := Palette[c].r;
 scan^[x2].g := Palette[c].g;
 scan^[x2].b := Palette[c].b;
 end
 else
 begin
 scan^[x2].r := Palette[0].r;
 scan^[x2].g := Palette[0].g;
 scan^[x2].b := Palette[0].b;
 end;
 {Image1.Canvas.Pixels[x, y] := RGB(r, g, b);}
 end;
 end;
 Image1.Refresh;
end;
procedure TForm1.ScrollBarChange(Sender: TObject);
var
 ny2, nx: Double;
 c: Integer;
 ca, cap: Double;
begin
 sRed.Text := IntToStr(ScrollBar1.Position);
 sGreen.Text := IntToStr(ScrollBar2.Position);
 sBlue.Text := IntToStr(ScrollBar3.Position);
 edit1.Text := IntToStr(ScrollBar4.Position);
 dRed.Text := IntToStr(ScrollBar5.Position);
 dGreen.Text := IntToStr(ScrollBar6.Position);
 dBlue.Text := IntToStr(ScrollBar7.Position);
 aRed.Text := IntToStr(ScrollBar8.Position);
 aGreen.Text := IntToStr(ScrollBar9.Position);
 aBlue.Text := IntToStr(ScrollBar10.Position);
 nx := pi / 2;
 ny2 := nx / 256;
 for C := 0 to 255 do
 begin
 ca := Cos(nx);
 cap := Power(ca, ScrollBar4.Position);
 nx := nx - ny2;
 Palette[c].r := Trunc(ScrollBar8.Position + (ScrollBar5.Position * ca) +
 (ScrollBar1.Position * cap));
 if Palette[c].r > 255 then
 Palette[c].r := 255;
 Palette[c].G := Trunc(ScrollBar9.Position + (ScrollBar6.Position * ca) +
 (ScrollBar2.Position * cap));
 if Palette[c].g > 255 then
 Palette[c].g := 255;
 Palette[c].B := Trunc(ScrollBar10.Position + (ScrollBar7.Position * ca) +
 (ScrollBar3.Position * cap));
 if Palette[c].b > 255 then
 Palette[c].b := 255;
 end;
 Image1MouseMove(Self, [], Current_X, Current_Y);
 Application.ProcessMessages();
end;
procedure TForm1.Label11Click(Sender: TObject);
begin
 ShellExecute(Handle, 'open', 'http://wkweb5.cableinet.co.uk/daniel.davies/',
 nil, nil, SW_SHOWNORMAL);
end;
end.
Source: Взято с http://delphiworld.narod.ru
ID: 03727
Category:Графика