Quellcode-Bibliothek

^© Kompilation durch diese Firma

[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]

Datei: yts768.cob Sprache: Cobol

Original von: f90gl^©

module stars_mod
use opengl_gl
use opengl_glu
use opengl_glut
implicit none

real(gldouble), parameter :: M_PI = 3.14159265358979323846_gldouble

integer(glenum), parameter :: &
  NORMAL = 0, &
  WEIRD = 1

integer(glenum), parameter :: &
  STREAK = 0, &
  CIRCLE = 1

integer, parameter :: MAXSTARS = 400
integer, parameter :: MAXPOS = 10000
integer, parameter :: MAXWARP = 10
integer, parameter :: MAXANGLES = 6000

type starRec
  integer(GLint) type
  real x(0:1), y(0:1), z(0:1)
  real offsetX, offsetY, offsetR, rotation
end type starRec

logical(GLboolean) doubleBuffer
integer(GLint) :: windW = 300, windH = 300

integer(GLenum) :: flag = NORMAL
integer(GLint) :: starCount = MAXSTARS / 2
real :: speed = 1.0
integer(GLint) :: nitro = 0
type(starRec) :: stars(0:MAXSTARS)
real :: sinTable(0:MAXANGLES)

contains

function mySin(angle)
real, intent(in) :: angle
real mySin
  mySin = sinTable(mod(int(angle),MAXANGLES))
return
end function mySin

function myCos(angle)
real, intent(in) :: angle
real myCos
   myCos = sinTable(mod(int(angle) + (MAXANGLES / 4),MAXANGLES))
return
end function myCos

subroutine NewStar(n, d)
integer(glint), intent(in) :: n,d
  if (mod(rand(),4) == 0) then
    stars(n)%type = CIRCLE
  else
    stars(n)%type = STREAK
  end if
  stars(n)%x(0) = mod(rand(), MAXPOS) - MAXPOS / 2
  stars(n)%y(0) = mod(rand(), MAXPOS) - MAXPOS / 2
  stars(n)%z(0) = mod(rand(), MAXPOS) + d
  stars(n)%x(1) = stars(n)%x(0)
  stars(n)%y(1) = stars(n)%y(0)
  stars(n)%z(1) = stars(n)%z(0)
  if (mod(rand(), 4) == 0 .and. flag == WEIRD) then
    stars(n)%offsetX = mod(rand(), 100) - 100 / 2
    stars(n)%offsetY = mod(rand(), 100) - 100 / 2
    stars(n)%offsetR = mod(rand(), 25) - 25 / 2
  else
    stars(n)%offsetX = 0.0
    stars(n)%offsetY = 0.0
    stars(n)%offsetR = 0.0
  end if
return
end subroutine NewStar

subroutine RotatePoint(x, y, rotation)
real, intent(in out) :: x,y
real, intent(in) :: rotation
  real tmpX, tmpY

  tmpX = x * myCos(rotation) - y * mySin(rotation)
  tmpY = y * myCos(rotation) + x * mySin(rotation)
  x = tmpX
  y = tmpY
return
end subroutine RotatePoint

subroutine MoveStars()
  real offset
  integer(GLint) n

  offset = speed * 60.0

  do n=0,starCount
    stars(n)%x(1) = stars(n)%x(0)
    stars(n)%y(1) = stars(n)%y(0)
    stars(n)%z(1) = stars(n)%z(0)
    stars(n)%x(0) = stars(n)%x(0) + stars(n)%offsetX
    stars(n)%y(0) = stars(n)%y(0) + stars(n)%offsetY
    stars(n)%z(0) = stars(n)%z(0) - offset
    stars(n)%rotation = stars(n)%rotation + stars(n)%offsetR
    if (stars(n)%rotation >= MAXANGLES) then
      stars(n)%rotation = 0.0
    end if
  end do
return
end subroutine MoveStars

function StarPoint(n)
integer(glint), intent(in) :: n
logical(glboolean) :: StarPoint
  real x0, y0

  x0 = stars(n)%x(0) * windW / stars(n)%z(0)
  y0 = stars(n)%y(0) * windH / stars(n)%z(0)
  call RotatePoint(x0, y0, stars(n)%rotation)
  x0 = x0 + windW / 2.0
  y0 = y0 + windH / 2.0

  if (x0 >= 0.0 .and. x0 < windW .and. y0 >= 0.0 .and. y0 < windH) then
    StarPoint = GL_TRUE
  else
    StarPoint = GL_FALSE
  end if
return
end function StarPoint

subroutine ShowStar(n)
integer(glint), intent(in) :: n
  real x0, y0, x1, y1, width, x, y
  integer(GLint) i

  x0 = stars(n)%x(0) * windW / stars(n)%z(0)
  y0 = stars(n)%y(0) * windH / stars(n)%z(0)
  call RotatePoint(x0, y0, stars(n)%rotation)
  x0 = x0 + windW / 2.0
  y0 = y0 + windH / 2.0

  if (x0 >= 0.0 .and. x0 < windW .and. y0 >= 0.0 .and. y0 < windH) then
    if (stars(n)%type == STREAK) then
      x1 = stars(n)%x(1) * windW / stars(n)%z(1)
      y1 = stars(n)%y(1) * windH / stars(n)%z(1)
      call RotatePoint(x1, y1, stars(n)%rotation)
      x1 = x1 + windW / 2.0
      y1 = y1 + windH / 2.0

      call glLineWidth(MAXPOS / 100.0 / stars(n)%z(0) + 1.0)
      call glColor3f(1.0, (MAXWARP - speed) / MAXWARP, (MAXWARP - speed) / MAXWARP)
      if (abs(x0 - x1) < 1.0 .and. abs(y0 - y1) < 1.0) then
        call glBegin(GL_POINTS)
        call glVertex2f(x0, y0)
        call glEnd()
      else
        call glBegin(GL_LINES)
        call glVertex2f(x0, y0)
        call glVertex2f(x1, y1)
        call glEnd()
      end if
    else
      width = MAXPOS / 10.0 / stars(n)%z(0) + 1.0
      call glColor3f(1.0, 0.0, 0.0)
      call glBegin(GL_POLYGON)
      do i=0,7
        x = x0 + width * myCos(i * MAXANGLES / 8.0)
        y = y0 + width * mySin(i * MAXANGLES / 8.0)
        call glVertex2f(x, y)
      end do
      call glEnd()
    end if
  end if
return
end subroutine ShowStar

subroutine UpdateStars()
  integer(GLint) n

  call glClear(GL_COLOR_BUFFER_BIT)

  do n=0,starCount
    if (stars(n)%z(0) > speed .or. (stars(n)%z(0) > 0.0 .and. speed < MAXWARP)) then
      if (.not.StarPoint(n)) then
        call NewStar(n, MAXPOS)
      end if
    else
      call NewStar(n, MAXPOS)
    end if
  end do
return
end subroutine UpdateStars

subroutine ShowStars()
  integer(GLint) n

  call glClear(GL_COLOR_BUFFER_BIT)

  do n=0,starCount
    if (stars(n)%z(0) > speed .or. (stars(n)%z(0) > 0.0 .and. speed < MAXWARP)) then
      call ShowStar(n)
    end if
  end do
return
end subroutine ShowStars

subroutine Init()
  real angle
  integer(GLint) n

  call random_seed

  do n=0,MAXSTARS
    call NewStar(n, 100)
  end do

  angle = 0.0
  do n=0,MAXANGLES
    sinTable(n) = sin(angle)
    angle = angle + M_PI / (MAXANGLES / 2.0)
  end do

  call glClearColor(0.0, 0.0, 0.0, 0.0)

  call glDisable(GL_DITHER)
return
end subroutine Init

subroutine Reshape(width, height)
integer(glcint), intent(in out) :: width, height
  windW = width
  windH = height

  call glViewport(0, 0, windW, windH)

  call glMatrixMode(GL_PROJECTION)
  call glLoadIdentity()
  call gluOrtho2D(-0.5_gldouble, windW + 0.5_gldouble, -0.5_gldouble, windH + 0.5_gldouble)
  call glMatrixMode(GL_MODELVIEW)
return
end subroutine Reshape

!/* ARGSUSED1 */
subroutine Key(ikey, x, y)
integer(glcint), intent(in out) :: ikey, x, y
  select case(ikey)
  case (iachar(' '))
    if (flag == NORMAL) then
       flag = WEIRD
    else
       flag = NORMAL
    end if
  case (iachar('t'))
    nitro = 1
  case (27)
    stop
  end select
return
end subroutine key

subroutine Idle()
  call MoveStars()
  call UpdateStars()
  if (nitro > 0) then
    speed = (nitro / 10.) + 1.0
    if (speed > MAXWARP) then
      speed = MAXWARP
    end if
    nitro = nitro + 1
    if (nitro > MAXWARP * 10) then
      nitro = -nitro
    end if
  elseif (nitro < 0) then
    nitro = nitro + 1
    speed = (-nitro / 10.) + 1.0
    if (speed > MAXWARP) then
      speed = MAXWARP
    end if
  end if
  call glutPostRedisplay()
return
end subroutine Idle

subroutine Display()
  call ShowStars()
  if (doubleBuffer) then
    call glutSwapBuffers()
  else
    call glFlush()
  end if
return
end subroutine Display

subroutine Visible(state)
integer(glcint), intent(in out) :: state
  if (state == GLUT_VISIBLE) then
    call glutIdleFunc(Idle)
  else
    call glutIdleFunc(GLUTNULLFUNC)
  end if
return
end subroutine visible

!static void
!Args(int argc, char **argv)
!{
!  GLint i;
!
!  doubleBuffer = GL_TRUE;
!
!  for (i = 1; i < argc; i++) {
!    if (strcmp(argv(i), "-sb") == 0) {
!      doubleBuffer = GL_FALSE;
!    } else if (strcmp(argv(i), "-db") == 0) {
!      doubleBuffer = GL_TRUE;
!    }
!  }
!}

function rand()
integer :: rand
real :: frand
  call random_number(frand)
  rand = 32768*frand
return
end function rand

end module stars_mod

program stars_prog
use opengl_gl
use opengl_glut
use stars_mod
  integer(GLenum) type
  integer(glcint) win

  call glutInitWindowSize(windW, windH)
  call glutInit()
  doubleBuffer = GL_TRUE !  Args(argc, argv);

  type = GLUT_RGB
  if (doubleBuffer) then
     type = ior(type,GLUT_DOUBLE)
  else
     type = ior(type,GLUT_SINGLE)
  end if
  call glutInitDisplayMode(type)
  win = glutCreateWindow("Stars")

  call Init()

  call glutReshapeFunc(Reshape)
  call glutKeyboardFunc(Key)
  call glutVisibilityFunc(Visible)
  call glutDisplayFunc(Display)
  call glutMainLoop()
stop
end program stars_prog

¤ Dauer der Verarbeitung: 0.31 Sekunden (vorverarbeitet) ¤

Download des Quellennavigators
Download des sprechenden Kalenders
in der Quellcodebibliothek suchen

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.