-+-+-+-+-+-+-+-+ START OF PART 167 -+-+-+-+-+-+-+-+
XC 1.0, 1st March 1991, G. Williams, First Version.
X
XC---------------------------------------------------------------------------
V-
X
XC--------------------------------------------------------------------------
X
X         PROGRAM menutest
X
X         implicit none
X
X         LOGICAL menuquit, picked
X         INTEGER itemnum
X         INTEGER ptkf_stringtoint
X         LOGICAL getmenupick
X         INTEGER err, line, mark, text, interior, edge, pattern
X         INTEGER colour, view
X
X         include '`5B`5Dvmsphigs77.for'
X         include '`5B`5Dvmsptk77.for'
X
XC     open PHIGS`20
X         print *,('Testing the menus utility of the PHIGS Toolkit...')
X         print *,('Opening DEC PHIGS...')
X
X         call popph(0, 0)
X`20
XC     create the workstation type (either tool or canvas)`20
X             `20
XC     open the workstation`20
X      `20
X         call popwk(1, 0, 0)
X
X         call psdus(1, PWAITD, PNIVE)
X
X         call pqwksl(0, err, line, mark, text, interior,
X     : edge, pattern, colour, view)
X      `20
X         call ptkf_inithashtables()
X         call ptkf_createhashtable('structureid', 0, 100)
X         call ptkf_createhashtable('viewindex', 1, 100)
X         call ptkf_createhashtable('label', 0, 100)
X         call ptkf_createhashtable('nameset', 0, 100)
X         call ptkf_createhashtable('menuid', 1, 100)
X         call ptkf_createhashtable('colourindex', 1, 100)
X         call ptkf_createhashtable('name', 1, 100)
X             `20
XC     set colours`20
X         if (colour .gt. 2) then
X           call ptkf_setcolourrep(1, 'white')
X           call ptkf_setcolourrep(1, 'orange')
X           call ptkf_setcolourrep(1, 'brown')
X           call ptkf_setcolourrep(1, 'yellow')
X           call ptkf_setcolourrep(1, 'green')
X           call ptkf_setcolourrep(1, 'blue')
X           call ptkf_setcolourrep(1, 'medium green')
X           call ptkf_setcolourrep(1, 'magenta')
X           call ptkf_setcolourrep(1, 'medium magenta')`20
X           call ptkf_setcolourrep(1, 'black')
X           call ptkf_setcolourrep(1, 'grey')
X           call ptkf_setcolourrep(1, 'red')
X
X           call ptkf_setbackgroundcolourind(1,`20
X     : ptkf_stringtoint('colourindex', 'grey'))
X         endif
X
XC     menus to select type of menu and type of input`20
X      `20
X         call makemainmenu(colour)
X      `20
X         call makeinputmenu(colour)
X      `20
XC     create test box, user and rotator menus`20
X      `20
X         call createbox(colour)
X      `20
X         call createrotator(colour)
X      `20
XC     interaction loop`20
XC     draw main menu`20
X      `20
X         menuquit = .FALSE.
X 10      call ptkf_postmenu(1, ptkf_stringtoint('menuid',`20
X     : 'mainmenu'))
X         call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',`20
X     : 'inputmenu'))   `20
X         call prst(1, PALWAY)
X
X         itemnum = 0
X         picked = getmenupick(ptkf_stringtoint('menuid', 'mainmenu'),`20
X     : itemnum)
X         if (picked .eq. .TRUE.) then
X           if (itemnum .eq. 1) then
X            call testboxmenu()
X           else if (itemnum .eq. 2) then
X            call testrotator()
X           else
X            menuquit = .TRUE.
X           endif
X         else
X           print *,('You didnt pick a menu.')
X         endif
X
X         if (menuquit .eq. .TRUE.) then
X           goto 20
X         else`20
X           goto 10
X         endif
X
X 20      print *,('Closing PHIGS...')
X         call pclwk(1)
X         call pclph()
X
X         STOP
X         END
X
XC--------------------------------------------------------------------------
X     `20
X         SUBROUTINE pickinput(itemnum)
X         INTEGER itemnum
X         INTEGER menuset(20), emptyset(20), menunames(20)
X         INTEGER totsize, i
X         INTEGER stat, ppd
X         INTEGER pp(3, 20), ppath(3, 20)
X         INTEGER ia(2), ldr, err, lstr(1)
X         REAL rl(4)
X         CHARACTER*80 str, datrec(10)
X         LOGICAL picked
X         LOGICAL ptkf_pickscanmenus
X         REAL devx, devy
X
X         include '`5B`5Dvmsphigs77.for'
X
X         call ptkf_inqmaxdevicecoords(1, devx, devy)
X
XC test picking`20
X         itemnum = 0
X         print *,('Pick a menu item...')
XC initialise pick`20
X     `20
X         call ptkf_inqpostedmenus(1, 20, menuset, totsize, err)
X         do 10, i=1,totsize
X           call ptkf_inqmenuname(menuset(i), menunames(i), err)`20
X 10        continue
X
X         call pspkft(1, 1, totsize, menunames, 0, emptyset)
X     `20
X         rl(1) = 0.05
X
X         call pprec(0, ia, 1, rl, 0, lstr, str, 10, err, ldr, datrec)
X
X         call pinpk(1, 1, PNPICK, 0, pp, 1, 0.0, devy, 0.0, devy,`20
X     : ldr, datrec, PPOBOT)`20
X        `20
XC set pick`20
X         call pspkm(1, 1, PREQU, PECHO)
X        `20
XC request pick`20
X
X         call prqpk(1, 1, 10, stat, ppd, ppath)
X        `20
X         if (stat .eq. POK) then
X           picked = ptkf_pickscanmenus(ppd, ppath, PPOBOT, menuid,`20
X     : itemnum)`20
X           if (picked .eq. .TRUE.) then
X             print *,'menu item', itemnum, 'was picked from menu',`20
X     : menuid
X           else
X             print *,('You did not pick a menu.')
X           endif
X         else
X           print *,('Nothing picked.')
X         endif
X
X         RETURN
X         END
X
XC--------------------------------------------------------------------------
X        `20
X         LOGICAL FUNCTION getmenupick(menuid, itemnum)
X         INTEGER menuid, itemnum
X         INTEGER pmenuid
X         INTEGER menuset(10), emptyset(10)
X         INTEGER stat, ppd
X         INTEGER pp(3, 20), ppath(3, 20)
X         INTEGER ia(2), ldr, err, lstr(1)
X         REAL ra(1)
X         CHARACTER*80 str, datrec(10)
X         LOGICAL ptkf_pickscanmenus
X         REAL devx, devy
X
X         include '`5B`5Dvmsphigs77.for'
X
X         call ptkf_inqmaxdevicecoords(1, devx, devy)
X
XC make menu pickable`20
X         call ptkf_inqmenuname(menuid, menuset(1), err)
X         call pspkft(1, 1, 1, menuset, 0, emptyset)
X
X         ra(1) = 0.05
X
X         call pprec(0, ia, 1, ra, 0, lstr, str, 10, err, ldr, datrec)
X
X         call pinpk(1, 1, PNPICK, 0, pp, 1, 0.0, devy, 0.0, devy, ldr,`20
X     : datrec, PPOBOT)`20
X        `20
XC set pick`20
X         call pspkm(1, 1, PREQU, PECHO)
X        `20
XC request pick`20
X
X         call prqpk(1, 1, 10, stat, ppd, ppath)
X        `20
X         if (stat .eq. POK) then
X           getmenupick = ptkf_pickscanmenus(ppd, ppath, PPOBOT,`20
X     : pmenuid, itemnum)
X         else
X           getmenupick = .FALSE.
X         endif
X
X         RETURN
X         END
X
XC--------------------------------------------------------------------------
X        `20
X         SUBROUTINE pointinput(itemnum)
X         INTEGER itemnum
X         CHARACTER*80 datrec(2), str(2)
X         INTEGER stat, view, err
X         REAL point(2)
X         INTEGER menuid
X         REAL value(2)
X         INTEGER ia(2), lstr(2), ldr
X         REAL ra(2)
X         LOGICAL picked
X         LOGICAL ptkf_locscanmenus
X         REAL devx, devy
X
X         include '`5B`5Dvmsphigs77.for'
X
X         call ptkf_inqmaxdevicecoords(1, devx, devy)
X         itemnum = 0
X         print *,('Point at a menu item...')
X
X         call pprec(0, ia, 0, ra, 0, lstr, str, 2, err, ldr,
X     : datrec)
X         call pinlc(1, 1, 0, 0.5, 0.5, 1, 0.0, devy, 0.0, devy, ldr,`20
X     : datrec)
X         call pslcm(1, 1, PREQU, PECHO)
X         call prqlc(1, 1, stat, view, point(1), point(2))
X         if (stat .eq. POK) then
X           picked = ptkf_locscanmenus(1, point, menuid, itemnum,`20
X     : value)`20
X           if (picked .eq. .TRUE.) then
X             print *,'menu item', itemnum, 'was pointed at from menu',
X     : menuid
X             print *,'value, x =', value(1), 'y =', value(2)
X           endif
X         else
X           print *,('You did not point at a menu.')
X         endif
X
X         RETURN
X         END
X
XC--------------------------------------------------------------------------
X        `20
X         SUBROUTINE stringinput(itemnum)
X         INTEGER itemnum
X         CHARACTER*30 dummystr
X         INTEGER dummylen
X         REAL echoarea(4)
X         REAL devx, devy
X         LOGICAL picked
X         LOGICAL ptkf_stringscanmenus
X
X         itemnum = 0
X         print *,('Enter a menu item...')   `20
X         call ptkf_inqmaxdevicecoords(1, devx, devy)
X         call ptkf_limit(0.0, 0.5 * devx, 0.0, 0.05 * devy, echoarea)
X         call ptkf_readstring(1, 'dummy', 'Type menu item name >',
X     : echoarea, 30, dummystr, dummylen)
X         picked = ptkf_stringscanmenus(1, dummystr, menuid, itemnum)
X         if (picked .eq. .TRUE.) then
X           print *,'menu item', itemnum, 'was entered from menu',`20
X     : menuid
X         else`20
X           print *,('No menu item of that name.')
X         endif
X
X         RETURN
X         END
X
XC--------------------------------------------------------------------------
X        `20
X         SUBROUTINE makemainmenu(colour)
X         INTEGER colour
X         INTEGER err
X         REAL topleft(2), box(2)
X         INTEGER textind
X         REAL charht
X         INTEGER white, blue, black
X         INTEGER mainmenuid
X         INTEGER ptkf_stringtoint
X
X         include '`5B`5Dvmsphigs77.for'
X
XC create a BOX menu`20
XC set up main menu - box menu(box, user, rotator, exit)`20
X
X         mainmenuid = ptkf_stringtoint('menuid', 'mainmenu')`20
X         call ptkf_point(0.2, 0.1, box)
X         textind = 1
X         charht = 0.025
X         call ptkf_point(0.8, 1.0, topleft)
X         call ptkf_createboxmenu(mainmenuid, topleft, box)
X         if (colour .gt. 2) then
X           white = ptkf_stringtoint('colourindex', 'white')
X           blue = ptkf_stringtoint('colourindex', 'blue')
X           black = ptkf_stringtoint('colourindex', 'black')
X           call ptkf_setboxmenuattrs(1, mainmenuid, PDOWN, 1,
X     : white, blue, blue, white, black, white, blue, blue)
X         endif
X
X         call ptkf_createtextmenuitem(mainmenuid, 'box', 1, PINSRT, err)
X         call ptkf_createtextmenuitem(mainmenuid, 'rotator', 2, PINSRT,`20
X     : err)
X         call ptkf_createtextmenuitem(mainmenuid, 'exit', 3, PINSRT,`20
X     : err)
X
X         RETURN
X         END
X
XC--------------------------------------------------------------------------
X        `20
X         SUBROUTINE makeinputmenu(colour)
X         INTEGER colour
X         INTEGER err
X         REAL topleft(2), box(2)
X         INTEGER textind
X         REAL charht
X         INTEGER white, magenta, black, darkmagenta
X         INTEGER inputmenuid
X         INTEGER ptkf_stringtoint
X
X         include '`5B`5Dvmsphigs77.for'
X
X         inputmenuid = ptkf_stringtoint('menuid', 'inputmenu')`20
X         call ptkf_point(0.2, 0.1, box)
X         textind = 1
X         charht = 0.03
X         call ptkf_point(0.8, 0.5, topleft)
X         call ptkf_createboxmenu(inputmenuid, topleft, box)
X         if (colour .gt. 2) then
X           white = ptkf_stringtoint('colourindex', 'white')
X           magenta = ptkf_stringtoint('colourindex', 'magenta')
X           darkmagenta = ptkf_stringtoint('colourindex',
X     : 'medium magenta')
X           black = ptkf_stringtoint('colourindex', 'black')
X           call ptkf_setboxmenuattrs(1, inputmenuid, PDOWN, 1,
X     : white, magenta, magenta, white, black, white,`20
X     : darkmagenta, darkmagenta)`20
X         endif        `20
X         call ptkf_createtextmenuitem(inputmenuid, 'pick', 1, PINSRT,`20
X     : err)
X         call ptkf_createtextmenuitem(inputmenuid, 'point', 2, PINSRT,`20
X     : err)
X         call ptkf_createtextmenuitem(inputmenuid, 'string', 3, PINSRT,`20
X     : err)
X         call ptkf_createtextmenuitem(inputmenuid, 'exit', 4, PINSRT,`20
X     : err)
X
X         RETURN
X         END
X
XC--------------------------------------------------------------------------
X        `20
X         SUBROUTINE createbox(colour)
X         INTEGER colour
X         INTEGER err
X         REAL topleft(2), box(2)
X         INTEGER textind
X         REAL charht
X         INTEGER white, green, black, darkgreen
X         INTEGER boxmenuid
X         INTEGER ptkf_stringtoint
X
X         include '`5B`5Dvmsphigs77.for'
X
X         boxmenuid = ptkf_stringtoint('menuid', 'boxmenu')
X         call ptkf_point(0.2, 0.1, box)
X         textind = 1
X         charht = 0.03
X         call ptkf_point(0.0, 0.0, topleft)
X         call ptkf_createboxmenu(boxmenuid, topleft, box)
X         if (colour .gt. 2) then
X           white = ptkf_stringtoint('colourindex', 'white')
X           green = ptkf_stringtoint('colourindex', 'green')
X           darkgreen = ptkf_stringtoint('colourindex', 'medium green')
X           black = ptkf_stringtoint('colourindex', 'black')
X           call ptkf_setboxmenuattrs(1, boxmenuid, PDOWN, 1,
X     : white, green, green, white, black, white,`20
X     : darkgreen, darkgreen)`20
X         endif
X
X         call ptkf_point(0.5, 0.7, topleft)
X         call ptkf_setmenuposition(boxmenuid, topleft)        `20
X         call ptkf_createtextmenuitem(boxmenuid, 'item 1', 1, PINSRT,`20
X     : err)
X         call ptkf_createtextmenuitem(boxmenuid, 'item 2', 2, PINSRT,`20
X     : err)
X         call ptkf_createtextmenuitem(boxmenuid, 'item 3', 3, PINSRT,`20
X     : err)
X         call ptkf_createtextmenuitem(boxmenuid, 'item 4', 4, PINSRT,`20
X     : err)
X
X         RETURN
X         END
X        `20
XC--------------------------------------------------------------------------
X                `20
X         SUBROUTINE createrotator(colour)
X         INTEGER colour
X         REAL size(2), pos(2)
X         INTEGER blue, white, black
X         INTEGER rotator1, rotator2, rotator3
X         INTEGER ptkf_stringtoint
X
X         include '`5B`5Dvmsptk77.for'
X
XC create a rotator`20
X         rotator1 = ptkf_stringtoint('menuid', '1drotator')
X         rotator2 = ptkf_stringtoint('menuid', '2drotator')
X         rotator3 = ptkf_stringtoint('menuid', '3drotator')
X         call ptkf_point(0.2, 0.2, size)
X         call ptkf_createrotator(1, rotator1, PTKEONED, size,`20
X     : '1D rotator', 0.02)
X         call ptkf_createrotator(1, rotator2, PTKETWOD, size,`20
X     : '2D rotator', 0.02)
+-+-+-+-+-+-+-+-  END  OF PART 167 +-+-+-+-+-+-+-+-