DECLARE SUB draw.cursor (mx%, my%)
DECLARE SUB load.cursor ()
DECLARE SUB restore.font ()
DECLARE SUB set.font.char (index%)
DECLARE SUB get.mouse (x%, y%, b%)
DECLARE FUNCTION init.mouse% ()
DECLARE SUB memcopy (destseg%, destoff%, srcseg%, srcoff%, numbytes%)
DECLARE SUB get.font.table ()
'$INCLUDE: 'qb.bi'
DEFINT A-Z
CLS
TYPE frame
x1 AS INTEGER
y1 AS INTEGER
x2 AS INTEGER
y2 AS INTEGER
END TYPE
IF NOT init.mouse THEN
PRINT "No mouse driver"
END
END IF
DIM SHARED font.table(2048) AS INTEGER
DIM SHARED font.table.backup(2048) AS INTEGER
get.font.table
DIM SHARED cursor(8, 16) AS INTEGER
DIM SHARED background(2, 2) AS INTEGER
DIM SHARED omx, omy
load.cursor
first.frame = -1
'show.mouse
PRINT
PRINT
PRINT
PRINT "Smooth mouse cursor v1.0"
PRINT " by moi :)"
PRINT
PRINT "This shows how font manipulation can be used"
PRINT "to create a smooth scrolling mouse cursor in"
PRINT "text mode. It uses four characters from 240-"
PRINT "243 to draw the cursor on top of the letters"
PRINT "and write it to the font table, creating the"
PRINT "image you see as the cursor. There's still a"
PRINT "bug I haven't removed: one of the bits isn't"
PRINT "written to the font table, causing a line to"
PRINT "be drawn every 8th bit on the screen. It's a"
PRINT "simple thing to solve, probably, but I don't"
PRINT "want to waste more time on it right now."
PRINT
PRINT "Have fun :)"
DO
get.mouse mx, my, mb
IF mx <> omx OR my <> omy OR first.frame THEN
IF first.frame THEN
'omx = mx
'omy = my
first.frame = 0
END IF
LOCATE 1, 1
PRINT mx; my; mb
PRINT mx \ 8; my \ 8
draw.cursor mx, my
omx = mx
omy = my
END IF
LOOP WHILE INKEY$ = ""
restore.font
DATA 2,2,0,0,0,0,0,0
DATA 2,1,2,0,0,0,0,0
DATA 2,1,1,2,0,0,0,0
DATA 2,1,1,1,2,0,0,0
DATA 2,1,1,1,1,2,0,0
DATA 2,1,1,1,1,1,2,0
DATA 2,1,1,1,1,1,1,2
DATA 2,2,2,1,1,2,2,2
DATA 0,0,0,2,1,1,2,0
DATA 0,0,0,2,1,1,2,0
DATA 0,0,0,0,2,1,1,2
DATA 0,0,0,0,2,2,2,2
DATA 0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0
SUB draw.cursor (mx, my)
IF omx \ 8 <> mx \ 8 OR omy \ 8 <> my \ 8 THEN
FOR y = 0 TO 1
FOR x = 0 TO 1
yy = omy \ 8 + y + 1
xx = omx \ 8 + x + 1
IF xx > 0 AND yy > 0 AND xx <= 80 AND yy <= 25 THEN
LOCATE yy, xx
COLOR 7, 0
IF background(x, y) = 0 THEN background(x, y) = 32
PRINT CHR$(background(x, y));
END IF
NEXT x
NEXT y
END IF
'use chars 240-243 to draw the cursor
mmx = mx \ 8
mmy = my \ 8
IF omx \ 8 <> mx \ 8 OR omy \ 8 <> my \ 8 THEN
FOR y = 0 TO 1
FOR x = 0 TO 1
yy = 1 + mmy + y
xx = 1 + mmx + x
IF xx > 0 AND yy > 0 AND xx <= 80 AND yy <= 25 THEN
background(x, y) = SCREEN(yy, xx)
END IF
NEXT x
NEXT y
END IF
dx = mx AND 7
dy = (my AND 7) * 2
index = 240
s = VARSEG(font.table(0))
o = VARPTR(font.table(0))
FOR y = 0 TO 1
FOR x = 0 TO 1
memcopy s, o + index * 16, s, o + background(x, y) * 16, 16
index = index + 1
NEXT x
NEXT y
DEF SEG = s
i = 240
FOR y = 0 TO 1
FOR x = 0 TO 1
oo = o + i * 16
FOR yy = 0 TO 15
row = PEEK(oo)
FOR xx = 0 TO 7
IF xx + x * 8 - dx >= 0 AND xx + x * 8 - dx < 8 AND yy + y * 16 - dy >= 0 AND yy + y * 16 - dy < 16 THEN
IF cursor(xx + x * 8 - dx, yy + y * 16 - dy) = 1 THEN
row = row OR (2 ^ (7 - xx))
ELSEIF cursor(xx + x * 8 - dx, yy + y * 16 - dy) = 2 THEN
row = row AND (255 XOR (2 ^ (7 - xx)))
END IF
END IF
NEXT xx
POKE oo, row
oo = oo + 1
NEXT yy
set.font.char i
yy = 1 + mmy + y
xx = 1 + mmx + x
IF xx > 0 AND yy > 0 AND xx <= 80 AND yy <= 25 THEN
LOCATE yy, xx
PRINT CHR$(i);
COLOR 7, 0
END IF
i = i + 1
NEXT x
NEXT y
END SUB
SUB get.font.table
DIM r AS RegTypeX
r.ax = &H1130
r.bx = &H600
CALL interruptx(&H10, r, r)
bpc = r.cx 'bytes per char
rows = (r.dx AND 255) + 1
fseg = r.es
foff = r.bp
memcopy VARSEG(font.table(0)), VARPTR(font.table(0)), fseg, foff, 4096
memcopy VARSEG(font.table.backup(0)), VARPTR(font.table.backup(0)), fseg, foff, 4096
END SUB
SUB get.mouse (x, y, b)
DIM r AS regtype
r.ax = 3
CALL interrupt(&H33, r, r)
x = r.cx
y = r.dx
b = r.bx
END SUB
SUB hide.mouse
DIM r AS regtype
r.ax = 2
CALL interrupt(&H33, r, r)
END SUB
FUNCTION init.mouse
DIM r AS regtype
r.ax = 0
CALL interrupt(&H33, r, r)
init.mouse = (r.ax <> 0)
END FUNCTION
SUB load.cursor
FOR y = 0 TO 15
FOR x = 0 TO 7
READ cursor(x, y)
NEXT x
NEXT y
END SUB
SUB memcopy (destseg, destoff, srcseg, srcoff, numbytes)
FOR i = 0 TO numbytes - 1
DEF SEG = srcseg
byte = PEEK(srcoff + i)
DEF SEG = destseg
POKE destoff + i, byte
NEXT i
DEF SEG
END SUB
SUB restore.font
memcopy VARSEG(font.table(0)), VARPTR(font.table(0)), VARSEG(font.table.backup(0)), VARPTR(font.table.backup(0)), 2048
FOR i = 0 TO 255
set.font.char i
NEXT i
END SUB
SUB set.font.char (index)
DIM r AS RegTypeX
r.ax = &H1100
r.bx = &H1000
r.cx = 1
r.dx = index
r.es = VARSEG(font.table(0))
r.bp = VARPTR(font.table(0)) + 16 * index
CALL interruptx(&H10, r, r)
END SUB
SUB show.mouse
DIM r AS regtype
r.ax = 1
CALL interrupt(&H33, r, r)
END SUB
|