c    Program SCREENIN: demonstration of GREX text-mode features
c
c    Copyright (C) 1989 by MicroWay Inc.
c    For use in NDP applications
c    by SSF and PNS
c
c

      INTEGER month, day, year, err, x, y, iattr

      INTEGER key, get_a_key, get_ordinal, iy, ix, kb

      INTEGER level

      CHARACTER*40 help_messages(11)

      CHARACTER*20 words(10)

      CHARACTER*80 string

      CHARACTER first_name*14, mi*1, last_name*30, magazine*30, town*26

      CHARACTER street*30, state*2, zip_code*10, telephone*14, ch*1

      CHARACTER q

      INCLUDE "scrval.fh"

      INCLUDE "GREX.FH"

      COMMON level,help_messages(11)

      first_name = ' '
      mi         = ' '
      last_name  = ' '
      magazine   = ' '
      town       = ' '
      street     = ' '
      state      = ' '
      zip_code   = ' '
      telephone  = ' '

c    initialize text mode actions
      CALL get_video_mode(max_row,max_column)

c    initialize help messages
      CALL messages

c    clear screen
      CALL cls

c    Print a banner
      CALL place_string_at(30,4,"MicroWay Questionnaire")

c    print the questionaire headings using the dim attribute
      CALL set_active_attribute(idim)

      CALL place_string_at(0,6,"TODAY'S DATE")
      CALL place_string_at(0,8,"NAME")
      CALL place_string_at(0,10,"MAGAZINE READ")
      CALL place_string_at(0,11,"STREET ADDRESS")
      CALL place_string_at(0,12,"TOWN")
      CALL place_string_at(31,12,"STATE")
      CALL place_string_at(41,12,"ZIP CODE")
      CALL place_string_at(0,13,"TELEPHONE")

c    set the attribute back to bright
      CALL set_active_attribute(ibright)

c    read the date with bright attribute
      CALL input_date_at(15,6,imonth,iday,iyear)

c    now change back to a dim attribute
      CALL set_active_attribute(idim)

c    now put the help message on the screen
c    that tells the user about alt-h and help messages
      CALL help(0)

      CALL place_string_at(10,0,"use <left> and <up> arrows to go back")
      CALL place_string_at(10,1,
     &     "use <right>, <down> and <Enter> to advance")

c    now set the attribute byte back to bright
      CALL set_active_attribute(ibright)

      call pause

c    initialize kb to non zero so that first usage works with
c    arrow keys

      kb = 2

c   The main part of the program works like a linked list of
c   subroutines. Each call to input_string_at updates the
c   string that that particular call edits. This routine is
c   written so that it can be reentered and it will start up
c   editing in the same location on the screen. After exiting
c   we check to see how the user left. If he left with an up
c   or left arrow, we know that he wants to go backwards up the
c   chain, and we call the previous invocation. If he exited with
c   the <Enter>, down arrow or right arrow keys, we know he wants to go
c   on and we fall through to the next call to input_string_at
c   or we fall into the section which summarizes the values input
c   from the screen
	
   10 level = 1
      CALL input_string_at(0,9,"First ",first_name,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 10

   20 level = 2
      CALL input_string_at(20,9,"MI ",mi,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 10

   30 level = 3
      CALL input_string_at(26,9,"Last ",last_name,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 20

   40 level = 4
      CALL input_string_at(14,10," ",magazine,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 30

   50 level = 5
      CALL input_string_at(15,11," ",street,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 40

   60 level = 6
      CALL input_string_at(5,12,"L",town,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 50

   70 level = 7
      CALL input_string_at(37,12,"L",state,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 60

   80 level = 8
      CALL input_string_at(50,12,"L",zip_code,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 70

   90 level = 9
      CALL input_string_at(10,13,"L",telephone,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 80

  100 level = 10
      CALL input_string_at(0,15,"Hit enter if complete ",ch,kb,err)
      IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 90

c   Now demonstrate the use of the alternate screens or pages.
c
c   Note: if you take advantage of these features, you
c   cannot mix in ordinary Fortran I/O, as it always gets
c	written and displayed on page 0

      CALL set_active_text_page(1)

      CALL cls

      CALL place_string_at(0,12,"Your input is:")

      CALL place_string_at(0,15,first_name)
      ix = klen(first_name)+2
      CALL place_string_at(ix,15,mi)
      ix = ix+klen(mi)+2
      CALL place_string_at(ix,15,last_name)
      CALL place_string_at(0,16,magazine)
      CALL place_string_at(0,17,street)
      CALL place_string_at(0,18,town)
      CALL place_string_at(0,19,state)
      CALL place_string_at(0,20,zip_code)
      CALL place_string_at(0,21,telephone)

c    now display page 1
      CALL display_text_page(1)


      CALL place_string_at(10,0,"Page 1 is now on the screen")
      CALL set_active_attribute(iblinking_bright)
      CALL place_string_at(10,1,"Hit any key to return to page 0")
      CALL set_active_attribute(ibright)

      CALL pause

      CALL set_active_text_page(0)

      CALL cls

      CALL display_text_page(0)

C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

C  Draw a frame around the screen, using currently active attribute

c    know max_row and max_column
      ier = get_video_mode (max_row, max_column)
c    move to top left
      ier = home ()
c    write a Ú
      ier = write_one_char (218)
c    move right one space
      ier = rt_cursor ()
c    write a line of Ä
      ier = write_char (196,max_column)
c    move to right side
      ier = locate (max_column,0)
c    write a ¿
      ier = write_one_char (191)
c    for each line between the top and the bottom
      do 1000 i=1,max_row-1
c         write a ³ on the left side
           ier = locate (0,i)
           ier = write_one_char (179)
c         write a ³ on the right side
           ier = locate (max_column,i)
           ier = write_one_char (179)
 1000 continue
c    End-for
c    move to bottom left
      ier = locate (0,max_row)
c    write a À
      ier = write_one_char (192)
c    move right one space
      ier = rt_cursor ()
c    write a line of Ä
      ier = write_char (196,max_column)
c    move to bottom right
      ier = locate (max_column,max_row)
c    write a Ù
      ier = write_one_char (217)

C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

C    Test scrolling of windows in text-mode
c
c      Scrolling is limited so that blank lines are not introduced into
c      the window.

C    The data to be scrolled consist, logically enough,
C      of MicroWay product names.

      words( 1) = 'NDP Fortran-386'
      words( 2) = 'NDP C-386'
      words( 3) = 'NDP Pascal-386'
      words( 4) = 'Monoputer'
      words( 5) = 'Quadputer'
      words( 6) = 'Videoputer'
      words( 7) = 'flickerFixer'
      words( 8) = 'FastCache 286'
      words( 9) = '287 TurboPlus'
      words(10) = '386/387 Turbo-AT'

C    Show these ten items in a window that is only five lines high

      ier = place_string_at( 9, 5,'ÚÄÄÄÄÄ MicroWay ÄÄÄÄÄ¿')
      ier = place_string_at( 9, 6,'³                    ³')
      ier = place_string_at( 9, 7,'³                    ³')
      ier = place_string_at( 9, 8,'³                    ³')
      ier = place_string_at( 9, 9,'³                    ³')
      ier = place_string_at( 9,10,'³                    ³')
      ier = place_string_at( 9,11,'ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ')

C    Write the initial text into the window

      ier = place_string_at(10, 6,words( 1))
      ier = place_string_at(10, 7,words( 2))
      ier = place_string_at(10, 8,words( 3))
      ier = place_string_at(10, 9,words( 4))
      ier = place_string_at(10,10,words( 5))

C    Instruct the user

      ier = locate(2,max_row-3)
      ier = write_string('Use arrow keys to scroll up or down')
      ier = locate(2,max_row-2)
      ier = write_string('Press <Enter> or <Esc> to view the next test')

C    j is the index of the list element in the top line of the window

C    k is the index of the list element in the bottom line of the window

      j = 1
      k = 5

C    While the user presses a key other than <Enter> or <Esc>,
 1005 key = pause()
      if(key.ne.13.and.key.ne.10.and.key.ne.27) then
c         get a key from the user
c         if key is the up arrow, scroll the window down
c                                 decrement the list pointers
c                                 if you would scroll blanks onto the screen
c                                   then don't; beep instead.
           if(key.eq.-72) then
                k = k-1
                j = j-1
                if(j.lt.1) then
                     ier = beep()
                     j = 1
                     k = k+1
                   else
                     ier = scroll_active_page_down(10,6,29,10,1,7)
                     ier = place_string_at(10, 6,words(j))
                   endif
              endif
c         if key is the down arrow, scroll the window up
c                                   increment the list pointers
c                                   if you would scroll blanks onto the screen
c                                     then don't; beep instead.
           if(key.eq.-80) then
                j = j+1
                k = k+1
                if(k.gt.10) then
                     ier = beep()
                     k = 10
                     j = j-1
                   else
                     ier = scroll_active_page_up(10,6,29,10,1,7)
                     ier = place_string_at(10,10,words(k))
                   endif
              endif
c           get another key from the user
           go to 1005
         endif
c    End-while

      call cls

C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

C    Test cursor movement functions
C         get_cursor
C         read_char
C         read_attr


C    Write an array of characters to the screen, with different attributes.
      do 1013 i=1,4
           do 1012 j =1,64
                ia = 64*(i-1) + j - 1
                k = 48 + mod(j-1,16)
                if(k.gt.57) k = k+7
                ier = locate(j+7,i+7)
                ier = write_char_attr (k,1,ia)
 1012      continue
 1013 continue

c    Instructions
      ier = place_string_at (2,max_row-3,'Move cursor with arrow keys')
      ier = locate (2,max_row-2)
      ier = write_string ('Press <Esc> to view the next test. ')

C    know max_row and max_column
      ier = get_video_mode(max_row,max_column)
c    find the cursor
      ier = get_cursor(ic,ir)
c    while the user presses a key other than Escape
 1014 key = pause()
      if (key.ne.27) then
c         move the cursor in response
c                                                        Home key
           if (key.eq.-71) ier = locate(0,ir)
c                                                        Up arrow
           if (key.eq.-72) ier = up_cursor()
c                                                        PgUp key
           if (key.eq.-73) ier = locate(ic,0)
c                                                        Left arrow
           if (key.eq.-75) ier = lt_cursor()
c         note that the 5 key on the keypad is dead
c                                                        Right arrow
           if (key.eq.-77) ier = rt_cursor()
c                                                        End key
           if (key.eq.-79) ier = locate(max_column,ir)
c                                                        Down arrow
           if (key.eq.-80) ier = dn_cursor()
c                                                        PgDn key
           if (key.eq.-81) ier = locate(ic,max_row)
c         get current cursor location
           ier = get_cursor(ic,ir)
c         read character at cursor position
           k = read_char()
c           the function returns an integer.  Convert to character.
           q = char(k)
c         read attribute at cursor position
           ia = read_attr()
c         write cursor position, character, and attribute in lower right
           write(string,610) ir,ic,q,ia
  610      format(2i4,1x,a,i4)
           ier = place_string_at(max_column-14,max_row,string)
c         get another key
           go to 1014
         endif
c    End-while

C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      CALL locate(0,max_row)

      STOP 'Okay.'

      END

c***********************************************************************
c
c   Rewritten by P. Schweitzer to take advantage of new features
c
      subroutine input_string_at(xin,yin,prompt,result,key,err)

      integer max_row,max_column
      integer ia
      integer iblank
      integer xin,yin,key,err
      integer ix,jx,L,klen,x,y
      integer get_a_key
      character*(*) prompt,result
      character*9 cv
      character nul

c    include keyboard and color definitions
      include 'scrval.fh'

c    make a few definitions here
      iblank = 32
      nul = char(0)
      x = xin
      y = yin

c    get screen limits
      call get_video_mode(max_row,max_column)

c    show prompt if its length is greater than one
      call locate(x,y)
      if(len(prompt).gt.1) call write_string(prompt)

c    save current attribute
      call get_active_attribute(ia)
      call set_active_attribute(ireverse_bright)

c    current location is character after prompt or screen edge
      call get_cursor(x,y)

c    save this; it is the leftward limit of backspacing
      ix = x
      if(x.eq.max_column) ix = x

c    write the result string into the remaining space
      call locate(ix,y)
      call write_string(result)

c    find out where this leaves the cursor
      call get_cursor(x,y)

c    save cursor x-coordinate; it is the rightward limit of data entry
      jx = ix + len(result) - 1
      if(x.eq.max_column) jx = x

c    clear nul characters from result string
      do 1 j = 1,len(result)
           if(result(j:j).eq.nul) result(j:j) = ' '
    1 continue

c    put cursor after last nonblank character in result
      L = klen(result)
      x = ix + L
c    or on last displayable character, whichever is smaller
      x = min0(x,jx)
      call locate(x,y)

c    Get a key from user
    5 key = get_a_key()

      if(key.gt.0) then

           If(key.eq.key_help) then
                call help(0)
              endif

           if(key.eq.key_enter) then
                go to 86
             endif

           if(key.eq.key_del) then
c              find index of letter at cursor position
                j = x - ix + 1
c              set to blank
                result(j:j) = ' '
c              display
                call write_one_char(result(j:j))
             endif

           if(key.eq.key_backspace) then
c              move cursor one space to the left (if possible)
                x = max0(x-1,ix)
                call locate(x,y)
c              blank this position
                call write_one_char(iblank)
c              find index of letter at new cursor position
                j = x - ix + 1
c              set to blank
                result(j:j) = ' '
c              and get next key
                go to 5
             endif

c         if key is a normal character, place on screen
           call write_one_char(key)
c         store character in result string
           j = x - ix + 1
           result(j:j) = char(key)
c         move cursor to the right one space if possible
           x = min0(x+1,jx)
           call locate(x,y)

         else

           if(key.eq.key_home) then
c              discard entire result
                result = ' '
c              clear the screen display of the result
                call place_string_at(ix,y,result)
c              place the cursor
                x = ix
                call locate(x,y)
             endif

           if(key.eq.key_end) then
             endif

           if(key.eq.key_lt_arrow) then
c              move cursor one space to the left (if possible)
                x = max0(x-1,ix)
                call locate(x,y)
c              blank this position
                call write_one_char(iblank)
c              find index of letter at new cursor position
                j = x - ix + 1
c              set to blank
                result(j:j) = ' '
             endif

           if(key.eq.key_rt_arrow) then
c              move cursor right one position
                x = min0(x+1,jx)
                call locate(x,y)
             endif

           if(key.eq.key_up_arrow) then
                go to 86
             endif

           if(key.eq.key_dn_arrow) then
                go to 86
             endif

           if(key.eq.key_pgup) then
               call beep()
             endif

           if(key.eq.key_pgdn) then
                call beep()
             endif

           if(key.eq.key_end) then
                call beep()
             endif

         endif

      go to 5

   86 call set_active_attribute(ia)
      return
      end

      integer function klen(s)
      character*(*) s
      character blank,nul
      blank = ' '
      nul = char(0)
      j = 1 + len(s)
    1 j = j-1
      if(j.le.0) go to 2
      if(s(j:j).eq.blank.or.s(j:j).eq.nul) go to 1
    2 klen = j
      return
      end



      SUBROUTINE input_date_at(x,y,month,day,year)

      INCLUDE "scrval.fh"

      CHARACTER*1 screen_char, input_key_at
      INTEGER x, y, month, day, year
      INTEGER key, key1, get_a_key, get_ordinal
      INTEGER char_arg

      ix = x
      iy = y
      CALL locate(ix,iy)

c    write the initial template
      CALL write_string("(mm-dd-yy)")

c    move cursor over '(' to first position
      ix = ix + 1
    5 CALL locate(ix,iy)

c    get first number till a 1 or 0 appears
   10 key1 = get_a_key()
      IF (key1 .EQ. key_0) GOTO 20
      IF (key1 .EQ. key_1) GOTO 20
      GO TO 10

c    write first character to screen
   20 char_arg = key1
      CALL write_one_char(char_arg)

c    move cursor to second position
      ix = ix + 1

c    come here from next char backspace
   25 CALL locate(ix,iy)

c    get the second character which must be an ordinal
c     that results in 01,02 .. 09,10,11 or 12 only
   30 key2 = get_ordinal()

c    first test for backspace and go back if found
      IF (key2 .EQ. key_backspace) THEN
           CALL write_one_char(key_m)
           ix = ix - 1
           GO TO 5
         ENDIF

c    test for legal cases 10,11,12
      IF ((key1 .EQ. key_1) .AND. (key2 .LT. key_3)) GOTO 40
      IF  (key1 .EQ. key_1) GOTO 30
c    only key1 = 0 get this far
c    test for legal cases 01 .. 09 by eliminating 00 illegal case
      IF (key2 .EQ. key_0) GOTO 30

   40 char_arg = key2
      CALL write_one_char(char_arg)

c    skip over next key check
      GOTO 50

c-----------------------Now get the day------------------------------

c     skip over '/'
   50 ix = ix + 2
   53 CALL locate(ix,iy)

c    now get first numeral of month	12/?#/##
c    look for a 0, 1, 2 or 3

   55 key3 = get_ordinal()
      IF (key3 .EQ. key_backspace) THEN
           CALL write_one_char(key_d)
           ix = ix -2
           GOTO 25
         ENDIF
      IF (key3 .GT. key_3) GOTO 55

c    write it to first location and increment cursor
      char_arg = key3
      CALL write_one_char(char_arg)
      ix = ix + 1

c--------------------last half of day--------------------------------

   57 CALL locate (ix,iy)

c    get next ordinal checking for backspace
   60 key4 = get_ordinal()
      IF (key4 .EQ. key_backspace) THEN
           CALL write_one_char(key_d)
           ix = ix - 1
           GOTO 53
         ENDIF

c    The second key must be in the range of 0 .. 9
c    for all cases of key3, except 3, for which it
c    must be either 0 or 1, so reject 32 .. 39
      IF ((key3 .EQ. key_3) .AND. (key4 .GT. key_1)) GOTO 60

      char_arg = key4
      CALL write_one_char(char_arg)

c---------------------------get the year-----------------------------

c    now read the year which can be any value between 00 .. 99
      ix = ix + 2
   65 CALL locate (ix,iy)

c    now get first numeral of year 12/34/?#
c    look for a 0 .. 9

   70 key5 = get_ordinal()
      IF (key5 .EQ. key_backspace) THEN
           CALL write_one_char(key_y)
           ix = ix -2
           GOTO 57
         ENDIF

c    write it to first location and increment cursor
      char_arg = key5
      CALL write_one_char(char_arg)
      ix = ix + 1

c------------------------last half of year--------------------------

      CALL locate (ix,iy)

c    get next ordinal checking for backspace
   75 key6 = get_ordinal()
      IF (key6 .EQ. key_backspace) THEN
           CALL write_one_char(key_y)
           ix = ix - 1
           GOTO 65
         ENDIF

   80 char_arg = key6
      CALL write_one_char(char_arg)

c    now wait for either a new numeral, backspace or enter
   85 key = get_a_key()

c    check for ordinal
      IF ((key .GE. key_0) .AND. (key .LE. key_9)) THEN
           key6 = key
           GOTO 80
         ENDIF
      IF (key .EQ. key_backspace) THEN
           CALL write_one_char(key_y)
           ix = ix - 1
           GOTO 65
         ENDIF
      IF (key .EQ. key_enter) THEN
           month = key2 - key_0 + 10*(key1 - key_0)
           day   = key4 - key_0 + 10*(key3 - key_0)
           year  = key6 - key_0 + 10*(key5 - key_0) + 1900
           GOTO 90
         ENDIF

c    if it wasn't a numeral, enter or backspace we poll again
      GOTO 85

c       we're done !
   90 CONTINUE
      END

c*********************************************************************

      INTEGER FUNCTION get_ordinal()

      INCLUDE "scrval.fh"

      INTEGER key,get_a_key

   10 key = get_a_key()
      IF (key .EQ. key_backspace) GOTO 20
      IF (key .LT. key_0) GOTO 10
      IF (key .GT. key_9) GOTO 10

   20 get_ordinal = key

      END

c*********************************************************************

      INTEGER FUNCTION get_a_key()
      INTEGER level,ihelp,key
      CHARACTER*40 help_messages(11)
      COMMON level,help_messages(11)

      INCLUDE "scrval.fh"

c    initialize help flag to 0
      ihelp = 0

c    read a key
   10 key = inkey$()

c    filter the result of the read

c    no character read, so still poll
      IF (key .EQ. key_null) GOTO 10

c    check to see if we have a help message printed below
c      and if we do, erase it by calling help with a zero
      IF (ihelp .NE. 0) THEN
           ihelp = 0
           CALL help(ihelp)
         ENDIF

c    a control C was hit, so return to DOS
      IF (key .EQ. key_cntrl_c) STOP

c    we chose to use the escape as a return to DOS also
      IF (key .EQ. key_esc) STOP

c    This is an ideal place for a context-sensitive help
c     function

      IF (key .EQ. key_alt_h) THEN
           ihelp = level
           CALL help(ihelp)
           GOTO 10
         ENDIF

c    return key code
      get_a_key = key

      END

c **************************************************************************
      SUBROUTINE help(ihelp)
      INTEGER level,ihelp,iattr1,iattr2
      CHARACTER*40 help_messages(11)
      COMMON level,help_messages(11)

      INCLUDE "scrval.fh"

c    get the current cursor position
      CALL get_cursor(ix1,iy1)

c    get the active attribute to restore it below
      CALL get_active_attribute(iattr1)


c    if ihelp <> 0 change to reverse bright characters
      IF (ihelp .NE. 0) THEN
           CALL set_active_attribute(ibright)
         ELSE
           CALL set_active_attribute(idim)
         ENDIF

c    write the message to the next to the last row of the screen
      CALL place_string_at(10,23,help_messages(ihelp+1))

c    restore the attribute
      CALL set_active_attribute(iattr1)

c    restore the cursor to the input line
      CALL locate(ix1,iy1)

      END
*************************************************************************
      SUBROUTINE messages
      INTEGER level
      CHARACTER*40 help_messages(11)
      COMMON level,help_messages(11)

c   set up the help message array in common

      help_messages(1 ) = "<Alt-h> for help messages"
      help_messages(2 ) = "Your first name please"
      help_messages(3 ) = "Your middle initial please"
      help_messages(4 ) = "Your last name please"
      help_messages(5 ) = "Enter the name of your favorite magazine"
      help_messages(6 ) = "Enter your street address"
      help_messages(7 ) = "Enter the name of your town"
      help_messages(8 ) = "Enter the state's two letter abreviation"
      help_messages(9 ) = "Enter a 5 digit zip code only"
      help_messages(10) = "Enter your area code and number"
      help_messages(11) = "To go back use up arrow, else hit enter"

      END
c************************************************************************
