Qbasicnews.com

Qbasicnews.com > QBasic > QB Projects > Video13h v1.3
Full Version: Video13h v1.3
You're currently viewing a stripped down version of our content. View the full version with proper formatting.

Nemesis

09-12-2004, 04:09 AM
It's here! I finally found some time to work on it yesterday, and a little today Smile
I fixed some major errors from version 1.2!
I added blending capabilities in both font and sprite routines,
added ability to use, save, & load, large sprites/tiles
without errors, (if running in the IDE), fixed the delay routine,
and improved the multi-key routine.
Also, I removed the old page buffering technique, which used the HD constantly, and replaced it with QB's PUT, (the most common
non ASM way.)
Now, to complete the library and make the final 'public release'
I need to turn it into a .qlb, code some decent demos, (not like the lame ones that come with it now), add some other routines like joystick/joypad routines, 2-D graphic roto-zooming, timming routines, a fill command, speed optimizations and other enhancements. (When I have some more free time again.)
Other than that, I'd like to mention that this version is pure QB, so it's not too fast compared to most QB/ASM libs on the net :oops:
(Compile it for a significant speed improvement.)
Please don't distribute since this is not the official 'public release'
You may use any rotines for your own programs, if you find any of them useful, but please... give me credit if you use any code that is unique, (like code out of the norm, or code you never seen or used before).
Video 13hv1.3 QuickBASIC v4.5 (source)...

Code:
'''
' VIDEO13h v1.3, QuickBASIC 4.5, (SCREEN 13), manipulation routines.
'
' (C)opyright 2004, Pure QB Innovations
'
' Email any questions, comments, or suggestions to...
'  ESmemberNEMESIS@aol.com
'
' Visit the, PQBI web site, (under construction), at...
'  http://members.aol.com/esmembernemesis
'
' THIS PROGRAM MAY BE DISTRIBUTED FREELY AS PUBLIC DOMAIN SOFTWARE
' AS LONG AS ANY PART OF THIS FILE IS NOT ALTERED IN ANY WAY.
' IF YOU DO WISH TO USE THESE ROUTINES IN YOUR OWN PROGRAMS
' THEN PLEASE GIVE CREDIT TO THE AUTHOR... Mario LaRosa.
'
'
'
'
'$DYNAMIC
'
DEFINT A-Z
'
TYPE REGXdata
AX    AS INTEGER
BX    AS INTEGER
cx    AS INTEGER
DX    AS INTEGER
BP    AS INTEGER
SI    AS INTEGER
DI    AS INTEGER
FL    AS INTEGER
DS    AS INTEGER
ES    AS INTEGER
END TYPE
'
TYPE PNTdata
switch AS INTEGER
frame AS INTEGER
lb AS INTEGER
rb AS INTEGER
xx AS INTEGER
yy AS INTEGER
minXX AS INTEGER
minYY AS INTEGER
maxXX AS INTEGER
maxYY AS INTEGER
END TYPE
'
TYPE PALdata
Red AS INTEGER
Grn AS INTEGER
Blu AS INTEGER
END TYPE
'
COMMON SHARED PAL() AS PALdata
'
COMMON SHARED REGX AS REGXdata
COMMON SHARED PNT AS PNTdata
COMMON SHARED SYS&, PUTcolour
COMMON SHARED clipXXleft, clipYYTOP, clipXXright, clipYYbottom
'
DECLARE FUNCTION V13hLOF& (file$)
'
DECLARE SUB V13hCLS (colour)
DECLARE SUB V13hCLP (xxLEFT, yyTOP, xxRIGHT, yyBOTTOM)
DECLARE SUB V13hCPY (Tsegm&, Toffs, Dsegm&, Doffs, Bytes&, Blits$)
DECLARE SUB V13hPAL (file$)
DECLARE SUB V13hBLN (file$)
DECLARE SUB V13hBLD (ARRAY(), file$)
DECLARE SUB V13hBND (ARRAY(), file$)
DECLARE SUB V13hBSV (ARRAY(), file$)
DECLARE SUB V13hDEL (seconds!)
DECLARE SUB V13hFDE (fadeOUT, fadeINN, fadeSEC!)
DECLARE SUB V13hKEY ()
DECLARE SUB V13hPNT (ARRAY(), frame, colour)
DECLARE SUB V13hPUT (ARRAY(), xxLEFT, yyTOP, frame, skin$)
DECLARE SUB V13hSPR (ARRAY(), xxLEFT, yyTOP, frame, skin$)
DECLARE SUB V13hSEE ()
DECLARE SUB V13hSET ()
DECLARE SUB V13hTXT (ARRAY(), XXcenter, xxLEFT, yyTOP, colour, text$, skin$)
'
DECLARE SUB INTERRUPTX (INTNUM AS INTEGER, INREG AS REGXdata, OUTREG AS REGXdata)
'
DECLARE SUB DEMO ()
'
DIM SHARED PAL(0 TO 255) AS PALdata
'
DIM SHARED BLN&(0 TO 255)
'
DIM SHARED VIDEO(0 TO 32007)
DIM SHARED BLEND(0 TO 16447)
DIM SHARED FONTS(0 TO 3263)
DIM SHARED MOUSE(0 TO 129)
DIM SHARED BOARD(0 TO 127)
'
V13hSET
'
DEMO
'
SYSTEM
'

SUB DEMO
'
' DRAW AND GET, (-3- 20*20) TILES. (DEMO)...
'
DIM TILES(0 TO 606)
FOR x = 0 TO 40 STEP 20
  col = col + 1
  LINE (x, 0)-(x + 19, 19), col, BF
  LINE (x, 0)-(x + 19, 19), 15, B
  LINE (x + 5, 5)-(x + 14, 14), 0, BF
  GET (x, 0)-(x + 19, 19), TILES(stp)
  stp = stp + 202
NEXT
'
'SCROLLING FONT DEMO...
'
FOR y = (clipYYbottom + 1) TO (clipYYTOP - (32 * 8)) STEP -1
  V13hCLS 0
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 0), 15, "-WELCOME-", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 2), 7, "VIDEO13h v1.3, Pure QuickBASIC v4.5,", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 4), 7, "(SCREEN 13), manipulation routines.", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 8), 15, "-FEATURES-", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 10), 7, "320X200X256 resolution (VGA),", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 12), 7, "page flipping, sprite animation,", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 14), 7, "sprite clipping, font routines,", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 16), 7, "mouse and keyboard handlers.", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 18), 7, "Also supports QuickBASIC's,", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 20), 7, "original graphical commands too!", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 24), 15, "-REQUIREMENTS-", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 26), 7, "100+ Mhz PC processor, a VGA monitor,", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 28), 7, "keyboard, mouse, and QuickBASIC v4.5", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 32), 15, "-CREDITS-", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 34), 15, "...Programmer...", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 36), 7, "Mario LaRosa, ESmemberNEMESIS@aol.com", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 40), 15, "...Special Thanks...", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 42), 7, "Jonathan Dale Kirwan, JonKirwan@aol.com", "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 44), 7, "Quinton Roberts, Eclipzer@aol.com", "TRANSPARENT"
  V13hTXT FONTS(), FALSE, 0, (8 * 24), 15, "(C)opyright 2004,", "BLEND"
  V13hTXT FONTS(), FALSE, (8 * 18), (8 * 24), 12, "Pure", "BLEND"
  V13hTXT FONTS(), FALSE, (8 * 23), (8 * 24), 10, "QB", "BLEND"
  V13hTXT FONTS(), FALSE, (8 * 26), (8 * 24), 9, "Innovations", "BLEND"
  V13hSEE
  IF LEN(INKEY$) THEN EXIT FOR
  '
NEXT
'
'FADE OUT/IN DEMO...
'
V13hFDE NOT FALSE, NOT FALSE, 1 / 32
'
DO: LOOP UNTIL LEN(INKEY$)
'
'MOUSE DEMO...
'
DO
  V13hCLS 0
  V13hPNT MOUSE(), 1, 15
  V13hTXT FONTS(), NOT FALSE, 0, 14, 2, "PNT.xx = " + STR$(PNT.xx), "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, 22, 2, "PNT.yy = " + STR$(PNT.yy), "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, 169, 4, "PNT.lb = " + STR$(PNT.lb), "TRANSPARENT"
  V13hTXT FONTS(), NOT FALSE, 0, 177, 4, "PNT.rb = " + STR$(PNT.rb), "TRANSPARENT"
  V13hSEE
LOOP UNTIL LEN(INKEY$)
'
'DELAY DEMO...
'
CLS
LOCATE 1, 1: PRINT "V13hDEL 1/4 seconds..."
PRINT
DO: LOOP UNTIL TIMER <> TIMER
DO
  t! = TIMER
  V13hDEL 1 / 4
  PRINT TIMER - t!
LOOP UNTIL LEN(INKEY$)
'
CLS
LOCATE 1, 1: PRINT "V13hDEL 1/8 seconds..."
PRINT
DO: LOOP UNTIL TIMER <> TIMER
DO
  t! = TIMER
  V13hDEL 1 / 8
  PRINT TIMER - t!
LOOP UNTIL LEN(INKEY$)
'
CLS
LOCATE 1, 1: PRINT "V13hDEL 1/32 seconds..."
PRINT
DO: LOOP UNTIL TIMER <> TIMER
DO
  t! = TIMER
  V13hDEL 1 / 32
  PRINT TIMER - t!
LOOP UNTIL LEN(INKEY$)
'
'''
''' CLEAR SCREEN (256X) DEMO...
'''
'
DO: LOOP UNTIL TIMER <> TIMER
t! = TIMER
FOR c = 0 TO 255
  V13hCLS c
  V13hSEE
NEXT
t! = TIMER - t!
LOCATE 1, 1: PRINT "V13hCLS (256X):"; t!
DO: LOOP UNTIL LEN(INKEY$)
'
'''
''' (1O,OOO) RANDOM PIXELS DEMO...
'''
V13hCLS 0
DO: LOOP UNTIL TIMER <> TIMER
t! = TIMER
FOR x = 1 TO 10000
  PSET (INT(RND(1) * 319 + 1), INT(RND(1) * 199 + 1)), INT(RND(1) * 255 + 1)
NEXT
t! = TIMER - t!
V13hSEE
LOCATE 1, 1: PRINT "PSET (1O,OOOX):"; t!
DO: LOOP UNTIL LEN(INKEY$)
'
'''
''' (1O,OOO) RANDOM LINES DEMO...
'''
'
V13hCLS 0
DO: LOOP UNTIL TIMER <> TIMER
t! = TIMER
FOR x = 1 TO 10000
  x1 = INT(RND * 340) - 10: x2 = INT(RND * 340) - 10
  y1 = INT(RND * 220) - 10: y2 = INT(RND * 220) - 10
  LINE (x1, y1)-(x2, y2), INT(RND * 15) + 1
NEXT
t! = TIMER - t!
V13hSEE
LOCATE 1, 1: PRINT "LINE (1O,OOOX):"; t!
DO: LOOP UNTIL LEN(INKEY$)
'
'''
''' (1O,OOO) RANDOM TILES DEMO...
'''
'
kind$ = "SOLID"
DO
  V13hCLS 0
  DO: LOOP UNTIL TIMER <> TIMER
  t! = TIMER
  FOR x = 1 TO 10000
   xx = INT(RND(1) * 341 + -20)
   yy = INT(RND(1) * 221 + -20)
   frame = INT(RND(1) * 3 + 1)
   V13hPUT TILES(), xx, yy, frame, kind$
  NEXT
  t! = TIMER - t!
  V13hSEE
  K$ = "V13hPUT " + kind$ + " (1O,OOOX):"
  LOCATE 1, 1: PRINT K$; t!
  DO: LOOP UNTIL LEN(INKEY$)
  SELECT CASE kind$
   CASE "SOLID"
    kind$ = "TRANSPARENT"
   CASE "TRANSPARENT"
    kind$ = "BLEND"
   CASE "BLEND"
    kind$ = "BEHIND"
   CASE "BEHIND"
    kind$ = "PSET"
   CASE "PSET"
    kind$ = "PRESET"
   CASE "PRESET"
    kind$ = "AND"
   CASE "AND"
    kind$ = "OR"
   CASE "OR"
    kind$ = "XOR"
   CASE "XOR"
    EXIT DO
  END SELECT
LOOP
'
scroll:
'
'''
'''KEYBOARD & SCROLLING DEMO
'''
'
t& = TIMER
DO
  s = s + 1
  IF ABS(TIMER - t&) >= 1 THEN FPS = s: s = 0: t& = TIMER
  FOR yy = -20 TO 200 STEP 20
   FOR xx = -20 TO 320 STEP 20
    V13hPUT TILES(), (xx + ZX), (yy + ZY), 1, "PSET"
   NEXT
  NEXT
  '
  V13hPUT TILES(), 149, 89, 2, "TRANSPARENT"
  '
  V13hKEY
  '
  IF BOARD(80) THEN ZY = ZY - 1: AD = NOT FALSE ELSE AD = FALSE
  IF BOARD(75) THEN ZX = ZX + 1: AL = NOT FALSE ELSE AL = FALSE
  IF BOARD(77) THEN ZX = ZX - 1: AR = NOT FALSE ELSE AR = FALSE
  IF BOARD(72) THEN ZY = ZY + 1: AU = NOT FALSE ELSE AU = FALSE
  IF ZY > 19 OR ZY < -19 THEN ZY = 0
  IF ZX > 19 OR ZX < -19 THEN ZX = 0
  V13hTXT FONTS(), FALSE, 0, 0, 10, "FPS:" + STR$(FPS), "TRANSPARENT"
  V13hTXT FONTS(), FALSE, 0, 16, 11, "Arrow up:   " + STR$(AU), "TRANSPARENT"
  V13hTXT FONTS(), FALSE, 0, 24, 11, "Arrow down: " + STR$(AD), "TRANSPARENT"
  V13hTXT FONTS(), FALSE, 0, 32, 11, "Arrow right:" + STR$(AR), "TRANSPARENT"
  V13hTXT FONTS(), FALSE, 0, 40, 11, "Arrow left: " + STR$(AL), "TRANSPARENT"
  V13hTXT FONTS(), FALSE, 0, 56, 12, "Esc to exit.", "TRANSPARENT"
  V13hSEE
LOOP UNTIL INKEY$ = CHR$(27)
'
EXIT SUB
'
END SUB

REM $STATIC
SUB V13hBLD (ARRAY(), file$)
'
length& = V13hLOF&(file$)
IF length& THEN
  Words = ((length& + 1) \ 2) - 1
  REDIM ARRAY(0 TO Words)
  DEF SEG = VARSEG(ARRAY(0))
  BLOAD file$, 0
END IF
'
END SUB

SUB V13hBLN (file$)
'
DEF SEG = VARSEG(BLEND(0))
'
IF V13hLOF&(file$) > 0 THEN
  BLOAD file$, 0
ELSE
  FOR p = 0 TO 254
   FOR B = p TO 255
    max = 11907
    rt = (PAL(p).Red + PAL(B).Red) \ 2
    gt = (PAL(p).Grn + PAL(B).Grn) \ 2
    bt = (PAL(p).Blu + PAL(B).Blu) \ 2
    FOR c = 0 TO 255
     rd = rt - PAL(c).Red
     gd = gt - PAL(c).Grn
     bd = bt - PAL(c).Blu
     v = (rd * rd) + (gd * gd) + (bd * bd)
     IF v < max THEN
      max = v
      tag = c
      IF v THEN  ELSE EXIT FOR
     END IF
    NEXT
    POKE incb&, tag
    incb& = incb& + 1
   NEXT
  NEXT
  '
  BSAVE file$, 0, (incb& + 1)
  '
END IF
'
END SUB

SUB V13hBND (ARRAY(), file$)
'
length& = V13hLOF&(file$)
IF length& THEN
  Words = (length& \ 2)
  U = UBOUND(ARRAY)
  IF U THEN
   V13hBSV ARRAY(), "buffer.tmp"
   REDIM ARRAY(0 TO (U + Words))
   DEF SEG = VARSEG(ARRAY(0)): BLOAD "buffer.tmp", 0
   KILL "buffer.tmp"
   BLOAD file$, (U + 1) * 2
  ELSE
   REDIM ARRAY(0 TO (Words - 1))
   DEF SEG = VARSEG(ARRAY(0))
   BLOAD file$, 0
  END IF
END IF
'
END SUB

SUB V13hBSV (ARRAY(), file$)
'
DEF SEG = VARSEG(ARRAY(0)): BSAVE file$, 0, (UBOUND(ARRAY) + 1) * 2
'
END SUB

SUB V13hCLP (xxLEFT, yyTOP, xxRIGHT, yyBOTTOM)
'
clipXXleft = xxLEFT
clipYYTOP = yyTOP
clipXXright = xxRIGHT
clipYYbottom = yyBOTTOM
'
IF clipXXleft < 0 THEN clipXXleft = 0
IF clipXXright > 319 THEN clipXXright = 319
IF clipYYTOP < 0 THEN clipYYTOP = 0
IF clipYYbottom > 199 THEN clipYYbottom = 199
'
END SUB

SUB V13hCLS (colour)
'
IF colour THEN
  LINE (clipXXleft, clipYYTOP)-(clipXXright, clipYYbottom), colour, BF
ELSE
  V0 = VIDEO(0)
  V1 = VIDEO(1)
  V2 = VIDEO(2)
  V3 = VIDEO(3)
  V4 = VIDEO(4)
  V5 = VIDEO(5)
  V6 = VIDEO(6)
  V7 = VIDEO(7)
  REDIM VIDEO(0 TO 32007)
  VIDEO(0) = V0
  VIDEO(1) = V1
  VIDEO(2) = V2
  VIDEO(3) = V3
  VIDEO(4) = V4
  VIDEO(5) = V5
  VIDEO(6) = V6
  VIDEO(7) = V7
END IF
'
END SUB

SUB V13hCPY (Tsegm&, Toffs, Dsegm&, Doffs, Bytes&, Blits$)
'
TS& = Tsegm&
DS& = Dsegm&
'
DIM bt(&H0 TO &HF)
DIM bd(&H0 TO &HF)
'
FOR x = &H0 TO &HF
bt(x) = (x + Toffs)
bd(x) = (x + Doffs)
NEXT
'
SELECT CASE Blits$
'
CASE "SOLID"
  '
  FOR x = &H1 TO (Bytes& \ &H10)
   DEF SEG = TS&
   GOSUB tBF
   DEF SEG = DS&
   GOSUB dBF
   TS& = TS& + &H1
   DS& = DS& + &H1
  NEXT
  '
  SELECT CASE (Bytes& MOD &H10)
   CASE &H1
    DEF SEG = TS&
    GOSUB tB0
    DEF SEG = DS&
    GOSUB dB0
   CASE &H2
    DEF SEG = TS&
    GOSUB tB1
    DEF SEG = DS&
    GOSUB dB1
   CASE &H3
    DEF SEG = TS&
    GOSUB tB2
    DEF SEG = DS&
    GOSUB dB2
   CASE &H4
    DEF SEG = TS&
    GOSUB tB3
    DEF SEG = DS&
    GOSUB dB3
   CASE &H5
    DEF SEG = TS&
    GOSUB tB4
    DEF SEG = DS&
    GOSUB dB4
   CASE &H6
    DEF SEG = TS&
    GOSUB tB5
    DEF SEG = DS&
    GOSUB dB5
   CASE &H7
    DEF SEG = TS&
    GOSUB tB6
    DEF SEG = DS&
    GOSUB dB6
   CASE &H8
    DEF SEG = TS&
    GOSUB tB7
    DEF SEG = DS&
    GOSUB dB7
   CASE &H9
    DEF SEG = TS&
    GOSUB tB8
    DEF SEG = DS&
    GOSUB dB8
   CASE &HA
    DEF SEG = TS&
    GOSUB tB9
    DEF SEG = DS&
    GOSUB dB9
   CASE &HB
    DEF SEG = TS&
    GOSUB tBA
    DEF SEG = DS&
    GOSUB dBA
   CASE &HC
    DEF SEG = TS&
    GOSUB tBB
    DEF SEG = DS&
    GOSUB dBB
   CASE &HD
    DEF SEG = TS&
    GOSUB tBC
    DEF SEG = DS&
    GOSUB dBC
   CASE &HE
    DEF SEG = TS&
    GOSUB tBD
    DEF SEG = DS&
    GOSUB dBD
   CASE &HF
    DEF SEG = TS&
    GOSUB tBE
    DEF SEG = DS&
    GOSUB dBE
  END SELECT
  '
CASE "TRANSPARENT"
  '
  FOR x = &H1 TO (Bytes& \ &H10)
   DEF SEG = TS&
   GOSUB tBF
   DEF SEG = DS&
   GOSUB dTF
   TS& = TS& + &H1
   DS& = DS& + &H1
  NEXT
  '
  SELECT CASE (Bytes& MOD &H10)
   CASE &H1
    DEF SEG = TS&
    GOSUB tB0
    DEF SEG = DS&
    GOSUB dT0
   CASE &H2
    DEF SEG = TS&
    GOSUB tB1
    DEF SEG = DS&
    GOSUB dT1
   CASE &H3
    DEF SEG = TS&
    GOSUB tB2
    DEF SEG = DS&
    GOSUB dT2
   CASE &H4
    DEF SEG = TS&
    GOSUB tB3
    DEF SEG = DS&
    GOSUB dT3
   CASE &H5
    DEF SEG = TS&
    GOSUB tB4
    DEF SEG = DS&
    GOSUB dT4
   CASE &H6
    DEF SEG = TS&
    GOSUB tB5
    DEF SEG = DS&
    GOSUB dT5
   CASE &H7
    DEF SEG = TS&
    GOSUB tB6
    DEF SEG = DS&
    GOSUB dT6
   CASE &H8
    DEF SEG = TS&
    GOSUB tB7
    DEF SEG = DS&
    GOSUB dT7
   CASE &H9
    DEF SEG = TS&
    GOSUB tB8
    DEF SEG = DS&
    GOSUB dT8
   CASE &HA
    DEF SEG = TS&
    GOSUB tB9
    DEF SEG = DS&
    GOSUB dT9
   CASE &HB
    DEF SEG = TS&
    GOSUB tBA
    DEF SEG = DS&
    GOSUB dTA
   CASE &HC
    DEF SEG = TS&
    GOSUB tBB
    DEF SEG = DS&
    GOSUB dTB
   CASE &HD
    DEF SEG = TS&
    GOSUB tBC
    DEF SEG = DS&
    GOSUB dTC
   CASE &HE
    DEF SEG = TS&
    GOSUB tBD
    DEF SEG = DS&
    GOSUB dTD
   CASE &HF
    DEF SEG = TS&
    GOSUB tBE
    DEF SEG = DS&
    GOSUB dTE
  END SELECT
  '
END SELECT
'
EXIT SUB
'
tBF: BF = PEEK(bt(&HF))
tBE: be = PEEK(bt(&HE))
tBD: bd = PEEK(bt(&HD))
tBC: bc = PEEK(bt(&HC))
tBB: bb = PEEK(bt(&HB))
tBA: BA = PEEK(bt(&HA))
tB9: b9 = PEEK(bt(&H9))
tB8: b8 = PEEK(bt(&H8))
tB7: b7 = PEEK(bt(&H7))
tB6: b6 = PEEK(bt(&H6))
tB5: b5 = PEEK(bt(&H5))
tB4: b4 = PEEK(bt(&H4))
tB3: b3 = PEEK(bt(&H3))
tB2: b2 = PEEK(bt(&H2))
tB1: b1 = PEEK(bt(&H1))
tB0: b0 = PEEK(bt(&H0))
     '
     RETURN
     '
dBF: POKE bd(&HF), BF
dBE: POKE bd(&HE), be
dBD: POKE bd(&HD), bd
dBC: POKE bd(&HC), bc
dBB: POKE bd(&HB), bb
dBA: POKE bd(&HA), BA
dB9: POKE bd(&H9), b9
dB8: POKE bd(&H8), b8
dB7: POKE bd(&H7), b7
dB6: POKE bd(&H6), b6
dB5: POKE bd(&H5), b5
dB4: POKE bd(&H4), b4
dB3: POKE bd(&H3), b3
dB2: POKE bd(&H2), b2
dB1: POKE bd(&H1), b1
dB0: POKE bd(&H0), b0
     '
     RETURN
     '
dTF: IF BF THEN POKE bd(&HF), BF
dTE: IF be THEN POKE bd(&HE), be
dTD: IF bd THEN POKE bd(&HD), bd
dTC: IF bc THEN POKE bd(&HC), bc
dTB: IF bb THEN POKE bd(&HB), bb
dTA: IF BA THEN POKE bd(&HA), BA
dT9: IF b9 THEN POKE bd(&H9), b9
dT8: IF b8 THEN POKE bd(&H8), b8
dT7: IF b7 THEN POKE bd(&H7), b7
dT6: IF b6 THEN POKE bd(&H6), b6
dT5: IF b5 THEN POKE bd(&H5), b5
dT4: IF b4 THEN POKE bd(&H4), b4
dT3: IF b3 THEN POKE bd(&H3), b3
dT2: IF b2 THEN POKE bd(&H2), b2
dT1: IF b1 THEN POKE bd(&H1), b1
dT0: IF b0 THEN POKE bd(&H0), b0
     '
     RETURN
     '
END SUB

SUB V13hDEL (seconds!) STATIC
'
IF seconds! THEN
  FOR inc& = 1 TO (SYS& * (seconds! * 18.2065)): NEXT
ELSE
  DEF SEG = &H40
  DO: LOOP UNTIL PEEK(&H6C) <> PEEK(&H6C)
  t = PEEK(&H6C)
  '
  DO
   FOR clc& = clc& TO clc& * 2: NEXT
  LOOP UNTIL t <> PEEK(&H6C)
  '
  SYS& = clc&: i& = 1
  '
  DO
   i& = i& * 2
   d& = clc& \ i&
   DO: LOOP UNTIL PEEK(&H6C) <> PEEK(&H6C)
   t = PEEK(&H6C)
   FOR inc& = 1 TO SYS&: NEXT
   IF t <> PEEK(&H6C) THEN
    SYS& = SYS& - d&
   ELSE
    SYS& = SYS& + d&
   END IF
  LOOP UNTIL i& >= clc&
  '
END IF
'
END SUB

SUB V13hFDE (fadeOUT, fadeINN, fadeSEC!)
'
OUT &H3C8, 0
'
IF fadeOUT THEN
  FOR y = 0 TO 63
   FOR x = 0 TO 255
    r = PAL(x).Red - y
    g = PAL(x).Grn - y
    B = PAL(x).Blu - y
    IF r < 0 THEN r = 0
    IF g < 0 THEN g = 0
    IF B < 0 THEN B = 0
    OUT &H3C9, r
    OUT &H3C9, g
    OUT &H3C9, B
   NEXT
   V13hDEL fadeSEC!
  NEXT
END IF
'
IF fadeINN THEN
  FOR y = 0 TO 63
   FOR x = 0 TO 255
    r = PAL(x).Red
    g = PAL(x).Grn
    B = PAL(x).Blu
    IF y < r THEN r = y
    IF y < g THEN g = y
    IF y < B THEN B = y
    OUT &H3C9, r
    OUT &H3C9, g
    OUT &H3C9, B
   NEXT
   V13hDEL fadeSEC!
  NEXT
END IF
'
END SUB

SUB V13hKEY
'
i = INP(&H60): IF i = 170 THEN REDIM BOARD(0 TO 127): EXIT SUB
'
IF (i AND &H80) THEN
  BOARD(i XOR &H80) = FALSE
ELSE
  BOARD(i) = NOT FALSE
END IF
'
DEF SEG = &H40: POKE &H1C, PEEK(&H1A)
'
END SUB

REM $DYNAMIC
FUNCTION V13hLOF& (file$)
'
FileNum = FREEFILE
OPEN file$ FOR BINARY ACCESS READ AS FileNum
  V13hLOF& = LOF(FileNum) - 7
CLOSE FileNum
'
END FUNCTION

REM $STATIC
SUB V13hPAL (file$)
'
DEF SEG = VARSEG(PAL(0))
'
IF V13hLOF&(file$) > 0 THEN
  BLOAD file$, 0
  OUT &H3C8, 0
  FOR x = 0 TO 255
   OUT &H3C9, PAL(x).Red
   OUT &H3C9, PAL(x).Grn
   OUT &H3C9, PAL(x).Blu
  NEXT
ELSE
  OUT &H3C7, 0
  FOR x = 0 TO 255
   PAL(x).Red = INP(&H3C9)
   PAL(x).Grn = INP(&H3C9)
   PAL(x).Blu = INP(&H3C9)
  NEXT
  BSAVE file$, 0, 1536
END IF
'
END SUB

SUB V13hPNT (ARRAY(), frame, colour)
'
IF PNT.switch THEN
  REGX.AX = 3
  INTERRUPTX &H33, REGX, REGX
  PNT.lb = ((REGX.BX AND 1) <> 0)
  PNT.rb = ((REGX.BX AND 2) <> 0)
  PNT.xx = REGX.cx \ 2
  PNT.yy = REGX.DX
  PNT.frame = frame
  IF PNT.xx < PNT.minXX THEN PNT.xx = PNT.minXX
  IF PNT.xx > PNT.maxXX THEN PNT.xx = PNT.maxXX
  IF PNT.yy < PNT.minYY THEN PNT.yy = PNT.minYY
  IF PNT.yy > PNT.maxYY THEN PNT.yy = PNT.maxYY
  '
  PUTcolour = -15 + colour
  V13hPUT ARRAY(), PNT.xx, PNT.yy, PNT.frame, "TRANSPARENT"
  PUTcolour = FALSE
  '
END IF
'
END SUB

SUB V13hPUT (ARRAY(), xxLEFT, yyTOP, frame, skin$)
'
IF frame THEN
  '
  VIDEOseg& = 1 + VARSEG(VIDEO(0))
  TILESseg& = VARSEG(ARRAY(0))
  '
  TILESwidth = ARRAY(0) \ 8
  TILESheight& = ARRAY(1)
  '
  TP& = 4 + (TILESwidth * TILESheight&)
  '
  TH = ARRAY(1) - 1
  TW = TILESwidth - 1
  TF = frame - 1
  TL = xxLEFT + TW
  TT = yyTOP + TH
  '
  IF xxLEFT < clipXXleft THEN
   clip = NOT FALSE
   XL = clipXXleft
   CLIPadd = clipXXleft - xxLEFT
   IF CLIPadd > TW THEN EXIT SUB
   IF CLIPadd < 0 THEN CLIPadd = -CLIPadd
   CL = CLIPadd
  ELSE
   XL = xxLEFT
  END IF
  '
  IF TL > clipXXright THEN
   clip = NOT FALSE
   XR = clipXXright
   CLIPadd = TL - clipXXright
   IF CLIPadd > TW THEN EXIT SUB
  ELSE
   XR = TL
  END IF
  '
  IF yyTOP < clipYYTOP THEN
   clip = NOT FALSE
   YT& = VIDEOseg& + (clipYYTOP * 20)
   CT = clipYYTOP - yyTOP
   IF CT > TH THEN EXIT SUB
   IF CT < 0 THEN CT = -CT
   CT = CT * TILESwidth
  ELSE
   YT& = VIDEOseg& + (yyTOP * 20)
  END IF
  '
  IF TT > clipYYbottom THEN
   clip = NOT FALSE
   YB& = VIDEOseg& + (clipYYbottom * 20)
   IF (TT - clipYYbottom) > TH THEN EXIT SUB
  ELSE
   YB& = VIDEOseg& + (TT * 20)
  END IF
  '
  IF TP& AND &H1 THEN
   TB& = 4 + TF + ((TP& * TF) + (CL + CT))
  ELSE
   TB& = 4 + ((TP& * TF) + (CL + CT))
  END IF
  '
  DIM c(XL TO XR)
  '
  SELECT CASE skin$
    '
   CASE "SOLID"
    '
    FOR y& = YT& TO YB& STEP 20
     DEF SEG = TILESseg&
     FOR x = XL TO XR
      c(x) = PEEK(TB&)
      TB& = TB& + 1
     NEXT
     TB& = TB& + CLIPadd
     DEF SEG = y&
     IF PUTcolour THEN
      FOR x = XL TO XR
       POKE x, c(x) + PUTcolour
      NEXT
     ELSE
      FOR x = XL TO XR
       POKE x, c(x)
      NEXT
     END IF
    NEXT
   '
   CASE "TRANSPARENT"
   '
    FOR y& = YT& TO YB& STEP 20
     DEF SEG = TILESseg&
     FOR x = XL TO XR
      c(x) = PEEK(TB&)
      TB& = TB& + 1
     NEXT
     TB& = TB& + CLIPadd
     DEF SEG = y&
     IF PUTcolour THEN
      FOR x = XL TO XR
       IF c(x) THEN POKE x, c(x) + PUTcolour
      NEXT
     ELSE
      FOR x = XL TO XR
       IF c(x) THEN POKE x, c(x)
      NEXT
     END IF
    NEXT
    '
   CASE "BLEND"
    '
    BLNseg = VARSEG(BLEND(0))
    '
    FOR y& = YT& TO YB& STEP 20
     DEF SEG = TILESseg&
     FOR x = XL TO XR
      c(x) = PEEK(TB&)
      TB& = TB& + 1
     NEXT
     TB& = TB& + CLIPadd
     DEF SEG = y&
     FOR x = XL TO XR
      IF c(x) THEN
       IF PUTcolour THEN c(x) = c(x) + PUTcolour
       v = PEEK(x)
       DEF SEG = BLNseg
       IF v > c(x) THEN
        B = PEEK(BLN&(c(x)) + (v - c(x)))
       ELSE
        B = PEEK(BLN&(v) + (c(x) - v))
       END IF
       DEF SEG = y&
       POKE x, B
      END IF
     NEXT
    NEXT
    '
   CASE "BEHIND"
    '
    FOR y& = YT& TO YB& STEP 20
     DEF SEG = TILESseg&
     FOR x = XL TO XR
      c(x) = PEEK(TB&)
      TB& = TB& + 1
     NEXT
     TB& = TB& + CLIPadd
     DEF SEG = y&
     IF PUTcolour THEN
      FOR x = XL TO XR
       IF PEEK(x) THEN  ELSE POKE x, c(x) + PUTcolour
      NEXT
     ELSE
      FOR x = XL TO XR
       IF PEEK(x) THEN  ELSE POKE x, c(x)
      NEXT
     END IF
    NEXT
    '
   CASE "PSET"
    '
    IF clip THEN
     FOR y& = YT& TO YB& STEP 20
      DEF SEG = TILESseg&
      FOR x = XL TO XR
       c(x) = PEEK(TB&)
       TB& = TB& + 1
      NEXT
      TB& = TB& + CLIPadd
      DEF SEG = y&
      FOR x = XL TO XR
       POKE x, c(x)
      NEXT
     NEXT
    ELSE
     PUT (xxLEFT, yyTOP), ARRAY((TB& - 4) \ 2), PSET
    END IF
    '
   CASE "PRESET"
   '
    IF clip THEN
     FOR y& = YT& TO YB& STEP 20
      DEF SEG = TILESseg&
      FOR x = XL TO XR
       c(x) = PEEK(TB&)
       TB& = TB& + 1
      NEXT
      TB& = TB& + CLIPadd
      DEF SEG = y&
      FOR x = XL TO XR
       POKE x, NOT c(x)
      NEXT
     NEXT
    ELSE
     PUT (xxLEFT, yyTOP), ARRAY((TB& - 4) \ 2), PRESET
    END IF
    '
   CASE "AND"
    '
    IF clip THEN
     FOR y& = YT& TO YB& STEP 20
      DEF SEG = TILESseg&
      FOR x = XL TO XR
       c(x) = PEEK(TB&)
       TB& = TB& + 1
      NEXT
      TB& = TB& + CLIPadd
      DEF SEG = y&
      FOR x = XL TO XR
       POKE x, c(x) AND PEEK(x)
      NEXT
     NEXT
    ELSE
     PUT (xxLEFT, yyTOP), ARRAY((TB& - 4) \ 2), AND
    END IF
    '
   CASE "OR"
    '
    IF clip THEN
     FOR y& = YT& TO YB& STEP 20
      DEF SEG = TILESseg&
      FOR x = XL TO XR
       c(x) = PEEK(TB&)
       TB& = TB& + 1
      NEXT
      TB& = TB& + CLIPadd
      DEF SEG = y&
      FOR x = XL TO XR
       POKE x, c(x) OR PEEK(x)
      NEXT
     NEXT
    ELSE
     PUT (xxLEFT, yyTOP), ARRAY((TB& - 4) \ 2), OR
    END IF
    '
   CASE "XOR"
    '
    IF clip THEN
     FOR y& = YT& TO YB& STEP 20
     DEF SEG = TILESseg&
      FOR x = XL TO XR
       c(x) = PEEK(TB&)
       TB& = TB& + 1
      NEXT
      TB& = TB& + CLIPadd
      DEF SEG = y&
      FOR x = XL TO XR
       POKE x, c(x) XOR PEEK(x)
      NEXT
     NEXT
    ELSE
     PUT (xxLEFT, yyTOP), ARRAY((TB& - 4) \ 2), XOR
    END IF
    '
  END SELECT
  '
END IF
'
END SUB

SUB V13hSEE
'
DEF SEG
POKE VIDEO(0), VIDEO(2)
POKE VIDEO(1), VIDEO(3)
PUT (0, 0), VIDEO(6), PSET
POKE VIDEO(0), VIDEO(4)
POKE VIDEO(1), VIDEO(5)
'
END SUB

SUB V13hSET
'
SCREEN 13: CLS
'
'Blend LUT Segments
'
FOR x = 0 TO 254
  BLN&(x + 1) = (BLN&(x) + (256 - x))
NEXT
'
V13hPAL "palette.pal"
'
V13hBLN "palette.bln"
'
REG.AX = 0
INTERRUPTX &H33, REGX, REGX
IF REGX.AX THEN PNT.switch = NOT FALSE
'
'put MOUSE
'
REGX.AX = 4
REGX.cx = 0
REGX.DX = 0
INTERRUPTX &H33, REGX, REGX
'
'show MOUSE
'
REGX.AX = 1
INTERRUPTX &H33, REGX, REGX
'
'capture MOUSE
'
GET (0, 0)-(15, 15), MOUSE
'
'hide MOUSE
'
REGX.AX = 2
INTERRUPTX &H33, REGX, REGX
'
PNT.minXX = 0
PNT.minYY = 0
PNT.maxXX = 319
PNT.maxYY = 199
'
COLOR 1
'
FOR x = 1 TO 32
  LOCATE 1, x: PRINT CHR$(x + 31)
  LOCATE 2, x: PRINT CHR$(x + 63)
  LOCATE 3, x: PRINT CHR$(x + 95)
NEXT
'
FOR y = 0 TO 23 STEP 8
  FOR x = 0 TO 255 STEP 8
   GET (x, y)-(x + 7, y + 7), FONTS(E)
   E = E + 34
  NEXT
NEXT
'
CLS : PRESET (160, 100), 0
VIDEOseg& = 1 + VARSEG(VIDEO(0))
DEF SEG : BSAVE "buffer.tmp", &H0, &HFA00
DEF SEG = VIDEOseg&: BLOAD "buffer.tmp", 0
KILL "buffer.tmp"
FOR i = 8 TO 32007 - 1
  IF VIDEO(i) = &H7DA0 AND VIDEO(i + 1) = &HA000 THEN
   VIDEO(0) = ((i + 1) * 2) - 16
   VIDEO(1) = VIDEO(0) + 1
   VIDEO(4) = VIDEOseg& AND &HFF
   IF (VIDEOseg& AND &H8000) THEN
    VIDEO(5) = ((VIDEOseg& AND &HFF00) \ &HFF) + &H100
   ELSE
    VIDEO(5) = (VIDEOseg& AND &HFF00) \ &HFF
   END IF
   DEF SEG
   VIDEO(2) = PEEK(VIDEO(0))
   VIDEO(3) = PEEK(VIDEO(1))
   POKE VIDEO(0), VIDEO(4): POKE VIDEO(1), VIDEO(5)
   EXIT FOR
  END IF
NEXT
'
VIDEO(6) = 2560
VIDEO(7) = 200
'
V13hCLP 0, 0, 319, 199
'
V13hDEL calibrate!
'
V13hCLS 0
'
COLOR 15
'
END SUB

SUB V13hTXT (ARRAY(), XXcenter, xxLEFT, yyTOP, colour, text$, skin$)
'
FONTwidth = ARRAY(0) \ 8
PUTcolour = -1 + colour
FONTyy = yyTOP
'
TL = LEN(text$)
'
IF XXcenter THEN
  cx = (clipXXleft + ((clipXXright - clipXXleft) + 1) \ 2)
  xx = cx - ((TL * FONTwidth) \ 2)
ELSE
  xx = xxLEFT
END IF
'
FOR x = 1 TO TL
  frame = (ASC(MID$(text$, x, 1)) - 31)
  FONTxx = xx + ((x - 1) * FONTwidth)
  V13hPUT ARRAY(), FONTxx, FONTyy, frame, skin$
NEXT
'
PUTcolour = FALSE
'
END SUB

If you would please, report any errors with the program you see,
to this thread. Also, could some of you post the average frames per second you get with the scrolling demo. (The last little demo.)
Post the FPS in the IDE, and if you can compile it and post what FPS you get with the compiled version. Also, please note what O/S you where using, how much RAM you where running and what speed your processor is, thanx!
eg...

Nemesis, running Windows 98, (DOS box), with no apllications running, using an AMD 800 MHz processor, and 500 MB of RAM....

FPS (IDE): 60
FPS (EXE): 96

Thanx again,

Nemesis

barok

09-12-2004, 11:05 AM
as long as you make it an open source lib like neolib, i'm happy. Big Grin

Adigun A. Polack

09-13-2004, 04:22 AM
To Nemesis:

Pleasure meeting you here for the first time. Wink

Now about current version 1.3 of your “Pure-QB”-based library Video13h, I just tested it out, and guess what? It has *indeed* improved dramatically! When I ran it under pure DOS mode (and not Windows), the needless CPU load time for your routines to come into full shape has finally disappeared at very last!! TRULY AWESOME JOB SO FAR!!! d=^_^=b !!

With such noticable improvements like that, look, you lib just _might_ be no doubt as splendidly good as NeoLib and then some..........at least so anyway. I can guarantee that!! Big Grin !

Just keep up the real good work the way you are doing, Nemesis, and see you again now, you hear? Wink



KEEPING YOU IN REAL GOOD HANDS,

[Image: AAPname.gif]
Adigun Azikiwe Polack
One of the Founders of “Aura Flow”
Continuing Developer of “Frantic Journey”
Current Developer of “Star Angelic Slugger”
Webmaster of the “AAP Official Projects Squad”



______________________________________
[Image: NewQBCPCbanner.jpg]
T H E • T H I R D • C A L I B E R • H A S • C U R R E N T L Y • A R R I V E D ! ! ! Big Grin !!

Now encouraging even more positive originality than ever before, and even featuring exclusive QB challenges based on the 2004 Athens Olympic Games, too!!! ;*) !

Got game for the QuickBASIC Caliber Programming Compo 2004/2005? Then I challenge you to please visit http://dhost.hopto.org/aapproj/qbcpc/. That means YOU, pal! Wink

Z!re

09-13-2004, 06:19 PM
Code:
V13hPAL "palette.pal"
'
V13hBLN "palette.bln"

Nice lib, too bad it doesent work.

Black screen, joy...

Nemesis

09-13-2004, 10:59 PM
Quote:
Code:
V13hPAL "palette.pal"
'
V13hBLN "palette.bln"

Nice lib, too bad it doesent work.

Black screen, joy...

Oh, it works...
Just when you first run it, or if the files "palette.pal" or "palette.bln"
aren't in the same directory as the lib, it'll have to create them.
Give it a few seconds, because calculating the blending map..."palette.bln" may take a moment.
When the .bas is converted to a .qlb, which will be the case in the next version, this wait will be dramatically reduced,
(also the same goes for if you compile the .bas to .exe, of course).
And yes, Barok, VIDEO13h will always be open-source.

Thanx,

Nemesis

barok

09-14-2004, 09:36 AM
just making sure. :wink:

Anyways, it looks very good so far!!! I can't wait for the final release!

::EDIT:: Just played through it, got 45 fps ide, 180 (max) fps compiled. AMD Duron 800 mhz, 256 mb, laptop.

and, the multikey routine doesn't seem to work well. For example, sometimes the keys would stick, and if you hold two keys at the same time, the program will register both keys for about a second, then it won't detect the second key your pressing.
Qbasicnews.com > QBasic > QB Projects > Video13h v1.3