home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / QBASIC / VIDBASIC.ZIP / DEMO.BAS next >
Encoding:
BASIC Source File  |  1990-11-29  |  14.3 KB  |  535 lines
  1. DEFINT A-Z
  2. '===========================================================================
  3. 'Demo of all the video routines.
  4. 'Updated 11/26/90
  5. '===========================================================================
  6. REM $INCLUDE: 'VIDEO.BI'
  7.  
  8. 'Main routines
  9.  
  10. DECLARE SUB NormalWindow (ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  11. DECLARE SUB ExplodingWindow (ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  12. DECLARE SUB DropWindow (ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  13. DECLARE SUB ExplodingDrop (ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  14.  
  15. 'Help routines
  16.  ' This makes text move up and down
  17. DECLARE SUB FunScroll (ULR%, ULC%, LRR%, LRC%, ATTR%)
  18.  ' Scrolls text down three rows
  19. DECLARE SUB DownRow (ULR%, ULC%, LRR%, LRC%, ATTR%)
  20.  ' Clears the display from the outside in.
  21. DECLARE SUB ClearCircle ()
  22.  ' Allow for a time delay so can see the action.  This is a suboptimal routine
  23.  ' a better version is descibed in the Delayer header
  24. DECLARE SUB Delayer (Factor!)
  25.  
  26. 'Selects the Border% Elements based on Choice of Border%
  27. 'Listed by Border% Number
  28.     'Double Line Border%                           'Border% 1
  29.     'Single Line Border%                           'Border% 2
  30.     'Double Horizontal Single Vertical Border%     'Border% 3
  31.     'Double Vertical Single Horizontal Border%     'Border% 4
  32.     'Hash Border% (the default for case else)      'Border% 5
  33.  
  34. DIM Scrn%(2000) 'Display storage area
  35.  
  36. 'These are the Border% elements
  37. DIM SHARED Factor!
  38.  
  39. '------------------- Regular Window Module -------------------------------
  40. CLS
  41. 'turn cursor off, the same as LOCATE ,,0
  42. CALL CURSET(0)
  43.  
  44. 'if have EGA/VGA MONO use HERC type attributes
  45. CALL EGAMONO(1)
  46.  
  47.     ULC = 1: LRC = 80
  48.     ULR = 1: LRR = 25:
  49.     BORDER% = 1
  50.     LABEL$ = "Normal Box"
  51.    
  52. SELECT CASE VIDEOSTAT     'test for display that can show color well
  53.     CASE -3, -2, 0, 3, 4, 10
  54.         Attrib1 = &H7   'Select white on black
  55.                      'for Herc, COMPAQ, AT&T, EGA/VGA mono display
  56.         ATTR% = &H70    'Background color = 7: Foreground color = 0
  57.     CASE ELSE
  58.         Attrib1 = &H17  'select White on blue for other displays
  59.         ATTR% = &H30    'Background color = 3: Foreground color = 0
  60. END SELECT
  61.  
  62.     
  63.     CALL NormalWindow(ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  64.     ' Save screen 1
  65.     CALL SAVESCRN(VARSEG(Scrn%(0)), VARPTR(Scrn%(0)))
  66.  
  67. DO
  68.     
  69.     CALL RESTSCRN(VARSEG(Scrn%(0)), VARPTR(Scrn%(0)))
  70.     CALL Delayer(.18)
  71.  
  72.     IF LEN(INKEY$) THEN EXIT DO    'faster than testing if INKEY$ = ""
  73.     
  74.     ULC = 9: LRC = 70
  75.     ULR = 3: LRR = 17:
  76.     BORDER% = 4 OR 256
  77.     LABEL$ = "Drop Box"
  78.     ATTR% = &H17    'Back = 1: Fore = 7
  79.     CALL DropWindow(ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  80.     Text$ = "Moving Text"
  81.     CALL QPRINT(ULR% + 1, ULC% + 25, Text$, &H1E)
  82.     CALL Delayer(.18)
  83.     
  84.     IF LEN(INKEY$) THEN EXIT DO
  85.     
  86.     ULC = 12: LRC = 67
  87.     ULR = 10: LRR = 21:
  88.     LABEL$ = "Exploding Drop Box"
  89.     BORDER% = 2 OR 256
  90.     ATTR% = &H47   'Back = 4: Fore = 7
  91.     CALL ExplodingDrop(ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  92.     
  93.     CALL DownRow(4, 10, 8, 68, &H1E)
  94.     
  95.     IF LEN(INKEY$) THEN EXIT DO
  96.     
  97.     BORDER% = 2 OR 256 'add shadow to border type 2 with OR 256
  98.     ULC = 30: LRC = 54
  99.     ULR = 16: LRR = 23:
  100.     LABEL$ = "Another Drop Box"
  101.     ATTR% = &H2F     'Back = 2: Fore = 15
  102.                   'don't use black foreground w/ green background
  103.                   'if will have an EGA mono display because it
  104.                   'wont show up
  105.     CALL DropWindow(ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  106.     
  107.     Text$ = "(c) S J Kelly 1990"  'faster if assign text to variable
  108.     CALL QPRINT(ULR% + 1, ULC% + 3, Text$, &H2F)
  109.     CALL FunScroll(ULR% + 1, ULC% + 1, LRR% - 1, LRC% - 1, &H2F)
  110.     
  111.     IF LEN(INKEY$) THEN EXIT DO
  112.     
  113.     BORDER% = 3 OR 256
  114.     ULC = 63: LRC = 77
  115.     ULR = 2: LRR = 11:
  116.     LABEL$ = "Tiny"
  117.     ATTR% = &H5E      'Back = 5: Fore = 14
  118.     CALL DropWindow(ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  119.     Text$ = "Bounce text"
  120.     CALL QPRINT(ULR% + 1, ULC% + 2, Text$, ATTR%)
  121.     
  122.     CALL Delayer(.18)
  123.     
  124.     CALL FunScroll(ULR% + 1, ULC% + 2, LRR% - 1, LRC% - 1, ATTR%)
  125.     CALL FunScroll(ULR% + 1, ULC% + 2, LRR% - 1, LRC% - 1, ATTR%)
  126.     
  127.     CALL Delayer(.13)
  128.     
  129.     ULC = 2: LRC = 25
  130.     ULR = 18: LRR = 24:
  131.     LABEL$ = "Lower Box"
  132.     BORDER% = 2
  133.     ATTR% = &H70     'Back = 7: Fore = 0
  134.     CALL ExplodingWindow(ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$)
  135.     CALL Delayer(.4)
  136.  
  137.     IF LEN(INKEY$) THEN EXIT DO
  138.  
  139. LOOP
  140. CALL SAVESCRN(VARSEG(Scrn%(0)), VARPTR(Scrn%(0)))
  141.  
  142. 'Clears the display when complete
  143. CALL ClearCircle
  144.  
  145. 'shows that the text was not affected
  146. ULR = 1: ULC = 1: LRR = 25: LRC = 80
  147.  
  148. FOR X% = 0 TO 120 STEP 5
  149.     CALL CLEARAREA(ULR, ULC, LRR, LRC, X%)
  150.     CALL Delayer(.25)
  151.     CALL RESTSCRN(VARSEG(Scrn%(0)), VARPTR(Scrn%(0)))
  152.     CALL Delayer(.15)
  153. NEXT X%
  154.  
  155. CALL Delayer(.1)
  156.  
  157. IF (Attrib1 = &H17) THEN    ' if have a display that can show color well
  158.     'show how one set of colors can be changed at a time
  159.     CALL RECOLOR(&H70, &H17)
  160.     CALL Delayer(.15)
  161.     CALL RECOLOR(&H5E, &H17)
  162.     CALL Delayer(.15)
  163.     CALL RECOLOR(&H2F, &H17)
  164.     CALL Delayer(.15)
  165.     CALL RECOLOR(&H47, &H17)
  166.     CALL Delayer(.15)
  167.     CALL RECOLOR(&H1E, &H17)
  168.     CALL Delayer(.15)
  169.     CALL RECOLOR(&H7, &H20)
  170.     CALL Delayer(.15)
  171.     CALL RECOLOR(&H30, &H40)
  172. END IF
  173.  
  174. CALL Delayer(2)
  175. CALL EGAMONO(0)    'turn of EGA mono pallette, use default
  176.  
  177. CALL FADE          'fade out display
  178.  
  179.  
  180.  
  181. CALL SETQP(10, 10, Attrib1) 'set up information for QPRINTL
  182.  
  183. Text$ = "Status information concerning your video adapter."
  184. CALL QPRT(10, 10, Text$)   'note that no attribute has to be selected
  185.  
  186. IF DUALDISPLAY% THEN
  187.     Text$ = "You have a DUAL DISPLAY, so I will select the other."
  188.     CALL QPRT(11, 10, Text$)
  189.         
  190.         IF INCOLOR THEN
  191.             CALL SWAPMONO       'sets any herc to half mode if have 2 displays
  192.             CALL QPRINTL("A mono display.")
  193.             CALL Delayer(.45)
  194.             CALL SWAPCOLOR
  195.         ELSE
  196.             CALL SWAPCOLOR
  197.             CALL QPRINTL("A color display.")
  198.             CALL Delayer(.45)
  199.             CALL SWAPMONO       'sets any herc to half mode if have 2 displays
  200.         END IF
  201.             
  202.         SCREEN 0: WIDTH 80, 25
  203.         LOCATE 1, 1
  204.  
  205. ELSE
  206.     Text$ = "You only have one display type active: "
  207.     CALL QPRT(12, 10, Text$)
  208.     IF FINDCOLOR% THEN
  209.         CALL QPRINTL("A color display.")
  210.     ELSE
  211.         CALL QPRINTL("A mono display.")
  212.     END IF
  213. END IF
  214.  
  215. LOCATE 13, 10
  216. PRINT "Active Display:  ";
  217.     SELECT CASE VIDEOSTAT%
  218.         CASE 13
  219.             PRINT "VGA with color";
  220.         CASE 11
  221.             PRINT "MCGA with color";
  222.         CASE 10
  223.             PRINT "EGA, VGA or MCGA monochrome";
  224.         CASE 9
  225.             PRINT "EGA with color ECD";
  226.         CASE 8
  227.             PRINT "64KB EGA with color ECD";
  228.         CASE 4
  229.             PRINT "AT&T single color CGA";
  230.         CASE 3
  231.             PRINT "Hercules, with graphics enabled ";
  232.         CASE 2
  233.             PRINT "CGA";
  234.         CASE 0
  235.             PRINT "normal mono";
  236.         CASE -2
  237.             PRINT "COMPAQ single color CGA";
  238.         CASE -3
  239.             PRINT "Hercules, (but MSHERC.COM is not installed)";
  240.         CASE -8
  241.             PRINT "64KB EGA with CGA";
  242.         CASE -9
  243.             PRINT "EGA with CGA";
  244.         CASE -11
  245.             PRINT "MCGA with ECD";
  246.         CASE ELSE
  247.             PRINT "error";
  248.     END SELECT
  249.     PRINT " display."
  250.     PRINT
  251.  
  252. CALL VIDINFO(Mode%, ROW%, COLUMN%, CURPAGE%, PAGESIZE%)
  253. LOCATE , 10
  254. PRINT "Current Bios Mode: "; Mode%
  255. LOCATE , 10
  256. PRINT "Current Length of display:"; ROW; "lines."
  257. LOCATE , 10
  258. PRINT "Current Width of display:"; COLUMN%; "columns."
  259. LOCATE , 10
  260. PRINT "The current active Page:"; CURPAGE%
  261. LOCATE , 10
  262. PRINT "The current Pagesize: ";
  263. PRINT USING "#####,"; PAGESIZE%; : PRINT " bytes."
  264.  
  265. Text$ = "The End!!"    'faster if assign text to variable
  266. CALL VPRINT(1, 1, Text$, &H47)  'shows vertical printing
  267.  
  268. Text$ = "Copyright Copr. 1990, Sidney J. Kelly, All Rights Reserved"
  269. CALL QPRINT(2, 5, Text$, &H47)
  270.  
  271. END
  272.  
  273. '============================================================================
  274. 'Clears the display of a Color display
  275. '============================================================================
  276. SUB ClearCircle STATIC
  277.     
  278.     STATIC Click!
  279.  
  280. MaxLen = 25   'length of display
  281. Click! = .04
  282. StopNum = MaxLen \ 2 + 1
  283. Characters = 1
  284.  
  285. Attrib = 0
  286. Bottom = MaxLen
  287. Right = 80
  288. Top = 1: Left = 1
  289.  
  290. DO
  291.    
  292.     ROW = Top                 'Clear Across the row
  293.     FOR COL = Left TO Right
  294.         CALL QATTRIB(ROW%, COL%, Characters%, Attrib%)
  295.     NEXT COL
  296.     
  297.     CALL Delayer(Click!)
  298.  
  299.     SELECT CASE Top           'Stop at center of screen
  300.         CASE StopNum
  301.             EXIT DO
  302.         CASE ELSE
  303.             Top = Top + 1
  304.     END SELECT
  305.   
  306.     COL = Right
  307.     
  308.     FOR ROW = Top TO Bottom    'Clear Down the right side
  309.         CALL QATTRIB(ROW%, COL%, Characters%, Attrib%)
  310.     NEXT ROW
  311.     CALL Delayer(Click!)
  312.     Right = Right - 1
  313.    
  314.     ROW = Bottom                 'Clear across the bottom
  315.     
  316.     FOR COL = Right TO Left STEP -1
  317.         CALL QATTRIB(ROW%, COL%, Characters%, Attrib%)
  318.     NEXT COL
  319.     Bottom = Bottom - 1
  320.  
  321.     COL = Left                   'Clear up the left side
  322.     CALL Delayer(Click!)
  323.     
  324.     FOR ROW = Bottom TO Top STEP -1
  325.         CALL QATTRIB(ROW%, COL%, Characters%, Attrib%)
  326.     NEXT ROW
  327.     
  328.     CALL Delayer(Click!)
  329.     Left = Left + 1
  330.     
  331. LOOP
  332.  
  333. END SUB
  334.  
  335. ' =============================== Delay ================================
  336. '   Better Timer Delay Function
  337. '   Delay based on time so that wait will be the same on any processor.
  338. '   Notice the check for negative numbers so that the delay won't
  339. '   freeze at midnight when the delay could become negative.
  340. '
  341. '   A much better routine is available in Programmers Journal that uses
  342. '   Long integers for more precise delays without the 10kb overhead of
  343. '   floating point numbers.  The routine is copyrighted by ETHAN WINER
  344. '   of Cresent Software.
  345. ' ======================================================================
  346. SUB Delayer (Factor!) STATIC
  347.    STATIC Begin!
  348.   
  349.    Begin! = TIMER
  350.    DO UNTIL (TIMER - Begin! > Factor!) OR (TIMER - Begin! < 0)
  351.    LOOP
  352.  
  353. END SUB
  354.  
  355. '===========================================================================
  356. 'Scroll down text in defined window three rows
  357. '===========================================================================
  358. SUB DownRow (ULR%, ULC%, LRR%, LRC%, ATTR%) STATIC
  359.     STATIC Factor1!
  360.     Factor1! = .025
  361.  
  362.     CALL SCROLLDOWN(ULR%, ULC%, LRR%, LRC%, 1, ATTR%)
  363.     CALL Delayer(Factor1!)
  364.   
  365.     CALL SCROLLDOWN(ULR%, ULC%, LRR%, LRC%, 1, ATTR%)
  366.     CALL Delayer(Factor1!)
  367.   
  368.     CALL SCROLLDOWN(ULR%, ULC%, LRR%, LRC%, 1, ATTR%)
  369.     CALL Delayer(Factor1!)
  370.     
  371. END SUB
  372.  
  373. '======================================================================
  374. 'Draws a Drop Windowed box
  375. '======================================================================
  376. SUB DropWindow (ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$) STATIC
  377.  
  378.     HASHNO% = 32
  379.     CALL MAKEBOXES(ULR, ULC, LRR, LRC, HASHNO%, BORDER%, ATTR%)
  380.    
  381.     SELECT CASE LEN(LABEL$)
  382.         CASE 1 TO ((LRC - ULC) - 5)
  383.             T$ = "[" + LABEL$ + "]"
  384.             CALL QPRINT(ULR, ULC + 3, T$, ATTR)
  385.         CASE ELSE
  386.     END SELECT
  387.     T$ = ""
  388.  
  389. END SUB
  390.  
  391. '=========================================================================
  392. 'Exploding Drop Windows
  393. '
  394. 'Note this can be rather messy looking on snowy CGA displays.
  395. '=========================================================================
  396. SUB ExplodingDrop (ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$) STATIC
  397.  
  398.     STATIC Factor1!
  399.     Factor1! = .0001
  400.  
  401.     X1% = ULC + ((LRC% - ULC%) \ 2)
  402.     X2% = LRC - ((LRC% - ULC%) \ 2)
  403.     Y1% = ULR + ((LRR% - ULR%) \ 2)
  404.     Y2% = LRR - ((LRR% - ULR%) \ 2)
  405.  
  406. DO
  407.     
  408.     IF X1% > ULC THEN X1% = X1% - 3: IF X1% < ULC THEN X1% = ULC
  409.     IF X2% < LRC THEN X2% = X2% + 3: IF X2% > LRC THEN X2% = LRC
  410.     IF Y1% > ULR THEN Y1% = Y1% - 1
  411.     IF Y2% < LRR THEN Y2% = Y2% + 1
  412.     
  413.     IF (X1% = ULC) AND (X2% = LRC) AND (Y1% = ULR) AND Y2% = (LRR) THEN
  414.         
  415.         HASHNO% = 32
  416.         CALL MAKEBOXES(ULR, ULC, LRR, LRC, HASHNO%, BORDER%, ATTR%)
  417.         SELECT CASE LEN(LABEL$)
  418.             CASE 1 TO ((LRC - ULC) - 5)
  419.                 T$ = "[" + LABEL$ + "]"
  420.                 CALL QPRINT(ULR, ULC + 3, T$, ATTR)
  421.             CASE ELSE
  422.         END SELECT
  423.         T$ = ""
  424.         EXIT SUB
  425.     
  426.     END IF
  427.     
  428.     'Draw main window
  429.     
  430.     HASHNO% = 32
  431.     CALL MAKEBOXES(Y1%, X1%, Y2%, X2%, HASHNO%, BORDER%, ATTR%)
  432.     SELECT CASE LEN(LABEL$)
  433.         CASE 1 TO ((X2 - X1) - 5)
  434.             T$ = "[" + LABEL$ + "]"
  435.             CALL QPRINT(Y1, X1 + 3, T$, ATTR)
  436.         CASE ELSE
  437.     END SELECT
  438.     T$ = ""
  439.     
  440.     CALL Delayer(Factor1!)
  441.  
  442. LOOP
  443.  
  444. END SUB
  445.  
  446. '===========================================================================
  447. 'Draws an Exploding window
  448. '===========================================================================
  449. SUB ExplodingWindow (ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$) STATIC
  450.    
  451.     X1% = ULC + INT((LRC - ULC) / 2)
  452.     X2% = LRC - INT((LRC - ULC) / 2)
  453.     Y1% = ULR + INT((LRR - ULR) / 2)
  454.     Y2% = LRR - INT((LRR - ULR) / 2)
  455.  
  456. DO
  457.     
  458.     IF X1% > ULC THEN X1% = X1% - 3: IF X1% < ULC THEN X1% = ULC
  459.     IF X2% < LRC THEN X2% = X2% + 3: IF X2% > LRC THEN X2% = LRC
  460.     IF Y1% > ULR THEN Y1% = Y1% - 1
  461.     IF Y2% < LRR THEN Y2% = Y2% + 1
  462.     
  463.     'Calling setup Border%s also acts as a delay factor
  464.     
  465.     HASHNO% = 32
  466.     CALL MAKEBOXES(Y1%, X1%, Y2%, X2%, HASHNO%, BORDER%, ATTR%)
  467.  
  468.     SELECT CASE LEN(LABEL$)
  469.         CASE 1 TO ((X2 - X1) - 5)
  470.             T$ = "[" + LABEL$ + "]"
  471.             CALL QPRINT(Y1, X1 + 3, T$, ATTR)
  472.         CASE ELSE
  473.     END SELECT
  474.     T$ = ""
  475.     CALL Delayer(.001)
  476.     
  477.     IF (X1% = ULC) AND (X2% = LRC) AND (Y1% = ULR) AND Y2% = (LRR) THEN
  478.         EXIT DO
  479.     END IF
  480. LOOP
  481.  
  482. END SUB
  483.  
  484. '===========================================================================
  485. 'Make text in a defined window bounce
  486. '===========================================================================
  487. SUB FunScroll (ULR%, ULC%, LRR%, LRC%, ATTR%) STATIC
  488.     STATIC MiliDelay!
  489.     MiliDelay! = .034
  490.  
  491.     CALL SCROLLDOWN(ULR%, ULC%, LRR%, LRC%, 1, ATTR%)
  492.     CALL Delayer(MiliDelay!)
  493.    
  494.     CALL SCROLLDOWN(ULR%, ULC%, LRR%, LRC%, 1, ATTR%)
  495.     CALL Delayer(MiliDelay!)
  496.    
  497.     CALL SCROLLDOWN(ULR%, ULC%, LRR%, LRC%, 1, ATTR%)
  498.     CALL Delayer(MiliDelay!)
  499.    
  500.     CALL SCROLLDOWN(ULR%, ULC%, LRR%, LRC%, 1, ATTR%)
  501.     CALL Delayer(MiliDelay!)
  502.    
  503.     CALL SCROLLUP(ULR%, ULC%, LRR%, LRC%, 1, ATTR%)
  504.     CALL Delayer(MiliDelay!)
  505.  
  506.     CALL SCROLLUP(ULR% + 1, ULC%, LRR%, LRC% - 1, 1, ATTR%)
  507.     CALL Delayer(MiliDelay!)
  508.  
  509. END SUB
  510.  
  511. '===========================================================================
  512. 'NormalWindow Program, typical popup w/o drops or exploding
  513. '===========================================================================
  514. SUB NormalWindow (ULR%, ULC%, LRR%, LRC%, ATTR%, BORDER%, LABEL$) STATIC
  515.     
  516.     SELECT CASE BORDER%
  517.         CASE 1 - 4
  518.             HASHNO% = 32
  519.         CASE ELSE
  520.             HASHNO% = 176
  521.     END SELECT
  522.     
  523.     CALL MAKEBOXES(ULR, ULC, LRR, LRC, HASHNO%, BORDER%, ATTR%)
  524.     
  525.     SELECT CASE LEN(LABEL$)
  526.         CASE 1 TO ((LRC - ULC) - 5)
  527.             T$ = "[" + LABEL$ + "]"
  528.             CALL QPRINT(ULR, ULC + 3, T$, ATTR)
  529.         CASE ELSE
  530.     END SELECT
  531.     T$ = ""
  532.  
  533. END SUB
  534.  
  535.