Einzelnen Beitrag anzeigen

WojTec

Registriert seit: 17. Mai 2007
482 Beiträge
 
Delphi XE6 Professional
 
#5

Re: 3-dimensional array to list?

  Alt 1. Jun 2011, 14:12
See yourself:

Delphi-Quellcode:
{ Copyright (C) 2000 Michael Hansen. All Rights Reserved. }

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
  ExtCtrls, ComCtrls, GR32_Image, Spin;

type
  TForm1 = class(TForm)
    Draw: TButton;
    NoiseGen: TButton;
    NoiseRadio: TRadioGroup;
    SmoothRadio: TRadioGroup;
    ViewCombo: TComboBox;
    Label1: TLabel;
    Label2: TLabel;
    Image321: TImage32;
    SpinEdit1: TSpinEdit;
    procedure FormCreate(Sender: TObject);
    procedure DrawClick(Sender: TObject);
    procedure NoiseGenClick(Sender: TObject);
    procedure Mix;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure NoiseRadioClick(Sender: TObject);
    procedure SmoothRadioClick(Sender: TObject);
    procedure ViewComboChange(Sender: TObject);
    procedure SpinEdit1Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

type
  TRGBTripleArray = array [0 .. 32767] of TRGBTriple;

var
  Bitmap: TBitmap;
  YLine: ^TRGBTripleArray;
  Noise: array of array of array of Byte;
  Layers: array of array of array of Byte;
  InitDone: Boolean = False;

  { Max shr CLayer MUST be > 1 else program exits.
    In other words:  if Max div CLayer*2^CLayer > 1 then close }

  CLayer: Byte = 7; { Actual Layers = CLayer+1 }
  Max: Word = 255; { Actual Size = (Max+1)*(Max+1) }

  { Grain or MixDown Factor, thats like a layers opasity
    in photoshop,127=50% Opaque and 255=100% Opaque.
    Change the grainess with this value. > 127 = more grain. }

  Grain: Byte = 127;

{$R *.DFM}

function freq(xy, layer: Word): Word;
begin
  Result := xy shr layer;
end;

procedure TForm1.Mix;
var
  x, y: Word;
  c, l: Byte;
begin
  l := ViewCombo.ItemIndex;
  if l = 0 then
  begin
    for y := 0 to Max do
    begin
      YLine := Bitmap.Scanline[y];
      for x := 0 to Max do
      begin
        c := Layers[0, x, y];
        for l := 1 to CLayer do
          c := ((c * Grain) + (Layers[l, x, y] * not Grain)) shr 8;
        FillChar(YLine[x], 3, c);
      end;
    end
  end
  else
  begin
    for y := 0 to Max do
    begin
      YLine := Bitmap.Scanline[y];
      for x := 0 to Max do
      begin
        c := Layers[l - 1, x, y];
        FillChar(YLine[x], 3, c);
      end;
    end;
  end;
  Image321.Bitmap.Assign(Bitmap);
end;

procedure Init(NumberOFLayers: byte);
var
  xy, y: Word;
  l: Byte;
begin
  SetLength(Noise, NumberOFLayers + 1);
  SetLength(Layers, NumberOFLayers + 1);

  for l := 0 to NumberOFLayers do
  begin
    xy := freq(Max, l);
    SetLength(Noise[l], xy + 1);
    SetLength(Layers[l], Max + 1);
    for y := 0 to xy do
      SetLength(Noise[l, y], xy);
    for y := 0 to Max do
      SetLength(Layers[l, y], Max + 1);
  end;
end;

procedure InterpolateRect(Rect: TRect; v1, v2, v3, v4: byte; layer: byte);
var
  c, x, y, dx, dy, dxy, dxX, dyY: Word;
begin
  { Interpolation between the values v1..v4 in the size of rect }
  with Rect do
  begin
    dx := Right - Left;
    dy := Bottom - Top;
    dxy := dx * dy;
    for y := 0 to dy do
    begin
      dyY := dy - y;
      for x := 0 to dx do
      begin
        dxX := dx - x;
        c := (v1 * dyY * dxX) div dxy + (v2 * dyY * x) div dxy + (v3 * y * dxX)
          div dxy + (v4 * y * x) div dxy;
        Layers[layer, Left + x, Top + y] := c;
      end;
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  x: Byte;
begin
  if Max shr CLayer < 1 then
    exit; { see introduction }
  Bitmap := TBitmap.Create;
  Bitmap.PixelFormat := pf24bit;
  Bitmap.SetSize(Max + 1, Max + 1);
  Init(CLayer);
  ViewCombo.Items.Add('Mixed Layers');
  for x := 0 to CLayer do
    ViewCombo.Items.Add('Layer ' + IntToStr(x + 1));
  NoiseRadio.ItemIndex := 0;
  SmoothRadio.ItemIndex := 0;
  ViewCombo.ItemIndex := 0;
  InitDone := true;
  NoiseGen.Click;
end;

procedure TForm1.DrawClick(Sender: TObject);
var
  x, y: Word;
  l, cl: Byte;
  sc: Single;
begin
  Screen.Cursor := crHourGlass;
  { No Interpolation and layer[0] fill }
  for l := 0 to CLayer do
    for x := 0 to Max do
      for y := 0 to Max do
        Layers[l, x, y] := Noise[l, freq(x, l), freq(y, l)];
  { Interpolation }
  if SmoothRadio.ItemIndex = 0 then
  begin
    for l := 1 to CLayer do
    begin
      y := 0;
      cl := freq(Max, l);
      sc := Max / cl;
      repeat
      begin
        x := 0;
        repeat
        begin
          InterpolateRect(Rect(Round(x * sc), Round(y * sc),
              Round((x * sc) + sc), Round((y * sc) + sc)), Noise[l, x, y],
            Noise[l, x + 1, y], Noise[l, x, y + 1], Noise[l, x + 1, y + 1], l);
          Inc(x);
        end;
        until x = cl;
        Inc(y);
      end;
      until y = cl;
    end;
  end;
  Mix;
  Screen.Cursor := crDefault;
end;

procedure TForm1.NoiseGenClick(Sender: TObject);
var
  x, y, l: Word;
begin
  Randomize;
  { Grayscale noise }
  if NoiseRadio.ItemIndex = 0 then
    for l := 0 to CLayer do
      for x := 0 to freq(Max, l) do
        for y := 0 to freq(Max, l) do
          Noise[l, x, y] := Random(32768);
  { Monochrome noise }
  if NoiseRadio.ItemIndex = 1 then
    for l := 0 to CLayer do
      for x := 0 to freq(Max, l) do
        for y := 0 to freq(Max, l) do
          if Random(32768) > 16384 then
            Noise[l, x, y] := 255
          else
            Noise[l, x, y] := 0;
  Draw.Click;
  // ViewCombo.ItemIndex:=0
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  { Release memory used }
  Finalize(Layers);
  Finalize(Noise);
  YLine := nil;
  Bitmap.Free
end;

procedure TForm1.NoiseRadioClick(Sender: TObject);
begin
  if InitDone then
    NoiseGen.Click
end;

procedure TForm1.SmoothRadioClick(Sender: TObject);
begin
  if InitDone then
    Draw.Click
end;

procedure TForm1.SpinEdit1Change(Sender: TObject);
begin
  Grain := SpinEdit1.Value;
  Mix;
end;

procedure TForm1.ViewComboChange(Sender: TObject);
begin
  if InitDone then
    Mix
end;

end.
When I want to use bigger bitmap, AVs are raised. So, this is reason I'm looking for better structure than array.
  Mit Zitat antworten Zitat