home *** CD-ROM | disk | FTP | other *** search
- 1 '************************* TITLEDEM.BAS ******************************
- 2 '********* written for I.B. Magazette by: KARL MINOR ************
- 3 COMMON ADDR.%, CLOCK.ON%
- 4 KEY OFF: SCREEN 0: WIDTH 80: KEY(8) ON: ON KEY(8) GOSUB 65000
- 5 DEF SEG = 0: IF (PEEK(&H410) AND &H30) <> &H30 THEN GRAPH.ICS=1
- 6 IF GRAPH.ICS THEN FC=3: BC=4 ELSE FC=7
- 7 COLOR FC,0,BC: CLS
- 8 DEF SEG:IF PEEK(3)<>195 AND PEEK(6)<>0 THEN IBMPC=0 ELSE IBMPC=1
- 50 MSG$="TITLE":TD.Y1%=3:COLOR FC+6:GOSUB 50000
- 60 MSG$="SCREENS":TD.Y1%=13:GOSUB 50000
- 70 GOSUB 8000
- 100 CLS:COLOR FC
- 110 LOCATE 8,13:PRINT "This program is a demonstration of a BASIC subroutine"
- 120 LOCATE ,13:PRINT "that can be easily merged into your BASIC programs and"
- 130 LOCATE ,13:PRINT "called with a single line of code. It will present a"
- 140 LOCATE ,13:PRINT "title screen similar to the one at the beginning of this"
- 150 LOCATE ,13:PRINT "program. The title can be placed anywhere on the screen,"
- 160 LOCATE ,13:PRINT "but the routine will automatically center the title if"
- 170 LOCATE ,13:PRINT "you do not specify a column. The title can be displayed"
- 180 LOCATE ,13:PRINT "in any color if a color monitor is attached, but will"
- 190 LOCATE ,13:PRINT "also work with monochrome monitors."
- 200 Y1=6:Y2=18:X1=10:X2=71:COLOR 7:GOSUB 8100
- 210 GOSUB 8000
- 300 CLS:COLOR FC,0
- 310 COLOR 7:LOCATE 3,32:PRINT "USING THE ROUTINE"
- 320 COLOR FC:LOCATE 5,5 :PRINT " The following variables are passed to the routine in order to create"
- 322 LOCATE ,5 :PRINT " a title screen. The routine itself is located at line ";:COLOR FC+8:PRINT "50000";:COLOR FC:PRINT ". To use"
- 324 LOCATE ,5 :PRINT "it in your own programs, save the routine to disk by itself in ASCII"
- 326 LOCATE ,5 :PRINT "format, then MERGE it into your program. See the BASIC manual for "
- 328 LOCATE ,5: PRINT "more information concerning the MERGE command."
- 330 COLOR FC+8:LOCATE 11,10:PRINT "MSG$";:COLOR FC:PRINT " ..... This is the word or characters you want printed on"
- 332 LOCATE 12,10:PRINT " the screen. It can be no longer than ten characters."
- 334 COLOR FC+8:LOCATE 14,10:PRINT "TD.Y1% ";:COLOR FC:PRINT "... (optional) Specifies the starting row of the title."
- 336 LOCATE 15,10:PRINT " If TD.Y1% is omitted, the title will be centered"
- 338 LOCATE 16,10:PRINT " vertically by the routine."
- 340 COLOR FC+8:LOCATE 18,10:PRINT "TD.X1%";:COLOR FC:PRINT " ... (optional) Specifies the starting column of the"
- 342 LOCATE 19,10:PRINT " title. If TD.X1% is omitted, the title will be"
- 344 LOCATE 20,10:PRINT " centered horizontally."
- 346 LOCATE 22,5 :PRINT " The color of the title will be the current foreground color."
- 350 GOSUB 8000
- 400 CLS:COLOR 7
- 410 LOCATE 2,29:PRINT "SAMPLE SUBROUTINE CALL"
- 412 COLOR FC:LOCATE 4, 5:PRINT "The line below is a sample call of the TITLE subroutine. Press a key"
- 414 LOCATE 5, 5:PRINT "to see the result of this line of code."
- 416 LOCATE 7,10:PRINT "100 MSG$ = ";CHR$(34);"Sample!";CHR$(34);" : TD.Y1%=15 : GOSUB 50000"
- 420 GOSUB 8000
- 430 MSG$="Sample!" : TD.Y1%=15 : GOSUB 50000
- 440 GOSUB 8000
- 500 CLS:COLOR FC:LOCATE 3,8:PRINT "Enter any message of ten characters or less at the prompt below."
- 510 LOCATE 5,34:ALLEN%=10:GOSUB 9500
- 520 MSG$=NTRY$:COLOR 10:GOSUB 50000
- 530 GOSUB 8000
- 540 GOTO 500
- 3000 LIST 50000-50200,"TITLERT9.BAS"
- 8000 '********** pause until keypress ***************
- 8010 DEF SEG=0:POKE &H41A,PEEK(&H41C)
- 8020 COLOR 14:LOCATE 24,20:PRINT "Press any key to continue, or F8 to exit.";
- 8030 I$=INKEY$:IF I$="" THEN 8030 ELSE SOUND 500,.01:SOUND 100,0:RETURN
- 8032 '************************************************
- 8050 '********** wait for selection *********
- 8055 DEF SEG=0:POKE &H41A,PEEK(&H41C)
- 8060 COLOR 14:LOCATE 24,19:PRINT "Press selection to continue, or F8 to exit.";
- 8065 I$=INKEY$:IF I$="" THEN 8030 ELSE SOUND 500,.51:SOUND 100,0:RETURN
- 8100 '**** routine to draw a box on the text screen, given the upper left ***** **** and lower right corners(x1,y1,x2,y2)
- 8105 LOCATE Y1,X1+1:PRINT STRING$(X2-X1-1,"─");:LOCATE Y1,X1:PRINT "┌";:LOCATE Y1,X2:PRINT "╖";:FOR BOXROW = Y1+1 TO Y2-1:LOCATE BOXROW,X1:PRINT "│";:LOCATE BOXROW,X2:PRINT "║";:NEXT BOXROW:LOCATE Y2,X1:PRINT "╘";:LOCATE Y2,X1+1
- 8110 PRINT STRING$(X2-X1-1,"═");
- 8115 LOCATE Y2,X2:PRINT "╝";
- 8120 RETURN
- 8125 '**** routine to erase that last box drawn ********
- 8130 LOCATE Y1,X1+1:PRINT STRING$(X2-X1-1," ");:LOCATE Y1,X1:PRINT " ";:LOCATE Y1,X2:PRINT " ";:FOR BOXROW = Y1+1 TO Y2-1:LOCATE BOXROW,X1:PRINT " ";:LOCATE BOXROW,X2:PRINT " ";:NEXT BOXROW:LOCATE Y2,X1:PRINT " ";:LOCATE Y2,X1+1
- 8135 PRINT STRING$(X2-X1-1," ");
- 8140 LOCATE Y2,X2:PRINT " ";
- 8145 RETURN
- 9500 '*******************************************************
- 9505 '* ALPHABETIC INPUT ROUTINE *
- 9510 '*******************************************************
- 9515 PRINT STRING$(ALLEN%,CHR$(176));:FOR AZX= 1 TO ALLEN%:PRINT CHR$(29);:NEXT AZX
- 9520 NTRY$=""
- 9525 KK$=INKEY$: IF KK$="" THEN 9525
- 9526 KK%=ASC(KK$): IF LEN(KK$)>1 AND RIGHT$(KK$,1)=CHR$(75) THEN 9555
- 9530 IF KK%=13 THEN GOTO 9580 'End of entry
- 9535 IF KK%=8 THEN GOTO 9555 'Backspace
- 9540 IF KK%>31 OR (KK%<28 AND KK%>13) OR (KK%<8 AND KK%>0) THEN PRINT KK$;: NTRY$=NTRY$+KK$ 'Echo keystroke and add to entry
- 9545 IF LEN(NTRY$) = ALLEN% THEN 9580 'Entry full
- 9550 GOTO 9525 'Get another character
- 9555 '**** Backspace
- 9560 IF LEN(NTRY$)=0 THEN 9525 'Not if entry is empty
- 9565 PRINT CHR$(29);STRING$(1,176);CHR$(29); 'Redisplay box
- 9570 NTRY$=LEFT$(NTRY$,LEN(NTRY$)-1) 'Delete last character
- 9575 GOTO 9525 'Get next character
- 9580 IF LEN(NTRY$)=0 THEN BEEP :GOTO 9520 ELSE PRINT SPACE$(ALLEN% - LEN(NTRY$));
- 9585 RETURN
- 50000 '========== display TITLE routine ==============
- 50001 '┌──────────────────────────────────────────────────────────────────┐
- 50002 '│ Define MSG$ before entering. │
- 50003 '│ TD.Y1% and TD.X1% will locate MSG$, but MSG$ will be centered if │
- 50004 '│ they are omitted. Set color with a COLOR statement. │
- 50006 '└──────────────────────────────────────────────────────────────────┘
- 50010 TD.WDTH = 1 ' change to 1,2,or 3 to set width
- 50020 TD.BLK$ =STRING$(TD.WDTH,"█"):TD.BNK$=STRING$(TD.WDTH," ")
- 50030 DEF SEG=0:POKE &H41A,PEEK(&H41C):DEF SEG=&HF000
- 50040 IF LEN(MSG$) >10/TD.WDTH OR LEN(MSG$)<1 OR TD.Y1%>17 THEN RETURN
- 50050 IF TD.X1%=0 THEN TD.X1%=41-INT((LEN(MSG$)/2)*(8*TD.WDTH))
- 50055 IF TD.Y1%=0 THEN TD.Y1%=8
- 50060 FOR TD.C=1 TO LEN(MSG$)
- 50070 TD.S=&HFA6E+ASC(MID$(MSG$,TD.C,1))*8
- 50080 FOR TD.L=TD.S TO TD.S+7
- 50090 TD.V%=PEEK(TD.L)
- 50100 LOCATE TD.Y1%+TD.L-TD.S,TD.X1%
- 50110 IF TD.V% AND 128 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
- 50120 IF TD.V% AND 64 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
- 50130 IF TD.V% AND 32 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
- 50140 IF TD.V% AND 16 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
- 50150 IF TD.V% AND 8 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
- 50160 IF TD.V% AND 4 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
- 50170 IF TD.V% AND 2 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
- 50180 IF TD.V% AND 1 THEN PRINT TD.BLK$ : ELSE PRINT TD.BNK$
- 50190 NEXT TD.L:TD.X1%=TD.X1%+8*TD.WDTH:NEXT TD.C
- 50195 TD.Y1%=0:TD.X1%=0
- 50200 RETURN
- 65000 ' return to magazette
- 65010 SCREEN 0: WIDTH 80: COLOR 14,0
- 65015 ON ERROR GOTO 0:CLOSE
- 65020 IF ADDR.%<>0 THEN LOCATE 25,1,0: PRINT SPACE$(28);"Returning to Magazette";SPACE$(29);: CHAIN "START"
- 65030 CLS: LOCATE 12,35: PRINT"Good-bye!": COLOR 3
- 65040 LOCATE 23,1:END
