The QBasic / QB64 Discussion Forum      Other Subforums, Links and Downloads
 
 

 Return to Index  

Michael Webster

May 11 2012 at 9:20 AM
Anonymous  (no login)

 
speicher kapazitaet reicht nicht aus statement
offenbart schlechten charakter ....das richtige statement waere<
dann ist mehr platz

http://uolang.org/sourcecode/basic/bmpdump.txt.



original:

Screen 13 to BMP
May 15th, 2004

--------------------------------------------------------------------------------
This is a small QB program that stores a SCREEN 13 image as a Windows BMP file. I initially planned to include code to compress the bitmap, but I eventually decided that for this application compression was more trouble than it was worth. And before someone bothers to point it out, I am well aware that this has been done many times before.
--------------------------------------------------------------------------------

'Code:

'-------------------------------------------------------------------------------

DECLARE SUB DrawTestImage (i%)
DECLARE SUB GetBitmap (bitmap%())
DEFINT A-Z

' This program stores a screen mode 13 full-screen
' image as an uncompressed 8-bit Windows BMP file.
'
' An 8-bit Windows BMP file must contain the
' following components, in the order specified:
' A properly initialized BITMAPFILEHEADER structure
' A properly initialized BITMAPINFOHEADER structure
' A color table (256 RGBQUAD structures)
' A bitmap

' This constant is the multiplier that will be
' used to scale the 6-bit intensity values from
' the color registers. The value 4 will scale
' the intensities to span the full 8-bit range,
' which will allow the bitmap to display with
' normal intensities under Windows running
' color depths of 8-32 bits.
CONST SCALEFACTOR = 4

TYPE BITMAPFILEHEADER ' 14 bytes
bfType AS STRING * 2 ' "BM"
bfSize AS LONG ' file size, bytes
bfReserved1 AS INTEGER ' set to 0
bfReserved2 AS INTEGER ' set to 0
bfOffBits AS LONG ' byte offset of bitmap in file
END TYPE

TYPE BITMAPINFOHEADER
biSize AS LONG ' 40 bytes
biWidth AS LONG ' image width, pixels
biHeight AS LONG ' image height, pixels
biPlanes AS INTEGER ' must be 1
biBitCount AS INTEGER ' 8 (bits per pixel)
biCompression AS LONG ' 0 = uncompressed
biSizeImage AS LONG ' 0 for uncompressed
biXPelsPerMeter AS LONG ' set to 0
biYPelsPerMeter AS LONG ' set to 0
biClrUsed AS LONG ' 256
biClrImportant AS LONG ' 0 for all important
END TYPE

TYPE RGBQUAD
rgbBlue AS STRING * 1
rgbGreen AS STRING * 1
rgbRed AS STRING * 1
rgbReserved AS STRING * 1
END TYPE
DECLARE SUB FillColorTable (colorTable() AS RGBQUAD)

TYPE RegTypeX
ax AS INTEGER
bx AS INTEGER
cx AS INTEGER
dx AS INTEGER
bp AS INTEGER
si AS INTEGER
di AS INTEGER
flags AS INTEGER
ds AS INTEGER
es AS INTEGER
END TYPE
DECLARE SUB InterruptX (interrupt AS INTEGER, inregs AS RegTypeX, outregs AS RegTypeX)

' Allocate the BMP header variables.
DIM bmfh AS BITMAPFILEHEADER
DIM bmih AS BITMAPINFOHEADER

' Allocate an array to store the BMP color table
' (1024 bytes total). Note that this array MUST
' be dynamic.
' $DYNAMIC
DIM colorTable(0 TO 255) AS RGBQUAD

' Switch to screen mode 13 and draw a test image.
SCREEN 13
DO
INPUT "Enter test image number (1-5):", i
IF i > 0 AND i < 6 THEN EXIT DO
LOOP
DrawTestImage i

FillColorTable colorTable()
DIM bitmap(0 TO 31999)
GetBitmap bitmap()

' Initialize bmfh and bmih.
bmfh.bfType = "BM"
bmfh.bfSize = 14 + 40 + 1024 + 320& * 200
bmfh.bfReserved1 = 0
bmfh.bfReserved2 = 0
bmfh.bfOffBits = 14 + 40 + 1024

bmih.biSize = 40
bmih.biWidth = 320
bmih.biHeight = 200
bmih.biPlanes = 1
bmih.biBitCount = 8
bmih.biCompression = 0
bmih.biSizeImage = 0
bmih.biXPelsPerMeter = 0
bmih.biYPelsPerMeter = 0
bmih.biClrUsed = 256
bmih.biClrImportant = 0

' Open a file, copy everything to it, and close it.
KILL "bmptest.bmp"
OPEN "bmptest.bmp" FOR BINARY AS 1
PUT #1, , bmfh
PUT #1, , bmih
FOR i = 0 TO 255
PUT #1, , colorTable(i)
NEXT
FOR i = 0 TO 31999
PUT #1, , bitmap(i)
NEXT
CLOSE

LOCATE 12, 11
COLOR 15
PRINT "Press any key to exit"
DO
LOOP UNTIL INKEY$ <> ""

REM $STATIC
SUB DrawTestImage (i)
CLS
SELECT CASE i
CASE 1
LINE (0, 0)-(319, 199), , B
FOR y = 1 TO 198
FOR x = 1 TO 318
PSET (x, y), 1 / 500! * x * y MOD 256
NEXT
NEXT
CASE 2
LINE (0, 0)-(319, 199), , B
FOR y = 1 TO 198 STEP 3
FOR x = 1 TO 318 STEP 3
PSET (x, y), 1 / 500! * x * y MOD 256
NEXT
NEXT
CASE 3
LINE (0, 0)-(319, 199), , B
pi! = 4 * ATN(1)
WINDOW (-159, -99)-(159, 99)
FOR theta! = 0 TO 10 * pi! STEP .0006
x! = r! * SIN(theta!)
y! = r! * COS(theta!)
IF (ABS(x!) < 158) AND (ABS(y!) < 98) THEN
PSET (x!, y!), 1
END IF
x! = r! * SIN(theta! + pi!)
y! = r! * COS(theta! + pi!)
IF (ABS(x!) < 158) AND (ABS(y!) < 98) THEN
PSET (x!, y!), 4
END IF
r! = r! + theta! / 10000
NEXT
CASE 4
LINE (0, 0)-(319, 199), , B
FOR y = 1 TO 198
FOR x = 1 TO 318
PSET (x, y), RND * 256
NEXT
NEXT
CASE 5
PRINT
COLOR 1
PRINT "ASPECT RATIO=SCREEN 13 DEFAULT (.833)"
PRINT
COLOR 4
PRINT "ASPECT RATIO=1"
CIRCLE (160, 100), 50, 1
CIRCLE (160, 100), 50, 4, , , 1
END SELECT
END SUB

SUB FillColorTable (colorTable() AS RGBQUAD)

' This procedure fills the elements of <colorTable()>
' with the RGB intensities from the Color Registers,
' using the value in SCALEFACTOR to scale the 6-bit
' intensities.

DIM regX AS RegTypeX

' For each of the VGA Color Registers, call the VGA
' BIOS Read Individual Color Register function and
' copy the scaled RGB intensities to the elements of
' <colorTable>. The function returns the red intensity
' in DH, the green intensity in CH, and the blue
' intensity in CL.
FOR i = 0 TO 255
regX.ax = &H1015
regX.bx = i
InterruptX &H10, regX, regX
red = ((regX.dx \ 256) * SCALEFACTOR)
green = ((regX.cx \ 256) * SCALEFACTOR)
blue = ((regX.cx AND &HFF) * SCALEFACTOR)
colorTable(i).rgbRed = CHR$(red)
colorTable(i).rgbGreen = CHR$(green)
colorTable(i).rgbBlue = CHR$(blue)
NEXT
END SUB

SUB GetBitmap (bitmap())

' This procedure reads the pixel data from the
' display buffer and copies it the elements
' of <bitmap()>.

' Store the bitmap, last pixel row first.
DEF SEG = &HA000
FOR y = 199 TO 0 STEP -1
FOR x = 0 TO 319 STEP 2
pixelOffset& = 320& * y + x
pixelValue0 = PEEK(pixelOffset&)
pixelValue1 = PEEK(pixelOffset& + 1)
w$ = CHR$(pixelValue0) + CHR$(pixelValue1)
bitmap(i) = CVI(w$)
i = i + 1
NEXT
NEXT
DEF SEG

END SUB

===================================================================================
MichaelWebster
General user









Posts: 15
Re: Qbasic
« Reply #14 on: Mar 30th, 2004, 4:04pm » Quote Modify

--------------------------------------------------------------------------------
Quote:
Assembly is faster than BASIC, so you might want to embed some machine code that prints and copies data. In fact, machine code is required to get the mouse to work in your programs when using Qbasic 1.x. With Qbasic 4.5+, you can use "call interrupt".



For Microsoft and compatible DOS mouse drivers and DOS or Win9x MS-DOS mode, you can call the mouse driver from a QBasic app with CALL ABSOLUTE. No assembly language is required.
Code:
DECLARE SUB GetMouseStatus (row%, col%, fLeft%, fRight%)
DECLARE SUB HideMouse ()
DECLARE SUB ShowMouse ()
DECLARE FUNCTION ResetMouse% ()
DEFINT A-Z

' This program demonstrates how to use the mouse
' with nothing but pure QBasic code. It uses CALL
' ABSOLUTE to do a far call to the mouse driver
' far call entry point, located two past the
' Interrupt call entry point for Microsoft and
' compatible mouse drivers.
'
' Note that unlike the Interrupt call method,
' the far call method will not work under
' Windows because for the Windows mouse drivers
' Microsoft placed a RETF 8 instruction at the
' far call entry point, so the call just returns
' to the caller without further action.

DIM SHARED driverSegment, driverOffset
CLS

' Get the driver entry point segment and offset
' from the Interrupt 33h vector.
DEF SEG = 0
vectorOffset = &H33 * 4
driverSegment = &H100& * PEEK(vectorOffset + 3) + PEEK(vectorOffset + 2)
driverOffset = &H100& * PEEK(vectorOffset + 1) + PEEK(vectorOffset + 0)

' If the vector is 0000:0000, or it points
' to an IRET instruction (opcode CFh), or
' the reset function returns 0, then assume
' the mouse driver is not installed.
IF driverSegment = 0 AND driverOffset = 0 THEN GOSUB NoDriver
DEF SEG = driverSegment
IF PEEK(driverOffset) = &HCF THEN GOSUB NoDriver
DEF SEG
IF ResetMouse = 0 THEN GOSUB NoDriver

ShowMouse
PRINT
PRINT "Any key to exit..."
DO
GetMouseStatus row, col, fLeft, fRight
LOCATE 3, 2
PRINT "row ="; row;
LOCATE 4, 2
PRINT "col ="; col;
LOCATE 5, 2
PRINT "fLeft ="; fLeft;
LOCATE 6, 2
PRINT "fRight ="; fRight;
LOOP UNTIL INKEY$ <> ""
HideMouse

END

NoDriver:
PRINT
PRINT "Mouse driver not found, any key to exit..."
DO
LOOP UNTIL INKEY$ <> ""
END

SUB GetMouseStatus (row%, col%, fLeft%, fRight%) STATIC

' Calls the mouse driver Get Button Status and
' Mouse Position function. Returns with the
' arguments set to reflect the current mouse
' status.
'
' This procedure assumes 80x25 text mode.

DEF SEG = driverSegment
CALL ABSOLUTE(3, m2, m3, m4, driverOffset + 2)
DEF SEG
row = m4 \ 8 + 1
col = m3 \ 8 + 1
IF m2 AND 1 THEN fLeft = -1 ELSE fLeft = 0
IF m2 AND 2 THEN fRight = -1 ELSE fRight = 0

END SUB

SUB HideMouse

' Calls the Mouse Hide Cursor function, which
' decrements the internal cursor flag and hides
' the mouse cursor.

DEF SEG = driverSegment
CALL ABSOLUTE(2, m2, m3, m4, driverOffset + 2)
DEF SEG

END SUB

FUNCTION ResetMouse

' Calls the Mouse Reset and Status function.
' Returns -1 if reset OK.

DEF SEG = driverSegment
m1 = 0
CALL ABSOLUTE(m1, m2, m3, m4, driverOffset + 2)
ResetMouse = m1
DEF SEG

END FUNCTION

SUB ShowMouse

' Calls the Mouse Show Cursor function, which
' increments the internal cursor flag and shows
' the mouse cursor if the cursor flag is 0
' after the increment. The flag will never be
' > 0.

DEF SEG = driverSegment
CALL ABSOLUTE(1, m2, m3, m4, driverOffset + 2)
DEF SEG

END SUB






==========================================
Author Topic: Fast Integer to Binary String Conversion (Read 30 times)

MichaelWebster
General user









Posts: 15
Fast Integer to Binary String Conversion
« on: Mar 30th, 2004, 12:38pm » Quote Modify

--------------------------------------------------------------------------------
Code:DECLARE FUNCTION Binary$ (n&)
DEFINT A-Z

' This is a test of a fairly fast integer to binary
' string procedure. The conversion is done using
' multiply and AND operations, avoiding the slower
' divide and exponentation operations.
CLS

FOR i& = 0 TO 65535
a$ = Binary$(i&)
PRINT a$
NEXT

FUNCTION Binary$ (n&)
' Returns a 16-digit string that represents the
' value of <n&> in binary.

' Work on a copy to avoid changing the argument.
b& = n&
FOR i = 1 TO 16
' Shift the value left by one bit position
' and clear the higher order bits to avoid
' an overflow.
b& = 2 * (b& AND &H1FFFF)
' Add a "0" or a "1" to the binary string
' depending on the value of the shifted-out
' bit.
IF b& AND &H10000 THEN
b$ = b$ + "1"
ELSE
b$ = b$ + "0"
END IF
NEXT
Binary$ = b$
END FUNCTION

===========================================================================
Author Topic: Double-Buffered Animation (Read 46 times)

MichaelWebster
General user









Posts: 15
Double-Buffered Animation
« on: Feb 23rd, 2004, 1:36am » Quote Modify

--------------------------------------------------------------------------------
This is an experiment with double-buffered animation using pure QB code.

Double buffered animation utilizes a “front” buffer for viewing, and a “back” buffer for drawing. Each animation frame is drawn in the back buffer and, when the frame is complete, the buffers are “flipped” so the back buffer effectively becomes the front buffer, and vice versa. While the competed frame in the front buffer is being viewed, the next frame is being drawn in the back buffer. Double buffering, in combination with synchronization with vertical retrace can virtually eliminate flicker, even when the drawing operations take more than one vertical frame time.

Because the QB graphics functions act only on display memory, the back buffer must be located in display memory. SCREEN 9 was selected because it provides 2 display pages (with VGA), and these pages serve as the front and back buffers.
Code:
DECLARE SUB VSync ()
DECLARE SUB Flip ()
DEFINT A-Z

' This is an experiment with double-buffered
' animation using pure QB code.

CONST false = 0, true = NOT false
DIM SHARED vPage, fSync
fSync = true

' Initially use display page 0 for the front
' buffer and display page 1 for the back buffer.
SCREEN 9, , 1, 0

' Draw a frame and copy it to the front buffer.
LINE (0, 0)-(639, 349), 15, B
PCOPY 1, 0

' Set the physical viewport so the image will be
' clipped at frame. This simplifies the animation
' logic.
VIEW (1, 1)-(638, 348)

DO
LOOP UNTIL INKEY$ <> ""

' Enter the animation loop.
x = 1
y = 150
xStep = 1
s! = TIMER
DO
' Draw the new image.
LINE (x, y)-(x + 30, y + 30), 1, BF

' Flip the buffers.
Flip

' Erase the old image.
LINE (x - xStep, y)-(x - xStep + 30, y + 30), 0, BF

' Increment the X coordinate.
x = x + xStep

' Adjust for boundaries and flip direction.
IF x < 1 THEN
x = 1
xStep = -xStep
END IF
IF x > 608 THEN
x = 608
xStep = -xStep
END IF

' Check for user input and respond.
key$ = INKEY$
SELECT CASE (key$)
CASE "S", "s"
fSync = NOT fSync
fps! = 0
i = 0
s! = TIMER
CASE "1" TO "9"
' Erase image from both buffers
' to avoid restarting the loop.
CLS
Flip
CLS
xStep = VAL(key$)
CASE CHR$(27)
EXIT DO
END SELECT

' Calculate and display frame rate. The value
' 400 was selected as a compromise between
' accuracy and response time.
i = i + 1
IF i > 399 THEN
f! = TIMER
fps! = 400 / (f! - s!)
s! = f!
i = 0
END IF
LOCATE 2, 2
PRINT CINT(fps!); " ";
LOOP

DO
LOOP UNTIL INKEY$ <> ""

END

SUB Flip STATIC
' Swaps the display pages for the
' front and back buffers.

IF vPage THEN
IF fSync THEN VSync
SCREEN , , 1, 0
vPage = 0
ELSE
IF fSync THEN VSync
SCREEN , , 0, 1
vPage = 1
END IF
END SUB

SUB VSync STATIC
' Waits for the start of vertical retrace before
' returning.
'
' Synchronization with vertical retrace ensures
' that the entire screen will be updated in a
' single vertical frame (assuming the system is
' fast enough to update the screen within the
' vertical frame time). Without synchronization,
' most screen updates will require two vertical
' frames, and most users will be able to perceive
' the image appearing in two steps.
'
' **********************************************
' For some unknown (to me) reason, this procedure
' cannot effectively synchronize with vertical
' retrace when it is called from a program running
' in the QB45 programming environment. Note that
' this is not a problem for QBasic or PDS.
' **********************************************

' The display is in vertical retrace when bit 3
' of the Input Status #1 register (3DAh) is set.

' Wait until not vertical retrace.
WHILE (b AND 8)
b = INP(&H3DA)
WEND

' Wait until vertical retrace.
WHILE (b AND 8) = 0
b = INP(&H3DA)
WEND

END SUB
==================================================================
Mario L. (AKA... NEMESIS,
Guest



Re: Double-Buffered Animation
« Reply #2 on: Mar 14th, 2004, 12:20pm » Quote Modify Remove

--------------------------------------------------------------------------------
Hello...
I just submitted a program that uses a double buffer
technique for QB's SCREEN 13.
(Counting the sprite as a buffer and the video page as a buffer, he-heh, so technically it wouldn't be considered "DOUBLE BUFFERING" like the previous snippet, but oh well, it's still smooth and fast. 8))
Anyways, I'm hoping to make the fastest "pure QB" SCREEN 13, graphics library on the net (eventually), so I can brag about it and have a really big ego about such a silly thing. :P (Yes. I'm one of those "pure QB fanatics", though I do code in Assembly for my more serious projects.)
As a matter of fact, I'm starting/started a web site called... PURE QB INNOVATIONS, which will feature some of the the best pure QB code from around the net. Not much done yet, but I'll get around to it.
Well, hey, since I like you guys here at the ABC forum, I'll give you the first version of VIDEO13h, right now!
'
' VIDEO13h v1.1, Pure 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 Pure QB Innovations web site at...
' http://members.aol.com/esmembernemesis/index.htm
'
' 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
'
COMMON SHARED FONTcolour
COMMON SHARED clipXXleft, clipYYtop, clipXXright, clipYYbottom
'
DECLARE SUB DEMO ()
'
DECLARE SUB V13hCLS (colour)
DECLARE SUB V13hCLP (XXleft, YYtop, XXright, YYbottom)
DECLARE SUB V13hPUT (ARRAY(), XXleft, YYtop, frame, mode$)
DECLARE SUB V13hSEE ()
DECLARE SUB V13hSET ()
DECLARE SUB V13hTXT (ARRAY(), XXcenter, XXleft, YYtop, colour, text$)
'
DIM SHARED VIDEO(0 TO 31999)
DIM SHARED FONTS(0 TO 3263)
'
V13hSET
'
DEMO
'
KILL "video.tmp"
'
SYSTEM
'

REM $STATIC
SUB DEMO
'
'''
''' Draw and capture -3- 20*20, tiles...
'''
'
DIM TILES(0 TO 606)
V13hCLS 0
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
'
'''
''' Welcome, (scrolling font routine)...
'''
'
FOR y = (clipYYbottom + 1) TO (clipYYtop - (44 * 8)) STEP -1
V13hCLS 0
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 0), 15, "-WELCOME-"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 2), 7, "VIDEO13h v1.1, pure QuickBASIC 4.5,"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 4), 7, "SCREEN 13 manipulation routines."
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 8), 15, "-FEATURES-"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 10), 7, "320X200X256 resolution (VGA),"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 12), 7, "page flipping, sprite animation,"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 14), 7, "sprite clipping, font routines,"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 16), 7, "and also supports QuickBASIC's"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 18), 7, "own graphical functions too!"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 22), 15, "-REQUIREMENTS-"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 24), 7, "100+ Mhz PC processor, a VGA monitor,"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 26), 7, "keyboard or mouse, QuickBASIC v4.5,"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 28), 7, "and a disk cache active."
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 32), 15, "-SOON-"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 34), 7, "VIDEO13h v1.2, featuring..."
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 36), 7, "mouse and keyboard handelers,"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 38), 7, "timming & delay functions,"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 40), 7, "faster graphics, and much more!"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 44), 15, "-CREDITS-"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 48), 15, "...Programmer..."
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 50), 7, "Mario LaRosa, ESmemberNEMESIS@aol.com"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 54), 15, "...Special Thanks..."
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 56), 7, "Jonathan Dale Kirwan, JonKirwan@aol.com"
V13hTXT FONTS(), NOT FALSE, 0, y + (8 * 58), 7, "Quinton Roberts, Eclipzer@aol.com"
V13hTXT FONTS(), FALSE, 0, (8 * 24), 15, "(C)opyright 2004,"
V13hTXT FONTS(), FALSE, (8 * 18), (8 * 24), 12, "Pure"
V13hTXT FONTS(), FALSE, (8 * 23), (8 * 24), 10, "QB"
V13hTXT FONTS(), FALSE, (8 * 26), (8 * 24), 9, "Innovations"
V13hSEE
'
'WAIT &H3DA, 8
'
IF LEN(INKEY$) THEN EXIT FOR
NEXT
SLEEP
'
'''
''' Fill screen 256 times...
'''
'
t! = TIMER
FOR c = 0 TO 255
V13hCLS c
V13hSEE
NEXT
LOCATE 1, 1: PRINT "CLS, (256x's):"; TIMER - t!
SLEEP
'
'''
''' Show 1O,OOO random pixels...
'''
V13hCLS 0
t! = TIMER
FOR x = 1 TO 10000
PSET (INT(RND(1) * 319 + 1), INT(RND(1) * 199 + 1)), INT(RND(1) * 255 + 1)
NEXT
V13hSEE
LOCATE 1, 1: PRINT "PSET, (1O,OOOx's):"; TIMER - t!
SLEEP
'
'''
''' Show 1O,OOO random lines...
'''
'
V13hCLS 0
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
V13hSEE
LOCATE 1, 1: PRINT "LINE, (1O,OOOx's):"; TIMER - t!
SLEEP
'
'''
''' Show 1,OOO random tiles...
'''
'
kind$ = "TRANSPARENT"
DO
V13hCLS 0
t! = TIMER
FOR t = 1 TO 1000
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
V13hSEE
k$ = "PUT " + kind$ + ", (1,OOOx's:)"
LOCATE 1, 1: PRINT k$; TIMER - t!
SLEEP
SELECT CASE kind$
CASE "TRANSPARENT"
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 tiles...
'''
'
FOR c = 1 TO 2
IF c = 2 THEN V13hCLP 30, 20, 289, 179
FOR TIMES = 1 TO 10
FOR ZZ = 0 TO 19
FOR YY = 0 TO 180 STEP 20
FOR xx = -20 TO 300 STEP 20
V13hPUT TILES(), (xx + ZZ), YY, c, "PSET"
NEXT
V13hPUT TILES(), 150, 90, c + 1, "TRANSPARENT"
NEXT
V13hSEE
NEXT
NEXT
NEXT
SLEEP
V13hCLS 0
V13hCLP 0, 0, 319, 199
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
REDIM VIDEO(0 TO 31999)
END IF
'
END SUB

SUB V13hPUT (ARRAY(), XXleft, YYtop, frame, mode$)
'
IF frame THEN
'
VIDEOseg = VARSEG(VIDEO(0))
'
TILESseg = VARSEG(ARRAY(0))
TILESwidth = ARRAY(0) \ 8
TILESpixels = TILESwidth * ARRAY(1)
'
TH = ARRAY(1) - 1
TW = TILESwidth - 1
TP = TILESpixels + 4
TF = frame - 1
tl = XXleft + TW
TT = YYtop + TH
TI = (TP \ 2) * TF
'
IF TI < 0 OR TI > UBOUND(ARRAY) THEN EXIT SUB
'
IF XXleft < clipXXleft THEN
XL = clipXXleft
CLIP = NOT FALSE
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
XR = clipXXright
CLIP = NOT FALSE
CLIPadd = tl - clipXXright: IF CLIPadd > TW THEN EXIT SUB
ELSE
XR = tl
END IF
'
IF YYtop < clipYYtop THEN
YT = VIDEOseg + (clipYYtop * 20)
CLIP = NOT FALSE
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
YB = VIDEOseg + (clipYYbottom * 20)
CLIP = NOT FALSE
IF (TT - clipYYbottom) > TH THEN EXIT SUB
ELSE
YB = VIDEOseg + (TT * 20)
END IF
'
t = ((TP * TF) + (CL + CT)) + 4
'
DIM c(XL TO XR)
'
SELECT CASE mode$
'
CASE "TRANSPARENT"
'
FOR y = YT TO YB STEP 20
DEF SEG = TILESseg
FOR x = XL TO XR
c(x) = PEEK(t)
t = t + 1
NEXT
t = t + CLIPadd
DEF SEG = y
FOR x = XL TO XR
IF c(x) THEN POKE x, c(x)
NEXT
NEXT
'
CASE "BEHIND"
'
FOR y = YT TO YB STEP 20
DEF SEG = TILESseg
FOR x = XL TO XR
c(x) = PEEK(t)
t = t + 1
NEXT
t = t + CLIPadd
DEF SEG = y
FOR x = XL TO XR
IF PEEK(x) THEN ELSE POKE x, c(x)
NEXT
NEXT
'
CASE "PSET"
'
IF CLIP THEN
FOR y = YT TO YB STEP 20
DEF SEG = TILESseg
FOR x = XL TO XR
c(x) = PEEK(t)
t = t + 1
NEXT
t = t + CLIPadd
DEF SEG = y
FOR x = XL TO XR
POKE x, c(x)
NEXT
NEXT
ELSE
PUT (XXleft, YYtop), ARRAY(TI), 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(t)
t = t + 1
NEXT
t = t + CLIPadd
DEF SEG = y
FOR x = XL TO XR
POKE x, NOT c(x)
NEXT
NEXT
ELSE
PUT (XXleft, YYtop), ARRAY(TI), 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(t)
t = t + 1
NEXT
t = t + CLIPadd
DEF SEG = y
FOR x = XL TO XR
POKE x, c(x) AND PEEK(x)
NEXT
NEXT
ELSE
PUT (XXleft, YYtop), ARRAY(TI), 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(t)
t = t + 1
NEXT
t = t + CLIPadd
DEF SEG = y
FOR x = XL TO XR
POKE x, c(x) OR PEEK(x)
NEXT
NEXT
ELSE
PUT (XXleft, YYtop), ARRAY(TI), 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(t)
t = t + 1
NEXT
t = t + CLIPadd
DEF SEG = y
FOR x = XL TO XR
POKE x, c(x) XOR PEEK(x)
NEXT
NEXT
ELSE
PUT (XXleft, YYtop), ARRAY(TI), XOR
END IF
'
CASE "FONT"
'
FOR y = YT TO YB STEP 20
DEF SEG = TILESseg
FOR x = XL TO XR
c(x) = PEEK(t)
t = t + 1
NEXT
t = t + CLIPadd
DEF SEG = y
FOR x = XL TO XR
IF c(x) THEN POKE x, c(x) + FONTcolour
NEXT
NEXT
'
END SELECT
'
END IF
'
END SUB

SUB V13hSEE
'
DEF SEG = VARSEG(VIDEO(0)): BSAVE "video.tmp", 0, &HFA00
DEF SEG = &HA000: BLOAD "video.tmp", 0
'
END SUB

SUB V13hSET
'
SCREEN 13: CLS : COLOR 255
'
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 = VARSEG(VIDEO(0))
DEF SEG : BSAVE "video.tmp", &H0, &HFA00
DEF SEG = VIDEOseg: BLOAD "video.tmp", 0
FOR I = LBOUND(VIDEO) TO (UBOUND(VIDEO) - 1)
IF VIDEO(I) = &H7DA0 AND VIDEO(I + 1) = &HA000 THEN
target = ((I + 1) * 2)
lo = VIDEOseg AND &HFF: hi = (VIDEOseg AND &HFF00) \ &HFF
IF (VIDEOseg AND &H8000) THEN hi = (hi + &H100)
DEF SEG : POKE target, lo: POKE (target + 1), hi
END IF
NEXT
'
V13hCLP 0, 0, 319, 199
'
COLOR 15
'
END SUB

SUB V13hTXT (ARRAY(), XXcenter, XXleft, YYtop, colour, text$)
'
FONTwidth = ARRAY(0) \ 8
FONTcolour = -255 + 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, "FONT"
NEXT
'
END SUB
'

P.S...
One of the best things about this program is the fact that you can use QB's own graphical functions too, (PSET,LINE,PAINT, etc...) and they all output to a
video page (yahoo!) . You can even compile the program/routines for faster results that will be needed for stuff like, eh, games! ;D

CYA, and let me know what you think, comments, suggestions, praise, etc...

Mario L.


========================================================================
MichaelWebster
General user









Posts: 15
Re: QBasic. GET command
« Reply #5 on: Feb 7th, 2004, 5:49pm » Quote Modify

--------------------------------------------------------------------------------
Code:
DEFINT A-Z
CLS

' This program attempts to demonstrate how the GET
' and PUT (graphics) statements work. SCREEN 13 is
' used because the screen data occupies 1 byte per
' pixel, making it easier to visualize the concepts,
' calculate the size of the required storage, and
' manipulate the pixels.
SCREEN 13
PRINT "L"

' The default character box for SCREEN 13 is 8x8,
' so we need to store 8 * 8 = 64 pixels. The GET
' statement needs 4 extra bytes to store the width
' and height information needed by the PUT statement,
' so we need to store 68 bytes total. The image will
' be stored in an integer array, and integers occupy
' 2 bytes each, so our array needs 34 elements.
DIM storage(0 TO 33)

' Store the image. Screen coordinates start at 0,0
' in the upper left corner of the screen.
GET (0, 0)-(7, 7), storage

' The first two elements of the stored data contain
' the width of the image in bits, and the height of
' the image in scan lines.
PRINT
PRINT storage(0), storage(1)
PRINT
' The remainder of the stored data is the actual
' image, where each byte holds the color value for
' the corresponding pixel. The foreground color was
' left at the default (15 = 0Fh) so it would display
' as a single hex digit. PEEK and POKE provide the
' most reasonable (and fastest) method of accessing
' the individual bytes of the array.
DEF SEG = VARSEG(storage(0))
imageBase = VARPTR(storage(2))
FOR row = 0 TO 7
FOR col = 0 TO 7
PRINT HEX$(PEEK(imageBase + row * 8 + col));
NEXT
PRINT
NEXT

' Reverse the pixels in each row of the image.
FOR row = 0 TO 7
FOR col = 0 TO 3
pixel1 = PEEK(imageBase + row * 8 + col)
pixel2 = PEEK(imageBase + row * 8 + 7 - col)
POKE imageBase + row * 8 + col, pixel2
POKE imageBase + row * 8 + 7 - col, pixel1
NEXT
NEXT

' Display the reversed image.
PUT (8, 0), storage

' Reverse the pixels in each column of the image
' (i.e. invert the image). If the logic of this is
' not apparent, consider that the image is stored
' as:
' 0123456701234567...
' ^ row0 ^^ row1 ^...
' So the address of any given pixel is always
' (imageBase + row * 8 + col).
FOR col = 0 TO 7
FOR row = 0 TO 3
pixel1 = PEEK(imageBase + row * 8 + col)
pixel2 = PEEK(imageBase + (7 - row) * 8 + col)
POKE imageBase + row * 8 + col, pixel2
POKE imageBase + (7 - row) * 8 + col, pixel1
NEXT
NEXT

' Walk the inverted image across the screen.
PRINT
PRINT "Press any key to animate image..."
DO: LOOP UNTIL INKEY$ <> ""
FOR x = 16 TO 312
PUT (x, 0), storage
' This will delay for one timer tick (~55ms).
t! = TIMER
DO: LOOP UNTIL t! <> TIMER
' Give the user a chance to abort with Escape.
IF INKEY$ = CHR$(27) THEN END
PUT (x, 0), storage, XOR
NEXT

==============================================================
MichaelWebster
General user









Posts: 15
Old Graphics Program
« on: Jan 12th, 2004, 3:06am » Quote Modify

--------------------------------------------------------------------------------
This is a modified version of an old QB45 program that displays screen saver style moving graphics based on the LINE statement. I coded the original version to support any graphics-capable display subsystem, but in the interest of making it QBasic compatible I dropped support for anything below EGA. I also modified the Delay procedure for Windows XP compatibility.

The program includes a control panel that allows the user to control 8 operating parameters. Variations in these parameters can produce a practically endless variety of patterns. A few combinations that I like are:
20, 70, 10, 10, 10, 10, 9, line
0, 30, 640, 480, 3, 2, 9, line
0, 1, 640, 480, 3, 2, 9, block
0, 1, 640, 480, 3, 2, cycle, block
5, 100, 20, 20, 1, 1, cycle, box
0, 600, 100, 40, 9, 10, 9, line
VGA is assumed, and the delay values are appropriate for a 500MHz P3.

***
This code has been updated since it was first posted to correct a problem that caused the delay period to always be zero for a compiled EXE.
***
Code:
DECLARE SUB Delay (microSec&)
DECLARE SUB SyncTimer ()
DECLARE SUB SetDefaults ()
DECLARE SUB MainLoop ()
DECLARE SUB CPanel ()
DEFINT A-Z

CONST MAXDELAY = 500000
CONST MAXLINES = 1000
CONST MAXSTEP = 100
CONST LINEMODE = 0
CONST BOXMODE = 1
CONST BLOCKMODE = 2

DIM SHARED delayMicroSec&, lineCount, xLength, yLength
DIM SHARED currentColor, mode, screenMode
DIM SHARED xStep, yStep, xMax, yMax

' Initialize global vars to match display subsystem.
ON ERROR GOTO ModeError
DO
SCREEN 12
IF badMode THEN
badMode = 0
ELSE
xMax = 639
yMax = 479
screenMode = 12
EXIT DO
END IF
SCREEN 10
IF badMode THEN
badMode = 0
ELSE
xMax = 639
yMax = 349
screenMode = 10
EXIT DO
END IF
SCREEN 9
IF badMode THEN
badMode = 0
ELSE
xMax = 639
yMax = 349
screenMode = 9
EXIT DO
END IF
PRINT "Program requires EGA or VGA"
END
LOOP
ON ERROR GOTO 0

' Set up buffer for line coordinates.
TYPE bufferType
x1 AS INTEGER
y1 AS INTEGER
x2 AS INTEGER
y2 AS INTEGER
END TYPE
DIM SHARED buffer(MAXLINES) AS bufferType

CLS
PRINT
PRINT " Alt activates the control panel."
PRINT " Spacebar freezes/unfreezes the image."
PRINT " Escape exits program."
PRINT
PRINT " Press any key to continue..."
' Calibrate delay loop count here.
Delay 0
DO
LOOP UNTIL INKEY$ <> ""
CLS

SetDefaults
MainLoop

' Reset to text mode before exit.
SCREEN 0
CLS

END

ModeError:
badMode = -1
RESUME NEXT

SUB CPanel

' Control Panel.
'
' Delay after CLS for cleaner transition.

' Switch to text mode.
CLS
Delay 5000
SCREEN 0

' Define panel array.
DIM w$(5 TO 17)
w$(5) = CHR$(218) + STRING$(38, 196) + CHR$(191)
w$(6) = CHR$(179) + " delay (ms) = " + CHR$(179)
w$(7) = CHR$(179) + " lineCount = " + CHR$(179)
w$(8) = CHR$(179) + " xLength = " + CHR$(179)
w$(9) = CHR$(179) + " yLength = " + CHR$(179)
w$(10) = CHR$(179) + " xStep = " + CHR$(179)
w$(11) = CHR$(179) + " yStep = " + CHR$(179)
w$(12) = CHR$(179) + " color = " + CHR$(179)
w$(13) = CHR$(179) + " mode = " + CHR$(179)
w$(14) = CHR$(179) + " " + CHR$(179)
w$(15) = CHR$(179) + " Up/Down=Select PgUp/PgDn=Change " + CHR$(179)
w$(16) = CHR$(179) + " Enter=Exit Home=Reset " + CHR$(179)
w$(17) = CHR$(192) + STRING$(38, 196) + CHR$(217)

' Print panel.
FOR row = 5 TO 17
LOCATE row, 21
PRINT w$(row);
NEXT

' Main loop.
DO
delayMs! = delayMicroSec& / 1000
' Print the current parameter values.
FOR n = 1 TO 8
IF n = currField THEN COLOR 0, 7 ELSE COLOR 7, 0
SELECT CASE n
CASE 1
LOCATE 6, 44
PRINT USING "####.#"; delayMs!;
CASE 2
LOCATE 7, 44
PRINT USING " #####"; lineCount;
CASE 3
LOCATE 8, 44
PRINT USING " #####"; xLength;
CASE 4
LOCATE 9, 44
PRINT USING " #####"; yLength;
CASE 5
LOCATE 10, 44
PRINT USING " #####"; xStep;
CASE 6
LOCATE 11, 44
PRINT USING " #####"; yStep;
CASE 7
IF currentColor = 16 THEN
currentColor$ = " cycle"
ELSE
currentColor$ = STR$(currentColor)
END IF
LOCATE 12, 44
PRINT SPACE$(6 - LEN(currentColor$)); currentColor$;
CASE 8
LOCATE 13, 44
SELECT CASE mode
CASE LINEMODE
PRINT " line";
CASE BOXMODE
PRINT " box";
CASE BLOCKMODE
PRINT " block";
END SELECT
END SELECT
NEXT
COLOR 7, 0

' Wait for key and then process it.
DO
key$ = INKEY$
LOOP UNTIL key$ <> ""
SELECT CASE ASC(RIGHT$(key$, 1))
CASE 72 ' Up
currField = currField - 1
IF currField <= 0 THEN currField = 8
CASE 80 ' Down
currField = currField + 1
IF currField > 8 THEN currField = 1
CASE 73 ' PgUp
SELECT CASE currField
CASE 1
IF delayMicroSec& < 2000 THEN
delayMicroSec& = delayMicroSec& + 100
ELSE
delayMicroSec& = delayMicroSec& + 1000
END IF
IF delayMicroSec& > MAXDELAY THEN delayMicroSec& = MAXDELAY
CASE 2
IF lineCount >= 100 THEN
lineCount = lineCount + 10
ELSE
lineCount = lineCount + 1
END IF
IF lineCount > MAXLINES THEN lineCount = MAXLINES
CASE 3
xLength = xLength + 10
IF xLength > xMax + 1 THEN xLength = xMax + 1
CASE 4
yLength = yLength + 10
IF yLength > yMax + 1 THEN yLength = yMax + 1
CASE 5
xStep = xStep + 1
IF xStep > MAXSTEP THEN xStep = MAXSTEP
CASE 6
yStep = yStep + 1
IF yStep > MAXSTEP THEN yStep = MAXSTEP
CASE 7
currentColor = currentColor + 1
IF currentColor > 16 THEN currentColor = 16
CASE 8
mode = mode + 1
IF mode > 2 THEN mode = 2
END SELECT
CASE 81 ' PgDn
SELECT CASE currField
CASE 1
IF delayMicroSec& < 2000 THEN
delayMicroSec& = delayMicroSec& - 100
ELSE
delayMicroSec& = delayMicroSec& - 1000
END IF
IF delayMicroSec& < 0 THEN delayMicroSec& = 0
CASE 2
IF lineCount >= 110 THEN
lineCount = lineCount - 10
ELSE
lineCount = lineCount - 1
END IF
IF lineCount < 1 THEN lineCount = 1
CASE 3
xLength = xLength - 10
IF xLength < 10 THEN xLength = 10
CASE 4
yLength = yLength - 10
IF yLength < 10 THEN yLength = 10
CASE 5
xStep = xStep - 1
IF xStep < 1 THEN xStep = 1
CASE 6
yStep = yStep - 1
IF yStep < 1 THEN yStep = 1
CASE 7
currentColor = currentColor - 1
IF currentColor < 1 THEN currentColor = 1
CASE 8
mode = mode - 1
IF mode < 0 THEN mode = 0
END SELECT
CASE 71 ' Home
SetDefaults
CASE 13 ' Enter
EXIT DO
END SELECT
LOOP

' Reset to graphics mode.
CLS
Delay 5000
SCREEN screenMode

END SUB

DEFSNG A-Z
SUB Delay (microSec&) STATIC

' Delays for <microseconds&> microseconds before
' returning. Should be Windows XP compatible.
'
' Calibrates the delay loop count on first call.

IF fRun% THEN
loops& = microSec& * loopsPerMicroSec!
FOR i& = 1 TO loops&
x! = x! ^ 2
NEXT
ELSE
loops& = 1000
SyncTimer
DO
s! = TIMER
FOR i& = 1 TO loops&
x! = x! ^ 2
NEXT
f! = TIMER
IF f! > s! + 1 THEN
fRun% = -1
EXIT DO
END IF
loops& = loops& * 2
LOOP
loopsPerMicroSec! = loops& / (f! - s!) / 1000000
' This was used to diagnose a problem.
' PRINT loops&, (f! - s!), loopsPerMicroSec!
END IF
END SUB

DEFINT A-Z
SUB MainLoop

' Initialize local parameters.
x2 = xLength - 1
y2 = yLength - 1
x1Step = xStep
y1Step = yStep
x2Step = xStep
y2Step = yStep

DO
' Check shift flags and call CPanel if Alt.
' Reinitialize starting values after return.
DEF SEG = &H40
IF PEEK(&H17) AND 8 THEN
CPanel
x1 = 0
y1 = 0
x2 = xLength - 1
y2 = yLength - 1
x1Step = xStep
y1Step = yStep
x2Step = xStep
y2Step = yStep
' Clear circular buffer.
head = 0
tail = 0
END IF
DEF SEG

' If space then pause.
key$ = INKEY$
IF key$ = CHR$(32) THEN
DO
key$ = INKEY$
LOOP UNTIL key$ <> ""
END IF

Delay delayMicroSec&

' Calculate new coordinates. If next step will
' place coordinates outside screen area then
' reverse step direction.
x1 = x1 + x1Step
IF x1 < 0 THEN x1 = 0
IF x1 < ABS(x1Step) OR x1 > xMax - ABS(x1Step) THEN x1Step = -x1Step
y1 = y1 + y1Step
IF y1 < 0 THEN y1 = 0
IF y1 < ABS(y1Step) OR y1 > yMax - ABS(y1Step) THEN y1Step = -y1Step
x2 = x2 + x2Step
IF x2 > xMax THEN x2 = xMax
IF x2 < ABS(x2Step) OR x2 > xMax - ABS(x2Step) THEN x2Step = -x2Step
y2 = y2 + y2Step
IF y2 > yMax THEN y2 = yMax
IF y2 < ABS(y2Step) OR y2 > yMax - ABS(y2Step) THEN y2Step = -y2Step

' Draw image.
IF currentColor = 16 THEN
' Cycle.
currColor = currColor + 1
IF currColor > 15 THEN currColor = 1
ELSE
currColor = currentColor
END IF

SELECT CASE mode
CASE LINEMODE
LINE (x1, y1)-(x2, y2), currColor
CASE BOXMODE
LINE (x1, y1)-(x2, y2), currColor, B
CASE BLOCKMODE
LINE (x1, y1)-(x2, y2), currColor, BF
END SELECT

' Save coordinates to circular buffer.
' Store at head and read from tail.
' Buffer empty when head = tail.
buffer(head).x1 = x1
buffer(head).y1 = y1
buffer(head).x2 = x2
buffer(head).y2 = y2
head = head + 1
IF head > lineCount THEN head = 0

' If buffer full then start erasing the oldest
' rectangle or line. Buffer full when head behind
' tail. Block mode erases border only.
h = head
h = h + 1
IF h > lineCount THEN h = 0
IF h = tail THEN
SELECT CASE mode
CASE LINEMODE
LINE (buffer(tail).x1, buffer(tail).y1)-(buffer(tail).x2, buffer(tail).y2), 0
CASE BOXMODE, BLOCKMODE
LINE (buffer(tail).x1, buffer(tail).y1)-(buffer(tail).x2, buffer(tail).y2), 0, B
END SELECT
tail = tail + 1
IF tail > lineCount THEN tail = 0
END IF

LOOP UNTIL key$ = CHR$(27)

END SUB

SUB SetDefaults

' Set parameters to default.
delayMicroSec& = 0
lineCount = 20
xLength = xMax / 2
yLength = yMax / 2
xStep = 3
yStep = 2
currentColor = 9
mode = LINEMODE

END SUB

DEFSNG A-Z
SUB SyncTimer

' Waits for the next system timer tick before
' returning.
'
' The value of the TIMER function changes in
' increments of ~55ms, corresponding to the
' period of the system timer tick that it is
' derived from. Because the timing of an
' interval requires two calls to the TIMER
' function, the uncertainty in the interval
' is ~110ms. Synchronizing with the timer
' tick will reduce the uncertainty to ~55ms.

s! = TIMER
DO
LOOP UNTIL s! <> TIMER

END SUB
===========================================================================
Author Topic: LANSCAPE.BAS-QB TO HP DESKJET (Read 43 times)

RogerOxford
General user




I love YaBB 1G - SP1!




Posts: 70
LANSCAPE.BAS-QB TO HP DESKJET
« on: Dec 22nd, 2003, 10:33pm » Quote Modify

--------------------------------------------------------------------------------
I will not be putting any more unpolished code up right away. This code "lanscape.bas" completes what I have wanted to accomplish for about 8 years.
I will dress it up when I am rested.

Roger

Code:
'PROGRAM NANE IS LANSCAPE.BAS = LANDSCAPE SCREEN PRINT
'THIS PROGRAM IS TUNED TO PRINT ALL FOUR PLANES OF SCREEN 12 AS ONE PLANE
'ORED TOGETHER. IT MIGHT WORK ON NUMEROUS H.P. DESKJETS. IF IT PRINTS ON YOUR
'H.P. SEND AN EMAIL STATING THE MODEL#. ENJOY. OPEN FOR IMPROVEMENT BY
'EXAMPLE. ALL 640 ROWS OF 60 BYTES ARE SAVED @ RESOLUTION 150 AND 450 LPI
'VERTICAL DISPLACEMENT ( RESOLUTION ). THE 60 HORIZONTAL (480/8) BYTES HAD
'TO BE DOUBLED (11223344) (55667788) MAKING 120 BYTES. THAT WAS NOT ENOUGH
'SO THE 120 WAS EXPANDED (12344) CONVERTED TO DECIMAL AND PRINTED 150 BYTES
'WIDE BY 640 ROWS TALL.
'$DYNAMIC

REM GOTO 200
SCREEN 12
NumPlanes% = 4: ScreenWidth% = 640: ScreenLength% = 480
IF NumPlanes% = 2 THEN ci% = 0 ELSE ci% = 1 ' Color increment
xmax% = ScreenWidth%: ymax% = ScreenLength%
halfx% = xmax% / 2: halfy% = ymax% / 2
x% = halfx%: c% = 1
FOR y% = ymax% TO halfy% STEP -5
deltax% = xmax% - x%: deltay% = ymax% - y%
LINE (halfx%, y%)-(x%, halfy%), c%
LINE (x%, ymax%)-(xmax%, y%), c% + ci%
LINE (halfx%, deltay%)-(x%, halfy%), c% + 2 * ci%
LINE (x%, 0)-(xmax%, deltay%), c% + 3 * ci%
LINE (halfx% + 1, y%)-(deltax%, halfy%), c% + 4 * ci%
LINE (deltax%, ymax%)-(0, y%), c% + 5 * ci%
LINE (halfx%, deltay%)-(deltax%, halfy% + 1), c% + 6 * ci%
LINE (deltax%, 0)-(0, deltay%), c% + 7 * ci%
x% = x% + (((xmax% + 1) / (ymax% + 1)) * 5)
NEXT y%
LOCATE 1, 60: INPUT "LANSCAPE"; JFG

CONST cGraphicsAddressRegister = &H3CE
CONST cGraphicsDataRegister = &H3CF
' Index value for the Graphics Controller
' Read Map Select Register:
CONST cReadMapSelectIndex = 4

WIDTH LPRINT 255
CONST compression0 = "*b0M"
CONST resetprinter = "E"
CONST SETRESOLUTION75 = "*t75R"
CONST SETRESOLUTION100 = "*t100R"
CONST SETRESOLUTION150 = "*t150R"
CONST Setresolution200 = "*t200R"
CONST SETRESOLUTION300 = "*t300R"
CONST STARTRASTERGRAPHICS = "*r0A"
CONST endrastergraphics = "*rC"

200
DEF SEG = &HA000
OPEN "O", 1, "WORK": CLOSE 1
OPEN "WORK" FOR BINARY AS 1
COLEND% = 79
FOR COL% = 0 TO COLEND%
FOR ROW& = 479 TO 0 STEP -1
PLANE% = 0
OUT cGraphicsAddressRegister, cReadMapSelectIndex
OUT cGraphicsDataRegister, PLANE%
PLACE& = ROW&
PLACE& = PLACE& * (COLEND% + 1)
PLACE& = PLACE& + COL%
MEM% = PEEK(PLACE&)
PLANE% = 1
OUT cGraphicsAddressRegister, cReadMapSelectIndex
OUT cGraphicsDataRegister, PLANE%
MEM% = MEM% OR PEEK(PLACE&)
PLANE% = 2
OUT cGraphicsAddressRegister, cReadMapSelectIndex
OUT cGraphicsDataRegister, PLANE%
MEM% = MEM% OR PEEK(PLACE&)
PLANE% = 3
OUT cGraphicsAddressRegister, cReadMapSelectIndex
OUT cGraphicsDataRegister, PLANE%
MEM% = MEM% OR PEEK(PLACE&)
GOSUB 1900: REM DECIMAL TO BINARY + WRITE IN WORK
2001 NEXT ROW&
NEXT COL%
PRINT LOF(1); " AT 1900"
CLOSE 1
DEF SEG

OPEN "O", 2, "WORK2": CLOSE 2
OPEN "WORK2" FOR BINARY AS 2
OPEN "WORK" FOR BINARY AS 1
DIM HPIX(480) AS STRING * 8
2150 FOR G = 1 TO 80
FOR K = 1 TO 480
GET #1, , HPIX$(K)
NEXT K
FOR COL = 1 TO 8
LET VPIX$ = ""
FOR HP = 1 TO 480
LET VPIX$ = VPIX$ + MID$(HPIX$(HP), COL, 1)
IF (HP / 8) - INT(HP / 8) = 0 THEN GOSUB 2401: REM DUP BINARY-WRITE TO FILE
2155 NEXT HP
NEXT COL
NEXT G
PRINT LOF(2); " AT 2401"
CLOSE 1: CLOSE 2
GOSUB 2501: REM .. EXPAND THE HORIZONTAL (12344)- CONVERT TO DECIMAL- FILE
GOTO 3100

2401 LET fronthalf$ = MID$(VPIX$, 1, 4): LET backhalf$ = MID$(VPIX$, 5, 4)
LET VPIX$ = ""
FOR v = 1 TO 4
LET VPIX$ = VPIX$ + MID$(fronthalf$, v, 1)
LET VPIX$ = VPIX$ + MID$(fronthalf$, v, 1)
NEXT v
PUT #2, , VPIX$
LET VPIX$ = ""
FOR v = 1 TO 4
LET VPIX$ = VPIX$ + MID$(backhalf$, v, 1)
LET VPIX$ = VPIX$ + MID$(backhalf$, v, 1)
NEXT v
PUT #2, , VPIX$
LET VPIX$ = ""
RETURN

2501 COUNT = 0
OPEN "O", 1, "WORK": CLOSE 1
OPEN "WORK" FOR BINARY AS 1
OPEN "WORK2" FOR BINARY AS 2
DIM four(1) AS STRING * 4
2520 FOR JJ = 1 TO LOF(2) / 4
GET #2, , four$(1): COUNT = COUNT + 1
LET VPIX$ = four$(1) + MID$(four$(1), 4, 1)
PUT #1, , VPIX$
NEXT JJ
2530 PRINT LOF(1); " "; COUNT; " AT 12344 EXPANSION"
CLOSE 1: CLOSE 2
RETURN

OPEN "WORK" FOR BINARY AS 1
OPEN "O", 2, "WORK2"
DIM EIGHTBITS(1) AS STRING * 8
2540 FOR JJ = 1 TO 96000
GET #1, , EIGHTBITS$(1)
GOSUB 2201
NEXT JJ
2550 PRINT LOF(2); " AT GOING DECIMAL"
CLOSE 1: CLOSE 2: REM NOW WORK2 HAS THE FINAL DECIMAL DATA 150 BYTES / ROW
RETURN


2201 'BINARY TO DECIMAL
LET TMP% = 0
LET L = LEN(EIGHTBITS$(1))
FOR KV = 8 TO 1 STEP -1
LET EXPO = L - KV
IF MID$(EIGHTBITS$(1), KV, 1) = "1" THEN TMP% = TMP% + (2 ^ EXPO)
NEXT KV
RETURN

3100 REM:::: begin the print out
CONST COLUMNS = "150W": REM THIS IS # BYTES TO MAKE ZERO COMPRESSION ROW!!
LPRINT CHR$(27); "E";
LPRINT CHR$(27); SETRESOLUTION150;
LPRINT CHR$(27); "&l450D"; : REM vertical line per inch
LPRINT CHR$(27); STARTRASTERGRAPHICS;

OPEN "WORK" FOR BINARY AS 2
DIM EIGHTBITS(1) AS STRING * 8
3150 FOR FF = 1 TO 640
LPRINT CHR$(27); "*b0m" + COLUMNS; : REM = 0 COMP WITH 150 BYTES TO FOLLOW
FOR GG = 1 TO 149
GET #2, , EIGHTBITS$(1)
GOSUB 2201
LPRINT CHR$(TMP%);
NEXT GG
GET #2, , EIGHTBITS$(1)
GOSUB 2201
LPRINT CHR$(TMP%)
LPRINT CHR$(27); "*b0W";
3200 NEXT FF
CLOSE 2

3220 'LPRINT CHR$(27); "*b0W"; : REM clears LAST ROW OF xx BYTES!!
'"EVERY RASTER TRANSFER AFFECTS THE SEED ROW REGARDLESS OF THE
'COMPRESSION METHOD" QUOTE THE BOOK.THE SINGLE MOST IMPORTANT AND
'NON OBVIOUS FACTOR!

LPRINT CHR$(12);
LPRINT CHR$(27); endrastergraphics
LPRINT CHR$(27); "E"
END

1900 'decimal to binary
TMP% = MEM%: b$ = ""
FOR J = 7 TO 0 STEP -1
IF TMP% \ 2 ^ J THEN b$ = b$ + "1": TMP% = TMP% - 2 ^ J: GOTO 1901
b$ = b$ + "0"
1901 NEXT J
PUT #1, , b$
RETURN

=======================================================================================
Author Topic: QBTOOLS (Read 171 times)

WaltDecker
Moderator
General user









Posts: 37
QBTOOLS
« on: Oct 1st, 2003, 3:45pm » Quote Modify

--------------------------------------------------------------------------------
In module DIALOG.BAS, cpListBox() doesn't work well with OpenWindow(). If one sets

WindowType.row
WindowType.col = 0
WindowType.rows = 20
WindowTyp.Cols to 22

the window is centered on the screen.

Then opens cpListBox() with:

ListBoxType.row = 2
ListBoxType.col = 2
ListBoxType.Rows = 18
ListBoxType.cols = 21

The list box is completely out of the window.

If no window is opened, cpListBox produces an error.

LATER:

Code:
COLOR 0, 3

CLS
COLOR 7, 3
FOR I = 1 TO 23
FOR J = 1 TO 70
PRINT LTRIM$(STR$(J));
NEXT J
PRINT
NEXT I


W.Rows = 0
W.Cols = 0
W.Rows = 23
W.Cols = 16
W.Back = 2
W.Fore = 15
'W.Border = 0
W.FTitleBar = 1
W.TitleBarFore = 15
W.TitleBarBack = 2
I = 1
J = 128

DIM Lst$(I TO J)

FOR I = 1 TO J
Lst$(I) = STR$(I)
NEXT I

X = 40 - 15 \ 2
Y = 3

LstBox.Row = 2
LstBox.Col = 2

LstBox.Rows = 18
LstBox.Cols = 15

LstBox.SelectedItem = 4
LstBox.fUpdate = 0


CALL OpenWindow(W, "TEST")

DO
CALL CPListBox(LstBox, Lst$())
IF KeyPressed(13) THEN EXIT DO
LOOP




The shadow on the window is incomplete on the right side toward the bottom.

LATER:

The text in the shadow is not being correctly rendered. Also, making changes in the WindowType struct after closing a window and then opening another window appears not to be honored.




« Last Edit: Oct 1st, 2003, 5:12pm by WaltDecker » IP Logged

--------------------------------------------------------------------------------
Walt Decker
UPLA


MichaelWebster
General user









Posts: 15
Re: QBTOOLS
« Reply #1 on: Oct 1st, 2003, 7:12pm » Quote Modify

--------------------------------------------------------------------------------
Walt,

The programmer is responsible for setting the control parameters, including location and size. The row and column are specified in absolute screen coordinates (not window relative).

The window is centered on the screen vertically if the row element is 0 and centered on the screen horizontally if the column element is 0.

The controls are not free standing; they must be defined in and operated from a window procedure. My intention was that each window should have its own window procedure, and that all programmer-defined data for that window be encapsulated in the window procedure. When a window is closed the shared window data is discarded, and when the window procedure returns the programmer-defined data for that window is discarded.

An error will be generated when a control overlaps the borders of the screen, but not when it overlaps the borders of the window it is associated with. If a control overlaps the borders of borders of the window it is associated with it may not display correctly, but it should operate correctly.

If you are using QBDIALOG.QLB and the most recent version of QBTOOLS (DIALOG.BAS v1.2), error information is logged to ERRORLOG.BAS. Refer to the LogError procedure in GENERAL.BAS for the specifics.

For detailed information refer to DIALOG.TXT, the header comments in the control procedures, and the include files.

Also, you might want to look at the example programs FONTVIEW.BAS, IDDEVICE.BAS, and MEMVIEW.BAS. Note that they may not run or run correctly under Windows 2000/XP, and that IDDEVICE will return useful information only under Windows 98 FE or Windows 9x MS-DOS mode.

Also, feel free to complain. If I cannot present a logical reason for any design decision I made, then it was probably a bad decision.

Code:
DECLARE SUB TestWindow ()
DEFINT A-Z

' $INCLUDE: 'DIALOG.BI'
' $INCLUDE: 'GENERAL.BI'
' $INCLUDE: 'MOUSE.BI'
' $INCLUDE: 'ERROR.BI'

CONST cFalse = 0, cTrue = NOT cFalse

TestWindow


SUB TestWindow

OpenScreen cWhite, cBlue, ""

' The window is centered on the screen vertically
' if the row element is 0 and centered on the
' screen horizontally if the column element is 0.
DIM win AS WindowType
win.fTitleBar = cTrue
win.row = 2
win.col = 4
win.rows = 19
win.cols = 60
OpenWindow win, "TestWindow"

' The row and column elements for the controls
' are absolute screen coordinates (not window
' relative).

DIM lstTest AS ListBoxType
lstTest.row = 4
lstTest.col = 19
lstTest.rows = 12
lstTest.cols = 30
lstTest.fDoubleClick = cTrue

DIM cmdShow AS CommandButtonType
cmdShow.row = 18
cmdShow.col = 20
cmdShow.fDefault = cTrue

DIM cmdClose AS CommandButtonType
cmdClose.row = 18
cmdClose.col = 37
cmdClose.fCancel = cTrue

' A list box will truncate items
' that are too long to within the
' specified width.
DIM items$(1 TO 26)
FOR i = 1 TO 26
items$(i) = STRING$(30, 96 + i)
NEXT

DIM msgWin AS WindowType
msgWin.fTitleBar = cTrue
msgWin.fore = cBlack
msgWin.back = cCyan

DO
CpListBox lstTest, items$()
CpCommandButton cmdShow, " &Show "
CpCommandButton cmdClose, " Close "
IF KeyPressed(cKeyF1) THEN
REDIM msg$(1 TO 5)
msg$(1) = "Message boxes are always centered."
msg$(2) = "The minimum width depends on the"
msg$(3) = "style. The box will expand to fit"
msg$(4) = "the message, within the limits of"
msg$(5) = "the screen."
junk = MessageBox(msgWin, cMbOk, 1, "Test", msg$())
END IF
IF cmdShow.fClicked THEN
REDIM msg$(1 TO 2)
IF lstTest.selectedItem THEN
msg$(1) = items$(lstTest.selectedItem)
ELSE
msg$(1) = " No item selected"
END IF
junk = MessageBox(msgWin, cMbOk, 1, "Test", msg$())
END IF
LOOP UNTIL cmdClose.fClicked

' Close the window opened by the call to OpenWindow.
CloseWindow

' Close the window opened by the call to OpenScreen.
CloseWindow

END SUB




IP Logged



WaltDecker
Moderator
General user









Posts: 37
Re: QBTOOLS
« Reply #2 on: Oct 1st, 2003, 7:48pm » Quote Modify

--------------------------------------------------------------------------------
I can work with the design. However, the shadow on the window does not render correctly, at least when windowtype.row and windowtype.col are specified as zero and running on a w2k OS.

Also, I'm not using QBDIALOG.QLB. I'm using DIALOG.BAS and the associated modules in the PDS IDE.
« Last Edit: Oct 1st, 2003, 7:58pm by WaltDecker » IP Logged

--------------------------------------------------------------------------------
Walt Decker
UPLA


MichaelWebster
General user









Posts: 15
Re: QBTOOLS
« Reply #3 on: Oct 2nd, 2003, 3:00am » Quote Modify

--------------------------------------------------------------------------------
The shadow not rendering correctly surprises me. I have never seen this under Windows 9x, Windows 9x MS-DOS mode, or plain MS-DOS. Are you running in a window or full screen? If full screen, exactly what is it doing? I don’t normally run MS-DOS applications in a window because they are very slow to respond and just generally look bad.

I included the Quick library with the last version because DIALOG.BAS in combination with other sizeable modules will not otherwise run within the programming environment. The typical result is an “Out of string space” error and this is what will happen if you try to run any of the examples with all of the modules loaded. The problem can be corrected by processing the program components with CONVERT.BAS, and the result will generally run under QBASIC, but trying to work with the resulting source would be difficult because of the lack of comments and indentation. The Quick library approach is a more reasonable solution, but you do frequently need to refer to ERRORLOG.BAS to determine the cause of run-time errors that are generated within the library.

IP Logged



WaltDecker
Moderator
General user









Posts: 37
Re: QBTOOLS
« Reply #4 on: Oct 2nd, 2003, 11:21am » Quote Modify

--------------------------------------------------------------------------------
There are a couple of problems with my system. The w2k runs all DOS apps in a window, my video card won't accept DOS graphics, and with DOS text I have to explicitly set 80 x 25 mode. I neglected to do that so the shadow was displaying incorrectly. Even then, when the window is on col 1 with the shadow extending to row 25, the bottom shadow is gray instead of black. Moving the window to col 2 clears the problem. Regardless, I need it to display correctly in both 80 x 25 and 80 x 50 mode.

I've found that having two listboxes in the same window presents a problem. I have to press TAB several times to toggle from one listbox to the other then wait several seconds and try to move the selection.

As far as running DIALOG.BAS in the IDE, so far I haven't had a problem as long as I load it as a module, but, for what I'm doing I'm not sure I'm going to be able to use it.
IP Logged

--------------------------------------------------------------------------------
Walt Decker
UPLA


MichaelWebster
General user









Posts: 15
Re: QBTOOLS
« Reply #5 on: Oct 2nd, 2003, 12:51pm » Quote Modify

--------------------------------------------------------------------------------
You should be able to toggle full-screen mode with Alt+Enter.

The shadows use a black background and a high-intensity black (dark gray) foreground.

DIALOG.BAS is hard coded for 80x25. I considered 80x50, but I decided that the 8x8 double-dot font is just too hard on the eyes. If this font were generally considered acceptable, IBM would not have replaced it with an 8x14 font on the EGA and then an 8x16 font on the VGA. Maybe I’m just picky, but I absolutely hated using CGA displays. I stuck with monochrome so I could have a decent 8x14 font.

Two List boxes in the same window should work fine. I think your problem here a combination of running in a window and running under Windows 2000. If this is to be an MS-DOS application, then I think it should be designed and tested on a system that does a reasonable job of emulating DOS (meaning Windows 98), or under real MS-DOS. I have run programs with a DIALOG.BAS UI on a wide variety of systems under MS-DOS and Windows 9x without problems. But when I recently tested under Windows XP, I did have problems. Before you make a final judgement, I really wish you would try DIALOG.BAS under the OS it was intended for.
Code:
DECLARE SUB TestWindow ()
DEFINT A-Z

' $INCLUDE: 'DIALOG.BI'
' $INCLUDE: 'GENERAL.BI'
' $INCLUDE: 'MOUSE.BI'
' $INCLUDE: 'ERROR.BI'

CONST cFalse = 0, cTrue = NOT cFalse

TestWindow



SUB TestWindow

OpenScreen cWhite, cBlue, ""

' The window is centered on the screen vertically
' if the row element is 0 and centered on the
' screen horizontally if the column element is 0.
DIM win AS WindowType
win.fTitleBar = cTrue
win.rows = 20
win.cols = 70
OpenWindow win, "TestWindow"

' The row and column elements for the controls
' are absolute screen coordinates (not window
' relative).

DIM lblTest1 AS LabelType
lblTest1.row = 5
lblTest1.col = 15

DIM lstTest1 AS ListBoxType
lstTest1.row = 6
lstTest1.col = 15
lstTest1.rows = 12
lstTest1.cols = 25
lstTest1.fDoubleClick = cTrue

DIM lblTest2 AS LabelType
lblTest2.row = 5
lblTest2.col = 43

DIM lstTest2 AS ListBoxType
lstTest2.row = 6
lstTest2.col = 43
lstTest2.rows = 12
lstTest2.cols = 25
lstTest2.fDoubleClick = cTrue

DIM cmdShow AS CommandButtonType
cmdShow.row = 20
cmdShow.col = 28
cmdShow.fDefault = cTrue

DIM cmdClose AS CommandButtonType
cmdClose.row = 20
cmdClose.col = 44
cmdClose.fCancel = cTrue

' A list box will truncate items
' that are too long to within the
' specified width.
DIM items$(1 TO 26)
FOR i = 1 TO 26
items$(i) = STRING$(30, 96 + i)
NEXT

DIM msgWin AS WindowType
msgWin.fTitleBar = cTrue
msgWin.fore = cBlack
msgWin.back = cCyan

DO
CpLabel lblTest1, "List&1:"
CpListBox lstTest1, items$()
CpLabel lblTest2, "List&2:"
CpListBox lstTest2, items$()
CpCommandButton cmdShow, " &Show "
CpCommandButton cmdClose, " Close "
IF KeyPressed(cKeyF1) THEN
REDIM msg$(1 TO 5)
msg$(1) = "Message boxes are always centered."
msg$(2) = "The minimum width depends on the"
msg$(3) = "style. The box will expand to fit"
msg$(4) = "the message, within the limits of"
msg$(5) = "the screen."
junk = MessageBox(msgWin, cMbOk, 1, "Test", msg$())
END IF
IF cmdShow.fClicked THEN
REDIM msg$(1 TO 2)
IF ActiveControlIndex = lstTest1.internal.tabIndex THEN
IF lstTest1.selectedItem THEN
msg$(1) = items$(lstTest1.selectedItem)
ELSE
msg$(1) = " No item selected"
END IF
ELSEIF ActiveControlIndex = lstTest2.internal.tabIndex THEN
IF lstTest2.selectedItem THEN
msg$(1) = items$(lstTest2.selectedItem)
ELSE
msg$(1) = " No item selected"
END IF
END IF
junk = MessageBox(msgWin, cMbOk, 1, "Test", msg$())
END IF
LOOP UNTIL cmdClose.fClicked

' Close the window opened by the call to OpenWindow.
CloseWindow

' Close the window opened by the call to OpenScreen.
CloseWindow

END SUB




IP Logged



FB37
Moderator
Expert user









Posts: 473
Re: QBTOOLS
« Reply #6 on: Oct 2nd, 2003, 11:11pm » Quote Modify

--------------------------------------------------------------------------------
As Walt said, the problem is not the OS. The problem is his video card, which won't run DOS graphics. That's why he ran the program in a window.

- FB37.
IP Logged



MichaelWebster
General user









Posts: 15
Re: QBTOOLS
« Reply #7 on: Oct 3rd, 2003, 2:01am » Quote Modify

--------------------------------------------------------------------------------
DIALOG.BAS uses text (alphanumeric) mode, not graphics.

IP Logged



MichaelWebster
General user









Posts: 15
Re: QBTOOLS
« Reply #8 on: Oct 3rd, 2003, 4:32am » Quote Modify

--------------------------------------------------------------------------------
I just installed Windows 2000 Pro so I could do some testing.

Trying to run QB in a window, the mouse does not work and response to the keyboard is somewhat slow. If I run the last program code I posted, it opens in a window, the mouse does not work, and response to the keyboard is somewhat slow. If I modify the code to force a full mode set (QB does not perform a full mode set under all conditions) by adding a SCREEN 12 statement followed by a SCREEN 0 statement to the start of the program, the program then runs full-screen (80x25) and works normally. And when I return to QB, it is running full-screen (80x25) and working normally.

I cannot find any way to start QB in a normal 80x25 full-screen mode. When I select Full-screen in the PIF, I get 80x50 text mode, the same as I get under Window 98 when I run QB with the /H option. I suspect that Microsoft hard coded this for Windows 2000 (and probably XP). Other than the mode difference, QB works normally. If I run the last program code I posted, it runs full screen but the only the top half of the screen is filled and the image wraps with the rightmost ~1/5 of the image showing on the left side of the screen. If I add code to force a full mode set, it runs full screen and works normally. But when I return to QB, QB is still running 80x50.

For compiled versions of the sample programs:

FONTVIEW works normally in full screen mode (because it already contains statements that force a full mode set).

After I added code to force a full mode set, IDDEVICE worked normally in full screen mode. But it could not actually read any information from the drives because all versions of Windows other than 98 FE block access to the command/control registers.

MEMVIEW will not run at all because the BIOS Event Wait function returns an error (the same as it does under Windows XP).

So it is the OS that is causing the user interface to act differently than it does under Windows9x and MS-DOS. Now that I know about this, I’ll just make a full mode set standard for all programs.

IP Logged



MichaelWebster
General user









Posts: 15
Re: QBTOOLS
« Reply #9 on: Oct 4th, 2003, 2:39pm » Quote Modify

--------------------------------------------------------------------------------
I did some more testing under Windows XP HE.

When run in a window, the mouse works normally and response to the keyboard is better that than it was under Windows 2000, but still not normal. The appearance is at least as good as 80x25-text mode. Running a full-screen app will force QB to full-screen mode, the same as for Windows 2000 Pro.

When run full-screen, QB uses 80x50 and the output screen wraps, both identical to the behavior under Windows 2000 Pro.

A SCREEN 0 statement by itself is not sufficient to force a full mode set, but a SCREEN statement that sets a graphics mode followed by a SCREEN 0 is.

A WIDTH 80,25 statement by itself is sufficient to force a full mode set.

Basically, the problem is that in the absence of a mode specification, QB makes assumptions about the state of the video hardware that are valid for DOS and Windows9x, but not valid for Windows 2000 and XP.

IP Logged



WaltDecker
Moderator
General user









Posts: 37
Re: QBTOOLS
« Reply #10 on: Oct 12th, 2003, 5:40pm » Quote Modify

--------------------------------------------------------------------------------
I think ListBoxType should have fore color and back color components added. Currently they default to the colors of the background window.
IP Logged

--------------------------------------------------------------------------------
Walt Decker
UPLA


MichaelWebster
General user









Posts: 15
Re: QBTOOLS
« Reply #11 on: Oct 12th, 2003, 6:26pm » Quote Modify

--------------------------------------------------------------------------------
At one point in the development, all of the control types included fore and back elements. But I eventually decided to eliminate the color selection and multiple other similar things so I could concentrate on getting the basic functionality right. AFAIK you would only need to add fore and back elements to the ListBoxType definition in DIALOG.BI and modify the five SetColor statements in CpListBox.

IP Logged



WaltDecker
Moderator
General user









Posts: 37
Re: QBTOOLS
« Reply #12 on: Oct 13th, 2003, 12:44am » Quote Modify

--------------------------------------------------------------------------------
Quote:
AFAIK you would only need to add fore and back elements to the ListBoxType definition in DIALOG.BI and modify the five SetColor statements in CpListBox.



Already done.

There is one small problem I haven't figured out how to correct though. When ListBoxType.SelectedItem is set and there is a default button, if the user wants the selected item, <enter> has to be punched twice for it to be effective. I'll work on it some more though.
IP Logged

--------------------------------------------------------------------------------
Walt Decker
UPLA


MichaelWebster
General user









Posts: 15
Re: QBTOOLS
« Reply #13 on: Oct 13th, 2003, 10:14am » Quote Modify

--------------------------------------------------------------------------------
Quote:
There is one small problem I haven't figured out how to correct though. When ListBoxType.SelectedItem is set and there is a default button, if the user wants the selected item, <enter> has to be punched twice for it to be effective. I'll work on it some more though.



That sounds like the Enter key is being trapped in more that one place. The first control that handles a key sets sfDiscardKey, causing GetUserInput to discard the key and check for a new one. Is there perhaps more than a single default button? Also, there is a caution in the header comments of the KeyPressed procedure.

IP Logged



WaltDecker
Moderator
General user









Posts: 37
Re: QBTOOLS
« Reply #14 on: Oct 13th, 2003, 1:28pm » Quote Modify

--------------------------------------------------------------------------------
There's only one default button and I'm not making a call to KeyPress at all.

Here's the code.
Code:
DEFINT A-Z

' $INCLUDE: 'c:\bc7\bin\newabcrd\dialog\INTX.BI'
' $INCLUDE: 'c:\bc7\bin\newabcrd\dialog\DIALOG.BI'
' $INCLUDE: 'c:\bc7\bin\newabcrd\dialog\GENERAL.BI'
' $INCLUDE: 'c:\bc7\bin\newabcrd\dialog\MOUSE.BI'
' $INCLUDE: 'c:\bc7\bin\newabcrd\dialog\ERROR.BI'


' $DYNAMIC

DIM SHARED typBut(1 TO 1) AS CommandButtonType
DIM SHARED typLb(1 TO 1) AS ListBoxType
DIM SHARED NumWindows
DIM SHARED Closed

SCREEN 0
WIDTH 80, 25

DIM But$(1 TO 9)
DIM Drvs$(1 TO 5)
DIM Fldr$(1 TO 1000)

FOR i = 1 TO 5
Drvs$(i) = STR$(i)
NEXT i

FOR i = 1 TO 500
Fldr$(i) = SPACE$(20) + STR$(i)
NEXT i
REDIM PRESERVE Fldr$(1 TO 500)
MaxLen = LEN(Fldr$(500))

CALL OpenScreen(0, 15, "")

IF Closed THEN GOTO Set.FileBrowser.Window

IF Selected = 0 THEN Selected = 1

ON ERROR RESUME NEXT

NumButtons = UBOUND(typBut)
ON ERROR GOTO 0


REDIM PRESERVE typBut(1 TO NumButtons + 2) AS CommandButtonType

ON ERROR RESUME NEXT

OkButton = NumButtons + 1
CnclButton = NumButtons + 2

But$(OkButton) = " &OK "
But$(CnclButton) = " &Cancel "

NumList = UBOUND(typLb)
ON ERROR GOTO 0

REDIM PRESERVE typLb(1 TO NumList + 2) AS ListBoxType

DrvList = NumList + 1
FileList = NumList + 2

REDIM PRESERVE TypWin(1 TO NumWindows + 1) AS WindowType



WindowNum = NumWindows + 1
NumWindows = WindowNum
Closed = 1

Set.FileBrowser.Window: '

IF StringSize = MaxLen THEN GOTO Display.Browser.Window

'Set the window size and controls

StringSize = MaxLen
WinStart = 40 - (MaxLen + 12) \ 2
WinEnd = WinStart + MaxLen + 12 - 1

TypWin(WindowNum).row = 1
TypWin(WindowNum).col = WinStart
TypWin(WindowNum).rows = 24
TypWin(WindowNum).cols = MaxLen + 12
TypWin(WindowNum).fore = 15
TypWin(WindowNum).back = 8
TypWin(WindowNum).fNoShadow = 0
TypWin(WindowNum).titleBarFore = 4
TypWin(WindowNum).titleBarBack = 14
TypWin(WindowNum).fTitleBar = 1

typBut(OkButton).row = 24
typBut(OkButton).col = WinStart + 2
typBut(OkButton).fClicked = 0
typBut(OkButton).fDisabled = 0
typBut(OkButton).fDefault = 1

typBut(CnclButton).row = 24
typBut(CnclButton).col = WinEnd - LEN(But$(2)) + 2
typBut(CnclButton).fClicked = 0
typBut(CnclButton).fDisabled = 0


typLb(DrvList).row = 2
typLb(DrvList).col = WinStart + 1
typLb(DrvList).rows = UBOUND(Drvs$) + 2
typLb(DrvList).cols = 6
typLb(DrvList).fDoubleClick = 0
typLb(DrvList).selectedItem = 0

typLb(FileList).row = 2
typLb(FileList).col = WinEnd - MaxLen - 2
typLb(FileList).rows = 22
typLb(FileList).cols = MaxLen + 4
typLb(FileList).fDoubleClick = 0
typLb(FileList).selectedItem = Selected

IF Selected > 1 THEN ' Close the window
CALL CloseWindow
END IF

Open.Window: ' Open the window

CALL OpenWindow(TypWin(WindowNum), "Browse For Directory")

Display.Browser.Window: '

DO
CALL CpListBox(typLb(FileList), Fldr$())
CALL CpListBox(typLb(DrvList), Drvs$())
CALL CpCommandButton(typBut(OkButton), But$(OkButton))
CALL CpCommandButton(typBut(CnclButton), But$(CnclButton))

IF typBut(OkButton).fClicked THEN
IF ActiveControlIndex = typLb(FileList).internal.tabindex THEN
Selected = typLb(FileList).selectedItem
MaxLen = -1
EXIT DO
END IF

IF ActiveControlIndex = typLb(DrvList).internal.tabindex THEN
Selected = typLb(DrvList).selectedItem
MaxLen = -2
EXIT DO
END IF

END IF
IF typBut(CnclButton).fClicked THEN
Selected = -1
EXIT DO
END IF
LOOP

IF Selected < 0 THEN
CALL CloseWindow
NumWindows = NumWindows - 1
Closed = 0
WinStart = 0
WinEnd = 0
END IF

' resize the window and controls and do it again

MaxLen = MaxLen + LEN(Fldr$(500)) + 2

GOTO Set.FileBrowser.Window




It also produces a second problem. Works fine on the first pass but on the second pass it produces an error in cpCommandButton here:

Code:
' The following statement will trigger a Subscript
' out of range error if the first command button in
' the tab order is disabled.
ELSEIF cmd.fDefault AND sControlData(sCurrentWindow, sWindowData(sCurrentWindow).activeControl).controlType <> cCtCommandButton THEN
IF NOT cmd.internal.fCurrentDefault THEN
cmd.internal.fCurrentDefault = cTrue
GOSUB PrintNormal
END IF
cmd.internal.fActive = cFalse
ELSE




LATER: '

Forget the above problem. I've solved it. Have to re-initialize all structs before re-opening the window.
« Last Edit: Oct 13th, 2003, 2:11pm by WaltDecker » IP Logged

--------------------------------------------------------------------------------
Walt Decker
UPLA


MichaelWebster
General user









Posts: 15
Re: QBTOOLS
« Reply #15 on: Oct 13th, 2003, 7:08pm » Quote Modify

--------------------------------------------------------------------------------
I wrote this before you updated your last post.

You are apparently using PDS 7.1. My PDS 7.0 does not support REDIM PRESERVE. VBDOS does but there are some name conflicts with DIALOG.BAS. Before I could run the code I had to write some procedures to replace REDIM PRESERVE.

Here are the problems I found:

The OK button does not recognize the mouse click event.

When I click Cancel, CpListBox returns an illegal function call error because the statement:
typLb(FileList).selectedItem = Selected
is setting an invalid value (-1).

I added code to write information about selected events to a log file. Here is the log that results when I press Enter while the file list box has the focus, causing CpCommandButton to generate a Subscript out of range error:

Start
OpenScreen
Start Set.FileBrowser.Window:
OpenWindow
Start Main Loop
GOTO Set.FileBrowser.Window
Start Set.FileBrowser.Window:
OpenWindow
Start Main Loop

As you can see, OpenWindow is being called twice without an intervening call to CloseWindow. The design of DIALOG.BAS requires that the operations be done in a specific order:

Open the window
Initialize the controls
Enter the main loop
Exit the main loop
Close the window

In addition, the design requires that the value of certain elements of the …internalType variables be set to zero when the control procedures are first called. My intention was that these variables be completely reinitialized each time a window is opened. Encapsulating all the code for a window in a window procedure (without a STATIC attribute) accomplishes this with no special effort on the part of the programmer.

IP Logged



WaltDecker
Moderator
General user









Posts: 37
Re: QBTOOLS
« Reply #16 on: Oct 25th, 2003, 2:08am » Quote Modify

--------------------------------------------------------------------------------
on Oct 3rd, 2003, 4:32am, MichaelWebster wrote:I just installed Windows 2000 Pro so I could do some testing.

Trying to run QB in a window, the mouse does not work and response to the keyboard is somewhat slow. If I run the last program code I posted, it opens in a window, the mouse does not work, and response to the keyboard is somewhat slow. If I modify the code to force a full mode set (QB does not perform a full mode set under all conditions) by adding a SCREEN 12 statement followed by a SCREEN 0 statement to the start of the program, the program then runs full-screen (80x25) and works normally. And when I return to QB, it is running full-screen (80x25) and working normally.



Try right clicking on the QB icon in the upper left corner. Select either default or properties, select options, then uncheck quickedit. That should make the mouse work.

======================================================================================
Author Topic: Algorithm help... (Read 58 times)

Mario LaRosa
New user




I registered with ABC on Thursday, June 24, 2004!




Posts: 4
Algorithm help...
« on: Jun 27th, 2004, 4:03pm » Quote Modify

--------------------------------------------------------------------------------
Hello everyone, I've posted this algorithm here that I'm hoping someone could prehaps optimize or make the function a little bit faster :)...
'
'OOOP...(object:Red) -> (operation:Blend) -> (object:Blue) -> (product:Purple)
'
'$DYNAMIC
'
DECLARE FUNCTION LUTpos% (Table0%, Color1&, Color2&)
'
SCREEN 0: WIDTH 80: CLS
'
Table0% = 255
Color1& = 255
Color2& = 254
'
LOCATE 1, 1: PRINT "Table:"; 0; "to"; Table0%
LOCATE 2, 1: PRINT "Color:"; Color1&
LOCATE 3, 1: PRINT "Color:"; Color2&;
LOCATE 4, 1: PRINT "Point:"; LUTpos%(Table0%, Color1&, Color2&)
'
SLEEP
'
SYSTEM
'

REM $STATIC
'
FUNCTION LUTpos% (Table0%, Color1&, Color2&)
'
IF Color1& > Color2& THEN SWAP Color1&, Color2&
'
LUTpos% = (Color1& * Table0%) - ((Color1& * (Color1& - 1)) \ 2) + (Color2& - Color1&) - 1
'
END FUNCTION


It might just be something real simple that I've over looked, but...Anyways, the function was programmed in QB4.5, and its purpose is to point to a specific byte in an array which is actually a Screen 13,
256 color blender map. (For use in my VIDEO13h graphics library).
The Look-up-table or aka... LUT, consists of the results from blending all 256 with each other, (besides two of the same colors), in a palette.
So example, starting in the first byte of the LUT, (byte 0), would contain the result of blending colors 0 and 1, the second, (byte 1), would hold the result of blending colors 0 & 2, etc... Up to the last byte, (byte 32639),
which would hold the result of blending colors 254 and 255. To give you a better understanding, try to graph out a small table of 8 colors
(0-7) on some graph paper and you should come up with an even right triangle type of pattern.

Example...

00 07 13 18 22 25 27
01 08 14 19 23 26
02 09 15 20 24
03 10 16 21
04 11 17
05 12
06

So, for the results of color 0 and 1 blended would reside on 00, 0 and 7 blended would reside on 06, 1 and 2 would reside on 07, colors 2 and 3 would reside on 13, colors 2 and 6 would reside on 16, colors 5 and 7 would reside on 26, and colors 6 and 7 would end up on 27. You could also see this example if you change the Table% value from 255 to 7,
in the code I've posted above.

Well, I tried to explain my function as best as I could, so if you understand it could you please tell me if there is a faster way to point to the correct
position in my LUT. (I need as much speed as possible because this function will be used for real time blending in screen 13).

Thanks,

Mario LaRosa

IP Logged



Michael Webster
General user




I registered with ABC on Monday, April 5, 2004!




Posts: 24
Re: Algorithm help...
« Reply #1 on: Jun 27th, 2004, 8:14pm » Quote Modify

--------------------------------------------------------------------------------
Hi Mario,

Although I understand basically what you are trying to do here, I don’t understand your numbers. For Screen 13, the PALETTE statement works directly with the VGA Color Registers. There are 256 of these registers, and each register contains a 24-bit color value that consists of 6 bits each for the primary colors red, green, and blue. Each 6-bit field specifies one of 64 (0-63) possible intensities for the primary color, so this arrangement provides 64 * 64 * 64 = 262,144 (256K) possible colors. But note that the color, or properly, “attribute” value that is stored in the display bit planes is a Color Register number, and not an actual color value. Because of this, and because of the arbitrary arrangement of default color values in the Color Registers (16 EGA colors followed by 16 shades of gray, etc), you cannot “blend” colors by manipulating the attribute values. Instead, you must manipulate the primary color intensities in the Color Registers. I don’t know precisely what sort of manipulations might be required, but I doubt that any straightforward, simple scheme would produce the desired results. The program below will allow you to examine and manipulate the Color Registers directly.

The normal purpose of a look-up table is to provide quick access to calculated values where real-time calculation of the values would be too slow. Typically, the look-up table is loaded when the program starts, either by calculating the values directly, or by loading pre-calculated values from a file. In this case, you would have no need for an actual table in memory. The calculated values could simply be stored in the Color Registers, and the hardware would effectively (and efficiently) take care of the look-up operation.
Code:
DECLARE SUB SetColorValues (register%, red%, green%, blue%)
DECLARE SUB ShowColorValues ()
DECLARE FUNCTION HighByte% (i%)
DECLARE FUNCTION LowByte% (i%)
DECLARE SUB GetColorValues (register%, red%, green%, blue%)
DEFINT A-Z
TYPE RegTypeX
ax AS INTEGER
bx AS INTEGER
cx AS INTEGER
dx AS INTEGER
bp AS INTEGER
si AS INTEGER
di AS INTEGER
flags AS INTEGER
ds AS INTEGER
es AS INTEGER
END TYPE
DECLARE SUB InterruptX (intnum%, inRegs AS RegTypeX, outRegs AS RegTypeX)
SCREEN 13

ShowColorValues
reg = 239
CLS
DO
PRINT "Enter R,G,B or 0,0,0 to exit"
INPUT "", red, green, blue
IF red = 0 THEN EXIT DO
' Rotate through registers 240 to 250 to
' avoid changing any sample colors still
' on screen.
reg = reg + 1
IF reg > 250 THEN reg = 239
SetColorValues reg, red, green, blue
PRINT "Result:";
COLOR reg
PRINT STRING$(20, 219)
COLOR 15
DO
key$ = INKEY$
LOOP UNTIL key$ <> ""
LOOP UNTIL key$ = CHR$(27)
ShowColorValues

SUB GetColorValues (register%, red%, green%, blue%)
' Returns with <red%>, <green%>, and <blue%> set to
' the color intensity values from the Color Register
' specified by <register%>.
'
' This procedure requires that the active display
' adapter be VGA compatible.

DIM regX AS RegTypeX

' Simulate an Illegal Function Call error if the
' register number is out of range.
IF register < 0 OR register > 255 THEN ERROR 5

regX.ax = &H1015
regX.bx = register
InterruptX &H10, regX, regX
red = HighByte(regX.dx)
green = HighByte(regX.cx)
blue = LowByte(regX.cx)

END SUB

FUNCTION HighByte% (i%)
' Returns the most significant byte of <i%>.

' Make sure the current segment is the default data segment.
DEF SEG

HighByte = PEEK(VARPTR(i) + 1)

END FUNCTION

FUNCTION LowByte% (i%)
' Returns the least significant byte of <i%>.

LowByte = i AND &HFF

END FUNCTION

SUB SetColorValues (register%, red%, green%, blue%)
c& = 65536 * blue + 256 * green + red
PALETTE register, c&
END SUB

SUB ShowColorValues
CLS
PRINT
PRINT "Index Red Green Blue"
PRINT "---------------------------"
VIEW PRINT 4 TO 25
FOR i = 0 TO 255
GetColorValues i, red, green, blue
PRINT i; TAB(8); red; TAB(16); green; TAB(24); blue;
COLOR i
PRINT TAB(32); STRING$(6, 219)
COLOR 15
DO
key$ = INKEY$
LOOP UNTIL key$ <> ""
IF key$ = CHR$(27) THEN
VIEW PRINT
EXIT SUB
END IF
NEXT
END SUB




IP Logged



FB37
Moderator
Expert user









Posts: 473
Re: Algorithm help...
« Reply #2 on: Jun 27th, 2004, 9:30pm » Quote Modify

--------------------------------------------------------------------------------
Mario, forget about using the PALETTE command to change the palette. Use the OUT command instead; it's much faster.

There's something you'll especially like about the OUT command - you specify the R-G-B values each time you change the palette, rather than having to re-calculate the palette parameters every time.

You can find literally hundreds of programs that use the OUT command with SCREEN 13, but I can always link you to an example if you like.

- FB37.
IP Logged



Mario LaRosa
New user




I registered with ABC on Thursday, June 24, 2004!




Posts: 4
Re: Algorithm help...
« Reply #3 on: Jun 27th, 2004, 10:22pm » Quote Modify

--------------------------------------------------------------------------------
>>Mario, forget about using the PALETTE command to change the palette. Use the OUT command instead; it's much faster<<

Umm, I'm lost, I don't recall any mention of using PALETTE, atleast I don't think so.
And yes using OUT is faster, it's the method I
use for my palettes.

Everyone kinda is focusing on palette manipulation and other palette functions as my question/problem.
The algorithm I posted earlier is just a simple pointer for my palette LUT's, (Look-up-tables).
The palette manipulating routines, such as OUT/INP
are used only in generating the LUT.
So the LUT is generally an ARRAY that holds all the
possible blended results of the 256 colors of the palette. (The results are colors, not RGB intensities.)

All my posted algorithm does is point to the correct byte position on the LUT, so see if I wanted to know where on my LUT the blended results of color 5 and color 190 are, I just call the function with the variables COLOR1=190 and COLOR2=5 and the function will return the correct byte on the LUT to retrieve the correct
blended color.

SO the function is just a pointer.
IP Logged



Michael Webster
General user




I registered with ABC on Monday, April 5, 2004!




Posts: 24
Re: Algorithm help...
« Reply #4 on: Jun 28th, 2004, 3:00am » Quote Modify

--------------------------------------------------------------------------------
on Jun 27th, 2004, 9:30pm, FB37 wrote:Mario, forget about using the PALETTE command to change the palette. Use the OUT command instead; it's much faster.


I was not suggesting the use of the PALETTE statement, I was providing code to illustrate my point (see below).

on Jun 27th, 2004, 10:22pm, Mario LaRosa wrote:
Umm, I'm lost, I don't recall any mention of using PALETTE, atleast I don't think so.
And yes using OUT is faster, it's the method I use for my palettes.

Everyone kinda is focusing on palette manipulation and other palette functions as my question/problem.
The algorithm I posted earlier is just a simple pointer for my palette LUT's, (Look-up-tables).
The palette manipulating routines, such as OUT/INP are used only in generating the LUT.
So the LUT is generally an ARRAY that holds all the possible blended results of the 256 colors of the palette. (The results are colors, not RGB intensities.)

All my posted algorithm does is point to the correct byte position on the LUT, so see if I wanted to know where on my LUT the blended results of color 5 and color 190 are, I just call the function with the variables COLOR1=190 and COLOR2=5 and the function will return the correct byte on the LUT to retrieve the correct blended color.

SO the function is just a pointer.


You did not mention using PALETTE, or anything else that I interpreted as meaning you intended to manipulate the palette. And because of this, I assumed that you would be using the default Color Register values. The problem is that you cannot in general blend colors this way using the default Color Register values, or at least not by my definition of “blending”. Your example of blending red and blue to produce purple (magenta) would work correctly, as would some other combinations in the lower 16 color values, and (I think) most or all combinations in the 32 grayscale values. But the bulk of the colors cannot be blended this way. For example the default RGB values for color 4 (red) are 42-0-0, and the default RGB values for color 5 (magenta) are 42-0-42, and it seems to me that the RGB values for the blended color should be 42-0-21. The problem here is that the default RGB values include no such combination. Essentially, the blending operation would work only when the colors being blended are primary colors or grayscale colors, which means ~ 40 colors out of 256. The only alternative I can see is to alter the default Color Register values to some arrangement that will properly support the blending operation.

I was assuming that you would be assigning descriptive names to the blended colors. But if you need to translate from the component color numbers to the blended color number, then one fast way to do so would be to load the blended color numbers in a two-dimensional array indexed by the component color numbers. That way, your relatively slow pointer calculation would be reduced to a table lookup:
Code:
blendedColor = table(color1,color2)




IP Logged



Mike
ABC Administrator




Please donate :)




Posts: 118
Re: Algorithm help...
« Reply #5 on: Jun 28th, 2004, 5:03pm » Quote Modify

--------------------------------------------------------------------------------
If you use PALETTE, use the following format:

palette (colour #), red% * 65536 + green% * 256 + blue%

the color values need to be from 0 to 63. Your best bet is to divide your values by 4 since you want 0 to 255.

I still would agree to use the OUT command instead.
IP Logged

--------------------------------------------------------------------------------
ABC is improving day after day, update after update.


FB37
Moderator
Expert user









Posts: 473
Re: Algorithm help...
« Reply #6 on: Jun 28th, 2004, 9:36pm » Quote Modify

--------------------------------------------------------------------------------
My apologies, Mario and Michael. I assumed that we were talking PALETTE here because that's what was in the code in Michael's reply box.

Anyway, my bad. Next time, I'll read more carefully.

- FB37.
IP Logged



Mario LaRosa
New user




I registered with ABC on Thursday, June 24, 2004!




Posts: 4
Re: Algorithm help...
« Reply #7 on: Jul 2nd, 2004, 7:55pm » Quote Modify

--------------------------------------------------------------------------------
>>I was assuming that you would be assigning descriptive names to the blended colors. But if you need to translate from the component color numbers to the blended color number, then one fast way to do so would be to load the blended color numbers in a two-dimensional array indexed by the component color numbers. That way, your relatively slow pointer calculation would be reduced to a table lookup:

Code:
blendedColor = table(color1,color2)<<

Michael, that's actually the way I'm doing it now, using an array (table) which is only slightly faster than using my pointer function. But the downside is the array takes up memory, the pointer is just the code.
So, I guess it's the age old problem every programmer
faces, faster execution but more memory or
less memory but slower execution.




IP Logged



FB37
Moderator
Expert user









Posts: 473
Re: Algorithm help...
« Reply #8 on: Jul 2nd, 2004, 11:33pm » Quote Modify

--------------------------------------------------------------------------------
In general, if you decrease the amount of variables the program has to look at, it will go faster.

I would also try setting the variables you use into Integers (or variables that only store whole numbers, not decimals). For example:

DIM RedValue AS INTEGER
IP Logged



Michael Webster
General user




I registered with ABC on Monday, April 5, 2004!




Posts: 24
Re: Algorithm help...
« Reply #9 on: Jul 3rd, 2004, 5:40am » Quote Modify

--------------------------------------------------------------------------------
on Jul 2nd, 2004, 7:55pm, Mario LaRosa wrote:
Michael, that's actually the way I'm doing it now, using an array (table) which is only slightly faster than using my pointer function. But the downside is the array takes up memory, the pointer is just the code.
So, I guess it's the age old problem every programmer faces, faster execution but more memory or less memory but slower execution.



A table lookup would be much faster than your pointer function. This program times both methods, and it shows the table lookup has a >5:1 advantage through the QB45 interpreter, and >3:1 for a compiled EXE. And note that this is the worst possible case because Color1& is always < Color2& (so the SWAP statement never runs), huge dynamic arrays are slower than normal arrays, and multi-dimension arrays are slower than one-dimensional arrays.
Code:
DECLARE FUNCTION LUTpos% (Table0%, Color1&, Color2&)
DEFINT A-Z

' This array must be dynamic and when starting
' QB you must use the /AH command line option
' to enable huge dynamic arrays.
' $DYNAMIC
DIM table(0 TO 255, 0 TO 255)

Table0% = 0: Color1& = 0: Color2& = 7

s! = TIMER
FOR i& = 1 TO 1000000
p = LUTpos(Table0%, Color1&, Color2&)
NEXT
f! = TIMER
PRINT "using LUTpos : "; f! - s!

s! = TIMER
FOR i& = 1 TO 1000000
p = table(Color1&, Color2&)
NEXT
f! = TIMER
PRINT "using table lookup: "; f! - s!


REM $STATIC
FUNCTION LUTpos% (Table0%, Color1&, Color2&)
IF Color1& > Color2& THEN SWAP Color1&, Color2&
LUTpos% = (Color1& * Table0%) - ((Color1& * (Color1& - 1)) \ 2) + (Color2& - Color1&) - 1
END FUNCTION





 
 Respond to this message   
 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement  

Newbies usually go to www.qbasic.com and click on The QBasic Forum
Forum regulars have their own ways, which include The QBasic Community Forums