home *** CD-ROM | disk | FTP | other *** search
/ RBBS in a Box Volume 1 #3.1 / RBBSIABOX31.cdr / trac / titledem.bas < prev    next >
BASIC Source File  |  1987-01-17  |  8KB  |  127 lines
  1. 1 '*************************  TITLEDEM.BAS  ******************************
  2. 2 '*********    written for I.B. Magazette by:  KARL MINOR    ************
  3. 3 COMMON ADDR.%, CLOCK.ON%
  4. 4 KEY OFF: SCREEN 0: WIDTH 80: KEY(8) ON: ON KEY(8) GOSUB 65000
  5. 5 DEF SEG = 0: IF (PEEK(&H410) AND &H30) <> &H30 THEN GRAPH.ICS=1
  6. 6 IF GRAPH.ICS THEN FC=3: BC=4 ELSE FC=7
  7. 7 COLOR FC,0,BC: CLS
  8. 8 DEF SEG:IF PEEK(3)<>195 AND PEEK(6)<>0 THEN IBMPC=0 ELSE IBMPC=1
  9. 50 MSG$="TITLE":TD.Y1%=3:COLOR FC+6:GOSUB 50000
  10. 60 MSG$="SCREENS":TD.Y1%=13:GOSUB 50000
  11. 70 GOSUB 8000
  12. 100 CLS:COLOR FC
  13. 110 LOCATE  8,13:PRINT "This program is a demonstration of a BASIC subroutine"
  14. 120 LOCATE   ,13:PRINT "that can be easily merged into your BASIC programs and"
  15. 130 LOCATE   ,13:PRINT "called with a single line of code.  It will present a"
  16. 140 LOCATE   ,13:PRINT "title screen similar to the one at the beginning of this"
  17. 150 LOCATE   ,13:PRINT "program.  The title can be placed anywhere on the screen,"
  18. 160 LOCATE   ,13:PRINT "but the routine will automatically center the title if"
  19. 170 LOCATE   ,13:PRINT "you do not specify a column.  The title can be displayed"
  20. 180 LOCATE   ,13:PRINT "in any color if a color monitor is attached, but will"
  21. 190 LOCATE   ,13:PRINT "also work with monochrome monitors."
  22. 200 Y1=6:Y2=18:X1=10:X2=71:COLOR 7:GOSUB 8100
  23. 210 GOSUB 8000
  24. 300 CLS:COLOR FC,0
  25. 310 COLOR 7:LOCATE 3,32:PRINT "USING THE ROUTINE"
  26. 320 COLOR FC:LOCATE 5,5 :PRINT "  The following variables are passed to the routine in order to create"
  27. 322 LOCATE  ,5 :PRINT "  a title screen.  The routine itself is located at line ";:COLOR FC+8:PRINT "50000";:COLOR FC:PRINT ".  To use"
  28. 324 LOCATE  ,5 :PRINT "it in your own programs, save the routine to disk by itself in ASCII"
  29. 326 LOCATE  ,5 :PRINT "format, then MERGE it into your program.  See the BASIC manual for "
  30. 328 LOCATE  ,5: PRINT "more information concerning the MERGE command."
  31. 330 COLOR FC+8:LOCATE 11,10:PRINT "MSG$";:COLOR FC:PRINT " ..... This is the word or characters you want printed on"
  32. 332 LOCATE 12,10:PRINT "           the screen.  It can be no longer than ten characters."
  33. 334 COLOR FC+8:LOCATE 14,10:PRINT "TD.Y1% ";:COLOR FC:PRINT "... (optional)  Specifies the starting row of the title."
  34. 336 LOCATE 15,10:PRINT "           If TD.Y1% is omitted, the title will be centered"
  35. 338 LOCATE 16,10:PRINT "           vertically by the routine."
  36. 340 COLOR FC+8:LOCATE 18,10:PRINT "TD.X1%";:COLOR FC:PRINT " ... (optional)  Specifies the starting column of the"
  37. 342 LOCATE 19,10:PRINT "           title.  If TD.X1% is omitted, the title will be"
  38. 344 LOCATE 20,10:PRINT "           centered horizontally."
  39. 346 LOCATE 22,5 :PRINT "   The color of the title will be the current foreground color."
  40. 350 GOSUB 8000
  41. 400 CLS:COLOR 7
  42. 410 LOCATE 2,29:PRINT "SAMPLE SUBROUTINE CALL"
  43. 412 COLOR FC:LOCATE  4, 5:PRINT "The line below is a sample call of the TITLE subroutine. Press a key"
  44. 414 LOCATE  5, 5:PRINT "to see the result of this line of code."
  45. 416 LOCATE  7,10:PRINT "100 MSG$ = ";CHR$(34);"Sample!";CHR$(34);" : TD.Y1%=15 : GOSUB 50000"
  46. 420 GOSUB 8000
  47. 430 MSG$="Sample!" : TD.Y1%=15 : GOSUB 50000
  48. 440 GOSUB 8000
  49. 500 CLS:COLOR FC:LOCATE 3,8:PRINT "Enter any message of ten characters or less at the prompt below."
  50. 510 LOCATE 5,34:ALLEN%=10:GOSUB 9500
  51. 520 MSG$=NTRY$:COLOR 10:GOSUB 50000
  52. 530 GOSUB 8000
  53. 540 GOTO 500
  54. 3000 LIST 50000-50200,"TITLERT9.BAS"
  55. 8000 '**********  pause until keypress ***************
  56. 8010 DEF SEG=0:POKE &H41A,PEEK(&H41C)
  57. 8020 COLOR 14:LOCATE 24,20:PRINT "Press any key to continue, or F8 to exit.";
  58. 8030 I$=INKEY$:IF I$="" THEN 8030 ELSE SOUND 500,.01:SOUND 100,0:RETURN
  59. 8032 '************************************************
  60. 8050 '********** wait for selection *********
  61. 8055 DEF SEG=0:POKE &H41A,PEEK(&H41C)
  62. 8060 COLOR 14:LOCATE 24,19:PRINT "Press selection to continue, or F8 to exit.";
  63. 8065 I$=INKEY$:IF I$="" THEN 8030 ELSE SOUND 500,.51:SOUND 100,0:RETURN
  64. 8100 '**** routine to draw a box on the text screen, given the upper left *****       **** and lower right corners(x1,y1,x2,y2)
  65. 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
  66. 8110 PRINT STRING$(X2-X1-1,"═");
  67. 8115 LOCATE Y2,X2:PRINT "╝";
  68. 8120 RETURN
  69. 8125 '**** routine to erase that last box drawn ********
  70. 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
  71. 8135 PRINT STRING$(X2-X1-1," ");
  72. 8140 LOCATE Y2,X2:PRINT " ";
  73. 8145 RETURN
  74. 9500 '*******************************************************
  75. 9505 '* ALPHABETIC INPUT ROUTINE                            *
  76. 9510 '*******************************************************
  77. 9515 PRINT STRING$(ALLEN%,CHR$(176));:FOR AZX= 1 TO ALLEN%:PRINT CHR$(29);:NEXT AZX
  78. 9520 NTRY$=""
  79. 9525 KK$=INKEY$: IF KK$="" THEN 9525
  80. 9526 KK%=ASC(KK$): IF LEN(KK$)>1 AND RIGHT$(KK$,1)=CHR$(75) THEN 9555
  81. 9530 IF KK%=13 THEN GOTO 9580                'End of entry
  82. 9535 IF KK%=8 THEN GOTO 9555                 'Backspace
  83. 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
  84. 9545 IF LEN(NTRY$) = ALLEN% THEN 9580        'Entry full
  85. 9550 GOTO 9525                               'Get another character
  86. 9555 '**** Backspace
  87. 9560 IF LEN(NTRY$)=0 THEN 9525               'Not if entry is empty
  88. 9565 PRINT CHR$(29);STRING$(1,176);CHR$(29);  'Redisplay box
  89. 9570 NTRY$=LEFT$(NTRY$,LEN(NTRY$)-1)          'Delete last character
  90. 9575 GOTO 9525                               'Get next character
  91. 9580 IF LEN(NTRY$)=0 THEN BEEP :GOTO 9520   ELSE PRINT SPACE$(ALLEN% - LEN(NTRY$));
  92. 9585 RETURN
  93. 50000 '========== display TITLE routine ==============
  94. 50001 '┌──────────────────────────────────────────────────────────────────┐
  95. 50002 '│ Define MSG$ before entering.                                     │
  96. 50003 '│ TD.Y1% and TD.X1% will locate MSG$, but MSG$ will be centered if │
  97. 50004 '│ they are omitted.  Set color with a COLOR statement.             │
  98. 50006 '└──────────────────────────────────────────────────────────────────┘
  99. 50010 TD.WDTH = 1         ' change to 1,2,or 3 to set width
  100. 50020 TD.BLK$ =STRING$(TD.WDTH,"█"):TD.BNK$=STRING$(TD.WDTH," ")
  101. 50030 DEF SEG=0:POKE &H41A,PEEK(&H41C):DEF SEG=&HF000
  102. 50040 IF LEN(MSG$) >10/TD.WDTH OR LEN(MSG$)<1 OR TD.Y1%>17  THEN RETURN
  103. 50050 IF TD.X1%=0 THEN TD.X1%=41-INT((LEN(MSG$)/2)*(8*TD.WDTH))
  104. 50055 IF TD.Y1%=0 THEN TD.Y1%=8
  105. 50060 FOR TD.C=1 TO LEN(MSG$)
  106. 50070 TD.S=&HFA6E+ASC(MID$(MSG$,TD.C,1))*8
  107. 50080 FOR TD.L=TD.S TO TD.S+7
  108. 50090 TD.V%=PEEK(TD.L)
  109. 50100 LOCATE TD.Y1%+TD.L-TD.S,TD.X1%
  110. 50110 IF TD.V% AND 128 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
  111. 50120 IF TD.V% AND  64 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
  112. 50130 IF TD.V% AND  32 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
  113. 50140 IF TD.V% AND  16 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
  114. 50150 IF TD.V% AND   8 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
  115. 50160 IF TD.V% AND   4 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
  116. 50170 IF TD.V% AND   2 THEN PRINT TD.BLK$;: ELSE PRINT TD.BNK$;
  117. 50180 IF TD.V% AND   1 THEN PRINT TD.BLK$ : ELSE PRINT TD.BNK$
  118. 50190 NEXT TD.L:TD.X1%=TD.X1%+8*TD.WDTH:NEXT TD.C
  119. 50195 TD.Y1%=0:TD.X1%=0
  120. 50200 RETURN
  121. 65000 ' return to magazette
  122. 65010 SCREEN 0: WIDTH 80: COLOR 14,0
  123. 65015 ON ERROR GOTO 0:CLOSE
  124. 65020 IF ADDR.%<>0 THEN LOCATE 25,1,0: PRINT SPACE$(28);"Returning to Magazette";SPACE$(29);: CHAIN "START"
  125. 65030 CLS: LOCATE 12,35: PRINT"Good-bye!": COLOR 3
  126. 65040 LOCATE 23,1:END
  127.