home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast2.iso / fortran / fv121s.zip / DEMO.FOR < prev    next >
Text File  |  1988-05-28  |  18KB  |  553 lines
  1. c========================================================
  2. c
  3. c       demo.for        FAT-Video 1.20 Updated 1/28/88
  4. c
  5. c       Window demo for FAT-Video 1.20.
  6. c
  7. c          This program works with CGA,EGA and MONO
  8. c       monitors in modes 3 or 7.
  9. c
  10. c       marc a. norton
  11. c=========================================================
  12.       INTEGER*2 attr,ulr,ulc,nr,nc,rattr,xattr,i,j,k,l,icol
  13.       INTEGER*2 fore,back,inten,blink,mode,ncols,page,battr
  14.       INTEGER*2 scan,key,wid1,wid2,wid3,wids,wdx(16),wid0
  15.       integer*2 White,Yellow
  16.       integer*2 Black,Blue,Red
  17.       character title*80,string*80,infil*35,outfil*35
  18.       logical   POP
  19.       character    adap*3
  20.       INTEGER*2    isel,iopt,ii,ipos,im,ikey
  21.       character*20 prnam(10)
  22.       character*50 itnam(20),itmen(20)
  23. c----------------------------------------------------------------------
  24. c   prnam must be declared as char*20 for compatability with menbar().
  25. c   itnam must be declared as char*50 for compatability with wmenu().
  26. c----------------------------------------------------------------------
  27.  
  28. c------- get adapter
  29.       call cls()
  30.       call getmod(mode,ncols,page)
  31.       call getadp(adap)
  32.       IF(mode .eq. 3)THEN
  33.         White = 7
  34.         Yellow= 6
  35.         Black = 0
  36.         Blue  = 1
  37.         Red   = 4
  38.       END IF
  39.       IF(mode .eq. 7)THEN
  40.         White = 7
  41.         Yellow= 7
  42.         Black = 0
  43.         Blue  = 0
  44.         Red   = 0
  45.       END IF
  46.  
  47. c--------set border, if were on a true CGA adapter, not EGA in mode 3
  48. c        border on EGA is set with the overscan register.
  49.       if(adap.eq.'CGA')call setbc(7)
  50.  
  51. c------opening display-----------------
  52.       call opndis(infil,outfil)
  53.       call cls()
  54.  
  55.       inten=0
  56.       blink=0
  57.       call setab(attr,White,Blue,inten,blink)
  58. c---------make borderless backdrop window
  59.       call wopen(wids,attr,attr,0,0,23,78,char(0),0,0,0)
  60.   105 continue
  61.  
  62. c----------loc of window of ulr,ulc for window #1
  63.       ulr=3
  64.       ulc=10
  65.       nr = 15
  66.       nc = 60
  67. c--------------set window colors
  68.       inten= 0
  69.       blink= 0
  70. c----------setup the attr byte
  71.       call setab(attr,Yellow,Black,inten,blink)
  72.       call revab(attr,battr)
  73. c-----------open window #1
  74.       title='1: FAT-Video Demo`'
  75.       call setnul(title)
  76.       call wopen(wid1,battr,attr,ulr,ulc,nr,nc,title,1,0,0)
  77.  
  78. c-----------write a line of txt
  79.       title='    This is a demonstration of the simple`'
  80.       call wprint(wid1,title)
  81.       title=' windowing that can be performed with the`'
  82.       call wprint(wid1,title)
  83.       title=' FAT-Video utilities, in Fortran.`'
  84.       call wprint(wid1,title)
  85.       call wprint(wid1,' Notice, if you have a CGA monitor`')
  86.       call wprint(wid1,' the border color is now set, and`')
  87.       call wprint(wid1,' we have a background screen to work on. `')
  88.       call wcrlf(wid1)
  89.       call wprint(wid1,' Press a key to continue...`')
  90.       call rdkbd(scan,key)
  91.  
  92.       call wcls(wid1)
  93.       call wprint(wid1,' First we will examine some text i/o.`')
  94.       call wcrlf(wid1)
  95.       call wprint(wid1,' Press a key, and notice the key is echoed`')
  96.       call wprint(wid1,' to the screen.`')
  97.       call revab(attr,rattr)
  98.       call wgetce(wid1,rattr,key)
  99.       call wcrlf(wid1)
  100.       call wprint(wid1,' Enter a string and press return: `')
  101.       call setab(rattr,White,Blue,0,0)
  102.  
  103.       call wgetse(wid1,rattr,string,15)
  104.       call wcrlf(wid1)
  105.       call wprint(wid1,' Enter a string, and press return,`')
  106.       call wprint(wid1,' notice there is no echo.`')
  107.       call wgetsn(wid1,string,15)
  108.       call wcrlf(wid1)
  109.       call wprint(wid1,' Your string was: `' )
  110.       call wprint(wid1,string)
  111.       call wcrlf(wid1)
  112.       call wprint(wid1,' Press a key to continue.`')
  113.       call rdkbd(scan,key)
  114.  
  115.       call wcls(wid1)
  116.       call wprint(wid1,'  These have been some examples of the`')
  117.       call wprint(wid1,' kind of text input and output available`')
  118.       call wprint(wid1,' with or without the`')
  119.       call wprint(wid1,' windows, using the FAT-Video libraries.`')
  120.       call wprint(wid1,'  Examine the demo source code to see how`')
  121.       call wprint(wid1,' easy it is to use the window, and video`')
  122.       call wprint(wid1,' library functions. They are all simple`')
  123.       call wprint(wid1,' subroutine calls, but they provide some`')
  124.       call wprint(wid1,' very powerful tools for writing pleasant`')
  125.       call wprint(wid1,' user interfaces.`')
  126.       call wcrlf(wid1)
  127.       call wprint(wid1,' Press any key to continue...`')
  128.       call RDKBD(SCAN,KEY)
  129.       call wcls(wid1)
  130.  
  131. c--------------go to menuing now...
  132.       call wprint(wid1,' We will go on to menus now. There are 3`')
  133.       call wprint(wid1,' types of menus in FAT-Video. The first is`')
  134.       call wprint(wid1,' the menu-bar, it is the master menu and it`')
  135.       call wprint(wid1,' appears in row 1 of the window it is`')
  136.       call wprint(wid1,' placed in. The second is the Pull-Down menu,`')
  137.       call wprint(wid1,' it drops from`')
  138.       call wprint(wid1,' under the main menu-item selected.  The`')
  139.       call wprint(wid1,' third`')
  140.       call wprint(wid1,' is the Pop-Up menu, it just pops up on`')
  141.       call wpriNT(WID1,' screen`')
  142.       call wprint(wid1,' wherever you want.`')
  143.       call wprint(wid1,' Before we look at the menus, here`')
  144.       call wprint(wid1,' are some simple rules to follow:`')
  145.       call wcrlf(wid1)
  146.       call wcrlf(wid1)
  147.       call wprint(wid1,'   To move around, use the arrow keys.`')
  148.       call wcrlf(wid1)
  149.       call wprint(wid1,'   To select a menu-item, press return.`')
  150.       call wcrlf(wid1)
  151.       call wprint(wid1,'   To exit, without selecting, press Esc.`')
  152.       call wcrlf(wid1)
  153.       call wprint(wid1,'   To exit  the menus, select Exit.`')
  154.       call wcrlf(wid1)
  155.       call wcrlf(wid1)
  156.       call wprint(wid1,' Thats it, press a key to go on...`')
  157.       call RDKBD(SCAN,KEY)
  158.       call wcls(wid1)
  159.  
  160. c-----------DEFINE MAIN MENU ITEMS
  161.       prnam(1)='Menus`'
  162.       prnam(2)='Disk`'
  163.       prnam(3)='Math`'
  164.       prnam(4)='Special`'
  165.       prnam(5)='Junk`'
  166.       prnam(6)='Memory`'
  167.       prnam(7)='Exit`'
  168.       prnam(8)=char(0)
  169.  
  170. c---------define Menus-items
  171.       itmen(1) = ' Pop-Up    Menus `'
  172.       itmen(2) = ' Pull-Down Menus `'
  173.       itmen(3) = '`'
  174.  
  175. c----------- define dummy menu items here
  176.       itnam(1)  = 'item number 1  `'
  177.       itnam(2)  = 'item number 2  `'
  178.       itnam(3)  = 'item number 3  `'
  179.       itnam(4)  = 'item number 4  `'
  180.       itnam(5)  = 'item number 5  `'
  181.       itnam(6)  = 'item number 6  `'
  182.       itnam(7)  = 'item number 7  `'
  183.       itnam(8)  = 'item number 8  `'
  184.       itnam(9)  = 'item number 9  `'
  185.       itnam(10) = 'item number 10 `'
  186.       itnam(11) = 'item number 11 `'
  187.       itnam(12) = 'item number 12 `'
  188.       itnam(13)=char(0)
  189.  
  190. c-----------place some text, but not in row #1 !!!
  191.       call wsetcp(wid1,2,1)
  192.       call wprint(wid1,'   As you play with the menuing features`')
  193.       call wprint(wid1,' take notice that the sliding-bar menu in`')
  194.       call wprint(wid1,' row 1 may have diffent colors than the`')
  195.       call wprint(wid1,' Pop-Up and Pull-Down menus. The 1st item`')
  196.       call wprint(wid1,' in the Main menu is Menus, it is the only`')
  197.       call wprint(wid1,' functional menu in the demo. It can `')
  198.       call wprint(wid1,' dynamically switch between Pop-Up and`')
  199.       call wprint(wid1,' Pull-Down menus. Try the menus out, and`')
  200.       call wprint(wid1,' examine the source code, they are easy to`')
  201.       call wprint(wid1,' make and use.`')
  202.       POP = .FALSE.
  203. c---------start position of selected menu
  204.       call curoff()
  205.       ipos = 1
  206.   130 call revab(attr,rattr)
  207.       call menbar(wid1,prnam,attr,rattr,isel,ipos)
  208.       if(isel.eq.7)go to135
  209.       if(isel .eq. 0)go to 130
  210.  
  211. c--------select colors
  212.       call setab(xattr,White,Blue,0,0)
  213. C      call revab(xattr,rattr)
  214.       icol=30
  215.  
  216. c----------call Pop-Up or Pull-Down Menus
  217.       if(POP)then
  218.        if(isel.eq.1)then
  219.          call wmenu(itmen,attr,rattr,7,icol,prnam(isel),isel)
  220.         if(isel.eq.1)POP=.TRUE.
  221.         if(isel.eq.2)POP=.FALSE.
  222.         else
  223.          call wmenu(itnam,attr,rattr,7,icol,prnam(isel),isel)
  224.        end if
  225.       else
  226.        if(isel.eq.1)then
  227.         call menu1(wid1,prnam,itmen,attr,rattr,isel)
  228.         if(isel.eq.1)POP=.TRUE.
  229.         if(isel.eq.2)POP=.FALSE.
  230.        else
  231.         call menu1(wid1,prnam,itnam,attr,rattr,isel)
  232.        end if
  233.       end if
  234. c-----------------------
  235.       go to 130
  236.   135 continue
  237. c----------turn cursor on again
  238.       call curon()
  239.  
  240.  
  241. c----------------open 2nd window
  242.       ulr=4
  243.       ulc=10
  244.       nr = 6
  245.       nc = 45
  246.       title='2:`'
  247.       fore=White
  248.       back=Blue
  249.       if(mode.eq.3)then
  250.         fore=fore+1
  251.         if(fore.eq.16)fore=0
  252.         back=back+1
  253.         if(back.eq.8)back=0
  254.       end if
  255. c----------setup the attr byte
  256.       call setab(attr,fore,back,0,0)
  257.       call revab(attr,battr)
  258.       call wxopen(wid2,battr,attr,ulr,ulc,nr,nc,title,1,0,0)
  259.  
  260.       call wprint(wid2,' Did you notice this window expanded`')
  261.       call wprint(wid2,' on opening. This window will perform`')
  262.       call wprint(wid2,' scrolling, and will move around the`')
  263.       call wprint(wid2,' screen, while retaining all of its`')
  264.       call wprint(wid2,' previously written contents.`')
  265.       call wprint(wid2,' Press any key to continue...`')
  266.       call rdkbd(scan,key)
  267.       call wcls(wid2)
  268. c-----------write some stuff to this window
  269.       call wprint(wid2,' F1 - save screen`')
  270.       call wcrlf(wid2)
  271.       call wprint(wid2,' F2 - get screen `')
  272.       call wcrlf(wid2)
  273.       call wprint(wid2,' F3 - save window`')
  274.       call wcrlf(wid2)
  275.       call wprint(wid2,' F4 - get window `')
  276.       call wcrlf(wid2)
  277.       call wprint(wid2,' Press any key to scroll`')
  278.       call rdkbd(scan,key)
  279.       do 99 i=1,15
  280.         call wcrlf(wid2)
  281.         call wprint(wid2,' data.....`')
  282.         call wcrlf(wid2)
  283.         call wprint(wid2,' more data...`')
  284.    99 continue
  285. c
  286. c      MOVE THE WINDOWS AROUND HERE...
  287. c
  288.       title=' Press any key to move the window`'
  289.       call wcrlf(wid2)
  290.       call wprint(wid2,title)
  291.       call rdkbd(scan,key)
  292.  
  293.       call wmovr(wid2,5,10)
  294.       call wcrlf(wid2)
  295.       call wprint(wid2,title)
  296.       call RDKBD(SCAN,KEY)
  297.  
  298.       call wmovr(wid2,-5,0)
  299.       call wcrlf(wid2)
  300.       call wprint(wid2,title)
  301.       call RDKBD(SCAN,KEY)
  302.  
  303.       call wmovr(wid2,5,-10)
  304.       call wcrlf(wid2)
  305.       call wprint(wid2,title)
  306.       call RDKBD(SCAN,KEY)
  307.  
  308.       call wmova(wid2,5,30)
  309.       call wcrlf(wid2)
  310.       call wprint(wid2,title)
  311.       call RDKBD(SCAN,KEY)
  312.  
  313.       call wmova(wid2,0,0)
  314.       call wcrlf(wid2)
  315.       call wprint(wid2,title)
  316.       call RDKBD(SCAN,KEY)
  317.  
  318.       call wmova(wid2,5,10)
  319.       call wcrlf(wid2)
  320.       call wprint(wid2,' Press any key to continue...`')
  321.       call RDKBD(SCAN,KEY)
  322.  
  323. c-----------------------open 3rd window
  324.       ulr=10
  325.       ulc=30
  326.       nr= 10
  327.       nc= 40
  328.       title='3:`'
  329.       fore=White
  330.       back=Blue
  331. c----------setup the attr byte
  332.       call setab(attr,fore,back,inten,blink)
  333.       call setab(rattr,back,fore,inten,blink)
  334.       call wopen(wid3,rattr,attr,ulr,ulc,nr,nc,title,1,0,0)
  335. c----------play with the window # 3
  336.       call wprnas(wid3,rattr,' You may write to windows using`')
  337.       call wprnas(wid3,rattr,' any attribute you like, to define`')
  338.       call wprnas(wid3,rattr,' the foreground and background colors`')
  339.       call wprnas(wid3,rattr,' of the text.`')
  340.       call wprint(wid3,' Then again you can just print text in the`')
  341.       call wprint(wid3,' windows default colors.`')
  342.       call wcrlf(wid3)
  343.       call wprint(wid3,' Press a key to clear screen`')
  344.       call RDKBD(SCAN,KEY)
  345.       call wcls(wid3)
  346.  
  347.       call wprint(wid3,' That cleared the window.`')
  348.       call wprint(wid3,' We can overwrite in a window too,`')
  349.       call wprint(wid3,' as well as use the built in word wrap`')
  350.       call wprint(wid3,' feature. This is not bad.`')
  351.       call wprint(wid3,' The text is not right justified though.`')
  352.  
  353.       call wcrlf(wid3)
  354.       call wprint(wid3,' Press a key to overwrite this line...`')
  355.       call RDKBD(SCAN,KEY)
  356.       call wcrx(wid3)
  357.       call wcleol(wid3)
  358.       call wprint(wid3,' That seems to work.`')
  359.       call wcrlf(wid3)
  360.       call wprint(wid3,' Press a key to go on...`')
  361.       call RDKBD(SCAN,KEY)
  362.  
  363. c----------------------show some windows
  364.       do 889 im=6,18,6
  365.       ii=-1
  366.       do 888 j=1,16
  367.       write(unit=title(1:4),fmt='(i2,''*''a)')j,char(0)
  368.       ii=ii+1
  369.       if(ii.gt.7)ii=0
  370.       k=j-1
  371.       ulr=j
  372.       ulc=j+im+2
  373.       nr=7
  374.       nc=30
  375.       if(k.eq.ii)k=ii+3
  376.       if(mode.eq.7)k=7
  377.       if(mode.eq.7)ii=0
  378.       call setab(attr,k,ii,0,0)
  379.       call revab(attr,battr)
  380.       call wopen(wdx(j),battr,attr,ulr,ulc,nr,nc,title,1,0,1)
  381.   888 continue
  382.       call wprint(wdx(16),'Press a key to continue...`')
  383.       call RDKBD(SCAN,KEY)
  384.       do 889 j=16,1,-1
  385.       call wclose(wdx(j))
  386.   889 continue
  387. c
  388. c-----------close and clean up windows.
  389. c-----------delete window #3
  390.       call wclose(wid3)
  391.  
  392. c-----------wait for key
  393.       call wcls(wid2)
  394.       title='Press a key to continue...`'
  395.       call wprint(wid2,title)
  396.       call RDKBD(SCAN,KEY)
  397. c---------close w#2
  398.       call wclose(wid2)
  399.  
  400. c-----------wait for key
  401.       call wcls(wid1)
  402.       call wsetcp(wid1,5,10)
  403.       title='Press any key to repeat Demo, ESC to quit.`'
  404.       call wprint(wid1,title)
  405.       call RDKBD(SCAN,KEY)
  406. c---------close w#1
  407.       call wclose(wid1)
  408.  
  409. c---------loop or quit ?
  410.       if(key.eq.27)go to 200
  411.       go to 105
  412.  
  413.   200 continue
  414. c---------close background screen
  415.       call wclose(wids)
  416.  
  417.       end
  418.  
  419.  
  420. C==============================================================
  421. C
  422. C       opndis.for
  423. C
  424. C          This is the opening display for FAT-Video 1.0
  425. C
  426. C       Marc A. Norton
  427. C===============================================================
  428.       subroutine opndis(infil,outfil)
  429.       character*35 infil,outfil,char*1
  430.       integer*2  imode,inc,ipage,icode,iattr1
  431.       integer*2  White,Yellow
  432.       integer*2  Blue,Black,Red
  433.       integer*2  ibattr,iattr,iwid0,iwid1,iwid2,iwid3,iwid4,ikey
  434.  
  435.       call getmod(imode,inc,ipage)
  436.       IF(imode .eq. 3)THEN
  437.         White = 7
  438.         Yellow= 6
  439.         Black = 0
  440.         Blue  = 1
  441.         Red   = 4
  442.       END IF
  443.       IF(imode .eq. 7)THEN
  444.         White = 7
  445.         Yellow= 7
  446.         Black = 0
  447.         Blue  = 0
  448.         Red   = 0
  449.       END IF
  450. c---------black on white if mode 7 , else, yellow-f & blue-b
  451.       call setab(iattr,Yellow,Blue,0,0)
  452.       call revab(iattr,ibattr)
  453. c---------background screen
  454.       call wopen(iwid0,ibattr,iattr,0,0,23,78,char(0),1,0,0)
  455.  
  456. c----------program title & copy notice
  457.       call wopen(iwid1,ibattr,iattr,2,19,8,40,char(0),2,0,0)
  458.       call wopen(iwid2,ibattr,iattr,3,29,1,18,char(0),1,0,0)
  459.       call wprint(iwid2,'  FAT-Video 1.20`')
  460.       call wsetcp(iwid1,5,3)
  461.       call wprint(iwid1,' Fortran Accessory Tools for Video`')
  462.       call wsetcp(iwid1,7,3)
  463.       call wprint(iwid1,' Copyright (c) 1987 Marc A. Norton`')
  464.  
  465. c---------share info
  466.       call wopen(iwid3,ibattr,iattr,14,4,8,72,char(0),1,0,0)
  467.       call wcrlf(iwid3)
  468.       call wprint(iwid3,'  This is shareware software and may`')
  469.       call wprint(iwid3,' be freely distributed, so long as all`')
  470.       call wprint(iwid3,' shareware notices are left intact. Only`')
  471.       call wprint(iwid3,' registered users will receive any`')
  472.       call wprint(iwid3,' support for this product, as well as`')
  473.       call wprint(iwid3,' upgrade`')
  474.       call wprint(iwid3,' information. Registered owners also receive`')
  475.       call wprint(iwid3,' the window source code.`')
  476.       call wprint(iwid3,'   This demo may not work well if you`')
  477.       call wprint(iwid3,' are using a color emulation board, using `')
  478.       call wprint(iwid3,' shades of gray. If so, please switch to the`')
  479.       call wprint(iwid3,' mono-mode.`')
  480.       call wsetcp(iwid3,8,21)
  481.       call wprint(iwid3,'Look for FAT-DOS, coming soon...`')
  482.  
  483.  
  484. c---------shareware notice
  485.       call wsetcp(iwid0,14,27)
  486.       call setab(iattr1,Yellow,Blue,0,1)
  487.       call wprnas(iwid0,iattr1,' ** Shareware Notice ** `')
  488.       call setcp(25,0,0)
  489.  
  490. c--------wait for em to read this.
  491.       call wait(12)
  492. c---------close shareware notice
  493.       call wclose(iwid3)
  494.  
  495. c--------put up file prompts
  496.   150 call wopen(iwid3,ibattr,iattr,13,19,6,40,char(0),1,0,0)
  497.       call wcrlf(iwid3)
  498.       call wprint(iwid3,'     F1  -> Enter First Name`')
  499.       call wcrlf(iwid3)
  500.       call wprint(iwid3,'     F2  -> Enter Last Name`')
  501.       call wcrlf(iwid3)
  502.       call wprint(iwid3,'     F3  -> Start Demo`')
  503. c     call wcrlf(iwid3)
  504. c     call wprint(iwid3,'     F10 -> Exit  Demo`')
  505.  
  506. c---------get keystroke
  507.       call setcp(25,0,0)
  508.   200 call rdkbd(icode,ikey)
  509.  
  510. c-----------F1 ----Input file
  511.       if(icode.eq.59)then
  512.       call wopen(iwid4,ibattr,iattr,16,13,1,50,
  513.      $'Your First Name`',1,0,0)
  514.       call wprint(iwid4,' File: `')
  515.       call wgetse(iwid4,iattr,infil,35)
  516.       call wsetcp(iwid0,22,3)
  517.       call wprint(iwid0,'                                    `')
  518.       call wsetcp(iwid0,22,3)
  519.       call wprint(iwid0,infil)
  520.       call wclose(iwid4)
  521.       end if
  522. c----------F2 -----Output file
  523.       if(icode.eq.60)then
  524.       call wopen(iwid4,ibattr,iattr,16,13,1,50,
  525.      $'Your Last Name`',1,0,0)
  526.       call wprint(iwid4,' File: `')
  527.       call wgetse(iwid4,iattr,outfil,35)
  528.       call wsetcp(iwid0,23,3)
  529.       call wprint(iwid0,'                                    `')
  530.       call wsetcp(iwid0,23,3)
  531.       call wprint(iwid0,outfil)
  532.       call wclose(iwid4)
  533.       end if
  534. c----------F3  Continue
  535.       if(icode.eq.61)go to 210
  536. c----------F10  Exit Demo
  537. c      if(icode.eq.68)stop
  538. c-----------hide the cursor
  539.       call setcp(25,0,0)
  540.       go to 200
  541.  
  542. c------exit
  543.   210 continue
  544.       call wclose(iwid3)
  545.       call wclose(iwid2)
  546.       call wclose(iwid1)
  547.       call wclose(iwid0)
  548.       return
  549.       end
  550.  
  551.  
  553.