home *** CD-ROM | disk | FTP | other *** search
/ gondwana.ecr.mu.oz.au/pub/ / Graphics.tar / Graphics / VOGLE.ZIP / VOGLE / EXAMPLES / FLCUBE.FOR < prev    next >
Text File  |  2000-02-11  |  4KB  |  177 lines
  1.  
  2.     program flcube
  3.     parameter(TRANS = 20.0, SC = 0.1)
  4.  
  5.         integer BLACK, FACE, FILLED, OUTLINE
  6.         parameter (BLACK = 0, FACE = 1, FILLED = 2, OUTLINE = 3)
  7.  
  8.     character *10 device, but*1
  9.     integer getdepth, checkkey, slocator, backbuffer
  10.  
  11.     logical back, fill, hatch
  12.  
  13. c    print*, 'Enter output device:'
  14. c    read(*, '(a)') device
  15.     device=' '
  16.  
  17.     call prefposition(50, 50)
  18.     call prefsize(500, 500)
  19.  
  20.     call vinit(device)
  21.  
  22.     call window(-800.0, 800.0, -800.0, 800.0, -800.0, 800.0)
  23.     call lookat(0.0, 0.0, 1500.0, 0.0, 0.0, 0.0, 0.0)
  24.  
  25.     tdir = TRANS
  26.     scal = SC
  27.  
  28. c
  29. c Start with a very ordinary filled cube like in the original demo...
  30. c
  31.     call polyhatch(.false.)
  32.     call hatchang(45.0)
  33.     call hatchpitch(40.0)
  34.     call polyfill(.true.)
  35.  
  36.     fill = .true.
  37.     hatch = .false.
  38.     back = .true.
  39.  
  40.     call makeobj(FACE)
  41.         call makepoly
  42.             call rect(-200.0, -200.0, 200.0, 200.0)
  43.         call closepoly
  44.     call closeobj
  45.  
  46.     call makecube(FILLED)
  47.  
  48.     nplanes = getdepth()
  49.     if (nplanes .eq. 1) call makecube(OUTLINE)
  50.  
  51.     call backface(back)
  52. c
  53. c Setup drawing into the backbuffer....
  54. c
  55.     if (backbuffer().lt.0) then
  56.         call vexit
  57.         write(*,*)'Device can''t support doublebuffering'
  58.         stop
  59.     endif
  60.  
  61. 1    continue
  62.         idum = slocator(x, y)
  63.         call pushmatrix
  64.             call rotate(100.0 * x, 'y')
  65.             call rotate(100.0 * y, 'x')
  66.             call color(BLACK)
  67.             call clear
  68.             call callobj(FILLED)
  69.             if (nplanes .eq. 1 .and. (fill .or. hatch))
  70.      +                call callobj(OUTLINE)
  71.         call popmatrix
  72.         call swapbuffers
  73.  
  74.         
  75.         but = char(checkkey())
  76.         if (but .eq. 'x') then
  77.             call translate(tdir, 0.0, 0.0)
  78.         else if (but .eq. 'y') then
  79.             call translate(0.0, tdir, 0.0)
  80.         else if (but .eq. 'z') then
  81.             call translate(0.0, 0.0, tdir)
  82.         else if (but .eq. 's') then
  83.             call scale(scal, scal, scal)
  84.         else if (but .eq. 'f') then
  85.             fill = .not. fill
  86.             hatch = .false.
  87.             call polyfill(fill)
  88.         else if (but .eq. 'h') then
  89.             hatch = .not. hatch
  90.             fill = .false.
  91.             call polyhatch(hatch)
  92.         else if (but .eq. 'b') then
  93.             back = .not. back
  94.             call backface(back)
  95.         else if (but .eq. '-') then
  96.             tdir = -tdir
  97.             
  98.             if (scal .lt. 1.0) then
  99.                 scal = 1.0 + SC
  100.             else
  101.                 scal = 1.0 - SC
  102.             end if
  103.  
  104.         else if (but .eq. '+') then
  105.             tdir = TRANS
  106.         else if (but .eq. 'q' .or. ICHAR(but) .eq. 27) then
  107.             call vexit
  108.             stop
  109.         end if
  110.  
  111.     goto 1
  112.     end
  113.  
  114.     subroutine makecube(obj)
  115.     integer    obj
  116.         integer BLACK, RED, GREEN, YELLOW, BLUE, CYAN,
  117.      +          MAGENTA, WHITE, OUTLINE, FILLED, FACE
  118.         parameter (BLACK = 0, RED = 1, GREEN = 2, YELLOW = 3,
  119.      +         BLUE = 4, CYAN = 5, MAGENTA = 6, WHITE = 7)
  120.     parameter(FACE = 1, FILLED = 2, OUTLINE = 3)
  121.  
  122.     call makeobj(obj)
  123.         if (obj .eq. OUTLINE) then
  124.             call pushattributes
  125.             call color(BLACK)
  126.             call polyfill(.false.)
  127.             call polyhatch(.false.)
  128.         end if
  129.  
  130.         call pushmatrix
  131.             call translate(0.0, 0.0, 200.0)
  132.             if (obj .eq. FILLED) call color(RED)
  133.             call callobj(FACE)
  134.         call popmatrix
  135.  
  136.         call pushmatrix
  137.             call translate(200.0, 0.0, 0.0)
  138.             call rotate(90.0, 'y')
  139.             if (obj .eq. FILLED) call color(GREEN)
  140.             call callobj(FACE)
  141.         call popmatrix
  142.  
  143.         call pushmatrix
  144.             call translate(0.0, 0.0, -200.0)
  145.             call rotate(180.0, 'y')
  146.             if (obj .eq. FILLED) call color(BLUE)
  147.             call callobj(FACE)
  148.         call popmatrix
  149.  
  150.         call pushmatrix
  151.             call translate(-200.0, 0.0, 0.0)
  152.             call rotate(-90.0, 'y')
  153.             if (obj .eq. FILLED) call color(CYAN)
  154.             call callobj(FACE)
  155.         call popmatrix
  156.  
  157.         call pushmatrix
  158.             call translate(0.0, 200.0, 0.0)
  159.             call rotate(-90.0, 'x')
  160.             if (obj .eq. FILLED) call color(MAGENTA)
  161.             call callobj(FACE)
  162.         call popmatrix
  163.  
  164.         call pushmatrix
  165.             call translate(0.0, -200.0, 0.0)
  166.             call rotate(90.0, 'x')
  167.             if (obj .eq. FILLED) call color(YELLOW)
  168.             call callobj(FACE)
  169.         call popmatrix
  170.  
  171.         if (obj .eq. OUTLINE) call popattributes
  172.  
  173.     call closeobj
  174.  
  175.     return
  176.     end
  177.