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

Советы » Canvas » Карта высот картинки

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

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

.

 

Другое по теме:

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com