From:	CSBVAX::MRGATE!vtcf@ncsc.ARPA@SMTP 13-APR-1988 05:48
To:	ARISIA::EVERHART
Subj:	SWING 11 OF 13


Received: from ncsc.ARPA by KL.SRI.COM with TCP; Mon 11 Apr 88 09:50:57-PDT
Received: by ncsc.ARPA id AA03425; Mon, 11 Apr 88 11:47:28 CST
Date: Mon, 11 Apr 88 11:47:28 CST
From: vtcf@ncsc.ARPA (Williams)
Message-Id: <8804111747.AA03425@ncsc.ARPA>
To: info-vax@kl.sri.com
Subject: SWING 11 OF 13

$Part11:
$ File_is="SWING_7.FOR"
$ Check_Sum_is=1870510114
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X      subroutine pd_bar_choice( keyboard, num_choice, pd_choices )
X
X      implicit none
X      include '($smgdef)'
X      include 'pulldown.cmn'
X
X      integer pos, new_pos, key, num_choice, keyboard, ii
X      logical exit, down
X      record /pd_choice_type/ pd_choices
X
X      exit = .false.
X      down = .false.
X      key = 0
X      new_pos = num_choice
X      pos = num_choice
X
XC     SET THE RENDITION OF THE FIRST CHOICE
X      ii = 1 + (pd_cell_size*(new_pos-1))
X      call smg$change_rendition( pd_bar_id, 1, ii, 1, 
X     .                           pd_cell_size, smg$m_bold )
X
X      do while ( key .ne. smg$k_trm_enter .and.
X     .           key .ne. smg$k_trm_cr .and. 
X     .           .not. down .and. .not. exit ) 
X
X         call smg$set_cursor_abs( pd_bar_id, 1, 1 )
X
X         call smg$read_keystroke( keyboard, key )
X 
X         if ( key .eq. smg$k_trm_left ) then
X            if ( pos .gt. 1 ) then
X              new_pos = pos - 1
X              else
X              new_pos = pd_num_choices
X              end if
X
X            else if ( key .eq. smg$k_trm_right ) then
X            if ( pos .lt. pd_num_choices ) then
X              new_pos = pos + 1
X              else
X              new_pos = 1
X              end if
X
X            else if ( key .eq. smg$k_trm_down ) then
X            if ( pd_choices.ptr(pos) .ne. 0 ) down = .true.
X
X            else if ( key .eq. smg$k_trm_ctrlz ) then
X            exit = .true.
X            end if
X
X         if ( new_pos .ne. pos ) then
X            ii = 1 + (pd_cell_size*(pos-1))
X            call smg$change_rendition( pd_bar_id, 1, ii, 1, 
X     .                                 pd_cell_size, 0, 0 )
X            ii = 1 + (pd_cell_size*(new_pos-1))
X            call smg$change_rendition( pd_bar_id, 1, ii, 1, 
X     .                                 pd_cell_size, smg$m_bold )
X            end if
X
X         pos = new_pos
X
X      end do
X
X      ii = 1 + (pd_cell_size*(pos-1))
X      call smg$change_rendition( pd_bar_id, 1, ii, 1, 
X     .                           pd_cell_size, 0, 0 )
X
X      if ( exit ) then
X         num_choice = 0
X         else
X         num_choice = pos
X         end if
X
X      return
X      end
X      subroutine pd_draw_bar( board_id )
X
X*     PD_DRAW_BAR( BOARD_ID )
X*
X*     BOARD_ID          INTEGER*4
X*
X      implicit none
X      include 'pulldown.cmn'
X
X      integer board_id
X
X      call smg$unpaste_virtual_display( pd_bar_id, board_id )
X      call smg$paste_virtual_display( pd_bar_id, board_id, 1, 1 )
X
X      return
X      end 
X*=======================================================================
X*     
X*  Title:        PULLDOWN PACKAGE
X*                
X*  Version:      1-001
X*                
X*  Abstract:     This is a package of routines to implement a pulldown
X*                menu system on a VT100 type terminal with SMG routines.
X*                It is used by SWING
X*                
X*  Environment:  VMS
X*                
X*  Author:       Eric Andresen of General Research Corporation
X*                
X*  Date:         24-SEP-1986 
X*                
X*-----------------------------------------------------------------------
X
X      subroutine pd_get_choice( board_id, keyboard, width, 
X     .                          pd_choices, choice, code )
X
X      implicit none
X*     PD_GET_CHOICE( BOARD_ID, KEYBOARD, WIDTH, PD_CHOICES, CHOICE, CODE )
X*     
X*     BOARD_ID       INTEGER*4
X*     KEYBOARD       INTEGER*4
X*     WIDTH          INTEGER*4
X*     PD_CHOICES     RECORD /PD_CHOICE_TYPE/  (PULLDOWN.CMN)
X*     CHOICE         CHARACTER*(PD_MAX_CHOICE_LEN)
X*     CODE           INTEGER*4
X*
X      include 'pulldown.cmn'
X
X      integer   num_choice, save_choice, code, keyboard, width
X      integer   board_id
X      logical   do_bar
X      character choice*(PD_MAX_CHOICE_LEN)
X      record /pd_choice_type/ pd_choices
X
X      do_bar = .true.
X      num_choice = 1
X
XC     LOOP UNTIL A VALID EXIT OCCURS
X      do while ( do_bar )
X
XC        GET A CHOICE FROM THE BAR
X         call pd_bar_choice( keyboard, num_choice, pd_choices )
X
X         save_choice = 0
X         do_bar = .false.
X
XC        AS LONG AS THE USER IS CHOOSING LISTS FROM THE BAR
X         do while ( save_choice .ne. num_choice .and.
X     .              pd_choices.ptr(num_choice) .ne. 0 )
X            save_choice = num_choice
X            call pd_list_choice( board_id, keyboard, width, num_choice,
X     .                           %val(pd_choices.ptr(num_choice)),
X     .                           choice, .true., code, do_bar )
X         end do
X
XC        IF A CHOICE HAS BEEN MADE 
X         if ( .not. do_bar ) then
X            
XC           IF ITS ONLY A CHOICE FROM THE BAR BECAUSE THERE WAS NO
XC           ASSOCIATED LIST
X            if ( save_choice .eq. 0 .and. num_choice .ne. 0 ) then
X               choice = pd_choices.choice(num_choice)
X               code = pd_choices.code(num_choice)
X
XC              IF NO CHOICE WAS MADE
X               else if ( save_choice .eq.0 .and. num_choice .eq.0 ) then
X               choice = ' '
X               code = -1
X               end if
X
XC              OTHERWISE A CHOICE WAS MADE FROM THE CALL TO
XC              pd_list_choice
X
X            end if
X
X      end do
X
X      return
X      end
X      subroutine pd_list_choice( board_id, keyboard, width, num_choice, 
X     .                           pd_choices, choice, pullmode,
X     .                           code, do_bar)
X
X      implicit none
X      include '($smgdef)'
X      include '($ssdef)'
X      include 'pulldown.cmn'
X
X      record /pd_choice_type/ pd_choices
X
X      integer smg$create_virtual_display
X      integer max_cell, ii, jj, kk, lens(PD_MAX_CHOICES), code, istat
X      integer start_pos, pd_list_id, atts(PD_MAX_CHOICES), num_choice
X      integer pos, new_pos, key, width, keyboard, board_id
X      logical exit, do_bar, direct, pullmode
X      character choice*(PD_MAX_CHOICE_LEN), key_upcase
X      do_bar = .false.
X
XC     FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
X      ii = 1
X      max_cell = 0
X      do while ( ii .le. pd_choices.number )
X         call str$trim( pd_choices.choice(ii), pd_choices.choice(ii), 
X     .                  lens(ii) )
X         max_cell = max( max_cell, lens(ii) )         
X         ii = ii + 1         
X      end do
X      ii = ii - 1
X      
XC     CREATE THE VIRTUAL DISPLAY FOR THE LIST
X      istat = smg$create_virtual_display( ii, max_cell, pd_list_id,
X     .                                    smg$m_border, smg$m_reverse )
X
XC     PUT THE CHOICES IN THE LIST
X      do jj = 1, ii
X         if ( pd_choices.ptr(jj) .eq. 0 ) then
X            call smg$put_chars( pd_list_id, 
X     .                          pd_choices.choice(jj)(1:max_cell),
X     .                          jj, 1 )
X            atts(jj) = 0
X            else
X            call smg$put_chars( pd_list_id, 
X     .                          pd_choices.choice(jj)(1:max_cell),
X     .                          jj, 1,, smg$m_underline )
X            atts(jj) = smg$m_underline
X            end if
X      end do      
X
X      start_pos = 1 + (pd_cell_size*(num_choice-1))
X      if ( start_pos + max_cell .gt. width ) then
X         start_pos = width - max_cell + 1
X         end if
X
X      call smg$begin_pasteboard_update( board_id )
X      call smg$paste_virtual_display( pd_list_id, board_id, 2, 
X     .                                start_pos )
X      call smg$repaste_virtual_display( pd_bar_id, board_id, 1, 1 )
X      call smg$end_pasteboard_update( board_id )
X
XC     GET A CHOICE FROM THE LIST
X      exit = .false.
X      direct = .false.
X      key = 0
X      pos = 1
X      new_pos = 1
X
XC     SET THE RENDITION OF THE FIRST CHOICE
X      call smg$change_rendition( pd_list_id, 1, 1, 1, 
X     .                           max_cell, smg$m_bold + atts(1) )
X
X      do while ( key .ne. smg$k_trm_enter .and.
X     .           key .ne. smg$k_trm_cr .and.
X     .           .not. exit .and. .not. direct ) 
X
X         call smg$set_cursor_abs( pd_list_id, pos, 1 )
X
X         call smg$read_keystroke( keyboard, key )
X
X         if ( key .eq. smg$k_trm_up ) then
X            if ( pos .gt. 1 ) then
X               new_pos = pos - 1
X               else
X               do_bar = .true.
X               exit = .true.
X               end if
X          else if ( key .eq. smg$k_trm_down ) then
X            if ( pos .lt. ii ) then
X              new_pos = pos + 1
X              else
X              new_pos = 1
X              end if
X
X          else if ( key .eq. smg$k_trm_left .and.
X     .              pullmode .eq. .true. ) then
X            if ( num_choice .gt. 1 ) num_choice = num_choice - 1
X            do_bar = .true.
X            exit = .true.
X          else if ( key .eq. smg$k_trm_right .and.
X     .              pullmode .eq. .true. ) then
X            if ( num_choice .lt. pd_num_choices ) 
X     .         num_choice = num_choice + 1
X            do_bar = .true.
X            exit = .true.
X
X          else if ( key .eq. smg$k_trm_ctrlz ) then
X            exit = .true.
X
X          else
X            ii = 1
X            do while ( ii .le. pd_choices.number )
X              if ( key .eq. pd_choices.ptr(ii) .or.
X     .             key .eq. pd_choices.ptr(ii) + 32 ) then
X                direct = .true.
X                new_pos = ii
X              end if
X              ii = ii + 1
X            end do
X            end if
X
X         if ( new_pos .ne. pos ) then
X            call smg$change_rendition( pd_list_id, pos, 1, 1, 
X     .                                 max_cell, atts(pos))
X            call smg$change_rendition( pd_list_id, new_pos, 1, 1,
X     .                                 max_cell, 
X     .                                 smg$m_bold+atts(new_pos) )
X            end if
X
X         pos = new_pos
X
X      end do
X
X      call smg$unpaste_virtual_display( pd_list_id, board_id )
X
X      if ( exit ) then
X         choice = ' '
X         code = -1
X         else
X         choice = pd_choices.choice(pos)
X         code = pd_choices.code(pos)
X         end if
X
X      return
X      end
X      subroutine pd_load_bar( width, pd_choices )
X
X*     PD_LOAD_BAR( WIDTH, PD_CHOICES )
X*     
X*     WIDTH          INTEGER*4
X*     PD_CHOICES     RECORD /PD_CHOICE_TYPE/  (PULLDOWN.CMN)
X*
X      implicit none
X      include '($smgdef)'
X      include 'pulldown.cmn'
X
X      integer smg$create_virtual_display, smg$change_virtual_display
X      integer max_cell, ii, jj, kk, lens(PD_MAX_CHOICES)
X      integer start_pos, off_set, width, istat
X      record /pd_choice_type/ pd_choices
X
XC     FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
X      ii = 1
X      max_cell = 0
X      do while ( ii .le. pd_choices.number )
X         call str$trim( pd_choices.choice(ii), pd_choices.choice(ii), 
X     .                  lens(ii) )
X         max_cell = max( max_cell, lens(ii) )         
X         ii = ii + 1         
X      end do
X      ii = ii - 1
X      
XC     CREATE THE VIRTUAL DISPLAY FOR THE BAR
X      if ( pd_bar_id .eq. 0 ) then
X         istat = smg$create_virtual_display( 1, width, pd_bar_id,,
X     .                                       smg$m_reverse )
X         else
X         call smg$erase_display( pd_bar_id )
X         istat = smg$change_virtual_display( pd_bar_id, 1, width, 
X     .                                       pd_bar_id,, smg$m_reverse )
X         end if
X
XC     FIGURE OUT THE LENGTH OF EACH CELL
X
XC     IF THERE IS ROOM ENOUGH FOR ALL OF THE CHOICES AS IS
X      if ( (ii*max_cell) .le. width ) then
X         pd_cell_size = min( 16, width / ii )
X
XC        MAKE IT 16 OR LESS
X         else
X         pd_cell_size = min( 16, width / max_cell )
X         end if
X
XC     PUT THE CHOICES IN THE MENU
X      do jj = 1, ii
X         start_pos = 1 + (pd_cell_size*(jj-1))
X         off_set = max( 1, pd_cell_size-lens(jj)) / 2
X         call smg$put_chars( pd_bar_id, 
X     .                       pd_choices.choice(jj)(1:lens(jj)),,
X     .                       start_pos + off_set )
X      end do      
X
X      pd_num_choices = ii
X
X      return
X      end
X      subroutine pd_undraw_bar( board_id )    
X
X*     PD_UNDRAW_BAR( BOARD_ID )
X*
X*     BOARD_ID          INTEGER*4
X*
X      implicit none
X      include 'pulldown.cmn'
X
X      integer board_id
X
X      call smg$unpaste_virtual_display( pd_bar_id, board_id )
X
X      return
X      end 
X      subroutine print_file
X
Xc     Craig Young               3-AUG-87
X
Xc     This subroutine sends the current file to the printer as specified
Xc     by Swing$Print or defaults to $Print.  The terminal is not attached
Xc     to the spawned process so use of swing can continue.
X
X      include    'swing.cmn'
X      include    '($ssdef)'
X      include    '($clidef)'
X
XC
XC     file*50 changed to file*255   Change suggested by F. Bonzanigo
XC                                               Inst. f. Elektronik
XC                                               ETH-Zurich, Switzerland
XC
X
X      character  string*255, logical_name*50, file*255
X      integer    istat, len_string, len_file
X      integer*4  translate_logical
X
Xc     Check if current file is a directory.  If so, abort print.
X
X      istat = index( fnode(file_num).spec(1:), '.DIR;1' )
X
X      if ( istat .eq. 0 ) then
X         call print_message( ' ', 0 )
X         call smg$set_cursor_abs( window3, 2, 1 )
X         call str$trim( file, fnode(file_num).spec, len_file )
X
X         logical_name = 'SWING$PRINT'           !Check for user's printer
X         istat = translate_logical( logical_name, string )
X         if ( istat .eq. ss$_normal ) then
X            call str$trim( string, string, len_string )
X            call lib$spawn( string(1:len_string)
X     .                      //'/noidentify/nonotify '
X     .                      //file(1:len_file),,,cli$m_nowait)
X         else
X            call lib$spawn( '$print/noidentify/nonotify '
X     .                      //file(1:len_file),,,cli$m_nowait)
X            end if
X
X         call print_message( 'Sent file to printer.', 0 )
X
X      else
X         call print_message( 'Cannot print a directory.', 0 )
X         end if
X
X      return
X      end
X
$ GoSub Convert_File
$ Goto Part12
