QBasic and QB64 Discussion Board

[QB Forum Archives (1999-2009)/ ] [QB FAQ] [QB Links and Downloads] [Subforums and Chat Room] [Search]

QB64.Net Homepage   QB/QB64 Keywords   QB Graphics Forum   Homework Policy



HAPPY NEW YEAR!

by Pete (Premier Login iorr5t)
Forum Owner

Well nearly, only a little past 8:45 West Coast time. Will 2012 be the year of qbasic? It may be poised for a comeback! Well, one can dream, and thanks to dreams, we have QB64.

Anyway, it's good to see the mods taking such good care of the forum, and I hope this posts puts the "A" in Rob's Q and A, "Where's Pete?"

Best wishes in 2012 to all the forum regulars and newbies,

Pete

 

 

 

Posted on Dec 31, 2011, 8:48 PM

Respond to this message   

Return to Index


*Howdy, Pete.

by (Login MCalkins)
Moderator

Regards,
Michael

Posted on Dec 31, 2011, 10:04 PM

Respond to this message   

Return to Index


*Hi, Pete - Happy New Year to you too!

by (Login qb432l)
R

*

Posted on Jan 1, 2012, 1:06 AM

Respond to this message   

Return to Index


How is basketball going?

by (Login burger2227)
R

My brother is a coach for the Southern High school junior varsity girls team at Deep Creek Maryland. He spends a ton of time working with them! Hope your team does well!

Ted

Posted on Jan 1, 2012, 1:07 AM

Respond to this message   

Return to Index


Happy New Year to all! Revisited Times Square program:

by Solitaire (no login)

DECLARE SUB Ball (x AS INTEGER, y AS INTEGER, w AS INTEGER, tint() AS INTEGER)
DECLARE SUB Pole ()
DIM x AS INTEGER, y AS INTEGER, w AS INTEGER, T AS SINGLE
DIM yr AS INTEGER, mo AS INTEGER, cheer AS INTEGER
DIM year AS STRING, month AS STRING, msg AS STRING, E AS STRING
DIM tint(0 TO 20) AS INTEGER
DIM song(1 TO 5) AS STRING

RANDOMIZE TIMER
year$ = RIGHT$(DATE$, 4)
month$ = LEFT$(DATE$, 2)
yr = VAL(year$)
mo = VAL(month$)
IF mo >= 9 THEN yr = yr + 1
year$ = LTRIM$(RTRIM$(STR$(yr)))
year$ = SPACE$(4) + year$ + SPACE$(7)       'center interchange with message
msg$ = "HAPPY NEW YEAR!"
song$(1) = "p8mbmlO2T220"                   'song - Auld Lang Syne
song$(2) = "ccfffeffaagggfgg"
song$(3) = "agffffaa>ccddddd"
song$(4) = "p8ddccc<aaaffgggfgg"
song$(5) = "agfffdddccfffff"
CLS
LOCATE 6, 22: PRINT "TIMES SQUARE ON NEW YEAR'S EVE"
PRINT TAB(22); STRING$(30, "_")

PRINT : PRINT , , "by Solitaire"
LOCATE 19, 20: PRINT "Press Alt-Enter for a full screen."
PRINT TAB(15); "Program will not work properly in a window."
LOCATE 24, 24: PRINT "Press any key to begin...";
E$ = INPUT$(1)

CLS
FOR x = 0 TO 20             'changing colors of ball as it drops
    READ tint(x)            'assigned to array
NEXT x
CALL Pole
x = 2
y = 10
w = 1
CALL Ball(x, y, w, tint())
w = 0
COLOR 7, 0
LOCATE 25, 1: PRINT "Press any key to begin countdown ";
PRINT TAB(50); "Press Esc to stop";
E$ = INPUT$(1)
IF E$ = CHR$(27) THEN CLS : SYSTEM
LOCATE 25, 1: PRINT SPACE$(70);
s = 260
COLOR 8
LOCATE 10, 12: PRINT "Goodbye..."
LOCATE 10, 58: PRINT yr - 1

FOR x = 1 TO 20
    ex$ = INKEY$
    IF ex$ = CHR$(27) THEN  'Esc places ball on bottom
        CLS
        CALL Pole
        CALL Ball(20, 0, 0, tint())
        COLOR 7, 0: : EXIT FOR
    END IF
    SOUND s, 10             'sound heard while ball is dropping
    s = s + 9
    IF x MOD 2 = 0 THEN     'countdown from 10 to 1
        y = y - 1
    END IF
    CALL Ball(x, y, w, tint())
    T = TIMER
    DO WHILE T + .5 >= TIMER AND T + .5 <= 86400: LOOP
NEXT x

IF ex$ <> CHR$(27) THEN
    COLOR 30, 0
    LOCATE 10, 10
    PRINT msg$
    LOCATE 10, 55
    PRINT year$
    PLAY "P2"
    FOR i = 1 TO 5                      'song - Auld Lang Syne
        PLAY song$(i)
        ex$ = INKEY$
        IF ex$ = CHR$(27) THEN COLOR 7, 0: EXIT FOR
    NEXT i
    c = 16
END IF

IF ex$ <> CHR$(27) THEN cheer = 120
FOR blink = 1 TO cheer              'will not execute if Esc was pressed
    ex$ = INKEY$
    IF ex$ = CHR$(27) THEN COLOR 7, 0: EXIT FOR
    c = c + 1
    IF c = 32 THEN c = 17
    COLOR c, 0
    IF blink > 110 THEN COLOR 30    'messages blink and switch places
    IF blink = 120 THEN COLOR 14
    SELECT CASE blink
        CASE 1 TO 16, 33 TO 48, 65 TO 80, IS > 97
            LOCATE 10, 10
            PRINT msg$
            LOCATE 10, 55
            PRINT year$
        CASE ELSE
            LOCATE 10, 10
            PRINT year$
            LOCATE 10, 55
            PRINT msg$
    END SELECT
    DO
        row = INT(21 * RND) + 2         'confetti fills the sky
        col = INT(75 * RND) + 3         'does not cover ball or pole
    LOOP WHILE row > 17 AND col > 34 AND col < 46 OR col = 40
    tint = INT(15 * RND) + 1
    confetti$ = CHR$(INT(6 * RND) + 1)
    LOCATE row, col
    COLOR tint, 0
    IF blink > 105 THEN
        confetti$ = "*"             'last confetti stars remain blinking
        COLOR tint + 16, 0
    END IF
    PRINT confetti$
    T = TIMER
    DO WHILE T + .15 >= TIMER AND T + .15 <= 86400: LOOP
NEXT blink
COLOR 30                            'blinking yellow
LOCATE 10, 55: PRINT year$          'covers any random confetti
LOCATE 10, 10: PRINT msg$
IF ex$ = CHR$(27) THEN CLEAR        'stop song if Esc was pressed
COLOR 7, 0
LOCATE 25, 3: PRINT "Press any key to end...";
LOCATE 25, 55: PRINT "By Solitaire";
E$ = INPUT$(1)
CLS
DATA 3,3,2,2,3,3,5,5,3,3,2,2,3,3,5,5,3,3,2,2,3,3,3
SYSTEM

SUB Ball (x AS INTEGER, y AS INTEGER, w AS INTEGER, tint() AS INTEGER)
STATIC T AS INTEGER
IF x > 2 THEN               'clear top of ball
    LOCATE x - 1, 38
    PRINT SPACE$(5)         'space prints background color
END IF
LOCATE x, 36: PRINT " "
LOCATE x, 44: PRINT " "
LOCATE x, 37: PRINT SPACE$(7)
COLOR 6
IF x > 2 THEN               'redraw pole on top
    LOCATE x - 1, 40
    PRINT CHR$(186)
END IF
COLOR tint(T)             'redraw descending ball with changing color
IF x > 1 THEN
    LOCATE x, 38
    PRINT CHR$(220); STRING$(3, CHR$(219)); CHR$(220)
END IF
FOR z = 1 TO 2
    IF x = 1 THEN
        LOCATE x + z, 39
        PRINT STRING$(3, CHR$(219))
    ELSE
        LOCATE x + z, 36
        IF z = 1 THEN
            PRINT CHR$(220); STRING$(7, CHR$(219)); CHR$(220)
        ELSE
            PRINT CHR$(223); STRING$(7, CHR$(219)); CHR$(223)
        END IF
    END IF
NEXT z
LOCATE x + 3, 38
IF x > 1 THEN PRINT CHR$(223); STRING$(3, CHR$(219)); CHR$(223)
IF y = 10 THEN
    IF w = 1 THEN
        LOCATE 3, 38
    ELSE
        LOCATE x + 2, 38
    END IF
ELSE
    LOCATE x + 1, 39
END IF
COLOR 0, tint(T)         'background color of countdown number
PRINT y;                 'countdown number
COLOR 7, 0
LOCATE 1, 32
PRINT "TIMES SQUARE BALL"
IF x = 20 THEN
    LOCATE 21, 40
    COLOR 30, tint(T)
    PRINT CHR$(1)                       'happy face replaces countdown number
    LOCATE 22, 40
    PRINT "*"
END IF
T = T + 1               'static counter
END SUB

SUB Pole
COLOR 6     'color of pole
FOR x = 2 TO 24
    LOCATE x, 40
    PRINT CHR$(186)
NEXT x
LOCATE 24
PRINT TAB(37); CHR$(201); STRING$(2, CHR$(205)); CHR$(202); STRING$(2, CHR$(205)); CHR$(187);
END SUB

Posted on Jan 1, 2012, 3:25 PM

Respond to this message   

Return to Index


*Thank-you Solitaire! Now I can officially begin 2012. All the best for the new year!

by (Login qb432l)
R

*

Posted on Jan 2, 2012, 12:22 AM

Respond to this message   

Return to Index


* Thanks, Bob. All the best to you!

by Solitaire (no login)

Posted on Jan 2, 2012, 10:44 AM

Respond to this message   

Return to Index


*HAPPY NEW YEAR TO EVERYBUDDY*

by OPRESION (no login)

*******************

Posted on Jan 1, 2012, 8:29 PM

Respond to this message   

Return to Index


Reading a single byte or less from a file...

by acehi (no login)

In QB 4.5, When reading from an opened binary file, the smallest data-type I can read into is an int% (2 bytes).

Just so I can move forward, I currently use a function that expands the integer into binary, then isolate what I need.

Is there an intuitive method that any of you would suggest for grabbing just 1 byte, or even better, just a nibble?

Posted on Dec 31, 2011, 9:46 AM

Respond to this message   

Return to Index


Yes, use a character...

by (Login qb432l)
R

a$ = " "

a$ represents one character now which is one byte.

GET #1, , a$

Value% = ASC(a$)

This converts it to an integer.

To get nibbles, use the following:

HiNIBBLE% = ASC(a$) \ &H10 'Note: integer division, not division
LoNIBBLE% = ASC(a$) AND &HF

-Bob

Posted on Dec 31, 2011, 11:43 AM

Respond to this message   

Return to Index


* Also, DIM b AS STRING * 1

by (Login MCalkins)
Moderator

Posted on Dec 31, 2011, 1:17 PM

Respond to this message   

Return to Index


Thanks to the both of you...

by acehi (no login)

Bracing myself for the obvious, I knew this all along. The tips for nibbles is new to me however.

Don't party too hard tonight.

Posted on Dec 31, 2011, 1:24 PM

Respond to this message   

Return to Index


*yw. LOL @ don't party too hard. I wasn't planning on partying at all... :-)

by (Login MCalkins)
Moderator

Posted on Dec 31, 2011, 1:47 PM

Respond to this message   

Return to Index


What is the difference between END and SYSTEM?

by AlGoreIthm (no login)

After seeing so many programs end with 'END' and others end with 'SYSTEM', can't honestly say I know what the difference is between the two statements as a final line.
If there is a difference, who can put it into words?

Posted on Dec 30, 2011, 3:12 PM

Respond to this message   

Return to Index


Re: What is the difference between END and SYSTEM?

by (Login MCalkins)
Moderator

In QBASIC 1.1:

If you run the program with:

qbasic.exe /run progname.bas

Then SYSTEM kicks you back to the command prompt (*), whereas END gives you "Press any key to continue...", then kicks you into the QBASIC Editor.

Otherwise, they are basically the same.

* Even if you have run the program with /run, if anything kicks you into the editor, such as the user pressing CTRL+BREAK, or encountering a runtime error without an error handler, then resumes, SYSTEM acts like END.

In QB64:

END gives you "Press any key to continue...". This allows the user to read the window before it disappears.

SYSTEM causes the window to disappear immediately. The user doesn't have a chance to read it.

QBASIC runs in a normal console, so the user can read the screen even after the program has ended. QB64 does not use a console window, so you can't read the screen from the command prompt after the QB64 program has terminated.

So:

For QBASIC programs, I always use SYSTEM.

For QB64 programs, or QBASIC programs that I think will be used in QB64, I use END unless the screen contents at termination don't matter.

Regards,
Michael

Posted on Dec 30, 2011, 3:50 PM

Respond to this message   

Return to Index


So you are saying

by AlGoreIthm (no login)

that - depending on how you ran the program at the outset,
SYSTEM will return you to the DOS prompt, whereas END will leave you in the QBasic editor?

And if you ran the program from the QBasic editor, then SYSTEM will perform the same as END will, which in either case you end up in the Qbasic Editor. Is that it?

Posted on Dec 30, 2011, 4:32 PM

Respond to this message   

Return to Index


*yes.

by (Login MCalkins)
Moderator

Posted on Dec 31, 2011, 1:18 PM

Respond to this message   

Return to Index


In Qbasic SYSTEM allows a program to be run just like a compiled EXE program.

by Clippy (no login)

You can use the command line to run the program and SYSTEM ends the program immediately, just like a compiled program would.

When you run the BAS program from the IDE, SYSTEM behaves the same as END. That confused the hell out of me until I realized that!

Posted on Dec 31, 2011, 1:34 PM

Respond to this message   

Return to Index


Kaleidoscope

by lawgin (no login)

It works well with qb64, might be a little slow in qb.


CLS
SCREEN 12
DO
d = d + .003
FOR th = 0 TO 60 STEP .003
r = 3 ^ (th * .1)
x = COS(th + d) * r
y = SIN(th + d) * r
xp = COS(th - d) * r
yp = SIN(th - d) * r
PSET (320 + xp, 250 - y), d + 1
PSET (320 + x, 250 - yp), 0
NEXT
LOOP WHILE INKEY$ = ""



Posted on Dec 30, 2011, 10:31 AM

Respond to this message   

Return to Index


*Wow! That's beautiful -- and with so little code! Nice job!

by (Login qb432l)
R

*

Posted on Dec 30, 2011, 10:50 AM

Respond to this message   

Return to Index


*very cool.

by (Login MCalkins)
Moderator

Posted on Dec 30, 2011, 10:59 AM

Respond to this message   

Return to Index


* slow on XP, but unbelievable :)

by Lisztfr (no login)

*

Posted on Dec 31, 2011, 1:12 AM

Respond to this message   

Return to Index


Videoport still dysfunction !

by Lisztfr (no login)

Microsoft Windows XP [version 5.1.2600]
(C) Copyright 1985-2001 Microsoft Corp.

C:\36_videoprt>install.bat

C:\36_videoprt>if not exist C:\WINDOWS\system32\drivers\vidprt0.sys (
copy C:\WINDOWS\system32\drivers\videoprt.sys C:\WINDOWS\system32\drivers\vidprt
0.sys
copy C:\WINDOWS\system32\dllcache\videoprt.sys C:\WINDOWS\system32\dllcache\vid
prt0.sys
copy C:\WINDOWS\ServicePackFiles\i386\videoprt.sys C:\WINDOWS\ServicePackFiles\
i386\vidprt0.sys
)

C:\36_videoprt>copy videoprt.sys C:\WINDOWS\ServicePackFiles\i386\videoprt.sys
Le chemin d'accès spécifié est introuvable.
0 fichier(s) copié(s).

C:\36_videoprt>copy videoprt.sys C:\WINDOWS\system32\drivers\videoprt.sys
1 fichier(s) copié(s).

C:\36_videoprt>copy videoprt.sys C:\WINDOWS\system32\dllcache\videoprt.sys
1 fichier(s) copié(s).

C:\36_videoprt>


Is this correct ? There was 1 path not found error :

C:\36_videoprt>copy videoprt.sys C:\WINDOWS\ServicePackFiles\i386\videoprt.sys
Le chemin d'accès spécifié est introuvable.
0 fichier(s) copié(s).

Nothing was copied ? is that critical ? There is no ServicePack etc.

thanks, L

Posted on Dec 30, 2011, 5:49 AM

Respond to this message   

Return to Index


*Better after restart. Now we see how long it holds..

by Lisztfr (no login)

*

Posted on Dec 30, 2011, 5:55 AM

Respond to this message   

Return to Index


*XP repaired it self over night while in stand by...

by Lisztfr (no login)

*

Posted on Dec 31, 2011, 1:13 AM

Respond to this message   

Return to Index


QBASIC Code

by (no login)

I've been away from QBasic for 10-15 years and would like to resurrect a program I wrote which simulated a blackjack game and generated statistics on various card strategies (ie hit, double down, split, hold). However, now I only have the printed out info with the program code. How do I obtain QBasic so I can reenter my 5-6 pages of code and execute the program?

Posted on Dec 30, 2011, 4:08 AM

Respond to this message   

Return to Index


Re: QBASIC Code

by (Login MCalkins)
Moderator

Well, you can enter it now with Notepad...
If you have a scanner and OCR software, you might try scanning it. Double check the results.

To get QBASIC 1.1:

http://download.microsoft.com/download/win95upg/tool_s/1.0/w95/en-us/olddos.exe

Extract that somewhere. Qbasic.* and possibly Help.* are what you want.

Also, there is a Win32 compiler that can compile most QBASIC code:

http://qb64.net/

Regards,
Michael

Posted on Dec 30, 2011, 10:56 AM

Respond to this message   

Return to Index


QB64 will run your code, and in the latest Windows platforms, too...

by (Login qb432l)
R

Go here and download QB64 (free).

http://www.qb64.net/

After installing, copy your QBasic code to the QB64 directory and run QB64.EXE. Open your program and press F5.

QB64 is great in that it will run QBasic code without having to alter it, but it also has a great many other capabilities, including expanded graphics, display of bitmaps, etc., playing .wav and .mp3 sound files, etc., etc.. While your at the QB64 website, check out the QB64 Wiki for both QBasic commands, and new QB64 commands.

-Bob

Posted on Dec 30, 2011, 11:00 AM

Respond to this message   

Return to Index


look at my freebasic project

by Ben (no login)

not in qb, but its pretty cool

here is exe and stuff:
http://qbasic.orgfree.com/fbgui1.zip

and here is video:
http://www.youtube.com/watch?v=8HAx3ttyjd8

and here is source code:

declare sub printf overload (x, y, s as string, c as ubyte)
declare sub printf overload (x, y, s as string, c as ubyte, buffer as any ptr)
declare sub memcopy (byval src as any ptr, byval dest as any ptr, byval n as uinteger, byval d as uinteger)

declare sub drawin overload (x, y, x1, y1, cap as string)
declare sub drawin overload (x, y, x1, y1, cap as string, buffer as any ptr)
declare sub redraw ()
declare sub res (x, y)
declare sub resize(x, y, buffer as any ptr)

declare sub mktop (id)
declare sub closewin (id)
declare sub makewin (x, y, x1, y1, cap as string, pid)

declare sub clock (id)
declare sub smalldir (id)
declare sub text (id)
declare sub loadbmp (id)
declare sub runcom (id)

declare function getfiles (path as string, f() as string)
declare function mousebox (x, y, x1, y1)

dim shared mx, my, mb

type wintype
x as integer
y as integer
x1 as integer
y1 as integer
cap as string
pid as integer

diri as integer

iptr as any ptr
end type
dim shared win(100) as wintype
dim shared wins as integer = 0

dim shared sdir(100) as string
dim shared sdirs(100) as integer
dim shared sdirf(500) as string

dim shared textf(100) as string
dim shared textx(100) as integer
dim shared texty(100) as integer
dim shared textb(100) as ubyte ptr
dim shared textl(100) as integer
dim shared textc(100) as integer

type loadbmptype
iptr as any ptr
x as integer
y as integer
end type
dim shared lbmp(100) as loadbmptype
dim shared bmpf(100) as string

dim shared runcomx(100) as string

dim shared menu1(9) as string
menu1(0)="menu"
menu1(1)=""
menu1(2)="file man"
menu1(3)="text"
menu1(4)="clock"
menu1(5)="run"
menu1(6)=""
menu1(7)="-----------"
menu1(8)="options >"
menu1(9)="exit"

dim shared menu2(5) as string
menu2(0)=" 320x240"
menu2(1)="*640x480"
menu2(2)=" 800x600"
menu2(3)=" 1024x768"
menu2(4)=""
menu2(5)="bg center"

dim shared bgstretch=0
dim shared bgoff=0

screenres 640, 480, 8
dim shared as integer screenw,screenh
screeninfo screenw,screenh

dim shared as any ptr temp1,temp2,temp3,temp4
temp1 = imagecreate(screenw,screenh)

dim shared font(1040) as ubyte
bload "font.dat", varptr(font(11))

dim shared s as string*2
dim shared as ushort bx,by
dim shared bg as any ptr
bg = imagecreate(screenw,screenh,0)
if not bgoff then
open "bg.bmp" for binary as #1
get #1,,s
if s="BM" then
get #1,19,bx
get #1,23,by
temp3=imagecreate(bx,by)
bload "bg.bmp",temp3
if bgstretch then
resize screenw,screenh,temp3
imagedestroy bg
bg = temp3
else
put bg,((screenw-bx)\2,(screenh-by)\2),temp3
imagedestroy temp3
end if
end if
close
end if

palette 0, &h000000
palette 15, &hffffff

'makewin 400,200,150,175,"clock",1
'makewin 100,100,150,175,"clock1",1

'makewin 0,0,150,200,"dir",2
'win(wins-1).diri=wins-1
'sdir(win(wins-1).diri)="C:\"
'sdirs(win(wins-1).diri)=0

'makewin 0,0,150,200,"dir",2
'win(wins-1).diri=wins-1
'sdir(win(wins-1).diri)="C:\font\"
'sdirs(win(wins-1).diri)=0

'makewin 50,50,200,200,"text",3
'win(wins-1).diri=wins-1
'textf(win(wins-1).diri)="C:\bensled.bas"
'textx(win(wins-1).diri)=0
'texty(win(wins-1).diri)=0
'open textf(win(wins-1).diri) for binary as #1
' textb(win(wins-1).diri)=allocate(lof(1))
' get #1,,*textb(win(wins-1).diri),lof(1)
' textl(win(wins-1).diri)=lof(1)
'close

'open "bg.bmp" for binary as #1
'
' get #1,,s
' if s="BM" then
'
' get #1,19,bx
' get #1,23,by
'
' makewin 50,50,bx+2,by+27,"bmpload",4
' win(wins-1).diri=wins-1
' bmpf(wins-1)="bg.bmp"
' end if
'close

dim key as string

'makewin 50,50,150,200,"dir",2
'win(wins-1).diri=wins-1
'sdir(win(wins-1).diri)=".\img\"
'sdirs(win(wins-1).diri)=0

screenlock
put(0,0),bg,pset
for i=wins-1 to 0 step -1
select case win(i).pid
case 1
clock i
case 2
smalldir i
case 3
text i
case 4
loadbmp i
case 5
runcom i
case else
drawin 0,0,win(i).x1,win(i).y1,win(i).cap,win(i).iptr
put (win(i).x,win(i).y),win(i).iptr,pset
end select
next
screenunlock

do
start:
getmouse mx,my,,mb

'window management
for i=0 to wins-1
if mousebox(win(i).x,win(i).y,win(i).x1+win(i).x,win(i).y1+win(i).y) then
if mousebox(win(i).x,win(i).y,win(i).x1+win(i).x,win(i).y+25) then

if mb=1 then
mktop i

screenlock
put(0,0),bg,pset
redraw
get(0,0)-(screenw-1,screenh-1),temp1
put(win(0).x,win(0).y),win(0).iptr,pset
screenunlock

oldx= mx-win(0).x
oldy= my-win(0).y
do
oldmx= mx
oldmy= my
getmouse mx,my,,mb

newx= mx-oldx
newy= my-oldy
if mx<>oldmx and my<>oldmy then
screenlock
put(0,0),temp1,pset
'put(newx,newy),temp2,pset
'line(0,0)-(639,479),0,bf
'redraw
'drawin newx,newy,win(0).x1,win(0).y1,win(0).cap
put(newx,newy),win(0).iptr,pset

screenunlock
end if
loop until mb=0
win(0).x= newx
win(0).y= newy

screenlock
put(0,0),bg,pset
redraw
put(win(0).x,win(0).y),win(0).iptr,pset
screenunlock
exit for
goto start
elseif mb=2 then
do
getmouse mx,my,,mb
loop while mb=2

closewin i
screenlock
put(0,0),bg,pset
redraw
put(win(0).x,win(0).y),win(0).iptr,pset
screenunlock
exit for
goto start
end if
else
if mb<>0 then
mktop i
screenlock
put(0,0),bg,pset
redraw
get(0,0)-(screenw-1,screenh-1),temp1
put(win(0).x,win(0).y),win(0).iptr,pset
screenunlock
goto start
end if
exit for
end if

end if
next

'menu
if mb=2 then
do
getmouse mx,my,,mb
loop while mb=2
l=len(menu1(0))
for i=0 to ubound(menu1)
if l<len(menu1(i)) then l=len(menu1(i))
next

x=l*8+10
y=(ubound(menu1)+1)*15+10
temp2=imagecreate(x+1,y+1)

if screenw-mx<=x then ox=screenw-x-1 else ox=mx
if screenh-my<=y then oy=screenh-y-1 else oy=my

get (ox,oy)-step(x,y),temp2
do
getmouse mx,my,,mb
screenlock
line (ox+1,oy+1)-step(x-2,y-2),0,bf
line (ox,oy)-step(x,y),15,b
for i=0 to ubound(menu1)
if (my-oy-5)\15 = i then
line(ox+1,oy+3+((my-oy-5)\15)*15)-step(x-2,15),15,bf
printf ox+5,oy+i*15+5,menu1(i),0
else
printf ox+5,oy+i*15+5,menu1(i),15
end if
next
screenunlock

'sub menu
if (my-oy-5)\15 = ubound(menu1)-1 then
l2=len(menu2(0))
for i=0 to ubound(menu2)
if l2<len(menu2(i)) then l2=len(menu2(i))
next

x2=l2*8+10
y2=(ubound(menu2)+1)*15+10
temp3=imagecreate(x2+1,y2+1)

ox2=ox+x+1
oy2=oy+((my-oy-5)\15)*15
if screenw-ox-x<x2+2 then ox2=ox-x2-1
if screenh-oy-y<y2 then oy2=screenh-y2-1

get(ox2,oy2)-step(x2,y2),temp3
do
getmouse mx,my,,mb

screenlock
line (ox2+1,oy2+1)-step(x2-2,y2-2),0,bf
line (ox2,oy2)-step(x2,y2),15,b
for i=0 to ubound(menu2)
if (my-oy2-5)\15 = i then
line(ox2+1,oy2+3+((my-oy2-5)\15)*15)-step(x2-2,15),15,bf
printf ox2+5,oy2+i*15+5,menu2(i),0
else
printf ox2+5,oy2+i*15+5,menu2(i),15
end if
next
screenunlock
if mb<>0 then
if mousebox(ox2,oy2,ox2+x2,oy2+y2) then
select case (my-oy2-5)\15
case 0
menu2(0)="*320x240"
menu2(1)=" 640x480"
menu2(2)=" 800x600"
menu2(3)=" 1024x768"
'res 320, 240
'goto start
case 1
menu2(0)=" 320x240"
menu2(1)="*640x480"
menu2(2)=" 800x600"
menu2(3)=" 1024x768"
put (ox2,oy2),temp3,pset
imagedestroy temp3
res 640, 480
goto start
case 2
menu2(0)=" 320x240"
menu2(1)=" 640x480"
menu2(2)="*800x600"
menu2(3)=" 1024x768"
put (ox2,oy2),temp3,pset
imagedestroy temp3
res 800, 600
goto start
case 3
menu2(0)=" 320x240"
menu2(1)=" 640x480"
menu2(2)=" 800x600"
menu2(3)="*1024x768"
put (ox2,oy2),temp3,pset
imagedestroy temp3
res 1024, 768
goto start
case 5
if mb=1 then
bgstretch=not bgstretch
bgoff=0
if bgstretch then menu2(5)="bg stretch" else menu2(5)="bg center"
put (ox2,oy2),temp3,pset
imagedestroy temp3
res screenw, screenh
goto start
else
do
getmouse mx,my,,mb
loop until mb=0
menu2(5)="bg off"
bgoff=-1
put (ox2,oy2),temp3,pset
imagedestroy temp3
res screenw, screenh
goto start
end if
end select
end if
end if
loop while ((my-oy-5)\15 = ubound(menu1)-1 and mousebox(ox,oy,ox+x,oy+y)) or mousebox(ox2,oy2,ox2+x2,oy2+y2)
put (ox2,oy2),temp3,pset
imagedestroy temp3
end if

'
'menu selection
if mb=1 and mousebox(ox,oy,ox+x,oy+y) then
put (ox,oy),temp2,pset

select case (my-oy-5)\15
case 2

makewin mx,my,150,200,"dir",2
win(wins-1).diri=wins-1
sdir(win(wins-1).diri)="C:\"
sdirs(win(wins-1).diri)=0

mktop wins-1
screenlock
put(0,0),bg,pset
redraw
screenunlock
smalldir 0
goto start
case 3
makewin 10,10,600,400,"text",3
win(wins-1).diri=wins-1
textf(win(wins-1).diri)="readme.txt"
textx(win(wins-1).diri)=0
texty(win(wins-1).diri)=0
textc(win(wins-1).diri)=0
open textf(win(wins-1).diri) for binary as #1
textb(win(wins-1).diri)=allocate(lof(1))
get #1,,*textb(win(wins-1).diri),lof(1)
textl(win(wins-1).diri)=lof(1)
close

mktop wins-1
screenlock
put(0,0),bg,pset
redraw
screenunlock
text 0
goto start
case 4
makewin mx,my,150,175,"clock",1

mktop wins-1
screenlock
put(0,0),bg,pset
redraw
screenunlock
clock 0
goto start
case 5

makewin mx,my,200,50,"run command",5
win(wins-1).diri=wins-1
runcomx(win(wins-1).diri)=""

mktop wins-1
screenlock
put(0,0),bg,pset
redraw
screenunlock
runcom 0
goto start
case ubound(menu1)
end
case else
end select
end if
loop until mb<>0'while mousebox(ox,oy,ox+x,oy+y)

put (ox,oy),temp2,pset
imagedestroy temp2
end if

'live redrawing & application main loops
select case win(0).pid
case 1
clock 0
case 2
if mousebox(win(0).x,win(0).y+25,win(0).x+win(0).x1,win(0).y+win(0).y1) then
j=getfiles(sdir(win(0).diri),sdirf())
do while mousebox(win(0).x,win(0).y+25,win(0).x+win(0).x1,win(0).y+win(0).y1)
getmouse mx,my,,mb

if mousebox(win(0).x+win(0).x1-25,win(0).y+win(0).y1-25,win(0).x+win(0).x1,win(0).y+win(0).y1) then
if mb=1 then
if ((win(0).y1-30)\15)+sdirs(win(0).diri)<j then sdirs(win(0).diri)+=1

line win(0).iptr,(1,26)-(win(0).x1-26,win(0).y1-1),0,bf
for i=0 to (win(0).y1-30)\15-1
if i+sdirs(win(0).diri)>=j then exit for
printf 5, 30+i*15, sdirf(i+sdirs(win(0).diri)), 15, win(0).iptr
next
put(win(0).x,win(0).y),win(0).iptr,pset

elseif mb=2 then 'resize
screenlock
put(0,0),bg,pset
redraw
get(0,0)-(screenw-1,screenh-1),temp1
put(win(0).x,win(0).y),win(0).iptr,pset
screenunlock

oldy=win(0).y1-my
do
getmouse mx,my,,mb
imagedestroy win(0).iptr
if my+oldy>75 then win(0).y1=my+oldy
win(0).iptr=imagecreate(win(0).x1+1,win(0).y1+1)

screenlock
put(0,0),temp1,pset

drawin 0,0,win(0).x1,win(0).y1,sdir(win(0).diri),win(0).iptr
line win(0).iptr,(150,25)-step(-25,25),15,b
line win(0).iptr,-(150,win(0).y1-25),15,b
line win(0).iptr,-step(-25,25),15,b
for i=0 to (win(0).y1-30)\15-1
if i+sdirs(win(0).diri)>=j then exit for
printf 5, 30+i*15, sdirf(i+sdirs(win(0).diri)), 15, win(0).iptr
next
put(win(0).x,win(0).y),win(0).iptr,pset

screenunlock
loop while mb=2

end if
elseif mousebox(win(0).x+win(0).x1-25,win(0).y+25,win(0).x+win(0).x1,win(0).y+50) then
if mb=1 then

if sdirs(win(0).diri)>0 then sdirs(win(0).diri)-=1

line win(0).iptr,(1,26)-(win(0).x1-26,win(0).y1-1),0,bf
for i=0 to (win(0).y1-30)\15-1
if i+sdirs(win(0).diri)>=j then exit for
printf 5, 30+i*15, sdirf(i+sdirs(win(0).diri)), 15, win(0).iptr
next
put(win(0).x,win(0).y),win(0).iptr,pset

end if
elseif mousebox(win(0).x+25,win(0).y+25,win(0).x+win(0).x1-25,win(0).y+win(0).y1) then


if mb=1 then
do
getmouse mx,my,,mb
loop until mb=0
f = sdirs(win(0).diri)+(my-win(0).y-25)\15
if f < j then
if sdirf(f)="..\" then
if right(sdir(win(0).diri),2)<>":\" then
for i=len(sdir(win(0).diri)) to 2 step -1
if mid(sdir(win(0).diri),i-1,1)="\" then exit for
next
if multikey(&h1d) then
makewin mx,my,150,200,"dir",2
win(wins-1).diri=wins-1
sdir(win(wins-1).diri)=left(sdir(win(0).diri),i-1)
sdirs(win(wins-1).diri)=0

mktop wins-1
screenlock
put(0,0),bg,pset
redraw
smalldir 0
screenunlock
else
sdir(win(0).diri)=left(sdir(win(0).diri),i-1)
sdirs(win(0).diri)=0
smalldir 0
end if
exit select
end if
elseif right(sdirf(f),1)="\" then
if multikey(&h1d) then
makewin mx,my,150,200,"dir",2
win(wins-1).diri=wins-1
sdir(win(wins-1).diri)=sdir(win(0).diri) + sdirf(f)
sdirs(win(wins-1).diri)=0

mktop wins-1
screenlock
put(0,0),bg,pset
redraw
smalldir 0
screenunlock
else
sdir(win(0).diri) += sdirf(f)
sdirs(win(0).diri)=0
smalldir 0
end if
exit select
elseif ucase(right(sdirf(f),4))=".BAS" or ucase(right(sdirf(f),4))=".TXT" then


makewin mx,my,200,200,"text",3
win(wins-1).diri=wins-1
textf(win(wins-1).diri)=sdir(win(0).diri)+sdirf(f)
textx(win(wins-1).diri)=0
texty(win(wins-1).diri)=0
textc(win(wins-1).diri)=0
open textf(win(wins-1).diri) for binary as #1
textb(win(wins-1).diri)=allocate(lof(1))
get #1,,*textb(win(wins-1).diri),lof(1)
textl(win(wins-1).diri)=lof(1)
close

mktop wins-1
screenlock
put(0,0),bg,pset
redraw
text 0
screenunlock
elseif ucase(right(sdirf(f),4))=".BMP" then
open sdir(win(0).diri)+sdirf(f) for binary as #1
get #1,,s
if s="BM" then

get #1,19,bx
get #1,23,by

makewin mx,my,bx+2,by+27,"bmpload",4
win(wins-1).diri=wins-1
bmpf(wins-1)=sdir(win(0).diri)+sdirf(f)
end if
close
mktop wins-1
screenlock
put(0,0),bg,pset
redraw
loadbmp 0
screenunlock

end if
end if

else
line win(0).iptr,(1,26)-(win(0).x1-26,win(0).y1-1),0,bf
for i=0 to (win(0).y1-30)\15-1
if i+sdirs(win(0).diri)>=j then exit for
if i=(my-win(0).y-25)\15 then
line win(0).iptr,(0,26+i*15)-step(win(0).x1-25,15),15,bf
printf 5, 30+i*15, sdirf(i+sdirs(win(0).diri)), 0, win(0).iptr
else
printf 5, 30+i*15, sdirf(i+sdirs(win(0).diri)), 15, win(0).iptr
end if
next
put(win(0).x,win(0).y),win(0).iptr,pset

end if
else
'this may not be required, but removes the presisting white selection
line win(0).iptr,(1,26)-(win(0).x1-26,win(0).y1-1),0,bf
for i=0 to (win(0).y1-30)\15-1
if i+sdirs(win(0).diri)>=j then exit for
printf 5, 30+i*15, sdirf(i+sdirs(win(0).diri)), 15, win(0).iptr
next
put(win(0).x,win(0).y),win(0).iptr,pset

end if
loop
end if
case 3
do while mousebox(win(0).x,win(0).y+25,win(0).x+win(0).x1,win(0).y+win(0).y1)
getmouse mx,my,,mb

if multikey(&h1f) and multikey(&h1d) then
open textf(win(0).diri) for binary as #1
put #1,,textb(win(0).diri)[0],textl(win(0).diri)
close
locate 1,1:? "SAVED"
end if

key=inkey
if key<>"" then

select case key
case chr(255)+"M"
if textc(win(0).diri)<textl(win(0).diri)-2 then
textc(win(0).diri)+=1
if *(textb(win(0).diri)+textc(win(0).diri))=10 then textc(win(0).diri)+=1
text 0
end if
case chr(255)+"K"
if textc(win(0).diri)>0 then
textc(win(0).diri)-=1
if *(textb(win(0).diri)+textc(win(0).diri))=10 then textc(win(0).diri)-=1
text 0
end if
case chr(255)+"P"
i=0
do
i+=1
loop until *(textb(win(0).diri)+textc(win(0).diri)+i)=10
if textc(win(0).diri)+i>=textl(win(0).diri)-1 then exit select
j=0
do
j+=1
loop until *(textb(win(0).diri)+textc(win(0).diri)-j)=10
j-=1
for k=0 to j
if *(textb(win(0).diri)+textc(win(0).diri)+i+k+1)=10 then
j=k-1
exit for
end if
next

textc(win(0).diri)+=i+j+1
text 0
case chr(255)+"H"
i=0
do
i+=1
if textc(win(0).diri)-i<=0 then exit select
loop until *(textb(win(0).diri)+textc(win(0).diri)-i)=10
j=0
do
j+=1
if textc(win(0).diri)-i-j+1<=0 then exit do
loop until *(textb(win(0).diri)+textc(win(0).diri)-i-j)=10
if j>i then j-=i+1 else j=0

textc(win(0).diri)-=i+j+1
text 0

case chr(8)
if textc(win(0).diri)>0 then
textb(win(0).diri)=reallocate(textb(win(0).diri),textl(win(0).diri)-1)
memcopy textb(win(0).diri)+textc(win(0).diri),textb(win(0).diri)+textc(win(0).diri)-1,textl(win(0).diri)-textc(win(0).diri),-1

textc(win(0).diri)-=1
textl(win(0).diri)-=1

text 0

end if

case chr(13)
textb(win(0).diri)=reallocate(textb(win(0).diri),textl(win(0).diri)+1)

memcopy textb(win(0).diri)+textl(win(0).diri),textb(win(0).diri)+textl(win(0).diri)+1,textl(win(0).diri)-textc(win(0).diri)+1,0

*(textb(win(0).diri)+textc(win(0).diri))=10
textl(win(0).diri)+=1
textc(win(0).diri)+=1

text 0
case chr(32) to chr(128)
textb(win(0).diri)=reallocate(textb(win(0).diri),textl(win(0).diri)+1)

memcopy textb(win(0).diri)+textl(win(0).diri),textb(win(0).diri)+textl(win(0).diri)+1,textl(win(0).diri)-textc(win(0).diri)+1,0

*(textb(win(0).diri)+textc(win(0).diri))=asc(key)
textl(win(0).diri)+=1
textc(win(0).diri)+=1

text 0
end select
end if


if mousebox(win(0).x+win(0).x1-25,win(0).y+win(0).y1-25,win(0).x+win(0).x1,win(0).y+win(0).y1) then
if mb=1 then

screenlock
put(0,0),bg,pset
redraw
get(0,0)-(screenw-1,screenh-1),temp1
put(win(0).x,win(0).y),win(0).iptr,pset
screenunlock

oldx=win(0).x1-mx
oldy=win(0).y1-my
do
getmouse mx,my,,mb

if mx+oldx>100 then win(0).x1=mx+oldx
if my+oldy>100 then win(0).y1=my+oldy
imagedestroy win(0).iptr
win(0).iptr=imagecreate(win(0).x1+1,win(0).y1+1)
screenlock
put(0,0),temp1,pset
text 0
'drawin win(0).x,win(0).y,win(0).x1,win(0).y1,"Test"
screenunlock

loop while mb=1

end if
elseif mousebox(win(0).x+win(0).x1-25,win(0).y+25,win(0).x+win(0).x1,win(0).y+50) then
if mb=1 then
if texty(win(0).diri) > 0 then
texty(win(0).diri)-=1
text 0
end if
end if
elseif mousebox(win(0).x+win(0).x1-25,win(0).y+win(0).y1-50,win(0).x+win(0).x1,win(0).y+win(0).y1-25) then
if mb=1 then
texty(win(0).diri)+=1
text 0
end if
elseif mousebox(win(0).x,win(0).y+win(0).y1-25,win(0).x+25,win(0).y+win(0).y1) then
if mb=1 then
if textx(win(0).diri) > 0 then
textx(win(0).diri)-=1
text 0
end if
end if
elseif mousebox(win(0).x+win(0).x1-50,win(0).y+win(0).y1-25,win(0).x+win(0).x1-25,win(0).y+win(0).y1) then
if mb=1 then
textx(win(0).diri)+=1
text 0
end if
end if
loop
case 4
do while mousebox(win(0).x,win(0).y+26,win(0).x+win(0).x1,win(0).y+win(0).y1)
getmouse mx,my,,mb
if mb=1 then
screenlock
put(0,0),bg,pset
redraw
get(0,0)-(screenw-1,screenh-1),temp1
put(win(0).x,win(0).y),win(0).iptr,pset
screenunlock

oldx=win(0).x1-mx
oldy=win(0).y1-my
do
getmouse mx,my,,mb

if mx+oldx>100 then win(0).x1=mx+oldx
if my+oldy>100 then win(0).y1=my+oldy

imagedestroy win(0).iptr
win(0).iptr=imagecreate(win(0).x1+1,win(0).y1+1)

screenlock
put(0,0),temp1,pset
resize win(0).x1-2,win(0).y1-27,lbmp(win(0).diri).iptr
drawin 0,0,win(0).x1,win(0).y1,bmpf(win(0).diri)+" "+str(win(0).x1-2)+"x"+str(win(0).y1-27),win(0).iptr
put win(0).iptr,(1,26),lbmp(win(0).diri).iptr,pset
put (win(0).x,win(0).y),win(0).iptr,pset
screenunlock
loop while mb=1
elseif mb=2 then
open bmpf(win(0).diri) for binary as #1
get #1,,s
if s="BM" then
get #1,19,bx
get #1,23,by

win(0).x1=bx+2
win(0).y1=by+27

imagedestroy win(0).iptr
win(0).iptr=imagecreate(win(0).x1+1,win(0).y1+1)

screenlock
put(0,0),bg,pset
redraw
loadbmp 0
screenunlock

end if
close

end if

loop
case 5

'do while mousebox(win(0).x,win(0).y+25,win(0).x+win(0).x1,win(0).y+win(0).y1)
getmouse mx,my,,mb


key=inkey
if key<>"" then
select case key
case chr(13)
dim as string exe,args
runcomx(win(0).diri)=runcomx(win(0).diri)+chr(32)
exe= mid(runcomx(win(0).diri),1,instr(runcomx(win(0).diri),chr(32)))
args=right(runcomx(win(0).diri),len(runcomx(win(0).diri))-instr(runcomx(win(0).diri),chr(32)))
x=exec(exe,args)
res screenw,screenh
case chr(8)
if len(runcomx(win(0).diri))>=1 then
runcomx(win(0).diri)=left(runcomx(win(0).diri),len(runcomx(win(0).diri))-1)
runcom 0
end if
case chr(32) to chr(128)
runcomx(win(0).diri)=runcomx(win(0).diri)+key
runcom 0
end select
end if
'loop

case else
end select
loop until inp(&h60)=1
end

sub printf(x, y, s as string, c as ubyte)
dim sptr as ubyte ptr = sadd(s)
dim vptr as ubyte ptr = screenptr
'dim w as integer
'screeninfo w

o=y*screenw+x
l=((len(s)) shl 3)-1
j=0
for y1=0 to 10
i=0
for x1=0 to l
if font(11*(*(sptr+(x1 shr 3))-32)+y1) and (1 shl (7-(x1 and 7))) then *(vptr+o+j+i)=c
i+=1
next
j+=screenw
next
end sub

sub printf(x, y, s as string, c as ubyte, buffer as any ptr)
dim sptr as ubyte ptr = sadd(s)
dim vptr as ubyte ptr = buffer
dim w as integer
if imageinfo(buffer, w) then exit sub

o=y*w+x
l=((len(s)) shl 3)-1
j=0
for y1=0 to 10
i=0
for x1=0 to l
if font(11*(*(sptr+(x1 shr 3))-32)+y1) and (1 shl (7-(x1 and 7))) then *(vptr+o+j+i)=c
i+=1
next
j+=w
next
end sub

function getfiles(path as string, f() as string)
dim s as string = dir(path+"*.*", &h10)
for i=0 to ubound(f)
s=dir()
if s="" then exit for
f(i)=s+"\"
next

s = dir(path+"*.*", not &h10)
for i=i to ubound(f)
if s="" then exit for
f(i)=s
s=dir()
next

getfiles = i
end function

function mousebox(x, y, x1, y1)
if mx>=x then if mx<=x1 then if my>=y then if my<=y1 then mousebox=-1
end function

sub makewin(x, y, x1, y1, cap as string, pid)
win(wins).x=x
win(wins).y=y
win(wins).x1=x1
win(wins).y1=y1
win(wins).cap=cap
win(wins).pid=pid
win(wins).iptr=imagecreate(x1+1, y1+1)

wins=wins+1
end sub

sub mktop(id)
dim temp as wintype = win(id)
for i=id-1 to 0 step -1
win(i+1)=win(i)
next
win(0)=temp
end sub

sub closewin(id)
imagedestroy win(id).iptr
for i=id to wins
win(i)=win(i+1)
next

if win(id).pid=3 then
deallocate textb(win(id).diri)
end if
wins=wins-1
end sub

sub drawin(x, y, x1, y1, cap as string)
line(x,y)-step(x1,y1),0,bf
line(x,y)-step(x1,y1),15,b
line(x,y)-step(x1,25),15,b

if (len(cap)*8)>(x1-10) then printf x+5,y+8,left(cap, (x1-10) shr 3),15 else printf x+5,y+8,cap,15
end sub

sub drawin (x, y, x1, y1, cap as string, buffer as any ptr)
line buffer,(x,y)-step(x1,y1),0,bf
line buffer,(x,y)-step(x1,y1),15,b
line buffer,(x,y)-step(x1,25),15,b

if (len(cap)*8)>(x1-10) then printf x+5,x+8,left(cap, (x1-10) shr 3),15,buffer else printf x+5,y+8,cap,15,buffer
end sub

sub redraw()
for i=wins-1 to 1 step -1
'drawin win(i).x,win(i).y,win(i).x1,win(i).y1,win(i).cap
put(win(i).x,win(i).y),win(i).iptr,pset
next
end sub

sub clock(id)
drawin 0,0,win(id).x1,win(id).y1,time,win(id).iptr

dim pi as single =3.1415926*2
circle win(id).iptr,(75,100),70,15

dim i as single
j=0
for i=0 to pi step pi/60
if j mod 5 = 0 then r=58 else r=62
j=j+1
line win(id).iptr,(65*cos(i)+75,65*sin(i)+100)-(r*cos(i)+75,r*sin(i)+100),15
next

sec=val(right(time,2))
min=val(mid(time,4,2))
hou=val(left(time,2))
line win(id).iptr,(75,100)-(70*cos(sec*pi/60-pi/4)+75,70*sin(sec*pi/60-pi/4)+100),15,,&h5555
line win(id).iptr,(75,100)-(64*cos(min*pi/60-pi/4)+75,64*sin(min*pi/60-pi/4)+100),15
hou=5*hou+(5*min)/60
line win(id).iptr,(75,100)-(20*cos(hou*pi/60-pi/4)+75,20*sin(hou*pi/60-pi/4)+100),15
put(win(id).x,win(id).y),win(id).iptr,pset
end sub

sub smalldir(id)
drawin 0,0,win(id).x1,win(id).y1,sdir(win(id).diri),win(id).iptr
line win(id).iptr,(150,25)-step(-25,25),15,b
line win(id).iptr,-(150,win(id).y1-25),15,b
line win(id).iptr,-step(-25,25),15,b

j=getfiles(sdir(win(id).diri),sdirf())

for i=0 to (win(id).y1-30)\15-1
if i+sdirs(win(id).diri)>=j then exit for
printf 5, 30+i*15, sdirf(i+sdirs(win(id).diri)), 15, win(id).iptr
next

put(win(id).x,win(id).y),win(id).iptr,pset
end sub

sub text(id)
drawin 0,0,win(id).x1,win(id).y1,textf(win(id).diri),win(id).iptr
line win(id).iptr,(win(id).x1-25,25)-step(25,25),15,b
line win(id).iptr,-step(-25,win(id).y1-100),15,b
line win(id).iptr,-step(25,25),15,b
line win(id).iptr,-step(-25,25),15,b
line win(id).iptr,-step(-25,-25),15,b
line win(id).iptr,-(25,win(id).y1-25),15,b
line win(id).iptr,-step(-25,25),15,b

x=0
y=0
xx=textx(win(id).diri)
yy=texty(win(id).diri)
for i=0 to textl(win(id).diri)-2
if y>=yy then exit for
if (*(textb(win(id).diri)+i))=10 then y=y+1
next
y=0
for i=i to textl(win(id).diri)-2
if y>(win(id).y1-55)\15-1 then exit for
if i=textc(win(id).diri) and x<(win(id).x1-30)\8 then line win(id).iptr,(x*8+4,y*15+30)-step(5,15),15,b
if (*(textb(win(id).diri)+i))=10 then
x=0
y=y+1
else
if x<(win(id).x1-30)\8 then
if *(textb(win(id).diri)+i)>=32 and *(textb(win(id).diri)+i)<=128 then
'draw string win(id).iptr,(5+x*8,30+y*15),chr(*(textb(win(id).diri)+i)),15
printf x*8+5,y*15+30,chr(*(textb(win(id).diri)+i)),15,win(id).iptr
end if

end if
x=x+1
end if

next

'if texty(win(id).diri)>y then texty(win(id).diri)=y

put(win(id).x,win(id).y),win(id).iptr,pset
end sub

sub loadbmp(id)
w=win(id).x1-2
h=win(id).y1-27

lbmp(win(id).diri).iptr=imagecreate(w,h)
bload bmpf(win(id).diri),lbmp(win(id).diri).iptr
palette 0, &h000000
palette 15, &hffffff

drawin 0,0,win(id).x1,win(id).y1,bmpf(win(id).diri)+" "+str(w)+"x"+str(h),win(id).iptr
put win(id).iptr,(1,26),lbmp(win(id).diri).iptr,pset
put(win(id).x,win(id).y),win(id).iptr,pset

end sub

sub res (x, y)
screenres x, y, 8
screeninfo screenw,screenh
imagedestroy temp1
temp1 = imagecreate(screenw,screenh)
imagedestroy bg
bg = imagecreate(screenw,screenh,0)

if not bgoff then
open "bg.bmp" for binary as #1
get #1,,s
if s="BM" then
get #1,19,bx
get #1,23,by
temp4=imagecreate(bx,by)
bload "bg.bmp",temp4
if bgstretch then
resize screenw,screenh,temp4
imagedestroy bg
bg = temp4
else
put bg,((screenw-bx)\2,(screenh-by)\2),temp4
imagedestroy temp4
end if
end if
close
end if

palette 0, &h000000
palette 15, &hffffff
put(0,0),bg
redraw
put(win(0).x,win(0).y),win(0).iptr,pset
end sub

sub resize (x, y, buffer as any ptr)
dim as integer w,h,k,l
dim as single p,q
dim as ubyte ptr addr1,addr2

temp2=imagecreate(x,y)
if imageinfo(temp2,,,,,addr2) then exit sub
if imageinfo(buffer,w,h,,,addr1) then exit sub

p=w/x
q=h/y
k=0
for j=0 to y-1
k=w*cint(j*q)
for i=0 to x-1
*(addr2+l+i)=*(addr1+k+cint(i*p))
next
l=l+x
next

imagedestroy buffer
buffer=temp2
end sub

sub memcopy (byval src as any ptr, byval dest as any ptr, byval n as uinteger, byval d as uinteger)
asm
mov esi,[src]
mov edi,[dest]

cmp dword ptr [d],0
je here

cld
mov eax,[n]
mov ecx,eax
shr ecx,2
rep movsd
and eax,3
mov ecx,eax
rep movsb
jmp there

here:
std
mov ecx,[n]
rep movsb

there:
end asm
end sub

sub runcom (id)
drawin 0,0,win(id).x1,win(id).y1,win(id).cap,win(id).iptr

if len(runcomx(win(id).diri))>23 then
printf 5,35,right(runcomx(win(id).diri),23),15,win(id).iptr
line win(id).iptr,(5+23*8,30)-step(5,15),15,b

else
printf 5,35,runcomx(win(id).diri),15,win(id).iptr
line win(id).iptr,(5+len(runcomx(win(id).diri))*8,30)-step(5,15),15,b

end if
put (win(id).x,win(id).y),win(id).iptr,pset
end sub

Posted on Dec 26, 2011, 11:31 PM

Respond to this message   

Return to Index


*I watched the video -- seems to work extremely well. Nice job.

by (Login qb432l)
R

*

Posted on Dec 27, 2011, 12:44 PM

Respond to this message   

Return to Index


*cool.

by (Login MCalkins)
Moderator

Posted on Dec 27, 2011, 1:13 PM

Respond to this message   

Return to Index


major problems printing please help

by (no login)

Pleeease help. I am writing a program that needs to send random access data to a printer. All works well for the first page of the printing, and then for some reason it prints the menu screen as well and not the rest of the data. When I run the program it will only print the first 16 entries and not go onto page 2 for the rest. As you can see am am new to programming but trying my best. I have added the part of the program that I am using for the printing.

1100 REM view outstanding books per grade
CLS
1111 LOCATE 1, 20: LPRINT "Textbook tracking program version 2"
LOCATE 1, 20: PRINT "Textbook tracking program version 2"
LOCATE 3, 20: LPRINT "VIEW OUTSTANDING BOOKS PER GRADE"
LOCATE 3, 20: PRINT "VIEW OUTSTANDING BOOKS PER GRADE"
LOCATE 4, 10: INPUT "Enter grade:"; dw
LOCATE 4, 10: LPRINT Grade, dw
GOSUB 250 ' thisi s to check if the file exists
LET ak = 1
1116 GET #1, ak
LET al = CVS(e$)
IF al = dw THEN GOTO 1130
LET ak = ak + 1
IF ak = 10 THEN CLOSE: CLS: LOCATE 20, 20: PRINT " Booklist for this grade does not exist": INPUT dx: GOTO 100
GOTO 1116
INPUT "prblem"; ss

1130 LPRINT: LPRINT "Book title:", f$: LPRINT
LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
1135 GET #2, ck
IF CVS(an$) = 0 GOTO 1140
IF CVS(at$) = 0 GOTO 1134
IF CVS(ao$) = dw THEN LPRINT CVS(at$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 1140
1134 LET ck = ck + 1
GOTO 1135

1140 LPRINT: LPRINT "Book title:", g$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
1145 GET #2, ck
IF CVS(an$) = 0 GOTO 1150
IF CVS(au$) = 0 GOTO 1144
IF CVS(ao$) = dw THEN LPRINT CVS(au$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 1150
1144 LET ck = ck + 1
GOTO 1145

1150 LPRINT: LPRINT "Book title:", h$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
1155 GET #2, ck
IF CVS(an$) = 0 GOTO 1160
IF CVS(av$) = 0 GOTO 1154
IF CVS(ao$) = dw THEN LPRINT CVS(av$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 1160
1154 LET ck = ck + 1
GOTO 1155

1160 LPRINT: LPRINT "Book title:", i$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
1165 GET #2, ck
IF CVS(an$) = 0 GOTO 1170
IF CVS(aw$) = 0 GOTO 1164
IF CVS(ao$) = dw THEN LPRINT CVS(aw$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 1170
1164 LET ck = ck + 1
GOTO 1165

1170 LPRINT: LPRINT "Book title:", j$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
1175 GET #2, ck
IF CVS(an$) = 0 GOTO 1180
IF CVS(ax$) = 0 GOTO 1174
IF CVS(ao$) = dw THEN LPRINT CVS(ax$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 1180
1174 LET ck = ck + 1
GOTO 1175

1180 LPRINT: LPRINT "Book title:", k$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
1185 GET #2, ck
IF CVS(an$) = 0 GOTO 1190
IF CVS(ay$) = 0 GOTO 1184
IF CVS(ao$) = dw THEN LPRINT CVS(ay$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 1190
1184 LET ck = ck + 1
GOTO 1185

1190 LPRINT: LPRINT "Book title:", l$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
1195 GET #2, ck
IF CVS(an$) = 0 GOTO 2000
IF CVS(az$) = 0 GOTO 1194
IF CVS(ao$) = dw THEN LPRINT CVS(az$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2000
1194 LET ck = ck + 1
GOTO 1195

2000 LPRINT: LPRINT "Book title:", m$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2005 GET #2, ck
IF CVS(an$) = 0 GOTO 2010
IF CVS(ba$) = 0 GOTO 2004
IF CVS(ao$) = dw THEN LPRINT CVS(ba$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2010
2004 LET ck = ck + 1
GOTO 2005

2010 LPRINT: LPRINT "Book title:", n$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2015 GET #2, ck
IF CVS(an$) = 0 GOTO 2020
IF CVS(bb$) = 0 GOTO 2014
IF CVS(ao$) = dw THEN LPRINT CVS(bb$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2020
2014 LET ck = ck + 1
GOTO 2015

2020 LPRINT: LPRINT "Book title:", o$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2025 GET #2, ck
IF CVS(an$) = 0 GOTO 2030
IF CVS(bc$) = 0 GOTO 2024
IF CVS(ao$) = dw THEN LPRINT CVS(bc$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2030
2024 LET ck = ck + 1
GOTO 2025

2030 LPRINT: LPRINT "Book title:", p$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2035 GET #2, ck
IF CVS(an$) = 0 GOTO 2040
IF CVS(bd$) = 0 GOTO 2034
IF CVS(ao$) = dw THEN LPRINT CVS(bd$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2040
2034 LET ck = ck + 1
GOTO 2035

2040 LPRINT: LPRINT "Book title:", q$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2045 GET #2, ck
IF CVS(an$) = 0 GOTO 2050
IF CVS(be$) = 0 GOTO 2044
IF CVS(ao$) = dw THEN LPRINT CVS(be$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2050
2044 LET ck = ck + 1
GOTO 2045

2050 LPRINT: LPRINT "Book title:", r$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2055 GET #2, ck
IF CVS(an$) = 0 GOTO 2060
IF CVS(bf$) = 0 GOTO 2054
IF CVS(ao$) = dw THEN LPRINT CVS(bf$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2060
2054 LET ck = ck + 1
GOTO 2055

2060 LPRINT: LPRINT "Book title:", s$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2065 GET #2, ck
IF CVS(an$) = 0 GOTO 2070
IF CVS(bg$) = 0 GOTO 2064
IF CVS(ao$) = dw THEN LPRINT CVS(bg$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2070
2064 LET ck = ck + 1
GOTO 2065

2070 LPRINT: LPRINT "Book title:", t$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2075 GET #2, ck
IF CVS(an$) = 0 GOTO 2080
IF CVS(bh$) = 0 GOTO 2074
IF CVS(ao$) = dw THEN LPRINT CVS(bh$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2080
2074 LET ck = ck + 1
GOTO 2075

2080 LPRINT: LPRINT "Book title:", u$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2085 GET #2, ck
IF CVS(an$) = 0 GOTO 2090
IF CVS(bi$) = 0 GOTO 2084
IF CVS(ao$) = dw THEN LPRINT CVS(bi$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2090
2084 LET ck = ck + 1
GOTO 2085

2090 LPRINT: LPRINT "Book title:", v$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2095 GET #2, ck
IF CVS(an$) = 0 GOTO 2100
IF CVS(bj$) = 0 GOTO 2094
IF CVS(ao$) = dw THEN LPRINT CVS(bj$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2100
2094 LET ck = ck + 1
GOTO 2095

2100 LPRINT: LPRINT "Book title:", w$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2115 GET #2, ck
IF CVS(an$) = 0 GOTO 2110
IF CVS(bk$) = 0 GOTO 2114
IF CVS(ao$) = dw THEN LPRINT CVS(bk$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2110
2114 LET ck = ck + 1
GOTO 2115

2110 LPRINT: LPRINT "Book title:", x$: LPRINT: LPRINT "book no: Gr: Stud.no: Surname:"
GOSUB 50
LET ck = 1
2125 GET #2, ck
IF CVS(an$) = 0 THEN CLEAR: GOTO 2120
IF CVS(bl$) = 0 GOTO 2124
IF CVS(ao$) = dw THEN LPRINT CVS(bl$), ap$; CVS(an$), aq$
IF CVS(an$) = 1 GOTO 2120
2124 LET ck = ck + 1
GOTO 2125

2120 LOCATE 20, 5: CLS: CLEAR: CLOSE: INPUT "Printing complete press 'enter' to continue"; op
CLOSE
GOTO 100

Posted on Dec 24, 2011, 11:00 PM

Respond to this message   

Return to Index


More info required

by Galleon (no login)

-QBASIC or QB64?
-What kind of printer?
-Is this a page-break included by you or that you expect to be done automatically by the printer?

Posted on Dec 25, 2011, 2:24 AM

Respond to this message   

Return to Index


Merry Christmas Galleon

by (no login)

Merry Christmas, Galleon.

Posted on Dec 25, 2011, 2:20 PM

Respond to this message   

Return to Index


Christmas Q&A

by Galleon (no login)

Q: Where is Pete?
A:

Posted on Dec 24, 2011, 3:11 PM

Respond to this message   

Return to Index


A: Being a father and coach, I expect...

by (Login qb432l)
R

Pete announced a couple years ago that he was leaving the forum to do other things, but it took him quite awhile to go. Being forum owner has certain responsibilities, and I think he wanted to be sure that moderators such as Solitaire and Michael Calkins had things under control.

It's understandable, given that the old forum ain't what it used to be -- sometimes with only one post every several days. In any case I'm sure we all miss his presence on a regular basis. I know I do. The only reason I still drop by every day is that unlike Pete, I don't have a life (well, a wife and son, anyway).

Merry Christmas Galleon, and everyone else, too!

-Bob

Posted on Dec 24, 2011, 3:39 PM

Respond to this message   

Return to Index


Merry Christmas Bob!

by Galleon (no login)

I know Pete always talked about leaving us but I never thought he'd actually get around to doing it. It saddens me to see the lack of activity round here too and I'm not really comfortable with any role QB64 may have played in this. It's a big responsibility to be the only language carrying the baton for QBASIC into the future. Pete saw potential in what I was doing and I had dreams, neither of us predicted how long it would take to fully realize those dreams which I'm only beginning to reach.

Merry Christmas

RE: 'The only reason I still drop by every day is that unlike Pete, I don't have a life'
Speaking of wasting time, what are you carving atm? I'm a big fan of your works, especially the sowing machine.

Posted on Dec 25, 2011, 2:16 AM

Respond to this message   

Return to Index


*Thanks -- not carving so much these days as recording music, but I'll get back to it :-)

by (Login qb432l)
R

*

Posted on Dec 25, 2011, 6:53 PM

Respond to this message   

Return to Index


Windows XP

by (no login)

To add to a recent thread, in my business (government) they run XP. They don't use Windows 7, they don't need it and they don't want it. Same for 64b, they don't care, and so i, and any sane person. 64b is only form the commercial sector, but the business don't give a ***. For running office it's still fast enough.

And if you see the tests, 64b is only slightly faster than 32b and it's not worth ! not worth the hassle of incompatibility etc. Anything after XP is just *insane*.

Posted on Dec 20, 2011, 10:26 AM

Respond to this message   

Return to Index


* Yeah, but they are gonna sell it anyhow!

by (Login burger2227)
R

Posted on Dec 20, 2011, 10:32 AM

Respond to this message   

Return to Index


wow look at this

by Ben (no login)



SCREEN _NEWIMAGE(640, 480, 32)

x = -1
y = -1
z = 1
z1 = 5
'x1 = 101
DO

IF y1 < -150 OR y1 > 250 THEN y = y * -1
IF z1 > 130 OR z1 < 4 THEN z = z * -1
IF x1 > 100 OR x1 < -100 THEN x = x * -1
CLS
x1 = x1 + x
y1 = y1 + y
z1 = z1 + z
s x1, y1, z1
_DISPLAY
_LIMIT 80

LOOP UNTIL INP(&H60) = 1


SUB s (x1, y1, z1)
d = 250
FOR j = -100 TO 100 STEP 3
jj = SQR(10000 - j * j)
FOR i = 0 TO 2 * 3.14159 STEP .1
x = COS(i) * (jj)
y = 100 + j + y1
z = SIN(i) * (jj) + z1
LINE (ox * d \ (oz + 200) + 320 + x1, oy * d \ (oz + 200))-(x * d \ (z + 200) + 320 + x1, y * d \ (z + 200)), _RGB(z + 100, 0, 0)
ox = x
oy = y
oz = z
NEXT
NEXT
END SUB

Posted on Dec 18, 2011, 6:51 PM

Respond to this message   

Return to Index


*Pretty neat! If you inverted it, it would look like a balloon on a string.

by (Login qb432l)
R

*

Posted on Dec 18, 2011, 7:20 PM

Respond to this message   

Return to Index


Qbasic image

by (no login)

I'm wondering how the following boot screen was made:

http://pic5.picturetrail.com/VOL99/1958090/3783588/79272278.jpg

This image is a screencapture of an old 8088 PC, which used this image after de computer booted.
It was not on the ROM, but somehow it was presented just before the c:\> came up.

I've tried to solve the question myself, but until now I did not find anything satisfactioning.

So: I suppose it is a Q-basic made image; and I'm wondering how to get it back onto my IBM 8088 (with HDD)during it's startup? oh btw: the IBM doesn't have a VGA screen: it has a Hercules Plus-monochrome adapter.

Posted on Dec 16, 2011, 1:11 PM

Respond to this message   

Return to Index


Re: Qbasic image

by (Login MCalkins)
Moderator

QBASIC has a screen mode for Hercules, but it requires that you load the MSHERC terminate and stay resident program before you use SCREEN 3. I would say load MSHERC before starting QBASIC, otherwise, you might fragment your conventional memory.

You can put commands to run MSHERC and QBASIC in your autoexec.bat file to start them automatically at boot. You can use QBASIC with the /run switch, and terminate the program with SYSTEM (instead of END).

Does this answer your question? Are you a QBASIC programmer? (based on the wording of your post, I'm not sure.)

To draw an image in QBASIC, you would set the screen mode with the SCREEN statement. The hercules mode is 3. It is a 720x348 monochrome graphics mode. You can then use statements like LINE, CIRCLE, and PSET to draw the image. LINE can draw lines and rectangles. CIRCLE can draw circles, ellipses, and arcs. PSET draws individual pixels.

In QBASIC, you can get to the help system by pressing SHIFT+F1.

Regards,
Michael

Posted on Dec 16, 2011, 6:28 PM

Respond to this message   

Return to Index


Re: Qbasic image

by Michiel van Ginkel (no login)

thanks for the reply!
I'm not so familiar with qbasic, but I'm busy learning it :)

Posted on Dec 17, 2011, 1:02 AM

Respond to this message   

Return to Index


Re: Qbasic image

by (no login)

Well, again a message:
I want to thank you Michael, because your hint was the right one!
I've made the bootscreen and it works perfectly. Somehow I've made a mistake in the transcription of the 'coordinates' of the image, so it turned out to be quite small. But nonetheless it looks precisely as it ought to :)

https://fbcdn-sphotos-a.akamaihd.net/hphotos-ak-ash4/384128_2894153241714_1496796373_2989349_139159483_n.jpg

Michiel

Posted on Dec 17, 2011, 12:43 PM

Respond to this message   

Return to Index


*Nice job, Michiel!

by (Login qb432l)
R

*

Posted on Dec 17, 2011, 7:53 PM

Respond to this message   

Return to Index


*yw, and I'm glad it worked.

by (Login MCalkins)
Moderator

Posted on Dec 18, 2011, 4:38 AM

Respond to this message   

Return to Index


&H not working as expected.

by (no login)

When assigning a Long Int variable using hex representations of numbers, it seems to treat some lower range numbers as negatives errantly.

For example:

x& = &H8080
PRINT x&

results in -32640, instead of +32896

It appears that if the number is in the range of Int (2 byte variable), it will treat it as an Int even though the variable it is assigned to is a Long (4 byte).

Am I doing something wrong (I can't even find "&H" documented in the help files)?
Is this a glitch in Qbasic?
Has anyone else encountered this?
Can I trust that adding "&" after the hex number will always fix the problem?

Posted on Dec 13, 2011, 8:00 PM

Respond to this message   

Return to Index


Yes, adding & after the number will work...

by (Login qb432l)
R

...because you're telling QBasic to treat the hex number as a long integer. This is a problem in other contexts as well, for example:

x& = 32000 * 2
print x&

This will result in an overflow error, unless you use 32000 * 2&

-Bob

Posted on Dec 13, 2011, 8:38 PM

Respond to this message   

Return to Index


* Ok, thanks a lot

by loudhvx (no login)

Posted on Dec 14, 2011, 1:39 AM

Respond to this message   

Return to Index


The & suffix after the number makes it a LONG value

by (Login burger2227)
R

Thus when the suffix is added, the value is within the positive range of a LONG value. When the suffix is removed it becomes a negative Integer value.

A hexadecimal Integer value consists of 2 bytes with every 2 hex digits designating a byte. When the highest bit is set the values will turn negative. So &H8080 is a negative value.

A hexadecimal LONG value consists of 4 bytes with every 2 hex digits designating a byte. When the highest bit is set, the number will turn negative so &H80808080& will also be negative.

This is normal. You cannot fix it because negative values need to be available too.



Posted on Dec 13, 2011, 8:45 PM

Respond to this message   

Return to Index


More math than anything

by cantide5ga (no login)

Okay folks, my brain is fried on this one:

On a 2D field exclusively located in the fourth quadrant of a graph, a sprite wants to move to a given location and reflect the direction in its rotation to correctly face its destination. The destination and the path to get there can be gathered by finding the slope. How then would I find the degrees to orientate the sprite to face its direction?

I generally prototype my work in QB to satisfy my nostalgia, despite this being for another language. I have a feeling there is something simple I am missing here and am prepared to bash my head on the keyboard.

Posted on Dec 11, 2011, 7:02 PM

Respond to this message   

Return to Index


do you have any code of your attempt?

by Gayboy (no login)

something like this where the red line would be top to bottom of the sprite a is the perpendicular angle from slope. (this is from qb64, x,y is location of sprite, and mosuex,nseysfgd )

a = ATN(-1 / ((_MOUSEY - y) / (_MOUSEX - x)))

LINE (x - 50 * COS(a), y - 50 * SIN(a))-(x + 50 * COS(a), y + 50 * SIN(a)), 12

Posted on Dec 11, 2011, 9:08 PM

Respond to this message   

Return to Index


Click and drag program not working

by (no login)

I made a program with a box which you can drag around the screen. However, everytime I click the box, it jumps to a new location on the screen.


Here is my source code :



hdscreen = _NEWIMAGE(1920, 1080, 32)
xcor = 0
ycor = 0
SCREEN hdscreen
DIM mousex(100000)
DIM mousey(100000)
r = 24
g = 230
b = 32
DO

CLS
wheel = 0

LINE (100 + xcor, 100 + ycor)-(800 + xcor, 800 + ycor), _RGB(r, g, b), BF

DO WHILE _MOUSEINPUT
mousex(x) = _MOUSEX
mousey(y) = _MOUSEY
left = _MOUSEBUTTON(1) * -1
right = _MOUSEBUTTON(2) * -1
middle = _MOUSEBUTTON(3) * -1
wheel = wheel + _MOUSEWHEEL
LOOP
IF _MOUSEX >= 100 + xcor AND _MOUSEX <= 800 + xcor AND _MOUSEY >= 100 + ycor AND _MOUSEY <= 800 + ycor THEN
PRINT "R = "; r; " G = "; g; " B = "; b
IF r <= 255 - wheel THEN r = (r + wheel * 5) ELSE r = 0
IF g <= 255 - wheel THEN g = (g + wheel * 10) ELSE g = 0
IF b <= 255 - wheel THEN b = (b + wheel * 15) ELSE b = 0
IF r < 0 THEN r = 255
IF g < 0 THEN g = 255
IF b < 0 THEN b = 255
IF left = 1 THEN
IF xcor >= 1120 AND (_MOUSEX - mousex(x - 1)) <= 0 THEN xcor = xcor + (_MOUSEX - mousex(x - 1))
IF xcor <= -100 AND (_MOUSEX - mousex(x - 1)) >= 0 THEN xcor = xcor + (_MOUSEX - mousex(x - 1))
IF ycor >= 280 AND (_MOUSEY - mousey(y - 1)) <= 0 THEN ycor = ycor + (_MOUSEY - mousex(y - 1))
IF ycor >= 1120 AND (_MOUSEY - mousey(y - 1)) >= 0 THEN ycor = ycor + (_MOUSEY - mousex(y - 1))

IF xcor < 1120 AND xcor > -100 THEN xcor = xcor + (_MOUSEX - mousex(x - 1))
IF ycor < 280 AND ycor > -100 THEN ycor = ycor + (_MOUSEY - mousey(y - 1))
END IF


END IF
IF x < 100000 THEN x = x + 1 ELSE x = 1
IF y < 100000 THEN y = y + 1 ELSE y = 1

_DISPLAY
LOOP

Posted on Dec 10, 2011, 1:52 PM

Respond to this message   

Return to Index


Because you coded it wrong...

by Galleon (no login)

hdscreen = _NEWIMAGE(800, 600, 32)
xcor = 100
ycor = 30
bwidth = 200
bheight = 200

SCREEN hdscreen
r = 24
g = 230
b = 32
DO

CLS

LINE (xcor, ycor)-(bwidth + xcor, bheight + ycor), _RGB(r, g, b), BF

'old values
oleft = left
oright = right
omiddle = middle
omx = mx
omy = my

wheel = 0
leftclick = 0
rightclick = 0
middleclick = 0
DO WHILE _MOUSEINPUT
mx = _MOUSEX
my = _MOUSEY
wheel = wheel + _MOUSEWHEEL
left = _MOUSEBUTTON(1) * -1
right = _MOUSEBUTTON(2) * -1
middle = _MOUSEBUTTON(3) * -1
IF left = 1 AND oleft = 0 THEN leftclick = 1: EXIT DO 'exit do to handle event immediately and prevent multiple events piling up
IF right = 1 AND oright = 0 THEN middleclick = 1: EXIT DO
IF middle = 1 AND omiddle = 0 THEN rightclick = 1: EXIT DO
LOOP


'mouse over box
IF _MOUSEX >= xcor AND _MOUSEX < bwidth + xcor AND _MOUSEY >= ycor AND _MOUSEY < bheight + ycor THEN

'crazy mouse wheel rgb box color changing code ;) I'll just leave this bit alone....
PRINT "R = "; r; " G = "; g; " B = "; b
IF r <= 255 - wheel THEN r = (r + wheel * 5) ELSE r = 0
IF g <= 255 - wheel THEN g = (g + wheel * 10) ELSE g = 0
IF b <= 255 - wheel THEN b = (b + wheel * 15) ELSE b = 0
IF r < 0 THEN r = 255
IF g < 0 THEN g = 255
IF b < 0 THEN b = 255

'left mouse button down
IF leftclick = 1 THEN
drag = 1
dragx = mx - xcor
dragy = my - ycor
END IF

END IF

IF left = 0 THEN drag = 0

IF drag THEN
xcor = mx - dragx
ycor = my - dragy
IF xcor < 0 THEN xcor = 0
IF ycor < 0 THEN ycor = 0
IF xcor > _WIDTH - bwidth THEN xcor = _WIDTH - bwidth
IF ycor > _HEIGHT - bheight THEN ycor = _HEIGHT - bheight
END IF

_LIMIT 100

_DISPLAY
LOOP

Posted on Dec 10, 2011, 8:22 PM

Respond to this message   

Return to Index


Oops, I mixed up the middle & right mouse button in that example!

by Galleon (no login)

I guess I coded it wrong too!

Still the rest works fine.

Posted on Dec 10, 2011, 8:24 PM

Respond to this message   

Return to Index


It's nice to reply when someone helps you out Pmarathe

by Galleon (no login)

Or they might not feel so helpful next time ;)

Posted on Dec 13, 2011, 10:43 AM

Respond to this message   

Return to Index


*Thank you

by (no login)

Posted on Dec 15, 2011, 3:30 PM

Respond to this message   

Return to Index


my approach

by Gayboy (no login)

SCREEN _NEWIMAGE(800, 600, 32), , 1, 0

LOCATE 5, 5: PRINT "background / redraw etc)"

SCREEN , , 0, 0



x = 100

y = 100

wx = 200

wy = 200



r = 255

g = 255

b = 255

DIM c AS LONG

c = _RGB(r, g, b)

DIM temp(10000000)



PCOPY 1, 0

LINE (x, y)-STEP(wx, wy), c, BF



DO

DO

LOOP WHILE _MOUSEINPUT

IF _MOUSEX >= x AND _MOUSEX <= x + wx AND _MOUSEY >= y AND _MOUSEY <= y + wy THEN

IF _MOUSEBUTTON(1) THEN

PCOPY 1, 0

ox = _MOUSEX - x

oy = _MOUSEY - y

DO

DO

LOOP WHILE _MOUSEINPUT

x = _MOUSEX - ox

y = _MOUSEY - oy

PCOPY 1, 0

LINE (x, y)-STEP(wx, wy), c, BF

_DISPLAY

LOOP WHILE _MOUSEBUTTON(1)

END IF

END IF



_DISPLAY

LOOP UNTIL INP(&H60) = 1

SYSTEM

Posted on Dec 10, 2011, 10:02 PM

Respond to this message   

Return to Index


*remove the last _display

by Gayboy (no login)

Posted on Dec 10, 2011, 10:20 PM

Respond to this message   

Return to Index


* hmmm

by (Login burger2227)
R

Posted on Dec 10, 2011, 10:50 PM

Respond to this message   

Return to Index

 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement