
*=======================================================================
*     
*  Title:        PULLDOWN PACKAGE
*                
*  Version:      1-001
*                
*  Abstract:     This is a package of routines to implement a pulldown
*                menu system on a VT100 type terminal with SMG routines.
*                It is used by SWING
*                
*  Environment:  VMS
*                
*  Author:       Eric Andresen of General Research Corporation
*                
*  Date:         24-SEP-1986 
*                
*-----------------------------------------------------------------------

      subroutine pd_get_choice( board_id, keyboard, width, 
     .                          pd_choices, choice, code )

*     PD_GET_CHOICE( BOARD_ID, KEYBOARD, WIDTH, PD_CHOICES, CHOICE, CODE )
*     
*     BOARD_ID       INTEGER*4
*     KEYBOARD       INTEGER*4
*     WIDTH          INTEGER*4
*     PD_CHOICES     RECORD /PD_CHOICE_TYPE/  (PULLDOWN.CMN)
*     CHOICE         CHARACTER*(PD_MAX_CHOICE_LEN)
*     CODE           INTEGER*4
*
      include 'pulldown.cmn'

      integer   num_choice, save_choice, code, keyboard, width
      integer   board_id
      logical   do_bar
      character choice*(PD_MAX_CHOICE_LEN)
      record /pd_choice_type/ pd_choices

      do_bar = .true.
      num_choice = 1

C     LOOP UNTIL A VALID EXIT OCCURS
      do while ( do_bar )

C        GET A CHOICE FROM THE BAR
         call pd_bar_choice( keyboard, num_choice, pd_choices )

         save_choice = 0
         do_bar = .false.

C        AS LONG AS THE USER IS CHOOSING LISTS FROM THE BAR
         do while ( save_choice .ne. num_choice .and.
     .              pd_choices.ptr(num_choice) .ne. 0 )
            save_choice = num_choice
            call pd_list_choice( board_id, keyboard, width, num_choice,
     .                           %val(pd_choices.ptr(num_choice)),
     .                           choice, code, do_bar )
         end do

C        IF A CHOICE HAS BEEN MADE 
         if ( .not. do_bar ) then
            
C           IF ITS ONLY A CHOICE FROM THE BAR BECAUSE THERE WAS NO
C           ASSOCIATED LIST
            if ( save_choice .eq. 0 .and. num_choice .ne. 0 ) then
               choice = pd_choices.choice(num_choice)
               code = pd_choices.code(num_choice)

C              IF NO CHOICE WAS MADE
               else if ( save_choice .eq.0 .and. num_choice .eq.0 ) then
               choice = ' '
               code = -1
               end if

C              OTHERWISE A CHOICE WAS MADE FROM THE CALL TO
C              pd_list_choice

            end if

      end do

      return
      end

      subroutine pd_load_bar( width, pd_choices )

*     PD_LOAD_BAR( WIDTH, PD_CHOICES )
*     
*     WIDTH          INTEGER*4
*     PD_CHOICES     RECORD /PD_CHOICE_TYPE/  (PULLDOWN.CMN)
*
      include '($smgdef)'
      include 'pulldown.cmn'

      integer max_cell, ii, jj, kk, lens(PD_MAX_CHOICES)
      integer start_pos, off_set, width
      record /pd_choice_type/ pd_choices

C     FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
      ii = 1
      max_cell = 0
      do while ( ii .le. pd_choices.number )
         call str$trim( pd_choices.choice(ii), pd_choices.choice(ii), 
     .                  lens(ii) )
         max_cell = max( max_cell, lens(ii) )         
         ii = ii + 1         
      end do
      ii = ii - 1
      
C     CREATE THE VIRTUAL DISPLAY FOR THE BAR
      if ( pd_bar_id .eq. 0 ) then
         istat = smg$create_virtual_display( 1, width, pd_bar_id,,
     .                                       smg$m_reverse )
         else
         call smg$erase_display( pd_bar_id )
         istat = smg$change_virtual_display( pd_bar_id, 1, width, 
     .                                       pd_bar_id,, smg$m_reverse )
         end if

C     FIGURE OUT THE LENGTH OF EACH CELL

C     IF THERE IS ROOM ENOUGH FOR ALL OF THE CHOICES AS IS
      if ( (ii*max_cell) .le. width ) then
         pd_cell_size = min( 16, width / ii )

C        MAKE IT 16 OR LESS
         else
         pd_cell_size = min( 16, width / max_cell )
         end if

C     PUT THE CHOICES IN THE MENU
      do jj = 1, ii
         start_pos = 1 + (pd_cell_size*(jj-1))
         off_set = max( 1, pd_cell_size-lens(jj)) / 2
         call smg$put_chars( pd_bar_id, 
     .                       pd_choices.choice(jj)(1:lens(jj)),,
     .                       start_pos + off_set )
      end do      

      pd_num_choices = ii

      return
      end

      subroutine pd_draw_bar( board_id )

*     PD_DRAW_BAR( BOARD_ID )
*
*     BOARD_ID          INTEGER*4
*
      include 'pulldown.cmn'

      integer board_id

      call smg$unpaste_virtual_display( pd_bar_id, board_id )
      call smg$paste_virtual_display( pd_bar_id, board_id, 1, 1 )

      return
      end 

      subroutine pd_undraw_bar( board_id )

*     PD_UNDRAW_BAR( BOARD_ID )
*
*     BOARD_ID          INTEGER*4
*
      include 'pulldown.cmn'

      integer board_id

      call smg$unpaste_virtual_display( pd_bar_id, board_id )

      return
      end 

      subroutine pd_bar_choice( keyboard, num_choice, pd_choices )

      include '($smgdef)'
      include 'pulldown.cmn'

      integer pos, new_pos, key, num_choice, keyboard
      logical exit, down
      record /pd_choice_type/ pd_choices

      exit = .false.
      down = .false.
      key = 0
      new_pos = num_choice
      pos = num_choice

C     SET THE RENDITION OF THE FIRST CHOICE
      ii = 1 + (pd_cell_size*(new_pos-1))
      call smg$change_rendition( pd_bar_id, 1, ii, 1, 
     .                           pd_cell_size, smg$m_bold )

      do while ( key .ne. smg$k_trm_enter .and.
     .           key .ne. smg$k_trm_cr .and. 
     .           .not. down .and. .not. exit ) 

         call smg$set_cursor_abs( pd_bar_id, 1, 1 )

         call smg$read_keystroke( keyboard, key )

         if ( key .eq. smg$k_trm_left ) then
            if ( pos .gt. 1 ) new_pos = pos - 1
            else if ( key .eq. smg$k_trm_right ) then
            if ( pos .lt. pd_num_choices ) new_pos = pos + 1
            else if ( key .eq. smg$k_trm_down ) then
            if ( pd_choices.ptr(pos) .ne. 0 ) down = .true.
            else if ( key .eq. smg$k_trm_ctrlz ) then
            exit = .true.
            end if

         if ( new_pos .ne. pos ) then
            ii = 1 + (pd_cell_size*(pos-1))
            call smg$change_rendition( pd_bar_id, 1, ii, 1, 
     .                                 pd_cell_size, 0, 0 )
            ii = 1 + (pd_cell_size*(new_pos-1))
            call smg$change_rendition( pd_bar_id, 1, ii, 1, 
     .                                 pd_cell_size, smg$m_bold )
            end if

         pos = new_pos

      end do

      ii = 1 + (pd_cell_size*(pos-1))
      call smg$change_rendition( pd_bar_id, 1, ii, 1, 
     .                           pd_cell_size, 0, 0 )

      if ( exit ) then
         num_choice = 0
         else
         num_choice = pos
         end if

      return
      end

      subroutine pd_list_choice( board_id, keyboard, width, num_choice, 
     .                           pd_choices, choice, code, do_bar)

      include '($smgdef)'
      include 'pulldown.cmn'

      record /pd_choice_type/ pd_choices

      integer max_cell, ii, jj, kk, lens(PD_MAX_CHOICES), code
      integer start_pos, pd_list_id, atts(PD_MAX_CHOICES), num_choice
      integer pos, new_pos, key, width, keyboard, board_id
      logical exit, do_bar
      character choice*(PD_MAX_CHOICE_LEN)

      do_bar = .false.

C     FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
      ii = 1
      max_cell = 0
      do while ( ii .le. pd_choices.number )
         call str$trim( pd_choices.choice(ii), pd_choices.choice(ii), 
     .                  lens(ii) )
         max_cell = max( max_cell, lens(ii) )         
         ii = ii + 1         
      end do
      ii = ii - 1
      
C     CREATE THE VIRTUAL DISPLAY FOR THE LIST
      istat = smg$create_virtual_display( ii, max_cell, pd_list_id,
     .                                    smg$m_border, smg$m_reverse )

C     PUT THE CHOICES IN THE LIST
      do jj = 1, ii
         if ( pd_choices.ptr(jj) .eq. 0 ) then
            call smg$put_chars( pd_list_id, 
     .                          pd_choices.choice(jj)(1:max_cell),
     .                          jj, 1 )
            atts(jj) = 0
            else
            call smg$put_chars( pd_list_id, 
     .                          pd_choices.choice(jj)(1:max_cell),
     .                          jj, 1,, smg$m_underline )
            atts(jj) = smg$m_underline
            end if
      end do      

      start_pos = 1 + (pd_cell_size*(num_choice-1))
      if ( start_pos + max_cell .gt. width ) then
         start_pos = width - max_cell + 1
         end if

      call smg$begin_pasteboard_update( board_id )
      call smg$paste_virtual_display( pd_list_id, board_id, 2, 
     .                                start_pos )
      call smg$repaste_virtual_display( pd_bar_id, board_id, 1, 1 )
      call smg$end_pasteboard_update( board_id )

C     GET A CHOICE FROM THE LIST
      exit = .false.
      key = 0
      pos = 1
      new_pos = 1

C     SET THE RENDITION OF THE FIRST CHOICE
      call smg$change_rendition( pd_list_id, 1, 1, 1, 
     .                           max_cell, smg$m_bold + atts(1) )

      do while ( key .ne. smg$k_trm_enter .and.
     .           key .ne. smg$k_trm_cr .and. .not. exit ) 

         call smg$set_cursor_abs( pd_list_id, pos, 1 )

         call smg$read_keystroke( keyboard, key )

         if ( key .eq. smg$k_trm_up ) then
            if ( pos .gt. 1 ) then
               new_pos = pos - 1
               else
               do_bar = .true.
               exit = .true.
               end if
            else if ( key .eq. smg$k_trm_down ) then
            if ( pos .lt. ii ) new_pos = pos + 1
            else if ( key .eq. smg$k_trm_left ) then
            if ( num_choice .gt. 1 ) num_choice = num_choice - 1
            do_bar = .true.
            exit = .true.
            else if ( key .eq. smg$k_trm_right ) then
            if ( num_choice .lt. pd_num_choices ) 
     .         num_choice = num_choice + 1
            do_bar = .true.
            exit = .true.
            else if ( key .eq. smg$k_trm_ctrlz ) then
            exit = .true.
            end if

         if ( new_pos .ne. pos ) then
            call smg$change_rendition( pd_list_id, pos, 1, 1, 
     .                                 max_cell, atts(pos))
            call smg$change_rendition( pd_list_id, new_pos, 1, 1,
     .                                 max_cell, 
     .                                 smg$m_bold+atts(new_pos) )
            end if

         pos = new_pos

      end do

      call smg$unpaste_virtual_display( pd_list_id, board_id )

      if ( exit ) then
         choice = ' '
         code = -1
         else
         choice = pd_choices.choice(pos)
         code = pd_choices.code(pos)
         end if

      return
      end
