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!
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.
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.
)
