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  = 1024
  integer, parameter      :: S_HEIGHT = 1024
  integer, parameter      :: NB_BODY  = 51

  !!! 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)

  ! STOP 'BEFORE CRASH'

  call la_grande_boucle(0, 2000, planets)

  STOP ': YOLO TIME *NOW*'

!-----------------------------------------------------------------------
contains
!-
!         fabrication d'une 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.)
  
    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)

    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 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*13, 255)
      cmap(ix, iy)%g = mod(near*14, 255)
      cmap(ix, iy)%b = mod(near*15, 255)

    enddo
  enddo

  call rgbpix_spit_as_pnm(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

  integer, parameter      :: EE = 51
  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

    moons(foo)%heading = moons(foo)%heading + (0.78*(rand()-0.50))
    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