Важная информация
Страница 1 из 2 12 ПоследняяПоследняя
Показано с 1 по 10 из 13

Тема: Фракталы

  1. #1 Фракталы 
    Супер модератор Аватар для >Quiet Snow<
    Регистрация
    11.04.2011
    Адрес
    Планета земля
    Сообщений
    3,846
    Сказал(а) спасибо
    1,815
    Поблагодарили 945 раз(а) в 807 сообщениях
    Записей в блоге
    1

    Фракталы


    Создаю топик специально для фракталов на FreeBASIC! По моим наблюдениям это нужно для
    более грамотного формирования списка более всеобъемлющих тем.

    Итак, уважаемые форумчане, выкладываем код фракталов и обсуждаем. Поехали!

    Пример для старта:

    Программа из книжки TurboPascal практикум. Фрактал - папоротник. Я слегка адаптировал.
    Добавил "накопление цвета" и настроил палитру. Результат на скрине.

    Paporotn.jpg

    Код freebasic:
    CONST Iterations = 9000000
    DIM t AS DOUBLE, x AS DOUBLE, y AS DOUBLE, p AS DOUBLE
    DIM k AS LONG
    DIM Midx AS INTEGER, Midy AS INTEGER, radius AS INTEGER
    DIM Cv AS INTEGER
    DIM Gr AS INTEGER
    SCREEN 20
     FOR k = 0 TO 255
        Gr = k ^ .74 + RND
        OUT &H3C8, k
        OUT &H3C9, Gr / 1.8
        OUT &H3C9, Gr
        OUT &H3C9, Gr / 3.5
     NEXT
      Midx = 512
      Midy = 768
      radius = .1 * Midy
      RANDOMIZE TIMER
      x = 1
      y = 0
      FOR k = 1 TO Iterations
       p = 1 - RND / 2
       t = x
       IF p <= .85 THEN
         x = .85 * x + .04 * y
         y = -.04 * t + .85 * y + 1.6
       ELSE
          IF p <= .92 THEN
           x = .2 * x - .26 * y
           y = .23 * t + .22 * y + 1.6
          ELSE
             IF p <= .99 THEN
              x = -.15 * x + .28 * y
              y = .26 * t + .24 * y + .44
             ELSE
              x = 0
              y = .16 * y
             END IF
          END IF
       END IF
       Cv = POINT(Midx + radius * x, Midy - radius * y)
       Cv = Cv + 1
       IF Cv > 255 THEN Cv = 255
       PSET (Midx + radius * x, Midy - radius * y), Cv
      NEXT
    WHILE INKEY$ = "": WEND
    Обучение прикладному программированию(по skype), качественно, недорого, 18+, вопросы в личку.
    «Если вы ничего не сделаете, я уверяю вас, ничего и не произойдёт» © Жак Фреско
    Ограниченно модерирую.
    Ответить с цитированием  
     

  2. #2  
    Супер модератор Аватар для >Quiet Snow<
    Регистрация
    11.04.2011
    Адрес
    Планета земля
    Сообщений
    3,846
    Сказал(а) спасибо
    1,815
    Поблагодарили 945 раз(а) в 807 сообщениях
    Записей в блоге
    1
    Дело было вечером(ну или ночью), делать было нечего.
    Фрактал Лейс, уважаемые господа, прошу любить и жаловать.
    Перенёс с цайбера + допилил эффект ореола. Первоначальный источник находится >ЗДЕСЬ<

    Код freebasic:
    ' $Lang: "FBLite"
    DECLARE FUNCTION Arctg# (xf AS DOUBLE, yf AS DOUBLE)
    CONST Pi = 3.141592653589793#
    CONST Foton = 0
      DIM x AS DOUBLE, y AS DOUBLE, A AS DOUBLE
      DIM X1 AS DOUBLE, Y1 AS DOUBLE
      DIM n AS INTEGER
      DIM r0 AS DOUBLE, w AS DOUBLE
      DIM M AS SHORT, tt AS USHORT
     
      SCREEN 20
      COLOR 255: PRINT "Please wait a minute..."
      RANDOMIZE TIMER
      v = INT(RND * 3)
      FOR i = 0 TO 255
         SELECT CASE v
            CASE 0: OUT &H3C8, i: OUT &H3C9, 0: OUT &H3C9, (i \ 4) * .75: OUT &H3C9, i \ 4
            CASE 1: OUT &H3C8, i: OUT &H3C9, i \ 4: OUT &H3C9, (i \ 4) * .35: OUT &H3C9, (i \ 4) * .10
            CASE 2: OUT &H3C8, i: OUT &H3C9, (i \ 4) * .55: OUT &H3C9, (i \ 4): OUT &H3C9, (i \ 4) * .10
         END SELECT
      NEXT
      x = .1
      y = .1
      FOR i = 1 TO 2500000
        A = RND
        r0 = (x * x + y * y) ^ .55
        w = Arctg#(x - 1, y)
        IF A <= 1 / 4 THEN
           w = Arctg#(x - 1, y)
           Y1 = -r0 * COS(w) / 2 + 1
           X1 = -r0 * SIN(w) / 2
        ELSE
           IF (A <= 2 / 4) THEN
              w = Arctg#(x + 1 / 2, y - 3 ^ .5 / 2)
              Y1 = -r0 * COS(w) / 2 - 1 / 2
              X1 = -r0 * SIN(w) / 2 + 3 ^ .5 / 2
           ELSE
              IF (A <= 3 / 4) THEN
                  w = Arctg#(x + 1 / 2, y + 3 ^ .5 / 2)
                  Y1 = -r0 * COS(w) / 2 - 1 / 2
                  X1 = -r0 * SIN(w) / 2 - 3 ^ .5 / 2
              ELSE
                  w = Arctg#(x, y)
                  Y1 = -r0 * COS(w) / 2
                  X1 = -r0 * SIN(w) / 2
              END IF
           END IF
        END IF
        x = X1
        y = Y1
          PoX = 512 + 208 * x
          PoY = 340 + 208 * y
          M = POINT(PoX, PoY) + 2 + RND
          IF M > 255 THEN M = 255
          PSET (PoX, PoY), M
      NEXT i
       '  Заводим буферы для сглаживания
    DIM SHARED Ek(1023, 768) AS SHORT, Ek2(1023, 768) AS SHORT
       '  Буфер для сглаживания
    FOR scY = 0 TO 767
          FOR scX = 0 TO 1023
          Ek(scX, scY) = POINT(scX, scY)
          NEXT
    NEXT
       '  Создаём первый ореол сглаживанием
    FOR Sgl = 1 to 4
     IF INKEY$ <> "" THEN END
     FOR scY = 1 TO 767
          FOR scX = 1 TO 1023
               tt = Ek(scX - 1, scY - 1) + Ek(scX, scY - 1) + Ek(scX + 1, scY - 1)
               tt = tt + Ek(scX - 1, scY) + Ek(scX, scY) + Ek(scX + 1, scY)
               tt = tt + Ek(scX - 1, scY + 1) + Ek(scX, scY + 1) + Ek(scX + 1, scY + 1)
               tt = tt * .111 + Ek(scX, scY) * .08
               IF tt > 255 THEN tt = 255
          Ek2(scX, scY) = tt
          NEXT
     NEXT
     FOR scY = 1 TO 767
          FOR scX = 1 TO 1023
               tt = Ek2(scX - 1, scY - 1) + Ek2(scX, scY - 1) + Ek2(scX + 1, scY - 1)
               tt = tt + Ek2(scX - 1, scY) + Ek2(scX, scY) + Ek2(scX + 1, scY)
               tt = tt + Ek2(scX - 1, scY + 1) + Ek2(scX, scY + 1) + Ek2(scX + 1, scY + 1)
               tt = tt * .111 + Ek2(scX, scY) * .08 
               IF tt > 255 THEN tt = 255
          Ek(scX, scY) = tt
          NEXT
     NEXT
    NEXT Sgl
       '  Добавляем первый ореол
    FOR scY = 1 TO 767
          FOR scX = 1 TO 1023
          tt = POINT(scX, scY) + Ek(scX, scY)
          'IF tt < Ek(scX, scY) THEN tt = Ek(scX, scY)
          IF tt > 255 THEN tt = 255
          PSET (scX, scY), tt
          NEXT
    NEXT
       '  Создаём второй ореол сглаживанием
    FOR Sgl = 1 to 11
     IF INKEY$ <> "" THEN END
     FOR scY = 1 TO 767
          FOR scX = 1 TO 1023
               tt = Ek(scX - 1, scY - 1) + Ek(scX, scY - 1) + Ek(scX + 1, scY - 1)
               tt = tt + Ek(scX - 1, scY) + Ek(scX, scY) + Ek(scX + 1, scY)
               tt = tt + Ek(scX - 1, scY + 1) + Ek(scX, scY + 1) + Ek(scX + 1, scY + 1)
               tt = tt * .111 + Ek(scX, scY) * .008
               IF tt > 255 THEN tt = 255
          Ek2(scX, scY) = tt
          NEXT
     NEXT
     FOR scY = 1 TO 767
          FOR scX = 1 TO 1023
               tt = Ek2(scX - 1, scY - 1) + Ek2(scX, scY - 1) + Ek2(scX + 1, scY - 1)
               tt = tt + Ek2(scX - 1, scY) + Ek2(scX, scY) + Ek2(scX + 1, scY)
               tt = tt + Ek2(scX - 1, scY + 1) + Ek2(scX, scY + 1) + Ek2(scX + 1, scY + 1)
               tt = tt * .111 + Ek2(scX, scY) * .008
               IF tt > 255 THEN tt = 255
          Ek(scX, scY) = tt + RND
          NEXT
     NEXT
    NEXT Sgl
       '  Добавляем второй ореол
    FOR scY = 1 TO 767
          FOR scX = 1 TO 1023
          tt = POINT(scX, scY)' + Ek(scX, scY)
          IF tt < Ek(scX, scY) THEN tt = Ek(scX, scY)
          IF tt > 255 THEN tt = 255
          PSET (scX, scY), tt
          NEXT
    NEXT
     
    WHILE INKEY$ = "": WEND
    FUNCTION Arctg# (xf AS DOUBLE, yf AS DOUBLE)
    DIM w AS DOUBLE
      w = ATN(ABS(yf / xf))
      IF (yf > 0) AND (xf < 0) THEN w = Pi - w
      IF (yf < 0) AND (xf < 0) THEN w = w + Pi
      IF (yf < 0) AND (xf > 0) THEN w = -w
      Arctg# = w
    END FUNCTION
    Lace1.jpgLace2.jpgLace3.jpg
    Вложения
    Обучение прикладному программированию(по skype), качественно, недорого, 18+, вопросы в личку.
    «Если вы ничего не сделаете, я уверяю вас, ничего и не произойдёт» © Жак Фреско
    Ограниченно модерирую.
    Ответить с цитированием  
     

  3. 3 пользователя(ей) сказали cпасибо:

    Good.Morning (17.04.2014), Kakos_nonos (11.01.2013), Абадябер (11.01.2013)

  4. #3  
    Гуру Аватар для Абадябер
    Регистрация
    09.12.2010
    Адрес
    Беларусь, Минск
    Сообщений
    1,219
    Сказал(а) спасибо
    302
    Поблагодарили 176 раз(а) в 144 сообщениях
    Записей в блоге
    5
    Ммм. Выглядит красиво
    Как понимаю, судя по этому: ("CASE 0: OUT &H3C8, i: OUT &H3C9, 0: OUT &H3C9, (i \ 4) * .75: OUT &H3C9, i \ 4") оно еще и под DOS-ом работает, верно?
    Дружба-магия-радость!
    Ответить с цитированием  
     

  5. #4  
    Супер модератор Аватар для >Quiet Snow<
    Регистрация
    11.04.2011
    Адрес
    Планета земля
    Сообщений
    3,846
    Сказал(а) спасибо
    1,815
    Поблагодарили 945 раз(а) в 807 сообщениях
    Записей в блоге
    1
    оно еще и под DOS-ом работает, верно?
    Возможно работает, я если честно не смотрел, может ли FB делать программы под DOS в режиме FBLite.
    Все эти порты сохранены для совместимости. Даже для вертикальной синхронизации можно написать
    Код freebasic:
    WAIT &H3DA, 8
    Просто я изучаю FB для винды, под досом нет ничего роднее чем QB4 + MASM.
    Обучение прикладному программированию(по skype), качественно, недорого, 18+, вопросы в личку.
    «Если вы ничего не сделаете, я уверяю вас, ничего и не произойдёт» © Жак Фреско
    Ограниченно модерирую.
    Ответить с цитированием  
     

  6. #5  
    Гуру Аватар для Абадябер
    Регистрация
    09.12.2010
    Адрес
    Беларусь, Минск
    Сообщений
    1,219
    Сказал(а) спасибо
    302
    Поблагодарили 176 раз(а) в 144 сообщениях
    Записей в блоге
    5
    Возможно работает, я если честно не смотрел, может ли FB делать программы под DOS в режиме FBLite.
    Хмм... Оно только под DOS-ом и должно работать, по логике вещей. Windows запрещает запись в порты для обычных приложений. Как вообще это понимать, что вы пишете в порты в этой программе, хотя она рассчитана на работу под виндой? Может быть, FB как то "эмулирует" этот вопрос? Или я сного чего-то не понял, только-то
    Дружба-магия-радость!
    Ответить с цитированием  
     

  7. #6  
    Супер модератор Аватар для >Quiet Snow<
    Регистрация
    11.04.2011
    Адрес
    Планета земля
    Сообщений
    3,846
    Сказал(а) спасибо
    1,815
    Поблагодарили 945 раз(а) в 807 сообщениях
    Записей в блоге
    1
    FB как то "эмулирует" этот вопрос?
    Да, я это и имел в виду. Естественно винда не даст обращаться к портам непосредственно.
    Обучение прикладному программированию(по skype), качественно, недорого, 18+, вопросы в личку.
    «Если вы ничего не сделаете, я уверяю вас, ничего и не произойдёт» © Жак Фреско
    Ограниченно модерирую.
    Ответить с цитированием  
     

  8. #7  
    Новичок
    Регистрация
    14.04.2014
    Адрес
    Москва
    Сообщений
    7
    Сказал(а) спасибо
    0
    Поблагодарили 1 раз в 1 сообщении
    Простите, а кто Вас заставляет читать? И не думал... Это написано для "подрастающего поколения" и кто знает, как наше слово отзовется :-)
    Ваше мнение о необходимости опубликовать программы для рисования фракталов будет учтено! Но много проблем со стандартным софтом...
    Вы заметили, что все интересные программы в сети теперь стоят денег? Печально, потому и религиозная составляющая...

    Я не программист, я - металлург. Пишу, как могу, жаль что даже замечания не блещут "математической строгостью" :-(
    Ответить с цитированием  
     

  9. #8  
    Профи
    Регистрация
    09.11.2013
    Сообщений
    234
    Сказал(а) спасибо
    17
    Поблагодарили 76 раз(а) в 51 сообщениях
    Здравствуйте! Пытаюсь переписать программу построения кривой Госпера с Паскаля на FreeBasic. На Паскале программа рисует то, что нужно, а на бейсике не хочет. Никак не могу понять, в чем проблема... Может глянете свежим глазом и подскажете где я накосячил? Коды на ФБ и Паскале прилагаю

    Basic Code:
    1.  
    2.  
    3. ' Gosp2.bas
    4.  
    5. Declare Sub Draw2 ( ByRef x As Double,_
    6.                       ByRef y As Double,_
    7.                       ByVal l As Double,_
    8.                       ByVal u As Double,_
    9.                       ByVal t As Integer,_
    10.                       ByVal q As Integer )
    11.                       
    12. Declare Sub DrawGosper ( ByRef x As Double,_
    13.                          ByRef y As Double,_
    14.                          ByVal l As Double,_
    15.                          ByVal u As Double,_
    16.                          ByVal t As Integer,_
    17.                          ByVal q As Integer )
    18. Const pi = 3.1415
    19.  
    20. ScreenRes 800, 800, 8                        
    21. DrawGosper (100, 355, 400, 0, 2, 0)
    22. Sleep
    23.  
    24. Sub Draw2 ( ByRef x As Double,_
    25.             ByRef y As Double,_
    26.             ByVal l As Double,_
    27.             ByVal u As Double,_
    28.             ByVal t As Integer,_
    29.             ByVal q As Integer )
    30.  
    31.     DrawGosper (x, y, l, u, t, q)
    32.     x = x + l*cos(u)
    33.     y = y - l*sin(u)
    34. End Sub
    35.  
    36.  
    37.  
    38. Sub DrawGosper ( ByRef x As Double,_
    39.                  ByRef y As Double,_
    40.                  ByVal l As Double,_
    41.                  ByVal u As Double,_
    42.                  ByVal t As Integer,_
    43.                  ByVal q As Integer )
    44.  
    45.  
    46.   If t > 0 Then
    47.   
    48.     If q = 1 Then
    49.       x = x + l*cos(u)
    50.       y = y - l*sin(u)
    51.       u = u + pi
    52.     End If
    53.     
    54.     u = u - 2 * pi / 19
    55.     l = l / sqr(7)
    56.     Draw2(x, y, l, u,          t-1, 0)
    57.     Draw2(x, y, l, u + pi/3,   t-1, 1)
    58.     Draw2(x, y, l, u + pi,     t-1, 1)
    59.     Draw2(x, y, l, u + 2*pi/3, t-1, 0)
    60.     Draw2(x, y, l, u,          t-1, 0)
    61.     Draw2(x, y, l, u,          t-1, 0)
    62.     Draw2(x, y, l, u - pi/3,   t-1, 1)
    63.  
    64.   Else
    65.       Line ( CInt(x), CInt(y) ) - ( CInt(x+l*cos(u)), CInt(y-l*Sin(u)) ), 5
    66.   End If
    67. End Sub


    Pascal Code:
    1. Program Gosp2;
    2. Uses CRT, Graph;
    3. var
    4.   gd, gm: SmallInt;
    5.  
    6. Procedure Draw(x, y, l, u : Real; t, q : Integer);
    7.  
    8. Procedure Draw2(Var x, y: Real; l, u : Real; t, q : Integer);
    9. Begin
    10.     Draw(x, y, l, u, t, q);
    11.     x := x + l*cos(u);
    12.     y := y - l*sin(u);
    13. End;
    14.  
    15. Begin
    16.   If t > 0 Then
    17.   Begin
    18.     If q = 1 then
    19.     Begin
    20.       x := x + l*cos(u);
    21.       y := y - l*sin(u);
    22.       u := u + pi;
    23.     End;
    24.     u := u - 2*pi/19;
    25.     l := l/sqrt(7);
    26.     Draw2(x, y, l, u,        t-1, 0);
    27.     Draw2(x, y, l, u+pi/3,   t-1, 1);
    28.     Draw2(x, y, l, u+pi,     t-1, 1);
    29.     Draw2(x, y, l, u+2*pi/3, t-1, 0);
    30.     Draw2(x, y, l, u,        t-1, 0);
    31.     Draw2(x, y, l, u,        t-1, 0);
    32.     Draw2(x, y, l, u-pi/3,   t-1, 1);
    33.   End
    34.   Else Line(Round(x), Round(y), Round(x+cos(u)*l), Round(y-sin(u)*l))
    35. End;
    36.  
    37. Begin
    38.   gd := Detect;
    39.   InitGraph(gd, gm, '');
    40.   Draw(100, 355, 400, 0, 2, 0);
    41.   ReadKey;
    42.   CloseGraph
    43. End.
    Ответить с цитированием  
     

  10. #9  
    Супер модератор Аватар для >Quiet Snow<
    Регистрация
    11.04.2011
    Адрес
    Планета земля
    Сообщений
    3,846
    Сказал(а) спасибо
    1,815
    Поблагодарили 945 раз(а) в 807 сообщениях
    Записей в блоге
    1
    ur_naz, чуть позже посмотрю, в чём проблема. Какой паскаль кстати, Turbo?
    Обучение прикладному программированию(по skype), качественно, недорого, 18+, вопросы в личку.
    «Если вы ничего не сделаете, я уверяю вас, ничего и не произойдёт» © Жак Фреско
    Ограниченно модерирую.
    Ответить с цитированием  
     

  11. #10  
    Профи
    Регистрация
    09.11.2013
    Сообщений
    234
    Сказал(а) спасибо
    17
    Поблагодарили 76 раз(а) в 51 сообщениях
    Цитата Сообщение от >Quiet Snow< Посмотреть сообщение
    Какой паскаль кстати, Turbo?
    Изначально это был код для турбопаскаля, я его переделал для Лазаруса. Это не многого стоило, всего лишь поменять тип gm и gd с Integer на SmallInt. Затем решил переписать на фри бейсик и тут началась мистика...
    Ответить с цитированием  
     

Страница 1 из 2 12 ПоследняяПоследняя
Информация о теме
Пользователи, просматривающие эту тему

Эту тему просматривают: 1 (пользователей: 0 , гостей: 1)

Ваши права
  • Вы не можете создавать новые темы
  • Вы не можете отвечать в темах
  • Вы не можете прикреплять вложения
  • Вы не можете редактировать свои сообщения
  •