A lot of folks are curious about how we can get our programs to talk to each other, and curious about how we'd use QB64 to communicate via TCP/IP over a network. The wiki has a few examples, but they tend to be outdated and simply don't work for me. (Such as the mini-messenger example in the wiki.) I figured people might like a working example of how to get all the proper parts working together, so I tried various wiki samples and eventually decided to rework one until I got it to working for me...
The finished code here is working as intended on Windows. (I dunno if it'll work for Linux or Mac users, but I'd love to hear if it does or doesn't.) Instead of a single set of code which tries to toggle between client and host, I worked this up as two separate sets of code -- one for each. Copy one set of code into QB64, and then run it. Then, while that program is still running in the background, copy the second set of code and run it.. Type in either program and watch as they happily communicate with each other without any issues.
THE HOST:
Code: (Select All)
DIM SHARED Users(1 TO 1000) ' array to hold other client info
DIM SHARED NumClients
DIM SHARED out$
PRINT "[Steve's Mini Messenger]"
host = _OPENHOST("TCP/IP:7319") ' no host found, so begin new host
IF host THEN
PRINT "[Beginning new host chat session!]"
NumClients = 0
client = _OPENCLIENT("TCP/IP:7319:localhost")
IF client = 0 THEN PRINT "ERROR: could not attach host's personal client to host!"
INPUT "Enter your name:", myname$
'PRINT #client, myname$ + " connected!"
PRINT "[Chat session active!]"
ELSE
PRINT "ERROR: Could not begin new host!"
END IF ' host
DO ' host main loop
newclient = _OPENCONNECTION(host) ' receive any new connection
IF newclient THEN
NumClients = NumClients + 1
Users(NumClients) = newclient
PRINT "Welcome to Steve's Mini Messenger!"
END IF
FOR i = 1 TO NumClients
GetMessage Users(i) 'check all clients for a message
IF out$ <> "" THEN
l = LEN(out$)
FOR j = 1 TO NumClients ' distribute incoming messages to all clients
PUT #Users(j), , l
PUT #Users(j), , out$
NEXT
END IF
NEXT i
SUB GetMessage (client) ' get & display any new message
GET #client, , l
IF l > 0 THEN
out$ = SPACE$(l)
GET #client, , out$
VIEW PRINT 1 TO 20
LOCATE 20, 1
PRINT out$
VIEW PRINT 1 TO 24
ELSE
out$ = ""
END IF
END SUB
SUB SendMessage (myname$, mymessage$, client) ' simple input handler
k$ = INKEY$
IF LEN(k$) THEN
IF k$ = CHR$(8) AND LEN(mymessage$) <> 0 THEN
mymessage$ = LEFT$(mymessage$, LEN(mymessage$) - 1)
ELSE
IF LEN(k$) = 1 AND ASC(k$) >= 32 THEN mymessage$ = mymessage$ + k$
END IF
END IF
VIEW PRINT 1 TO 24
LOCATE 22, 1: PRINT SPACE$(80); ' erase previous message displayed
LOCATE 22, 1: PRINT myname$ + ": "; mymessage$;
IF k$ = CHR$(13) THEN ' [Enter] sends the message
IF mymessage$ = "" THEN SYSTEM ' [Enter] with no message ends program
mymessage$ = myname$ + ":" + mymessage$
l = LEN(mymessage$)
PUT #client, , l
PUT #client, , mymessage$
mymessage$ = ""
END IF
IF k$ = CHR$(27) THEN SYSTEM ' [Esc] key ends program
END SUB
THE CLIENT:
Code: (Select All)
DIM SHARED out$
PRINT "[Steve's Mini Messenger]"
client = _OPENCLIENT("TCP/IP:7319:localhost") ' Attempt to connect to local host as a client
PRINT "[connected to " + _CONNECTIONADDRESS(client) + "]"
INPUT "Enter your name: ", myname$
out$ = myname$ + " connected!"
l = LEN(out$)
PUT #client, , l
PUT #client, , out$
DO
GetMessage client
SendMessage myname$, mymessage$, client ' display current input on screen
_LIMIT 30
LOOP
'.................... END OF MAIN PROGRAM ................
SUB GetMessage (client) ' get & display any new message
GET #client, , l
IF l > 0 THEN
out$ = SPACE$(l)
GET #client, , out$
VIEW PRINT 1 TO 20
LOCATE 20, 1
PRINT out$
VIEW PRINT 1 TO 24
ELSE
out$ = ""
END IF
END SUB
SUB SendMessage (myname$, mymessage$, client) ' simple input handler
k$ = INKEY$
IF LEN(k$) THEN
IF k$ = CHR$(8) AND LEN(mymessage$) <> 0 THEN
mymessage$ = LEFT$(mymessage$, LEN(mymessage$) - 1)
ELSE
IF LEN(k$) = 1 AND ASC(k$) >= 32 THEN mymessage$ = mymessage$ + k$
END IF
END IF
VIEW PRINT 1 TO 24
LOCATE 22, 1: PRINT SPACE$(80); ' erase previous message displayed
LOCATE 22, 1: PRINT myname$ + ": "; mymessage$;
IF k$ = CHR$(13) THEN ' [Enter] sends the message
IF mymessage$ = "" THEN SYSTEM ' [Enter] with no message ends program
mymessage$ = myname$ + ":" + mymessage$
l = LEN(mymessage$)
PUT #client, , l
PUT #client, , mymessage$
mymessage$ = ""
END IF
IF k$ = CHR$(27) THEN SYSTEM ' [Esc] key ends program
END SUB
Have fun playing around with this as a local system messenger program. Try it out, kick it around, and let me know if there's anything you don't understand about what it's doing. This isn’t exactly how I'd normally write one of these; but that's because I started with what the wiki had and then gutted it and rebuilt it up until it was actually working for me as it should. Honestly, I think I would've been better off to have just wrote the whole program from scratch!
An oldie salvaged from the ashes of the old forums!
Code: (Select All)
TITLE "Steve QB64-IRC Bot"
DIM SHARED Client AS LONG, Server AS STRING, Channel AS STRING
crlf$ = CHR$(13) + CHR$(10)
nick$ = "SqbBot"
pass$ = ""
Server = "irc.freenode.net"
Channel = "#qb64"
PRINT "Connecting to " + Server + "..."
Client = _OPENCLIENT("TCP/IP:6667:" + Server)
IF Client& = 0 THEN PRINT "Error: could not connect...": SLEEP: SYSTEM
IF pass$ > "" THEN SendInfo "PASS" + pass$
SendInfo "NICK " + nick$
SendInfo "USER " + nick$ + " 0 * :" + nick$
PRINT "Connected!"
respond = 0
DO
_LIMIT 1000
GET #Client&, , In$
IF LEFT$(In$, 4) = "PING" THEN
'Respond with PONG
res$ = "PONG" + MID$(In$, 5) + CHR$(13) + CHR$(10)
PUT #Client, , res$
END IF
'IF In$ <> "" THEN PRINT LEFT$(In$, LEN(In$) - 2) 'Unremark this is we want to see what's being typed by everyone.
IF In$ <> "" AND respond THEN ProcessInput In$
IF INSTR(In$, "End of /NAMES list.") THEN respond = -1 'Don't start responding to the automatic server messages, like an idiot bot!
LOOP UNTIL INKEY$ = CHR$(32) 'Spacebar to quit
SUB SendInfo (text$)
text$ = text$ + CHR$(13) + CHR$(10)
PUT #Client&, , text$
END SUB
SUB SendReply (text$)
text$ = "PRIVMSG " + Channel$ + " :" + text$ + CHR$(13) + CHR$(10)
PUT #Client&, , text$
COLOR 14: PRINT text$
END SUB
IF INSTR(eval$, " SQBBOT ") THEN
'someone is talking directly to the bot or giving it a command
IF INSTR(eval$, " QUIT ") THEN SYSTEM 'A means to automatically shut down the bot
IF INSTR(eval$, " FINISH ") THEN SYSTEM 'A means to automatically shut down the bot
IF INSTR(eval$, " DIE ") THEN SYSTEM 'A means to automatically shut down the bot
IF INSTR(eval$, " SHUT DOWN ") THEN SYSTEM 'A means to automatically shut down the bot
IF INSTR(eval$, " EXIT ") THEN SYSTEM 'A means to automatically shut down the bot
IF INSTR(eval$, " END ") THEN SYSTEM 'A means to automatically shut down the bot
IF INSTR(eval$, " TELL") THEN
IF INSTR(eval$, "TIME") THEN Out$ = Out$ + "The TIME is " + TIME$ + ". "
IF INSTR(eval$, "DATE") THEN Out$ = Out$ + "The DATE is " + DATE$ + ". "
END IF
IF INSTR(eval$, " HI ") THEN Out$ = "Hiyas, " + Speaker$ + ". "
IF INSTR(eval$, " HELLO ") THEN Out$ = "Hello to you too, " + Speaker$ + ". "
IF INSTR(eval$, " YO ") THEN Out$ = "Hola! " + Speaker$ + " How's it hanging? "
IF INSTR(eval$, " HOLA ") THEN Out$ = "What's happening, " + Speaker$ + "? "
END IF
IF INSTR(In$, " JOIN ") AND (INSTR(eval$, "JOIN") = 0) THEN Out$ = "Welcome to QB64 Chat, " + Speaker$ + ". "
IF Out$ <> "" THEN
COLOR 15
l = INSTR(In$, "PRIVMSG")
PRINT Speaker$; " on "; MID$(In$, l + 8) 'I put a print here, so we can see what our bot is responding to, no matter what.
SendReply Out$
END IF
END SUB
Another program from the depths of my hard drive — the start of an IRC chat bot. I’m certain many of the old regulars will remember this guy popping up over and over in the IRC channel as folks tested it and then used it as a base to build their own custom bot, but we have a lot of new members around now, and I thought they too deserved the chance to drive us old QB64 chat channel lurkers crazy...
(If anyone still uses IRC chat at all anymore. Guess it's just another relic left over moldering from the past. )
SUB InitializeMap
FOR x = 0 TO XSize
FOR y = 0 TO YSize
Grid(x, y) = -999 'default blank part of map
NEXT
NEXT
END SUB
SUB DrawMap
DIM kolor AS _UNSIGNED LONG
xscale = _WIDTH / XSize
yscale = _HEIGHT / YSize
FOR x = 0 TO XSize
FOR y = 0 TO YSize
SELECT CASE Grid(x, y)
CASE -3: kolor = DarkBlue 'Deep Water
CASE -2: kolor = Blue 'Water
CASE -1: kolor = SkyBlue 'Shallow Water
CASE 0: kolor = Tann 'beach/sand
CASE 1: kolor = Green 'grassland
CASE 2: kolor = DarkGreen 'forest
CASE 3: kolor = Gold 'hills
CASE 4: kolor = Purple 'mountains
CASE 5 TO 99: kolor = Red
CASE ELSE: kolor = Black
END SELECT
LINE (x * xscale, y * yscale)-STEP(xscale, yscale), kolor, BF
NEXT y, x
END SUB
SUB GenerateTerrain
Height = -3
DO UNTIL finished
finished = -1
FOR x = 0 TO XSize
FOR y = 0 TO YSize
IF Grid(x, y) = Height THEN Fill x, y, Height + 1: finished = 0
NEXT
NEXT
Height = Height + 1
LOOP
END SUB
SUB Fill (x, y, height)
SELECT CASE height
CASE IS = -2: RepeatChance = 50 'water repeat
CASE IS = -1: RepeatChance = 30 'shallow water repeat
CASE IS = 0: RepeatChance = 25 'beach repeat
CASE IS = 1: RepeatChance = 55 'grassland
CASE IS = 2: RepeatChance = 55 'forest
CASE IS = 3: RepeatChance = 50 ' hills
CASE IS = 4: RepeatChance = 50 'mountains
CASE ELSE
RepeatChance = 50 - 3 * height
IF RepeatChance < 10 THEN RepeatChance = 10
END SELECT
CurrentX = x
IF CurrentX > 0 THEN
IF Grid(CurrentX - 1, y) = -999 THEN
Grid(CurrentX - 1, y) = height
IF INT(RND * 100) < RepeatChance THEN Fill CurrentX - 1, y, height
END IF
END IF
CurrentX = x
IF CurrentX < XSize THEN
IF Grid(CurrentX + 1, y) = -999 THEN
Grid(CurrentX + 1, y) = height
IF INT(RND * 100) < RepeatChance THEN Fill CurrentX + 1, y, height
END IF
END IF
CurrentY = y
IF CurrentY > 0 THEN
IF Grid(x, CurrentY - 1) = -999 THEN
Grid(x, CurrentY - 1) = height
IF INT(RND * 100) < RepeatChance THEN Fill x, CurrentY - 1, height
END IF
END IF
CurrentY = y
IF CurrentY < YSize THEN
IF Grid(x, CurrentY + 1) = -999 THEN
Grid(x, y + 1) = height
IF INT(RND * 100) < RepeatChance THEN Fill x, CurrentY + 1, height
END IF
END IF
END SUB
SUB Lakes (Number, MinSize, MaxSize)
FOR i = 1 TO Number
x = INT(RND * XSize): y = INT(RND * YSize)
LakeSize = INT(RND * (MaxSize - MinSize)) + MinSize
LakeBuilt = 0
DO UNTIL LakeBuilt >= LakeSize
xchange = 0: ychange = 0
DO
DO
xchange = INT(RND * 3) - 1
LOOP UNTIL x + xchange > 0 AND x + xchange < XSize
DO
ychange = INT(RND * 3) - 1
LOOP UNTIL y + ychange > 0 AND y + ychange < YSize
LOOP UNTIL xchange <> 0 AND ychange <> 0
repeat:
IF x + xchange < 0 OR x + xchange > XSize THEN xchange = -xchange
IF y + ychange < 0 OR y + ychange > YSize THEN ychange = -ychange
IF Grid(x + xchange, y + ychange) = -999 THEN
Grid(x + xchange, y + ychange) = -3
LakeBuilt = LakeBuilt + 1
x = x + xchange: y = y + ychange
ELSE
flip = INT(RND * 2)
IF flip THEN xchange = xchange * 2 ELSE ychange = ychange * 2
GOTO repeat
END IF
LOOP
NEXT
END SUB
SUB Rivers (Number, Meander, Deep)
FOR i = 1 TO Number
flip1 = INT(RND * 2): flip2 = INT(RND * 2)
IF flip1 THEN 'entry point is on top
x1 = INT(RND * XSize): y1 = 0
ELSE 'entry point is on left
x1 = 0: y1 = INT(RND * YSize)
END IF
IF flip2 THEN 'exit point is on bottom
x2 = INT(RND * XSize): y2 = YSize
ELSE 'exit point is on right
x2 = XSize: y2 = INT(RND * YSize)
END IF
Grid(x1, y1) = Deep: Grid(x2, y2) = Deep
StartX = x1: StartY = y1: EndX = x2: EndY = y2 'just to preserve our original values, if needed.
DO UNTIL StartX = EndX AND StartY = EndY
CoinToss = INT(RND * 100) 'Coin toss to move left/right or up/down, to go towards exit, or wander a bit.
Meander = 10
IF CoinToss MOD 2 THEN 'even or odd, so we only walk vertical or hortizontal and not diagional
IF CoinToss < 100 - Meander THEN 'Lower values meander less and go directly to the target.
XChange = SGN(EndX - StartX) '-1,0,1, drawn always towards the mouse
Ychange = 0
ELSE
XChange = INT(RND * 3) - 1 '-1, 0, or 1, drawn in a random direction to let the lightning wander
Ychange = 0
END IF
ELSE
IF CoinToss < 100 - Meander THEN 'Lower values meander less and go directly to the target.
Ychange = SGN(EndY - StartY)
XChange = 0
ELSE
Ychange = INT(RND * 3) - 1
XChange = 0
END IF
END IF
StartX = StartX + XChange
StartY = StartY + Ychange
IF StartX < 0 THEN StartX = 0 'Make certain we move inside the bounds of our map dimensions
IF StartY < 0 THEN StartY = 0
IF StartX > XSize THEN StartX = XSize
IF StartY > YSize THEN StartY = YSize
Grid(StartX, StartY) = Deep 'place a river where we moved to
LOOP
NEXT
END SUB
FUNCTION MaxScreen
MaxScreen = _NEWIMAGE(1024, 720, 32)
END FUNCTION
SUB ScreenMove (x, y)
DO UNTIL _WIDTH <> 0 AND _SCREENEXISTS = -1: LOOP
_SCREENMOVE x - BorderWidth, y - BorderWidth - TitleBarHeight
END SUB
SUB ScreenMove_Middle
DO UNTIL _WIDTH <> 0 AND _SCREENEXISTS = -1: LOOP
_SCREENMOVE (_DESKTOPWIDTH - _WIDTH - BorderWidth) / 2 + 1, (_DESKTOPHEIGHT - _HEIGHT - BorderWidth) / 2 - TitleBarHeight + 1
END SUB
We start by building some rivers across the screen, which would be the lowest point on the map, and then we rise up to build terrain from that point outwards... beach, plain, forest, hill, mountain, impassable mountains!
Some things to play around with here:
Rivers Int(Rnd * 10) + 1, Int(Rnd * 100) - 100, -3 -- First value is the number of rivers, second is how much they meander across the map, and the third is their starting depth. Note that I haven't set any colors for a depth < -3.
In the fill sub, there's a section which you can play around with to increase density of various features:
Select Case height Case Is < 0: RepeatChance = 33 'water repeat Case Is = 0: RepeatChance = 25 'beach repeat Case Is = 1: RepeatChance = 55 'grassland Case Is = 2: RepeatChance = 55 'forest Case Is = 3: RepeatChance = 40 ' hills Case Is = 4: RepeatChance = 33 'mountains Case Else RepeatChance = 50 - 3 * height If RepeatChance < 10 Then RepeatChance = 10 End Select
The higher the numbers here, the more of the feature your map is going to have...
There's no Ocean on these maps, nor is there any lakes (I think lakes would be a nice addition, rather than just forcing multiple rivers to define the low points of the map), but I think this goes to show how I'd work on generating a map like this. I'd start at the lowest point and then just expand outwards and upwards to my mountains.
Edit: Added Lakes into the mix.
I've got to admit, I think some of these end up looking rather nice. (Of course, since almost everything is random here, some of these end up looking like complete garbage to me as well.)
Keep in mind, I'm creating massive 200 x 200 world maps with the settings the way I currently have them. Also note, the actual game would probably be at a much larger scale with only small portions of it viewable by the player at a time. I also don't know if I'd bother to use so many colors for water... Probably just shallow water (where you can wade in it) and deep water (where a boat travels) would be good enough. My thinking behind 3 levels of water here was basically ocean ship, canoe/raft/shallow drag boat, and then wading/shallow water.
Anywho... I'd call this a decent shot at a random terrain generator. It doesn't follow any basic rules of logic, but it's decent enough I'm not ashamed to share it.
If I was serious about this thing, I'd probably start at my mountains and then flow down to my oceans and not backwards like I did in this attempt, as that seems like it'd generate a more natural water flow from high to low. I'd also try to work in things like temperature zones for the polar regions, and deserts for places which are too far away from any major source of water and would normally be plains instead.
Enough to showcase the basic idea behind things here, but it can definitely be expanded on if someone was wanting to. ;D
Please note that all of the following links go off-site and go to places which we have no direct control over. Content on these external sites may change at any time, as they may have different licenses or restrictions upon any media shared upon them. The old, now defunct and down, QB64 sites operated under a policy of, "Any media uploaded to QB64 sites, are the property of the QB64 Project".
Or policy, here at the Phoenix Edition, is: "Any code you share remains the exclusive property of yours, and we appreciate the privilege to share and help make available to the public any code that you wish to contribute to help expand the knowledgebase and learning of our community. If at any point you wish for your code to be removed from our site, we happily allow you the chance to edit and remove your own works, or else you can contact an administrator or moderator and have your work removed in bulk."
QB64.rip stated that any code you shared was theirs.
Our policy is that any code you share is yours, and if you wish to make your samples fully public domain or open source, then you should include a comment or license with them stating such. We claim no ownership over anyone's work hosted on any of our sites, except our own.
So, with that distinction and warning in mind, we'd like to share links to various outside sites which are QB64 related and may be a boost for people seeking to learn the language:
DECLARE CUSTOMTYPE LIBRARY "direntry"
FUNCTION FILE_load_dir& ALIAS load_dir (s AS STRING)
FUNCTION FILE_has_next_entry& ALIAS has_next_entry ()
SUB FILE_close_dir ALIAS close_dir ()
SUB FILE_get_next_entry ALIAS get_next_entry (s AS STRING, flags AS LONG, file_size AS LONG)
SUB FILE_get_current_dir ALIAS get_current_dir (s AS STRING)
FUNCTION FILE_current_dir_length& ALIAS current_dir_length ()
END DECLARE
FUNCTION SelectFile$ (search$, x AS INTEGER, y AS INTEGER)
'save some old values
LoadFile_DC = _DEFAULTCOLOR: LoadFile_BG = _BACKGROUNDCOLOR
LoadFile_s = _SOURCE: LoadFile_d = _DEST
f = _FONT: _FONT 16
'some variables
'Count our filetypes to display
LoadFile_TypeCount = 0
DO
LoadFile_TypeCount = LoadFile_TypeCount + 1
LoadFile_l = INSTR(LoadFile_l + 1, search$, ";") ' look for ; to denote more files
REDIM _PRESERVE LoadFile_Label(LoadFile_TypeCount) AS STRING
IF LoadFile_l > 0 THEN LoadFile_Label(LoadFile_TypeCount) = MID$(search$, LoadFile_last + 1, LoadFile_l - LoadFile_last - 1) ELSE LoadFile_Label(LoadFile_TypeCount) = MID$(search$, LoadFile_last + 1, LEN(search$) - LoadFile_last)
LoadFile_last = LoadFile_l + 1
LOOP UNTIL LoadFile_l = 0
LoadFile_l = 640 / (LoadFile_TypeCount + 1)
REDIM LoadFile_start(LoadFile_TypeCount), LoadFile_previous(LoadFile_TypeCount), LoadFile_more(LoadFile_TypeCount), LoadFile_Count(LoadFile_TypeCount)
FOR i = 0 TO LoadFile_TypeCount: LoadFile_start(i) = 1: NEXT
_SOURCE LoadFile_ws: _DEST LoadFile_ws
DO
_LIMIT 30
FOR i = 0 TO LoadFile_TypeCount
LoadFile_Count(i) = 0
FOR j = 0 TO 9999
LoadFile_DirList(i, j) = ""
NEXT
NEXT
'Generate our updated directory listings.
IF FILE_load_dir&(LoadFile_Dir$ + CHR$(0)) THEN
DO
LoadFile_length = FILE_has_next_entry 'Get length of next entry
IF LoadFile_length > -1 THEN 'If we have a next entry
LoadFile_nam$ = SPACE$(LoadFile_length) 'Set the size of our string
FILE_get_next_entry LoadFile_nam$, LoadFile_flags, LoadFile_file_size 'Get the file's name, size, and 'flags'
'Check if it's a file or a directory
IF _DIREXISTS(LoadFile_Dir$ + LoadFile_nam$) THEN
IF LoadFile_nam$ <> "." THEN
LoadFile_Count(0) = LoadFile_Count(0) + 1
LoadFile_DirList(0, LoadFile_Count(0)) = LoadFile_nam$
END IF
ELSE 'We have a file
FOR i = 1 TO LoadFile_TypeCount
LoadFile_ext$ = RIGHT$(LoadFile_nam$, LEN(LoadFile_Label(i)))
IF UCASE$(LoadFile_ext$) = UCASE$(LoadFile_Label(i)) THEN
LoadFile_Count(i) = LoadFile_Count(i) + 1
LoadFile_DirList(i, LoadFile_Count(i)) = LEFT$(LoadFile_nam$, LEN(LoadFile_nam$) - LEN(LoadFile_Label(i)))
EXIT FOR
ELSEIF LoadFile_Label(i) = ".*" THEN
LoadFile_Count(i) = LoadFile_Count(i) + 1
LoadFile_DirList(i, LoadFile_Count(i)) = LoadFile_nam$
END IF
NEXT
END IF
END IF
LOOP UNTIL LoadFile_length = -1
FILE_close_dir
END IF
updatelist:
CLS , &HFF005050 'Draw a nice display box
COLOR , 0
LINE (0, 0)-(LoadFile_w, LoadFile_h + 5 - 2 * 16), LoadFile_BoxColor, B
LINE (1, 1)-(LoadFile_w - 1, LoadFile_h + 6 - 2 * 16), LoadFile_BoxColor, B
LINE (0, 0)-(LoadFile_w, LoadFile_h), LoadFile_BoxColor, B
LINE (1, 1)-(LoadFile_w - 1, LoadFile_h - 1), LoadFile_BoxColor, B
LINE (0, 16 + 3)-(LoadFile_w, 16 + 3), LoadFile_BoxColor
LINE (0, 16 + 4)-(LoadFile_w, 16 + 4), LoadFile_BoxColor
FOR i = 0 TO LoadFile_TypeCount
_PRINTSTRING (i * LoadFile_l + (LoadFile_l - 8 * LEN(LoadFile_Label(i))) / 2, 2), LoadFile_Label(i)
LINE (i * LoadFile_l, 0)-(i * LoadFile_l, LoadFile_h + 5 - 2 * 16), LoadFile_BoxColor
NEXT
LINE (627, 2)-(637, 18), &HFFFF0000, BF
LINE (626, 2)-(637, 18), &HFF000000, B
_PRINTSTRING (628, 2), "X"
IF selection > 0 THEN
IF LoadFile_Label(row) <> ".*" AND LoadFile_Label(row) <> "DIR" THEN temp$ = LoadFile_DirList(row, selection) + LoadFile_Label(row) ELSE temp$ = LoadFile_DirList(row, selection)
IF LoadFile_DirList(row, selection) = "" THEN temp$ = ""
selection = 0
END IF
_PRINTSTRING (10, 28 * 16 + 7), LoadFile_Dir$
_PRINTSTRING (630 - LEN(temp$) * 8, 28 * 16 + 7), temp$
IF temp$ = "" THEN oldselection = 0
IF oldselection > 0 THEN LINE (row * LoadFile_l, (oldselection + 1) * 16 + 5)-((row + 1) * LoadFile_l, (oldselection + 2) * 16 + 5), &HAAAAA000, BF
FOR i = 0 TO UBOUND(LoadFile_label)
IF i = 0 THEN COLOR LoadFile_FolderColor ELSE COLOR LoadFile_FileColor
counter = 0
FOR j = LoadFile_start(i) TO LoadFile_start(i) + 24
counter = counter + 1
IF LoadFile_DirList(i, j) = "" THEN EXIT FOR
_PRINTSTRING (i * LoadFile_l + 5, (counter + 1) * 16 + 7), LEFT$(LoadFile_DirList(i, j), LoadFile_l / 8 - 2)
NEXT
IF j = LoadFile_start(i) + 25 THEN LoadFile_more(i) = -1 ELSE LoadFile_more(i) = 0
IF LoadFile_start(i) > 1 THEN LoadFile_previous(i) = -1 ELSE LoadFile_previous(i) = 0
IF LoadFile_more(i) THEN
LINE (i * LoadFile_l + 2, 27 * 16 + 5)-((i + 1) * LoadFile_l - 3, 28 * 16 + 3), &HFFFF0000, BF
LINE (i * LoadFile_l + 2, 27 * 16 + 5)-((i + 1) * LoadFile_l - 3, 28 * 16 + 3), BoxColor, B
COLOR &HFFFFFF00: _PRINTSTRING (i * LoadFile_l + (LoadFile_l - 8 * 11) / 2, 27 * 16 + 5), "SCROLL DOWN"
COLOR LoadFile_FileColor
END IF
IF LoadFile_previous(i) THEN
LINE (i * LoadFile_l + 2, 16 + 5)-((i + 1) * LoadFile_l - 3, 2 * 16 + 3), &HFFFF0000, BF
LINE (i * LoadFile_l + 2, 16 + 5)-((i + 1) * LoadFile_l - 3, 2 * 16 + 3), BoxColor, B
COLOR &HFFFFFF00: _PRINTSTRING (i * LoadFile_l + (LoadFile_l - 8 * 9) / 2, 16 + 5), "SCROLL UP"
COLOR LoadFile_FileColor
END IF
NEXT
change = 0
DO
_LIMIT 30
LoadFile_LMB = 0 'This sets the left mouse button as unacceptable.
a = _KEYHIT
SELECT CASE a
CASE 8 'backspace
temp$ = LEFT$(temp$, LEN(temp$) - 1)
change = -1
CASE 13 'enter
DO: LOOP UNTIL INKEY$ = "" 'Clear the keyboard buffer so it doesn't affect the main program.
temp$ = LoadFile_Dir$ + temp$
COLOR LoadFile_DC, LoadFile_BG: _SOURCE LoadFile_s: _DEST LoadFile_d: PCOPY 1, 0: _DISPLAY: SelectFile$ = temp$ 'Restore our old settings
_FONT f
EXIT SUB 'And leave
CASE 27 'If ESC is pressed then...
DO: LOOP UNTIL INKEY$ = "" 'Clear the keyboard buffer so it doesn't affect the main program.
COLOR LoadFile_DC, LoadFile_BG: _SOURCE LoadFile_s: _DEST LoadFile_d: PCOPY 1, 0: _DISPLAY: SelectFile$ = "" 'Restore our old settings
_FONT f
EXIT SUB 'And leave
CASE 32 TO 126
temp$ = temp$ + CHR$(a)
change = -1
END SELECT
DO
IF _MOUSEBUTTON(1) = 0 THEN LoadFile_LMB = -1 'Only by lifting the mouse, will we count it as down
'Note: we ignore LoadFile_LMB for the scroll bars, so we can just hold it down and scroll happily forever and ever...
'or until we get to the limit of our file list.
'We only check LoadFile_LMB when actually trying to select an item from our list. No more "OOP! I held it too long and did something I didn't want to do!"
'Now we click once to select, click again to accept that selection.
LOOP WHILE _MOUSEINPUT
MX = _MOUSEX: MY = _MOUSEY
IF _MOUSEBUTTON(2) OR (LoadFile_LMB AND MX > 626 + x AND MX < 638 + x AND MY > 1 + y AND MY < 19 + y AND _MOUSEBUTTON(1)) THEN
'restore those old values, and just exit. Right mouse is an escape
COLOR LoadFile_DC, LoadFile_BG: _SOURCE LoadFile_s: _DEST LoadFile_d: PCOPY 1, 0: _DISPLAY: SelectFile$ = ""
_FONT f
EXIT SUB
END IF
IF _MOUSEBUTTON(1) THEN 'Without the mouse being down, we don't need to check squat!
'Check the 2 roLoadFile_ws for a click in the proper Y position
IF MY >= 16 + 5 + y AND MY <= 2 * 16 + 3 + y THEN 'We're on the top row
FOR j = 0 TO UBOUND(LoadFile_label)
IF LoadFile_previous(j) AND MX >= j * LoadFile_l + 2 + x AND MX <= (j + 1) * LoadFile_l - 3 + x THEN
LoadFile_start(j) = LoadFile_start(j) - 1
change = -1: selection = 0: click = 0: temp$ = ""
EXIT FOR
END IF
NEXT
ELSEIF MY >= 27 * 16 + 5 + y AND MY <= 28 * 16 + 3 + y THEN 'We're on the bottom row
FOR j = 0 TO UBOUND(LoadFile_label)
IF LoadFile_more(j) AND MX >= j * LoadFile_l + 2 + x AND MX <= (j + 1) * LoadFile_l - 3 + x THEN
LoadFile_start(j) = LoadFile_start(j) + 1
change = -1: selection = 0: click = 0: temp$ = ""
EXIT FOR
END IF
NEXT
ELSEIF MY >= 37 + y AND MY <= 437 + y AND LoadFile_LMB THEN 'It's in a column somewhere. Did someone click an item?!
FOR j = 0 TO UBOUND(LoadFile_label)
IF MX >= j * LoadFile_l + 2 + x AND MX <= (j + 1) * LoadFile_l - 3 + x THEN
row = j
oldselection = INT((MY - y - 37) / 16) + 1
selection = LoadFile_start(j) + oldselection - 1
change = -1
click = -1
EXIT FOR
END IF
NEXT
END IF
END IF
_DISPLAY
LOOP UNTIL change
IF click THEN 'we clicked something besides a scroll bar
IF LoadFile_Label(row) <> ".*" AND LoadFile_Label(row) <> "DIR" THEN temp1$ = LoadFile_DirList(row, selection) + LoadFile_Label(row) ELSE temp1$ = LoadFile_DirList(row, selection)
IF temp$ = temp1$ THEN
'We picked one!
SELECT CASE LoadFile_Label(row)
CASE "DIR"
IF LoadFile_DirList(row, selection) <> ".." THEN
LoadFile_Dir$ = LoadFile_Dir$ + LoadFile_DirList(row, selection) + LoadFile_Slash$
ELSE
DO
LoadFile_Dir$ = LEFT$(LoadFile_Dir$, LEN(LoadFile_Dir$) - 1)
LOOP UNTIL RIGHT$(LoadFile_Dir$, 1) = LoadFile_Slash$ OR LEN(LoadFile_Dir$) = 0
END IF
FOR i = 1 TO UBOUND(Loadfile_start)
LoadFile_start(i) = 1
NEXT
selection = 0: temp$ = "": oldselection = 0
CASE ".*": SelectFile$ = LoadFile_Dir$ + temp$: EXIT DO
CASE ELSE: SelectFile$ = LoadFile_Dir$ + temp$: EXIT DO
END SELECT
END IF
IF row > 0 THEN _DELAY .2: GOTO updatelist
ELSE
_DELAY .05
GOTO updatelist
END IF
LOOP
'restore those old values
COLOR LoadFile_DC, LoadFile_BG: _SOURCE LoadFile_s: _DEST LoadFile_d: PCOPY 1, 0: _DISPLAY
_FONT f
END SUB
'If you don't have a copy of direntry.h in your QB64 folder, then copy the following code into a new IDE window.
'Then remove the remarks.
'And save it as direntry.h
'direntry.h is required for this to work properly with the library files.
'I thought adding the code here would be a way to make certain that it'd be easy to recover the file
'in case something ever happened and it was accidently deleted off the drive for some reason.
Read the comments at the end of the file to create the direntry.h text/header file in your QB64 folder for it to run properly. (Or download it from the attachment below.)
Color scheme might not suit everyone's liking, but you guys can adjust that to your own preferences if you want. I know my color tastes aren't for everyone!
I have started down the journey of cleaning up the QB64 code base little by little. I have forked 'QB64-Phoenix-Edition/QB64pe:main'
Currently, I'm working on the qb64.bas. I'm mostly adding comments, and grouping related variables into structures. Needless to say it's going a bit slow.
My initial goals are:
Make it easier to read and understand.
Understand how it works, at very low level.
Understand how to add features and commands.
Optimize whenever possible.
I would like to people to test my changes on different platforms as I go along.
If you have questions, comments or concerns, let me know.
ColorPicker is an easy to use FUNCTION that asks for and returns a selected color. I put this together for a future drawing program. When you call the function, a color box pops on the screen. Use the mouse to select a color and click CLOSE. The color value is returned. If you press ESC you can cancel the color box. When the color box closes the original background is preserved.
- Dav
Code: (Select All)
'================
'COLORPICKER2.BAS
'================
'Simple to use color picker function.
'Coded by Dav for QB64-PE, AUG/2023
'Use mouse, hover over a color to choose, then
'Click left mouse button to select that color.
'You will see the color appear in the box, along
'with a gradient strip of color variations also.
'If you are happy with your color selection, then
'Press CLOSE to exit picker and return selected color.
'Press ESC to cancel making a selection.
Screen _NewImage(1000, 600, 32)
_FullScreen
Paint (0, 0), _RGB(33, 66, 99)
'=== draw stuff
For x = 25 To _Width - 25 Step 10
For y = 25 To _Height - 25 Step 10
Line (x, y)-Step(5, 5), _RGB(Rnd * 255, Rnd * 255, Rnd * 255), BF
Next
Next
_Delay .5
x = (_Width / 2) - 233: y = (_Height / 2) - 123
clr& = ColorPicker&(x, y)
_Delay .5
'clr& is the returned value
If clr& <> 0 Then
'=== break clr& into RGB valued
red = _Red32(clr&): grn = _Green32(clr&): blu = _Blue32(clr&)
'=== draw something to show color picked
Line (50, 50)-(150, 150), _RGB(red, grn, blu), BF
'=== Print color values to user
Print "Selected color: "; clr&; ", or _RGB ("; red; ","; grn; ","; blu; ")"
Else
Print "No color selected"
End If
End
'======================================
Function ColorPicker& (xpos, ypos)
'Update ColorPicker& Function by Dav, AUG/2023.
'Function Returns color picked by user if one selected.
'If no color selected before Closing, function returns 0
'Click CLOSE to close the ColorPicker image.
'ESC key also cancels selection and closes picker box.
'The xpos/ypos is x/y point on the screen to place colorpicker
'=== Save users display status
DisplayStatus% = _AutoDisplay
'=== copy current screen using _MEM (thanks Steve!)
'=== Used this method because_COPYIMAGE(_DISPLAY) didnt always work
Dim scr1 As _MEM, scr2 As _MEM
scr1 = _MemImage(0): scr2 = _MemNew(scr1.SIZE)
_MemCopy scr1, scr1.OFFSET, scr1.SIZE To scr2, scr2.OFFSET
'=== Save current PRINT colors too, restore later
fgclr& = _DefaultColor: bgclr& = _BackgroundColor
'=== draw color blocks
For x = xpos + 10 To xpos + 200 Step 56
For y = ypos + 10 To ypos + 200 Step 56
Line (x, y)-Step(56, 56), pal&(p), BF: p = p + 1
Line (x, y)-(x + 56, y + 56), _RGB(128, 128, 128), B
Next
Next
'=== draw color selection areas
Line ((xpos + 246), (ypos + 10))-((xpos + 453), (ypos + 70)), _RGB(128, 128, 128), B
Color _RGB(128, 128, 128), _RGB(255, 255, 255)
_PrintString (xpos + 246, ypos + 10), " New Color: "
Line ((xpos + 246), (ypos + 77))-((xpos + 454), (ypos + 135)), _RGB(128, 128, 128), B
_PrintString (xpos + 246, ypos + 77), " Gradient: "
'=== draw CLOSE button area
w& = _RGB(255, 255, 255): r& = _RGB(255, 0, 0)
Line (xpos + 246, ypos + 158)-(xpos + 453, ypos + 229), r&, BF
bx = xpos + 250: by = ypos + 158
Line (bx + 17, by + 11)-Step(29, 49), w&, BF 'C
Line (bx + 29, by + 20)-Step(6, 31), r&, BF
Line (bx + 35, by + 31)-Step(11, 10), r&, BF
Line (bx + 57, by + 11)-Step(12, 49), w&, BF 'L
Line (bx + 57, by + 50)-Step(20, 10), w&, BF
Line (bx + 87, by + 11)-Step(28, 49), w&, BF 'O
Line (bx + 98, by + 23)-Step(6, 27), r&, BF
Line (bx + 125, by + 11)-Step(26, 49), w&, BF 'S
Line (bx + 135, by + 20)-Step(5, 11), r&, BF
Line (bx + 135, by + 27)-Step(16, 4), r&, BF
Line (bx + 125, by + 39)-Step(16, 4), r&, BF
Line (bx + 136, by + 39)-Step(5, 11), r&, BF
Line (bx + 161, by + 11)-Step(21, 49), w&, BF 'E
Line (bx + 173, by + 21)-Step(9, 10), r&, BF
Line (bx + 173, by + 39)-Step(9, 11), r&, BF
'====================================
'=== Now get users color selection...
'=== no selection made yet
selected = 0
'=== main loop
Do
'=== Get mouse input
While _MouseInput
'=== Get mouse x/y
mx = _MouseX: my = _MouseY
'=== Only poll this area
If mx > xpos And mx < (xpos + 473) And my > ypos And my < (ypos + 243) Then
'=== if click button in area
If _MouseButton(1) Then
'=== if clicked in CLOSE box area
If mx > (xpos + 246) And mx < (xpos + 453) And my > (ypos + 158) And my < (ypos + 229) Then
Exit Do
End If
'=== made a color selection
selected = 1
'=== Get color where mouse pointer is
clr& = Point(mx, my)
'=== Make Red Green Blue color values
red = _Red32(clr&): grn = _Green32(clr&): blu = _Blue32(clr&)
'=== show color selected in box
Line ((xpos + 246), (ypos + 10))-((xpos + 453), (ypos + 70)), _RGB(red, grn, blu), BF
Line ((xpos + 246), (ypos + 10))-((xpos + 453), (ypos + 70)), _RGB(128, 128, 128), B
'=== Update gradient strip with color...
'=== ...ONLY if mouse is not in gradient strip area
If mx <= (xpos + 246) Or mx >= (xpos + 455) Or my <= (ypos + 78) Or my >= (ypos + 136) Then
'draw from color to whiteout
c = 0
xpc = (453 - 246 / 2)
For x = (xpos + xpc) To (xpos + 246) Step -4
Line (x, (ypos + 77))-(x + 4, (ypos + 135)), _RGB(red + c, grn + c, blu + c), BF
c = c + 8
Next
'now draw from color to blackout
c = 0
For x2 = xpos + xpc To xpc + xpos + 120 Step 4
Line (x2, (ypos + 77))-(x2 + 4, (ypos + 135)), _RGB(red + c, grn + c, blu + c), BF
c = c - 8
Next
Line ((xpos + 246), (ypos + 77))-((xpos + 454), (ypos + 135)), _RGB(128, 128, 128), B
End If
End If
'=== update screen, not used for now
'_DISPLAY
End If
Wend
'=== ESC key cancels picking and closes
If InKey$ = Chr$(27) Then
selected = 0: Exit Do
End If
Loop 'UNTIL INKEY$ <> ""
'=== wait for mouse button UP to continue
Do: mi = _MouseInput: Loop Until _MouseButton(1) = 0
'=== if user selected color, say so
If selected = 1 Then
ColorPicker& = clr&
Else
ColorPicker& = 0
End If
'====================================
'=== Restore background screen as it was
_MemCopy scr2, scr2.OFFSET, scr2.SIZE To scr1, scr1.OFFSET
_MemFree scr1: _MemFree scr2
'=== Restore display status as it was
If DisplayStatus% = -1 Then _AutoDisplay
TENTS.BAS is a clone of a popular addictive puzzle game called 'Tents & Trees'.
You put tents next to trees, and try to match the correct number of tents allowed for each row and column (their numbers shown on side).
Each tree much have a tent next to it, and the number of tents in the row/column must match the number shown. If there are too many tents in the row/column, or if 2 tents are touching each other, they will turn red. If it's the correct number, they turn green. Turn all row/col numbers green. Click on an empty square to put a tent there, click again to remove it. Remember, tents cannot touch other tents.
There are 10 levels to solve. You can restart current level by pressing SPACE. Use arrow keys to skip to other levels.
Posted by: SMcNeill - 05-01-2022, 05:45 AM - Forum: SMcNeill
- No Replies
And, after much brain melting, I think I've finally pieced together a suitable method to convert 32-bit images down to 256 colors for use with QB64. Needless to say, you'll need the attached files to run this demo:
Code: (Select All)
_Define A-Z As _UNSIGNED LONG
ws = _NewImage(640, 480, 32) 'A 32 bit screen
ts = _NewImage(640, 480, 256) 'A 256 color screen, which is only used so I can get the standard 256 color paletter from it.
Screen ws
Randomize Timer
Dim color256 As _Unsigned Long
Const ConvertToStandard256Palette = -1 'Change to 0 and you can see that we preseve the second pass's
' color information perfectly.
' If the CONST is set, then we convert our colors on the screen
' to as close of a match as possible, while preserving the standard
' QB64 256-color palette.
Cls , _RGB32(0, 0, 0)
For j = 1 To 2
If j = 1 Then
For i = 1 To 100 '100 random colors
'if we want to use the standard 256 color screen palette, we can do so as below
color256 = _RGB32(_Red(i, ts), _Green(i, ts), _Blue(i, ts))
Line (Rnd * 640, Rnd * 480)-(Rnd * 640, Rnd * 480), color256, BF
Next
Else 'we can go with completely random colors with the following instead:
For i = 1 To 100 '100 random colors
Line (Rnd * 640, Rnd * 480)-(Rnd * 640, Rnd * 480), &HF0000000 + Rnd * &HFFFFFFF, BF
Next
End If
Print "This is the original screen, pass"; j
Sleep 'show the original screen
t = Image32To256(ws)
Screen t 'show the standard 256 image screen with the image converted over
' this keeps us from having to learn or use any new/unique palettes the image may have
' but, it does cause us to lose details and hues.
Print "This is the 256-color screen, pass"; j
Sleep
Screen ws
_FreeImage t
Cls
Next
l = _LoadImage("Beautiful_colorful_bird_wallpaper01.jpg", 32)
Screen l
_ScreenMove 0, 0 'move the screen to use as much of the screen as possible, since it's so damn huge!
Print "This is the original 32-bit screen."
Sleep 'to show the 32-bit image of the colorful bird I found
t = Image32To256(l)
Screen t 'show the 256 image screen with the image converted over
_ScreenMove 0, 0 'move this one too!
Print "This is the converted 256 color screen."
'And we're done. You should now be seeing a pretty little 256 color version of the bird
Function Image32To256 (image&)
Dim o As _Offset
Dim a As _Unsigned _Byte, r As _Unsigned _Byte
Dim g As _Unsigned _Byte, b As _Unsigned _Byte
Dim t As _Unsigned Long, color256 As _Unsigned Long
Dim index256 As _Unsigned Long
Type Pal_type
c As _Unsigned Long 'color index
n As Long 'number of times it appears
End Type
Dim Pal(255) As _Unsigned Long
I256 = _NewImage(_Width(image&), _Height(image&), 256)
Dim m(1) As _MEM: m(0) = _MemImage(image&): m(1) = _MemImage(I256)
Do 'get the palette and number of colors used
_MemGet m(0), m(0).OFFSET + o, t 'Get the colors from the original screen
For i = 0 To colors 'check to see if they're in the existing palette we're making
If Pal(i) = t Then Exit For
Next
If i > colors Then
Pal(colors) = t
colors = colors + 1 'increment the index for the new color found
If colors > 255 Then 'no need to check any further; it's not a normal QB64 256 color image
Image32To256 = RemapImageFS(image&, I256)
_FreeImage I256
_MemFree m()
Exit Function 'and we're done, with 100% image compatability saved
End If
End If
o = o + 4
Loop Until o >= m(0).SIZE
' we might be working with a standard qb64 256 color screen
' check for that first
colors = colors - 1 'back up one, as we found our limit and aren't needing to set another
For i = 0 To colors 'comparing palette against QB64 256 color palette
t = Pal(i)
index256 = _RGBA(_Red(t), _Green(t), _Blue(t), _Alpha(t), I256)
color256 = _RGBA32(_Red(index256, I256), _Green(index256, I256), _Blue(index256, I256), _Alpha(index256, I256))
If t <> color256 Then NSCU = -1: Exit For
Next
If NSCU Then 'it's not a standard QB64 256 color palette, but it's still less than 256 total colors.
If ConvertToStandard256Palette Then
TI256 = RemapImageFS(image&, I256)
_MemFree m(1) 'free the old memory
_FreeImage I256 'and the old image
I256 = TI256 'replace with the new image
m(1) = _MemImage(I256) 'and point the mem block to the new image
Else
For i = 0 To colors: _PaletteColor i, Pal(i), I256: Next 'set the palette
End If
End If
'If we didn't change the palette above, we should work 100% with qb64's internal 256 color palette
o = 0
Do 'Get the colors, put them to a 256 color screen, as is
_MemGet m(0), m(0).OFFSET + o + 3, a
_MemGet m(0), m(0).OFFSET + o + 2, r
_MemGet m(0), m(0).OFFSET + o + 1, g
_MemGet m(0), m(0).OFFSET + o + 0, b
_MemPut m(1), m(1).OFFSET + o \ 4, _RGBA(r, g, b, a, I256) As _UNSIGNED _BYTE
o = o + 4
Loop Until o >= m(0).SIZE
_MemFree m()
Image32To256 = I256
End Function
Function RemapImageFS& (ohan&, dhan&)
RemapImageFS& = -1 'so far return invalid handle
shan& = ohan& 'avoid side effect on given argument
If shan& < -1 Then
'--- check/adjust source image & get new 8-bit image ---
swid% = _Width(shan&): shei% = _Height(shan&)
If _PixelSize(shan&) <> 4 Then
than& = _NewImage(swid%, shei%, 32)
If than& >= -1 Then Exit Function
_PutImage , shan&, than&
shan& = than&
Else
than& = -1 'avoid freeing below
End If
nhan& = _NewImage(swid%, shei%, 256)
'--- Floyd-Steinberg error distribution arrays ---
rhan& = _NewImage(swid%, 2, 32) 'these are missused as LONG arrays,
ghan& = _NewImage(swid%, 2, 32) 'with CHECKING:OFF this is much faster
bhan& = _NewImage(swid%, 2, 32) 'than real QB64 arrays
'--- curr/next row offsets (for distribution array access) ---
cro% = 0: nro% = swid% * 4 'will be swapped after each pixel row
'--- the matrix values are extended by 16384 to avoid slow floating ---
'--- point ops and to allow for integer storage in the above arrays ---
'--- also it's a power of 2, which may be optimized into a bitshift ---
seven% = (7 / 16) * 16384 'X+1,Y+0 error fraction
three% = (3 / 16) * 16384 'X-1,Y+1 error fraction
five% = (5 / 16) * 16384 'X+0,Y+1 error fraction
one% = (1 / 16) * 16384 'X+1,Y+1 error fraction
'--- if all is good, then start remapping ---
$Checking:Off
If nhan& < -1 And rhan& < -1 And ghan& < -1 And bhan& < -1 Then
_CopyPalette dhan&, nhan& 'dest palette to new image
'--- for speed we do direct memory access ---
Dim sbuf As _MEM: sbuf = _MemImage(shan&): soff%& = sbuf.OFFSET
Dim nbuf As _MEM: nbuf = _MemImage(nhan&): noff%& = nbuf.OFFSET
Dim rbuf As _MEM: rbuf = _MemImage(rhan&): roff%& = rbuf.OFFSET
Dim gbuf As _MEM: gbuf = _MemImage(ghan&): goff%& = gbuf.OFFSET
Dim bbuf As _MEM: bbuf = _MemImage(bhan&): boff%& = bbuf.OFFSET
'--- iterate through pixels ---
For y% = 0 To shei% - 1
For x% = 0 To swid% - 1
'--- curr/prev/next pixel offsets ---
cpo% = x% * 4: ppo% = cpo% - 4: npo% = cpo% + 4
'--- get pixel ARGB value from source ---
srgb~& = _MemGet(sbuf, soff%&, _Unsigned Long)
'--- add distributed error, shrink by 16384, clear error ---
'--- current pixel X+0, Y+0 (= cro% (current row offset)) ---
poff% = cro% + cpo% 'pre-calc full pixel offset
sr% = ((srgb~& And &HFF0000~&) \ 65536) + (_MemGet(rbuf, roff%& + poff%, Long) \ 16384) 'red
sg% = ((srgb~& And &HFF00~&) \ 256) + (_MemGet(gbuf, goff%& + poff%, Long) \ 16384) 'green
sb% = (srgb~& And &HFF~&) + (_MemGet(bbuf, boff%& + poff%, Long) \ 16384) 'blue
_MemPut rbuf, roff%& + poff%, 0 As LONG 'clearing each single pixel error using _MEMPUT
_MemPut gbuf, goff%& + poff%, 0 As LONG 'turns out even faster than clearing the entire
_MemPut bbuf, boff%& + poff%, 0 As LONG 'pixel row using _MEMFILL at the end of the loop
'--- find nearest color ---
crgb~& = _RGBA32(sr%, sg%, sb%, 0) 'used for fast value clipping + channel merge
npen% = _RGB(sr%, sg%, sb%, nhan&)
'--- put colormapped pixel to dest ---
_MemPut nbuf, noff%&, npen% As _UNSIGNED _BYTE
'------------------------------------------
'--- Floyd-Steinberg error distribution ---
'------------------------------------------
'--- You may comment this block out, to see the
'--- result without applied FS matrix.
'-----
'--- get dest palette RGB value, calc error to clipped source ---
nrgb~& = _PaletteColor(npen%, nhan&)
er% = ((crgb~& And &HFF0000~&) - (nrgb~& And &HFF0000~&)) \ 65536
eg% = ((crgb~& And &HFF00~&) - (nrgb~& And &HFF00~&)) \ 256
eb% = (crgb~& And &HFF~&) - (nrgb~& And &HFF~&)
'--- distribute error according to FS matrix ---
If x% > 0 Then
'--- X-1, Y+1 (= nro% (next row offset)) ---
poff% = nro% + ppo% 'pre-calc full pixel offset
_MemPut rbuf, roff%& + poff%, _MemGet(rbuf, roff%& + poff%, Long) + (er% * three%) As LONG 'red
_MemPut gbuf, goff%& + poff%, _MemGet(gbuf, goff%& + poff%, Long) + (eg% * three%) As LONG 'green
_MemPut bbuf, boff%& + poff%, _MemGet(bbuf, boff%& + poff%, Long) + (eb% * three%) As LONG 'blue
End If
'--- X+0, Y+1 (= nro% (next row offset)) ---
poff% = nro% + cpo% 'pre-calc full pixel offset
_MemPut rbuf, roff%& + poff%, _MemGet(rbuf, roff%& + poff%, Long) + (er% * five%) As LONG 'red
_MemPut gbuf, goff%& + poff%, _MemGet(gbuf, goff%& + poff%, Long) + (eg% * five%) As LONG 'green
_MemPut bbuf, boff%& + poff%, _MemGet(bbuf, boff%& + poff%, Long) + (eb% * five%) As LONG 'blue
If x% < (swid% - 1) Then
'--- X+1, Y+0 (= cro% (current row offset)) ---
poff% = cro% + npo% 'pre-calc full pixel offset
_MemPut rbuf, roff%& + poff%, _MemGet(rbuf, roff%& + poff%, Long) + (er% * seven%) As LONG 'red
_MemPut gbuf, goff%& + poff%, _MemGet(gbuf, goff%& + poff%, Long) + (eg% * seven%) As LONG 'green
_MemPut bbuf, boff%& + poff%, _MemGet(bbuf, boff%& + poff%, Long) + (eb% * seven%) As LONG 'blue
'--- X+1, Y+1 (= nro% (next row offset)) ---
poff% = nro% + npo% 'pre-calc full pixel offset
_MemPut rbuf, roff%& + poff%, _MemGet(rbuf, roff%& + poff%, Long) + (er% * one%) As LONG 'red
_MemPut gbuf, goff%& + poff%, _MemGet(gbuf, goff%& + poff%, Long) + (eg% * one%) As LONG 'green
_MemPut bbuf, boff%& + poff%, _MemGet(bbuf, boff%& + poff%, Long) + (eb% * one%) As LONG 'blue
End If
'------------------------------------------
'--- End of FS ----------------------------
'------------------------------------------
noff%& = noff%& + 1 'next dest pixel
soff%& = soff%& + 4 'next source pixel
Next x%
tmp% = cro%: cro% = nro%: nro% = tmp% 'exchange distribution array row offsets
Next y%
'--- memory cleanup ---
_MemFree bbuf
_MemFree gbuf
_MemFree rbuf
_MemFree nbuf
_MemFree sbuf
'--- set result ---
RemapImageFS& = nhan&
nhan& = -1 'avoid freeing below
End If
$Checking:On
'--- remapping done or error, cleanup remains ---
If bhan& < -1 Then _FreeImage bhan&
If ghan& < -1 Then _FreeImage ghan&
If rhan& < -1 Then _FreeImage rhan&
If nhan& < -1 Then _FreeImage nhan&
If than& < -1 Then _FreeImage than&
End If
End Function
As this works, it does 3 things for us: First, it checks to see if the image has 256 colors or less in it.
If it does, then it checks to see if those 256 colors match the original QB64 256 color palette. If they do, we convert the image to a standard QB64 256-color image, and at this point you can work with it with the normal color values you know and love.
If there's colors which aren't in the QB64 standard palette, then it alters the palette to match the image and then converts it to work with that palette. (How you'd know what colors are what, I dunno, but I'll leave that up to the end user to sort out. I suppose if you have a palette which you normally use, you could scan the colors in this one and swap them back and forth with the ones which you normally use, until the values match as originally intended.)
The results seem more than reasonable to me, and this will be a tool which I'll probably make use of quite a bit in the future. With it, loading and using 256 color images are now available once again with QB64!
[i][b]NOTE: Don't forget the attached files![/b][/i]
In the demo, the first pass uses the standard QB64 256 color palette. As you notice, the white text which we print to the screen with, continues to remain white, with no issues.
The second pass uses a random set of colors, which certainly won't match the standard 256 color palette, forcing us to save the palette in use, which (more than likely) is going to change the default value of white. The text which pops up in the top left of the converted screen is going to whatever the NEW palette tells us white is, for that image.
The third pass takes a large numbers of colors, dithers them down to 256 colors, and then saves the palette for them as closely as possible to the original. Since we attempted to save the image, converted down using the QB64 standard palette, the colors should be the ones that you're used to seeing normally. The white text should still look white, just as normal for us.
Play around with it. Kick it about a bit. See how it performs for you, and if there's any issues or problems.
And don't forget to thank RhoSigma, whose graphic library I borrowed (stole really ) heavily from to get this working the way it is now.
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%GIF STUFF%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
DIM SHARED MakeGif_OutBuffer AS STRING
DIM SHARED MakeGif_OStartAddress AS INTEGER, MakeGif_OAddress AS INTEGER
DIM SHARED MakeGif_OEndAddress AS INTEGER, MakeGif_OSeg AS INTEGER
DIM SHARED MakeGif_CodeSize AS INTEGER, MakeGif_CurrnetBit AS INTEGER, MakeGif_Char AS LONG
DIM SHARED MakeGIF_BlockLength AS INTEGER, MakeGif_X AS INTEGER, MakeGif_Y AS INTEGER
DIM SHARED MakeGif_MinX AS INTEGER, MakeGif_MinY AS INTEGER
DIM SHARED MakeGif_MaxX AS INTEGER, MakeGif_MaxY AS INTEGER
DIM SHARED MakeGif_Done AS INTEGER, MakeGif_GIFfile AS INTEGER, MakeGif_LastLoc AS LONG
'%%%%%%%%%%%%%%%%%%%%%%%%%%%END OF GIF STUFF%%%%%%%%%%%%%%%%%%%%%%%%%%%%
DIM Demo_T
SCREEN _NEWIMAGE(640, 480, 256)
RANDOMIZE TIMER
FOR i = 1 TO 100
LINE (RND * 640, RND * 480)-(RND * 640, RND * 480), i, BF 'draw some junk on the screen
NEXT
SaveGIF "booga.gif", 0, 0, 0, 639, 479
SLEEP
CLS
SLEEP
Demo_T = _LOADIMAGE("booga.gif")
SCREEN Demo_T
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%GIF STUFF%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'-----------------------------------------------------------------------
' PDS 7.1 & QB4.5 GIF Compression Routine v1.00 By Rich Geldreich 1992
' Bug fixed and Overhauled for QB64 by Steve McNeill 2019
'-----------------------------------------------------------------------
SUB SaveGIF (file$, image AS LONG, Xstart, YStart, Xend, Yend)
CONST Table.Size = 7177 'hash table's size - must be a prime number!
'Variables all DIMMED so as to avoid any OPTION _EXPLICIT errors.
DIM Prefix(Table.Size - 1) AS INTEGER
DIM Suffix(Table.Size - 1) AS INTEGER
DIM code(Table.Size - 1) AS INTEGER
DIM ScreenX AS INTEGER
DIM ScreenY AS INTEGER
DIM B AS STRING
DIM NumColors AS INTEGER
DIM BitsPixel AS INTEGER
DIM StartSize AS INTEGER
DIM StartCode AS INTEGER
DIM StartMax AS INTEGER
DIM ColorBits AS INTEGER
DIM a1 AS INTEGER
DIM a AS STRING
DIM R AS INTEGER
DIM G AS INTEGER
DIM B1 AS INTEGER
DIM ImageWidth AS INTEGER
DIM ImageHeight AS INTEGER
DIM MaxCode AS INTEGER
DIM ClearCode AS INTEGER
DIM EOFCode AS INTEGER
DIM NextCode AS INTEGER
DIM a2 AS LONG
DIM Prefix AS INTEGER
DIM Suffix AS INTEGER
DIM Found AS INTEGER
DIM index AS INTEGER
DIM Offset AS INTEGER
DIM D AS INTEGER
DIM S AS INTEGER
D = _DEST: S = _SOURCE
_DEST image&: _SOURCE image&
'Open GIF output file
MakeGif_GIFfile = FREEFILE 'use next free file
OPEN file$ FOR BINARY AS MakeGif_GIFfile
'Put GIF87a header at beginning of file
B$ = "GIF87a"
PUT MakeGif_GIFfile, , B$
'See how many colors are in this image...
NumColors = 256 'who cares about the old school graphic modes with fewer colors? Not me! Find a different encoder. :)
BitsPixel = 8 '8 bits per pixel
StartSize = 9 'first LZW code is 9 bits
StartCode = 256 'first free code
StartMax = 512 'maximum code in 9 bits
ColorBits = 6 'VGA
PUT MakeGif_GIFfile, , ScreenX 'put screen's dimensions
PUT MakeGif_GIFfile, , ScreenY
'pack colorbits and bits per pixel
a1 = 215 ' precalculated value: for 128 + (ColorBits - 1) * 16 + (BitsPixel - 1)
PUT MakeGif_GIFfile, , a1
'throw a zero into the GIF file; reserved for future expansion of format (which will never come)
a$ = CHR$(0)
PUT MakeGif_GIFfile, , a$
'Get the RGB palette from the screen and put it into the file...
FOR a1 = 0 TO 255
'Note: a BIOS call could be used here, but then we have to use
'the messy CALL INTERRUPT subs...
R = _RED(a1, image&)
G = _GREEN(a1, image&)
B1 = _BLUE(a1, image&)
a$ = CHR$(R): PUT MakeGif_GIFfile, , a$
a$ = CHR$(G): PUT MakeGif_GIFfile, , a$
a$ = CHR$(B1): PUT MakeGif_GIFfile, , a$
NEXT
'write out an image descriptor...
a$ = "," '"," is image seperator
PUT MakeGif_GIFfile, , a$ 'write it
PUT MakeGif_GIFfile, , MakeGif_MinX 'write out the image's location
PUT MakeGif_GIFfile, , MakeGif_MinY
ImageWidth = (MakeGif_MaxX - MakeGif_MinX + 1) 'find length & width of image
ImageHeight = (MakeGif_MaxY - MakeGif_MinY + 1)
PUT MakeGif_GIFfile, , ImageWidth 'store them into the file
PUT MakeGif_GIFfile, , ImageHeight
a$ = CHR$(BitsPixel - 1) '# bits per pixel in the image
PUT MakeGif_GIFfile, , a$
a$ = CHR$(StartSize - 1) 'store the LZW minimum code size
PUT MakeGif_GIFfile, , a$
'Initialize the vars needed by PutCode
MakeGif_CurrnetBit = 0: MakeGif_Char = 0
MaxCode = StartMax 'the current maximum code size
MakeGif_CodeSize = StartSize 'the current code size
ClearCode = StartCode 'ClearCode & EOF code are the
EOFCode = StartCode + 1 ' first two entries
StartCode = StartCode + 2 'first free code that can be used
NextCode = StartCode 'the current code
MakeGif_OutBuffer = STRING$(5000, 32) 'output buffer; for speedy disk writes
a2& = SADD(MakeGif_OutBuffer) 'find address of buffer
a2& = a2& - 65536 * (a2& < 0)
MakeGif_OSeg = VARSEG(MakeGif_OutBuffer) + (a2& \ 16) 'get segment + offset >> 4
MakeGif_OAddress = a2& AND 15 'get address into segment
MakeGif_OEndAddress = MakeGif_OAddress + 5000 'end of disk buffer
MakeGif_OStartAddress = MakeGif_OAddress 'current location in disk buffer
DEF SEG = MakeGif_OSeg
FOR a1 = 0 TO Table.Size - 1 'clears the hashing table
Prefix(a1) = -1 '-1 = invalid entry
Suffix(a1) = -1
code(a1) = -1
NEXT
PutCode ClearCode ' clear code
MakeGif_X = Xstart: MakeGif_Y = YStart 'MakeGif_X & MakeGif_Y have the current pixel
Prefix = GetByte 'the first pixel is a special case
MakeGif_Done = 0 '-1 when image is complete
DO 'while there are more pixels to encode
DO 'until we have a new string to put into the table
'get a pixel from the screen and see if we can find
'the new string in the table
Suffix = GetByte
GOSUB Hash 'is it there?
IF Found = -1 THEN Prefix = code(index) 'yup, replace the
'prefix:suffix string with whatever
'code represents it in the table
LOOP WHILE Found AND NOT MakeGif_Done 'don't stop unless we find a new string
PutCode Prefix 'output the prefix to the file
Prefix(index) = Prefix 'put the new string in the table
Suffix(index) = Suffix
code(index) = NextCode 'we've got to keep track if what code this is!
Prefix = Suffix 'Prefix=the last pixel pulled from the screen
NextCode = NextCode + 1 'get ready for the next code
IF NextCode = MaxCode + 1 THEN 'can an output code ever exceed
'the current code size?
'yup, increase the code size
MaxCode = MaxCode * 2
'Note: The GIF89a spec mentions something about a deferred clear
'code. When the clear code is deferred, codes are not entered
'into the hash table anymore. When the compression of the image
'starts to fall below a certain threshold, the clear code is
'sent and the hash table is cleared. The overall result is
'greater compression, because the table is cleared less often.
'This version of MakeGIF doesn't support this, because some GIF
'decoders crash when they attempt to enter too many codes
'into the string table.
IF MakeGif_CodeSize = 12 THEN 'is the code size too big?
PutCode ClearCode 'yup; clear the table and
FOR a1 = 0 TO Table.Size - 1 'clears the hashing table
Prefix(a1) = -1 '-1 = invalid entry
Suffix(a1) = -1
code(a1) = -1
NEXT
NextCode = StartCode
MakeGif_CodeSize = StartSize
MaxCode = StartMax
ELSE
MakeGif_CodeSize = MakeGif_CodeSize + 1 'just increase the code size if
END IF 'it's not too high( not > 12)
END IF
LOOP UNTIL MakeGif_Done 'while we have more pixels
'Once MakeGif_Done, write out the last pixel, clear the disk buffer
'and fix up the last block so its count is correct
PutCode Prefix 'write last pixel
PutCode EOFCode 'send EOF code
IF MakeGif_CurrnetBit <> 0 THEN
PutCode 0 'flush out the last code...
END IF
PutByte 0
MakeGif_OutBuffer = LEFT$(MakeGif_OutBuffer, MakeGif_OAddress - MakeGif_OStartAddress)
PUT MakeGif_GIFfile, , MakeGif_OutBuffer
a$ = ";" + STRING$(8, &H1A) 'the 8 EOF chars is not standard,
'but many GIF's have them, so how
'much could it hurt?
PUT MakeGif_GIFfile, , a$
a$ = CHR$(255 - MakeGIF_BlockLength) 'correct the last block's count
PUT MakeGif_GIFfile, MakeGif_LastLoc, a$
CLOSE MakeGif_GIFfile
_DEST D: _SOURCE S 'restore the destination and source now that we're done.
EXIT SUB 'so we won't have any issues trying to run the hash routines below.
'this is only one of a plethora of ways to search the table for
'a match! I used a binary tree first, but I switched to hashing
'cause it's quicker(perhaps the way I implemented the tree wasn't
'optimal... who knows!)
Hash:
'hash the prefix & suffix(there are also many ways to do this...)
'?? is there a better formula?
index = ((Prefix * 256&) XOR Suffix) MOD Table.Size
'
'(Note: the table size(7177 in this case) must be a prime number, or
'else there's a chance that the routine will hang up... hate when
'that happens!)
'
'Calculate an offset just in case we don't find what we want on the
'first try...
IF index = 0 THEN 'can't have Table.Size-0 !
Offset = 1
ELSE
Offset = Table.Size - index
END IF
DO 'until we (1) find an empty entry or (2) find what we're lookin for
IF code(index) = -1 THEN 'is this entry blank?
Found = 0 'yup- we didn't find the string
RETURN
'is this entry the one we're looking for?
ELSEIF Prefix(index) = Prefix AND Suffix(index) = Suffix THEN
'yup, congrats you now understand hashing!!!
Found = -1
RETURN
ELSE
'shoot! we didn't find anything interesting, so we must
'retry- this is what slows hashing down. I could of used
'a bigger table, that would of speeded things up a little
'because this retrying would not happen as often...
index = index - Offset
IF index < 0 THEN 'too far down the table?
'wrap back the index to the end of the table
index = index + Table.Size
END IF
END IF
LOOP
END SUB
'Puts a byte into the GIF file & also takes care of each block.
SUB PutByte (a) STATIC
MakeGIF_BlockLength = MakeGIF_BlockLength - 1 'are we at the end of a block?
IF MakeGIF_BlockLength <= 0 THEN ' yup,
MakeGIF_BlockLength = 255 'block length is now 255
MakeGif_LastLoc = LOC(MakeGif_GIFfile) + 1 + (MakeGif_OAddress - MakeGif_OStartAddress) 'remember the pos.
BufferWrite 255 'for later fixing
END IF
BufferWrite a 'put a byte into the buffer
END SUB
'Puts an LZW variable-bit code into the output file...
SUB PutCode (a) STATIC
MakeGif_Char = MakeGif_Char + a * 2 ^ MakeGif_CurrnetBit 'put the char were it belongs;
MakeGif_CurrnetBit = MakeGif_CurrnetBit + MakeGif_CodeSize ' shifting it to its proper place
DO WHILE MakeGif_CurrnetBit > 7 'do we have a least one full byte?
PutByte MakeGif_Char AND 255 ' yup! mask it off and write it out
MakeGif_Char = MakeGif_Char \ 256 'shift the bit buffer right 8 bits
MakeGif_CurrnetBit = MakeGif_CurrnetBit - 8 'now we have 8 less bits
LOOP 'until we don't have a full byte
END SUB
SUB BufferWrite (a) STATIC
IF MakeGif_OAddress = MakeGif_OEndAddress THEN 'are we at the end of the buffer?
PUT MakeGif_GIFfile, , MakeGif_OutBuffer ' yup, write it out and
MakeGif_OAddress = MakeGif_OStartAddress ' start all over
END IF
POKE MakeGif_OAddress, a 'put byte in buffer
MakeGif_OAddress = MakeGif_OAddress + 1 'increment position
END SUB
'This routine gets one pixel from the display.
FUNCTION GetByte STATIC
GetByte = POINT(MakeGif_X, MakeGif_Y) 'get the "byte"
MakeGif_X = MakeGif_X + 1 'increment MakeGif_X coordinate
IF MakeGif_X > MakeGif_MaxX THEN 'are we too far?
MakeGif_X = MakeGif_MinX 'go back to start
MakeGif_Y = MakeGif_Y + 1 'increment MakeGif_Y coordinate
IF MakeGif_Y > MakeGif_MaxY THEN 'are we too far down?
MakeGif_Done = -1 ' yup, flag it then
END IF
END IF
END FUNCTION
'%%%%%%%%%%%%%%%%%%%%%%%%%%%END OF GIF STUFF%%%%%%%%%%%%%%%%%%%%%%%%%%%%
As you can see from the wiki, it's based off the same code this is: Routine v1.00 By Rich Geldreich 1992
Two problems I really have with the current version in the wiki:
1) A lot of the comments were stripped out and edited for some reason from the program, such as the wiki containing the single line: DO 'until we have a new string to put into the table
When, the original of Rich's had it written up as: DO 'until we have a new string to put into the table 'get a pixel from the screen and see if we can find 'the new string in the table
There's also a long comment which the wiki has as just: 'Note: The GIF89a spec mentions something about a deferred clear code
Whereas, the original has this to say for us: 'Note: The GIF89a spec mentions something about a deferred clear 'code. When the clear code is deferred, codes are not entered 'into the hash table anymore. When the compression of the image 'starts to fall below a certain threshold, the clear code is 'sent and the hash table is cleared. The overall result is 'greater compression, because the table is cleared less often. 'This version of MakeGIF doesn't support this, because some GIF 'decoders crash when they attempt to enter too many codes 'into the string table.
Needless to say, I personally am glad I stumbled across an old version of Rich's code on my hard drives, as I'm definitely finding the unedited comments a lot better to help me understand what's going on where, and why.
2) The second problem I have with the wiki version is the fact that it requires a DEFINT, without bothering to specify that (see it hidden away in the "main program"?), which led me to countless hours trying to sort out WHY the wiki version was working with the wiki example, and not with anything I actually tried to use it with...
3) (And I'll toss in a free, bonus problem #3 for you guys!) Even after it got it up and going, it wasn't going very fast for me. (Relatively speaking.) I figured there must be a way to speed the routines up, so I dug around on the old drives, looking to see how I'd did such things before, in the past, and that's when I stumbled upon Rich's actual old code...
So, having the original to work with now, I started playing around with what would be needed to speed it up a bit and make it faster for us in QB64, while working to keep all the comments to help others understand what's going on inside the code. I took out several of the old OUT statements and replaced them with a much simpler _RED, _GREEN, _BLUE version of things. I explicitedly dimmed all the variables so they wouldn't cause any issues with OPTION _EXPLICIT. Fixed a glitch where it was checking the LOC(1) and not the LOC(GIFfile)....
A few tweaks here, a few minor changes there, a lot of DIM work.. and I now have the version posted above, which I thought I'd share for whomever might be interested in studying and learning the GIF format from.
)
