home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / FNTPAK32.ZIP / BASIC.EXE / DEMOMOUS.BAS < prev    next >
BASIC Source File  |  1995-08-16  |  7KB  |  289 lines
  1. DEFINT A-Z
  2.  
  3. '$INCLUDE: 'Font_Pak.Inc'           '... For QB/PDS/VB-DOS
  4.  
  5. '======================================================== PowerBasic Users
  6. ''$INCLUDE "Font_Pak.Inc"             '... PB users, UN-REM these lines
  7.  
  8. ''$Link    "FontPakP.OBJ"             '... SHAREWARE users
  9.  
  10. ''$Link    "Video.OBJ"                '... REGISTERED users
  11. ''$Link    "Fonts.OBJ"                '        "        "
  12. ''$Link    "Mouse_P.OBJ"              '        "        "
  13. ''$Link    "LdCursor.Obj"             '        "        "
  14.  
  15.  
  16. '======================================================== PowerBasic Users
  17.  
  18. '============================================================ DemoMous.Bas
  19. '
  20. ' A Font Pak Demonstration         Copyright 1991-1994 Rob W. Smetana
  21. '
  22. ' - Demonstrate how to use a few mouse routines
  23. ' - Show how easy it is to re-map the mouse cursor shape
  24. '
  25. ' Requires:     - A mouse
  26. '
  27. '               - Font_Pak.Lib (QB/PDS/VB-DOS) -or- Font_Pak.PBU (PowerBasic)
  28. '
  29. '============================================================ DemoMous.Bas
  30.  
  31. '==== Local Routines
  32. DECLARE SUB ClearButtons ()
  33. DECLARE SUB SetUpGrid ()
  34. DECLARE SUB DoMouseDemo ()
  35. DECLARE SUB DisplayButtons (Buttons%, PX%, PY%)
  36. DECLARE SUB Normal ()
  37. DECLARE SUB PrintMsg (PosX%, PosY%, PrintTxt$)
  38. DECLARE SUB Reverse ()
  39.  
  40. ForeGround = 7: BackGround = 1
  41.  
  42. SCREEN 0, 0
  43. WIDTH 80, 25                        '...DON'T change this.  This demo
  44.                                     '   assumes you're in 25-line mode!
  45.  
  46. COLOR 7, 1: CLS
  47.  
  48. CALL fpInitialize: CLS              '=== SHAREWARE versions ONLY
  49.  
  50. CALL DoMouseDemo
  51.  
  52. SUB ClearButtons
  53.  
  54.          
  55.     DO
  56.          '... the last 0 means return TEXT mode Row/Col rather than Pixels
  57.  
  58.          Buttons = rsButtonPressed(MouseRow, MouseCol, 0)
  59.  
  60.     LOOP WHILE Buttons
  61.  
  62. END SUB
  63.  
  64. SUB DisplayButtons (Buttons, PX, PY)
  65.  
  66.     Reverse
  67.  
  68.     LOCATE 24, 27: PRINT "Button(s) pressed: ";
  69.  
  70.     SELECT CASE Buttons
  71.         CASE 1          'LeftButton
  72.             PRINT "Left          ";
  73.         CASE 2          'RightButton
  74.             PRINT "Right         ";
  75.         CASE 3          'Both Left AND RightButton
  76.             PRINT "Left & right  ";
  77.         CASE 4
  78.             PRINT "Middle         ";
  79.         'CASE ELSE
  80.         '   PRINT "Unknown        ";
  81.     END SELECT
  82.  
  83.     LOCATE 24, 60: PRINT "Row="; PY; "  Col="; PX;
  84.  
  85.     Normal
  86.  
  87. END SUB
  88.  
  89. '
  90. SUB DoMouseDemo
  91.  
  92.     SHARED ForeGround, BackGround
  93.  
  94.     Normal
  95.     CLS
  96.  
  97.     IF rsThereIsAMouse = 0 THEN
  98.        PRINT
  99.        PRINT "Sorry, I couldn't find or initialize the mouse.  I can't continue."
  100.        PRINT
  101.        EXIT SUB
  102.     END IF
  103.  
  104.     '...display a grid
  105.  
  106.     SetUpGrid
  107.     PrintMsg 24, 2, " A Mouse IS Installed."
  108.  
  109.     '...load mouse shapes 1-4 into block 0, remapping ASCII slots 224-277
  110.  
  111.     FOR MouseCharacter = 224 TO 227
  112.         CALL rsLoadMouseCursor(0, MouseCharacter - 223, MouseCharacter)
  113.     NEXT
  114.  
  115.     '...set (select) ASCII 224
  116.  
  117.     MouseCharacter = 224
  118.  
  119.     '...this version of rsSetTextCursor lets you SELECT the FG/BG colors
  120.  
  121.     CALL rsSetTextCursor(14, BackGround, MouseCharacter)
  122.  
  123.  
  124.     '...Part 1 of the demo
  125.  
  126.     LOCATE 25, 2: Reverse: PRINT SPACE$(78);
  127.     LOCATE 25, 2, Zero
  128.     PRINT " Press the Left OR Right mouse buttons (or both).    Press <Escape> to Quit.";
  129.  
  130.  
  131.     CALL rsShowcursor
  132.  
  133.     ClearButtons
  134.  
  135.     DO UNTIL INKEY$ = CHR$(27)                  '... exit on Escape
  136.  
  137.         '...rsButtonPressed's final parameter (0) means return TEXT-mode Row/Col.
  138.         '   Change "0" to -1 (or any non-0 value) to tell rsButtonPressed
  139.         '   to return GRAPHICS-mode pixel coordinates.  But do NOT do
  140.         '   that here because we expect MouseRow and MouseCol to be in
  141.         '   the range of 1-25 and 1-80, respectively.
  142.  
  143.         Buttons = rsButtonPressed(MouseRow, MouseCol, 0)
  144.  
  145.         '...If the mouse has moved, change cursor shape based on Row/Col
  146.  
  147.         IF MouseRow <> LastRow OR MouseCol <> LastCol THEN
  148.  
  149.             SELECT CASE MouseRow
  150.                 CASE 1 TO 13
  151.                      IF MouseCol < 41 THEN MouseCharacter = 224 ELSE MouseCharacter = 226
  152.                 CASE ELSE
  153.                      IF MouseCol < 41 THEN MouseCharacter = 225 ELSE MouseCharacter = 227
  154.             END SELECT
  155.  
  156.             CALL rsSetTextCursor(14, BackGround, MouseCharacter)
  157.  
  158.         END IF
  159.  
  160.  
  161.         '... Should we update the screen:  Which button/Where the cursor is?
  162.  
  163.         IF MouseRow <> LastRow OR MouseCol <> LastCol OR Buttons THEN
  164.  
  165.             LastRow = MouseRow: LastCol = MouseCol
  166.  
  167.             DisplayButtons Buttons, MouseCol, MouseRow
  168.  
  169.         END IF
  170.  
  171.         '...If a mouse button is pressed, CHANGE the COLOR of the cursor.
  172.         '   The cursor WILL flicker if you hold a button down.
  173.  
  174.         IF Buttons THEN
  175.            CALL rsSetTextCursor(15, 4, MouseCharacter)
  176.  
  177.            '...rsSetTextCursorC INVERTS or USES FG/BG colors under the mouse
  178.            'CALL rsSetTextCursorC(-1, MouseCharacter)  '-1 = Invert; 0 = Use
  179.  
  180.            '...ClearButtons would eliminate flicker.  But it also would
  181.            '   prevent us from changing mouse shapes if you hold down a
  182.            '   button and then move across a grid boundary.
  183.  
  184.                'ClearButtons
  185.  
  186.         END IF
  187.  
  188.     LOOP
  189.  
  190.     CALL rsHidecursor
  191.  
  192.  
  193.     '...Part 2 of the demo
  194.  
  195.     ClearButtons
  196.  
  197.     CLS
  198.     PRINT
  199.     PRINT "  We just showed how you could re-map the shape of ASCII characters, then"
  200.     PRINT "  use those shapes as mouse cursors."
  201.     PRINT
  202.     PRINT "  But you can select ANY ASCII character, even though you haven't changed"
  203.     PRINT "  shapes.  Click either mouse button to see a few.        <Escape> = QUIT"
  204.     
  205.  
  206.     CALL rsShowcursor
  207.  
  208.     MouseCharacter = 1          '...start with ASCII 1
  209.                                 '   try ASCII 223 - 254 as well
  210.     CALL rsSetTextCursor(14, BackGround, MouseCharacter)
  211.  
  212.     DO UNTIL INKEY$ = CHR$(27)                  '... exit on Escape
  213.  
  214.         '...the last 0 = TextOrPixels (return TEXT-mode Row/Col)
  215.  
  216.         Buttons = rsButtonPressed(MouseRow, MouseCol, 0)
  217.  
  218.  
  219.         IF Buttons THEN
  220.  
  221.            '...get next one (mapped from chr$(228) to chr$(245)
  222.  
  223.            MouseCharacter = MouseCharacter + 1
  224.            IF MouseCharacter = 32 THEN MouseCharacter = 224
  225.  
  226.            CALL rsSetTextCursor(14, BackGround, MouseCharacter)
  227.  
  228.            '...wait until the button is released so we don't move too quickly
  229.            ClearButtons
  230.  
  231.         END IF
  232.  
  233.     LOOP
  234.  
  235.     CALL rsHidecursor
  236.  
  237. END SUB
  238.  
  239. SUB Normal
  240.  
  241.     SHARED ForeGround, BackGround
  242.  
  243.     COLOR ForeGround, BackGround
  244.  
  245. END SUB
  246.  
  247. SUB PrintMsg (PosX, PosY, PrintTxt$)
  248.  
  249.  
  250.     Reverse
  251.  
  252.     LOCATE PosX, PosY
  253.     PRINT LEFT$(PrintTxt$ + STRING$(50, " "), 50);
  254.  
  255.     Normal
  256.  
  257. END SUB
  258.  
  259. SUB Reverse
  260.  
  261.     SHARED ForeGround, BackGround
  262.  
  263.     COLOR BackGround, ForeGround
  264.  
  265. END SUB
  266.  
  267. SUB SetUpGrid
  268.  
  269.  
  270.     PRINT "              Move the mouse cursor around the CENTER of this grid."
  271.     PRINT "             Watch what happens each time the cursor crosses a line!"
  272.     PRINT
  273.     PRINT "             Also HOLD DOWN either mouse button, and then do the same."
  274.  
  275.     LOCATE 13, 10: PRINT STRING$(60, 196)
  276.  
  277.     FOR x = 7 TO 21: LOCATE x, 40: PRINT "│"; : NEXT
  278.  
  279.     LOCATE 13, 40: PRINT CHR$(197)
  280.  
  281.     Reverse
  282.  
  283.     LOCATE 24, 2: PRINT SPACE$(78);
  284.  
  285.     Normal
  286.  
  287. END SUB
  288.  
  289.