home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 15 / CDACTUAL15.iso / cdactual / program / basic / QB4WIN30.ZIP / W30.BAS < prev    next >
Encoding:
BASIC Source File  |  1989-05-01  |  47.0 KB  |  1,385 lines
  1. DECLARE SUB MemoryDump ()
  2. DECLARE SUB attributes ()
  3. DECLARE SUB DBox (F$)
  4. DECLARE SUB DebugData ()
  5. DECLARE SUB dec (n)
  6. DECLARE SUB Diversion ()
  7. DECLARE SUB Fill ()
  8. DECLARE SUB GraphicsDemo1 ()
  9. DECLARE SUB GraphicsDemo2 ()
  10. DECLARE SUB GraphicsDemo3 ()
  11. DECLARE SUB inc (n)
  12. DECLARE SUB k ()
  13. DECLARE SUB machine ()
  14. DECLARE SUB NewBorders ()
  15. DECLARE SUB open10 ()
  16. DECLARE SUB pages ()
  17. DECLARE SUB PrintxDemo ()
  18. DECLARE SUB ReadScreenDemo ()
  19. DECLARE SUB StringArray ()
  20. DECLARE SUB testpattern ()
  21. DECLARE SUB TextMode (r, c)
  22. DECLARE SUB train ()
  23. DECLARE SUB VGARead16ColReg (ColorReg$)
  24. DECLARE SUB VGAReadFile (File$, RGB$)
  25. DECLARE SUB VGAReadPalReg (Palette$)
  26. DECLARE SUB VGASet16ColReg (RGB$)
  27. DECLARE SUB VGASet1ColReg (Reg!, Red!, Green!, Blue!)
  28. DECLARE SUB VGASetDefaultReg ()
  29. DECLARE SUB VGAViewReg ()
  30.       
  31. '==================================================================
  32.         REM $DYNAMIC
  33.         COMMON SHARED i$
  34.         '$INCLUDE: 'W30.dec'
  35.         OPTION BASE 1
  36.         REDIM mode$(14, 5): 'used by TextMode
  37.  
  38. '==================================================================
  39.  
  40. 'flags to toggle displaytime & memorydump on/off
  41.         clock2 = 1: Trap2 = 1
  42.  
  43. 'initialize some strings for PrintxDemo
  44.         REDIM e$(100): OPEN "i", #3, "W30.DEC"
  45.         FOR x = 1 TO 30: LINE INPUT #3, e$(x): NEXT: CLOSE
  46.  
  47. '----Initialize the data for the main menu----
  48.         items = 14: TR = 4: LC = 10: '# items in the window & its location
  49.         RESTORE 100: REDIM M$(20)
  50.         FOR x = 1 TO 20: READ M$(x): NEXT
  51.  
  52. '===========================================================================
  53. start:
  54. '----clear the screen, print the menu----
  55.         Kolor 3, 0:
  56.         KLS
  57.         OpenW 2, 3, 0, TR, LC, TR + items + 4, 70
  58.         CALL FillW(0, VARPTR(M$(1)))
  59.  
  60. '----Wait for a keypress----
  61. MainMenuLoop:
  62.         i$ = "": DO UNTIL i$ <> "": i$ = INKEY$: LOOP: i$ = LCASE$(i$)
  63.  
  64. SELECT CASE i$
  65.         CASE "s": CALL train: CALL machine
  66.         CASE "f": CALL Fill
  67.         CASE "v": CALL attributes
  68.         CASE "c": CALL open10
  69.         CASE "d": CALL DebugData
  70.         CASE "p": CALL PrintxDemo
  71.         CASE "b": CALL NewBorders
  72.         CASE "q": CALL TextMode(25, 80): END
  73.         CASE "g": CALL GraphicsDemo2: CALL GraphicsDemo3: CALL GraphicsDemo1
  74.         CASE "t": CALL TextMode(0, 0)
  75.         CASE "x": SWAP Trap1, Trap2:
  76.                 IF Trap1 = 1 THEN
  77.                 PLAY ON
  78.                 PLAY "MB T130 L32 N0"
  79.                 ON PLAY(1) GOSUB MemDump
  80.                 CALL Dump2(17, 1, 3, 1, 5, 0, &H40, 16, 0, 1)
  81.                 ELSE PLAY OFF
  82.                 END IF
  83.         CASE "h": SWAP clock1, clock2:
  84.                 IF clock1 = 1 THEN
  85.                 ON TIMER(1) GOSUB DisplayTime: TIMER ON
  86.                 ELSE TIMER OFF
  87.                 END IF
  88.         CASE "n": CALL pages
  89.         'CASE "n": CALL SP
  90.         CASE "r": CALL Diversion
  91.         CASE "m": CALL MemoryDump
  92. CASE ELSE: GOTO MainMenuLoop
  93. END SELECT: GOTO start
  94. '==========================================================================
  95.  
  96. 100
  97. DATA "   Examples"
  98. DATA ""
  99. DATA "     S  Scrollx"
  100. DATA "     F  Fill Window"
  101. DATA "     V  View Attributes"
  102. DATA "     C  CloseLastW"
  103. DATA "     D  Call DebugW   "
  104. DATA "     B  User defined borders"
  105. DATA "     P  Printx Demo  "
  106. DATA "     G  Scroll Left in Graphics Mode"
  107. DATA "     H  Display time on/off"
  108. DATA "     X  Memory Dump on/off"
  109. DATA "     T  Change Text Mode (VGA/EGA)"
  110. DATA "     R  Color Registers (VGA only)"
  111. 'DATA "     N  SpreadSheet demo"
  112. DATA "     M  Scroll thru memory"
  113. DATA "     Q  Quit"
  114. DATA ,,,,,,,,,,,,,,
  115.  
  116. ResumeNext: EE = ERR: RESUME NEXT
  117.  
  118. DisplayTime:
  119.         cccR = CSRLIN: cccC = POS(x)
  120.         LOCATE 1, 60: PRINT TIME$
  121.         LOCATE cccR, cccC: 'restore cursor position
  122.         RETURN
  123.  
  124. MemDump:
  125. 'This is a sort of multi-tasking and yes, I got the idea from PC Magazine.
  126.         PLAY "MB N0"
  127.         CALL Refresh
  128.         RETURN
  129.  
  130. REM $STATIC
  131. '===========================================================================
  132.           SUB attributes STATIC
  133. Kolor 2, 0: KLS: DEF SEG = &HB800: 'segment of screen 1
  134. LOCATE 10, 30: PRINT "Decimal"; : LOCATE 20, 30: PRINT "Hex";
  135. LOCATE 25, 1: PRINT "Press any key to quit"
  136.  
  137. '----------------print all the a ttributes in decimal-----------
  138. LOCATE 1, 1, 0
  139. x = 0: DO UNTIL x = 127
  140.         PRINT USING "#####"; x;
  141.  
  142.         FOR y = 1 TO 9 STEP 2
  143.         POKE x * 10 + y, x
  144.         NEXT: i$ = INKEY$: IF i$ <> "" THEN EXIT DO
  145.         x = x + 1: LOOP
  146.  
  147. '-------Print all the attributes in hex-----------------
  148. LOCATE 11, 1
  149. x = 0: DO UNTIL x = 127
  150.         i$ = INKEY$: IF ii$ <> "" THEN EXIT SUB
  151.         PRINT USING "\   \"; HEX$(x);
  152.  
  153.         FOR y = 1 TO 9 STEP 2
  154.         POKE x * 10 + y + 1600, x
  155.         NEXT: i$ = INKEY$: IF i$ <> "" THEN EXIT DO
  156.         x = x + 1: LOOP
  157.  
  158. Printt CHR$(10), 7, 25, 1: 'erase message
  159.  
  160. Printt "Press any key to call SwapAttr", 7, 20, 1
  161. CALL k
  162. Printt "Press any key to call SwapAttr", 7, 21, 1: CALL SwapAttr
  163.  
  164. CALL k:
  165. Printt "Press any key to call ChangeAttr(15)", &H70, 22, 1: CALL SwapAttr
  166.  
  167. CALL k:
  168. Printt "Press any key to call ChangeAttr(&h70)", 7, 23, 1
  169. CALL ChangeAttr(15)
  170.  
  171. CALL k:
  172. Printt "Press any key to call SwapAttr" + CHR$(10), 15, 24, 1
  173. CALL ChangeAttr(&H70)
  174. CALL k:
  175. CALL SwapAttr
  176. Printt "Press any key...", 7, 25, 1
  177.  
  178. CALL k
  179.  
  180.  
  181. END SUB
  182.  
  183. SUB DBox (F$)
  184.         'QuickBasic's famous box-in-a-box.  Called by FILL
  185.  
  186.        TR = 5: LC = 15:     'Box location
  187.         c1 = 10: c2 = 4:     'color
  188. '--------------------------------------------
  189.         attr = c1 + c2 * 16
  190.         BR = TR + 13: RC = LC + 50
  191.         REDIM box(2000) AS INTEGER
  192.         OpenW 1, attr, VARSEG(box(1)), TR, LC, BR, RC
  193.        
  194.         OpenW 1, attr, 0, TR + 4, LC + 6, TR + 6, LC + 44
  195.         Printt "Name of a text file to view:", attr, TR + 3, LC + 7
  196.        
  197.         OpenW 2, attr, 0, TR + 8, LC + 13, TR + 10, LC + 18
  198.         Printt "OK", attr, TR + 9, LC + 15
  199.        
  200.         OpenW 1, attr, 0, TR + 8, LC + 28, TR + 10, LC + 37
  201.         Printt "Cancel", attr, TR + 9, LC + 30
  202.        
  203.         COLOR c1, c2: LOCATE TR + 5, LC + 8, 1
  204.         INPUT "", F$: ' comma suppresses the '?'
  205.         FOR x = 1 TO 4: CALL CloseLastW: NEXT
  206. END SUB
  207.  
  208. '===========================================================================
  209. SUB DebugData STATIC
  210.         CALL DebugW
  211. END SUB
  212.  
  213. SUB dec (n) STATIC
  214.         n = n - 1
  215. END SUB
  216.  
  217. SUB Diversion
  218.         Kolor 2, 0
  219.         CALL Adapter(n%): IF n% <> 3 THEN EXIT SUB
  220.  
  221.         'view current colors
  222.         KLS
  223.         CALL VGAViewReg
  224.         Printt "Press a key...", 2, 22, 1: k
  225.  
  226.         'save current colors
  227.         CALL VGARead16ColReg(SaveReg$)
  228.  
  229.         'read new colors from a file
  230.         CALL VGAReadFile("W30.VPT", RGB$)
  231.  
  232.         'set the VGA to these new colors
  233.         'changes those wimpy pastels to flaming reds and oranges
  234.         IF LEN(RGB$) <> 0 THEN
  235.                 CALL VGASet16ColReg(RGB$)
  236.  
  237.         'if the file wasn't found, set 4 registers individually
  238.         ELSE
  239.                 Red = 0: Green = 0: Blue = 0: Reg = 0
  240.                 CALL VGASet1ColReg(Reg, Red, Green, Blue)
  241.               
  242.                 Red = 63: Green = 10: Blue = 10: Reg = 1
  243.                 CALL VGASet1ColReg(Reg, Red, Green, Blue)
  244.               
  245.                 Red = 63: Green = 48: Blue = 7: Reg = 2
  246.                 CALL VGASet1ColReg(Reg, Red, Green, Blue)
  247.               
  248.                 Red = 30: Green = 49: Blue = 63: Reg = 3
  249.                 CALL VGASet1ColReg(Reg, Red, Green, Blue)
  250.         END IF
  251.  
  252.         'view the new colors:
  253.         CALL VGAViewReg: Kolor 2, 0
  254.  
  255.         'here's the diversion
  256.         Lokate 22, 1: Prnt "Play RedBaron?  y/n":
  257.         i$ = "": DO UNTIL i$ <> "": i$ = INKEY$: LOOP
  258.  
  259.         'run the game from a batch file instead of a simple shell command
  260.         'so control - break will be handled properly
  261.         IF LCASE$(i$) = "y" THEN
  262.                 CLOSE : OPEN "W30Temp.bat" FOR OUTPUT AS #3
  263.                 PRINT #3, "\games\Redbaron"
  264.                 CLOSE
  265.                 SHELL "W30Temp.bat"
  266.                 END IF
  267.  
  268.         'restore the original colors
  269.         Printt "restore colors to    1/original   2/default ", 2, 24, 1
  270.         CALL k: x = VAL(i$)
  271.         IF x = 1 THEN CALL VGASet16ColReg(SaveReg$) ELSE CALL VGASetDefaultReg
  272.  
  273.         CALL VGAViewReg
  274. END SUB
  275.  
  276. SUB Doc
  277.  
  278. '                       Quick Reference:
  279. 'Adapter (a%)  active adapter returned in a  0\mono 1\cga 2\ega 3\vga
  280. 'CGA ()        sets video segment for the cga
  281. 'ChangeAttr (attr)
  282. 'CloseLastW ()           close window opened with OpenW or SaveW
  283. 'closew ( segment,  TR,  LC,  BR,  RC)
  284. 'DebugW ()
  285. 'defborder (x$)          string of 9 char for user defined borders
  286. 'Dump2 (r,c,attr, border, #Lines, #Col, segment, offset%, format, refreshrate)
  287. 'FillW ( offset, varptr(a$(n))    fill a window from a string array.
  288. 'GScrollL8 ( TR,  LC,  BR,  RC)
  289. 'InitW (RR, CC)
  290. 'Int10 (ax%, bx%, cx%, dx%)
  291. 'int3
  292. 'KLS
  293. 'Kolor ( foreground,  background)
  294. 'Lokate ( r,  c)
  295. 'Monochrome ()    sets video segment for monochrome adapter
  296. 'OpenW ( border,  attr,  segment,  TR,  LC,  BR,  RC)
  297. 'Printt (a$,  attr,  r,  c)
  298. 'PrintW (a$,  attr,  r,  c)
  299. 'Prnt (a$)
  300. 'PrntS (i!)
  301. 'PrntUsingS (Mask$,  i!)
  302. 'PrntW (a$)
  303. 'ReadScreen (a$,  r,  c)
  304. 'Refresh ()              repeats the call to dump2
  305. 'saveW ( segment,  TR,  LC,  BR,  RC)
  306. 'scrolld ( attr,  lines,  TR,  LC,  BR,  RC)
  307. 'scrollL ( attr,  cols,  TR,  LC,  BR,  RC)
  308. 'scrollr ( attr,  cols,  TR,  LC,  BR,  RC)
  309. 'scrollu ( attr,  lines,  TR,  LC,  BR,  RC)
  310. 'SetViewPage (p)
  311. 'SetViewW ( page,  TR,  LC,  BR,  RC)
  312. 'SwapAttr ()
  313. '
  314. '
  315. '--------------------------------------------------------------------------
  316. 'Here is a list of all the VGA calls (these are subs in W30.BAS):
  317.  
  318. 'Adapter(n%)    [n is an integer variable, not BYVAL]
  319. '        type of adapter in use  0/mono 1/cga 2/ega 3/vga
  320. 'VGARead16ColReg (RGB$)
  321. '        returns a 49 byte string with contents of 16 color registers
  322. '        and the overscan register.
  323. 'VGARead1ColReg (Register,Red,Green,Blue)
  324. '        reads a single color register
  325. 'VGAReadFile (filename$,RGB$)
  326. '        reads a file created by VPT.EXE into a 49 byte string
  327. 'VGAReadPalReg (Palette$)
  328. '        Reads the 16 palette registers and overscan attribute into
  329. '        a 17 byte string
  330. 'VGASet16ColReg
  331. '        Sets 16 color registers from a 48 or 49 byte string.  Can use the
  332. '        string returned by VGARead16ColReg or VGAReadFile.
  333. 'VGASet1ColReg (Register,Red,Green,Blue)          [Red Green & Blue = 0 to 63]
  334. '        sets a single color register.
  335.  
  336. '               Note: the calls to read or set 16 registers use strings,
  337. '               those to read or set one register use numbers.
  338.  
  339. 'VGASetDefaultReg
  340. '        Sets the 16 palette and color registers to their defaults, except
  341. '        for color 7 which is set to green instead of white.
  342. 'VGASetOverScanReg (n)        [n = 0 to 15]
  343. '        sets the attribute for the overscan register.
  344.  
  345. '       There is no separate call to read the attribute of the overscan
  346. '       register, but it is the last byte of the string returned
  347. '        by ReadPalReg, ReadFile, or Read16ColReg.
  348.  
  349.  
  350. END SUB
  351.  
  352. REM $DYNAMIC
  353. SUB Fill STATIC
  354.         SHARED EE:       'error code from resumenext
  355.         SHARED SkipCheck: 'used by TextMode
  356.         'this routine prints tab character, may need to filter the file
  357.         F$ = "W30.doc": 'name of a text file to view
  358.  
  359. StartFillDemo:
  360. '---------------------------------------------------------------------------
  361.         'initialize the editing keys
  362.         PgUp$ = CHR$(0) + CHR$(73): PgDn$ = CHR$(0) + CHR$(81)
  363.         up$ = CHR$(0) + CHR$(72): down$ = CHR$(0) + CHR$(80)
  364.         lft$ = CHR$(0) + CHR$(75): rght$ = CHR$(0) + CHR$(77)
  365.         Ins$ = CHR$(0) + CHR$(82): del$ = CHR$(0) + CHR$(83)
  366.         backspace$ = CHR$(0) + CHR$(8): ShiftTab$ = CHR$(0) + CHR$(15)
  367.         Home$ = CHR$(0) + CHR$(71): end$ = CHR$(0) + CHR$(79)
  368.         CR$ = CHR$(13): esc$ = CHR$(27): tab$ = CHR$(9): eol$ = CHR$(10)
  369.  
  370. '--------------------INITIALIZE THE DATA-------------------------------
  371.         REDIM a$(2000): 'array holds the strings to be viewed
  372.         LastLine = 1: 'number of strings used in a$()
  373.         IF fore = 0 THEN fore = 15: back = 5: 'initial colors
  374.         e$ = "L32ege": 'play  when scrolling hits the end
  375.         SIZE = 2: 'initial size of the window
  376.         n = 0: 'initial string offset (increase n to scroll left)
  377.         L = 1: 'a$(L) is the string at the top of the window
  378.         border = 2: 'initial border, a double line
  379.         REDIM a%(9900): 'array used to save the screen, enough for 75x132
  380.         CALL defborder(CHR$(220) + CHR$(220) + CHR$(220) + CHR$(221) + CHR$(32) + CHR$(222) + CHR$(223) + CHR$(223) + CHR$(223))
  381.  
  382. '------------Clear the screen and print a help menu --------------------------
  383.         Kolor 2, 0: KLS
  384.         OpenW 4, 6, 0, 2, 1, 24, 24: Lokate 1, 1: 'draw a box
  385.         Kolor 12, 0: PrntW "Keys to scroll:" + CR$
  386.         Kolor 9, 0
  387.         PrntW CHR$(25) + " " + CHR$(26) + " " + CHR$(27) + " " + CHR$(24) + CR$
  388.         PrntW "PageUp PageDown  " + CR$
  389.         PrntW "Home  End" + CR$
  390.         PrntW "tab  shift/tab" + CR$
  391.         Kolor 6, 0: PrntW "______________________": PrntW CR$
  392.         Kolor 12, 0: PrntW "Change the display:" + CR$: Kolor 9, 0
  393.         PrntW "b     Border" + CR$
  394.         PrntW "f     New file" + CR$
  395.         PrntW "+ -   Window size" + CR$
  396.         PrntW "1,2   Foreground color" + CR$
  397.         PrntW "9,0   Background color" + CR$
  398.         PrntW "t     Select text mode" + CR$
  399.         PrntW "<esc> Quit" + CR$
  400.         Kolor 6, 0: PrntW "______________________": PrntW CR$
  401.         Kolor 12, 0: PrntW "Current colors:" + CR$:
  402.       
  403.         Kolor 9, 0
  404.         PrntW "   Foreground  " + CR$
  405.         PrntW "   Background  " + CR$
  406.         PrntW "   Attribute     "
  407.  
  408. '-------------------------Open a text file ---------------------------------
  409. OpenFile:
  410.         EE = 0: ON ERROR GOTO ResumeNext
  411.         CLOSE : OPEN "i", #3, F$
  412.         ON ERROR GOTO 0
  413.         IF EE = 0 GOTO ReadFile
  414.         CALL DBox(F$): IF F$ = "" GOTO ExitFillDemo ELSE GOTO OpenFile
  415.  
  416. '-------------------------Read the file into A$() -----------------------
  417. ReadFile:
  418.         Printt "Loading " + F$, 2, 10, 30
  419.         Printt "Press <Esc> to stop", 2, 12, 30
  420.         DO UNTIL EOF(3): LINE INPUT #3, a$(LastLine)
  421.         Lokate 9, 40: PrntUsingS "####", LastLine
  422.         
  423.         IF FRE(x$) < 2000 OR LastLine > 1999 THEN
  424.                  Lokate 13, 40: Prnt "Not enough room...": PLAY e$: CALL k
  425.                  EXIT DO
  426.                  END IF
  427.  
  428.         inc LastLine
  429.         i$ = INKEY$: IF i$ = esc$ THEN EXIT DO
  430.         LOOP: CLOSE #3
  431.         Printt "                   ", 2, 12, 30: 'erase the message
  432.  
  433. '---------------------------------------------------------------------------
  434. FileLoaded:
  435.         'find the center of the display
  436.         DEF SEG = 0
  437.         columns = PEEK(&H44A) + PEEK(&H44B) * 256
  438.         rows = PEEK(&H484) + 1
  439.         MiddleRow = INT(rows / 2): MiddleCol = INT(columns / 2)
  440.         DeltaR = MiddleRow / 6: 'add/subtract to window TR,LC,BR & RC when
  441.         DeltaC = MiddleCol / 6: '    changing the window size
  442.       
  443. '-------------------------Set up a window-----------------------------------
  444. OpenWindow:
  445.         'Update colors while not covered up by the file window
  446.         Kolor 12, 0:
  447.         Lokate 21, 17: PrntUsingS "###", fore
  448.         Lokate 22, 17: PrntUsingS "###", back
  449.         aa$ = HEX$(back * 16 + fore)
  450.         Lokate 23, 17: Prnt aa$ + " hex "
  451.                                        
  452.         'check bounds
  453.         IF SIZE < 1 THEN SIZE = 1
  454.         IF SIZE > MiddleRow / DeltaR + 1 THEN SIZE = MiddleRow / DeltaR + 1
  455.         TR = MiddleRow - SIZE * DeltaR: BR = MiddleRow + SIZE * DeltaR
  456.         LC = MiddleCol - SIZE * DeltaC: RC = MiddleCol + SIZE * DeltaC
  457.         attr = back * 16 + fore
  458.        
  459.         'open and save the window
  460.         CALL OpenW(border, attr, VARSEG(a%(1)), TR, LC, BR, RC)
  461.  
  462. '-------------------------Print the file in the window----------------------
  463. PrintWindow:
  464.         IF L > LastLine - MiddleRow THEN L = LastLine - MiddleRow: PLAY e$
  465.         IF L < 1 THEN L = 1: PLAY e$
  466.         IF n < 0 THEN n = 0: PLAY e$ ELSE IF n > 120 THEN n = 120: PLAY e$
  467.         CALL FillW(n, VARPTR(a$(L)))
  468.  
  469. '-----------------------Wait for instructions-------------------------------
  470.         CALL k
  471. SELECT CASE i$
  472.         CASE "f", "F": F$ = "": GOTO StartFillDemo: 'OpenFile
  473.         CASE up$: dec L
  474.         CASE down$: inc L
  475.         CASE lft$: inc n
  476.         CASE rght$: dec n
  477.         CASE "b": inc border: IF border = 5 THEN border = 0:
  478.                   CALL CloseLastW: GOTO OpenWindow
  479.         CASE tab$: n = n + 5
  480.         CASE ShiftTab$: n = n - 5
  481.         CASE esc$: GOTO ExitFillDemo
  482.         CASE PgUp$: L = L - MiddleRow * 2
  483.         CASE PgDn$: L = L + MiddleRow * 2
  484.         CASE Home$: n = 0: L = 1
  485.         CASE end$: L = 9999
  486.         CASE "-": dec SIZE: CALL CloseLastW: GOTO OpenWindow
  487.         CASE "+": inc SIZE: CALL CloseLastW: GOTO OpenWindow
  488.         CASE "t": SkipCheck = 1: CloseLastW: CALL TextMode(0, 0): GOTO FileLoaded
  489.         CASE "1": fore = fore + 1: IF fore > 15 THEN fore = 0
  490.                   CALL CloseLastW: GOTO OpenWindow
  491.         CASE "9": back = back + 1: IF back > 7 THEN back = 0
  492.                   CALL CloseLastW: GOTO OpenWindow
  493.         CASE "2": fore = fore - 1: IF fore < 0 THEN fore = 15
  494.                   CALL CloseLastW: GOTO OpenWindow
  495.         CASE "0": back = back - 1: IF back < 0 THEN back = 7
  496.                   CALL CloseLastW: GOTO OpenWindow
  497.  
  498.         CASE ELSE
  499. END SELECT: GOTO PrintWindow
  500. ExitFillDemo:
  501.         ERASE a%: ERASE a$
  502.  
  503. END SUB
  504.  
  505. REM $STATIC
  506. SUB GraphicsDemo1 STATIC
  507. SCREEN 2, , 0, 0: CLS
  508. 'move a triangle wave
  509.  
  510. y = 86: Z = -1
  511. LINE (0, 23)-(639, 23)
  512. LINE (0, 88)-(639, 88)
  513.  
  514. i$ = "": DO UNTIL i$ <> ""
  515.         FOR x = 632 TO 639
  516.         PSET (x, y)
  517.         y = y + Z
  518.         IF y < 32 THEN Z = 1 ELSE IF y > 86 THEN Z = -1
  519.         NEXT x
  520.  
  521. CALL GScrollL8(24, 0, 87, 639)
  522.                      i$ = INKEY$:    LOOP
  523. SCREEN 0
  524. END SUB
  525.  
  526. SUB GraphicsDemo2 STATIC
  527. SCREEN 0, 1, 0, 0
  528. SCREEN 2: CLS
  529. 'rack up some balls
  530.        
  531.         CIRCLE (559, 50), 30:
  532. FOR y = 1 TO 66: CALL GScrollL8(20, 0, 80, 639): NEXT
  533.  
  534.         CIRCLE (559, 50), 30:
  535. FOR y = 1 TO 56: CALL GScrollL8(20, 80, 80, 639): NEXT
  536.        
  537.         CIRCLE (559, 50), 30:
  538.         FOR y = 1 TO 46: CALL GScrollL8(20, 160, 80, 639): NEXT
  539.        
  540.         CIRCLE (559, 50), 30:
  541. FOR y = 1 TO 36: CALL GScrollL8(20, 240, 80, 639): NEXT
  542.  
  543. END SUB
  544.  
  545. SUB GraphicsDemo3 STATIC
  546. SCREEN 2, 0, 0, 0: CLS
  547. 'characters in SCREEN 2 are 8 by 8 so it is easy to scroll one char at a time
  548. 'draw a pattern
  549. FOR x = 1 TO 20
  550. PRINT "Hello 1 2 3 4 5 6 7 8 9 0 q w e r t y u i o p z x c v b n m , . / a s h j k l []"
  551. NEXT
  552.  
  553. 'define the window size. The row (a&c) is 1 to 25 and
  554. 'the columns (b & d) are 1 to 80
  555. a = 3: B = 1: c = 6: d = 80
  556.  
  557. 'convert rows & columns to 0-199 and 0-639 format
  558. TR = (a - 1) * 8: LC = (B - 1) * 8: BR = c * 8 - 1: RC = (d - 1) * 8
  559.  
  560. PRINT TR, LC, BR, RC: INPUT "Pause....."; x$
  561.  
  562. 'scroll 8 characters left
  563. CALL GScrollL8(TR, LC, BR, RC)
  564. CALL GScrollL8(TR, LC, BR, RC)
  565. CALL GScrollL8(TR, LC, BR, RC)
  566. CALL GScrollL8(TR, LC, BR, RC)
  567. CALL GScrollL8(TR, LC, BR, RC)
  568. CALL GScrollL8(TR, LC, BR, RC)
  569. CALL GScrollL8(TR, LC, BR, RC)
  570. CALL GScrollL8(TR, LC, BR, RC)
  571. INPUT "Pause....."; x$
  572. END SUB
  573.  
  574. SUB inc (n) STATIC
  575.         n = n + 1
  576. END SUB
  577.  
  578. SUB k
  579. k:       i$ = "": DO UNTIL i$ <> "": i$ = INKEY$: LOOP:
  580.  
  581. END SUB
  582.  
  583. REM $DYNAMIC
  584. '===========================================================================
  585.  SUB machine STATIC
  586.         c1 = 0: c2 = 4: attr = c1 + c2 * 16: 'color to use here
  587.         COLOR c1, c2: Kolor c1, c2: KLS
  588.         CR$ = CHR$(13): Lokate 5, 1
  589. Prnt "     xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + CR$
  590. Prnt "   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + CR$
  591. Prnt " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + CR$
  592. Prnt " xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx     "
  593. REDIM c%(800)
  594. CALL saveW(VARSEG(c%(1)), 3, 5, 9, 40)
  595.  
  596. Lokate 3, 1
  597. Prnt "                                   xxxxxxxxxxxx" + CR$
  598. Prnt "                      xxxxxxxxxxxxxxxxxxxxxx   " + CR$
  599. Prnt "                xxxxxxxxxxxxxxxxxxxxxxxxx   " + CR$
  600. Prnt "           xxxxxxxxxxxxxxxxxxxxxxxx         " + CR$
  601. Prnt "      xxxxxxxxxxxxxxxxxxxxxxx                " + CR$
  602. Prnt "   xxxxxxxxxxxxxxxxxxxx                      " + CR$
  603. Prnt "xxxxxxxxxxxxx                                            " + CR$
  604. REDIM ccc%(800)
  605. CALL saveW(VARSEG(ccc%(1)), 3, 5, 9, 40)
  606. KLS
  607.  
  608. CALL OpenW(0, 0, 0, 10, 49, 23, 53): 'Draw a black box (attribute is 0)
  609.  
  610. Printt "A B C D E F G H I J K L M N O", attr, 24, 51: ' A at 51, 0 is at 79
  611. y = 97: DO UNTIL y = 123
  612. i$ = INKEY$: IF i$ <> "" THEN EXIT DO
  613.  
  614. '----go left and up
  615. FOR pause = 1 TO 10: NEXT
  616. FOR x = 1 TO 7: CALL scrollL(attr, 1, 1, 44, 23, 60): NEXT
  617. CALL closew(VARSEG(ccc%(1)), 3, 5, 9, 40): 'print arm in up position
  618. FOR x = 1 TO 10: CALL scrollu(attr, 1, 1, 44, 23, 60): NEXT
  619.  
  620. '---go right and down
  621. FOR pause = 1 TO 10: NEXT
  622. FOR x = 1 TO 7: CALL scrollr(attr, 1, 1, 44, 23, 60): NEXT
  623. CALL closew(VARSEG(c%(1)), 3, 5, 8, 40): 'print arm in down position
  624. FOR x = 1 TO 10: CALL scrolld(attr, 1, 1, 44, 23, 60): NEXT
  625.  
  626. 'scroll the letters
  627. CALL scrollL(attr, 2, 24, 1, 25, 79)
  628. Printt CHR$(y), attr, 24, 49: ' small letter
  629. IF y < 108 THEN Printt CHR$(y - 17), attr, 24, 79: 'capital letter
  630.  
  631. inc y: LOOP
  632.  
  633. FOR pause = 1 TO 250: NEXT
  634. COLOR 2, 0
  635. ERASE c%: ERASE ccc%
  636. END SUB
  637.  
  638. REM $STATIC
  639. SUB MemoryDump STATIC
  640.  
  641.         'Turn off the XRay-type memory dump:
  642.         SHARED Trap1, Trap2
  643.         Trap1 = 0: Trap2 = 1
  644.         PLAY OFF
  645.  
  646. '--------------------------------------------------------------------------
  647.         IF PgUp$ = "" THEN
  648.         Lokate 1, 1: Prnt "Scroll - PgUp & PgDn          Exit - Esc  " + CHR$(13)
  649.         Prnt "Press any key to continue.......": CALL k
  650.         CALL ReturnSegments(cs%, ds%)
  651.         PgUp$ = CHR$(0) + CHR$(73): PgDn$ = CHR$(0) + CHR$(81)
  652.         up$ = CHR$(0) + CHR$(72): down$ = CHR$(0) + CHR$(80): esc$ = CHR$(27)
  653.         offset% = &H1600
  654.         END IF
  655. '--------------------------------------------------------------------------
  656.         DEF SEG = 0: r = PEEK(&H484) - 1: 'leave 2 lines for the border
  657.  
  658. DO UNTIL i$ = esc$
  659.        
  660.         Dump2 1, 1, &H5F, 2, r, 0, ds%, offset%, 0, 0
  661.         i$ = ""
  662.         'put refresh in the inkey$ loop so it displays data that changes     
  663.         DO UNTIL i$ <> "": i$ = INKEY$:
  664.        
  665.                 'moving the cursor makes the 2 bytes at 17C2 change:
  666.                 FOR x = 1 TO 2: : LOCATE x, x + 2
  667.                 Refresh
  668.                 NEXT
  669.         LOOP
  670.        
  671.         IF i$ = PgUp$ THEN
  672.                 n = offset% - r * 32
  673.                 IF n < -32767 THEN n = n + 65536
  674.                 IF n > 32767 THEN n = n - 65536
  675.                 offset% = n
  676.                 END IF
  677. LOOP
  678. END SUB
  679.  
  680. REM $DYNAMIC
  681. '===========================================================================
  682. SUB NewBorders STATIC
  683.         Kolor 3, 0: KLS: Lokate 10, 1: Prnt "Pattern:"
  684.         Lokate 12, 1: x$ = "123456789": Prnt x$
  685.         CALL defborder(x$):
  686.         CALL OpenW(4, &H3, 0, 4, 2, 8, 11)
  687.        
  688.         Lokate 12, 21: x$ = CHR$(220) + CHR$(220) + CHR$(220)
  689.         x$ = x$ + CHR$(221) + CHR$(32) + CHR$(222)
  690.         x$ = x$ + CHR$(223) + CHR$(223) + CHR$(223)
  691.         Prnt x$
  692.         CALL defborder(x$):
  693.         CALL OpenW(4, &H3, 0, 4, 22, 8, 31)
  694.        
  695.         Lokate 12, 41: x$ = CHR$(236) + CHR$(240) + CHR$(236)
  696.         x$ = x$ + CHR$(177) + CHR$(32) + CHR$(177)
  697.         x$ = x$ + CHR$(236) + CHR$(240) + CHR$(236)
  698.         Prnt x$
  699.         CALL defborder(x$):
  700.         CALL OpenW(4, &H3, 0, 4, 42, 8, 51)
  701.       
  702.         Lokate 12, 61: x$ = CHR$(176) + CHR$(176) + CHR$(176)
  703.         x$ = x$ + CHR$(219) + CHR$(32) + CHR$(219)
  704.         x$ = x$ + CHR$(176) + CHR$(176) + CHR$(176)
  705.         Prnt x$
  706.         CALL defborder(x$):
  707.         CALL OpenW(4, &H3, 0, 4, 62, 8, 71)
  708.       
  709. CALL k
  710. END SUB
  711.  
  712. '===========================================================================
  713. SUB open10 STATIC
  714.         r = 2000
  715.         REDIM a%(r): REDIM B%(r): REDIM c%(r): REDIM d%(r): REDIM e%(r)
  716.         REDIM F%(r): REDIM G%(r): REDIM h%(r): REDIM i%(r): REDIM J%(r)
  717.         pause = 64
  718.  
  719.  
  720.  
  721. '-------------------------------------------------
  722. CALL OpenW(2, &H1, VARSEG(a%(1)), 1, 1, 15, 20)
  723.         FOR x = 1 TO pause: NEXT
  724. CALL OpenW(2, &H2, VARSEG(B%(1)), 2, 4, 16, 24)
  725.         FOR x = 1 TO pause: NEXT
  726. CALL OpenW(2, &H3, VARSEG(c%(1)), 3, 8, 17, 28)
  727.         FOR x = 1 TO pause: NEXT
  728. CALL OpenW(2, &H40, VARSEG(d%(1)), 4, 12, 18, 32)
  729.         FOR x = 1 TO pause: NEXT
  730. CALL OpenW(2, &H50, VARSEG(e%(1)), 5, 16, 19, 36)
  731.         FOR x = 1 TO pause: NEXT
  732. CALL OpenW(2, &H60, VARSEG(F%(1)), 6, 20, 20, 40)
  733.         FOR x = 1 TO pause: NEXT
  734. CALL OpenW(2, &H70, VARSEG(G%(1)), 7, 24, 21, 44)
  735.         FOR x = 1 TO pause: NEXT
  736. CALL OpenW(2, &H10, VARSEG(h%(1)), 8, 28, 22, 48)
  737.         FOR x = 1 TO pause: NEXT
  738. CALL OpenW(2, &H20, VARSEG(i%(1)), 9, 32, 23, 52)
  739.         FOR x = 1 TO pause: NEXT
  740. CALL OpenW(2, &H30, VARSEG(J%(1)), 10, 36, 24, 56)
  741. FOR x = 1 TO 200: NEXT
  742.  
  743. FOR x = 1 TO 10:
  744.         CALL CloseLastW:
  745.         FOR xx = 1 TO 50: NEXT
  746.         NEXT
  747.  
  748. ERASE a%: ERASE B%: ERASE c%: ERASE d%: ERASE e%: ERASE F%:
  749. ERASE G%: ERASE h%: ERASE i%: ERASE J%:
  750. END SUB
  751.  
  752. REM $STATIC
  753. SUB pages STATIC
  754. 'tests if printx prints to correct pages
  755.  
  756. 'find # rows and columns being displayed
  757.         DEF SEG = 0: pagesize = PEEK(&H44C) + PEEK(&H44D) * 256
  758.         ppages = 16384 / pagesize
  759.         IF ppages = 1 THEN EXIT SUB: 'only 1 page is possible
  760.  
  761. FOR p = 0 TO ppages - 1
  762. SCREEN , , p, p: CALL SetViewPage(p): KLS
  763. CALL OpenW(2, &H77, 0, 5 + p, 5 + p * 4, 20 + p, 40 + p * 4)
  764. PrntW "This was printed on page ": PrntS p
  765. NEXT p
  766.  
  767. 'view each page
  768.         FOR x = 0 TO ppages - 1: SCREEN , , x, x: SetViewPage x
  769.         Printt "Viewing page ", 4, x * 2, 60: PrntS x:
  770.         CALL k: NEXT
  771.         FOR x = 0 TO ppages - 1: SCREEN , , x, x: SetViewPage x
  772.         Printt "Viewing page ", 4, 1, 1: PrntS x:
  773.         CALL k: NEXT
  774.  
  775. SCREEN , , 0, 0: SetViewPage (0)
  776. END SUB
  777.  
  778. SUB PrintxDemo STATIC
  779. CLS : LOCATE 1, 1, 1, 1, 12: 'block cursor
  780.         SHARED e$()
  781.         CR$ = CHR$(13)
  782. FOR px = 1 TO 3: 'demo's for PrntW, PrntW + CR$ and PrntW + EOL$
  783. 'print a description of each call
  784.         'call kls:kolor
  785. '        IF px = 1 THEN
  786.  
  787. '---------------------------initialize the screen--------------------
  788.         
  789.         Kolor 2, 0: KLS: 'color for text and window
  790.         'print a ruler below and left of the window:
  791.                 FOR x = 1 TO 16: Lokate x, 6: PrntS x: NEXT
  792.                 Lokate 17, 1: FOR x = 1 TO 6: Prnt "1234567890": NEXT
  793.         CALL OpenW(2, 7, 0, 4, 10, 16, 66)
  794.         Printt "Next string to print is", 7, 18, 1
  795.         IF px = 1 THEN Printt "Call to PrintW", 7, 4, 30
  796.         IF px = 2 THEN Printt "Call to PrintW $ + chr$(13)", 7, 4, 30
  797.         IF px = 3 THEN Printt "Call to PrintW $ + chr$(10)", 7, 4, 30
  798.  
  799.  
  800. '---------------------print 13 strings, each a different color --------------
  801.         Lokate 1, 1: 'top left of the window
  802.         attr% = 0: 'init val of color to print strings
  803.  
  804. x = 1:
  805. PDemoLoop: IF x = 16 GOTO PDemoD: '
  806.         attr% = attr% + &H10: IF attr% = &H80 THEN attr% = &H10
  807.  
  808. '-------------print RR & CC------------------------------
  809.         nr = RR: nc = CC: 'save cursor loc
  810.         Lokate 1, 40: Prnt "RR = ": PrntS nr: Prnt "   CC = ": PrntS nc
  811.        
  812. '------print the next string to be printed (below the window) -----
  813.         Lokate 19, 1
  814.         Printt e$(x), attr%, RR, CC
  815.         Printt CHR$(13), &H7, RR, CC: 'and 2 blank lines to erase the
  816.         Printt CHR$(13), &H7, RR, CC: 'last string
  817.  
  818.         'try to explain how eol$ and cr$ work
  819.         IF nr = 16 OR nc = 66 THEN
  820.         Lokate 22, 1: Prnt "Note the cursor goes out of bounds instead "
  821.                       Prnt "of scrolling the last line"
  822.                         END IF
  823. '----------------locate the cursor, make it visible-------
  824.         RR = nr: CC = nc: 'restore the cursor location
  825.         Lokate RR, CC:    'block cursor
  826.        
  827. '------------------------Pause, then make the call to PrintW---------------
  828.         CALL k
  829.         IF px = 1 THEN PrintW e$(x), attr%, RR, CC
  830.         IF px = 2 THEN PrintW e$(x) + CHR$(13), attr%, RR, CC
  831.         IF px = 3 THEN PrintW e$(x) + CHR$(10), attr%, RR, CC
  832. inc x: GOTO PDemoLoop
  833.  
  834. PDemoD: NEXT px
  835. END SUB
  836.  
  837. SUB sp
  838. '$DYNAMIC
  839.         EXIT SUB: 'doesn't work yet
  840.         Kolor 2, 0: KLS
  841.        
  842. 'dimension and initialize an array
  843.         MinR = 1: MaxR = 10: MinC = 1: MaxC = 10
  844.         REDIM ar(MinR TO MaxR, MinC TO MaxC) AS SINGLE
  845.         FOR x = 1 TO 10: FOR y = 1 TO 10: ar(x, y) = x + y / 100: NEXT: NEXT
  846.  
  847. 'print part of it as a spreadsheet
  848.         Row = 1: Col = 1: 'initial cursor position
  849.         ArraySegment = VARSEG(ar(1, 1)): ArrayOffset = VARPTR(ar(1, 1))
  850.         Nrows = 10: Ncols = 10: 'r & c to print
  851.         Rstep = 1: Cstep = 1
  852.         FirstR = 1: FirstC = 1
  853.         MaskSt$ = "#####.##"
  854.         CALL SpreadSheet(Row, Col, ArraySegment, ArrayOffset, Nrows, Ncols, Rstep, Cstep, FirstR, FirstC, MaskSt$, MaxR, MaxC, MinR, MinC)
  855.         'this prints about 7 times faster that basic
  856.  
  857. END SUB
  858.  
  859. REM $STATIC
  860. SUB testpattern
  861.         Kolor 7, 0
  862. DEF SEG = 0: c = PEEK(&H44A) + PEEK(&H44B) * 256:
  863.         r = PEEK(&H484) + 1
  864.         Lokate 1, 1
  865.         FOR x = 1 TO r: FOR y = 10 TO c STEP 10
  866.         PrntUsingS "#######.##", x + y / 100
  867.         NEXT: NEXT
  868. END SUB
  869.  
  870. SUB testscroll
  871. '==================================================================
  872. CALL testpattern
  873. CALL k
  874. scrollu 48, 2, 3, 20, 12, 60
  875. CALL k
  876. CALL testpattern
  877. CALL k
  878. scrolld 48, 2, 3, 20, 12, 60
  879. CALL k
  880. CALL testpattern
  881. CALL k
  882. scrollL 48, 2, 3, 20, 12, 60
  883. CALL k
  884. CALL testpattern
  885. CALL k
  886. scrollr 48, 2, 3, 20, 12, 60
  887. CALL k
  888.  
  889. END SUB
  890.  
  891. SUB TextMode (rows, columns) STATIC
  892.         '$DYNAMIC
  893.         SHARED mode$()
  894.         SHARED SkipCheck:  'shared with 'Fill'
  895.         IF mode$(1, 1) = "" THEN GOSUB InitTextMode
  896. '------------------------------------------------------------------------
  897. ' This sub should be entirely self-contained except for these two lines
  898. ' in the main part of the program:
  899. '       Rem $INCLUDE:'W30.DEC'
  900. '        REDIM Mode$(14, 5)
  901. 'so it can be copied as is into another program.  Call with the desired
  902. 'number of rows and columns to be displayed.  If it is not a valid mode,
  903. 'a window will pop up showing the available modes.  This was written on
  904. 'a Magnavox VGA, I'm not sure all cards have all these modes.
  905. '------------------------------------------------------------------------
  906.        
  907. 'see if row & column define a valid mode
  908.         h = 0: FOR x = 1 TO 13
  909.       IF VAL(mode$(x, 1)) = rows AND VAL(mode$(x, 2)) = columns THEN h = x
  910.         NEXT:
  911.         IF h <> 0 THEN GOSUB CallInt10: EXIT SUB
  912. '------------------------------------------------------------------------
  913.  
  914.         'Save the part of the screen containing the main menu
  915.         REDIM tmp(1 TO 2000) AS INTEGER
  916.         saveW VARSEG(tmp(1)), 1, 1, 25, 80
  917.        
  918.         'initialize data
  919.         up$ = CHR$(0) + CHR$(72): down$ = CHR$(0) + CHR$(80)
  920.         c1 = 3: c2 = 6: Kolor c1, c2: 'window colors
  921.         TR = 8: LC = 45: BR = TR + 14: n = 13: 'window location & size
  922.        
  923. '------------------------------------------------------------------------
  924. StartTextMode:
  925.  
  926.         'Print a help menu
  927.         OpenW 3, c2, 0, 3, 4, 9, 30: Lokate 1, 1: Kolor c1, c2
  928.         PrntW CHR$(25) + " " + CHR$(26) + "     Select display" + CHR$(13)
  929.         PrntW "<Enter> Change Display" + CHR$(13)
  930.         PrntW "<Esc>   Exit" + CHR$(13)
  931.         PrntW "y/n     Count on/off" + CHR$(13)
  932.         PrntW CHR$(13)
  933. '------------------------------------------------------------------------
  934. 'find # rows and columns being displayed
  935.         DEF SEG = 0: c = PEEK(&H44A) + PEEK(&H44B) * 256: r = PEEK(&H484) + 1
  936.         mode = 0: FOR x = 1 TO 13
  937.         IF VAL(mode$(x, 1)) = r AND VAL(mode$(x, 2)) = c THEN mode = x
  938.         NEXT: h = mode
  939.  
  940. '------------------------------------------------------------------------
  941. 'could it be a configuration I don't have?
  942.         IF mode = 0 THEN
  943.                 BR = BR + 1: mode$(14, 1) = STR$(r):
  944.                 mode$(14, 2) = STR$(c)
  945.                 n = n + 1: 'add 1 more line to the window
  946.                 mode = 14: h = 14
  947.                 END IF
  948.         CurrentMode = mode
  949.        
  950. '------------------------------------------------------------------------
  951. 'Print the possible modes in a window
  952.         Kolor c1, c2
  953.         OpenW 1, &H6B, 0, TR, LC, BR, LC + 12: 'draw a box, don't save
  954.         Lokate 0, 0: FOR x = 1 TO n
  955.         PrntW " " + mode$(x, 1): PrntW " x ": PrntW mode$(x, 2) + CHR$(10)
  956.         NEXT
  957.  
  958. '-------------------------------------------------------------------------
  959. highlight:
  960.         IF mode < 1 THEN mode = n ELSE IF mode > n THEN mode = 1
  961.         Lokate TR + h, 1: Kolor c1, c2:  'un-highlight
  962.         PrntW " " + mode$(h, 1): PrntW " x ": PrntW mode$(h, 2) + CHR$(10)
  963.         h = mode
  964.         Lokate TR + h, 1: Kolor c2, c1: 'highlight
  965.         PrntW " " + mode$(h, 1): PrntW " x ": PrntW mode$(h, 2) + CHR$(10)
  966.  
  967. '-------------------------------------------------------------------------
  968. TL:
  969.         CALL k
  970.         IF i$ = up$ THEN mode = mode - 1: GOTO highlight
  971.         IF i$ = down$ THEN mode = mode + 1: GOTO highlight
  972.         IF i$ = CHR$(13) GOTO ChangeMode
  973.         IF LCASE$(i$) = "y" THEN SkipCheck = 0: CurrentMode = 0:  GOTO ChangeMode
  974.         IF LCASE$(i$) = "n" THEN SkipCheck = 1: CurrentMode = 0:  GOTO ChangeMode
  975.         IF i$ = CHR$(27) GOTO ExitTextMode
  976.         GOTO TL
  977. 'mode is display just selected by the scroll bar
  978. 'h is highlighted bar. h trails mode to unhighlight the last bar
  979. 'currentmode  is how the display is now
  980.  
  981. '------------------------------------------------------------------------
  982. ChangeMode:
  983.         IF mode = 14 GOTO StartTextMode: 'don't support current mode
  984.         IF mode = CurrentMode GOTO StartTextMode: 'no change
  985.         GOSUB CallInt10
  986.         closew VARSEG(tmp(1)), 1, 1, 25, 80: 'Restore the main menu
  987.  
  988. '------------------------------------------------------------------------
  989. 'print a 'ruler' to check # of rows & columns
  990. IF SkipCheck = 0 THEN
  991.         Kolor 4, 0: Lokate 1, 1
  992.         FOR x = 10 TO VAL(mode$(mode, 2)) STEP 10
  993.         PrntUsingS "##########", x: NEXT
  994.         FOR x = 1 TO VAL(mode$(mode, 1)): Lokate x, 1:
  995.         PrntUsingS "#####", x: NEXT
  996.         END IF
  997. GOTO StartTextMode
  998. '------------------------------------------------------------------------
  999. ExitTextMode:
  1000.         closew VARSEG(tmp(1)), 1, 1, 25, 80: 'restore main menu
  1001.         EXIT SUB
  1002. '=====================================
  1003. CallInt10:
  1004.       
  1005.         'set number of scan lines: al= 0/200 1/350 2/400 3/480
  1006.         ax% = VAL("&h0" + (mode$(h, 3))): bx% = &H30
  1007.         IF ax% <> 0 THEN
  1008.         CALL Int10(ax%, bx%, cx%, dx%)
  1009.         IF ax% \ 256 <> &H12 THEN e$ = "L32ege": PLAY e$: GOTO ExitTextMode
  1010.                 END IF
  1011.  
  1012.         'Set text mode
  1013.         ax% = 3: bx% = 0
  1014.         CALL Int10(ax%, bx%, cx%, dx%)
  1015.  
  1016.         'change to the extended mode
  1017.         ax% = VAL("&h0" + mode$(h, 4)): bx% = 0
  1018.         IF ax% <> 0 THEN CALL Int10(ax%, bx%, cx%, dx%)
  1019.       
  1020.         'load a character set into the first font area
  1021.         ax% = VAL("&h0" + mode$(h, 5)): bx% = 0:
  1022.         IF ax% <> 0 THEN CALL Int10(ax%, bx%, cx%, dx%)
  1023. RETURN
  1024. '-------------------------------------------------------------------------
  1025.  
  1026.  
  1027. InitTextMode:
  1028.          mode$(1, 1) = "25":     'lines
  1029.          mode$(1, 2) = "80":     'columns
  1030.          mode$(1, 3) = "1202":   'scan lines (skip if 0).    BL = 30h
  1031.                                  'always set text mode here  AX = 3
  1032.          mode$(1, 4) = "0":      'extended mode (skip if 0)
  1033.          mode$(1, 5) = "1114":   'character set (skip if 0)  BX = 0
  1034.                                                
  1035.          mode$(2, 1) = "25"
  1036.          mode$(2, 2) = "132"
  1037.          mode$(2, 3) = "1202"
  1038.          mode$(2, 4) = "17"
  1039.          mode$(2, 5) = "1114"
  1040.         
  1041.          mode$(3, 1) = "34"
  1042.          mode$(3, 2) = "80"
  1043.          mode$(3, 3) = "1203"
  1044.          mode$(3, 4) = "1111"
  1045.          mode$(3, 5) = "0"
  1046.         
  1047.          mode$(4, 1) = "37"
  1048.          mode$(4, 2) = "100"
  1049.          mode$(4, 3) = "1201"
  1050.          mode$(4, 4) = "1F"
  1051.          mode$(4, 5) = "1114"
  1052.         
  1053.          mode$(5, 1) = "34"
  1054.          mode$(5, 2) = "132"
  1055.          mode$(5, 3) = "1203"
  1056.          mode$(5, 4) = "17"
  1057.          mode$(5, 5) = "1111"
  1058.         
  1059.          mode$(6, 1) = "43"
  1060.          mode$(6, 2) = "80"
  1061.          mode$(6, 3) = "1201"
  1062.          mode$(6, 4) = "0"
  1063.          mode$(6, 5) = "1112"
  1064.         
  1065.          mode$(7, 1) = "42"
  1066.          mode$(7, 2) = "100"
  1067.          mode$(7, 3) = "0"
  1068.          mode$(7, 4) = "1F"
  1069.          mode$(7, 5) = "1111"
  1070.         
  1071.          mode$(8, 1) = "43"
  1072.          mode$(8, 2) = "132"
  1073.          mode$(8, 3) = "1201"
  1074.          mode$(8, 4) = "17"
  1075.          mode$(8, 5) = "1112"
  1076.  
  1077.          mode$(9, 1) = "50"
  1078.          mode$(9, 2) = "80"
  1079.          mode$(9, 3) = "1202"
  1080.          mode$(9, 4) = "0"
  1081.          mode$(9, 5) = "1112"
  1082.  
  1083.          mode$(10, 1) = "50"
  1084.          mode$(10, 2) = "132"
  1085.          mode$(10, 3) = "1202"
  1086.          mode$(10, 4) = "17"
  1087.          mode$(10, 5) = "1112"
  1088.  
  1089.          mode$(11, 1) = "60"
  1090.          mode$(11, 2) = "80"
  1091.          mode$(11, 3) = "1203"
  1092.          mode$(11, 4) = "0"
  1093.          mode$(11, 5) = "1112"
  1094.                
  1095.          mode$(12, 1) = "75"
  1096.          mode$(12, 2) = "100"
  1097.          mode$(12, 3) = "0"
  1098.          mode$(12, 4) = "1F"
  1099.          mode$(12, 5) = "1112"
  1100.  
  1101.          mode$(13, 1) = "60"
  1102.          mode$(13, 2) = "132"
  1103.          mode$(13, 3) = "1203"
  1104.          mode$(13, 4) = "17"
  1105.          mode$(13, 5) = "1112"
  1106.          RETURN
  1107. END SUB
  1108.  
  1109. '===========================================================================
  1110. SUB train STATIC
  1111.  
  1112.         pause = 4: Kolor 2, 0: KLS
  1113.         LOCATE 1, 1: PRINT "          f/faster   s/slower  esc/quit          delay ="
  1114.         Lokate 1, 60: PrntUsingS "###", pause
  1115.         x$ = ".eiee[] o---o o---o o---o o---o o---o o---o eee[]e                                   "
  1116. 'run onto the screen
  1117. FOR x = 1 TO LEN(x$)
  1118.         Printt MID$(x$, x, 1), 2, 10, 80
  1119.         CALL scrollL(&H7, 1, 10, 1, 10, 80)
  1120.         CALL scrolld(&H7, 1, 1, 5, 16, 5)
  1121.         CALL scrollr(7, 1, 16, 1, 16, 80)
  1122.         CALL scrollu(7, 1, 10, 80, 16, 80)
  1123.         NEXT
  1124.        
  1125. 'run around until a keypress
  1126. DO
  1127.          CALL scrollL(&H7, 1, 10, 1, 10, 80)
  1128.         CALL scrolld(&H7, 1, 1, 5, 16, 5)
  1129.         CALL scrollr(7, 1, 16, 1, 16, 80)
  1130.         CALL scrollu(&H7, 1, 10, 80, 16, 80)
  1131.         FOR y = 1 TO pause: NEXT
  1132.         i$ = INKEY$: IF i$ = CHR$(27) THEN EXIT DO
  1133.         IF i$ <> "" THEN GOSUB TrainKeyPress
  1134.         LOOP
  1135.  
  1136. 'jump out if 132 column display
  1137. DEF SEG = 0: IF PEEK(&H44A) <> 80 THEN EXIT SUB
  1138.  
  1139. 'run off the screen
  1140.         xs = 16
  1141. FOR x = 1 TO 250
  1142.         y = SCREEN(16, 79)
  1143.         IF y = 46 THEN xs = 15: x = 200
  1144.         CALL scrollL(&H7, 1, 10, 1, 10, 80)
  1145.         CALL scrolld(&H7, 1, 1, 5, 16, 5)
  1146.         CALL scrollr(7, 1, 16, 1, 16, 80)
  1147.         CALL scrollu(&H7, 1, 10, 80, xs, 80)
  1148.         NEXT
  1149.  
  1150. EXIT SUB
  1151. '-----------------------------------------------------------
  1152. TrainKeyPress:
  1153.         IF i$ = "f" AND pause > 0 THEN dec pause
  1154.         IF i$ = "s" AND pause < 100 THEN inc pause
  1155.         Lokate 1, 60: PrntUsingS "###", pause
  1156.         RETURN
  1157.  
  1158. END SUB
  1159.  
  1160. REM $STATIC
  1161. SUB VGARead16ColReg (ColorReg$) STATIC
  1162. 'Save the state of 16 color registers and the overscan register.  On
  1163. 'return, Palette$ is 49 bytes long and contains the values of the 16
  1164. 'color registers currently in use, plus one byte for the overscan register.
  1165.  
  1166.         'Read the current palette registers to see
  1167.         'which color registers they are mapped to.
  1168.         CALL VGAReadPalReg(Palette$)
  1169.  
  1170.         'Read each color register into a string
  1171.         ColorReg$ = STRING$(49, " ")
  1172.     
  1173.         FOR n = 1 TO 16
  1174.         ax% = &H1017
  1175.         bx% = ASC(MID$(Palette$, n, 1)):    'first register to read
  1176.         cx% = 1:                            'number of registers to read
  1177.         dx% = SADD(ColorReg$) + (n - 1) * 3: 'string at es:dx
  1178.         Int10 ax%, bx%, cx%, dx%
  1179.         NEXT
  1180.         'This function reads cx registers into a string at es:dx, starting
  1181.         'with register number bx. You may read up to 255 reg at once with
  1182.         'this call.  Each takes 3 bytes, the order is Red-Green-Blue.
  1183.         'If you wish to read the registers into numeric arrays or
  1184.         'variables instead of a string, VGARead1ColReg may be easier.
  1185.  
  1186.         'overscan reg goes in the last byte
  1187.         MID$(ColorReg$, 49, 1) = MID$(Palette$, 17, 1)
  1188.  
  1189. END SUB
  1190.  
  1191. SUB VGARead1ColReg (Reg, Red, Green, Blue)
  1192. 'Reads the current values for one color register.
  1193. 'The default registers for VGA are:
  1194. '       Color   Register
  1195. '         0        0
  1196. '         1        1
  1197. '         2        2
  1198. '         3        3
  1199. '         4        4
  1200. '         5        5
  1201. '         6       20
  1202. '         7        7
  1203. '         8       56
  1204. '         9       57
  1205. '        10       58
  1206. '        11       59
  1207. '        12       60
  1208. '        13       61
  1209. '        14       62
  1210. '        15       63
  1211. 'Ex. to change the color displayed by the QB statement COLOR 8,0, change
  1212. 'the values in register 56
  1213. '
  1214.  
  1215.         IF Reg < 0 OR Reg > 255 THEN STOP
  1216.         ax% = &H1015
  1217.         bx% = Reg: 'register you wish to read, 0 to 255
  1218.         Int10 ax%, bx%, cx%, dx%
  1219.  
  1220.         'results:
  1221.         Red = dx% \ 256
  1222.         Blue = cx% \ 256
  1223.         Green = cx% MOD 256
  1224.  
  1225. END SUB
  1226.  
  1227. SUB VGAReadFile (File$, RGB$) STATIC
  1228. ' loads a file created by VPT.EXE into RBG$
  1229.  
  1230. ' on exit, RGB$ is 49 bytes, ***or a null string if an error occurred***
  1231.  
  1232.         ' VPT.EXE is a very nice editor for the vga color registers
  1233.         ' and may be found on the EXEC-PC bulletin board.
  1234.  
  1235.         'save a window, print message
  1236.         REDIM t(200) AS INTEGER
  1237.         OpenW 2, 2, VARSEG(t(1)), 10, 30, 12, 60
  1238.         Lokate 1, 1: PrntW "Loading " + File$
  1239.  
  1240.         RGB$ = SPACE$(49)
  1241. '       Be sure the file exists!
  1242.                 ON ERROR GOTO ResumeNext
  1243.                 OPEN File$ FOR RANDOM AS #1
  1244.                 ON ERROR GOTO 0
  1245.                 FileLength = LOF(1)
  1246.                 CLOSE
  1247.  
  1248.         IF FileLength = 49 THEN
  1249.                 OPEN File$ FOR BINARY AS #3: GET #3, , RGB$
  1250.                 ELSE RGB$ = "": PrintW File$ + " not found", 2, 1, 1
  1251.                 END IF
  1252. 'Be sure the file exists because OPEN FOR BINARY will create a file by
  1253. 'this name with 0 length, ON ERROR will not trap the error, and RGB$
  1254. 'will be a string of 49 zero's. That would make for a very black monitor.
  1255.  
  1256. FOR x = 1 TO 300: NEXT: 'time to read the message
  1257. CALL CloseLastW: ERASE t
  1258. END SUB
  1259.  
  1260. SUB VGAReadPalReg (Palette$) STATIC
  1261.         'Reads the state of 16 palette registers and
  1262.         'the overscan register into a 17 byte string
  1263.  
  1264.         Palette$ = STRING$(17, " ")
  1265.         Int10 &H1009, 0, 0, SADD(Palette$)
  1266.  
  1267. END SUB
  1268.  
  1269. SUB VGASet16ColReg (RGB$) STATIC
  1270. 'set all 16 color registers from a 48 or 49 byte string
  1271.  
  1272. 'Get a list of the color registers being displayed
  1273.         CALL VGAReadPalReg(Palette$)
  1274.  
  1275. 'Be sure we are not calling with a null or blank string:
  1276.         IF RGB$ <> SPACE$(49) AND (LEN(RGB$) = 49 OR LEN(RGB$) = 48) THEN
  1277.         FOR n = 1 TO 15
  1278.         ax% = &H1012
  1279.         bx% = ASC(MID$(Palette$, n, 1)):    'first register to write
  1280.         cx% = 1:                            'number of registers to write
  1281.         dx% = SADD(RGB$) + (n - 1) * 3: 'string at es:dx
  1282.         Int10 ax%, bx%, cx%, dx%
  1283.         NEXT
  1284.      
  1285.         END IF
  1286.  
  1287. END SUB
  1288.  
  1289. SUB VGASet1ColReg (Reg, Red, Green, Blue) STATIC
  1290.  
  1291.         IF Reg < 0 OR Reg > 255 THEN STOP
  1292.         IF Red < 0 OR Red > 63 THEN STOP
  1293.         IF Green < 0 OR Red > 63 THEN STOP
  1294.         IF Blue < 0 OR Red > 63 THEN STOP
  1295.         ax% = &H1010
  1296.         bx% = Reg
  1297.         cx% = Green * 256 + Blue
  1298.         dx% = Red * 256
  1299.         Int10 ax%, bx%, cx%, dx%
  1300.  
  1301. END SUB
  1302.  
  1303. SUB VGASetDefaultReg STATIC
  1304. ' set the palette and color registers to their default state
  1305.         REDIM CReg(0 TO 15, 1 TO 3) AS INTEGER
  1306.         Red = 1: Green = 2: Blue = 3
  1307.         CReg(0, Red) = 0: CReg(0, Green) = 0: CReg(0, Blue) = 0
  1308.         CReg(1, Red) = 0: CReg(1, Green) = 0: CReg(1, Blue) = 42
  1309.         CReg(2, Red) = 0: CReg(2, Green) = 42: CReg(2, Blue) = 0
  1310.         CReg(3, Red) = 0: CReg(3, Green) = 42: CReg(3, Blue) = 42
  1311.  
  1312.         CReg(4, Red) = 42: CReg(4, Green) = 0: CReg(4, Blue) = 0
  1313.         CReg(5, Red) = 42: CReg(5, Green) = 0: CReg(5, Blue) = 42
  1314.         CReg(6, Red) = 42: CReg(6, Green) = 21: CReg(6, Blue) = 0
  1315.         'Default values:
  1316.         CReg(7, Red) = 42: CReg(7, Green) = 42: CReg(7, Blue) = 42
  1317.         'I usually change 7 so the DOS prompt is green
  1318.         CReg(7, Red) = 0: CReg(7, Green) = 63: CReg(7, Blue) = 0
  1319.  
  1320.         CReg(8, Red) = 21: CReg(8, Green) = 21: CReg(8, Blue) = 21
  1321.         CReg(9, Red) = 21: CReg(9, Green) = 21: CReg(9, Blue) = 63
  1322.         CReg(1, Red) = 21: CReg(10, Green) = 63: CReg(10, Blue) = 21
  1323.         CReg(11, Red) = 21: CReg(11, Green) = 63: CReg(11, Blue) = 63
  1324.  
  1325.         CReg(12, Red) = 63: CReg(12, Green) = 21: CReg(12, Blue) = 21
  1326.         CReg(13, Red) = 63: CReg(13, Green) = 21: CReg(13, Blue) = 63
  1327.         CReg(14, Red) = 63: CReg(14, Green) = 63: CReg(14, Blue) = 21
  1328.         CReg(15, Red) = 63: CReg(15, Green) = 63: CReg(15, Blue) = 63
  1329.  
  1330.         REDIM PalReg(0 TO 16) AS INTEGER
  1331.         '0-15 are  Palette registers, 16 is the overscan register
  1332.         FOR n = 0 TO 7: PalReg(n) = n: NEXT
  1333.         FOR n = 8 TO 15: PalReg(n) = n + 48: NEXT
  1334.         PalReg(6) = 20: ' one oddball
  1335.         PalReg(16) = 0: 'overscan register
  1336.  
  1337.         FOR n = 0 TO 15
  1338.         'set the palette register
  1339.         Int10 &H1000, PalReg(n) * 256 + n, 0, 0
  1340.  
  1341.         'set the corresponding color register
  1342. Int10 &H1010, n + 0, CReg(n, Green) * 256 + CReg(n, Blue), CReg(n, Red) * 256
  1343.         NEXT
  1344.       
  1345.         'set the overscan register to zero
  1346.         Int10 &H1001, PalReg(16) * 256, 0, 0
  1347.  
  1348.  
  1349. END SUB
  1350.  
  1351. SUB VGASetOverScanReg (n) STATIC
  1352.         IF n < 0 OR n > 15 THEN STOP
  1353.         ax% = &H1001
  1354.         bx% = n
  1355.         Int10 ax%, bx%, cx%, dx%
  1356.  
  1357. END SUB
  1358.  
  1359. SUB VGAViewReg STATIC
  1360.         CALL VGARead16ColReg(V$)
  1361.         CALL VGAReadPalReg(Palette$)
  1362.  
  1363.         Lokate 1, 1: 'CALL KLS
  1364.         Black$ = CHR$(0) + CHR$(0) + CHR$(0): CR$ = CHR$(13)
  1365.         Prnt "          Current colors" + CR$: Prnt CR$
  1366.         Prnt "     Color  Register       Red     Green      Blue" + CR$
  1367.         FOR x = 1 TO 46 STEP 3
  1368.         c = (x - 1) / 3
  1369.         IF MID$(V$, x, 3) = Black$ THEN Kolor 7, 0 ELSE Kolor c, 0
  1370.         PrntUsingS "##########", c
  1371.         PrntUsingS "##########", ASC(MID$(Palette$, c + 1, 1))
  1372.         FOR y = 0 TO 2
  1373.                 PrntUsingS "##########", ASC(MID$(V$, x + y, 1))
  1374.                 NEXT
  1375.         IF MID$(V$, x, 3) = Black$ THEN
  1376.                 Prnt "  (Black)" + CR$
  1377.                 ELSE Prnt "   " + CHR$(219) + CHR$(219) + CHR$(219) + CR$
  1378.                 END IF
  1379.         NEXT
  1380.         Kolor 2, 0
  1381.         Prnt "Overscan is color ": PrntS ASC(RIGHT$(V$, 1))
  1382.  
  1383. END SUB
  1384.  
  1385.