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

Материал из 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