Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > IT форум > Помощь студентам
Регистрация

Восстановить пароль

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 03.12.2012, 18:26   #1
Rol
Новичок
Джуниор
 
Регистрация: 15.04.2010
Сообщений: 1
По умолчанию Построение фрактала облака (delphi)

Здравствуйте, форумчане.
Имеется нижеприведенный код (рисует фрактал облака), написанный на Pascal'e. Помогите перевести данный код на Delphi.

Код:
uses graphlib, crt;

type rect = record
              x1, y1, x2, y2 : word;
            end;

var
    pal : gltPalette;
    i   : byte;
    bmp : gltBitMap;
    fnt : gltFont;


procedure RenderFractal( var bm : gltBitMap;
                         h1, h2, h3, h4, d : word );

  var rt : rect;

  function  GetPoint( x, y : word ) : word;
    begin
      GetPoint := bm.addr^[ y * bm.D + x ];
    end;

  procedure PutPoint( x, y, c : word );
    begin
      bm.addr^[ y * bm.D + x ] := c;
    end;

  procedure ShowAll( r : rect; depth : word );
    var
        x12, y12, h1, h2, h3, h4 : word;
        k1, k2, k3         : real;
        r0                 : rect;
    begin

      if depth > d then exit;

      x12 := (r.x2+r.x1) div 2;
      y12 := (r.y2+r.y1) div 2;

      h1 := GetPoint( r.x1, r.y1 );
      h2 := GetPoint( r.x2, r.y1 );
      h3 := GetPoint( r.x2, r.y2 );
      h4 := GetPoint( r.x1, r.y2 );

      if GetPoint( x12, r.y1 ) = 255
        then
          begin
            k1 := random;
            PutPoint( x12, r.y1, round( h1*k1 + h2*(1-k1)) );
          end;

      if GetPoint( r.x2, y12 ) = 255
        then
          begin
            k1 := random;
            PutPoint( r.x2, y12, round( h2*k1 + h3*(1-k1)) );
          end;

      if GetPoint( x12, r.y2 ) = 255
        then
          begin
            k1 := random;
            PutPoint( x12, r.y2, round( h3*k1 + h4*(1-k1)) );
          end;

      if GetPoint( r.x1, y12 ) = 255
        then
          begin
            k1 := random;
            PutPoint( r.x1, y12, round( h4*k1 + h1*(1-k1)) );
          end;

      k1 := random / 3.;
      k2 := random / 3.;
      k3 := random / 3.;
      PutPoint( x12, y12, round( h1*k1 + h2*k2 + h3*k3 + h4*(1-k1-k2-k3)) );

      with r0 do
       begin
        x1 := r.x1;
        x2 := x12;
        y1 := r.y1;
        y2 := y12;
       end;
      ShowAll( r0, depth + 1 );

      with r0 do
       begin
        x2 := r.x2;
        x1 := x12;
        y1 := r.y1;
        y2 := y12;
       end;
      ShowAll( r0, depth + 1 );

      with r0 do
       begin
        x1 := r.x1;
        x2 := x12;
        y2 := r.y2;
        y1 := y12;
       end;
      ShowAll( r0, depth + 1 );

      with r0 do
       begin
        x2 := r.x2;
        x1 := x12;
        y2 := r.y2;
        y1 := y12;
       end;
      ShowAll( r0, depth + 1 );
    end;

  begin
    glClearBitMap( bm, 255 );

    with rt do
     begin
      x1 := 0;
      y1 := 0;
      x2 := bm.D-1;
      y2 := bm.H-1;
      glPoint( bm, x1, y1, h1 );
      glPoint( bm, x2, y1, h2 );
      glPoint( bm, x2, y2, h3 );
      glPoint( bm, x1, y2, h4 );
     end;


    ShowAll( rt, 1 );
  end;

Begin
  randomize;
  glInit320x200;



  for i := 0 to 63 do
    pal[i*3] := i;
  for i := 64 to 127 do
    pal[i*3+1] := i;
  for i := 128 to 126+63 do
    pal[i*3+2] := i;
  pal[600] := 30;
  pal[601] := 30;
  pal[602] := 30;
  glSetPalette( pal );


  glReadFont( 'font.fnt', fnt, AllocateOn );
  glSetFont( fnt );
  glCreateBitMap( bmp, 320, 200 );
  repeat
    RenderFractal( Screen, 20, 60, 20, 60, 9 );
    glPutString( Screen, 68, 190, 'Press any key...ESC for exit...', 100 );
    ch := readkey;
  until ch = #27;
  glDeleteBitMap( bmp );
  glClose320x200;

End.
Rol вне форума Ответить с цитированием
Старый 05.11.2017, 09:53   #2
MoneyCrafter
 
Регистрация: 29.09.2015
Сообщений: 7
По умолчанию

Код:
procedure RenderFractal(const bm: TQuickPixels; xc, yc, wid, hei: integer; detailed: integer; h1, h2, h3, h4 : TColor; d: word);
var rt : rect;

function  GetPoint( x, y : TColor ) : TColor;
var
  a: integer;
begin
  GetPoint := bm.Pixels[x div detailed + xc, y div detailed + yc];
end;

procedure PutPoint( x, y, c : TColor );
begin
  bm.Pixels[x div detailed + xc, y div detailed + yc] := c;
end;

procedure ShowAll( r : rect; depth : TColor );
  var
      x12, y12, h1, h2, h3, h4 : TColor;
      k1, k2, k3         : real;
      r0                 : rect;
  begin

    if depth > d then exit;

    x12 := (r.x2+r.x1) div 2;
    y12 := (r.y2+r.y1) div 2;

    h1 := GetPoint( r.x1, r.y1 );
    h2 := GetPoint( r.x2, r.y1 );
    h3 := GetPoint( r.x2, r.y2 );
    h4 := GetPoint( r.x1, r.y2 );

    if GetPoint( x12, r.y1 ) = 255
      then
        begin
          k1 := random;
          PutPoint( x12, r.y1, round( h1*k1 + h2*(1-k1)) );
        end;

    if GetPoint( r.x2, y12 ) = 255
      then
        begin
          k1 := random;
          PutPoint( r.x2, y12, round( h2*k1 + h3*(1-k1)) );
        end;

    if GetPoint( x12, r.y2 ) = 255
      then
        begin
          k1 := random;
          PutPoint( x12, r.y2, round( h3*k1 + h4*(1-k1)) );
        end;

    if GetPoint( r.x1, y12 ) = 255
      then
        begin
          k1 := random;
          PutPoint( r.x1, y12, round( h4*k1 + h1*(1-k1)) );
        end;

    k1 := random / 3.;
    k2 := random / 3.;
    k3 := random / 3.;
    PutPoint( x12, y12, round( h1*k1 + h2*k2 + h3*k3 + h4*(1-k1-k2-k3)) );

    with r0 do
     begin
      x1 := r.x1;
      x2 := x12;
      y1 := r.y1;
      y2 := y12;
     end;
    ShowAll( r0, depth + 1 );

    with r0 do
     begin
      x2 := r.x2;
      x1 := x12;
      y1 := r.y1;
      y2 := y12;
     end;
    ShowAll( r0, depth + 1 );

    with r0 do
     begin
      x1 := r.x1;
      x2 := x12;
      y2 := r.y2;
      y1 := y12;
     end;
    ShowAll( r0, depth + 1 );

    with r0 do
     begin
      x2 := r.x2;
      x1 := x12;
      y2 := r.y2;
      y1 := y12;
     end;
    ShowAll( r0, depth + 1 );
  end;

begin

  with rt do
   begin
    x1 := 0;
    y1 := 0;
    x2 := wid * detailed - 1;
    y2 := hei * detailed - 1;

    putPoint( x1, y1, h1 );
    putPoint( x2, y1, h2 );
    putPoint( x2, y2, h3 );
    putPoint( x1, y2, h4 );
   end;


  ShowAll( rt, 1 );
end;
Перевел и немного улучшил)
1 параметр - куда
2, 3, 4, 5 - рамка
6 - детализация (например, для красивого облака размером 100х100 поставить 10)
7, 8, 9, 10 - так и не понял логический смысл этих параметров
11 - глубина (для того же облака поставить 10)
MoneyCrafter вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Облака, хранение данных в интеренете habahaba Свободное общение 1 24.04.2012 21:49
Построение графиков в Delphi 7 Verusen1ka Помощь студентам 2 23.01.2012 08:50
построение окружностей в Delphi Kurai Помощь студентам 8 08.04.2010 22:00
Как сделать типа облака тэгов Drek JavaScript, Ajax 7 09.11.2009 05:43
облака mdm Помощь студентам 2 17.04.2007 13:43