БОЛЬШОЙ FAQ ПО DELPHI



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


 {
  вы знаете что такое карта высот?
  можно создать супер эффект  на простом 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://exelab.ru/pro/



Видеокурс ВЗЛОМ