Карта высот картинки
Материал из DRKB
{
вы знаете что такое карта высот?
можно создать супер эффект на простом 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