function dix_mode_demo(control) implicit none c c This program will accept a filename and start dispalying data c from that file c include 'dix_def.inc' include 'dix_screen_def.inc' include 'dix_demo_def.inc' record /control/ control integer*4 dix_mode_demo c character*255 line,header integer*4 istat,nk,nk_header,choise,dis_id_demo,row integer*4 lun_mem,nrec,max_len,col,lbr_index,lun_data logical*4 do_header,screen_name,seen_one record /smg/ smg character*(demo_name_length) start_screen record /screen_data/ screen_data c integer*4 cli$present integer*4 dix_demo_get_list integer*4 dix_demo_select external dix_msg_filnotop integer*4 dix_util_get_len_fu integer*4 dix_demo_process_data integer*4 dix_demo_get_file c include '($smgdef)' external dix_msg_nodemof external dix_msg_nodemos c c Now display c call get_pasteboard(control) call smg$create_virtual_keyboard(control.keyboard_id) call smg$erase_pasteboard(control.paste_id) c control.smg_window = 1 !force use of smg for messages c control.use_mouse = cli$present('use_mouse') c dis_id_demo = 0 do_header = cli$present('header') screen_name = cli$present('screenname') c smg.uppercase = cli$present('uppercase') call cli$get_value('p2',start_screen) if(start_screen .eq. ' ') start_screen = 'MAIN' seen_one = .false. c c c GEt a list of valid files c call cli$get_value('file',line,nk) c if(line .ne. ' ') then istat = dix_demo_get_file(control,line(1:nk),lun_data,header) if(.not. istat) goto 90 nrec = 1 lun_mem = 0 max_len = dix_util_get_len_fu(header) goto 14 endif c call cli$get_value('p1',line,nk) if(nk .eq. 0) call sys$fao('*',nk,line) c istat = dix_demo_get_list(control,line(1:nk), 1 lun_mem,nrec, 1 max_len,lbr_index) c if(.not. istat) goto 90 c if(nrec .eq. 0) then istat = %loc(dix_msg_nodemof) goto 90 endif c c Display info screen c call dix_demo_info(control,dis_id_demo,row) c choise = 1 c 10 istat = dix_demo_select(control,lun_mem, 1 nrec,lbr_index,max_len, 1 header, 1 lun_data,choise,row) if(.not. istat) goto 90 c if(lun_data .eq. 0) goto 90 c c Open the file, and start processing it c 14 seen_one = .true. if(do_header) then c c User wants header c call smg$create_virtual_display(1,control.ncols,smg.dis_hdr,, 1 smg$m_underline) nk_header = min(dix_util_get_len_fu(header),control.ncols-10) col = (control.ncols-nk_header)/2 if(col+ nk_header .gt. control.ncols-20) col = 1 call smg$put_chars(smg.dis_hdr,header(1:nk_header), 1 1,col,smg$m_reverse .or. smg$m_underline) call smg$paste_virtual_display(smg.dis_hdr,control.paste_id,1,1) screen_data.disp_nrows = control.nrows-1 screen_data.paste_row = 2 smg.screenname = screen_name else screen_data.disp_nrows = control.nrows screen_data.paste_row = 1 smg.dis_hdr = 0 smg.screenname = .false. endif c screen_data.disp_ncols = control.ncols c screen_data.row_offset = 1 screen_data.col_offset = 1 screen_data.paste_col = 1 screen_data.nlines = screen_data.disp_nrows screen_data.ncols = screen_data.disp_ncols c screen_data.view_nrows = screen_data.disp_nrows screen_data.view_ncols = screen_data.disp_ncols call smg$create_virtual_display( 1 screen_data.disp_nrows, 1 screen_data.disp_ncols, 1 smg.dis_id) call smg$paste_virtual_display(smg.dis_id,control.paste_id, 1 screen_data.paste_row,screen_data.paste_col) c call smg$create_viewport(smg.dis_id, 1 screen_data.row_offset,screen_data.col_offset, 1 screen_data.view_nrows,screen_data.view_ncols) c c istat = dix_demo_process_data(control,smg, 1 lun_data,start_screen, 1 screen_data,line) call memtab_close(control,lun_data) call smg$delete_virtual_display(smg.dis_id) if(smg.dis_hdr .ne. 0) call smg$delete_virtual_display(smg.dis_hdr) if(.not. istat) goto 82 goto 85 c c Some error in process_data, or demo_get_file c 82 nk = dix_util_get_len_fu(line) c call dix_message(control,%val(istat),line(1:nk)) c c Try again (if there is more than one file) c 85 if(nrec .gt. 1) goto 10 istat = 1 c if(lun_mem .ne. 0) call memtab_close(control,lun_mem) c 90 if(.not. seen_one) then call dix_message(control,dix_msg_nodemos) endif if(dis_id_demo .ne. 0) call smg$delete_virtual_display(dis_id_demo) c control.mode = mode_none dix_mode_demo = istat return end function dix_demo_process_data(control,smg, 1 lun_data,start_screen,screen_data,line) implicit none c include 'dix_def.inc' include 'dix_screen_def.inc' include 'dix_demo_def.inc' record /control/ control record /smg/ smg integer*4 lun_data !:i: the memory table character*(*) start_screen record /screen_data/ screen_data character*(*) line integer*4 dix_demo_process_data c include '($smgdef)' c integer*4 istat,idx,key,nk logical*4 dix_demo_display_data record /screen/ screen character*(demo_name_length) name character*(demo_name_length) screen_name c integer*4 dix_util_get_len c name = start_screen 10 istat = dix_demo_display_data(control,name,screen,smg,lun_data, 1 screen_data,line) if(.not. istat) goto 90 c screen_data.row_offset = 1 screen_data.col_offset = 1 c c Set the viewport back to upper left c call smg$change_viewport(smg.dis_id, 1 screen_data.row_offset,screen_data.col_offset, 1 screen_data.view_nrows,screen_data.view_ncols) c if(smg.screenname) then c c If we have a header, display the screen name now c nk = dix_util_get_len(screen.name) call smg$put_chars(smg.dis_hdr,name,1,control.ncols-nk+1) endif c screen_data.row = 1 screen_data.col = 1 c c 20 call dix_smg_set_Scroll(smg.dis_id,0,screen_data,1,1) call dix_demo_get_key(control,smg,screen,idx,lun_Data,screen_name) c if(screen_name .ne. ' ') then c c USer pointed to a name in the index window c name = screen_name goto 12 endif c c User selected none c if(idx .eq. 0) goto 90 c if(screen.keys(idx).internal) then key = screen.keys(idx).key if(key .eq. key_left) then screen_data.col = screen_data.col + 1 elseif(key .eq. key_right) then screen_data.col = screen_data.col - 1 elseif(key .eq. key_up) then screen_data.row = screen_data.row - 1 elseif(key .eq. key_down) then screen_data.row = screen_data.row + 1 endif goto 20 endif c c CLear the old module name c name = screen.keys(idx).screen 12 if(smg.screenname) then screen_name = ' ' call smg$put_chars(smg.dis_hdr,screen_name,1, 1 control.ncols-nk+1) endif goto 10 90 dix_demo_process_data = istat return end function dix_demo_display_data(control,name, 1 screen,smg,lun_data,screen_data,errline) implicit none c include 'dix_def.inc' include 'dix_screen_def.inc' include 'dix_demo_def.inc' record /control/ control character*(*) name record /screen/ screen integer*4 lun_data record /smg/ smg record /screen_data/ screen_data character*(*) errline logical*4 dix_demo_display_data c character*255 line,orgline,work,desfilename character*10 token,cmnd character*(demo_name_length) s_name integer*4 nk,row,ipos,video,key,col,istat,nk1,bpos,jpos,k,l,nb integer*4 xrow1,xrow2,xcol1,xcol2,offset,kpl,fldsiz,posasc,nl logical*4 gotit,whole,compress,in_ascii,has_fields logical*4 got_enter,got_back,got_left,got_right,got_up,got_down character*6 mode c include '($smgdef)' include '($rabdef)' c record /file_info/ file record /dis_pars/ dis record /rabdef/ rab record /key_info/ key_info c external dix_msg_formnotf external dix_msg_errcmnd c integer*4 keydefs_function_name_to_code integer*4 str$find_first_in_set integer*4 memtab_read c file.rabadr = %loc(rab) c call memtab_rewind(lun_data) call smg$erase_display(smg.dis_id) row = 1 col = 1 screen.gotmsg = .false. screen.n_keys = 0 screen.context = ' ' screen.linenr = 0 gotit = .false. video = 0 whole = .false. screen.row_cursor = 0 screen.col_cursor = 0 screen.prev_name = ' ' got_back = .false. got_left = .false. got_right = .false. got_up = .false. got_down = .false. got_enter = .false. screen_data.nlines = 0 screen_data.ncols = 0 c file.rec_nr = 1 file.got_record = .true. file.data.nb_data = 0 file.nk_fnam = 0 desfilename = ' ' offset =0 dis.number = .true. dis.word = 4 dis.number_hex = .false. dis.unsigned = .true. dis.hex = des_flag_translate_hex key_info.keyidx = 0 key_info.nsegment = 1 has_fields = .false. do k=1,8 key_info.keypos(k) = 0 key_info.keysiz(k) = 0 end do key_info.link.forw = 0 key_info.link.backw = 0 compress = .false. c file.ptr_keyinfo = %loc(key_info) c 10 istat = memtab_read(lun_data,nk,line) if(.not. istat) then c c EOF c istat = 1 goto 90 endif c if(line(1:1) .eq. '#') then if(line(2:nk) .eq. ' ') goto 10 !ignore c c Command c orgline = line call str$upcase(line,line(1:nk)) ipos = index(line,':') if(ipos .eq. 0) goto 50 token = line(2:ipos-1) line = line(ipos+1:) nk = nk - ipos if(token(1:2) .eq. 'HD' .or. token(1:2) .eq. 'CH') then c c Ignore the header and chapter fields c endif if(token(1:2) .eq. 'PA') then c c Paramter info c format PA:what:value c jpos = index(line,':') if(jpos .eq. 0) goto 50 cmnd = line(1:jpos-1) line = line(jpos+1:) nk = nk - jpos if(cmnd(1:2) .eq. 'FI') then c c Filename c file.fnam = line(1:nk) file.nk_fnam = nk elseif(cmnd(1:2) .eq. 'DA') then c c Data, value is a list of hex values c file.data.nb_data = 0 do while(nk .gt. 0) jpos = index(line,',') if(jpos .eq. 0) jpos = nk + 1 read(line(1:jpos-1),2030,err=50) l 2030 format(z8) nb = (jpos-1)/2 call lib$movc3(nb,l,file.data.data_rec(file.data.nb_data+1)) file.data.nb_data = file.data.nb_data + nb line = line(jpos+1:) nk = nk - jpos end do elseif(cmnd(1:2) .eq. 'HF') then c c Has fields value : y/n c has_fields =line(1:1) .eq.'Y' elseif(cmnd(1:2) .eq. 'RS') then c c Force recordlength setting c read(line(1:nk),2001,err=50) file.data.nb_data c elseif(cmnd(1:2) .eq. 'RT') then c c ecord type fixed/variab c file.fixed =line(1:1) .eq.'F' elseif(cmnd(1:2) .eq. 'AS') then c c In_ascii part y/n c in_Ascii = line(1:1) .eq. 'Y' elseif(cmnd(1:2) .eq. 'FT') then c c File type, value I/R/S c file.indexed = line(1:1) .eq. 'I' file.relative = line(1:1) .eq. 'R' elseif(cmnd(1:2) .eq. 'SI') then c c Signed/unsigned flag c dis.unsigned = line(1:1) .ne. 'S' elseif(cmnd(1:2) .eq. 'NH') then c c Toggle number hex parameter Value Y/n c dis.number_hex = line(1:1) .eq. 'Y' elseif(cmnd(1:2) .eq. 'KE') then c c Key value offset,length c jpos = index(line,',') if(jpos .eq. 0) goto 90 read(line(1:jpos-1),2001,err=50) key_info.keypos(1) read(line(jpos+1:nk),2001,err=50) key_info.keysiz(1) elseif(cmnd(1:2) .eq. 'OF') then c c Offset value byte[.bit] c jpos = index(line(1:nk),'.') if(jpos .eq. 0) then read(line(1:nk),2001,err=50) k l = 0 else read(line(1:jpos-1),2001,err=50) k read(line(jpos+1:nk),2001,err=50) l if(l .ge. bits_per_byte) goto 50 endif offset = k*bits_per_byte + l elseif(cmnd(1:2) .eq. 'WO') then c c WOrd size : value 1,2,4 c read(line(1:nk),2001,err=50) k if(k .ne. 1 .and. k .ne. 2 .and. k .ne.4) goto 50 dis.word = k elseif(cmnd(1:2) .eq. 'MO') then c c Mode : Hex,BIn,Dec,Oct c dis.hex = des_flag_translate_nor if(line(1:1) .eq. 'H') dis.hex = des_flag_translate_hex if(line(1:1) .eq. 'O') dis.hex = des_flag_translate_oct if(line(1:1) .eq. 'B') dis.hex = des_flag_translate_bin elseif(cmnd(1:2) .eq. 'DE') then c c Description filename c desfilename = line(1:nk) elseif(cmnd(1:2) .eq. 'CO') then c c Compress mode value Y/n c compress = line(1:1) .eq. 'Y' elseif(cmnd(1:2) .eq. 'RE') then read(line(1:nk),2001,err=50) file.rec_nr elseif(cmnd(1:2) .eq. 'RF') then c c RFa value block,byte c jpos = index(line,',') if(jpos .eq. 0) goto 50 read(line(1:jpos-1),2001,err=50) rab.rab$l_rfa0 read(line(jpos+1:nk),2001,err=50) rab.rab$w_rfa4 endif endif if(token(1:2) .eq. 'CO') then call str$upcase(screen.context,line) endif if(token(1:2) .eq. 'SC') then ipos = index(line(1:nk),':') if(ipos .ne. 0) nk = ipos - 1 if(gotit) then screen.next_name = line(1:nk) goto 90 endif c c See if it is the wanted one c if(line(1:nk) .eq. name) then c c It is the one, so rememeber it c gotit = .true. screen.name = line(1:nk) else c c Not yet, remember the previous c screen.prev_name = line(1:nk) endif endif c c Now check if we are in a valid screen c if(.not. gotit) goto 10 c if(token(1:2) .eq. 'HX') then c c Display the header c control.dis_kop = smg.dis_id call dix_dump_screen_display_hdr_1(control,file) call dix_dump_screen_display_hdr_2(control,file,dis) if(desfilename .eq. ' ') then if(dis.hex .eq. des_flag_translate_hex) then mode = 'Hex' elseif(dis.hex .eq. des_flag_translate_oct) then mode = 'Oct' elseif(dis.hex .eq. des_flag_translate_bin) then mode = 'Bin' else if(dis.unsigned) then mode = 'Unsign' else mode = 'Signed' endif endif call dix_dump_vars(control,dis,kpl,fldsiz,posasc) call dix_dump_create_header3(line,nk,kpl,fldsiz, 1 dis,posasc) line(nk+1:) = ' ' call smg$put_chars(control.dis_kop,line,3,1,, 1 smg$m_reverse) else mode = 'Norm' if(compress) mode = 'Comprs' call smg$put_chars(control.dis_kop,'Des file :',3,1,, 1 smg$m_reverse) call smg$put_chars(control.dis_kop,desfilename,3,11,, 1 smg$m_reverse .or. smg$m_bold) endif c c Add the mode c call smg$put_chars(control.dis_kop,mode(1:6),2,34,, 1 smg$m_bold .or. smg$m_reverse) c c call dix_dump_screen_dis_count(offset,dis.number_hex, 1 control.dis_kop,2,20,has_fields,6,control) row = 4 col = 1 elseif(token(1:2) .eq. 'DA') then c c Display the data c nl = (file.data.nb_data+kpl-1)/kpl do k=1,nl call dix_dump_screen_raw_line(control,smg.dis_id,k,kpl, 1 file,dis,posasc,fldsiz,.false.,3) end do c c Now we van get the default cursor start c call dix_dump_get_coord(offset,in_ascii,dis,kpl,posasc, 1 fldsiz,screen.row_cursor,screen.col_cursor) screen.row_cursor = screen.row_cursor + 3 row = nl + 5 col = 1 elseif(token(1:2) .eq. 'ME') then screen.gotmsg = .true. xrow1 = screen_data.view_nrows-1 xrow2 = screen_data.view_nrows xcol1 = screen_data.view_ncols-nk xcol2 = screen_data.view_ncols call smg$draw_line(smg.dis_id,xrow1,xcol1,xrow1,xcol2) call smg$draw_line(smg.dis_id,xrow1,xcol1,xrow2,xcol1) call smg$put_chars(smg.dis_id,orgline(ipos+1:ipos+nk), 1 xrow2,xcol1+1,,smg$m_bold) call smg$put_chars(smg.dis_id,'Messages',xrow1, 1 (xcol1+xcol2)/2-4) endif if(token(1:2) .eq. 'QU') then xrow1 = screen_data.view_nrows-4 xrow2 = screen_data.view_nrows-2 xcol1 = 1 xcol2 = nk+1 call smg$draw_line(smg.dis_id,xrow1,xcol1,xrow1,xcol2) call smg$draw_line(smg.dis_id,xrow1,xcol2,xrow2,xcol2) call smg$draw_line(smg.dis_id,xrow2,xcol1,xrow2,xcol2) call smg$put_chars(smg.dis_id,orgline(ipos+1:ipos+nk), 1 xrow1+1,xcol1) call smg$put_chars(smg.dis_id,'Questions-answers',xrow1, 1 (xcol1+xcol2)/2-6) endif if(token(1:2) .eq. 'KP') then read(line(1:nk),2001,err=50) bpos 2001 format(i10) screen.linenr = bpos endif c if(token(1:2) .eq. 'DH') then ipos = index(line(1:nk),',') if(ipos .ne. 0) then read(line(1:ipos-1),2001,err=50) xrow1 line = line(ipos+1:nk) nk = nk - ipos ipos = index(line(1:nk),',') if(ipos .ne. 0) then read(line(1:ipos-1),2001,err=50) xcol1 read(line(ipos+1:nk),2001,err=50)xcol2 call smg$draw_line(smg.dis_id,xrow1,xcol1,xrow1,xcol2) endif endif endif if(token(1:2) .eq. 'DV') then ipos = index(line(1:nk),',') if(ipos .ne. 0) then read(line(1:ipos-1),2001,err=50) xrow1 line = line(ipos+1:nk) nk = nk - ipos ipos = index(line(1:nk),',') if(ipos .ne. 0) then read(line(1:ipos-1),2001,err=50) xcol1 read(line(ipos+1:nk),2001,err=50) xrow2 call smg$draw_line(smg.dis_id,xrow1,xcol1,xrow2,xcol1) endif endif endif if(token(1:2) .eq. 'VI') then video = 0 whole = .false. if(index(line(1:nk),'B') .ne. 0) video = video .or. smg$m_bold if(index(line(1:nk),'R') .ne. 0) video = video .or. smg$m_reverse if(index(line(1:nk),'U') .ne. 0) video = video .or. smg$m_underline if(index(line(1:nk),'W') .ne. 0) whole = .true. elseif(token(1:2) .eq. 'CU') then ipos = index(line(1:nk),',') if(ipos .eq. 0) goto 50 read(line( 1:ipos-1),2010,err=50) screen.row_cursor read(line(ipos+1:nk ),2010,err=50) screen.col_cursor 2010 format(i4) elseif(token(1:2) .eq. 'PO') then ipos = index(line(1:nk),',') if(ipos .eq. 0) goto 50 read(line( 1:ipos-1),2010,err=50) row read(line(ipos+1:nk ),2010,err=50) col elseif(token(1:2) .eq. 'KE') then ipos = index(line(1:nk),':') if(ipos .eq. 0) goto 50 !ignore line s_name = line(ipos+1:nk) if(.not. keydefs_function_name_to_code(line(1:ipos-1),key, 1 control.key_table)) then if(.not. keydefs_function_name_to_code( 1 'key_'//line(1:ipos-1),key, 1 control.key_table)) then if(ipos .eq. 2) then c c A singlue character, means the key itself c key = ichar(line(1:1)) else goto 50 endif endif endif c call dix_demo_add_key(screen,key,.false.,s_name) c if(key .eq. key_up) got_up = .true. if(key .eq. key_down) got_down = .true. if(key .eq. key_left) got_left = .true. if(key .eq. key_right) got_right= .true. if(key .eq. key_prev) got_back = .true. if(key .eq. key_enter) got_enter= .true. c endif else if(gotit) then if(whole) nk = control.ncols - col + 1 if(row .gt. screen_data.disp_nrows) then screen_data.disp_nrows = row call smg$change_virtual_display(smg.dis_id, 1 screen_data.disp_nrows) endif if(col+nk-1 .gt. screen_data.disp_ncols) then screen_data.disp_ncols = col+nk-1 call smg$change_virtual_display(smg.dis_id,, 1 screen_data.disp_ncols) endif c c Now replace the #keyname to the real keyname c bpos = 1 63 ipos = index(line(bpos:nk),'#') if(ipos .ne. 0) then ipos = ipos + bpos jpos = str$find_first_in_set(line(ipos:nk),', .()') if(jpos .eq. 0) then jpos = nk-1 else jpos = jpos+ipos-2 endif c c See if valid key name c if(.not. keydefs_function_name_to_code(line(ipos:jpos),key, 1 control.key_table)) then if(.not. keydefs_function_name_to_code( 1 'key_'//line(ipos:jpos),key, 1 control.key_table)) goto 64 c c Now we keve a valid keycode c endif call keydefs_get_map(key,control,nk1,work, 1 screen.context) line(ipos-1:) = work(1:nk1)//line(jpos+1:nk) nk = nk + nk1 - jpos + ipos - 2 64 bpos = ipos+nk1 goto 63 endif call smg$put_chars(smg.dis_id,line(1:nk),row,col,,video) if(row .gt. screen_data.nlines) screen_data.nlines = row if(row+nk-1 .gt. screen_data.ncols) screen_data.ncols = col+nk-1 row = row + 1 col = 1 endif endif goto 10 50 call dix_message(control,dix_msg_errcmnd,orgline(1:nk)) goto 10 c 90 if(gotit) then errline = ' ' if(.not. got_enter .and. screen.next_name .ne. ' ') then call dix_demo_add_key(screen,key_enter,.false., 1 screen.next_name) endif if(.not. got_back .and. screen.prev_name .ne. ' ') then call dix_demo_add_key(screen,key_prev,.false.,screen.prev_name) endif if(screen_data.nlines .gt. screen_data.view_nrows) then if(.not. got_up) then call dix_demo_add_key(screen,key_up,.true.,' ') endif if(.not. got_down) then call dix_demo_add_key(screen,key_down,.true.,' ') endif endif if(screen_data.ncols .gt. screen_data.view_ncols) then if(.not. got_left) then call dix_demo_add_key(screen,key_left,.true.,' ') endif if(.not. got_right) then call dix_demo_add_key(screen,key_right,.true.,' ') endif endif istat = 1 else istat = %loc(dix_msg_formnotf) errline = name endif dix_demo_display_data = istat return end subroutine dix_demo_add_key(screen,key,internal,screen_name) implicit none c c Add a key to the keytable c include 'dix_demo_def.inc' record /screen/ screen integer*4 key logical*4 internal character*(*) screen_name c screen.n_keys = screen.n_keys + 1 screen.keys(screen.n_keys).key = key screen.keys(screen.n_keys).internal = internal screen.keys(screen.n_keys).screen = screen_name c return end subroutine dix_demo_get_key(control,smg,screen,idx, 1 lun_data,screen_name) implicit none c include 'dix_def.inc' include 'dix_demo_def.inc' include '($smgdef)' record /control/ control !:i: control block record /smg/ smg !:i: smg control block record /screen/ screen !:i: screen data integer*4 lun_data !:i: the memory file with the texts integer*4 idx !:o: the 'idx'key was hit character*(*) screen_name !:o: user selected a screen name via ! the index function c character*80 line character dix_util_upcase_kar integer*4 nk,k,key,dis_key,phase,maxl,row,col,dis_hlp character*(*) std_key parameter (std_key = 'H(elp),I(ndex)') c external dix_msg_illkey c maxl = len(std_key) c do phase=1,2 do k=1,screen.n_keys if(screen.keys(k).key .gt. 0) then line = char(screen.keys(k).key) nk = 1 else call keydefs_get_map(screen.keys(k).key,control, 1 nk,line,screen.context) endif if(phase .eq. 1) then maxl = max(maxl,nk) else call smg$put_chars(dis_key,line(1:nk),k,1) endif end do c c Now create the key window c if(phase .eq. 1) then call smg$create_virtual_display(screen.n_keys+1,maxl,dis_key) row = screen.linenr if(row .eq. 0) then if(screen.gotmsg) then row = control.nrows-screen.n_keys-3 else row = control.nrows-screen.n_keys-1 endif endif call smg$paste_virtual_display(dis_key,control.paste_id, 1 row,control.ncols-maxl) call smg$label_border(dis_key,'KEYES') call smg$put_chars(dis_key,std_key,screen.n_keys+1,1) endif end do c if(screen.row_cursor .ne. 0 .and. screen.col_cursor .ne. 0) then call smg$set_cursor_abs(smg.dis_id,screen.row_cursor, 1 screen.col_cursor) endif c screen_name = ' ' c 10 call dix_get_key(control,key,row,col,screen.context) c if(key .gt. 0) then if(smg.uppercase) then key = ichar(dix_util_upcase_kar(char(key))) endif endif c c if(key .eq. smg$k_trm_uppercase_h) then call smg$create_virtual_display(5,50,dis_hlp) call smg$put_chars(dis_hlp, 1 'You can type one of the key in the KEYES display',1,1) call smg$put_chars(dis_hlp, 1 ' Type H to get help (you just did it)',2,1) call smg$put_chars(dis_hlp, 1 ' Type I to get a list of screens',3,1) call keydefs_get_map(key_Exit,control,nk,line,' ') call smg$put_chars(dis_hlp,' Type '//line(1:nk)//' to quit',4,1) call smg$put_chars(dis_hlp, 1 ' Hit any key to cancel this help',5,1) call smg$label_border(dis_hlp,'HELP') call smg$paste_virtual_display(dis_hlp,control.paste_id,2,2) call dix_get_key(control,k,k,k,' ') call smg$delete_virtual_display(dis_hlp) goto 10 endif if(key .eq. smg$k_trm_uppercase_i) then c c DIsplay index, and let the user select a screen c call dix_demo_display_index(control,lun_data,screen_name) if(screen_name .ne. ' ') goto 90 goto 10 endif do k=1,screen.n_keys if(screen.keys(k).key .eq. key) then idx = k goto 90 endif end do c c Abort key, so exit c if(key .eq. key_exit .or. key .eq. key_abort) then idx = 0 goto 90 endif c c Key not found, signal message c call keydefs_function_to_name(control,key,line,nk) call dix_message(control,dix_msg_illkey,line(1:nk)) goto 10 90 call smg$delete_virtual_display(dis_key) return end function dix_demo_get_list(control,mask,lun_mem,nrec,max_len, 1 lbr_index) implicit none c include 'dix_def.inc' include '($jpidef)' include 'dix_screen_def.inc' c record /control/ control character*(*) mask !:I: selection mask integer*4 lun_mem !:o: mem table integer*4 nrec !:o: Count of record integer*4 max_len !:o: max lenght of name integer*4 lbr_index !:o: library index integer*4 dix_demo_get_list !:f: function result c include '($lbrdef)' c integer*4 ctx,istat,bpos,epos,nk_k,nk_hd,rfa(2),descr(2),nk_i,ipos character*(255) line,imagname,header,key c c integer*4 lun_memtab,p_c_control common /dix_demo_get/ lun_memtab,p_c_control c logical*4 dix_util_match_string_wild external dix_msg_nodemos external dix_demo_get_index integer*4 lbr$ini_control integer*4 lbr$open integer*4 lbr$lookup_key integer*4 lbr$get_record integer*4 lbr$get_index integer*4 memtab_read c call memtab_init(control,lun_mem,'MEM_DEMO') ctx = 0 nrec = 0 max_len = 0 c c Get all .dix_demo files in this directory c istat = lbr$ini_control(lbr_index,lbr$c_read,lbr$c_typ_txt) if(istat) then call lib$getjpi(jpi$_imagname,,,,imagname,nk_i) call dix_util_file_parse(imagname(1:nk_i),'N',bpos,epos) istat = lbr$open(lbr_index,'dix_demo',, 1 imagname(1:epos)//'.tlb;') endif if(.not. istat) goto 90 c p_c_control = %loc(control) call memtab_init(control,lun_memtab,'MEM_DEMO_LBR') c istat = lbr$get_index(lbr_index,1,dix_demo_get_index) if(.not. istat) goto 80 c c Now lun_memtab contains all modules c call memtab_rewind(lun_memtab) do while(memtab_read(lun_memtab,nk_k,key)) header = key(1:nk_k) nk_hd = nk_k c c Now line contains the key of the library c Look in the module for the #HD: keyward, that contains the header c istat = lbr$lookup_key(lbr_index,key(1:nk_k),rfa) if(.not. istat) goto 80 do while(lbr$get_record(lbr_index,line,descr)) if(line(1:1) .eq. '#') then ipos = index(line,':') call str$upcase(line(1:ipos),line(1:ipos)) if(line(1:3) .eq. '#HD') then header = line(ipos+1:) nk_hd = descr(1) - ipos goto 20 endif endif end do c c Now header contains the header line, write out a line to c the memtab containg the key|header c 20 if(dix_util_match_string_wild(header(1:nk_hd),mask, 1 .false.,wildcard_flag_standard)) then call memtab_add_record(control,lun_mem, 1 key(1:nk_k)//'|'//header(1:nk_hd)) nrec = nrec + 1 max_len = max(max_len,nk_hd) endif end do call memtab_close(control,lun_memtab) istat = 1 goto 90 80 call lbr$close(lbr_index) c 90 dix_demo_get_list = istat return end function dix_demo_get_index(key) implicit none c include 'dix_def.inc' character*(*) key integer*4 dix_demo_get_index c record /control/ control pointer (p_control,control) c integer*4 lun_memtab,p_c_control common /dix_demo_get/ lun_memtab,p_c_control c p_control = p_c_control call memtab_add_record(control,lun_memtab,key) dix_demo_get_index = 1 return end function dix_demo_select(control,lun_mem,nrec,lbr_index, 1 max_len,header,lun_data,choise,row) implicit none c include 'dix_def.inc' include '($jpidef)' include 'dix_screen_def.inc' c record /control/ control integer*4 lun_mem !i: memory lun with files integer*4 nrec !:i: #records in lun_mem integer*4 lbr_index integer*4 max_len !:i: max lenght of name character*(*) header !:o: headrer line integer*4 lun_data !:o: the memory table for the data integer*4 choise !:io: start point integer*4 row !:i: the row for the display integer*4 dix_demo_select !:f: function result c record /screen_data/ screen_data! c integer*4 ipos,istat,descr(2),rfa(2) integer*4 dis_id,k,krow,kcol,iterm,nk character*(255) line c record /dyn_help/ help_des c integer*4 lbr$lookup_key integer*4 lbr$get_record c character*(*) border_line parameter (border_line = 'Demo file selection') c character*(*) context parameter (context = 'SELDEMO') c c if(nrec .eq. 1) then screen_data.row = 1 goto 50 endif c screen_data.disp_nrows = nrec c c We need 3 for the number and 1 for the space c screen_data.disp_ncols = max(len(border_line)+2,max_len) screen_data.view_nrows = min(control.nrows-row-1,nrec) screen_data.view_ncols = min(control.ncols-10, 1 screen_data.disp_ncols) screen_data.row_offset = 1 screen_data.col_offset = 1 screen_data.paste_row = row screen_data.paste_col = (control.ncols-screen_data.view_ncols)/2 screen_data.nlines = nrec screen_data.ncols = max_len c call smg$create_virtual_display(screen_data.nlines, 1 screen_data.ncols,dis_id) call memtab_rewind(lun_mem) c do k=1,nrec call memtab_read(lun_mem,nk,line) ipos = index(line,'|') call smg$put_chars(dis_id,line(ipos+1:nk),k,1) end do c call smg$label_border(dis_id,border_line) c call smg$create_viewport(dis_id, 1 screen_data.row_offset, 1 screen_data.row_offset, 1 screen_data.view_nrows, 1 screen_data.view_ncols) call smg$paste_virtual_display(dis_id,control.paste_id, 1 screen_data.paste_row, 1 screen_data.paste_col) c screen_data.row = 1 screen_data.col = 1 c call help_init_std(control,help_des,'select files',20,15,context) call help_key(control,help_des,key_do, 1 'Use this file',context) call help_key(control,help_des,key_enter, 1 'Use this file',context) call help_key(control,help_des,key_abort, 1 'Exit',context) call dix_smg_stack_help(control,help_des) c 30 screen_data.row = max(choise,min(screen_data.row,screen_data.nlines)) screen_data.col = max(1,min(screen_data.col,screen_data.ncols)) c call dix_smg_set_scroll(dis_id,0,screen_data,0,1) c 18 call smg$set_cursor_abs(dis_id,screen_data.row,screen_data.col) c call dix_get_key(control,iterm,krow,kcol,context) c krow = krow - screen_data.paste_row+1 kcol = kcol - screen_data.paste_col+1 if(iterm .eq. key_mouse_left .or. 1 iterm .eq. key_mouse_right) then if(krow .ge. 1 .and. krow .le. screen_data.view_nrows .and. 1 kcol .ge. 1 .and. kcol .le. screen_data.view_ncols ) then screen_data.row = krow + screen_data.row_offset -1 iterm = key_enter else goto 18 endif elseif(iterm .eq. key_mouse_middle) then if(krow .lt. screen_data.view_nrows/2) then iterm = key_prev else iterm = key_next endif endif if(iterm .eq. key_do .or. iterm .eq. key_enter) then goto 45 elseif(iterm .eq. key_abort .or. iterm .eq. key_exit) then goto 40 elseif(iterm .eq. key_up) then screen_data.row = screen_data.row - 1 elseif(iterm .eq. key_down) then screen_data.row = screen_data.row + 1 elseif(iterm .eq. key_top) then screen_data.row = 1 elseif(iterm .eq. key_bot) then screen_data.row = screen_data.nlines elseif(iterm .eq. key_next) then screen_data.row = screen_data.row + 10 elseif(iterm .eq. key_help) then call dix_smg_help(control,context) elseif(iterm .eq. key_prev) then screen_data.row = screen_data.row - 10 else call dix_mes_invkey(control,context) endif goto 30 c c Abort, return 0 c 40 screen_data.row = 0 c c Normal selection c 45 call smg$delete_virtual_display(dis_id) call dix_smg_unstack_help(control) c c Select wanted c 50 if(screen_data.row .eq. 0) then lun_data = 0 else call memtab_rewind(lun_mem) do k=1,screen_data.row call memtab_read(lun_mem,nk,line) enddo ipos = index(line,'|') header = line(ipos+1:nk) call memtab_init(control,lun_data,'MEMTAB_DEMO_DATA') c istat = lbr$lookup_key(lbr_index,line(1:ipos-1),rfa) if(.not. istat) goto 99 do while(lbr$get_record(lbr_index,line,descr)) call memtab_add_record(control,lun_data,line(1:descr(1))) end do choise = screen_data.row endif c istat =1 99 dix_demo_select = istat return end subroutine dix_demo_display_index(control,lun_data,screen_name) implicit none c include 'dix_def.inc' include 'dix_demo_def.inc' include 'dix_screen_def.inc' c record /control/ control !:i: the control block integer*4 lun_data !:i: the memory lun with all texts character*(*) screen_name !:o: the name of the screen selected c logical*4 skip integer*4 ichap,dis_id,nk,ipos,nk_idx,row,key,col,iscreen,idx character*255 line character*10 idxasc c record /screen_data/ screen_data record /dyn_help/ help_des c character*(*) context parameter (context = 'DEMO_SEL_SCREEN') c integer*4 memtab_read c ichap = 0 c call memtab_rewind(lun_data) c screen_data.disp_ncols = control.ncols-10 screen_data.disp_nrows = control.nrows-4 c screen_data.paste_col = 2 screen_data.paste_row = 2 screen_data.nlines = 0 screen_data.ncols = 0 c screen_data.row_offset = 1 screen_data.col_offset = 1 screen_data.view_nrows = screen_data.disp_nrows screen_data.view_ncols = screen_data.disp_ncols call smg$create_virtual_display( 1 screen_data.disp_nrows, 1 screen_data.disp_ncols, 1 dis_id) c call help_init_std(control,help_des,'select screen',20,15,context) call help_key(control,help_des,key_do, 1 'Use this screen',context) call help_key(control,help_des,key_enter, 1 'Use this screen',context) call help_key(control,help_des,key_abort, 1 'Exit',context) call dix_smg_stack_help(control,help_des) skip = .true. row = 0 do while(memtab_read(lun_data,nk,line)) if(line(1:1) .eq. '#') then ipos = index(line,':') if(ipos .ne. 0) then screen_name = ' ' call str$upcase(line(1:ipos),line(1:ipos)) nk_idx = 0 if(line(2:3) .eq. 'CH') then line = line(ipos+1:) nk = nk - ipos if(line .eq. ' ') then skip = .true. else ichap = ichap + 1 call sys$fao('!UL. ',nk_idx,idxasc,%val(ichap)) iscreen = 0 skip = .false. endif elseif(line(2:3) .eq. 'SC') then if(.not. skip) then line = line(ipos+1:) !skip to SC: part nk = nk - ipos ipos = index(line,':') !locate the start of the name if(ipos .ne. 0) then screen_name = line(1:ipos-1) line = line(ipos+1:) nk = nk - ipos if(line .ne. ' ') then iscreen = iscreen + 1 call sys$fao(' !UL.!UL ',nk_idx,idxasc, 1 %val(ichap),%val(iscreen)) endif endif endif endif if(nk_idx .gt. 0) then line = idxasc(1:nk_idx)//line(1:nk) nk = nk + nk_idx line = screen_name//line nk = nk + len(screen_name) c row = row + 1 if(row .gt. screen_data.disp_nrows) then screen_data.disp_nrows = row call smg$change_virtual_display(dis_id, 1 screen_data.disp_nrows) endif if(nk .gt. screen_data.disp_ncols) then screen_data.disp_ncols = nk call smg$change_virtual_display(dis_id,, 1 screen_data.disp_ncols) endif c call smg$put_chars(dis_id,line,row,1) endif !we hav a useful line endif !valid tag endif !command line end do !process all lines c screen_data.nlines = screen_data.disp_nrows screen_data.ncols = screen_data.disp_ncols c call smg$label_border(dis_id,'Index') c screen_data.row_offset = 1 screen_data.col_offset = len(screen_name)+1 screen_data.view_nrows = control.nrows-3 screen_data.view_ncols = screen_data.disp_ncols-len(screen_name) c call smg$create_viewport(dis_id, 1 screen_data.row_offset,screen_data.col_offset, 1 screen_data.view_nrows,screen_data.view_ncols) c call smg$paste_virtual_display(dis_id,control.paste_id, 1 screen_data.paste_row,screen_data.paste_col) c screen_data.row = 1 screen_data.col = len(screen_name) + 1 c 20 call dix_smg_set_scroll(dis_id,0,screen_data,0,1) call smg$set_cursor_abs(dis_id,screen_data.row,screen_data.col) c call dix_get_key(control,key,row,col,' ') row = row - screen_data.paste_row+1 col = col - screen_data.paste_col+1 if(key .eq. key_mouse_left .or. 1 key .eq. key_mouse_right) then if(row .le. screen_data.view_nrows .and. row .gt. 0 .and. 1 col .le. screen_data.view_ncols .and. col .gt. 0) then screen_data.row = row + screen_data.row_offset - 1 key = key_enter else goto 20 endif elseif(key .eq. key_mouse_middle) then if(row .le. screen_data.view_nrows .and. row .gt. 0 .and. 1 col .le. screen_data.view_ncols .and. col .gt. 0) then if(row .gt. screen_data.view_nrows/2) then key = key_next else key = key_prev endif else goto 20 endif endif if(key .eq. key_down) then screen_data.row = screen_data.row + 1 elseif(key .eq. key_up) then screen_data.row = screen_data.row - 1 elseif(key .eq. key_next) then screen_data.row = screen_data.row + 3*screen_data.view_nrows/4 elseif(key .eq. key_prev) then screen_data.row = screen_data.row - 3*screen_data.view_nrows/4 elseif(key .eq. key_do .or. key .eq. key_enter) then c c Accept this one, check if it is a chapter header, if so take the next c row = screen_data.row call smg$read_from_display(dis_id,line,,row) screen_name = line(1:demo_name_length) do while(screen_name .eq. ' ' .and. row .lt. screen_data.nlines) row = row + 1 call smg$read_from_display(dis_id,line,,row) screen_name = line(1:demo_name_length) enddo goto 90 elseif(key .eq. key_exit) then screen_name = ' ' idx = 0 goto 90 elseif(key .eq. key_help) then call dix_smg_help(control,context) endif goto 20 90 call smg$delete_virtual_display(dis_id) call dix_smg_unstack_help(control) return end function dix_demo_get_file(control,fnam,lun_data,header) implicit none c include 'dix_def.inc' record /control/ control character*(*) fnam integer*4 lun_data character*(*) header integer*4 dix_demo_get_file c character*255 line integer*4 nk,bpos,epos,ipos,istat c integer*4 lun_file c external dix_msg_filnotf c call lib$get_lun(lun_file) call memtab_init(control,lun_data,'DEMO_FILE') open(lun_file,file=fnam,defaultfile='.dix_demo', 1 err=80,shared,readonly,status='old') inquire (lun_file,name=line) call dix_util_file_parse(line,'N',bpos,epos) header = line(bpos:epos) c c Start reding the file and copy to the mem file c rememeber the HD tag as header c 10 read(lun_file,2001,end=20) nk,line 2001 format(q,a) if(line(1:1) .eq. '#') then ipos = index(line,':') call str$upcase(line(1:ipos),line(1:ipos)) if(line(2:3) .eq. 'HD') header = line(ipos+1:nk) endif call memtab_add_record(control,lun_data,line(1:nk)) goto 10 20 close(lun_file) istat = 1 goto 90 80 istat = %loc(dix_msg_filnotf) 90 call lib$free_lun(lun_file) dix_demo_get_file = istat return end subroutine dix_demo_info(control,dis_id_demo,row) implicit none c include 'dix_def.inc' record /control/ control integer*4 dis_id_demo integer*4 row c call smg$create_virtual_display(10,65,dis_id_demo) call smg$put_line(dis_id_demo, 1 ' This is a DEMO for DIX') call smg$put_line(dis_id_demo, 1 ' NO real files are opened and NO data will be modified') call smg$put_line(dis_id_demo, 1 ' If you see a display with the name KEYES, then '// 1 'you can only') call smg$put_line(dis_id_demo, 1 'type those keys, on other screens you can type '// 1 'PF2/HELP for help') call smg$put_line(dis_id_demo, 1 ' You can select a demo from the following list') call smg$paste_virtual_display(dis_id_demo,control.paste_id,1,8) row = 8 return end