Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007
{
 
вы знаете что такое карта высот?
 
можно создать супер эффект  на простом 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
  normal
= 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 normal;
  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.

Взято с https://delphiworld.narod.ru