Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!utgpu!water!watnot!watmath!clyde!cbatt!ucbvax!u3369429@seismo.CSS.GOV@murdu.OZ.AU
From: u3369429@seismo.CSS.GOV@murdu.OZ.AU
Newsgroups: mod.computers.vax
Subject: SWING (modified) part 4 of 6
Message-ID: <8703030252.10302@murdu.OZ>
Date: Tue, 3-Mar-87 13:52:57 EST
Article-I.D.: murdu.8703030252.10302
Posted: Tue Mar  3 13:52:57 1987
Date-Received: Thu, 5-Mar-87 19:31:40 EST
Sender: daemon@ucbvax.BERKELEY.EDU
Reply-To: munnari!u3369429@seismo.CSS.GOV (Michael Bednarek)
Distribution: world
Organization: I.A.E.S.R., Melbourne University
Lines: 643
Approved: info-vax@sri-kl.arpa

$write sys$error "extract PD_LIST_CHOICE.FOR"
$copy sys$input PD_LIST_CHOICE.FOR
$deck/dollars="870303:12:53:38"
      subroutine pd_list_choice( board_id, keyboard, width, num_choice,
     .                           pd_choices, choice, code, do_bar)

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

      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
870303:12:53:38
$write sys$error "extract PD_LOAD_BAR.FOR"
$copy sys$input PD_LOAD_BAR.FOR
$deck/dollars="870303:12:53:38"
      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)/List'
      include 'pulldown.cmn/List'

      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
870303:12:53:38
$write sys$error "extract PD_UNDRAW_BAR.FOR"
$copy sys$input PD_UNDRAW_BAR.FOR
$deck/dollars="870303:12:53:38"
      subroutine pd_undraw_bar( board_id )

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

      integer board_id

      call smg$unpaste_virtual_display( pd_bar_id, board_id )

      return
      end
870303:12:53:38
$write sys$error "extract PRINT_MESSAGE.FOR"
$copy sys$input PRINT_MESSAGE.FOR
$deck/dollars="870303:12:53:38"
      subroutine print_message( message, abort )

      include    'swing.cmn/List'

      logical    abort, erased
      character  message*(*)

      if ( using_screen ) then

         if ( message .eq. ' ' ) then
            if ( .not. erased ) then
               erased = .true.
               call smg$erase_display( window3 )
               call smg$erase_line( window3, 2, 1 )
               end if

            else
            erased = .false.
            call smg$erase_display( window3 )
            call smg$put_chars( window3, message, 2, 1, 1 )
            end if

         if ( abort ) call exit_swing

         else
         print *, 'SWING: ', message
         if ( abort ) stop ' '
         end if

      return
      end
870303:12:53:38
$write sys$error "extract RECORD_STRUCTURE.FOR"
$copy sys$input RECORD_STRUCTURE.FOR
$deck/dollars="870303:12:53:38"
      subroutine record_structure( search )

      include    'swing.cmn/List'

      character  spec*255
      logical    search
      integer    icontext

      if ( search .and. swing_file_exists ) then
         do ii = 1, num_nodes
            node(ii).length = 0
            node(ii).child = 0
            node(ii).sister = 0
         end do

         call load_nodes

         call load_display

         call update_screen( cur_line, cur_level )
         end if

      do_save = .false.

      call print_message( 'Saving directory structure', 0 )

      icontext = 0
      do while( lib$find_file( main(1:len_main)//'swing.sav;*',
     .                         spec, icontext ))
         if ( .not. lib$delete_file( spec ) ) then
            call str$trim( spec, spec, len_spec )
            if ( modify_file_prot( spec(1:len_spec), 0, 0 ) ) then
               istat = lib$delete_file( spec )
               else
               call lib$spawn( 'SET PROT=(S:D,O:D,G:D,W:D) '//
     .                         main(1:len_main)//'swing.sav',
     .                         'NL:', 'NL:' )
               istat = lib$delete_file( spec )
               end if
            end if
      end do
      call lib$find_file_end( icontext )

      open( unit=2,
     .      name=main(1:len_main)//'swing.sav',
     .      status='new',
     .      carriagecontrol='list',
     .      access='sequential',
     .      form='unformatted',
     .      recl=73,
     .      organization='sequential',
     .      recordtype='variable',
     .      iostat=istat,
     .      err=99 )

      write( 2 ) num_lines, num_nodes, lowest_level

      do ii = 1, num_lines
         write( 2 ) (node_pointer(jj,ii), jj=0, MAX_LEVELS)
      end do

      do ii = 1, num_nodes
         write( 2 ) node(ii)
      end do

      close( unit=2 )

      call print_message( 'Finished saving directory structure', 0 )

      return

99    call print_message( 'Unable to record directory structure', 0 )
      return
      end
870303:12:53:38
$write sys$error "extract RENAME_DIRECTORY.FOR"
$copy sys$input RENAME_DIRECTORY.FOR
$deck/dollars="870303:12:53:38"
      subroutine rename_directory( code )

      include    'swing.cmn/List'
      include    '($ssdef)/List'
      include    '($smgdef)/List'

      character  new_dir*42, key, string*39, message*255, file*255
      integer    ikey, len_string, lib$rename_file, code, parent
      integer    sys$getmsg, istat, len_message, ipos, from_level
      integer    old_line, old_level, from_num, from_line
      logical    dir_to_file, finished, check_directory_move

      if ( code .eq. 20 ) then

         call print_message( ' ', 0 )
         call smg$set_cursor_abs( window3, 1, 1 )
         call smg$read_string( keyboard, string,
     .                         'Enter new name to give directory: ',
     .                         39,,,,len_string,, window3 )

         new_dir = ' '
         jj = 0

         do ii = 1, len_string
            if (string(ii:ii) .ne. '[' .and. string(ii:ii) .ne. ']'.and.
     .         string(ii:ii) .ne. '.' .and. string(ii:ii) .gt. ' ' .and.
     .         string(ii:ii) .ne. ';' ) then
               jj = jj + 1
               new_dir(jj:jj) = string(ii:ii)
               end if
         end do

         call str$upcase( new_dir, new_dir )

         if ( jj .ne. 0 ) then
            if ( dir_to_file( node(node_num).spec,
     .                        node(node_num).length,
     .                        file, ipos ) ) then
               istat = lib$rename_file( file,
     .                                  new_dir(1:jj)//'.DIR;1',,,
     .                                  1 )

               if ( istat .eq. ss$_normal ) then
                  call file_to_dir( file(1:ipos)//new_dir(1:jj)//'.DIR',
     .                              node(node_num).spec,
     .                              node(node_num).length,
     .                              node(node_num).name )

                  parent = 0
                  call move_node( node_num, parent )

                  call adjust_node_pointers

                  call load_display

                  cur_line = node(node_num).line
                  cur_level = node(node_num).level

                  call update_screen( cur_line, cur_level )

                  call print_message( 'Subdirectory renamed', 0 )

                  do_save = .true.

                  else
                  call sys$getmsg( %val(istat), len_message, message,
     .                             %val(1), )
                  call print_message( message(1:len_message), 0 )
                  end if
               end if
            else
            call smg$erase_display( window3 )
            end if

         else if ( code .eq. 30 ) then

         from_num = node_num
         from_line = cur_line
         from_level = cur_level
         node(from_num).rend = smg$m_reverse + smg$m_blink

         call smg$change_rendition( window2, from_line, from_level*17+1,
     .                              1, 12, node(from_num).rend )

         call print_message( 'Travel to new parent directory and hit '//
     .                       'RETURN - Hit any other key to abort', 0 )
         call smg$set_cursor_abs( window2, from_line, from_level*17+1 )

         finished = .false.

         do while ( .not. finished )

            call smg$read_keystroke( keyboard, ikey )

            old_line = cur_line
            old_level = cur_level
            old_rend = node(node_num).rend

            if ( ikey .eq. smg$k_trm_cr .or.
     .           ikey .eq. smg$k_trm_enter ) then
               finished = .true.

               else if ( ikey .eq. smg$k_trm_up ) then
               ii = cur_level
               jj = cur_line - 1
!!!	       do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 ) ! Michael Bednarek changed to:
	       do while (jj.ge.1 .and. node_pointer(ii,jj).eq.0)
                  jj = jj - 1
               end do
               if ( jj .ge. 1 ) cur_line = jj
               call update_screen( old_line, old_level )

               else if ( ikey .eq. smg$k_trm_down ) then
               ii = cur_level
               jj = cur_line + 1
               do while( node_pointer(ii,jj) .eq. 0 .and.
     .                   jj .le. num_lines )
                  jj = jj + 1
               end do
               if ( jj .le. num_lines ) cur_line = jj
               call update_screen( old_line, old_level )

               else if ( ikey .eq. smg$k_trm_right ) then
               ii = cur_level + 1
               jj = cur_line
               do while( node_pointer(ii,jj) .eq. 0 .and.
     .                   ii .le. MAX_LEVELS )
                  ii = ii + 1
               end do
               if ( ii .le. MAX_LEVELS ) cur_level = ii
               call update_screen( old_line, old_level )

               else if ( ikey .eq. smg$k_trm_left .and.
     .                   cur_level .ge. 1 ) then
               ii = cur_level - 1
               jj = cur_line
               do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 )
                  jj = jj - 1
               end do
               if ( jj .ge. 1 ) then
                  cur_level = ii
                  cur_line = jj
                  end if
               call update_screen( old_line, old_level )

               else
               finished = .true.
               end if

            call smg$set_cursor_abs( window2, cur_line, cur_level*17+1 )

         end do

         node(from_num).rend = smg$m_reverse

         call smg$change_rendition( window2, from_line, from_level*17+1,
     .                              1, 12, node(from_num).rend )

         if ( ikey .eq. smg$k_trm_cr .or.
     .        ikey .eq. smg$k_trm_enter ) then

            if ( .not. check_directory_move( from_num, node_num ) ) then
               call update_screen( cur_line, cur_level )
               call print_message( 'Rename would cause too great a '//
     .            'directory depth', 0 )
               return
               end if

            if ( dir_to_file( node(from_num).spec,
     .                        node(from_num).length,
     .                        file, ipos ) ) then

               istat = lib$rename_file( file,
     .                 node(node_num).spec(1:node(node_num).length)//
     .                 '*.dir;1',,, 1 )

               if ( istat ) then
                  call move_node( from_num, node_num )

                  call adjust_node_pointers

                  call load_display

                  cur_line = node(from_num).line
                  cur_level = node(from_num).level

                  call update_screen( cur_line, cur_level )

                  call print_message( 'Subdirectory has been moved', 0 )

                  do_save = .true.

                  else
                  call sys$getmsg( %val(istat), len_message, message,
     .                             %val(1), )
                  call print_message( message(1:len_message), 0 )
                  end if
               end if
            else
            call smg$erase_display( window3 )
            end if
         else
         call smg$erase_display( window3 )
         end if

      return
      end
870303:12:53:38
$write sys$error "extract RESET_TERMINAL.FOR"
$copy sys$input RESET_TERMINAL.FOR
$deck/dollars="870303:12:53:38"
      subroutine reset_terminal( terminal, char_buffer )

C     ROUTINE USES THE IO$_SETMODE FUNCTION TO SET TERMINAL
C     CHARACTERISTICS

      include    '($iodef)/List'

c                LAYOUT OF char_buffer
c
c     --------------------------------------------
c     |    buffer size     |   type   |   class  |  <- longword
c     |page len  |   terminal characteristics    |  <- longword (TTDEF)
c     |    extended terminal characteristics     |  <- longword (TT2DEF)
c     --------------------------------------------
c     31                                         0

      integer*2  iosb(4)
      integer*4  status, sys$trnlog, sys$assign, sys$qiow, chan
      integer*4  reset, char_buffer(3)
      character  terminal*(*)

      status = sys$assign( terminal, chan,, )

      status = sys$qiow ( %val(1),
     .                  %val(chan),
     .                  %val(io$_setmode),
     .                  iosb,,,
     .                  %ref(char_buffer),
     .                  %val(12),,,, )

      return
      end
870303:12:53:38
$write sys$error "extract SET_NOTAB.FOR"
$copy sys$input SET_NOTAB.FOR
$deck/dollars="870303:12:53:38"
      subroutine set_notab( terminal, save_buffer )

C     ROUTINE USES THE IO$_SETMODE FUNCTION TO SET TERMINAL
C     CHARACTERISTICS

      include    '($iodef)/List'
      include    '($ttdef)/List'
      include    '($tt2def)/List'

c                LAYOUT OF char_buffer
c
c     --------------------------------------------
c     |    buffer size     |   type   |   class  |  <- longword
c     |page len  |   terminal characteristics    |  <- longword (TTDEF)
c     |    extended terminal characteristics     |  <- longword (TT2DEF)
c     --------------------------------------------
c     31                                         0

      integer*2  iosb(4)
      integer*4  status, sys$trnlog, sys$assign, sys$qiow, chan
      integer*4  char_buffer(3), save_buffer(3)
      character  terminal*(*)

      status = sys$assign( terminal, chan,, )

      stat = sys$qiow ( %val(1),
     .                  %val(chan),
     .                  %val(io$_sensemode),
     .                  iosb,,,
     .                  %Ref(save_buffer),
     .                  %val(12),,,, )

      char_buffer(1) = save_buffer(1)
      char_buffer(2) = jibclr( save_buffer(2), tt$v_mechtab )
      char_buffer(3) = save_buffer(3)

      status = sys$qiow ( %val(1),
     .                  %val(chan),
     .                  %val(io$_setmode),
     .                  iosb,,,
     .                  %Ref(char_buffer),
     .                  %val(12),,,, )

      return
      end
870303:12:53:38
$write sys$error "extract SM_ALLOW_REPAINT.FOR"
$copy sys$input SM_ALLOW_REPAINT.FOR
$deck/dollars="870303:12:53:38"
      subroutine sm_allow_repaint

      include 'swing.cmn/List'

      integer  address
      external sm_repaint_screen

      address =  %loc( sm_repaint_screen )
      call smg$set_out_of_band_asts( board_id, '800000'x,
     .                               %val(address) )

      return
      end
870303:12:53:38
$write sys$error "extract SM_REPAINT_SCREEN.FOR"
$copy sys$input SM_REPAINT_SCREEN.FOR
$deck/dollars="870303:12:53:38"
      subroutine sm_repaint_screen

      include 'swing.cmn/List'

      call smg$repaint_screen( board_id )

      return
      end
870303:12:53:38