home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / qbnewsl / qbnws202 / mousecur / mouscurs.bas < prev    next >
BASIC Source File  |  1991-06-01  |  15KB  |  511 lines
  1. 'MOUSCURS.BAS  by Dr. Warren G. Lieuallen    v 3.1    3/3/91
  2. '  a program to "automate" drawing a graphic mouse cursor
  3. '  allows copying of cursor mask to screen mask, and clearing of either,
  4. '  automatic screen mask "expansion", user-definable hot-spot, on-screen
  5. '  representation of mouse on foreground and background, saving of
  6. '  either entire sub-program or only DATA, supports full-color and
  7. '  all screen modes!, loading of saved cursors
  8.  
  9. DEFINT A-Z
  10. OPTION BASE 1
  11. 'DECLARE FUNCTION QExist (filname$)
  12. DECLARE FUNCTION Dir$ (filename$)
  13. DECLARE SUB CopyIt ()
  14. DECLARE SUB ClearIt (x)
  15. DECLARE SUB Active ()
  16. DECLARE SUB DeActive ()
  17. DECLARE SUB Expand ()
  18. DECLARE SUB NewMousCurs ()
  19. DECLARE SUB EndIt (x, ctype)
  20. DECLARE SUB NewCursMask ()
  21.  
  22. ' Define Variable type for Interrupt
  23. TYPE RegType
  24.      ax    AS INTEGER
  25.      bx    AS INTEGER
  26.      cx    AS INTEGER
  27.      dx    AS INTEGER
  28.      bp    AS INTEGER
  29.      si    AS INTEGER
  30.      di    AS INTEGER
  31.      flags AS INTEGER
  32. END TYPE
  33.  
  34. DIM reg AS RegType, MousCurs&(32), CursMask(16, 32), CrsMsk&(64)
  35. DIM SHARED ratx!, raty!
  36. DECLARE SUB INTERRUPT (intnum, reg1 AS RegType, reg2 AS RegType)
  37.  
  38. FOR i = 1 TO 16
  39.    FOR j = 1 TO 16
  40.       CursMask(i, j) = -2             'Initialize masks to blanks
  41.       CursMask(i, j + 16) = 1
  42.    NEXT j
  43. NEXT i
  44.  
  45. FOR i = 17 TO 32
  46.    MousCurs&(i) = 65535
  47. NEXT i
  48. hotx = 5: hoty = 0
  49.  
  50. 'CALL QCrtMode(ctype, ccols)
  51. CLS : PRINT : PRINT "Enter graphics type:"
  52. PRINT : PRINT "1. Hercules"
  53. PRINT "2. CGA"
  54. PRINT "3. EGA"
  55. PRINT "4. VGA"
  56. PRINT : INPUT ctype
  57.  
  58. IF ctype = 1 THEN
  59.    DEF SEG = &H40
  60.    POKE &H49, 6                        'Adjustment for Hercules screen
  61.    DEF SEG
  62. END IF
  63.  
  64. reg.ax = 0
  65. CALL INTERRUPT(&H33, reg, reg)         'Reset driver and read status
  66. IF reg.ax = 0 THEN GOTO nomouse
  67.  
  68. SELECT CASE ctype
  69.    CASE 1                              'Hercules
  70.       SCREEN 3
  71.       ratx! = 1: raty! = 1
  72.       sx = 9: sy = 14
  73.    CASE 2                              'CGA?
  74.       SCREEN 2
  75.       ratx! = 640 / 720: raty! = 200 / 348
  76.       sx = 8: sy = 8
  77.    CASE 3                              'EGA?
  78.       SCREEN 9
  79.       ratx! = 640 / 720: raty! = 350 / 348
  80.       sx = 8: sy = 14
  81.    CASE 4                              'VGA
  82.       SCREEN 12
  83.       ratx! = 640 / 720: raty! = 398 / 348
  84.       sx = 8: sy = 16
  85.    CASE ELSE
  86.       PRINT : PRINT "Maybe you should select one of the supported graphics modes!"
  87.       PRINT : PRINT "Please try again."
  88.       END
  89. END SELECT
  90.  
  91. q1 = INT(635 * ratx!): q2 = INT(167 * raty!): q3 = INT(656 * ratx!)
  92.  
  93. FOR i = 1 TO 32
  94.    READ wrd
  95.    Msk$ = Msk$ + MKI$(wrd)
  96. NEXT i
  97.  
  98. reg.ax = 9
  99. reg.bx = 5: reg.cx = 0
  100. reg.dx = SADD(Msk$)
  101. CALL INTERRUPT(&H33, reg, reg)      'Define graphic cursor
  102.  
  103. reg.ax = 4
  104. reg.cx = 270 * ratx!: reg.dx = 150 * raty!
  105. CALL INTERRUPT(&H33, reg, reg)      'Position mouse cursor
  106.  
  107. reg.ax = 1
  108. CALL INTERRUPT(&H33, reg, reg)      'Show mouse cursor
  109.  
  110. IF ctype > 2 THEN COLOR 15
  111. LOCATE 1, 13: PRINT "Mouse Cursor Design Tool   by Dr. Warren G. Lieuallen"
  112. LINE (90 * ratx!, 13 * raty!)-(600 * ratx!, 13 * raty!)
  113. IF ctype > 2 THEN COLOR 14
  114. LOCATE 19, 40: PRINT "Expand"
  115. LOCATE 20, 21: PRINT "-> Copy ->"
  116. LOCATE 21, 4: PRINT "   Clear                            Clear"
  117. LOCATE 22, 61: PRINT "Activate Cursor": LOCATE 23, 60: PRINT "DeActivate Cursor"
  118. LOCATE 24, 5: PRINT "Save Data      Save Program      Load Cursor     Exit";
  119. IF ctype > 2 THEN COLOR 7
  120. LOCATE 2, 21: PRINT "Dec."; TAB(27); "Hex": LOCATE 2, 54: PRINT "Dec."; TAB(60); "Hex"
  121. LOCATE 9, 71: PRINT "Custom": LOCATE 10, 71: PRINT "Cursor": LOCATE 11, 69: PRINT "Appearance"
  122. LOCATE 20, 3: PRINT "(Cursor Mask)": LOCATE 20, 36: PRINT "(Screen Mask)"
  123.  
  124. IF ctype > 2 THEN COLOR 12
  125. LINE (6 * ratx!, 26 * raty!)-(155 * ratx!, 252 * raty!), , B   'Box around cursor mask
  126. LINE (303 * ratx!, 26 * raty!)-(453 * ratx!, 252 * raty!), , B 'Box around screen mask
  127. IF ctype > 2 THEN COLOR 7
  128. LINE (q1 - 2, q2 - 2)-(q3 - 2, q2 + 18), , B'Box around cursor-shape
  129. LINE (q3 - 2, q2 - 2)-(q3 + 18, q2 + 18), , BF'Inverse box
  130.  
  131. FOR i = 0 TO 15
  132.    LOCATE i + 3, 2
  133.    FOR j = 0 TO 15
  134.       PRINT ".";
  135.    NEXT j
  136.    LOCATE i + 3, 35
  137.    FOR j = 0 TO 15
  138.       PRINT "1";
  139.    NEXT j
  140. NEXT i
  141.  
  142.  
  143. FOR i = 1 TO 16
  144.    LOCATE 2 + i, 21
  145.    PRINT "0"; TAB(27); "0"
  146.    LOCATE 2 + i, 54
  147.    PRINT "65535"; TAB(60); "FFFF"
  148. NEXT i
  149. reg.ax = 3
  150.  
  151. DO
  152.    CALL INTERRUPT(&H33, reg, reg)   'Position and button status
  153.   
  154.    IF reg.bx = 1 THEN               'Left Button pressed
  155.       x = reg.cx \ sx + 1: y = reg.dx \ sy + 1
  156.       'LOCATE 22, 20: PRINT y; ","; x
  157.       IF y = 19 THEN CALL Expand: CALL NewMousCurs
  158.       IF y = 20 THEN CALL CopyIt: CALL NewMousCurs
  159.       IF y = 21 THEN CALL ClearIt(x): CALL NewMousCurs
  160.       IF y = 22 THEN CALL Active: reg.ax = 3
  161.       IF y = 23 THEN CALL DeActive: reg.ax = 3
  162.       IF y = 24 THEN CALL EndIt(x, ctype): reg.ax = 3
  163.       IF y < 3 OR y > 18 THEN GOTO toobig
  164.       IF x < 2 OR x > 50 THEN GOTO toobig
  165.       IF x > 17 AND x < 35 THEN GOTO toobig
  166.       IF x > 34 THEN x = x - 17
  167.       reg.ax = 2: CALL INTERRUPT(&H33, reg, reg)   'Hide cursor
  168.       CursMask(y - 2, x - 1) = NOT CursMask(y - 2, x - 1)
  169.      
  170.       IF x < 18 THEN
  171.          LOCATE y, x: PRINT CHR$(48 + (CursMask(y - 2, x - 1)))
  172.       ELSE
  173.          LOCATE y, x + 17: PRINT CHR$(48 + (CursMask(y - 2, x - 1)))
  174.       END IF
  175.      
  176.       reg.ax = 1: CALL INTERRUPT(&H33, reg, reg)   'Show cursor
  177.       reg.ax = 3
  178.      
  179.       CALL NewMousCurs
  180.   
  181.    ELSEIF reg.bx = 2 THEN         'Right button pressed
  182.       hotx = reg.cx \ sx - 1: hoty = reg.dx \ sy - 2
  183.       IF hotx < 0 OR hotx > 16 THEN GOTO toobig
  184.       IF hoty < 0 OR hoty > 16 THEN GOTO toobig
  185.       CursMask(hoty + 1, hotx + 1) = NOT CursMask(hoty + 1, hotx + 1)
  186.      
  187.       reg.ax = 2: CALL INTERRUPT(&H33, reg, reg)   'Hide cursor
  188.       LOCATE hoty + 3, hotx + 2: PRINT CHR$(88 + 40 * (CursMask(hoty + 1, hotx + 1) = -2))
  189.       reg.ax = 1: CALL INTERRUPT(&H33, reg, reg)   'Show cursor
  190.       reg.ax = 3
  191.     
  192.       CALL NewMousCurs
  193.   
  194.    END IF
  195. toobig:
  196. LOOP
  197.  
  198. END
  199.  
  200. nomouse:
  201. SCREEN 0
  202. PRINT : PRINT "  Sorry, but the program REQUIRES a mouse."
  203. PRINT : PRINT "    Press any key to exit...."
  204. WHILE INKEY$ = "": WEND
  205. END
  206.  
  207. DATA &HF3FF
  208. DATA &HE1FF
  209. DATA &HE1FF
  210. DATA &HE1FF
  211. DATA &HE07F
  212. DATA &HE00F
  213. DATA &HE001
  214. DATA &H8000
  215. DATA &H0000
  216. DATA &H0000
  217. DATA &H0000
  218. DATA &H0000
  219. DATA &H0000
  220. DATA &H0000
  221. DATA &H8001
  222. DATA &HC003
  223.  
  224. DATA &H0C00
  225. DATA &H1200
  226. DATA &H1200
  227. DATA &H1200
  228. DATA &H1380
  229. DATA &H1270
  230. DATA &H124E
  231. DATA &H7249
  232. DATA &H9249
  233. DATA &H9001
  234. DATA &H9001
  235. DATA &H8001
  236. DATA &H8001
  237. DATA &H8001
  238. DATA &H4002
  239. DATA &H3FFC
  240.  
  241. SUB Active
  242. SHARED reg AS RegType, MousCurs&(), hotx, hoty
  243.  
  244.    FOR i = 17 TO 32
  245.       CMsk$ = CMsk$ + MID$(MKL$(MousCurs&(i)), 1, 2)
  246.    NEXT i
  247.    FOR i = 1 TO 16
  248.       CMsk$ = CMsk$ + MID$(MKL$(MousCurs&(i)), 1, 2)
  249.    NEXT i
  250.  
  251.    reg.ax = 9
  252.    reg.bx = hotx: reg.cx = hoty
  253.    reg.dx = SADD(CMsk$)
  254.    CALL INTERRUPT(&H33, reg, reg)      'Define custom graphic cursor
  255.  
  256. END SUB
  257.  
  258. SUB ClearIt (x)
  259. SHARED CursMask(), MousCurs&()
  260.  
  261.    IF x < 20 THEN
  262.       FOR i = 1 TO 16
  263.          FOR j = 1 TO 16
  264.             CursMask(i, j) = -2
  265.          NEXT j
  266.          MousCurs&(i) = 0
  267.       NEXT i
  268.      
  269.       FOR y = 3 TO 18
  270.          FOR x = 1 TO 16
  271.             LOCATE y, x + 1: PRINT CHR$(48 + (CursMask(y - 2, x)))
  272.          NEXT x
  273.       NEXT y
  274.  
  275.    ELSE
  276.       FOR i = 1 TO 16
  277.          FOR j = 1 TO 16
  278.             CursMask(i, j + 16) = 1
  279.          NEXT j
  280.          MousCurs&(i + 16) = 65535
  281.       NEXT i
  282.       FOR y = 3 TO 18
  283.          FOR x = 17 TO 32
  284.             LOCATE y, x + 18: PRINT CHR$(48 + (CursMask(y - 2, x)))
  285.          NEXT x
  286.       NEXT y
  287.  
  288.    END IF
  289.  
  290. END SUB
  291.  
  292. SUB CopyIt
  293. SHARED CursMask(), MousCurs&()
  294.  
  295.    FOR i = 1 TO 16
  296.       MousCurs&(i + 16) = 0
  297.       FOR j = 1 TO 16
  298.          CursMask(i, j + 16) = NOT CursMask(i, j)
  299.       NEXT j
  300.    NEXT i
  301.   
  302.    FOR y = 3 TO 18
  303.       FOR x = 17 TO 32
  304.          LOCATE y, x + 18: PRINT CHR$(48 + (CursMask(y - 2, x)))
  305.       NEXT x
  306.    NEXT y
  307.  
  308. END SUB
  309.  
  310. SUB DeActive
  311. SHARED Msk$, reg AS RegType
  312.  
  313.    reg.ax = 9
  314.    reg.bx = 5: reg.cx = 0
  315.    reg.dx = SADD(Msk$)
  316.    CALL INTERRUPT(&H33, reg, reg)
  317.  
  318. END SUB
  319.  
  320. SUB EndIt (x, ctype)
  321. SHARED MousCurs&(), reg AS RegType, hotx, hoty
  322.  
  323.    reg.ax = 2: CALL INTERRUPT(&H33, reg, reg)   'Hide cursor
  324.    IF x < 35 THEN
  325.       CLOSE #1
  326.       i = 1
  327.       IF x > 17 THEN filname$ = "CURSORn.BAS" ELSE filname$ = "CURSORn.BI"
  328. namefile:
  329.       MID$(filname$, 7) = CHR$(i + 48)
  330.       'IF NOT QExist(filname$ + CHR$(0)) THEN i = i + 1: GOTO namefile
  331.       IF LEN(Dir$(filname$)) THEN i = i + 1: GOTO namefile
  332.       OPEN filname$ FOR OUTPUT AS #1
  333.       PRINT #1, "'Custom Graphic Mouse Cursor Routine  by Dr. Warren G. Lieuallen"
  334.       IF x > 17 THEN
  335.          PRINT #1, "TYPE RegType             'Variable for CALL Interrupt"
  336.          PRINT #1, "     ax    AS INTEGER"
  337.          PRINT #1, "     bx    AS INTEGER"
  338.          PRINT #1, "     cx    AS INTEGER"
  339.          PRINT #1, "     dx    AS INTEGER"
  340.          PRINT #1, "     bp    AS INTEGER"
  341.          PRINT #1, "     si    AS INTEGER"
  342.          PRINT #1, "     di    AS INTEGER"
  343.          PRINT #1, "     flags AS INTEGER"
  344.          PRINT #1, "END TYPE"
  345.          PRINT #1, "DIM reg AS RegType"
  346.          PRINT #1, "DECLARE SUB Interrupt (intnum%, reg1 AS RegType, reg2 AS RegType)"
  347.          IF ctype = 0 THEN
  348.             PRINT #1,
  349.             PRINT #1, "   DEF SEG = &H40"
  350.             PRINT #1, "   POKE &H49, 6"
  351.             PRINT #1, "   DEF SEG"
  352.          END IF
  353.          PRINT #1, "reg.ax = 0"
  354.          PRINT #1, "CALL Interrupt(&H33, reg, reg)         'Reset driver and read status"
  355.          PRINT #1, "IF reg.ax = 0 THEN END                 'No mouse driver found"
  356.          PRINT #1,
  357.          PRINT #1, "FOR i = 1 TO 32"
  358.          PRINT #1, "   READ wrd%"
  359.          PRINT #1, "   MMsk$ = MMsk$ + MKI$(wrd%)"
  360.          PRINT #1, "NEXT i"
  361.          PRINT #1, "READ hotx,hoty"
  362.          PRINT #1,
  363.          PRINT #1, "' *** Add appropriate SCREEN statement here ***"
  364.          PRINT #1,
  365.          PRINT #1, "reg.ax = 9"
  366.          PRINT #1, "reg.bx = hotx: reg.cx = hoty"
  367.          PRINT #1, "reg.dx = SADD(MMsk$)"
  368.          PRINT #1, "CALL Interrupt(&H33, reg, reg)    'Define graphic cursor"
  369.          PRINT #1, "reg.ax = 1"
  370.          PRINT #1, "CALL Interrupt(&H33, reg, reg)    'Show mouse cursor"
  371.          PRINT #1,
  372.          LOCATE 25, 21: PRINT filname$;
  373.       ELSE LOCATE 25, 5: PRINT filname$;
  374.       END IF
  375.       FOR i = 17 TO 32
  376.          PRINT #1, "DATA &H"; HEX$(MousCurs&(i))
  377.       NEXT i
  378.       PRINT #1,
  379.       FOR i = 1 TO 16
  380.          PRINT #1, "DATA &H"; HEX$(MousCurs&(i))
  381.       NEXT i
  382.       PRINT #1,
  383.       PRINT #1, "DATA"; hotx
  384.       PRINT #1, "DATA"; hoty
  385.       PRINT #1, "' ------ End of cursor routine ------"
  386.       CLOSE #1
  387.   
  388.    ELSEIF x < 53 THEN
  389.       LOCATE 23, 38: INPUT "FileName"; filname$
  390.       CLOSE #1
  391.       OPEN filname$ FOR INPUT AS #1
  392.       i = 17
  393.       DO UNTIL i = 33
  394.          LINE INPUT #1, cdata$
  395.          IF MID$(cdata$, 1, 5) = "DATA " THEN
  396.             MousCurs&(i) = VAL(MID$(cdata$, 6))
  397.             IF MousCurs&(i) < 0 THEN MousCurs&(i) = MousCurs&(i) + 65536
  398.             i = i + 1
  399.          END IF
  400.       LOOP
  401.       i = 1
  402.       DO UNTIL i = 17
  403.          LINE INPUT #1, cdata$
  404.          IF MID$(cdata$, 1, 5) = "DATA " THEN
  405.             MousCurs&(i) = VAL(MID$(cdata$, 6))
  406.             IF MousCurs&(i) < 0 THEN MousCurs&(i) = MousCurs&(i) + 65536
  407.             i = i + 1
  408.          END IF
  409.       LOOP
  410.       LINE INPUT #1, cdata$
  411.       LINE INPUT #1, cdata$: hotx = VAL(MID$(cdata$, 6))
  412.       LINE INPUT #1, cdata$: hoty = VAL(MID$(cdata$, 6))
  413.       CLOSE #1
  414.       'IF i <> 32 THEN BEEP: LOCATE 23, 38: PRINT "Error Reading File": SLEEP 2
  415.       LOCATE 23, 38: PRINT SPACE$(22)
  416.       CALL NewCursMask
  417.       CALL NewMousCurs
  418.  
  419.    ELSE
  420.       SCREEN 0: CLS : END
  421.    END IF
  422.    reg.ax = 1: CALL INTERRUPT(&H33, reg, reg)   'Show cursor
  423.  
  424. END SUB
  425.  
  426. SUB Expand
  427. SHARED CursMask(), MousCurs&()
  428.  
  429.    FOR i = 1 TO 16
  430.       FOR j = 1 TO 16
  431.          IF CursMask(i, j) = 1 THEN
  432.             FOR a = -1 TO 1
  433.                FOR B = -1 TO 1
  434.                   IF i + a > 0 AND i + a < 17 AND j + B > 0 AND j + B < 17 THEN
  435.                      IF CursMask(i + a, j + 16 + B) = 1 THEN
  436.                         CursMask(i + a, j + 16 + B) = -2
  437.                         LOCATE i + a + 2, j + 16 + B + 18: PRINT "."
  438.                         PRESET (q3 + j, q2 + i)
  439.                      END IF
  440.                   END IF
  441.                NEXT B
  442.             NEXT a
  443.          END IF
  444.       NEXT j
  445.    NEXT i
  446.  
  447. END SUB
  448.  
  449. SUB NewCursMask
  450. SHARED CursMask(), MousCurs&(), hotx, hoty
  451.  
  452.    'Rebuilds CursMask() from loaded MousCurs&()
  453.    FOR i = 1 TO 16
  454.       FOR j = 1 TO 16
  455.          CursMask(i, j) = -2
  456.          IF MousCurs&(i) AND 2 ^ (16 - j) THEN
  457.             CursMask(i, j) = 1
  458.          END IF
  459.          LOCATE i + 2, j + 1: PRINT CHR$(48 + (CursMask(i, j)))
  460.       NEXT j
  461.    NEXT i
  462.  
  463.    FOR i = 1 TO 16
  464.       FOR j = 17 TO 32
  465.          CursMask(i, j) = -2
  466.          IF MousCurs&(i + 16) AND 2 ^ (32 - j) THEN
  467.             CursMask(i, j) = 1
  468.          END IF
  469.          LOCATE i + 2, j + 18: PRINT CHR$(48 + (CursMask(i, j)))
  470.       NEXT j
  471.    NEXT i
  472.  
  473.    LOCATE hoty + 3, hotx + 2: PRINT CHR$(88 + 40 * (CursMask(hoty + 1, hotx + 1) = -2))
  474.  
  475. END SUB
  476.  
  477. SUB NewMousCurs
  478. SHARED MousCurs&(), CursMask(), CrsMsk&(), q1, q2, q3
  479.  
  480.    'rebuilds MousCurs&() based on CursMask values
  481.    FOR i = 1 TO 16
  482.       MousCurs&(i) = 0: MousCurs&(i + 16) = 65535
  483.       FOR j = 1 TO 16
  484.          IF CursMask(i, j) = 1 THEN MousCurs&(i) = MousCurs&(i) + (2 ^ (16 - j) * (SGN(CursMask(i, j))))
  485.       NEXT j
  486.  
  487.       FOR j = 17 TO 32
  488.          IF CursMask(i, j) = -2 THEN MousCurs&(i + 16) = MousCurs&(i + 16) + (2 ^ (32 - j) * (SGN(CursMask(i, j))))
  489.       NEXT j
  490.    NEXT i
  491.   
  492.    FOR i = 1 TO 16
  493.       LOCATE 2 + i, 20
  494.       PRINT MousCurs&(i); TAB(27); HEX$(MousCurs&(i)); "   "
  495.       LOCATE 2 + i, 53
  496.       PRINT MousCurs&(i + 16); TAB(60); HEX$(MousCurs&(i + 16)); "   "
  497.    NEXT i
  498.  
  499.    FOR i = 1 TO 16
  500.       FOR j = 1 TO 16
  501.          IF CursMask(i, j + 16) > 0 THEN PSET (q3 + j - 1, q2 + i - 1), 7 ELSE PRESET (q3 + j - 1, q2 + i - 1)
  502.          IF CursMask(i, j) > 0 THEN PSET (q1 + j - 1, q2 + i - 1), 15 ELSE PRESET (q1 + j - 1, q2 + i - 1)
  503.       NEXT j
  504.    NEXT i
  505.   
  506.    GET (q1, q2)-(q1 + 15, q2 + 15), CrsMsk&
  507.    PUT (q3, q2), CrsMsk&, XOR
  508.  
  509. END SUB
  510.  
  511.