home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
fortran
/
library
/
fv
/
demo.for
< prev
next >
Wrap
Text File
|
1988-05-28
|
18KB
|
553 lines
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