-+-+-+-+-+-+-+-+ START OF PART 169 -+-+-+-+-+-+-+-+
X      else if (commandstr(1:lencom) .eq. 'tidygroup') then
X         print *,('Testing ptkf_tidytopology()...')
X         ra(1) = 0.01
X         call pprec(0, ia, 1, ra, 0, lstr, str, 10, err, pldr,
X     : pdatrec)
X         call pprec(0, ia, 0, ra, 0, lstr, str, 10, err, lldr,
X     : ldatrec)
X         call ptkf_tidytopology(1, ptkf_stringtoint('topologyid',
X     : 'topology'),PTKEGROUP, 1, 1, pldr, pdatrec, 1, 1,`20
X     : lldr, ldatrec)
X
X      else if (commandstr(1:lencom) .eq. 'store') then
X         fileptr = ptkf_fopen(storename, 'w+')
X         print *,'storing layout in', storename
X         print *,('Testing ptkf_storetopologylayout()...')
X         call ptkf_storetopologylayout(fileptr,
X     : ptkf_stringtoint('topologyid', 'topology'))
X         err = ptkf_fclose(fileptr)
X
X      else if (commandstr(1:lencom) .eq. 'restore') then
X         fileptr = ptkf_fopen(storename, 'r')
X         print *,'restoring layout from', storename
X         print *,('Testing ptkf_restoretopologylayout()...')
X         call ptkf_restoretopologylayout(fileptr,`20
X     : ptkf_stringtoint('topologyid', 'topology'))
X         err = ptkf_fclose(fileptr)
X
X      else if (commandstr(1:lencom) .eq. 'quit') then
X         topquit = .TRUE.
X
X      else
X         print *,('Command unknown')   `20
X      endif
X
X       call prst(1, PALWAY)
X
X       if (topquit .eq. .TRUE.) then
X         goto 20
X       else`20
X         goto 10
X       endif
X
X 20    RETURN
X       END
X                `20
XC--------------------------------------------------------------------------
X        `20
XC     end of toptest.for
X
$ CALL UNPACK [.FORTRAN.SOURCE.DEMO]TOPTEST.FOR;2 72672360
$ create 'f'
XC---------------------------------------------------------------------------
V-
X
XC  Module name: Utilities demo program.
X
XC  Author: Gareth Williams.
X
XC  Function: Tests the PHIGS Debugger and PHIGS view editor.
X
XC  Dependencies:
X
XC  Internal function list:`20
X
XC  External function list:`20
X
XC  Modification history: (Version), (Date), (name), (Description).
X
XC  2.0, 30th October 1991, G. Williams, First version.
X
XC---------------------------------------------------------------------------
V-
X
X       PROGRAM utiltest
X
X       implicit none
X
X       include '`5B`5Dvmsphigs77.for'
X       include '`5B`5Dvmsptk77.for'
X
XC--------------------------------------------------------------------------
X
X       INTEGER minid, maxid, white, black, green
X       INTEGER grey, stid, lightblue
X       CHARACTER*20 commandstr
X       CHARACTER*50 str
X       REAL echoarea(4)
X       INTEGER lencom, lenstr
X       LOGICAL quit, dummy
X       INTEGER stids(1)
X       LOGICAL ptkf_readphinterscript
X       INTEGER ptkf_stringtoint
X       REAL vwormt(4, 4)
X       REAL vwmpmt(4, 4)
X       REAL vwcplm(6)
X       INTEGER xyclpi, bclipi, fclipi
X       INTEGER err, line, mark, text, interior, edge, pattern
X       INTEGER colour, view
X       REAL devx, devy
X
X       print *,('Testing the utility modules of the PHIGS Toolkit...')
X       print *,('Opening DEC PHIGS...')
X
X       call popph(0, 0)
X
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
XC initialise hashtables`20
X       minid = 1
X       maxid = 300
X       call ptkf_inithashtables()
X       call ptkf_createhashtable('structureid', minid, maxid)
X       call ptkf_createhashtable('label', minid, maxid)
X       call ptkf_createhashtable('colourindex', 1, maxid)
X       call ptkf_createhashtable('viewindex', 1, maxid)
X       call ptkf_createhashtable('windowid', 1, maxid)
X       call ptkf_createhashtable('menuid', 1, maxid)
X       call ptkf_createhashtable('name', 1, maxid)
X       call ptkf_createhashtable('topologyid', 1, maxid)
X   `20
XC set colours`20
X       if (colour .gt. 2) then
X         call ptkf_setcolourrep(1, 'black')
X         call ptkf_setcolourrep(1, 'green')
X         call ptkf_setcolourrep(1, 'grey')
X         call ptkf_setcolourrep(1, 'white')
X         call ptkf_setcolourrep(1, 'blue')
X         green = ptkf_stringtoint('colourindex', 'green')
X         grey = ptkf_stringtoint('colourindex', 'grey')
X         white = ptkf_stringtoint('colourindex', 'white')
X         black = ptkf_stringtoint('colourindex', 'black')
X         lightblue = ptkf_stringtoint('colourindex', 'blue')
X         call ptkf_setbackgroundcolourind(1, white)
X       endif
X `20
XC read scripts`20
X       dummy = ptkf_readphinterscript('`5B-.-.scripts`5Dlamp.scr', 0, 0)
X       dummy = ptkf_readphinterscript('`5B-.-.scripts`5Dpostcard.scr',`20
X     : 0, 0)
X   `20
X       stid = ptkf_stringtoint('structureid', 'lamp')
X       stids(1) = stid
X   `20
XC select debugger/ view
X   `20
X        quit = .FALSE.
X        call ptkf_inqmaxdevicecoords(1, devx, devy)
X        call ptkf_limit(0.0, 0.5 * devx, 0.0, 0.05 * devy, echoarea)
X 10     print *,('Testing ptkf_readstring()...')
X        call ptkf_readstring(1, 'debugger',`20
X     : 'Input command (default = debugger) >', echoarea, 20, commandstr,`20
X     : lencom)`20
X        if (commandstr(1:lencom) .eq. 'debugattrs') then
X          if (colour .gt. 2) then
X            call ptkf_setdebuggerattrs(-4, -4, grey, black, white,`20
X     : grey, black, white, black, grey, black)
X          endif
X
X        else if (commandstr(1:lencom) .eq. 'viewattrs') then
X          if (colour .gt. 2) then
X            call ptkf_setvieweditorattrs(-4, -4, grey, black,`20
X     : white, grey, black, white, black, grey, black)
X          endif
X
X        else if (commandstr(1:lencom) .eq. 'debugger') then
X          print *,('Testing the PHIGS debugger module of the PHIGS`20
X     : Toolkit..')
X          call ptkf_readstring(1, 'lamp',`20
X     : 'Input command (default = lamp) >', echoarea, 50, str,`20
X     : lenstr)
X          stid = ptkf_stringtoint('structureid', str)
X          call ptkf_debugger(1, stid)
X
X        else if (commandstr(1:lencom) .eq. 'view') then
X          print *,('Testing the PHIGS view editor module of the`20
X     : PHIGS Toolkit...')
X          call ptkf_readstring(1, 'lamp',`20
X     : 'Input command (default = lamp) >', echoarea, 50, str,`20
X     : lenstr)
X          stid = ptkf_stringtoint('structureid', str)
X          call ptkf_vieweditor(1, 1, stids, vwormt, vwmpmt, vwcplm,`20
X     : xyclpi, bclipi, fclipi)
X   `20
X       else if (commandstr(1:lencom) .eq. 'quit') then
X         quit = .TRUE.
X
X       else
X          print *,('Command unknown')   `20
X       endif
X
X       call prst(1, PALWAY)
X
X       if (quit .eq. .TRUE.) then
X         goto 20
X       else`20
X         goto 10
X       endif
X
X 20    call pclwk(1)
X       call pclph()
X
X       STOP
X       END
X   `20
XC--------------------------------------------------------------------------
$ CALL UNPACK [.FORTRAN.SOURCE.DEMO]UTILTEST.FOR;2 1410423275
$ create 'f'
XC---------------------------------------------------------------------------
V`20
X
XC Program name: Windows test program.
X
XC Author: Gareth Williams
X
XC Description:
X
XC Modification history : (Version), (Date), (Name), (Description).
X
XC 1.0, 1st September 1991, G. Williams, First Version.
X
XC---------------------------------------------------------------------------
V-
X
X       PROGRAM windtest
X
X       implicit none
X
X       INTEGER minid, maxid, lampid
X       INTEGER lamplist(1)
X       REAL pos(2), size(2)
X       INTEGER ptkf_stringtoint
X       LOGICAL ptkf_readphinterscript
X
X       include '`5B`5Dvmsphigs77.for'
X      `20
XC     open PHIGS`20
X         print *,('Testing the windows module 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      `20
XC     initialise hashtables`20
X      `20
X       minid = 1
X       maxid = 50
X       call ptkf_inithashtables()
X       call ptkf_createhashtable('structureid', minid, maxid)
X       call ptkf_createhashtable('topologyid', minid, maxid)
X       call ptkf_createhashtable('label', minid, maxid)
X       call ptkf_createhashtable('colourindex', 1, 50)
X       call ptkf_createhashtable('viewindex', 1, 50)
X       call ptkf_createhashtable('windowid', 1, 50)
X       call ptkf_createhashtable('name', 1, 50)
X             `20
X       if (ptkf_readphinterscript('`5B-.-.scripts`5Dlamp.scr', 0, 0) .eq.
X     : .TRUE.) then
X         call ptkf_point(0.5, 0.5, pos)
X         call ptkf_point(0.6, 0.6, size)    `20
X         call ptkf_createwindow(1, ptkf_stringtoint('windowid',`20
X     : 'lampwindow'), size, pos, 'lamp window')
X         call ptkf_posttowindow(ptkf_stringtoint('windowid',`20
X     : 'lampwindow'), ptkf_stringtoint('structureid', 'lamp'))
X         lampid = ptkf_stringtoint('structureid', 'lamp')
X         lamplist(1) = lampid
X         call ptkf_setcameraworld(ptkf_stringtoint('windowid',`20
X     : 'lampwindow'), 1, lamplist)
X         call ptkf_postwindow(ptkf_stringtoint('windowid',`20
X     : 'lampwindow'))
X      `20
X         call ptkf_point(0.1, 0.9, pos)
X         call ptkf_seticonposition(ptkf_stringtoint('windowid',`20
X     : 'lampwindow'), pos)
X         call prst(1, PALWAY)
X
X         call options()
X       endif
X
X       print *,('Closing PHIGS...')
X       call pclwk(1)
X       call pclph()
X
X       STOP
X       END
X      `20
XC--------------------------------------------------------------------------
X      `20
X      SUBROUTINE init_input()
XC     Initializes four valuators in sample mode, and a choice
XC     device in event mode.`20
X       CHARACTER*80 vrec(10), crec(10)
X       CHARACTER*80 str(2)
X       INTEGER ia(2)
X       INTEGER la(2)
X       REAL ra(2)
X       REAL ea(4)
X       INTEGER err
X       REAL devx, devy
X       CHARACTER*80 titles(5)
X`20
X       include '`5B`5Dvmsphigs77.for'
X
X       call psvlm(1, 1, PREQU, PECHO)
X       call psvlm(1, 2, PREQU, PECHO)
X       call psvlm(1, 3, PREQU, PECHO)
X       call psvlm(1, 4, PREQU, PECHO)
X       call pschm(1, 1, PREQU, PECHO)
X      `20
X       call ptkf_inqmaxdevicecoords(1, devx, devy)
X
X       call ptkf_limit(devx * 0.8, devx, devy * 0.8, devy, ea)
X
X       titles(1) = 'Spin'
X       titles(2) = 'Zoom'
X       titles(3) = 'Swivel'
X       titles(4) = 'Twist'
X       titles(5) = 'Options'
X
X       ia(1) = %LOC(titles(1))
X       ia(2) = 4
X       call pprec(2, ia, 0, ra, 0, la, str, 10, err, ldr, vrec)
X       call pinvl(1, 1, 0.0, 1, ea(1), ea(2), ea(3), ea(4), 0.0,`20
X     : 360.0, ldr, vrec)
X       call psvlm(1, 1, PSAMPL, PECHO)
X      `20
X       ia(1) = %LOC(titles(2))
X       ia(2) = 4
X       call pprec(2, ia, 0, ra, 0, la, str, 10, err, ldr, vrec)
X
X       call ptkf_limit(devx * 0.8, devx, devy * 0.6, devy * 0.8, ea)
X
X       call pinvl(1, 2, 1.0, 1, ea(1), ea(2), ea(3), ea(4), 0.0, 2.0,`20
X     : ldr, vrec)
X       call psvlm(1, 2, PSAMPL, PECHO)
X      `20
X       ia(1) = %LOC(titles(3))
X       ia(2) = 6
X       call pprec(2, ia, 0, ra, 0, la, str, 10, err, ldr, vrec)
X
X       call ptkf_limit(devx * 0.8, devx, devy * 0.4, devy * 0.6, ea)
X
X       call pinvl(1, 3, 0.0, 1, ea(1), ea(2), ea(3), ea(4), 0.0,`20
X     : 360.0, ldr, vrec)
X       call psvlm(1, 3, PSAMPL, PECHO)
X      `20
X       ia(1) = %LOC(titles(4))
X       ia(2) = 5
X       call pprec(2, ia, 0, ra, 0, la, str, 10, err, ldr, vrec)
X
X       call ptkf_limit(devx * 0.8, devx, devy * 0.2, devy * 0.4, ea)
X
X       call pinvl(1, 4, 0.0, 1, ea(1), ea(2), ea(3), ea(4), 0.0,`20
X     : 360.0, ldr, vrec)
X       call psvlm(1, 4, PSAMPL, PECHO)
X      `20
X       ea(3) = 0.0
X       ea(4) = 0.05`20
X       str(1) = 'Reset'
X       str(2) = 'Exit'
X       la(1) = 5
X       la(2) = 4
X       ia(1) = %loc(titles(5))
X       ia(2) = 7
X       call pprec(2, ia, 0, ra, 2, la, str, 10, err, ldr, crec)
X       call pinch(1, 1, POK, 1, 1, ea(1), ea(2), ea(3), ea(4), ldr,`20
X     : crec)
X       call pschm(1, 1, PEVENT, PECHO)
X
X       RETURN
X       END
X      `20
XC--------------------------------------------------------------------------
X      `20
X       SUBROUTINE camerainterface()
X       INTEGER wsid, inclass, indev
XC Event input data.`20
X       INTEGER chstat, chnum
X       REAL spinval, oldspinval, newspin
X       REAL swivelval, oldswivelval, newswivel
X       REAL twistval, oldtwistval, newtwist
X       REAL zoomval, oldzoomval, newzoom
X       INTEGER stat
X
X       include '`5B`5Dvmsphigs77.for'
X   `20
X       call init_input()
X
XC Initialise input devices.`20
X       chnum = 0
X       oldspinval = 0.0
X       oldswivelval = 0.0
X       oldtwistval = 0.0
X       oldzoomval = 1.0
X 20    call psmvl(1, 1, spinval)
X       call psmvl(1, 2, zoomval)
X       call psmvl(1, 3, swivelval)
X       call psmvl(1, 4, twistval)
X       newspin = spinval - oldspinval
X       newswivel = swivelval - oldswivelval
X       newtwist = (twistval - oldtwistval)
X       if (oldzoomval .ne. 0.0) then
X         newzoom = zoomval / oldzoomval
X       endif
X       if (newspin .ne. 0.0) then
X         call ptkf_rotatecameraposition(1, newspin)
X         call prst(1, PALWAY)
X       endif
X       if (newzoom .ne. 1.0) then
X         call ptkf_scaleviewwindow(1, newzoom)
X         call prst(1, PALWAY)
X       endif
X       if (newswivel .ne. 0.0) then
X         call ptkf_rotatecameraptinterest(1, newswivel)
X         call prst(1, PALWAY)
X       endif
X       if (newtwist .ne. 0.0) then
X         call ptkf_rotatecameraupvector(1, newtwist)
X         call prst(1, PALWAY)
X       endif
X       oldspinval = spinval
X       oldswivelval = swivelval
X       oldtwistval = twistval
X       oldzoomval = zoomval
X       call pwait(0.0, wsid, inclass, indev)
XC See if choice picked.`20
X       if (inclass .eq. PCHOIC) then
X         call pgtch(chstat, chnum)
X         call pflush(1, inclass, indev)
X       endif
X       if (chnum .eq. 1) then
X         call init_input()
X         oldspinval = 0.0
X         oldswivelval = 0.0
+-+-+-+-+-+-+-+-  END  OF PART 169 +-+-+-+-+-+-+-+-