home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
xbase
/
library
/
dbase
/
tclitebr
/
pulldown.prg
< prev
Wrap
Text File
|
1987-07-25
|
16KB
|
459 lines
SET EXAC OFF
SET BELL OFF
SET TYPE TO 0
set esca off
************** a more fully commented version of PULLDOWN with be available
************** to registered users -- RF
SET TALK OFF
SET PROC TO pulldown
SET COLO TO w+/b
esca_char=CHR(27)
help_battr='31' && background attr for help, this is color used to "erase"
SET SCOR OFF && set scoreboard off and cls
LOAD DELAY && delay.bin gives a constant delay on different machines
LOAD litebar
CLEA
CALL LITEBAR WITH "0" && turn off cursor
CALL LITEBAR WITH "p0"
m=1.3
CALL DELAY WITH m
CALL LITEBAR WITH "p1"
CALL DELAY WITH m
blankcolor=IIF(ISCO(),"17","0") && if color, our blank color is 17 (blue on blue)
SET TYPE TO 1
CALL litebar WITH "l0,0,0,24,79,"+blankcolor && blank box
@24,0 SAY " Do you see snow on the screen? (Y/N)"
key = 0
CALL litebar WITH CHR(6)
DO WHIL .NOT. (LTRI(STR(key))$("78,110,121,89")) .OR. (key=0)
CALL litebar WITH "C0,0,23,79,"+blankcolor
key=INKEY()
ENDDO
IF LTRI(STR(key))$("89,121")
CALL litebar WITH CHR(5)
ENDI
other_ret=CHR(3) && returned by LITEBAR for trap of other chars
funkreturn=CHR(4) && " " " " " " function keys
rememb_char="M" && char passed to "remember" last param & option
locolor=IIF(ISCO(),"31","111") && if color, "lolited" opts will be color 31
&& (hiwhite on blue)
hicolor=IIF(ISCO(),"111","112") && and "hilited" options hiwhite on amber (W+/GR)
funk_char="K" && char passed to trap fkeys
help_char="H" && char passed for help prompts
low_high="31,111," && as above
time_str='T0,6,' && display time at 0,6
mchoice1="1,9, Menu(1) \1"
mhelp1="\24,20, Press Return or '1' for menu 1 \"
mchoice2="1,28, Menu(2) \2"
mhelp2="\24,20, Press Return or '2' for menu 2 \"
mchoice3="1,47, Menu(3) \3"
mhelp3="\24,20, Press Return or '3' for menu 3 \"
mchoice4="1,66, Menu(4) \4"
mhelp4="\24,20, Press Return or '3' for menu 3 \"
mchoice1=mchoice1+mhelp1
mchoice2=mchoice2+mhelp2
mchoice3=mchoice3+mhelp3
mchoice4=mchoice4+mhelp4
* now put it all together
mchoice=help_char+help_battr+time_str+"/"+low_high+mchoice1+mchoice2+mchoice3+mchoice4
msave=mchoice && save choice 'cause LITEBAR will trash it
REST FROM demomenus ADDI && here's the rest of the menu params
CLEA
@0,0SAY 'Time:'
DO WHIL .T.
SET COLO TO w+/b
CALL litebar WITH mchoice
IF mchoice=esca_char
EXIT
ENDI
IF mchoice=CHR(1)
@23,1 CLEA
@23,1 SAY "Whoops...something screwed up...whaddaya want for free?"
?mchoice
WAIT ''
CANC
ENDI
@24,0SAY SPAC(60)
SET COLO TO w+/gr
DO WHIL .t.
pchoice=mchoice
DO CASE
CASE mchoice='1'
DO menu1
CASE mchoice='2'
DO menu2
CASE mchoice='3'
DO menu3
CASE mchoice='4'
DO menu4
ENDC
IF pchoice=mchoice .OR. mchoice =esca_char
EXIT
ENDI
ENDD
IF mchoice=esca_char
EXIT
ENDI
mchoice='*'+LEFT(pchoice,1)+msave && remember option with last selection
&& hilited
ENDD
CALL LITEBAR WITH "s0" && save screen into buffer 0
CLEA
CALL LITEBAR WITH "j0,0,12,39" && junk top left quadrant
CALL LITEBAR WITH "j13,40,24,79" && and bottom right
CALL LITEBAR WITH "Q0,0,12,39" && zap text from top left in "queer" fashion
CALL LITEBAR WITH "NC178,0,0,12,39" && now add newbits to chars
m=1
CALL delay WITH m
CALL LITEBAR WITH "XC178,0,0,12,39" && reverse those new bits with XOR
CALL delay WITH m
CALL LITEBAR WITH "NC178,0,0,12,39" && add 'em in again
CALL delay WITH m
CALL LITEBAR WITH "XC178,0,0,12,39" && reverse 'em again
CALL delay WITH m
CALL LITEBAR WITH "NC178,0,0,12,39" && add 'em
CALL delay WITH m
CALL LITEBAR WITH "Z0,0,24,79" && zap all text on screen
CALL LITEBAR WITH "XC8,0,0,12,39" && turn on 8 bit of char
CALL delay WITH m
CALL LITEBAR WITH "Z0,0,24,79" && zap all again
CALL LITEBAR WITH "NC221,0,0,24,79" && fill with vertical stripe char
CALL delay WITH m
CALL LITEBAR WITH "XA64,0,0,12,79" && XOR attribute for red
CALL delay WITH m
CALL LITEBAR WITH "Z0,0,24,79" && zap text
CALL LITEBAR WITH "NC14,0,0,24,79" && fill screen with CHR(14)
CALL LITEBAR WITH "XA32,13,0,24,79" && reverse green attribute
CALL delay WITH m
CALL LITEBAR WITH "Z0,0,24,79" && zap text
CALL LITEBAR WITH "NC15,0,0,24,79" && fill with CHR(15)
CALL LITEBAR WITH "XA32,13,0,24,79" && reverse green attribute again
CALL delay WITH m
CALL LITEBAR WITH "Z0,0,24,79" && zap
CALL LITEBAR WITH "NC9,0,0,24,79" && fill with CHR(9)
CALL LITEBAR WITH "XA16,13,0,24,79" && reverse blue attribute
CALL delay WITH m
CALL LITEBAR WITH "Z0,0,24,79" && zap text again
CALL LITEBAR WITH "NC8,0,0,24,79" && fill with CHR(8)
CALL delay WITH m
tparam="R1,0,0,12,79,"+locolor && param for scrolling top half of screen
&& 1 line to the right
bparam="L1,13,0,24,79,"+locolor && param to scroll left 1 line bottom half
curtain=0
DO WHIL curtain<79 && do it 80 times
CALL LITEBAR WITH tparam
CALL LITEBAR WITH bparam
curtain=curtain+1
ENDD
SET ESCA ON
CALL LITEBAR WITH "p0" && pop screen from area 0
CALL LITEBAR WITH "1" && restore cursor
RELE MODU litebar
RELE MODU delay
RETU
PROC menu1
CALL litebar WITH "u0,2,4,9,21,"+blankcolor && blank box
SET COLO TO w+/gr
@2,4TO 9,21 DOUBLE
CALL litebar WITH "C1,9,1,17,"+hicolor && hilite pulldown thingie
m=menu1var
DO WHIL .t.
CALL litebar WITH m
IF m=other_ret
mchoice=IIF(SUBS(m,2,1)=CHR(75),'4','2') && if right or left arrow returned
EXIT && change active choice and we're
ENDI && thru here
IF M="4"
CALL LITEBAR WITH "S0" && save screen into area 0
DO CHECKERS
CALL LITEBAR WITH "Z0,0,24,79" && zap text
@23,0 SAY ''
WAIT
CALL LITEBAR WITH "U0,0,0,24,79,"+locolor && blank screen
CALL LITEBAR WITH "Z0,0,24,79" && zap text
CALL LITEBAR WITH "NC221,0,0,24,79" && fill with vertical stripes
@23,0 SAY ''
wait
CALL LITEBAR WITH "NC223,13,0,24,79" && bottom half with horiz. stripes
@23,0 SAY ''
WAIT
curtain=0
DO WHIL curtain <12 && scroll top up and bottom to left and right
CALL LITEBAR WITH "U1,0,0,12,79,"+locolor
CALL LITEBAR WITH "R4,13,40,24,79,"+locolor
CALL LITEBAR WITH "L4,13,0,24,39,"+locolor
curtain=curtain+1
ENDDO
CALL LITEBAR WITH "P0" && pop screen from area 0
ENDI
IF m=esca_char && user hit escape?
EXIT
ENDI
m=rememb_char+SPAC(10)
ENDD
CALL litebar WITH "C2,4,13,23,"+blankcolor && hide menu with blank color
CALL litebar WITH "C1,9,1,17,"+locolor && "uncolor" top menu selection
RETU
PROC menu2
accpt_resp=CHR(1)+CHR(2)+CHR(3)+CHR(4)
CALL litebar WITH "u0,2,23,9,40,"+blankcolor
@2,23TO 9,40 DOUBLE
CALL litebar WITH "C1,28,1,36,"+hicolor
m=menu2var
CALL litebar WITH m
DO WHIL .T.
IF m=funkreturn .AND.SUBS(m,2,1)$accpt_resp
choice=ASC(SUBS(m,2,1))
CALL litebar WITH "S0"
CALL litebar WITH "C2,23,9,40,"+blankcolor
IF choice=4
CLEA
LIST MEMO
CALL LITEBAR WITH "C0,0,24,79,"+LTRI(STR(VAL(hicolor)+128))
d1=2
CALL DELAY WITH d1
centerrow=12
centercol=39
windowsize=1
windcount=0
DO WHIL windcount<34
mparam="C"+LTRI(STR(INT(centerrow-(windowsize/3))))+","+LTRI(STR(centercol-windowsize+2))+","+LTRI(STR(INT(centerrow+(windowsize/3))))+","+LTRI(STR(centercol+windowsize+2))+","+locolor
CALL LITEBAR WITH mparam
windcount=windcount+1
windowsize=windowsize+1
ENDD
CALL LITEBAR WITH "P0"
m=rememb_char+SPAC(80)
CALL litebar WITH m
LOOP
ENDI
EXIT
ENDI
IF m=other_ret
mchoice=IIF(SUBS(m,2,1)=CHR(75),'1','3')
EXIT
ENDI
IF m=esca_char
EXIT
ELSE
??CHR(7)
@20,0SAY "You must press a func. key or escape to get out of this menu..any key to resume"
WAIT ''
CALL litebar WITH "C20,0,20,80,"+blankcolor
ENDI
m=rememb_char+SPAC(80)
CALL litebar WITH m
ENDD
CALL litebar WITH "C1,28,1,36,"+locolor
CALL litebar WITH "C2,23,13,40,"+blankcolor
RETU
PROC menu3
CALL litebar WITH "u0,2,42,9,59,"+blankcolor
@2,42TO 9,59 DOUBLE
CALL litebar WITH "C1,47,1,55,"+hicolor
m=menu3var
DO WHIL .t.
CALL litebar WITH m
IF m=other_ret
mchoice=IIF(SUBS(m,2,1)=CHR(75),'2','4')
EXIT
ENDI
IF m="3"
CALL LITEBAR WITH "S0"
CALL LITEBAR WITH "U0,11,21,20,58,"+LTRI(STR(VAL(hicolor)))
@12,24 SAY " ░▓▓░░░▓▓░░░▓▓▓░░░▓▓░░░▓▓░░░▓▓░░░"
@13,24 SAY "░░▓▓░░░▓▓░░▓▓░▓▓░░▓▓░░░▓▓░░▓▓▓▓░ "
@14,24 SAY " ░▓▓░░░▓▓░▓▓░░░▓▓░▓▓░░░▓▓░░▓▓▓▓░░"
@15,24 SAY "░░▓▓░▓░▓▓░▓▓░░░▓▓░▓▓░▓░▓▓░░░▓▓░░"
@16,24 SAY " ░▓▓▓▓▓▓▓░▓▓░░░▓▓░▓▓▓▓▓▓▓░░░▓▓░░░"
@17,24 SAY "░░▓▓▓░▓▓▓░░▓▓░▓▓░░▓▓▓░▓▓▓░░░░░░░"
@18,24 SAY " ░▓▓░░░▓▓░░░▓▓▓░░░▓▓░░░▓▓░░░▓▓░░░"
CALL LITEBAR WITH "C11,21,20,58,"+LTRI(STR(VAL(hicolor)+128))
d1=3
CALL DELAY WITH d1
d1=2
CALL LITEBAR WITH "Q11,21,20,58"
CLEA
call litebar with "B1,0, LITEBAR"
call litebar with "B9,0, MAKES"
call litebar with "B17,0, BANNERS"
CALL DELAY WITH d1
CALL LITEBAR WITH "P0"
ENDI
IF m=esca_char
EXIT
ENDI
m=rememb_char+SPAC(10)
ENDD
CALL litebar WITH "C1,47,1,55,"+locolor
CALL litebar WITH "C2,42,13,63,"+blankcolor
RETU
PROC menu4
CALL litebar WITH "u0,2,61,9,78,"+blankcolor
@2,61 TO 9,78 DOUBLE
CALL litebar WITH "C1,66,1,74,"+hicolor
m=menu4var
DO WHIL .t.
CALL litebar WITH m
IF m=other_ret
mchoice=IIF(SUBS(m,2,1)=CHR(75),'3','1')
EXIT
ENDI
IF m="4"
CALL LITEBAR WITH "S0"
CALL LITEBAR WITH "C0,0,20,40,"+hicolor
@22,0 SAY ''
WAIT
CALL LITEBAR WITH "C0,0,10,79,"+locolor
@22,0 SAY ''
WAIT
CALL LITEBAR WITH "C0,0,24,79,"+hicolor
@22,0 SAY ''
WAIT
CALL LITEBAR WITH "NC255,0,0,24,79"
CALL LITEBAR WITH "XC255,0,0,24,79"
@22,0 SAY ''
WAIT
CALL LITEBAR WITH "NC36,0,0,12,79"
@22,0 SAY ''
WAIT
CALL LITEBAR WITH "U0,0,0,24,79,"+locolor
*ascii table works better with FOX <grin>
SET COLO TO W+/B
@10,20 SAY "▄▄▄▄▄▄▄▄▄▄▄▄▄ ASCII TABLE ▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄"
@11,20 SAY "█Dec████ (Better when compiled) █████Hex█"
mchar=0
mrow=12
@4,0 SAY "Litebar is fast==>"
@13,0 SAY "When dBASE is"
@14,0 SAY " just too slow==>"
DO WHIL mrow<20
mcol=24
@mrow,20 SAY mchar PICT "999"
DO WHIL mcol<57 .AND. mchar < 256
coords=LTRI(STR(mrow))+","+LTRI(STR(mcol))+","+LTRI(STR(mrow))+","+LTRI(STR(mcol))
@mrow,mcol SAY CHR(mchar)
CALL LITEBAR WITH "C"+coords+","+LTRI(STR(mchar))
CALL LITEBAR WITH "C4,0,4,18,"+LTRI(STR(mchar))
CALL LITEBAR WITH "C13,0,14,18,"+LTRI(STR(mchar))
CALL LITEBAR WITH "U0,1,20,8,60,"+LTRI(STR(mchar))
CALL LITEBAR WITH "Z1,20,8,60,"+LTRI(STR(mchar))
CALL LITEBAR WITH "NC"+LTRI(STR(mchar))+",1,20,8,60,"
mcol=mcol+1
mchar=mchar+1
ENDD
lhchar=INT((mchar-1)/16)
rhchar=(mchar-(lhchar*16))-1
hexx_char=IIF(lhchar>9,CHR(lhchar+55),CHR(lhchar+48))+IIF(rhchar>9,CHR(rhchar+55),CHR(rhchar+48))
@mrow,58 SAY hexx_char PICT "!!!"
mrow=mrow+1
ENDD
@23,0 SAY ''
WAIT
CALL LITEBAR WITH "S1"
CALL LITEBAR WITH "L15,0,0,24,79,"+hicolor
@22,0 SAY ''
WAIT
CALL LITEBAR WITH "C0,0,24,79,"+locolor
@22,0 SAY ''
WAIT
CALL LITEBAR WITH "R15,0,0,24,79,"+locolor
@22,0 SAY ''
WAIT
CALL LITEBAR WITH "U0,0,0,24,79,"+blankcolor
@22,0 SAY ''
WAIT
CALL LITEBAR WITH "P1"
WAIT ''
RUN DIR /W
IF ISCO()
DO LITESHOW
ENDI
mparam="L1,0,8,24,79,"+locolor
curtain=0
DO WHIL curtain<72
CALL LITEBAR WITH mparam
curtain = curtain+1
ENDD
mparam="U1,0,0,24,20,"+locolor
curtain=0
DO WHIL curtain<25
CALL LITEBAR WITH mparam
curtain=curtain+1
ENDD
CALL LITEBAR WITH "P0"
ENDI
IF m=esca_char
EXIT
ENDI
m=rememb_char+SPAC(10)
ENDD
CALL litebar WITH "C1,66,1,74,"+locolor
CALL litebar WITH "C2,61,13,79,"+blankcolor
RETU
PROC LITESHOW
centerrow=12
centercol=39
windowsize=1
attrcount=0
DO WHIL attrcount<34
mparam="C"+LTRI(STR(INT(centerrow-(windowsize/3))))+","+LTRI(STR(centercol-windowsize+2))+","+LTRI(STR(INT(centerrow+(windowsize/3))))+","+LTRI(STR(centercol+windowsize+2))+","+LTRI(STR(attrcount*16))
CALL LITEBAR WITH mparam
attrcount=attrcount+1
windowsize=windowsize+1
ENDD
DO WHIL attrcount>0
mparam="C"+LTRI(STR(INT(centerrow-(windowsize/3))))+","+LTRI(STR(centercol-windowsize+2))+","+LTRI(STR(INT(centerrow+(windowsize/3))))+","+LTRI(STR(centercol+windowsize+2))+","+LTRI(STR(attrcount*16))
CALL LITEBAR WITH mparam
attrcount=attrcount-1
windowsize=windowsize-1
ENDD
RETU
PROC CHECKERS
msrow=0
attr=VAL(locolor)
aatr=128
DO WHIL msrow<19
mscol=0
merow=","+LTRI(STR(msrow+6))
attr=IIF(attr=VAL(locolor),VAL(hicolor),VAL(locolor))
DO WHIL mscol<61
mecol=","+LTRI(STR(mscol+19))+","
attr=IIF(attr=VAL(locolor),VAL(hicolor),VAL(locolor))
CALL LITEBAR WITH "C"+LTRI(STR(msrow))+","+LTRI(STR(mscol))+merow+mecol+LTRI(STR(attr+IIF(MOD(mscol,40)=0,128,0)))
mscol=mscol+20
ENDD
msrow=msrow+6
ENDD
RETU