Fortraneries/GravityField/animation.f90

!-----------------------------------------------------------------------
!-
!       Project "gravity field" - Firts renderer
!-
!-----------------------------------------------------------------------
program animation

  use realfield

  use spitpgm             ! extern module
  use pixrgb              ! extern module
              
  implicit none

  ! some configuration constants
  integer, parameter      :: S_WIDTH  = 2048
  integer, parameter      :: S_HEIGHT = 2048
  integer, parameter      :: NB_BODY  = 250

  !!! WARNING : global variable !!!
  type(massbody)          :: planets(NB_BODY)

  call init_random()
  call create_some_planets(planets, 1664e3, S_WIDTH , S_HEIGHT)
  call print_barycentre_bodies(planets, 'begin')

  call la_grande_boucle(0, 2000, planets)

  STOP ': YOLO TIME *NOW*'

!-----------------------------------------------------------------------
contains
!-
!         fabrication de la sequence complete
!-
subroutine la_grande_boucle(start, nbre, moons)
  integer, intent(in)            :: start, nbre
  type(massbody), intent(inout)  :: moons(:)

  character(len=100)      :: filename
  integer                 :: pass 

  do pass=start, start+nbre-1
    ! if second parameter is TRUE, use clipping,
    !                     else     use ?????ing
    call deplace_les_planetes(moons, .TRUE.)
  
    ! computing the field (used as a HF in Povray
    write (filename, "(a, i5.5, a)") 'WS/nanim/', pass, '.pgm'
    write(0, '(3I5, "    *  ", a20)') start, nbre, pass, filename
    call build_and_write_a_field(S_WIDTH, S_HEIGHT, moons, filename)

    ! save the current bodies positions (can be used in gnuplot)
    ! write (filename, "(a, i5.5, a)") 'WS/data/', pass, '.txt'
    ! call save_bodies_to_txt_file (planets, filename)

    write (filename, "(a, i5.5, a)") 'WS/colmap/', pass, '.pnm'
    call make_color_map(planets, filename, S_WIDTH, S_HEIGHT)

  enddo

call print_barycentre_bodies(moons, 'end')

end subroutine

!-----------------------------------------------------------------------
!-
!      this is going to go very complex
!-
subroutine make_color_map(moons, fname, width, height)
  type(massbody), intent(in)       :: moons(:)
  character(len=*), intent(in)     :: fname
  integer, intent(in)              :: width, height

  type(t_pixrgb), dimension(:,:), allocatable  :: cmap
  integer                                      :: ix, iy, near, ipl
  integer                                      :: errcode
  real                                         :: curdist, smalldist 
  real                                         :: fx, fy, dx, dy

  write(0, *) "colmap ", ubound(moons, 1), "moons to ", trim(fname)
  ! write(0, *) "mapsize ", width, height

  allocate (cmap(width, height), stat=errcode)
  ! write(0, *) "errcode allocate ", errcode

  ! map = -1       ! invalidate colmap

  !             DO SOME GOOD STUFF HERE
  do ix=1, width
    fx = real(ix)
    do iy=1, height
      fy = real(iy)

      near      = -1
      smalldist = 1e37

      ! loop over all the planet's bodies
      do ipl=1, ubound(moons, 1)
        ! compute the pseudo distance
        dx = fx - moons(ipl)%posx
        dy = fy - moons(ipl)%posy
        curdist = (dx*dx) + (dy*dy)
        if (curdist .LT. smalldist) then
          near = ipl
          smalldist = curdist
        endif
      end do    ! loop on all the moons, ipl index

      cmap(ix, iy)%r = mod(near*3, 255)
      cmap(ix, iy)%g = mod(near*4, 255)
      cmap(ix, iy)%b = mod(near*5, 255)

    enddo
  enddo

  call rgbpix_spit_as_pnm_8(cmap, fname)

  deallocate(cmap)

end subroutine
!-----------------------------------------------------------------------
!-
!     C'est ici que se passe le deplacement des choses mouvantes
!-
!     Il y a deux manieres d'aborder les bords de l'univers (non, le combo
!     segfault/coredump n'en fait pas partie).
!-
subroutine deplace_les_planetes(moons, clipit)
  type(massbody), intent(inout)    :: moons(:)
  logical, intent(in)              :: clipit

  integer                 :: foo
  real                    :: depx, depy, coef

  integer, parameter      :: EE = 100
  integer                 :: SW = S_WIDTH  - EE
  integer                 :: SH = S_HEIGHT - EE

  do foo=1, ubound(moons, 1)

    ! print *, "----- deplace ",foo, "serial ", moons(foo)%serial
    depx = moons(foo)%speed * sin(moons(foo)%heading)
    depy = moons(foo)%speed * cos(moons(foo)%heading)
    moons(foo)%posx = moons(foo)%posx + depx
    moons(foo)%posy = moons(foo)%posy + depy

    !-
    !   ici se pose une question pertinente sur la gestion des
    !   bords du chanmp. Clipping, Toring or Boucing ?
    !-
    if (clipit) then
      if (moons(foo)%posx .GT. SW)     moons(foo)%posx = SW
      if (moons(foo)%posy .GT. SH)     moons(foo)%posy = SH
      if (moons(foo)%posx .LT. EE)     moons(foo)%posx = EE
      if (moons(foo)%posy .LT. EE)     moons(foo)%posy = EE
      ! STOP 'BECAUSE WE ARE TOTALY FUCKED'
    else
      if (moons(foo)%posx .GT. SW)     moons(foo)%posx = EE
      if (moons(foo)%posy .GT. SH)     moons(foo)%posy = EE
      if (moons(foo)%posx .LT. EE)     moons(foo)%posx = SW
      if (moons(foo)%posy .LT. EE)     moons(foo)%posy = SH
    endif

    if (rand() .LT. 0.15) then
      coef = 1.63
    else
      coef = 0.78
    endif
    moons(foo)%heading = moons(foo)%heading + (coef*(rand()-0.42))
    if (moons(foo)%heading .GT. 6.283185307) moons(foo)%heading = 0.0
    if (moons(foo)%heading .LT. 0.000000001) moons(foo)%heading = 0.0

  enddo

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

end program