home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / P_FOTRAN.LZH / DEMOS.FOR / DOODLE.FOR < prev    next >
Text File  |  1987-12-31  |  23KB  |  580 lines
  1. *     This is a fairly simple GEM application which illustrates many
  2. *     of the main features of the GEM AES and VDI bindings, as well
  3. *     as other features of the Prospero Fortran system.
  4. *
  5. *     Author : R K Chapman
  6. *     Date   : 29 October 1987
  7. *
  8. *     Copyright (C) 1987 Prospero Software Ltd
  9.  
  10.       PROGRAM doodle_demo
  11.       IMPLICIT none
  12.       INTEGER*4 AESret
  13.       
  14.       CALL appl_init
  15.       IF (AESret .ge. 0) THEN
  16.         CALL initialise
  17.         CALL doodle
  18.         CALL terminate
  19.         CALL appl_exit
  20.       END IF
  21.       END
  22.  
  23.       SUBROUTINE newmem(p, size)
  24.       IMPLICIT none
  25.       INTEGER*4 p, size, sys
  26.       
  27.       INTEGER*2 parmarray(0:2)
  28.       INTEGER*2 funcno
  29.       INTEGER*4 bytes
  30.       EQUIVALENCE (funcno, parmarray(0)), (bytes, parmarray(1))
  31.       
  32.       funcno = $48           ! GEMDOS function number
  33.       bytes = size           ! Number of bytes required
  34.       p = sys(parmarray)     ! Address of memory allocated
  35.       END
  36.  
  37.       LOGICAL*4 FUNCTION intersect(x1, y1, w1, h1, x2, y2, w2, h2)
  38.       IMPLICIT none
  39.       INTEGER*4 x1, y1, w1, h1, x2, y2, w2, h2
  40.  
  41.       w1 = min0(w1+x1, w2+x2)-1
  42.       h1 = min0(h1+y1, h2+y2)-1
  43.       x1 = max0(x1, x2)
  44.       y1 = max0(y1, y2)
  45. *     Note w1,h1 are returned as coords rather than width/height
  46.       intersect = ((w1 .ge. x1) .AND. (h1 .ge. y1))
  47.       END
  48.  
  49. !-------------------------------------------------------------------
  50. !       SUBROUTINE redraw - redraw the portions of the given rectangle    
  51. !                    which correspond to visible areas of TheWindow
  52. !-------------------------------------------------------------------
  53.  
  54.       SUBROUTINE redraw(x, y, w, h)
  55.       IMPLICIT none
  56.       INTEGER*2 rect(0:7)
  57.       INTEGER*4 x, y, w, h, rx, ry, rw, rh
  58.       LOGICAL*4 intersect
  59.       INCLUDE 'GEMCONST'
  60.   
  61.       COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
  62.      -                   WorkRect
  63.       INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
  64.       INTEGER*2 WorkRect(0:3)
  65.  
  66.       COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
  67.       INTEGER*2 TheBuffer(0:9)
  68.       INTEGER*4 topleft_x, topleft_y
  69.                                    
  70.       COMMON /workstation/ Workstation, work_in, work_out, extend_out
  71.       INTEGER*4 Workstation
  72.       INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)
  73.  
  74. *     Get first visible area
  75.       CALL wind_get(TheWindow, WF_FIRSTXYWH, rx, ry, rw, rh)
  76.  
  77. 10    CONTINUE
  78.       IF ((rw+rh) .ne. 0) THEN
  79.         IF (intersect(rx, ry, rw, rh, x, y, w, h)) THEN
  80.           rect(0) = rx - wx + topleft_x     ! Source x1
  81.           rect(1) = ry - wy + topleft_y     ! Source y1
  82.           rect(2) = rw - wx + topleft_x     ! Source x2
  83.           rect(3) = rh - wy + topleft_y     ! Source y2
  84.           rect(4) = rx                      ! Dest x1
  85.           rect(5) = ry                      ! Dest y1
  86.           rect(6) = rw                      ! Dest x2
  87.           rect(7) = rh                      ! Dest y2
  88.           CALL graf_mouse(256, 0)           ! hide mouse
  89.           CALL vro_cpyfm(workstation, 3, rect, TheBuffer, 0)
  90.           CALL graf_mouse(257, 0)           ! Show mouse
  91.         END IF
  92. *       Get next visible area
  93.         CALL wind_get(TheWindow, WF_NEXTXYWH, rx, ry, rw, rh)
  94.         GOTO 10
  95.       END IF
  96.       END
  97.  
  98. !-------------------------------------------------------------------
  99. !       SUBROUTINE set_sliders - set the position and size of the sliders 
  100. !-------------------------------------------------------------------
  101.  
  102.       SUBROUTINE set_sliders
  103.       IMPLICIT none
  104.       INCLUDE 'GEMCONST'
  105.       
  106.       COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
  107.      -                   WorkRect
  108.       INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
  109.       INTEGER*2 WorkRect(0:3)
  110.  
  111.       COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
  112.       INTEGER*2 TheBuffer(0:9)
  113.       INTEGER*4 topleft_x, topleft_y
  114.                                    
  115.       CALL wind_set(TheWindow, WF_HSLIDE,
  116.      -              topleft_x * 1000 / (640 - ww), 0, 0, 0)
  117.       CALL wind_set(TheWindow, WF_VSLIDE,
  118.      -              topleft_y * 1000 / (400 - wh), 0, 0, 0)
  119.       CALL wind_set(TheWindow, WF_HSLSIZE,
  120.      -              ww * 1000 / 640, 0, 0, 0)
  121.       CALL wind_set(TheWindow, WF_VSLSIZE,
  122.      -              wh * 1000 / 400, 0, 0, 0)
  123.       END
  124.  
  125. !--------------------------------------------------------------------
  126. !       SUBROUTINE do_shape_title - handle menu selections from Shape title
  127. !--------------------------------------------------------------------
  128.  
  129.       SUBROUTINE do_shape_title(item)
  130.       IMPLICIT none
  131.       INTEGER*4 item
  132.  
  133.       COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
  134.      -                 QuitItem, RectItem, OvalItem, FilledItem,
  135.      -                 ColourItem
  136.       INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
  137.      -          QuitItem, RectItem, OvalItem, FilledItem
  138.       INTEGER*4 ColourItem(0:7)
  139.   
  140.       COMMON /settings/ Filling, TheColour, TheShape
  141.       LOGICAL*4 Filling
  142.       INTEGER*4 TheColour, TheShape
  143.   
  144.       IF (item .eq. FilledItem) THEN
  145.         filling = .NOT. filling
  146.         CALL menu_icheck(TheMenu, FilledItem, filling)
  147.       ELSE
  148.         CALL menu_icheck(TheMenu, TheShape, .false.)
  149.         TheShape = item
  150.         CALL menu_icheck(TheMenu, TheShape, .true.)
  151.       END IF    
  152.       END
  153.  
  154. !-------------------------------------------------------------------
  155. !       SUBROUTINE do_colour_title - handle selections from Colour title  
  156. !-------------------------------------------------------------------
  157.  
  158.       SUBROUTINE do_colour_title(item)
  159.       IMPLICIT none
  160.       INTEGER*4 item, dummy, vsl_color
  161.  
  162.       COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
  163.      -                 QuitItem, RectItem, OvalItem, FilledItem,
  164.      -                 ColourItem
  165.       INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
  166.      -          QuitItem, RectItem, OvalItem, FilledItem
  167.       INTEGER*4 ColourItem(0:7)
  168.   
  169.       COMMON /settings/ Filling, TheColour, TheShape
  170.       LOGICAL*4 Filling
  171.       INTEGER*4 TheColour, TheShape
  172.   
  173.       COMMON /workstation/ Workstation, work_in, work_out, extend_out
  174.       INTEGER*4 Workstation
  175.       INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)
  176.  
  177.       CALL menu_icheck(TheMenu, ColourItem(TheColour), .false.)
  178.       CALL menu_icheck(TheMenu, item, .true.)
  179.       TheColour = item - ColourItem(0)
  180.       dummy = vsl_color(workstation, TheColour) 
  181.       END
  182.  
  183. !--------------------------------------------------------------------
  184. !       SUBROUTINE draw_shape - draw the current shape                     
  185. !--------------------------------------------------------------------
  186.  
  187.       SUBROUTINE draw_shape(x, y)
  188.       IMPLICIT none
  189.       INTEGER*4 x, y, w, h, xcen, ycen, xrad, yrad, dummy
  190.       INTEGER*2 copyrect(0:7)
  191.       INCLUDE 'GEMFUNCS'
  192.       
  193.       COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
  194.      -                 QuitItem, RectItem, OvalItem, FilledItem,
  195.      -                 ColourItem
  196.       INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
  197.      -          QuitItem, RectItem, OvalItem, FilledItem
  198.       INTEGER*4 ColourItem(0:7)
  199.   
  200.       COMMON /settings/ Filling, TheColour, TheShape
  201.       LOGICAL*4 Filling
  202.       INTEGER*4 TheColour, TheShape
  203.   
  204.       COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
  205.      -                   WorkRect
  206.       INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
  207.       INTEGER*2 WorkRect(0:3)
  208.  
  209.       COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
  210.       INTEGER*2 TheBuffer(0:9)
  211.       INTEGER*4 topleft_x, topleft_y
  212.                                    
  213.       COMMON /workstation/ Workstation, work_in, work_out, extend_out
  214.       INTEGER*4 Workstation
  215.       INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)
  216.  
  217.       CALL graf_rubbox(x, y, 5, 5, w, h)         ! Get a rectangle
  218.       dummy = vsf_interior(workstation, 1)       ! select solid fill
  219.       dummy = vsf_color(workstation, TheColour)  ! .. in this colour
  220.       dummy = vsl_color(workstation, TheColour)  ! .. and border    
  221.       CALL vsf_perimeter(workstation, .true.)    ! .. and perimeter 
  222.       CALL graf_mouse(256,0)                     ! Hide mouse
  223.  
  224. *     Define the part of TheBuffer to be updated
  225.       copyrect(0) = x
  226.       copyrect(1) = y
  227.       copyrect(2) = x+w
  228.       copyrect(3) = y+h
  229.       copyrect(4) = copyrect(0) - wx + topleft_x
  230.       copyrect(5) = copyrect(1) - wy + topleft_y
  231.       copyrect(6) = copyrect(2) - wx + topleft_x
  232.       copyrect(7) = copyrect(3) - wy + topleft_y
  233.   
  234. *     Draw the shape
  235.       IF (TheShape .eq. RectItem) THEN
  236.         IF (filling) THEN
  237.           CALL v_rfbox(workstation, copyrect)
  238.         ELSE
  239.           CALL v_rbox(workstation, copyrect)
  240.         END IF
  241.       ELSE IF (TheShape .eq. OvalItem) THEN
  242.         xrad = w / 2
  243.         yrad = h / 2
  244.         xcen = x+xrad
  245.         ycen = y+yrad
  246.         IF (filling) THEN
  247.           CALL v_ellipse(workstation, xcen, ycen, xrad, yrad)
  248.         ELSE
  249.           CALL v_ellarc(workstation,  xcen, ycen, xrad, yrad, 0, 3600)
  250.         END IF
  251.       END IF
  252.       
  253. *     Now update TheBuffer
  254.       CALL vro_cpyfm(workstation, 3, copyrect, 0, TheBuffer) 
  255.   
  256.       CALL graf_mouse(257, 0)                         ! Show mouse
  257.       END
  258.  
  259. !--------------------------------------------------------------------
  260. !       SUBROUTINE doodle - the main event processing loop                 
  261. !--------------------------------------------------------------------
  262.  
  263.       SUBROUTINE doodle
  264.       IMPLICIT none
  265.       INTEGER*2 message(0:7)
  266.       INTEGER*4 dummy, event, mask, mx, my
  267.       INTEGER*4 x, y, w, h
  268.       INTEGER*4 title, item
  269.       LOGICAL*4 inside, quitting
  270.       INCLUDE 'GEMCONST'
  271.       INCLUDE 'GEMFUNCS'
  272.  
  273.       COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
  274.      -                 QuitItem, RectItem, OvalItem, FilledItem,
  275.      -                 ColourItem
  276.       INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
  277.      -          QuitItem, RectItem, OvalItem, FilledItem
  278.       INTEGER*4 ColourItem(0:7)
  279.   
  280.       COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
  281.      -                   WorkRect
  282.       INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
  283.       INTEGER*2 WorkRect(0:3)
  284.  
  285.       COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
  286.       INTEGER*2 TheBuffer(0:9)
  287.       INTEGER*4 topleft_x, topleft_y
  288.                                    
  289.       COMMON /workstation/ Workstation, work_in, work_out, extend_out
  290.       INTEGER*4 Workstation
  291.       INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)
  292.  
  293.       quitting = .false.
  294.       inside = .false.
  295.       CALL graf_mouse(0, 0)
  296.       mask = MU_M1 .OR. MU_MESAG
  297. 10    CONTINUE
  298.         event = evnt_multi(mask, 1, 1, 1,
  299.      -                     inside, wx, wy, ww, wh,
  300.      -                     .false., 0, 0, 0, 0,
  301.      -                     message, 0, mx, my,
  302.      -                     dummy, dummy, dummy, dummy)
  303.         CALL wind_update(BEG_UPDATE)
  304.         
  305.         IF ((event .AND. MU_M1) .ne. 0) THEN
  306.           inside = .NOT. inside
  307.           IF (inside) THEN
  308.             mask = MU_M1 .OR. MU_BUTTON .OR. MU_MESAG
  309.             CALL graf_mouse(5, 0)           ! Cross hair inside window
  310.           ELSE
  311.             mask = MU_M1 .OR. MU_MESAG      ! Don't accept clicks
  312.             CALL graf_mouse(0, 0)           ! Arrow outside window
  313.           END IF
  314.         END IF
  315.         
  316.         IF ((event .AND. MU_MESAG) .ne. 0) THEN
  317.           IF (message(0) .eq. MN_SELECTED) THEN
  318.             title = message(3)
  319.             item  = message(4)
  320.             IF (title .eq. FileTitle) THEN
  321.               quitting = .true.
  322.             ELSE IF (title .eq. ShapeTitle) THEN
  323.               CALL do_shape_title(item)
  324.             ELSE IF (title .eq. ColourTitle) THEN
  325.               CALL do_colour_title(item)
  326.             ELSE   ! Must have selected About ..
  327.               dummy = form_alert(1, '[0][Prospero Fortran Doodle demo'
  328.      -                           // ' | ][  OK  ]' // char(0))
  329.             END IF
  330.             CALL menu_tnormal(TheMenu, title, .true.)
  331.             
  332.           ELSE IF (message(0) .eq. WM_CLOSED) THEN
  333.             quitting = .true.
  334.             
  335.           ELSE IF ((message(0) .eq. WM_MOVED) .OR.
  336.      -             (message(0) .eq. WM_SIZED)) THEN
  337.             x = message(4)
  338.             y = message(5)          ! Extend coords to 4 bytes
  339.             w = message(6)          ! Probably unneccessary here
  340.             h = message(7)          ! as only 2 bytes used by wind_set
  341.             CALL wind_set(TheWindow, WF_CXYWH, x, y, w, h)
  342.             CALL wind_get(TheWindow, WF_WXYWH, wx, wy, ww, wh)
  343.             CALL set_sliders
  344.             WorkRect(0) = wx
  345.             WorkRect(1) = wy
  346.             WorkRect(2) = wx+ww-1
  347.             WorkRect(3) = wy+wh-1
  348.             CALL vs_clip(workstation, .true., WorkRect)
  349.  
  350.           ELSE IF (message(0) .eq. WM_REDRAW) THEN
  351.             x = message(4)
  352.             y = message(5)
  353.             w = message(6)
  354.             h = message(7)        ! Extend coordinates up to 4 bytes
  355.             CALL redraw(x, y, w, h)
  356.  
  357.           ELSE IF (message(0) .eq. WM_VSLID) THEN
  358.             topleft_y = (400 - wh) * message(4) / 1000
  359.             CALL set_sliders
  360.             CALL redraw(wx, wy, ww, wh)
  361.  
  362.           ELSE IF (message(0) .eq. WM_HSLID) THEN
  363.             topleft_x = (640 - ww) * message(4) / 1000
  364.             CALL set_sliders
  365.             CALL redraw(wx, wy, ww, wh)
  366.  
  367.           ELSE IF (message(0) .eq. WM_ARROWED) THEN
  368.             GOTO (21, 22, 23, 24, 25, 26, 27), message(4)
  369.               topleft_y = topleft_y - 50   ! page up
  370.               GOTO 30
  371. 21            topleft_y = topleft_y + 50   ! page down 
  372.               GOTO 30
  373. 22            topleft_y = topleft_y - 5    ! row up    
  374.               GOTO 30
  375. 23            topleft_y = topleft_y + 5    ! row down  
  376.               GOTO 30
  377. 24            topleft_x = topleft_x - 50   ! page left 
  378.               GOTO 30
  379. 25            topleft_x = topleft_x + 50   ! page right
  380.               GOTO 30
  381. 26            topleft_x = topleft_x - 5    ! column left 
  382.               GOTO 30
  383. 27            topleft_x = topleft_x + 5    ! column right
  384.  
  385. 30          CONTINUE
  386.             IF (topleft_x .lt. 0) topleft_x = 0
  387.             IF (topleft_y .lt. 0) topleft_y = 0
  388.             IF (topleft_x .gt. 640 - ww) topleft_x = 640 - ww
  389.             IF (topleft_y .gt. 400 - wh) topleft_y = 400 - wh
  390.             CALL set_sliders
  391.             CALL redraw(wx, wy, ww, wh)
  392.  
  393.           ELSE IF (message(0) .eq. WM_TOPPED) THEN
  394.             CALL wind_set(TheWindow, WF_TOP, 0, 0, 0, 0)
  395.  
  396.           ELSE IF (message(0) .eq. WM_FULLED) THEN
  397.             CALL wind_get(TheWindow, WF_CXYWH, wx, wy, ww, wh)
  398.             IF ((wx .eq. fx) .AND. (wy .eq. fy) .AND.
  399.      -          (ww .eq. fw) .AND. (wh .eq. fh)) THEN
  400.               CALL wind_get(TheWindow, WF_PXYWH, wx, wy, ww, wh)
  401.             ELSE
  402.               CALL wind_get(TheWindow, WF_FXYWH, wx, wy, ww, wh)
  403.             END IF
  404.             CALL wind_set(TheWindow, WF_CXYWH, wx, wy, ww, wh)
  405.             CALL wind_get(TheWindow, WF_WXYWH, wx, wy, ww, wh)
  406.             CALL set_sliders
  407.             WorkRect(0) = wx
  408.             WorkRect(1) = wy
  409.             WorkRect(2) = wx+ww-1
  410.             WorkRect(3) = wy+wh-1
  411.             CALL vs_clip(workstation, .true., WorkRect)
  412.              
  413.           END IF
  414.         END IF
  415.  
  416.         IF ((event .AND. MU_BUTTON) .ne. 0) THEN
  417.            CALL draw_shape(mx, my)
  418.         END IF
  419.  
  420.         CALL wind_update(END_UPDATE)
  421.         IF (.NOT. quitting) GOTO 10
  422.  
  423.       END
  424.  
  425. !-------------------------------------------------------------------
  426. !       SUBROUTINE initialise - set up the workstation, menu etc          
  427. !-------------------------------------------------------------------
  428.  
  429.       SUBROUTINE initialise
  430.       IMPLICIT none
  431.       INTEGER*4 i, dummy, tempitem
  432.       INTEGER*2 copyrect(0:3)
  433.       CHARACTER*20 TheTitle
  434.       INCLUDE 'GEMCONST'
  435.       INCLUDE 'GEMFUNCS'
  436.  
  437.       COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
  438.      -                 QuitItem, RectItem, OvalItem, FilledItem,
  439.      -                 ColourItem
  440.       INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
  441.      -          QuitItem, RectItem, OvalItem, FilledItem
  442.       INTEGER*4 ColourItem(0:7)
  443.   
  444.       COMMON /settings/ Filling, TheColour, TheShape
  445.       LOGICAL*4 Filling
  446.       INTEGER*4 TheColour, TheShape
  447.   
  448.       COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
  449.      -                   WorkRect
  450.       INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
  451.       INTEGER*2 WorkRect(0:3)
  452.  
  453.       COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
  454.       INTEGER*2 TheBuffer(0:9)
  455.       INTEGER*4 topleft_x, topleft_y
  456.                                    
  457.       COMMON /workstation/ Workstation, work_in, work_out, extend_out
  458.       INTEGER*4 Workstation
  459.       INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)
  460.  
  461. *     Open a virtual screen workstation
  462.       workstation = graf_handle(dummy, dummy, dummy, dummy)
  463.       DO 10 i = 0, 9
  464. 10      work_in(i) = 1                    ! Set initial attributes
  465.       work_in(10) = 2                     ! Raster coordinates
  466.       CALL v_opnvwk(work_in, workstation, work_out)
  467.  
  468. *     Prepare TheBuffer memory form, where image is stored
  469.       CALL vq_extnd(workstation, .true., extend_out)
  470.       TheBuffer(2) = 640
  471.       TheBuffer(3) = 400
  472.       TheBuffer(4) = 40
  473.       TheBuffer(5) = 0
  474.       TheBuffer(6) = extend_out(4)
  475.       CALL newmem(TheBuffer(0), 400*80*extend_out(4))
  476.     
  477. *     Clear TheBuffer
  478.       copyrect(0) = 0
  479.       copyrect(0) = 0
  480.       copyrect(2) = 640
  481.       copyrect(3) = 400
  482.       copyrect(4) = 0
  483.       copyrect(5) = 0
  484.       copyrect(6) = 640
  485.       copyrect(7) = 400
  486.       CALL vro_cpyfm(workstation, 0, copyrect, TheBuffer, TheBuffer)
  487.   
  488. *     Create the menu bar
  489.       TheMenu = menu_create(3, 13, '  About doodle ... '//char(0))
  490.       FileTitle   = menu_title(TheMenu, ' File '//char(0))
  491.       ShapeTitle  = menu_title(TheMenu, ' Shape '//char(0))
  492.       ColourTitle = menu_title(TheMenu, ' Colour '//char(0))
  493.       QuitItem = menu_item(TheMenu, FileTitle, '  Quit   '//char(0))
  494.       RectItem = menu_item(TheMenu, ShapeTitle, '  Rectangle '//
  495.      -                                             char(0))
  496.       OvalItem = menu_item(TheMenu, ShapeTitle, '  Oval '//char(0))
  497.       tempitem = menu_item(TheMenu, ShapeTitle, '------------'//
  498.      -                                             char(0))
  499.       CALL menu_ienable(TheMenu, tempitem, .false.)
  500.       filledItem = menu_item(TheMenu, ShapeTitle, '  Filled '//char(0))
  501.       ColourItem(0) = menu_item(TheMenu, ColourTitle, '  White   '//
  502.      -                                                     char(0))
  503.       ColourItem(1) = menu_item(TheMenu, ColourTitle, '  Black   '//
  504.      -                                                     char(0))
  505.       ColourItem(2) = menu_item(TheMenu, ColourTitle, '  Red     '//
  506.      -                                                     char(0))
  507.       ColourItem(3) = menu_item(TheMenu, ColourTitle, '  Green   '//
  508.      -                                                     char(0))
  509.       ColourItem(4) = menu_item(TheMenu, ColourTitle, '  Blue    '//
  510.      -                                                     char(0))
  511.       ColourItem(5) = menu_item(TheMenu, ColourTitle, '  Cyan    '//
  512.      -                                                     char(0))
  513.       ColourItem(6) = menu_item(TheMenu, ColourTitle, '  Yellow  '//
  514.      -                                                     char(0))
  515.       ColourItem(7) = menu_item(TheMenu, ColourTitle, '  Magenta '//
  516.      -                                                     char(0))
  517.  
  518. *     Set initial shape etc, and indicate settings on menu bar
  519.   
  520.       filling = .false.
  521.       TheColour = 1                           ! Black
  522.       CALL menu_icheck(TheMenu, ColourItem(1), .true.)
  523.       TheShape = RectItem
  524.       CALL menu_icheck(TheMenu, TheShape, .true.)
  525.   
  526.       CALL menu_bar(TheMenu, .true.)          ! Display menu bar
  527.  
  528. *     Create and open a window 
  529.       CALL graf_mouse(256, 0)                       ! Hide mouse
  530.       CALL wind_get(0, WF_WXYWH, fx, fy, fw, fh)    ! Get desktop work area
  531.       TheWindow = wind_create($fef, fx, fy, fw, fh) ! No info line
  532.       TheTitle = 'Doodle'//char(0)
  533.       CALL wind_title(TheWindow, TheTitle)    ! Must set before opening
  534.       CALL wind_open(TheWindow, fx, fy, fw, fh)
  535.  
  536. !     Clip to work area
  537.       CALL wind_get(TheWindow, WF_WXYWH, wx, wy, ww, wh)
  538.       WorkRect(0) = wx
  539.       WorkRect(1) = wy
  540.       WorkRect(2) = wx+ww-1
  541.       WorkRect(3) = wy+wh-1
  542.       topleft_x = 0
  543.       topleft_y = 0
  544.       CALL vs_clip(workstation, .true., WorkRect)
  545.  
  546.       CALL set_sliders                         ! Set the window sliders
  547.       CALL graf_mouse(257, 0)                  ! Show mouse
  548.       END
  549.  
  550. !-------------------------------------------------------------------
  551. !       SUBROUTINE terminate - clean up ready to terminate                
  552. !-------------------------------------------------------------------
  553.  
  554.       SUBROUTINE terminate
  555.       IMPLICIT none
  556.  
  557.       COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
  558.      -                 QuitItem, RectItem, OvalItem, FilledItem,
  559.      -                 ColourItem
  560.       INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
  561.      -          QuitItem, RectItem, OvalItem, FilledItem
  562.       INTEGER*4 ColourItem(0:7)
  563.   
  564.       COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
  565.      -                   WorkRect
  566.       INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
  567.       INTEGER*2 WorkRect(0:3)
  568.  
  569.       COMMON /workstation/ Workstation, work_in, work_out, extend_out
  570.       INTEGER*4 Workstation
  571.       INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)
  572.  
  573.       CALL wind_close(TheWindow)          ! Remove window from screen
  574.       CALL wind_delete(TheWindow)         ! and free its handle
  575.       CALL menu_bar(TheMenu, .false.)     ! Remove menu bar
  576.       CALL v_clsvwk(workstation)          ! Close virtual workstation
  577.       END
  578.  
  579.  
  580.