*     This is a fairly simple GEM application which illustrates many
*     of the main features of the GEM AES and VDI bindings, as well
*     as other features of the Prospero Fortran system.
*
*     Author : R K Chapman
*     Date   : 29 October 1987
*
*     Copyright (C) 1987 Prospero Software Ltd

      PROGRAM doodle_demo
      IMPLICIT none
      INTEGER*4 AESret
      
      CALL appl_init
      IF (AESret .ge. 0) THEN
        CALL initialise
        CALL doodle
        CALL terminate
        CALL appl_exit
      END IF
      END

      SUBROUTINE newmem(p, size)
      IMPLICIT none
      INTEGER*4 p, size, sys
      
      INTEGER*2 parmarray(0:2)
      INTEGER*2 funcno
      INTEGER*4 bytes
      EQUIVALENCE (funcno, parmarray(0)), (bytes, parmarray(1))
      
      funcno = $48           ! GEMDOS function number
      bytes = size           ! Number of bytes required
      p = sys(parmarray)     ! Address of memory allocated
      END

      LOGICAL*4 FUNCTION intersect(x1, y1, w1, h1, x2, y2, w2, h2)
      IMPLICIT none
      INTEGER*4 x1, y1, w1, h1, x2, y2, w2, h2

      w1 = min0(w1+x1, w2+x2)-1
      h1 = min0(h1+y1, h2+y2)-1
      x1 = max0(x1, x2)
      y1 = max0(y1, y2)
*     Note w1,h1 are returned as coords rather than width/height
      intersect = ((w1 .ge. x1) .AND. (h1 .ge. y1))
      END

!-------------------------------------------------------------------
!       SUBROUTINE redraw - redraw the portions of the given rectangle    
!                    which correspond to visible areas of TheWindow
!-------------------------------------------------------------------

      SUBROUTINE redraw(x, y, w, h)
      IMPLICIT none
      INTEGER*2 rect(0:7)
      INTEGER*4 x, y, w, h, rx, ry, rw, rh
      LOGICAL*4 intersect
      INCLUDE 'GEMCONST'
  
      COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
     -                   WorkRect
      INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
      INTEGER*2 WorkRect(0:3)

      COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
      INTEGER*2 TheBuffer(0:9)
      INTEGER*4 topleft_x, topleft_y
                                   
      COMMON /workstation/ Workstation, work_in, work_out, extend_out
      INTEGER*4 Workstation
      INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)

*     Get first visible area
      CALL wind_get(TheWindow, WF_FIRSTXYWH, rx, ry, rw, rh)

10    CONTINUE
      IF ((rw+rh) .ne. 0) THEN
        IF (intersect(rx, ry, rw, rh, x, y, w, h)) THEN
          rect(0) = rx - wx + topleft_x     ! Source x1
          rect(1) = ry - wy + topleft_y     ! Source y1
          rect(2) = rw - wx + topleft_x     ! Source x2
          rect(3) = rh - wy + topleft_y     ! Source y2
          rect(4) = rx                      ! Dest x1
          rect(5) = ry                      ! Dest y1
          rect(6) = rw                      ! Dest x2
          rect(7) = rh                      ! Dest y2
          CALL graf_mouse(256, 0)           ! hide mouse
          CALL vro_cpyfm(workstation, 3, rect, TheBuffer, 0)
          CALL graf_mouse(257, 0)           ! Show mouse
        END IF
*       Get next visible area
        CALL wind_get(TheWindow, WF_NEXTXYWH, rx, ry, rw, rh)
        GOTO 10
      END IF
      END

!-------------------------------------------------------------------
!       SUBROUTINE set_sliders - set the position and size of the sliders 
!-------------------------------------------------------------------

      SUBROUTINE set_sliders
      IMPLICIT none
      INCLUDE 'GEMCONST'
      
      COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
     -                   WorkRect
      INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
      INTEGER*2 WorkRect(0:3)

      COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
      INTEGER*2 TheBuffer(0:9)
      INTEGER*4 topleft_x, topleft_y
                                   
      CALL wind_set(TheWindow, WF_HSLIDE,
     -              topleft_x * 1000 / (640 - ww), 0, 0, 0)
      CALL wind_set(TheWindow, WF_VSLIDE,
     -              topleft_y * 1000 / (400 - wh), 0, 0, 0)
      CALL wind_set(TheWindow, WF_HSLSIZE,
     -              ww * 1000 / 640, 0, 0, 0)
      CALL wind_set(TheWindow, WF_VSLSIZE,
     -              wh * 1000 / 400, 0, 0, 0)
      END

!--------------------------------------------------------------------
!       SUBROUTINE do_shape_title - handle menu selections from Shape title
!--------------------------------------------------------------------

      SUBROUTINE do_shape_title(item)
      IMPLICIT none
      INTEGER*4 item

      COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -                 QuitItem, RectItem, OvalItem, FilledItem,
     -                 ColourItem
      INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -          QuitItem, RectItem, OvalItem, FilledItem
      INTEGER*4 ColourItem(0:7)
  
      COMMON /settings/ Filling, TheColour, TheShape
      LOGICAL*4 Filling
      INTEGER*4 TheColour, TheShape
  
      IF (item .eq. FilledItem) THEN
        filling = .NOT. filling
        CALL menu_icheck(TheMenu, FilledItem, filling)
      ELSE
        CALL menu_icheck(TheMenu, TheShape, .false.)
        TheShape = item
        CALL menu_icheck(TheMenu, TheShape, .true.)
      END IF    
      END

!-------------------------------------------------------------------
!       SUBROUTINE do_colour_title - handle selections from Colour title  
!-------------------------------------------------------------------

      SUBROUTINE do_colour_title(item)
      IMPLICIT none
      INTEGER*4 item, dummy, vsl_color

      COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -                 QuitItem, RectItem, OvalItem, FilledItem,
     -                 ColourItem
      INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -          QuitItem, RectItem, OvalItem, FilledItem
      INTEGER*4 ColourItem(0:7)
  
      COMMON /settings/ Filling, TheColour, TheShape
      LOGICAL*4 Filling
      INTEGER*4 TheColour, TheShape
  
      COMMON /workstation/ Workstation, work_in, work_out, extend_out
      INTEGER*4 Workstation
      INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)

      CALL menu_icheck(TheMenu, ColourItem(TheColour), .false.)
      CALL menu_icheck(TheMenu, item, .true.)
      TheColour = item - ColourItem(0)
      dummy = vsl_color(workstation, TheColour) 
      END

!--------------------------------------------------------------------
!       SUBROUTINE draw_shape - draw the current shape                     
!--------------------------------------------------------------------

      SUBROUTINE draw_shape(x, y)
      IMPLICIT none
      INTEGER*4 x, y, w, h, xcen, ycen, xrad, yrad, dummy
      INTEGER*2 copyrect(0:7)
      INCLUDE 'GEMFUNCS'
      
      COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -                 QuitItem, RectItem, OvalItem, FilledItem,
     -                 ColourItem
      INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -          QuitItem, RectItem, OvalItem, FilledItem
      INTEGER*4 ColourItem(0:7)
  
      COMMON /settings/ Filling, TheColour, TheShape
      LOGICAL*4 Filling
      INTEGER*4 TheColour, TheShape
  
      COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
     -                   WorkRect
      INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
      INTEGER*2 WorkRect(0:3)

      COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
      INTEGER*2 TheBuffer(0:9)
      INTEGER*4 topleft_x, topleft_y
                                   
      COMMON /workstation/ Workstation, work_in, work_out, extend_out
      INTEGER*4 Workstation
      INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)

      CALL graf_rubbox(x, y, 5, 5, w, h)         ! Get a rectangle
      dummy = vsf_interior(workstation, 1)       ! select solid fill
      dummy = vsf_color(workstation, TheColour)  ! .. in this colour
      dummy = vsl_color(workstation, TheColour)  ! .. and border    
      CALL vsf_perimeter(workstation, .true.)    ! .. and perimeter 
      CALL graf_mouse(256,0)                     ! Hide mouse

*     Define the part of TheBuffer to be updated
      copyrect(0) = x
      copyrect(1) = y
      copyrect(2) = x+w
      copyrect(3) = y+h
      copyrect(4) = copyrect(0) - wx + topleft_x
      copyrect(5) = copyrect(1) - wy + topleft_y
      copyrect(6) = copyrect(2) - wx + topleft_x
      copyrect(7) = copyrect(3) - wy + topleft_y
  
*     Draw the shape
      IF (TheShape .eq. RectItem) THEN
        IF (filling) THEN
          CALL v_rfbox(workstation, copyrect)
        ELSE
          CALL v_rbox(workstation, copyrect)
        END IF
      ELSE IF (TheShape .eq. OvalItem) THEN
        xrad = w / 2
        yrad = h / 2
        xcen = x+xrad
        ycen = y+yrad
        IF (filling) THEN
          CALL v_ellipse(workstation, xcen, ycen, xrad, yrad)
        ELSE
          CALL v_ellarc(workstation,  xcen, ycen, xrad, yrad, 0, 3600)
        END IF
      END IF
      
*     Now update TheBuffer
      CALL vro_cpyfm(workstation, 3, copyrect, 0, TheBuffer) 
  
      CALL graf_mouse(257, 0)                         ! Show mouse
      END

!--------------------------------------------------------------------
!       SUBROUTINE doodle - the main event processing loop                 
!--------------------------------------------------------------------

      SUBROUTINE doodle
      IMPLICIT none
      INTEGER*2 message(0:7)
      INTEGER*4 dummy, event, mask, mx, my
      INTEGER*4 x, y, w, h
      INTEGER*4 title, item
      LOGICAL*4 inside, quitting
      INCLUDE 'GEMCONST'
      INCLUDE 'GEMFUNCS'

      COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -                 QuitItem, RectItem, OvalItem, FilledItem,
     -                 ColourItem
      INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -          QuitItem, RectItem, OvalItem, FilledItem
      INTEGER*4 ColourItem(0:7)
  
      COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
     -                   WorkRect
      INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
      INTEGER*2 WorkRect(0:3)

      COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
      INTEGER*2 TheBuffer(0:9)
      INTEGER*4 topleft_x, topleft_y
                                   
      COMMON /workstation/ Workstation, work_in, work_out, extend_out
      INTEGER*4 Workstation
      INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)

      quitting = .false.
      inside = .false.
      CALL graf_mouse(0, 0)
      mask = MU_M1 .OR. MU_MESAG
10    CONTINUE
        event = evnt_multi(mask, 1, 1, 1,
     -                     inside, wx, wy, ww, wh,
     -                     .false., 0, 0, 0, 0,
     -                     message, 0, mx, my,
     -                     dummy, dummy, dummy, dummy)
        CALL wind_update(BEG_UPDATE)
        
        IF ((event .AND. MU_M1) .ne. 0) THEN
          inside = .NOT. inside
          IF (inside) THEN
            mask = MU_M1 .OR. MU_BUTTON .OR. MU_MESAG
            CALL graf_mouse(5, 0)           ! Cross hair inside window
          ELSE
            mask = MU_M1 .OR. MU_MESAG      ! Don't accept clicks
            CALL graf_mouse(0, 0)           ! Arrow outside window
          END IF
        END IF
        
        IF ((event .AND. MU_MESAG) .ne. 0) THEN
          IF (message(0) .eq. MN_SELECTED) THEN
            title = message(3)
            item  = message(4)
            IF (title .eq. FileTitle) THEN
              quitting = .true.
            ELSE IF (title .eq. ShapeTitle) THEN
              CALL do_shape_title(item)
            ELSE IF (title .eq. ColourTitle) THEN
              CALL do_colour_title(item)
            ELSE   ! Must have selected About ..
              dummy = form_alert(1, '[0][Prospero Fortran Doodle demo'
     -                           // ' | ][  OK  ]' // char(0))
            END IF
            CALL menu_tnormal(TheMenu, title, .true.)
            
          ELSE IF (message(0) .eq. WM_CLOSED) THEN
            quitting = .true.
            
          ELSE IF ((message(0) .eq. WM_MOVED) .OR.
     -             (message(0) .eq. WM_SIZED)) THEN
            x = message(4)
            y = message(5)          ! Extend coords to 4 bytes
            w = message(6)          ! Probably unneccessary here
            h = message(7)          ! as only 2 bytes used by wind_set
            CALL wind_set(TheWindow, WF_CXYWH, x, y, w, h)
            CALL wind_get(TheWindow, WF_WXYWH, wx, wy, ww, wh)
            CALL set_sliders
            WorkRect(0) = wx
            WorkRect(1) = wy
            WorkRect(2) = wx+ww-1
            WorkRect(3) = wy+wh-1
            CALL vs_clip(workstation, .true., WorkRect)

          ELSE IF (message(0) .eq. WM_REDRAW) THEN
            x = message(4)
            y = message(5)
            w = message(6)
            h = message(7)        ! Extend coordinates up to 4 bytes
            CALL redraw(x, y, w, h)

          ELSE IF (message(0) .eq. WM_VSLID) THEN
            topleft_y = (400 - wh) * message(4) / 1000
            CALL set_sliders
            CALL redraw(wx, wy, ww, wh)

          ELSE IF (message(0) .eq. WM_HSLID) THEN
            topleft_x = (640 - ww) * message(4) / 1000
            CALL set_sliders
            CALL redraw(wx, wy, ww, wh)

          ELSE IF (message(0) .eq. WM_ARROWED) THEN
            GOTO (21, 22, 23, 24, 25, 26, 27), message(4)
              topleft_y = topleft_y - 50   ! page up
              GOTO 30
21            topleft_y = topleft_y + 50   ! page down 
              GOTO 30
22            topleft_y = topleft_y - 5    ! row up    
              GOTO 30
23            topleft_y = topleft_y + 5    ! row down  
              GOTO 30
24            topleft_x = topleft_x - 50   ! page left 
              GOTO 30
25            topleft_x = topleft_x + 50   ! page right
              GOTO 30
26            topleft_x = topleft_x - 5    ! column left 
              GOTO 30
27            topleft_x = topleft_x + 5    ! column right

30          CONTINUE
            IF (topleft_x .lt. 0) topleft_x = 0
            IF (topleft_y .lt. 0) topleft_y = 0
            IF (topleft_x .gt. 640 - ww) topleft_x = 640 - ww
            IF (topleft_y .gt. 400 - wh) topleft_y = 400 - wh
            CALL set_sliders
            CALL redraw(wx, wy, ww, wh)

          ELSE IF (message(0) .eq. WM_TOPPED) THEN
            CALL wind_set(TheWindow, WF_TOP, 0, 0, 0, 0)

          ELSE IF (message(0) .eq. WM_FULLED) THEN
            CALL wind_get(TheWindow, WF_CXYWH, wx, wy, ww, wh)
            IF ((wx .eq. fx) .AND. (wy .eq. fy) .AND.
     -          (ww .eq. fw) .AND. (wh .eq. fh)) THEN
              CALL wind_get(TheWindow, WF_PXYWH, wx, wy, ww, wh)
            ELSE
              CALL wind_get(TheWindow, WF_FXYWH, wx, wy, ww, wh)
            END IF
            CALL wind_set(TheWindow, WF_CXYWH, wx, wy, ww, wh)
            CALL wind_get(TheWindow, WF_WXYWH, wx, wy, ww, wh)
            CALL set_sliders
            WorkRect(0) = wx
            WorkRect(1) = wy
            WorkRect(2) = wx+ww-1
            WorkRect(3) = wy+wh-1
            CALL vs_clip(workstation, .true., WorkRect)
             
          END IF
        END IF

        IF ((event .AND. MU_BUTTON) .ne. 0) THEN
           CALL draw_shape(mx, my)
        END IF

        CALL wind_update(END_UPDATE)
        IF (.NOT. quitting) GOTO 10

      END

!-------------------------------------------------------------------
!       SUBROUTINE initialise - set up the workstation, menu etc          
!-------------------------------------------------------------------

      SUBROUTINE initialise
      IMPLICIT none
      INTEGER*4 i, dummy, tempitem
      INTEGER*2 copyrect(0:3)
      CHARACTER*20 TheTitle
      INCLUDE 'GEMCONST'
      INCLUDE 'GEMFUNCS'

      COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -                 QuitItem, RectItem, OvalItem, FilledItem,
     -                 ColourItem
      INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -          QuitItem, RectItem, OvalItem, FilledItem
      INTEGER*4 ColourItem(0:7)
  
      COMMON /settings/ Filling, TheColour, TheShape
      LOGICAL*4 Filling
      INTEGER*4 TheColour, TheShape
  
      COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
     -                   WorkRect
      INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
      INTEGER*2 WorkRect(0:3)

      COMMON /TheBuffer/ TheBuffer, topleft_x, topleft_y
      INTEGER*2 TheBuffer(0:9)
      INTEGER*4 topleft_x, topleft_y
                                   
      COMMON /workstation/ Workstation, work_in, work_out, extend_out
      INTEGER*4 Workstation
      INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)

*     Open a virtual screen workstation
      workstation = graf_handle(dummy, dummy, dummy, dummy)
      DO 10 i = 0, 9
10      work_in(i) = 1                    ! Set initial attributes
      work_in(10) = 2                     ! Raster coordinates
      CALL v_opnvwk(work_in, workstation, work_out)

*     Prepare TheBuffer memory form, where image is stored
      CALL vq_extnd(workstation, .true., extend_out)
      TheBuffer(2) = 640
      TheBuffer(3) = 400
      TheBuffer(4) = 40
      TheBuffer(5) = 0
      TheBuffer(6) = extend_out(4)
      CALL newmem(TheBuffer(0), 400*80*extend_out(4))
    
*     Clear TheBuffer
      copyrect(0) = 0
      copyrect(0) = 0
      copyrect(2) = 640
      copyrect(3) = 400
      copyrect(4) = 0
      copyrect(5) = 0
      copyrect(6) = 640
      copyrect(7) = 400
      CALL vro_cpyfm(workstation, 0, copyrect, TheBuffer, TheBuffer)
  
*     Create the menu bar
      TheMenu = menu_create(3, 13, '  About doodle ... '//char(0))
      FileTitle   = menu_title(TheMenu, ' File '//char(0))
      ShapeTitle  = menu_title(TheMenu, ' Shape '//char(0))
      ColourTitle = menu_title(TheMenu, ' Colour '//char(0))
      QuitItem = menu_item(TheMenu, FileTitle, '  Quit   '//char(0))
      RectItem = menu_item(TheMenu, ShapeTitle, '  Rectangle '//
     -                                             char(0))
      OvalItem = menu_item(TheMenu, ShapeTitle, '  Oval '//char(0))
      tempitem = menu_item(TheMenu, ShapeTitle, '------------'//
     -                                             char(0))
      CALL menu_ienable(TheMenu, tempitem, .false.)
      filledItem = menu_item(TheMenu, ShapeTitle, '  Filled '//char(0))
      ColourItem(0) = menu_item(TheMenu, ColourTitle, '  White   '//
     -                                                     char(0))
      ColourItem(1) = menu_item(TheMenu, ColourTitle, '  Black   '//
     -                                                     char(0))
      ColourItem(2) = menu_item(TheMenu, ColourTitle, '  Red     '//
     -                                                     char(0))
      ColourItem(3) = menu_item(TheMenu, ColourTitle, '  Green   '//
     -                                                     char(0))
      ColourItem(4) = menu_item(TheMenu, ColourTitle, '  Blue    '//
     -                                                     char(0))
      ColourItem(5) = menu_item(TheMenu, ColourTitle, '  Cyan    '//
     -                                                     char(0))
      ColourItem(6) = menu_item(TheMenu, ColourTitle, '  Yellow  '//
     -                                                     char(0))
      ColourItem(7) = menu_item(TheMenu, ColourTitle, '  Magenta '//
     -                                                     char(0))

*     Set initial shape etc, and indicate settings on menu bar
  
      filling = .false.
      TheColour = 1                           ! Black
      CALL menu_icheck(TheMenu, ColourItem(1), .true.)
      TheShape = RectItem
      CALL menu_icheck(TheMenu, TheShape, .true.)
  
      CALL menu_bar(TheMenu, .true.)          ! Display menu bar

*     Create and open a window 
      CALL graf_mouse(256, 0)                       ! Hide mouse
      CALL wind_get(0, WF_WXYWH, fx, fy, fw, fh)    ! Get desktop work area
      TheWindow = wind_create($fef, fx, fy, fw, fh) ! No info line
      TheTitle = 'Doodle'//char(0)
      CALL wind_title(TheWindow, TheTitle)    ! Must set before opening
      CALL wind_open(TheWindow, fx, fy, fw, fh)

!     Clip to work area
      CALL wind_get(TheWindow, WF_WXYWH, wx, wy, ww, wh)
      WorkRect(0) = wx
      WorkRect(1) = wy
      WorkRect(2) = wx+ww-1
      WorkRect(3) = wy+wh-1
      topleft_x = 0
      topleft_y = 0
      CALL vs_clip(workstation, .true., WorkRect)

      CALL set_sliders                         ! Set the window sliders
      CALL graf_mouse(257, 0)                  ! Show mouse
      END

!-------------------------------------------------------------------
!       SUBROUTINE terminate - clean up ready to terminate                
!-------------------------------------------------------------------

      SUBROUTINE terminate
      IMPLICIT none

      COMMON /TheMenu/ TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -                 QuitItem, RectItem, OvalItem, FilledItem,
     -                 ColourItem
      INTEGER*4 TheMenu, FileTitle, ShapeTitle, ColourTitle,
     -          QuitItem, RectItem, OvalItem, FilledItem
      INTEGER*4 ColourItem(0:7)
  
      COMMON /TheWindow/ TheWindow, fx, fy, fw, fh, wx, wy, ww, wh,
     -                   WorkRect
      INTEGER*4 TheWindow, fx, fy, fw, fh, wx, wy, ww, wh
      INTEGER*2 WorkRect(0:3)

      COMMON /workstation/ Workstation, work_in, work_out, extend_out
      INTEGER*4 Workstation
      INTEGER*2 work_in(0:10), work_out(0:56), extend_out(0:56)

      CALL wind_close(TheWindow)          ! Remove window from screen
      CALL wind_delete(TheWindow)         ! and free its handle
      CALL menu_bar(TheMenu, .false.)     ! Remove menu bar
      CALL v_clsvwk(workstation)          ! Close virtual workstation
      END


