|
! In addition to modifications for the F and ELF90 subsets, rgb_colors was
! changed from glubyte to glfloat
module olympic_mod
use opengl_gl
use opengl_glu
use opengl_glut
implicit none
private
public :: fReshape, Key, visible, DrawScene, Init
private :: FillTorus, Clamp, MyRand, ReInit, Idle
integer, parameter, private :: &
XSIZE = 100, &
YSIZE = 75, &
RINGS = 5, &
BLUERING = 0, &
BLACKRING = 1, &
REDRING = 2, &
YELLOWRING = 3, &
GREENRING = 4, &
BLACK = 0, &
RED = 1, &
GREEN = 2, &
YELLOW = 3, &
BLUE = 4, &
MAGENTA = 5, &
CYAN = 6, &
WHITE = 7
real(kind=glfloat), parameter, private :: BACKGROUND = 8.0
integer, parameter, private :: double = kind(0.0_gldouble)
real, parameter, private :: M_PI = 3.141592654
integer(kind=glenum), public :: rgb, doubleBuffer
!integer(kind=glubyte), private, dimension(0:RINGS-1,0:2) :: rgb_colors
real(kind=glfloat), private, dimension(0:RINGS-1,0:2) :: rgb_colors
integer(kind=glint), private, dimension(0:RINGS-1) :: mapped_colors
real(kind=glfloat), private, dimension(0:RINGS-1,0:2) :: dests
real(kind=glfloat), private, dimension(0:RINGS-1,0:2) :: offsets
real(kind=glfloat), private, dimension(0:RINGS-1) :: angs
real(kind=glfloat), private, dimension(0:RINGS-1,0:2) :: rotAxis
integer, private, dimension(0:RINGS-1) :: iters
integer(kind=gluint), private :: theTorus
contains
subroutine FillTorus(rc, numc, rt, numt)
real, intent(in) :: rc, rt
integer, intent(in) :: numc, numt
integer :: i, j, k
real :: s, t
real(kind=glfloat) :: x, y, z
real :: pi, twopi
pi = M_PI
twopi = 2 * pi
do i = 0, numc-1
call glbegin(GL_QUAD_STRIP)
do j = 0, numt
do k = 1, 0, -1
s = modulo((i + k), numc) + 0.5
t = modulo(j, numt)
x = cos(t * twopi / numt) * cos(s * twopi / numc)
y = sin(t * twopi / numt) * cos(s * twopi / numc)
z = sin(s * twopi / numc)
call glnormal3f(x, y, z)
x = (rt + rc * cos(s * twopi / numc)) * cos(t * twopi / numt)
y = (rt + rc * cos(s * twopi / numc)) * sin(t * twopi / numt)
z = rc * sin(s * twopi / numc)
call glvertex3f(x, y, z)
end do
end do
call glend()
end do
return
end subroutine FillTorus
function Clamp(iters_left,t) result(resClamp)
integer, intent(in) :: iters_left
real, intent(in) :: t
real :: resClamp
if (iters_left < 3) then
resClamp = 0.0
else
resClamp = (iters_left - 2) * t / iters_left
end if
return
end function Clamp
subroutine MyRand(resMyRand)
real, intent(out) :: resMyRand
real :: rval
call random_number(rval)
resMyRand = 10.0 * (rval - 0.5)
return
end subroutine MyRand
subroutine ReInit()
integer :: i
real :: deviation, temp
call MyRand(deviation)
deviation = deviation / 2
deviation = deviation * deviation
do i = 0, RINGS-1
call MyRand(offsets(i,0))
call MyRand(offsets(i,1))
call MyRand(offsets(i,2))
call MyRand(angs(i))
angs(i) = 260.0 * angs(i)
call MyRand(rotAxis(i,0))
call MyRand(rotAxis(i,1))
call MyRand(rotAxis(i,2))
call MyRand(temp)
iters(i) = (deviation * temp + 60.0)
end do
return
end subroutine ReInit
subroutine Init()
real(kind=glfloat), save :: top_y = 1.0
real(kind=glfloat), save :: bottom_y = 0.0
real(kind=glfloat), save :: top_z = 0.15
real(kind=glfloat), save :: bottom_z = 0.69
real(kind=glfloat), save :: fspacing = 2.5
real(kind=glfloat), save, dimension(4) :: lmodel_ambient = (/0.0, 0.0, 0.0, 0.0/)
real(kind=glfloat), save, dimension(1) :: lmodel_twoside = (/GL_FALSE/)
real(kind=glfloat), save, dimension(1) :: lmodel_local = (/GL_FALSE/)
real(kind=glfloat), save, dimension(4) :: light0_ambient = (/0.1, 0.1, 0.1, 1.0/)
real(kind=glfloat), save, dimension(4) :: light0_diffuse = (/1.0, 1.0, 1.0, 0.0/)
real(kind=glfloat), save, dimension(4) :: light0_position = (/0.8660254, 0.5, 1.0, 0.0/)
real(kind=glfloat), save, dimension(4) :: light0_specular = (/1.0, 1.0, 1.0, 0.0/)
real(kind=glfloat), save, dimension(4) :: bevel_mat_ambient = (/0.0, 0.0, 0.0, 1.0/)
real(kind=glfloat), save, dimension(1) :: bevel_mat_shininess = (/40.0/)
real(kind=glfloat), save, dimension(4) :: bevel_mat_specular = (/1.0, 1.0, 1.0, 0.0/)
real(kind=glfloat), save, dimension(4) :: bevel_mat_diffuse = (/1.0, 0.0, 0.0, 0.0/)
call random_seed()
call ReInit()
! changed for glfloat rgb_colors
rgb_colors = 0.0_glfloat
rgb_colors(BLUERING,2) = 1.0_glfloat
rgb_colors(REDRING,0) = 1.0_glfloat
rgb_colors(GREENRING,1) = 1.0_glfloat
rgb_colors(YELLOWRING,0) = 1.0_glfloat
rgb_colors(YELLOWRING,1) = 1.0_glfloat
mapped_colors(BLUERING) = BLUE
mapped_colors(REDRING) = RED
mapped_colors(GREENRING) = GREEN
mapped_colors(YELLOWRING) = YELLOW
mapped_colors(BLACKRING) = BLACK
dests(BLUERING,:) = (/-fspacing, top_y, top_z/)
dests(BLACKRING,:) = (/0.0, top_y, top_z/)
dests(REDRING,:) = (/fspacing, top_y, top_z/)
dests(YELLOWRING,:) = (/-fspacing / 2.0, bottom_y, bottom_z/)
dests(GREENRING,:) = (/fspacing / 2.0, bottom_y, bottom_z/)
theTorus = glgenlists(1)
call glnewlist(theTorus, GL_COMPILE)
call FillTorus(0.1, 8, 1.0, 25)
call glendlist()
call glenable(GL_CULL_FACE)
call glcullface(GL_BACK)
call glenable(GL_DEPTH_TEST)
call glcleardepth(1.0_glclampd)
if (rgb == GL_TRUE) then
call glclearcolor(0.5_glclampf, 0.5_glclampf, 0.5_glclampf, 0.0_glclampf)
call gllightfv(GL_LIGHT0, GL_AMBIENT, light0_ambient)
call gllightfv(GL_LIGHT0, GL_DIFFUSE, light0_diffuse)
call gllightfv(GL_LIGHT0, GL_SPECULAR, light0_specular)
call gllightfv(GL_LIGHT0, GL_POSITION, light0_position)
call glenable(GL_LIGHT0)
call gllightmodelfv(GL_LIGHT_MODEL_LOCAL_VIEWER, lmodel_local)
call gllightmodelfv(GL_LIGHT_MODEL_TWO_SIDE, lmodel_twoside)
call gllightmodelfv(GL_LIGHT_MODEL_AMBIENT, lmodel_ambient)
call glenable(GL_LIGHTING)
call glmaterialfv(GL_FRONT, GL_AMBIENT, bevel_mat_ambient)
call glmaterialfv(GL_FRONT, GL_SHININESS, bevel_mat_shininess)
call glmaterialfv(GL_FRONT, GL_SPECULAR, bevel_mat_specular)
call glmaterialfv(GL_FRONT, GL_DIFFUSE, bevel_mat_diffuse)
call glcolormaterial(GL_FRONT_AND_BACK, GL_DIFFUSE)
call glenable(GL_COLOR_MATERIAL)
call glshademodel(GL_SMOOTH)
else
call glclearindex(BACKGROUND)
call glshademodel(GL_FLAT)
end if
call glmatrixmode(GL_PROJECTION)
call gluperspective(45.0_gldouble, 1.33_gldouble, 0.1_gldouble, 100.0_gldouble)
call glmatrixmode(GL_MODELVIEW)
return
end subroutine Init
subroutine Idle()
integer :: i, j
integer(kind=glenum), save :: more = GL_FALSE
do i = 0, RINGS-1
if (iters(i) /= 0) then
do j = 0, 2
offsets(i,j) = Clamp(iters(i), offsets(i,j))
end do
angs(i) = Clamp(iters(i), angs(i))
iters(i) = iters(i) - 1
more = GL_TRUE
end if
end do
if (more == GL_TRUE) then
call glutpostredisplay()
else
call glutidlefunc()
end if
return
end subroutine Idle
subroutine fReshape(width,height)
integer(kind=glcint), intent(in out) :: width, height
! if glcint is not the same as glsizei, width and height will
! need to be copied to variables of the later kind
call glviewport(0_glint, 0_glint, width, height)
return
end subroutine fReshape
subroutine Key(ikey, x, y)
integer(kind=glcint), intent(in out) :: ikey, x, y
select case(ikey)
case (27) ! esc
stop
case (ichar(" "))
call ReInit()
call glutidlefunc(Idle)
end select
return
end subroutine Key
! fortran handling of command line arguments is nonstandard, so
! this feature is omitted. Here is the original C code.
!GLenum
!Args(int argc, char **argv)
!{
! GLint i;
!
! rgb = GL_TRUE;
! doubleBuffer = GL_TRUE;
!
! for (i = 1; i < argc; i++) {
! if (strcmp(argv[i], "-ci") == 0) {
! rgb = GL_FALSE;
! } else if (strcmp(argv[i], "-rgb") == 0) {
! rgb = GL_TRUE;
! } else if (strcmp(argv[i], "-sb") == 0) {
! doubleBuffer = GL_FALSE;
! } else if (strcmp(argv[i], "-db") == 0) {
! doubleBuffer = GL_TRUE;
! } else {
! printf("%s (Bad option).\n", argv[i]);
! return GL_FALSE;
! }
! }
! return GL_TRUE;
!}
subroutine visible(vis)
integer(kind=glcint), intent(in out) :: vis
if (vis == GLUT_VISIBLE) then
call glutidlefunc(Idle)
else
call glutidlefunc()
end if
return
end subroutine visible
subroutine DrawScene()
integer :: i
call glpushmatrix()
call glclear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
call glulookat(0.0_gldouble, 0.0_gldouble, 10.0_gldouble, &
0.0_gldouble, 0.0_gldouble, 0.0_gldouble, &
0.0_gldouble, 1.0_gldouble, 0.0_gldouble)
do i = 0, RINGS-1
if (rgb == GL_TRUE) then
! call glcolor3ubv(rgb_colors(i,:))
call glcolor3fv(rgb_colors(i,:))
else
call glindexi(mapped_colors(i))
end if
call glpushmatrix()
call gltranslatef(dests(i,0) + offsets(i,0), dests(i,1) + offsets(i,1), &
dests(i,2) + offsets(i,2))
call glrotatef(angs(i), rotAxis(i,0), rotAxis(i,1), rotAxis(i,2))
call glcalllist(theTorus)
call glpopmatrix()
end do
call glpopmatrix()
if (doubleBuffer == GL_TRUE) then
call glutswapbuffers()
else
call glflush()
end if
return
end subroutine DrawScene
end module olympic_mod
program main
use opengl_gl
use opengl_glu
use opengl_glut
use olympic_mod
implicit none
integer(kind=glenum) :: ftype
integer :: i
call glutinitwindowsize(400_glcint, 300_glcint)
! not checking command line arguments
! glutInit(&argc, argv);
! if (Args(argc, argv) == GL_FALSE) {
! exit(1);
! }
call glutinit()
rgb = GL_TRUE ! default values which could have been
doubleBuffer = GL_TRUE ! overwritten by command line arguments
if (rgb == GL_TRUE) then
ftype = GLUT_RGB
else
ftype = GLUT_INDEX
end if
if (doubleBuffer == GL_TRUE) then
ftype = ior(ftype,GLUT_DOUBLE)
else
ftype = ior(ftype,GLUT_SINGLE)
end if
call glutinitdisplaymode(ftype)
i = glutcreatewindow("Olympic")
call Init()
call glutreshapefunc(fReshape)
call glutkeyboardfunc(Key)
call glutdisplayfunc(DrawScene)
call glutvisibilityfunc(visible)
call glutmainloop()
stop
end program main
¤ Dauer der Verarbeitung: 0.18 Sekunden
(vorverarbeitet)
¤
|
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.
|
