!******************************************************************** !* * !* Program: MENU1 * !* * !* Purpose: Menu subroutine. Places provided text on screen, * !* allows user to manipulate screen to make a choice. * !* * !* Programmer: Richard Snyder * !* The KeTech Corporation * !* * !* Calling parameters: * !* * !* param 1 - character string array, each element is 60 * !* characters long, the array contains 16 elements * !* The first element is the title line for the * !* menu. The other fifteen elements are the text * !* lines for the choices on the menu. Passed by * !* descriptor. * !* * !* param 2 - 32 bit integer, passed by reference. Specifies * !* the number of choices on the menu (2-15). * !* * !* param 3 - 32 bit integer, passed by reference. Specifies * !* the users choice ( 1 - param 2 ). * !* * !* param 4 - 32 bit integer, passed by reference. Flag to * !* control whether the routine completely repaints * !* the screen (useful in screen overlays). Set * !* to a one (1) causes a complete repaint of the * !* screen. * !* * !******************************************************************** subroutine menu1(prompt_string,no_choices,ireturn_code,ir) character*60 prompt_string(16) character*19 where(15) character*10 erase(15) character field*6 character garb*1 character mail_count*1 character bell*1 character esc*1 character bsp*1 data bell /7/ data esc /27/ data bsp /8/ ! ! initialize strings to position arrow ! where(1)=esc//'[05;06H'//esc//'[1m->'//esc//'[0m'//bsp where(2)=esc//'[06;06H'//esc//'[1m->'//esc//'[0m'//bsp where(3)=esc//'[07;06H'//esc//'[1m->'//esc//'[0m'//bsp where(4)=esc//'[08;06H'//esc//'[1m->'//esc//'[0m'//bsp where(5)=esc//'[09;06H'//esc//'[1m->'//esc//'[0m'//bsp where(6)=esc//'[10;06H'//esc//'[1m->'//esc//'[0m'//bsp where(7)=esc//'[11;06H'//esc//'[1m->'//esc//'[0m'//bsp where(8)=esc//'[12;06H'//esc//'[1m->'//esc//'[0m'//bsp where(9)=esc//'[13;06H'//esc//'[1m->'//esc//'[0m'//bsp where(10)=esc//'[14;06H'//esc//'[1m->'//esc//'[0m'//bsp where(11)=esc//'[15;06H'//esc//'[1m->'//esc//'[0m'//bsp where(12)=esc//'[16;06H'//esc//'[1m->'//esc//'[0m'//bsp where(13)=esc//'[17;06H'//esc//'[1m->'//esc//'[0m'//bsp where(14)=esc//'[18;06H'//esc//'[1m->'//esc//'[0m'//bsp where(15)=esc//'[19;06H'//esc//'[1m->'//esc//'[0m'//bsp ! ! strings to erase arrow ! erase(1)=esc//'[05;06H ' erase(2)=esc//'[06;06H ' erase(3)=esc//'[07;06H ' erase(4)=esc//'[08;06H ' erase(5)=esc//'[09;06H ' erase(6)=esc//'[10;06H ' erase(7)=esc//'[11;06H ' erase(8)=esc//'[12;06H ' erase(9)=esc//'[13;06H ' erase(10)=esc//'[14;06H ' erase(11)=esc//'[15;06H ' erase(12)=esc//'[16;06H ' erase(13)=esc//'[17;06H ' erase(14)=esc//'[18;06H ' erase(15)=esc//'[19;06H ' ! ! Display the headings, etc. if REPAINT was requested ! if ( ir .eq. 1 ) call draw_frame if ( no_choices .gt. 15 ) no_choices = 15 ! ! center the heading string and put it out ! call str$trim (prompt_string(1),prompt_string(1),icount) iposition = (40 - icount)/2 3 format('+',A,'[2;6H',A,'[1m',(' '),a,A,'[0m',$) write (6,3) esc,esc,prompt_string(1)(1:icount),esc ! ! Display the Calander, etc. depending ! upon the contents of (ir) ! call draw_box(ir) ! ! Display the Menu choices ! 4 format('+',a,'[',i2.2,';05H',' ',a,'[1m',a,a,'[0m - ',a,$) icode = 65 do i = 2,no_choices+1 write (6,4) esc,i+3,esc,char(icode),esc,prompt_string(i)(1:36) icode = icode + 1 enddo ! ! blank out empties ! do i = no_choices+2,17 write (6,4098) esc,i+3 4098 format('+',a,'[',i2.2,';05H',45(' '),$) enddo ! ! Allow them to move the -> to the option of their choice ! 5 format('+',A,$) ifield = 1 ! ! 900 write (6,5) where(ifield) call get_term(prompt_string,no_choices,irtn) ! ! check for a return ! if ( irtn .eq. 0 ) go to 990 ! ! check for a move down ! if (irtn .eq. 2) then write (6,5) erase(ifield) ifield = ifield + 1 if (ifield .gt. no_choices) then ifield = ifield - 1 endif go to 900 endif ! ! check for a move up ! if (irtn .eq. 1) then write (6,5) erase(ifield) ifield = ifield - 1 if (ifield .lt. 1) then ifield = ifield + 1 endif go to 900 endif ! ! check for a code character ! if ((irtn - 64) .gt. no_choices) go to 900 write (6,5) erase(ifield) ifield = irtn - 64 write (6,5) where(ifield) call lib$wait (2.) ! ! let them have control of the thing ! 990 ireturn_code = ifield return end C ----------------------------------------------------------- C Subroutine : Draw_Box C C Draws Calender C subroutine draw_box (ir) implicit integer (a-z) character esc*1 character daytime*23 integer*4 days_month(12) data days_month /31,28,31,30,31,30,31,31,30,31,30,31/ data esc /27/ ! ! Skip most of the drawing if NO-REPAINT is selected ! if (ir .ne. 1) go to 4123 ! ! draw the calendar ! 30 ida = sys$asctim (,daytime,,) read (daytime(1:2),'(i2)') ipresent_day ! ! get integer values for date ! call idate (imonth,idom,iyear) ! ! find out if this is a leap year ! ix = iyear/4 if ( (ix*4) .eq. iyear) then days_month(2) = 29 else days_month(2) = 28 endif ! ! calculate the day of the week for the first day of the month ! imm = imonth idom = 1 icent = 19 ! ! check if january or february (if so change year to last year) ! imonth = imonth - 2 if (imonth .lt. 1) then imonth = imonth + 12 iyear = iyear - 1 endif ! ! now do the calculation ! it1 = (26 * imonth - 2)/10 it2 = (iyear/4) it3 = (icent/4) it4 = it1 + it2 + it3 + idom + iyear - (2 * icent) if (it4 .lt. 0) then it4 = it4 + 196 endif it5 = it4/7 idown = it4 - (it5 *7) + 1 ! ! idown now contains the number(1-7) for the day of the week for ! the first day of the month------now draw the calendar on the screen ! write (6,100) esc,esc,esc,esc write (6,101) write (6,102) esc,esc,daytime(4:6),daytime(10:11),esc write (6,103) esc write (6,104) esc write (6,105) esc write (6,106) esc,esc write (6,107) esc,esc write (6,108) esc,esc write (6,109) esc,esc write (6,110) esc,esc write (6,111) esc,esc write (6,112) esc 100 format ('+',a,'7',a,'(0',a,'[1m',a,'[5;50H',$) 101 format ('+','lqqqqqqqqqqqqqqqqqqqqqk',$) 102 format ('+',a,'[6;50Hx',a,'[6;58H',a,' ',a,a,'[6;72Hx',$) 103 format ('+',a,'[7;50Htqqqqqqqqqqqqqqqqqqqqqu',$) 104 format ('+',a,'[8;50Hx S M T W T F S x',$) 105 format ('+',a,'[9;50Htqqqqqqqqqqqqqqqqqqqqqu',$) 106 format ('+',a,'[10;50Hx',a,'[10;72Hx',$) 107 format ('+',a,'[11;50Hx',a,'[11;72Hx',$) 108 format ('+',a,'[12;50Hx',a,'[12;72Hx',$) 109 format ('+',a,'[13;50Hx',a,'[13;72Hx',$) 110 format ('+',a,'[14;50Hx',a,'[14;72Hx',$) 111 format ('+',a,'[15;50Hx',a,'[15;72Hx',$) 112 format ('+',a,'[16;50Hmqqqqqqqqqqqqqqqqqqqqqj',$) ! ! now fill in the days of the month ! icol = (idown - 1) * 3 + 51 irow = 10 write (6,113) esc,icol 113 format ('+',a,'[10;',i2,'H',$) do i=1,days_month(imm) if (i .eq. ipresent_day) then write (6,116) esc,i,esc else write (6,114) i endif idown = idown + 1 if (idown .gt. 7) then idown = 1 irow = irow + 1 write (6,115) esc,irow endif enddo 114 format ('+',i2,' ',$) 115 format ('+',a,'[',i2,';51H',$) 116 format ('+',a,'[5;7m',i2,a,'[0;1m ',$) ! ! reset the terminal as needed ! 4123 write (6,117) esc,esc,esc 117 format ('+',a,'[0m',a,'(B',a,'8',$) ! ! show the current time ! call ast ! return end C ----------------------------------------------------------- C Subroutine : Draw_Frame C C Displays the frame for the menu C subroutine draw_frame character*80 dummy character esc*1 character line19*15 data esc /27/ data line19 /' for HELP'/ dummy = ' ' ! 1 format('+',a,'[2J',a,'[0;0H',a,'[7m',a,a,'[0m') 2 format(' ',a,'[7m',a,a,'[0m',a,a,'[7m',a,a,'[0m') 3 format(' ',a,'[7m',a,a,'[0m') 4 format('+',a,'[7m',a,'[',i2.2,';',i2.2,'H',a,a,'[0m',$) 19 format('+',a,'[19;54H',a,'[1;7m',a,a,'[0m',$) C C paint the top of the screen C write (6,1) esc,esc,esc,dummy,esc write (6,2) esc,dummy(1:5),esc,dummy(1:40),esc,dummy(1:35),esc write (6,3) esc,dummy,esc C C paint the Help notice C write (6,19) esc,esc,line19,esc return end C ----------------------------------------------------------- C Subroutine : Get_Term C C C C Reads TAB, BACKSPACE, DOWN_ARROW, UP_ARROW C RETURN and HELP keys from keyboard C passes back the following codes C C TAB 2 C DOWN_ARROW 2 C UP_ARROW 1 C BACKSPACE 1 C RETURN 0 C C A negative return value indicates that the C arrow should be positioned at a certain line C C Displays Help Frame if HELP requested C subroutine get_term (string,no_choices,ireturn_code) implicit integer (a-z) integer*4 iend(2) integer*2 iosb(4) character tab*1 character backspace*1 character delete*1 character cr*1 character esc*1 character input_string*5 character line21*60 character line22*60 character line23*60 character line24*60 byte iterm(32) data line21/'Directions: Using the up and down arrow keys place the'/ data line22/' -> next to your choice and press ;'/ data line23/' or enter the code character next to your '/ data line24/' choice'/ data esc /27/ data delete /'7f'x/ data cr /13/ data tab /9/ data backspace /8/ include '($iodef)' C C C set up the terminating character array--no terminators C iend(1) = '20'x iend(2) = %loc (iterm) do i=1,32 iterm(i) = 0 enddo C C position the cursor C write (6,3) esc 3 format ('+',a,'[20;1H',$) C C assign an io channel C if (ichan .eq. 0) call sys$assign ('sys$output',ichan,,) C C purge the typeahead buffer C 10 call sys$qiow (,%val(ichan),%val(io$_readvblk+io$m_purge),,,,,,,,,) C C read one character C 12 call sys$qio (%val(0) 1 ,%val(ichan) 2 ,%val(io$_ttyreadall+io$m_noecho+io$m_timed) 3 ,iosb 4 , 5 , 6 ,%ref(input_string) 7 ,%val(1) 8 ,%val(5) 9 ,%ref(iend),,) call sys$waitfr (%val(0)) C if (iosb(1) .eq. 556) then call ast go to 12 endif C C see if we have a one character code C if (input_string(1:1) .eq. cr) then ireturn_code = 0 go to 1000 endif C if (input_string(1:1) .eq. tab) then ireturn_code = 2 go to 1000 endif C if (input_string(1:1) .eq. backspace) then ireturn_code = 1 go to 1000 endif C C check for escape sequence C if (input_string(1:1) .eq. esc) then call sys$qio (%val(0) 1 ,%val(ichan) 2 ,%val(io$_ttyreadall+io$m_noecho) 3 ,iosb 4 , 5 , 6 ,%ref(input_string(2:3)) 7 ,%val(2) 8 , 9 ,%ref(iend),,) call sys$waitfr (%val(0)) C C decipher the escape sequence C if (input_string(2:3) .eq. '[A') then ireturn_code = 1 go to 1000 endif C if (input_string(2:3) .eq. 'OA') then ireturn_code = 1 go to 1000 endif C if (input_string(2:3) .eq. '[B') then ireturn_code = 2 go to 1000 endif C if (input_string(2:3) .eq. 'OB') then ireturn_code = 2 go to 1000 endif C C See if they requested the help block C if (input_string(2:3) .eq. 'OQ') then write (6,50) esc,esc,line21 write (6,51) esc,line22 write (6,52)esc,line23 write (6,53) esc,line24,esc 50 format ('+',a,'[21;10H',a,'[7m',a,$) 51 format ('+',a,'[22;10H',a,$) 52 format ('+',a,'[23;10H',a,$) 53 format ('+',a,'[24;10H',a,a,'[0m',$) go to 10 endif endif C C let us hope they chose a code letter C ireturn_code = ichar(input_string(1:1)) if (ireturn_code .gt. 90) ireturn_code = ireturn_code - 32 if (ireturn_code .lt. 65) go to 10 C C 1000 write (6,4004) esc,esc 4004 format ('+',a,'[20;1H',a,'[K',$) write (6,3) esc return end C ----------------------------------------------------------- C Subroutine : Ast C C Displays Current Time C subroutine ast character tim*9 character esc*1 data esc /27/ data bell /7/ C C call time(tim) 4 format('+',a,'7',$) write (6,4) esc call lib$put_screen(tim(1:8),2,57,1) 6 format('+',a,'8',$) write (6,6) esc return end