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

Previous  Top  Next

    
 

 

 

Code:

{

вы знаете что такое карта высот?

можно создать супер эффект  на простом 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.

 

 

©Drkb::03727

       

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