|
Post by tsh73 on Jan 31, 2019 9:41:04 GMT
look-alike.
BTW was confronted with old "not bug but feature": last point in a line is not drawn So my logic check active point if not black draw laser line and fire sparks overtype it with XOR hiding it make last line 1 pixel less so one pixel still at active point visible, (all other picture is restored) - this didn't quite worked
didn't work until I reversed line (that is start drawing from active point to the right) 'Laser engraving (look-alike) 'tsh73 'Jan 2019
nomainwin open "Laser engraving" for graphics_nsb_nf as #gr #gr "trapclose [quit]" #gr "down" #gr "fill black; flush"
#gr "backcolor black" #gr "color 1 1 1" 'almost black, but not exactly '#gr "color white" #gr "place 30 200" #gr "font times_new_roman 60 bold" #gr "\Laser"
#gr "color cyan" 'gives red on black after XOR. Don't ask.
n = 5 r = 20
x0=300 y0=150 x1=35 y1=y0
#gr "rule xor"
for x1 = 30 to 230 for y = 145 to 200 scan hasDot = (GetPixelValue$( x1,y, "#gr")<>"0 0 0") 'print x1,y,hasDot if not(hasDot) then goto [skip] 'print x1,y, hasDot y0=y:y1=y0 'since last point on a line inot drawn, we draw line from LAST point '#gr "line ";x0;" ";y0;" ";x1;" ";y1 #gr "line ";x1;" ";y1;" ";x0;" ";y0 for i = 1 to n a(i)=int(rnd(0)*360) r(i)=int(rnd(0)*r) next for i = 1 to n #gr "place ";x1;" ";y1 #gr "north; turn ";a(i) #gr "go ";r(i) next 'call pause 20'0'00 '#gr "line ";x0;" ";y0;" ";x1+1;" ";y1 '+1 !! #gr "line ";x1+1;" ";y1;" ";x0;" ";y0 for i = 1 to n #gr "place ";x1;" ";y1 #gr "north; turn ";a(i) #gr "go ";r(i) next [skip] next #gr "discard" next #gr "flush"
notice "That's all, folks" wait
[quit] close #gr end
sub pause mil t0=time$("ms") while time$("ms")<t0+mil scan wend exit sub [quit] close #gr end end sub
'***************************************************** 'GetPixelValue$ returns a string with the RGB values of the pixel 'in coordinates x and y in window/graphicbox names handle$ (e.g, "#main.graph") function GetPixelValue$(x, y, handle$)
'Grab a 1*1 bitmap #handle$, "getbmp gpv "; x; " "; y; " "; 1; " "; 1
'Save in a bmp file bmpsave "gpv", "getpvaluetemp.bmp"
'Open the file for string input and get it's full contents open "getpvaluetemp.bmp" for input as #gpv s$ = input$(#gpv, lof(#gpv)) close #gpv
'Check if user's display is 32-bit, and read the red-green-blue values 'If display 16 bit, then colors are masked. So some last (3 for red, 2 for green, 3 for blue) bits always 0 'That means that you did not get 255 255 255 for white - (248 252 248) instead. You have to experiment 'otherwise function returns nothing (support for other display types could be added (?)) bpp = asc(mid$(s$, 29, 1)) select case bpp case 32 red = asc(mid$(s$, 69, 1)) green = asc(mid$(s$, 68, 1)) blue = asc(mid$(s$, 67, 1)) case 16 bytes = asc(mid$( s$, 67, 1)) + 256*asc(mid$( s$, 68, 1)) red = (bytes AND 63488) /256 '0xF800 green = (bytes AND 2016) / 32 * 4 '0x7E0 blue = (bytes AND 31) * 8 '0x1F end select
'concatenate the return value, delete temporary file and free memory GetPixelValue$ = str$(red)+" "+str$(green)+" "+str$(blue) kill "getpvaluetemp.bmp" unloadbmp "gpv" end function
|
|
|
Post by B+ on Jan 31, 2019 18:37:37 GMT
Hi tsh73,
This is pretty nice except I get a couple of errors before it finishes. One is about closing and another is about "is empty".
Ah, another try and finally get to notice "That's all, folks."
|
|
|
Post by tsh73 on Jan 31, 2019 22:35:41 GMT
That's quite weird actually I made it on a fast machine under Win10 And it works without a hitch And pretty fast at that - sparks sparkle, line moves, text done - I never timed it, probably about minute
Now I run it on Win 10 Netbook First I had to adapt with "font 125%" set on it.
#gr "font times_new_roman 0 90 bold" did the trick.
Second I got errors "attempt to kill non-existing file", which is weird since file is read first deleted second. I changed kill line to
on error goto [skip] kill "getpvaluetemp.bmp" [skip]
and it worked. While netbook is about 4 times slower I think on computing tasks, program run may be a bit slower, not that much - 1.5 minutes (this time I timed it)
Now I run it on old WinXP machine (middle performance between first one and netbook on computing tasks) Alas. It practically stays on the spot - it is GetPixelValue$ that slows it down! If you convert
hasDot = (GetPixelValue$( x1,y, "#gr")<>"0 0 0") to
hasDot =1 laser part fill work - but still like 3x slower when on Win 10. Though, GetPixelValue actually used to save work (no laser if no active point) But you'll see no text in that case ;(
Probably should dig into "read whole BMP, then check points in memory" direction.
(and I would say Win 10 is good)
|
|
|
Post by tsh73 on Jan 31, 2019 23:01:48 GMT
Ok. I scavenged "read whole BMP, check pixels from where" from old flood fill program Now it works in XP too Took about 1.5 min on my old machine.
'Laser engraving (look-alike) ' XP version (where reading every pixel via file is slow) 'tsh73 'Jan 2019
'whole bitmap reading - from old project (flood fill one) '------------------------- dim GetPixelResponse$(1,1) 'to be re-dimmed as needed
global getPixelCounter, drawPIXELcounter, getPIXELask 'for optimizing getPixelCounter = 0 'real get pixel getPIXELask = 0 'requested get pixel drawPIXELcounter = 0
global width, height, storedBitmap$ global bmpWidth, bmpHeight, row '-----------------------
nomainwin open "Laser engraving" for graphics_nsb_nf as #gr #gr "trapclose [quit]" #gr "home ; down ; posxy cx cy" width = 2*cx : height = 2*cy #gr "fill black; flush"
#gr "backcolor black" #gr "color 1 1 1" 'almost black, but not exactly '#gr "color white" 'if you want to see text instantly. But it will turn to cian not red #gr "place 30 200" '#gr "font times_new_roman 60 bold" #gr "font times_new_roman 0 90 bold" 'saves font 125% problem #gr "\Laser" call InitForGetPixelValueFromMem "#gr"
#gr "color cyan" 'gives red on black after XOR. Don't ask.
n = 5 r = 20
x0=300 y0=150 x1=35 y1=y0 ooo$=chr$(0)+chr$(0)+chr$(0)
#gr "rule xor" t0=time$("ms") for x1 = 30 to 230 for y = 145 to 200 scan 'hasDot = (GetPixelValue$( x1,y, "#gr")<>"0 0 0") hasDot = (GetPixelValueFromMem$(x1, y)<>ooo$) 'if x1=50 then print x1, getReadablePixel$(GetPixelValueFromMem$(x1, y)) 'if x1=51 then wait 'hasDot =1 'print x1,y,hasDot if not(hasDot) then goto [skip] 'print x1,y, hasDot y0=y:y1=y0 'since last point on a line inot drawn, we draw line from LAST point '#gr "line ";x0;" ";y0;" ";x1;" ";y1 #gr "line ";x1;" ";y1;" ";x0;" ";y0 for i = 1 to n a(i)=int(rnd(0)*360) r(i)=int(rnd(0)*r) next for i = 1 to n #gr "place ";x1;" ";y1 #gr "north; turn ";a(i) #gr "go ";r(i) next call pause 20'0'00 '#gr "line ";x0;" ";y0;" ";x1+1;" ";y1 '+1 !! #gr "line ";x1+1;" ";y1;" ";x0;" ";y0 for i = 1 to n #gr "place ";x1;" ";y1 #gr "north; turn ";a(i) #gr "go ";r(i) next [skip] next #gr "discard" next #gr "flush"
t1=time$("ms") notice "That's all, folks ";t1-t0 wait
[quit] close #gr end
sub pause mil t0=time$("ms") while time$("ms")<t0+mil scan wend exit sub [quit] close #gr end end sub
'***************************************************** 'GetPixelValue$ returns a string with the RGB values of the pixel 'in coordinates x and y in window/graphicbox names handle$ (e.g, "#main.graph") function GetPixelValue$(x, y, handle$)
'Grab a 1*1 bitmap #handle$, "getbmp gpv "; x; " "; y; " "; 1; " "; 1
'Save in a bmp file bmpsave "gpv", "getpvaluetemp.bmp"
'Open the file for string input and get it's full contents open "getpvaluetemp.bmp" for input as #gpv s$ = input$(#gpv, lof(#gpv)) close #gpv
'Check if user's display is 32-bit, and read the red-green-blue values 'If display 16 bit, then colors are masked. So some last (3 for red, 2 for green, 3 for blue) bits always 0 'That means that you did not get 255 255 255 for white - (248 252 248) instead. You have to experiment 'otherwise function returns nothing (support for other display types could be added (?)) bpp = asc(mid$(s$, 29, 1)) select case bpp case 32 red = asc(mid$(s$, 69, 1)) green = asc(mid$(s$, 68, 1)) blue = asc(mid$(s$, 67, 1)) case 16 bytes = asc(mid$( s$, 67, 1)) + 256*asc(mid$( s$, 68, 1)) red = (bytes AND 63488) /256 '0xF800 green = (bytes AND 2016) / 32 * 4 '0x7E0 blue = (bytes AND 31) * 8 '0x1F end select
'concatenate the return value, delete temporary file and free memory GetPixelValue$ = str$(red)+" "+str$(green)+" "+str$(blue) on error goto [skip] kill "getpvaluetemp.bmp" [skip] unloadbmp "gpv" end function
'***************************************************** function GetPixelValueFromMem$(x, y) 'this functiom will return pixel from pre-read (full image) bitmap 'btw bitmap numbered from 0, to (width-1), (height-1). And Y is inverted. getPIXELask = getPIXELask + 1 if GetPixelResponse$(x, y) <> "" then GetPixelValueFromMem$ = GetPixelResponse$(x, y): exit function getPixelCounter = getPixelCounter + 1
i = height - y-1 ' oneLine$ = Mid$(storedBitmap$, i*row+1, row) ' triplet$ = Mid$(oneLine$,x*4,3) triplet$ = Mid$(storedBitmap$,i*row+x*4,3) GetPixelValueFromMem$ = triplet$ GetPixelResponse$(x, y) = triplet$ end function
function getReadablePixel$(triplet$) red = asc(mid$( triplet$, 3, 1)) green = asc(mid$( triplet$, 2, 1)) blue = asc(mid$( triplet$, 1, 1)) getReadablePixel$ = str$(red)+" "+str$(green)+" "+str$(blue) end function
sub InitForGetPixelValueFromMem handle$ 'this thing saves bitmap, reads in bitmap for getPixel 'global width, height, storedBitmap$ 'Grab bitmap #handle$, "getbmp gpv 0 0 "; width; " "; height 'Save in a bmp file fileName$ = "getpvaluetemp.bmp" bmpsave "gpv", fileName$ unloadbmp "gpv"
'this part copied out of Andy Amaya spriteMaker program Open fileName$ For Binary As #bmpIn 'get the length of the file lenFile = LOF(#bmpIn) 'get bmpHeaderInfo info$ = Input$(#bmpIn,66) If Left$(info$,2)<>"BM" And Mid$(info$,29,1)<>Chr$(32) Then Notice "This program works only in Truecolor (millions of colors, JB saves 32-bit windows bitmap)."+Chr$(10)+"Please try again." 'JB saves as 32 or as 16 bit. Now we deal only with 32 end End If 'get width of bmp bmpWidth = Asc(Mid$(info$,19,1))+Asc(Mid$(info$,20,1))*256 'get height of bmp bmpHeight = Asc(Mid$(info$,23,1))+Asc(Mid$(info$,24,1))*256 'but they are just what we saved so could ignore them 'for 32 bit width * 4 ALWAYS divides by 4, so... row = bmpWidth*4
'Set to start of bitmap color triplets Seek #bmpIn,67 'load bitmap data into 'storedBitmap$' storedBitmap$ = Input$(#bmpIn,lenFile-67) Close #bmpIn kill fileName$ 'this also clears mem redim GetPixelResponse$(width,height) end sub
|
|
|
Post by tsh73 on Jan 31, 2019 23:11:41 GMT
Just checked last program under win10 netbook. Same time as before (with file created/read/killed for each pixel). So reading files under Win10 is really fast.
|
|
|
Post by B+ on Feb 1, 2019 17:13:26 GMT
The 2nd version seems better because it worked from get go on my Windows 10 laptop, also like the random spread of laser lines at contact point.
Does "rule xor" cancel out a line when drawn over a 2nd time? I've not seen that before and was wondering how lines were getting cleared.
|
|
|
Post by tsh73 on Feb 1, 2019 20:04:19 GMT
Yes it is. Old trick Then cancelling out I draw long line one pixel short, leaving single point.
|
|
|
Post by tenochtitlanuk on Feb 3, 2019 21:47:21 GMT
Unfortunately doesn't seem to work for text.. after 5 seconds the drawn circle disappears, but not the text.. To erase text I have to overwrite it with a background colour block.
nomainwin
WindowWidth = 400 WindowHeight = 400
open "Graphics" for graphics_nsb as #wg
#wg "trapclose [quit]"
#wg "fill white ; backcolor white" #wg "rule xor ; font 36 ; size 48"
#wg "up ; goto 20 200 ; down" #wg "|Going, going..." #wg "set 100 100"
timer 5000, [moveOn] wait [moveOn] timer 0
#wg "up ; goto 20 200 ; down" #wg "|Going, going..." #wg "set 100 100"
#wg "flush"
wait
[quit] close #wg end
|
|
|
Post by tsh73 on Feb 3, 2019 22:29:27 GMT
I got that it is Windows thing, seen recently in old thread of other BASIC forum
so no font and drawbmp (so not likely change in next version of anything)
|
|
|
Post by tenochtitlanuk on Feb 3, 2019 22:43:02 GMT
I'm used to living with it!
|
|