Fortraneries/Fraktalism/fraktals.f90

module fraktals

  use points3d

  implicit none
  contains

!===============================================================
!	nouveau 28 mai 2022 (again) 
! source:
!    Fractal Creation with FRACTINT
!
subroutine parasites_0(pic, cx, cy, maxiter)
    implicit none

    ! here is the wtf
    integer, intent(inout), dimension (:,:)  ::  pic

    real, intent(in)                         ::  cx, cy
    integer, intent(in)                      ::  maxiter

    integer      ::  ix, iy, width, height
    real         ::  fx, fy, coef
    logical      ::  burps
    ! write(0, *) "subroutine parasites_0" , maxiter
    ! write(0, *) "constantes", cx, cy
 
    width  = ubound(pic, 1)    ;    height = ubound(pic, 2)
    coef   = float(maxiter)

    do ix = 1, width
      fx = cx + (float(ix) / (float(width)/4.0) - 2.0)
      burps = (RAND() .lt. 0.01)
      do iy = 1, height
        fy = cy + (float(iy) / (float(height)/4.0) - 2.0)

        if (burps) then
          pic(ix, iy) = int(fx * fy * coef * 1.005)
        else
          pic(ix, iy) = int(fx * fy * coef)
        endif

      enddo
    enddo

end subroutine parasites_0


!===============================================================

subroutine simple_julia(pic, cx, cy, maxiter)
    implicit none
    integer, intent(inout), dimension (:,:)  ::  pic
    real, intent(in)                         ::  cx, cy
    integer, intent(in)                      ::  maxiter

    integer      ::  ix, iy, width, height
    real         ::  fx, fy
    complex      ::  Z, C
    integer      ::  iter
    logical      ::  over_iter

    width  = ubound(pic, 1)
    height = ubound(pic, 2)

    C = complex(cx, cy)
    print *, "Const = ", C

    ! ready ? ok, clear the picture
    pic = 0

    do ix = 1, width
      fx = (float(ix) / (float(width)/4.0) - 2.0)
      do iy = 1, height
        fy = (float(iy) / (float(height)/4.0) - 2.0)

          ! ------ traitement du pixel
          iter = 0  ; over_iter = .FALSE.
          Z = complex(fx, fy)
          do while (modulus2(Z) .LT. 4.0) 

            Z = (Z * Z) + C
            iter = iter + 1

            if (iter .GE. maxiter) then
              over_iter = .TRUE.
              exit
            endif

          end do

          if (over_iter) then
            pic(ix, iy) = 0
          else
            pic(ix, iy) = iter*12
          endif
      enddo      ! iy
    enddo        ! ix

end subroutine simple_julia
!===============================================================
 
!  d'après les pages 91/92 du livre de Roger T Stevens
!       "Fractal programming in C"
! 
subroutine compute_pickover(array, coefs)
    type(t_point3d), dimension(:)    :: array
    double precision, dimension(4)   :: coefs

    double precision      :: xa, ya, za, xb, yb, zb
    integer               :: i
    ! print *, "coefs ", coefs

    ! write(0, '(1X, A18, I9)') "compute pickover ", ubound(array, 1)

    xa = 1.0  ; ya = 1.0  ; za = 1.0

    do i=1, ubound(array, 1)
      xb = sin(coefs(1)*ya) - za*cos(coefs(2)*xa)
      yb = za*sin(coefs(3)*xa) - cos(coefs(4)*ya)
      zb = sin(xa)
      array(i)%x   = xb
      array(i)%y   = yb
      array(i)%z   = zb
      array(i)%seq = i
      xa = xb ; ya = yb ; za = zb 
    enddo

end subroutine

!-----------------------------------------------------
! 
!  d'après les pages 91/92 du livre de Roger T Stevens
!       "Fractal programming in C"
! 
subroutine plot_pickover(pic, count)
    implicit none
    integer, intent(inout), dimension (:,:)  ::  pic
    integer, intent(in)                      ::  count

    type(t_point3d), dimension(:), allocatable ::   points
    double precision, dimension(4)             ::   coefs
    integer               :: i, w, h, px, py, errcode

    write(0, '(1X, A18 , I9)') "pickover_0 ", count

    allocate(points(count), stat=errcode)
    if (0 .NE. errcode) then
      STOP " : NO ENOUGH MEMORY"
    endif

    ! Clear the picture
    pic = 0

    coefs(1) = 2.24     ;     coefs(2) = 0.43
    coefs(3) = -0.65    ;     coefs(4) = -2.43
    call compute_pickover(points, coefs)
 
    w  = ubound(pic, 1)
    h  = ubound(pic, 2)

    do i=1, ubound(points, 1)
      px = int((points(i)%x * (w/4.09)) + (w / 2))
      py = int((points(i)%y * (h/4.09)) + (h / 2))
      pic(px, py) = 255               ! WARNING COREDUMP ?
    enddo

    deallocate(points)

end subroutine plot_pickover

!===============================================================
! 
!  d'après les pages NN/NN du livre de Roger T Stevens
!       "Fractal programming in C"
! 
subroutine lorentz_0(pic, count)
    implicit none
    integer, intent(inout), dimension (:,:)  ::  pic
    integer, intent(in)                      ::  count

! XXX    double precision      :: xa, ya, za, xb, yb, zb
! XXX    double precision      :: ka, kb, kc, kd
! XXX    integer               :: i, w, h, px, py

   write(0, *) "proc lorentz_0, count is ", count

end subroutine lorentz_0

!===============================================================
!           -- some support functions --
!-----------------------------------------------------------
!       usage : evolvopick & voxelize
subroutine interp4dp (ina, inb, out, dpk)
    double precision, dimension(4), intent(in)   :: ina, inb
    double precision, dimension(4), intent(out)  :: out
    double precision, intent(in)                 :: dpk
    integer                                      :: foo

    do foo=1, 4
      out(foo) = (ina(foo) * (1.0-dpk)) + (inb(foo) * (dpk))
    enddo

end subroutine
!-----------------------------------------------------------

function dist0 (x, y)
  implicit none
  real, intent(in)    :: x, y
  real                :: dist0
  dist0 = ( x*x + y*y )
end function

!-----------------------------------------------------------
function modulus2(pt)
  implicit none
  complex, intent(in)    ::   pt
  real                   ::   modulus2
  modulus2 = real(pt)*real(pt) + imag(pt)*imag(pt)
end
!-----------------------------------------------------

end module fraktals