Quelle polyoff.f90 Sprache: Fortran

! Example polyoff translated to Fortran by William F. Mitchell, NIST.
! The Fortran version is a contribution of NIST and not suject to copyright.
! The original C version contained the following copyright notice:
!/*
! * Copyright (c) 1993-1997, Silicon Graphics, Inc.
! * ALL RIGHTS RESERVED
! * Permission to use, copy, modify, and distribute this software for
! * any purpose and without fee is hereby granted, provided that the above
! * copyright notice appear in all copies and that both the copyright notice
! * and this permission notice appear in supporting documentation, and that
! * the name of Silicon Graphics, Inc. not be used in advertising
! * or publicity pertaining to distribution of the software without specific,
! * written prior permission.
! *
! * THE MATERIAL EMBODIED ON THIS SOFTWARE IS PROVIDED TO YOU "AS-IS"
! * AND WITHOUT WARRANTY OF ANY KIND, EXPRESS, IMPLIED OR OTHERWISE,
! * INCLUDING WITHOUT LIMITATION, ANY WARRANTY OF MERCHANTABILITY OR
! * FITNESS FOR A PARTICULAR PURPOSE.  IN NO EVENT SHALL SILICON
! * GRAPHICS, INC.  BE LIABLE TO YOU OR ANYONE ELSE FOR ANY DIRECT,
! * SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY
! * KIND, OR ANY DAMAGES WHATSOEVER, INCLUDING WITHOUT LIMITATION,
! * LOSS OF PROFIT, LOSS OF USE, SAVINGS OR REVENUE, OR THE CLAIMS OF
! * THIRD PARTIES, WHETHER OR NOT SILICON GRAPHICS, INC.  HAS BEEN
! * ADVISED OF THE POSSIBILITY OF SUCH LOSS, HOWEVER CAUSED AND ON
! * ANY THEORY OF LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE
! * POSSESSION, USE OR PERFORMANCE OF THIS SOFTWARE.
! *
! * US Government Users Restricted Rights
! * Use, duplication, or disclosure by the Government is subject to
! * restrictions set forth in FAR 52.227.19(c)(2) or subparagraph
! * (c)(1)(ii) of the Rights in Technical Data and Computer Software
! * clause at DFARS 252.227-7013 and/or in similar or successor
! * clauses in the FAR or the DOD or NASA FAR Supplement.
! * Unpublished-- rights reserved under the copyright laws of the
! * United States.  Contractor/manufacturer is Silicon Graphics,
! * Inc., 2011 N.  Shoreline Blvd., Mountain View, CA 94039-7311.
! *
! * OpenGL(R) is a registered trademark of Silicon Graphics, Inc.
! */

!   polyoff.f90
!   This program demonstrates polygon offset to draw a shaded
!   polygon and its wireframe counterpart without ugly visual
!   artifacts ("stitching").

module polyoff
use opengl_gl
use opengl_glu
use opengl_glut

private
public :: gfxinit, keyboard, display, mouse

integer(kind=GLuint), private :: list
integer(kind=GLint), private :: spinx = 0
integer(kind=GLint), private :: spiny = 0
real(kind=GLfloat), private :: tdist = 0.0
real(kind=GLfloat), private :: polyfactor = 1.0
real(kind=GLfloat), private :: polyunits = 1.0

contains

!   display() draws two spheres, one with a gray, diffuse material,
!   the other sphere with a magenta material with a specular highlight.

subroutine display()

    real(kind=GLfloat), dimension(4) :: &
                     mat_ambient = (/ 0.8, 0.8, 0.8, 1.0 /), &
                     mat_diffuse = (/ 1.0, 0.0, 0.5, 1.0 /), &
                     mat_specular = (/ 1.0, 1.0, 1.0, 1.0 /), &
                     gray = (/ 0.8, 0.8, 0.8, 1.0 /), &
                     black = (/ 0.0, 0.0, 0.0, 1.0 /)

    call glClear (ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
    call glPushMatrix ()
    call glTranslatef (0.0, 0.0, tdist)
    call glRotatef (real(spinx,GLfloat), 1.0, 0.0, 0.0)
    call glRotatef (real(spiny,GLfloat), 0.0, 1.0, 0.0)

    call glMaterialfv(GL_FRONT, GL_AMBIENT_AND_DIFFUSE, gray)
    call glMaterialfv(GL_FRONT, GL_SPECULAR, black)
    call glMaterialf(GL_FRONT, GL_SHININESS, 0.0)
    call glEnable(GL_LIGHTING)
    call glEnable(GL_LIGHT0)
    call glEnable(GL_POLYGON_OFFSET_FILL)
    call glPolygonOffset(polyfactor, polyunits)
    call glCallList (list)
    call glDisable(GL_POLYGON_OFFSET_FILL)

    call glDisable(GL_LIGHTING)
    call glDisable(GL_LIGHT0)
    call glColor3f (1.0, 1.0, 1.0)
    call glPolygonMode(GL_FRONT_AND_BACK, GL_LINE)
    call glCallList (list)
    call glPolygonMode(GL_FRONT_AND_BACK, GL_FILL)

    call glPopMatrix ()
    call glFlush ()
end subroutine display

!   specify initial properties
!   create display list with sphere
!   initialize lighting and depth buffer

subroutine gfxinit ()

    real(kind=GLfloat), dimension(4) :: &
                     light_ambient = (/ 0.0, 0.0, 0.0, 1.0 /), &
                     light_diffuse = (/ 1.0, 1.0, 1.0, 1.0 /), &
                     light_specular = (/ 1.0, 1.0, 1.0, 1.0 /), &
                     light_position = (/ 1.0, 1.0, 1.0, 0.0 /), &
                     global_ambient = (/ 0.2, 0.2, 0.2, 1.0 /)

    call glClearColor (0.0, 0.0, 0.0, 1.0)

    list = glGenLists(1)
    call glNewList (list, GL_COMPILE)
       call glutSolidSphere(1.0_gldouble, 20_glint, 12_glint)
    call glEndList ()

    call glEnable(GL_DEPTH_TEST)

    call glLightfv (GL_LIGHT0, GL_AMBIENT, light_ambient)
    call glLightfv (GL_LIGHT0, GL_DIFFUSE, light_diffuse)
    call glLightfv (GL_LIGHT0, GL_SPECULAR, light_specular)
    call glLightfv (GL_LIGHT0, GL_POSITION, light_position)
    call glLightModelfv (GL_LIGHT_MODEL_AMBIENT, global_ambient)
end subroutine gfxinit

!   call when window is resized
subroutine reshape(width, height)
integer(kind=glcint), intent(inout) :: width, height

    call glViewport (0, 0, width, height)
    call glMatrixMode (GL_PROJECTION)
    call glLoadIdentity ()
    call gluPerspective(45.0_gldouble, &
                        real(width,GLdouble)/real(height,GLdouble), &
                 1.0_gldouble, 10.0_gldouble)
    call glMatrixMode (GL_MODELVIEW)
    call glLoadIdentity ()
    call gluLookAt (0.0_gldouble, 0.0_gldouble, 5.0_gldouble, &
                    0.0_gldouble, 0.0_gldouble, 0.0_gldouble, &
                    0.0_gldouble, 1.0_gldouble, 0.0_gldouble)
end subroutine reshape

!   call when mouse button is pressed
subroutine mouse(button, state, x, y)
integer(kind=glcint), intent(inout) :: button, state, x, y
    select case (button)
case (GLUT_LEFT_BUTTON)
     select case (state)
  case (GLUT_DOWN)
      spinx = modulo((spinx + 5),360)
                    call glutPostRedisplay()
  case default
            end select
case (GLUT_MIDDLE_BUTTON)
     select case (state)
  case (GLUT_DOWN)
      spiny = modulo((spiny + 5),360)
                    call glutPostRedisplay()
  case default
            end select
case (GLUT_RIGHT_BUTTON)
     select case (state)
  case (GLUT_UP)
                    stop
  case default
            end select
        case default
    end select
end subroutine mouse

subroutine keyboard (key, x, y)
integer(kind=glint), intent(inout) :: key
integer(kind=glcint), intent(inout) :: x, y

   select case (key)
      case (ichar("t"))
         if (tdist < 4.0) then
            tdist = (tdist + 0.5)
            call glutPostRedisplay()
         endif
      case (ichar("T"))
         if (tdist > -5.0) then
            tdist = (tdist - 0.5)
            call glutPostRedisplay()
         endif
      case (ichar("F"))
         polyfactor = polyfactor + 0.1
  print *, "polyfactor is ", polyfactor
         call glutPostRedisplay()
      case (ichar("f"))
         polyfactor = polyfactor - 0.1
  print *, "polyfactor is ", polyfactor
         call glutPostRedisplay()
      case (ichar("U"))
         polyunits = polyunits + 1.0
  print *, "polyunits is ", polyunits
         call glutPostRedisplay()
      case (ichar("u"))
         polyunits = polyunits - 1.0
  print *, "polyunits is ", polyunits
         call glutPostRedisplay()
      case default
   end select
end subroutine keyboard

end module polyoff

!   Main Loop
!   Open window with initial window size, title bar,
!   RGBA display mode, and handle input events.

program main
use polyoff
use opengl_gl
use opengl_glut

integer(kind=glcint) :: iwin
    call glutInit()
    call glutInitDisplayMode(ior(ior(GLUT_SINGLE,GLUT_RGB),GLUT_DEPTH))
    iwin = glutCreateWindow("polyoff")
    call glutReshapeFunc(reshape)
    call glutDisplayFunc(display)
    call glutMouseFunc(mouse)
    call glutKeyboardFunc(keyboard)
    call gfxinit()
    call glutMainLoop()
end program main

quality92%

¤ Dauer der Verarbeitung: 0.12 Sekunden (vorverarbeitet) ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

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.