c========================================================
c
c       demo.for        FAT-Video 1.20 Updated 1/28/88
c
c       Window demo for FAT-Video 1.20.
c
c          This program works with CGA,EGA and MONO
c       monitors in modes 3 or 7.
c
c       marc a. norton
c=========================================================
      INTEGER*2 attr,ulr,ulc,nr,nc,rattr,xattr,i,j,k,l,icol
      INTEGER*2 fore,back,inten,blink,mode,ncols,page,battr
      INTEGER*2 scan,key,wid1,wid2,wid3,wids,wdx(16),wid0
      integer*2 White,Yellow
      integer*2 Black,Blue,Red
      character title*80,string*80,infil*35,outfil*35
      logical   POP
      character    adap*3
      INTEGER*2    isel,iopt,ii,ipos,im,ikey
      character*20 prnam(10)
      character*50 itnam(20),itmen(20)
c----------------------------------------------------------------------
c   prnam must be declared as char*20 for compatability with menbar().
c   itnam must be declared as char*50 for compatability with wmenu().
c----------------------------------------------------------------------

c------- get adapter
      call cls()
      call getmod(mode,ncols,page)
      call getadp(adap)
      IF(mode .eq. 3)THEN
        White = 7
        Yellow= 6
        Black = 0
        Blue  = 1
        Red   = 4
      END IF
      IF(mode .eq. 7)THEN
        White = 7
        Yellow= 7
        Black = 0
        Blue  = 0
        Red   = 0
      END IF

c--------set border, if were on a true CGA adapter, not EGA in mode 3
c        border on EGA is set with the overscan register.
      if(adap.eq.'CGA')call setbc(7)

c------opening display-----------------
      call opndis(infil,outfil)
      call cls()

      inten=0
      blink=0
      call setab(attr,White,Blue,inten,blink)
c---------make borderless backdrop window
      call wopen(wids,attr,attr,0,0,23,78,char(0),0,0,0)
  105 continue

c----------loc of window of ulr,ulc for window #1
      ulr=3
      ulc=10
      nr = 15
      nc = 60
c--------------set window colors
      inten= 0
      blink= 0
c----------setup the attr byte
      call setab(attr,Yellow,Black,inten,blink)
      call revab(attr,battr)
c-----------open window #1
      title='1: FAT-Video Demo`'
      call setnul(title)
      call wopen(wid1,battr,attr,ulr,ulc,nr,nc,title,1,0,0)

c-----------write a line of txt
      title='    This is a demonstration of the simple`'
      call wprint(wid1,title)
      title=' windowing that can be performed with the`'
      call wprint(wid1,title)
      title=' FAT-Video utilities, in Fortran.`'
      call wprint(wid1,title)
      call wprint(wid1,' Notice, if you have a CGA monitor`')
      call wprint(wid1,' the border color is now set, and`')
      call wprint(wid1,' we have a background screen to work on. `')
      call wcrlf(wid1)
      call wprint(wid1,' Press a key to continue...`')
      call rdkbd(scan,key)

      call wcls(wid1)
      call wprint(wid1,' First we will examine some text i/o.`')
      call wcrlf(wid1)
      call wprint(wid1,' Press a key, and notice the key is echoed`')
      call wprint(wid1,' to the screen.`')
      call revab(attr,rattr)
      call wgetce(wid1,rattr,key)
      call wcrlf(wid1)
      call wprint(wid1,' Enter a string and press return: `')
      call setab(rattr,White,Blue,0,0)

      call wgetse(wid1,rattr,string,15)
      call wcrlf(wid1)
      call wprint(wid1,' Enter a string, and press return,`')
      call wprint(wid1,' notice there is no echo.`')
      call wgetsn(wid1,string,15)
      call wcrlf(wid1)
      call wprint(wid1,' Your string was: `' )
      call wprint(wid1,string)
      call wcrlf(wid1)
      call wprint(wid1,' Press a key to continue.`')
      call rdkbd(scan,key)

      call wcls(wid1)
      call wprint(wid1,'  These have been some examples of the`')
      call wprint(wid1,' kind of text input and output available`')
      call wprint(wid1,' with or without the`')
      call wprint(wid1,' windows, using the FAT-Video libraries.`')
      call wprint(wid1,'  Examine the demo source code to see how`')
      call wprint(wid1,' easy it is to use the window, and video`')
      call wprint(wid1,' library functions. They are all simple`')
      call wprint(wid1,' subroutine calls, but they provide some`')
      call wprint(wid1,' very powerful tools for writing pleasant`')
      call wprint(wid1,' user interfaces.`')
      call wcrlf(wid1)
      call wprint(wid1,' Press any key to continue...`')
      call RDKBD(SCAN,KEY)
      call wcls(wid1)

c--------------go to menuing now...
      call wprint(wid1,' We will go on to menus now. There are 3`')
      call wprint(wid1,' types of menus in FAT-Video. The first is`')
      call wprint(wid1,' the menu-bar, it is the master menu and it`')
      call wprint(wid1,' appears in row 1 of the window it is`')
      call wprint(wid1,' placed in. The second is the Pull-Down menu,`')
      call wprint(wid1,' it drops from`')
      call wprint(wid1,' under the main menu-item selected.  The`')
      call wprint(wid1,' third`')
      call wprint(wid1,' is the Pop-Up menu, it just pops up on`')
      call wpriNT(WID1,' screen`')
      call wprint(wid1,' wherever you want.`')
      call wprint(wid1,' Before we look at the menus, here`')
      call wprint(wid1,' are some simple rules to follow:`')
      call wcrlf(wid1)
      call wcrlf(wid1)
      call wprint(wid1,'   To move around, use the arrow keys.`')
      call wcrlf(wid1)
      call wprint(wid1,'   To select a menu-item, press return.`')
      call wcrlf(wid1)
      call wprint(wid1,'   To exit, without selecting, press Esc.`')
      call wcrlf(wid1)
      call wprint(wid1,'   To exit  the menus, select Exit.`')
      call wcrlf(wid1)
      call wcrlf(wid1)
      call wprint(wid1,' Thats it, press a key to go on...`')
      call RDKBD(SCAN,KEY)
      call wcls(wid1)

c-----------DEFINE MAIN MENU ITEMS
      prnam(1)='Menus`'
      prnam(2)='Disk`'
      prnam(3)='Math`'
      prnam(4)='Special`'
      prnam(5)='Junk`'
      prnam(6)='Memory`'
      prnam(7)='Exit`'
      prnam(8)=char(0)

c---------define Menus-items
      itmen(1) = ' Pop-Up    Menus `'
      itmen(2) = ' Pull-Down Menus `'
      itmen(3) = '`'

c----------- define dummy menu items here
      itnam(1)  = 'item number 1  `'
      itnam(2)  = 'item number 2  `'
      itnam(3)  = 'item number 3  `'
      itnam(4)  = 'item number 4  `'
      itnam(5)  = 'item number 5  `'
      itnam(6)  = 'item number 6  `'
      itnam(7)  = 'item number 7  `'
      itnam(8)  = 'item number 8  `'
      itnam(9)  = 'item number 9  `'
      itnam(10) = 'item number 10 `'
      itnam(11) = 'item number 11 `'
      itnam(12) = 'item number 12 `'
      itnam(13)=char(0)

c-----------place some text, but not in row #1 !!!
      call wsetcp(wid1,2,1)
      call wprint(wid1,'   As you play with the menuing features`')
      call wprint(wid1,' take notice that the sliding-bar menu in`')
      call wprint(wid1,' row 1 may have diffent colors than the`')
      call wprint(wid1,' Pop-Up and Pull-Down menus. The 1st item`')
      call wprint(wid1,' in the Main menu is Menus, it is the only`')
      call wprint(wid1,' functional menu in the demo. It can `')
      call wprint(wid1,' dynamically switch between Pop-Up and`')
      call wprint(wid1,' Pull-Down menus. Try the menus out, and`')
      call wprint(wid1,' examine the source code, they are easy to`')
      call wprint(wid1,' make and use.`')
      POP = .FALSE.
c---------start position of selected menu
      call curoff()
      ipos = 1
  130 call revab(attr,rattr)
      call menbar(wid1,prnam,attr,rattr,isel,ipos)
      if(isel.eq.7)go to135
      if(isel .eq. 0)go to 130

c--------select colors
      call setab(xattr,White,Blue,0,0)
C      call revab(xattr,rattr)
      icol=30

c----------call Pop-Up or Pull-Down Menus
      if(POP)then
       if(isel.eq.1)then
         call wmenu(itmen,attr,rattr,7,icol,prnam(isel),isel)
        if(isel.eq.1)POP=.TRUE.
        if(isel.eq.2)POP=.FALSE.
        else
         call wmenu(itnam,attr,rattr,7,icol,prnam(isel),isel)
       end if
      else
       if(isel.eq.1)then
        call menu1(wid1,prnam,itmen,attr,rattr,isel)
        if(isel.eq.1)POP=.TRUE.
        if(isel.eq.2)POP=.FALSE.
       else
        call menu1(wid1,prnam,itnam,attr,rattr,isel)
       end if
      end if
c-----------------------
      go to 130
  135 continue
c----------turn cursor on again
      call curon()


c----------------open 2nd window
      ulr=4
      ulc=10
      nr = 6
      nc = 45
      title='2:`'
      fore=White
      back=Blue
      if(mode.eq.3)then
        fore=fore+1
        if(fore.eq.16)fore=0
        back=back+1
        if(back.eq.8)back=0
      end if
c----------setup the attr byte
      call setab(attr,fore,back,0,0)
      call revab(attr,battr)
      call wxopen(wid2,battr,attr,ulr,ulc,nr,nc,title,1,0,0)

      call wprint(wid2,' Did you notice this window expanded`')
      call wprint(wid2,' on opening. This window will perform`')
      call wprint(wid2,' scrolling, and will move around the`')
      call wprint(wid2,' screen, while retaining all of its`')
      call wprint(wid2,' previously written contents.`')
      call wprint(wid2,' Press any key to continue...`')
      call rdkbd(scan,key)
      call wcls(wid2)
c-----------write some stuff to this window
      call wprint(wid2,' F1 - save screen`')
      call wcrlf(wid2)
      call wprint(wid2,' F2 - get screen `')
      call wcrlf(wid2)
      call wprint(wid2,' F3 - save window`')
      call wcrlf(wid2)
      call wprint(wid2,' F4 - get window `')
      call wcrlf(wid2)
      call wprint(wid2,' Press any key to scroll`')
      call rdkbd(scan,key)
      do 99 i=1,15
        call wcrlf(wid2)
        call wprint(wid2,' data.....`')
        call wcrlf(wid2)
        call wprint(wid2,' more data...`')
   99 continue
c
c      MOVE THE WINDOWS AROUND HERE...
c
      title=' Press any key to move the window`'
      call wcrlf(wid2)
      call wprint(wid2,title)
      call rdkbd(scan,key)

      call wmovr(wid2,5,10)
      call wcrlf(wid2)
      call wprint(wid2,title)
      call RDKBD(SCAN,KEY)

      call wmovr(wid2,-5,0)
      call wcrlf(wid2)
      call wprint(wid2,title)
      call RDKBD(SCAN,KEY)

      call wmovr(wid2,5,-10)
      call wcrlf(wid2)
      call wprint(wid2,title)
      call RDKBD(SCAN,KEY)

      call wmova(wid2,5,30)
      call wcrlf(wid2)
      call wprint(wid2,title)
      call RDKBD(SCAN,KEY)

      call wmova(wid2,0,0)
      call wcrlf(wid2)
      call wprint(wid2,title)
      call RDKBD(SCAN,KEY)

      call wmova(wid2,5,10)
      call wcrlf(wid2)
      call wprint(wid2,' Press any key to continue...`')
      call RDKBD(SCAN,KEY)

c-----------------------open 3rd window
      ulr=10
      ulc=30
      nr= 10
      nc= 40
      title='3:`'
      fore=White
      back=Blue
c----------setup the attr byte
      call setab(attr,fore,back,inten,blink)
      call setab(rattr,back,fore,inten,blink)
      call wopen(wid3,rattr,attr,ulr,ulc,nr,nc,title,1,0,0)
c----------play with the window # 3
      call wprnas(wid3,rattr,' You may write to windows using`')
      call wprnas(wid3,rattr,' any attribute you like, to define`')
      call wprnas(wid3,rattr,' the foreground and background colors`')
      call wprnas(wid3,rattr,' of the text.`')
      call wprint(wid3,' Then again you can just print text in the`')
      call wprint(wid3,' windows default colors.`')
      call wcrlf(wid3)
      call wprint(wid3,' Press a key to clear screen`')
      call RDKBD(SCAN,KEY)
      call wcls(wid3)

      call wprint(wid3,' That cleared the window.`')
      call wprint(wid3,' We can overwrite in a window too,`')
      call wprint(wid3,' as well as use the built in word wrap`')
      call wprint(wid3,' feature. This is not bad.`')
      call wprint(wid3,' The text is not right justified though.`')

      call wcrlf(wid3)
      call wprint(wid3,' Press a key to overwrite this line...`')
      call RDKBD(SCAN,KEY)
      call wcrx(wid3)
      call wcleol(wid3)
      call wprint(wid3,' That seems to work.`')
      call wcrlf(wid3)
      call wprint(wid3,' Press a key to go on...`')
      call RDKBD(SCAN,KEY)

c----------------------show some windows
      do 889 im=6,18,6
      ii=-1
      do 888 j=1,16
      write(unit=title(1:4),fmt='(i2,''*''a)')j,char(0)
      ii=ii+1
      if(ii.gt.7)ii=0
      k=j-1
      ulr=j
      ulc=j+im+2
      nr=7
      nc=30
      if(k.eq.ii)k=ii+3
      if(mode.eq.7)k=7
      if(mode.eq.7)ii=0
      call setab(attr,k,ii,0,0)
      call revab(attr,battr)
      call wopen(wdx(j),battr,attr,ulr,ulc,nr,nc,title,1,0,1)
  888 continue
      call wprint(wdx(16),'Press a key to continue...`')
      call RDKBD(SCAN,KEY)
      do 889 j=16,1,-1
      call wclose(wdx(j))
  889 continue
c
c-----------close and clean up windows.
c-----------delete window #3
      call wclose(wid3)

c-----------wait for key
      call wcls(wid2)
      title='Press a key to continue...`'
      call wprint(wid2,title)
      call RDKBD(SCAN,KEY)
c---------close w#2
      call wclose(wid2)

c-----------wait for key
      call wcls(wid1)
      call wsetcp(wid1,5,10)
      title='Press any key to repeat Demo, ESC to quit.`'
      call wprint(wid1,title)
      call RDKBD(SCAN,KEY)
c---------close w#1
      call wclose(wid1)

c---------loop or quit ?
      if(key.eq.27)go to 200
      go to 105

  200 continue
c---------close background screen
      call wclose(wids)

      end


C==============================================================
C
C       opndis.for
C
C          This is the opening display for FAT-Video 1.0
C
C       Marc A. Norton
C===============================================================
      subroutine opndis(infil,outfil)
      character*35 infil,outfil,char*1
      integer*2  imode,inc,ipage,icode,iattr1
      integer*2  White,Yellow
      integer*2  Blue,Black,Red
      integer*2  ibattr,iattr,iwid0,iwid1,iwid2,iwid3,iwid4,ikey

      call getmod(imode,inc,ipage)
      IF(imode .eq. 3)THEN
        White = 7
        Yellow= 6
        Black = 0
        Blue  = 1
        Red   = 4
      END IF
      IF(imode .eq. 7)THEN
        White = 7
        Yellow= 7
        Black = 0
        Blue  = 0
        Red   = 0
      END IF
c---------black on white if mode 7 , else, yellow-f & blue-b
      call setab(iattr,Yellow,Blue,0,0)
      call revab(iattr,ibattr)
c---------background screen
      call wopen(iwid0,ibattr,iattr,0,0,23,78,char(0),1,0,0)

c----------program title & copy notice
      call wopen(iwid1,ibattr,iattr,2,19,8,40,char(0),2,0,0)
      call wopen(iwid2,ibattr,iattr,3,29,1,18,char(0),1,0,0)
      call wprint(iwid2,'  FAT-Video 1.20`')
      call wsetcp(iwid1,5,3)
      call wprint(iwid1,' Fortran Accessory Tools for Video`')
      call wsetcp(iwid1,7,3)
      call wprint(iwid1,' Copyright (c) 1987 Marc A. Norton`')

c---------share info
      call wopen(iwid3,ibattr,iattr,14,4,8,72,char(0),1,0,0)
      call wcrlf(iwid3)
      call wprint(iwid3,'  This is shareware software and may`')
      call wprint(iwid3,' be freely distributed, so long as all`')
      call wprint(iwid3,' shareware notices are left intact. Only`')
      call wprint(iwid3,' registered users will receive any`')
      call wprint(iwid3,' support for this product, as well as`')
      call wprint(iwid3,' upgrade`')
      call wprint(iwid3,' information. Registered owners also receive`')
      call wprint(iwid3,' the window source code.`')
      call wprint(iwid3,'   This demo may not work well if you`')
      call wprint(iwid3,' are using a color emulation board, using `')
      call wprint(iwid3,' shades of gray. If so, please switch to the`')
      call wprint(iwid3,' mono-mode.`')
      call wsetcp(iwid3,8,21)
      call wprint(iwid3,'Look for FAT-DOS, coming soon...`')


c---------shareware notice
      call wsetcp(iwid0,14,27)
      call setab(iattr1,Yellow,Blue,0,1)
      call wprnas(iwid0,iattr1,' ** Shareware Notice ** `')
      call setcp(25,0,0)

c--------wait for em to read this.
      call wait(12)
c---------close shareware notice
      call wclose(iwid3)

c--------put up file prompts
  150 call wopen(iwid3,ibattr,iattr,13,19,6,40,char(0),1,0,0)
      call wcrlf(iwid3)
      call wprint(iwid3,'     F1  -> Enter First Name`')
      call wcrlf(iwid3)
      call wprint(iwid3,'     F2  -> Enter Last Name`')
      call wcrlf(iwid3)
      call wprint(iwid3,'     F3  -> Start Demo`')
c     call wcrlf(iwid3)
c     call wprint(iwid3,'     F10 -> Exit  Demo`')

c---------get keystroke
      call setcp(25,0,0)
  200 call rdkbd(icode,ikey)

c-----------F1 ----Input file
      if(icode.eq.59)then
      call wopen(iwid4,ibattr,iattr,16,13,1,50,
     $'Your First Name`',1,0,0)
      call wprint(iwid4,' File: `')
      call wgetse(iwid4,iattr,infil,35)
      call wsetcp(iwid0,22,3)
      call wprint(iwid0,'                                    `')
      call wsetcp(iwid0,22,3)
      call wprint(iwid0,infil)
      call wclose(iwid4)
      end if
c----------F2 -----Output file
      if(icode.eq.60)then
      call wopen(iwid4,ibattr,iattr,16,13,1,50,
     $'Your Last Name`',1,0,0)
      call wprint(iwid4,' File: `')
      call wgetse(iwid4,iattr,outfil,35)
      call wsetcp(iwid0,23,3)
      call wprint(iwid0,'                                    `')
      call wsetcp(iwid0,23,3)
      call wprint(iwid0,outfil)
      call wclose(iwid4)
      end if
c----------F3  Continue
      if(icode.eq.61)go to 210
c----------F10  Exit Demo
c      if(icode.eq.68)stop
c-----------hide the cursor
      call setcp(25,0,0)
      go to 200

c------exit
  210 continue
      call wclose(iwid3)
      call wclose(iwid2)
      call wclose(iwid1)
      call wclose(iwid0)
      return
      end



