+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Drawing Tools Subs or Functions with Demo (/showthread.php?tid=272)
RE: Drawing Tools Subs or Functions with Demo - James D Jarvis - 05-02-2022
After figuring out a way to test it: by slapping a 30 by 30 btimap into the top left had corner of the screen and scanning each pixel with point I was able to determine rotozoom (either version with degrees or radians) was stretching the image by 1 pixel to the right and down. There is no data loss at this size because the whole source image is placed on the screen but it results in the 30 x 30 pixel source image becoming a 31 by 31 image when put on the screen.
RE: Drawing Tools Subs or Functions with Demo - bplus - 05-03-2022
Update @James D Jarvis sorry, didn't want to look like I ignored your comment. I just don't know what to do about it. I've wasted quite some time trying to get better results off some RotoZomm images and failed. You seem to report a distortion due to increase in image size but I see Galleon code does subtract 1 from W and H when starting from 0,0 so IDK?
_________________________________________________________________________________________________________________
Plasma Laser Canon (PLC)
Code: (Select All)
_Title "Plasma Laser Cannon demo" 'b+ 2020-11-11
Screen _NewImage(1024, 700, 32)
_Delay .25
_ScreenMove _Middle
Randomize Timer
Dim Shared tx, ty, tr, tc As _Unsigned Long
newTarget
Do
Cls
'PRINT tx, ty, tr, tc
drawBall tx, ty, tr, tc
drawShip _Width / 2, _Height / 2, &HFF3366AA
While _MouseInput: Wend 'aim with mouse
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
PLC _Width / 2, _Height / 2, _MouseX, _MouseY, tr
_Display
End If
If _Hypot(mx - tx, my - ty) < tr And mb Then
For r = 0 To 255
fcirc tx, ty, r, _RGBA32(255, 255 - r, 0, 10)
_Display
_Limit 400
Next
newTarget
End If
If InKey$ = " " Then newTarget
_Display
_Limit 60
Loop Until _KeyDown(27)
Sub newTarget
If Rnd < .5 Then
If Rnd < .5 Then tx = Rnd * 200 + 50 Else tx = _Width - 250 + Rnd * 200
ty = Rnd * (_Height - 100) + 50
Else
If Rnd < .5 Then ty = Rnd * 200 + 50 Else ty = _Height - 250 + Rnd * 100
tx = Rnd * (_Width - 100) + 50
End If
tr = Rnd * 50 + 20
tc = _RGB32(60 + Rnd * 195, Rnd * 255, Rnd * 255)
End Sub
Sub PLC (baseX, baseY, targetX, targetY, targetR) ' PLC for PlasmaLaserCannon
r = Rnd ^ 2 * Rnd: g = Rnd ^ 2 * Rnd: b = Rnd ^ 2 * Rnd: hp = _Pi(.5) ' red, green, blue, half pi
ta = _Atan2(targetY - baseY, targetX - baseX) ' angle of target to cannon base
dist = _Hypot(targetY - baseY, targetX - baseX) ' distance cannon to target
dr = targetR / dist
For r = 0 To dist Step .25
x = baseX + r * Cos(ta)
y = baseY + r * Sin(ta)
c = c + .3
fcirc x, y, dr * r, _RGB32(128 + 127 * Sin(r * c), 128 + 127 * Sin(g * c), 128 + 127 * Sin(b * c))
Next
For rr = dr * r To 0 Step -.5
c = c + 1
fcirc x, y, rr, _RGB32(128 + 127 * Sin(r * c), 128 + 127 * Sin(g * c), 128 + 127 * Sin(b * c))
Next
End Sub
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
Sub drawShip (x, y, colr As _Unsigned Long) 'shipType collisions same as circle x, y radius = 30
Static ls
Dim light As Long, r As Long, g As Long, b As Long
r = _Red32(colr): g = _Green32(colr): b = _Blue32(colr)
fellipse x, y, 6, 15, _RGB32(r, g - 120, b - 100)
fellipse x, y, 18, 11, _RGB32(r, g - 60, b - 50)
fellipse x, y, 30, 7, _RGB32(r, g, b)
For light = 0 To 5
fcirc x - 30 + 11 * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
Next
ls = ls + 1
If ls > 5 Then ls = 0
End Sub
Sub fellipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
If xr = 0 Or yr = 0 Then Exit Sub
Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
Dim x As Long, y As Long
w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
Line (CX - xr, CY)-(CX + xr, CY), C, BF
Do While y < yr
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub
'vince version fill circle x, y, radius, color
Sub vfcirc (x As Long, y As Long, R As Long, C As _Unsigned Long)
Dim x0 As Long, y0 As Long, e As Long
x0 = R: y0 = 0: e = 0
Do While y0 < x0
If e <= 0 Then
y0 = y0 + 1
Line (x - x0, y + y0)-(x + x0, y + y0), C, BF
Line (x - x0, y - y0)-(x + x0, y - y0), C, BF
e = e + 2 * y0
Else
Line (x - y0, y - x0)-(x + y0, y - x0), C, BF
Line (x - y0, y + x0)-(x + y0, y + x0), C, BF
x0 = x0 - 1: e = e - 2 * x0
End If
Loop
Line (x - R, y)-(x + R, y), C, BF
End Sub
'from Steve Gold standard
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End SubA little fun! Along with code for the PLC you get my famous space ship drawing sub.
RE: Drawing Tools Subs or Functions with Demo - James D Jarvis - 05-04-2022
I think it has to do with _maptriangle. The added pixels seem to be in the middle. It's not a real "problem" as unless somebody using it to do fine image manipulation it isn't noticeable. If I hadn't been titling fairly small bitmaps I wouldn't have noticed.
(no problem on the speed of response, this a forum thread...any response is good)
RE: Drawing Tools Subs or Functions with Demo - Pete - 05-04-2022
So you're the guy dropping Big Foot off in the woods! Mystery solved, and Pete likes the spaceship!
Pete
RE: Drawing Tools Subs or Functions with Demo - bplus - 05-04-2022
Dang! I thought I was the guy drawing crop circles.
https://qb64phoenix.com/forum/showthread.php?tid=101
RE: Drawing Tools Subs or Functions with Demo - bplus - 05-25-2022
Image to Sphere and Rotate
2 Sample Demos:
Code: (Select All)
_Title "Cheese + Sphere = Moon" 'b+ 2022-05-20
Randomize Timer
Const wW = 1280, wH = 720
Screen _NewImage(wW, wH, 32)
_ScreenMove 80, 0
_MouseHide
stars& = _LoadImage("stars.png")
Dim map(1 To 2) As Long
For i = 1 To 2
map(i) = growCheese&
_PutImage , map(i), 0
Next
Do While _KeyDown(27) = 0
Cls
For i = 1 To 2
Select Case i
Case 1: x = 300: y = 175: rr = 120
Case 2: x = 900: y = 500: rr = 350
Case 3: x = 1175: y = 525: rr = 90
Case 4: x = 300: y = 540: rr = 151
End Select
xoff = (_Width(map&(i)) + xoff - _Height(map&(i)) / 360) Mod _Width(map&(i))
projectImagetoSphere map(i), x, y, rr, xoff
Next
_Display
_Limit 60
Loop
Sub projectImagetoSphere (image&, x0, y0, sr, xo)
r = _Height(image&) / 2
iW = _Width(image&) - 20
iH = _Height(image&)
scale = sr / r
For y = -r To r
x1 = Sqr(r * r - y * y)
tv = (_Asin(y / r) + 1.5) / 3
For x = -x1 + 1 To x1
tu = (_Asin(x / x1) + 1.5) / 6
_Source image&
pc~& = Point((xo + tu * iW) Mod iW, tv * iH)
_Dest 0
PSet (x * scale + x0, y * scale + y0), pc~&
Next x
Next y
End Sub
Function growCheese& () 'make this more self contained than first version, all hole stuff just in here
curr& = _Dest
map& = _NewImage(wW, wH, 32)
_Dest map&
nHoles = Rnd * 200 + 50: maxHoleLife = 10: maxHoleRadius = Rnd * 10 + 7: tfStart = 1
Dim hx(nHoles), hy(nHoles), hLife(nHoles)
For i = 1 To nHoles
GoSub newHole
Next
r = Rnd * 155 + 100: g = Rnd * 255: b = Int(Rnd * 2) * (Rnd * 155 + 100)
tfStart = 0
For layr = 1 To 30
Line (0, 0)-(wW, wH), _RGBA32(r, g, b, 50), BF 'layer of cheese
For i = 1 To nHoles 'holes in layer
If hLife(i) + 1 > maxHoleLife Then GoSub newHole Else hLife(i) = hLife(i) + 1
hx(i) = hx(i) + Rnd * 2 - 1
hy(i) = hy(i) + Rnd * 2 - 1
If hLife(i) < maxHoleRadius Then
radius = hLife(i)
ElseIf maxHoleLife - hLife(i) < maxHoleRadius Then
radius = maxHoleLife - hLife(i)
Else
radius = maxHoleRadius
End If
Color _RGBA32(0, 0, 0, 80)
fcirc hx(i), hy(i), radius
Next
Next
_Dest curr&
growCheese& = map&
Exit Function
newHole:
hx(i) = wW * Rnd
hy(i) = wH * Rnd
If tfStart Then hLife(i) = Int(Rnd * maxHoleLife) Else hLife(i) = 1
Return
End Function
'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long
subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0
If subRadius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End SubHere's one with Earth Map and a Grid Image placed over it:
Code: (Select All)
_Title "Image to Sphere" 'b+ 2022-05-23
Randomize Timer
Const wW = 1280, wH = 720
Screen _NewImage(wW, wH, 32)
_ScreenMove 65, 0
'_MouseHide
map& = _LoadImage("worldmap.png")
mw& = _Width(map&)
mh& = _Height(map&)
grid& = _NewImage(mw&, mh&, 32)
_Dest grid&
Color &HFF000000
drawGrid 0, 0, (mw& - 1) / 36, (mh& - 1) / 18, 36, 18
_Dest 0
'Color , &HFFFFFFFF ' test grid
'Cls
'_PutImage (0, 0), grid&, 0
'End
While _KeyDown(27) = 0
_PutImage , map&, 0
_PutImage , grid&, 0
xoff = (xoff + 4) Mod (_Width(map&) + 1)
a = a + _Pi(2 / 320)
x = 640 + 330 * Cos(a): y = 360 + 58 * Sin(a)
projectImagetoSphere map&, x, y, 300, xoff
projectImagetoSphere grid&, x, y, 300, xoff
_Display
_Limit 60
Wend
Sub projectImagetoSphere (image&, x0, y0, sr, xo)
r = _Height(image&) / 2
iW = _Width(image&)
iH = _Height(image&)
scale = sr / r
For y = -r To r
x1 = Sqr(r * r - y * y)
tv = (_Asin(y / r) + 1.5) / 3
For x = -x1 + 1 To x1
tu = (_Asin(x / x1) + 1.5) / 6
_Source image&
pc~& = Point((xo + tu * iW) Mod iW, tv * iH)
_Dest 0
PSet (x * scale + x0, y * scale + y0), pc~&
Next x
Next y
End Sub
Sub drawGrid (x, y, xs, ys, xn, yn) ' top left x, y, x side, y side, number of x, nmber of y
Dim As Long i, dx, dy
dx = xs * xn: dy = ys * yn
For i = 0 To xn
Line (x + xs * i, y)-(x + xs * i, y + dy)
Next
For i = 0 To yn
Line (x, y + ys * i)-(x + dx, y + ys * i)
Next
End SubRE: Drawing Tools Subs or Functions with Demo - vince - 05-25-2022
(04-29-2022, 04:54 PM)bplus Wrote: Dang new code box colors started! Cool!
Here is my raw, uncut, unedited, undemo'd listing of drawing subs and functions I store in a file called 000Handy.bas with allot of other stuff
Nice, this is a very handy and fully featured library
RE: Drawing Tools Subs or Functions with Demo - James D Jarvis - 05-25-2022
(05-25-2022, 01:45 AM)bplus Wrote:oooooooh.Image to Sphere and Rotate
RE: Drawing Tools Subs or Functions with Demo - bplus - 05-25-2022
Fade From One Image to Another
Code: (Select All)
Screen _NewImage(320, 300, 32)
YDI& = _NewImage(_Width, _Height, 32)
snap& = _NewImage(_Width, _Height, 32)
Cls
For i = 1 To 40
Line (Rnd * _Width, Rnd * _Height)-Step(Rnd * 50, Rnd * 50), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 255), BF
Next
_PutImage , 0, snap&
Color _RGB32(0, 0, 255), &HFF000000
Cls
_PutImage , snap&, 0
Color &HFFFFFFFF
Locate 2, 5: Print "First image, press any..."
Sleep
Cls
Color &HFF3333FF
Locate 10, 17
Circle (171, 150), 60, &HFFFFAA00
Print "You did it!"
_PutImage , 0, YDI&
Cls
_PutImage , YDI&, 0
Color &HFFFFFFFF
Locate 2, 5: Print "2nd image, press any for fade from first to 2nd images..."
Sleep
Cls
For i = 0 To 100 ' demo gives you control over how fast to transition
Cls
fade snap&, YDI&, i / 100
_Display
_Limit 50 ' 2 secs is good fade time
Next
Beep
Sub fade (img1&, img2&, frac!) ' from img 1 to img 2
For y = 0 To _Height(img1&)
For x = 0 To _Width(img1&)
_Source img1&: p1~& = Point(x, y)
_Source img2&: p2~& = Point(x, y)
PSet (x, y), Ink~&(p1~&, p2~&, frac!)
Next
Next
End Sub
Sub cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub
Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
Dim R1, G1, B1, A1, R2, G2, B2, A2
cAnalysis c1, R1, G1, B1, A1
cAnalysis c2, R2, G2, B2, A2
Ink~& = _RGB32(R1 + (R2 - R1) * fr##, G1 + (G2 - G1) * fr##, B1 + (B2 - B1) * fr##, A1 + (A2 - A1) * fr##)
End FunctionFor a 2nd demo, I used Fade 2 Images for Kaleidoscope, fading from first image to next. A little blip when next image is fully shown:
Code: (Select All)
_Title "Kaleidoscope 2 fade to next" 'b+ mod 2022-05-25
' it so obvious to use maptriangle!
Randomize Timer
Dim Shared sH, sW, sHd2, sWd2
sH = 700: sW = 700: sHd2 = sH / 2: sWd2 = sW / 2
Screen _NewImage(700, 700, 32)
_ScreenMove 290, 0
last& = _NewImage(sW, sH, 32)
nextImg& = _NewImage(sW, sH, 32)
Do Until _KeyDown(27)
_Dest nextImg&
If Rnd > .1 Then Line (0, 0)-(sW - 1, sH - 1), _RGB32(0, 0, 0, 10), BF Else Cls
n = (n + 1) Mod 30 + 3
'If n Mod 2 Then n = n + 1
ReDim px(0 To n - 1), py(0 To n - 1)
circleDivN = _Pi(2 / n)
For i = 0 To n - 1
px(i) = sWd2 + sHd2 * Cos(i * circleDivN)
py(i) = sHd2 + sHd2 * Sin(i * circleDivN)
Next
For i = 1 To 700
Line (Rnd * sW, Rnd * sH)-Step(Rnd * 5, Rnd * 5), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF
Circle (Rnd * sW, Rnd * sH), Rnd * 8 + 2, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
Next
For i = 1 To 30
w = Rnd * 700
Line (sWd2 - w / 2, Rnd * sH)-Step(w, Rnd * 5), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF
Next
For s = 0 To n - 1
For i = 0 To n - 1
_MapTriangle (sWd2, sHd2)-(px((i + s) Mod n), py((i + s) Mod n))-(px((i + 1 + s) Mod n), py((i + 1 + s) Mod n)), nextImg& To(sWd2, sHd2)-(px((i + 2 + s) Mod n), py((i + 2 + s) Mod n))-(px((i + 1 + s) Mod n), py((i + 1 + s) Mod n)), nextImg&
Next
Next
_Dest 0 ' back to screen
For f = 1 To 25
fade last&, nextImg&, f / 25
_Display
_Limit 100
Next
Sound 1100, 1
If last& Then _FreeImage last&
last& = _CopyImage(nextImg&)
Loop
Sub fade (img1&, img2&, frac!) ' from img 1 to img 2
For y = 0 To _Height(img1&)
For x = 0 To _Width(img1&)
_Source img1&: p1~& = Point(x, y)
_Source img2&: p2~& = Point(x, y)
PSet (x, y), Ink~&(p1~&, p2~&, frac!)
Next
Next
End Sub
Sub cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub
Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
Dim R1, G1, B1, A1, R2, G2, B2, A2
cAnalysis c1, R1, G1, B1, A1
cAnalysis c2, R2, G2, B2, A2
Ink~& = _RGB32(R1 + (R2 - R1) * fr##, G1 + (G2 - G1) * fr##, B1 + (B2 - B1) * fr##, A1 + (A2 - A1) * fr##)
End FunctionRE: Drawing Tools Subs or Functions with Demo - SierraKen - 05-26-2022
(04-29-2022, 03:33 PM)bplus Wrote: Rotozoom3 is a great one to kick off this thread, this is freshly minted zip with the sub an image and demo code in a bas source.
Code: (Select All)' Description:
' Started from a mod of Galleon's in Wiki that both scales and rotates an image.
' This version scales the x-axis and y-axis independently allowing rotations of image just by changing X or Y Scales
' making this tightly coded routine a very powerful and versatile image tool.
Sub RotoZoom3 (X As Long, Y As Long, Image As Long, xScale As Single, yScale As Single, radianRotation As Single)
' This assumes you have set your drawing location with _DEST or default to screen.
' X, Y - is where you want to put the middle of the image
' Image - is the handle assigned with _LOADIMAGE
' xScale, yScale - are shrinkage < 1 or magnification > 1 on the given axis, 1 just uses image size.
' These are multipliers so .5 will create image .5 size on given axis and 2 for twice image size.
' radianRotation is the Angle in Radian units to rotate the image
' note: Radian units for rotation because it matches angle units of other Basic Trig functions
' and saves a little time converting from degree.
' Use the _D2R() function if you prefer to work in degree units for angles.
Dim px(3) As Single: Dim py(3) As Single ' simple arrays for x, y to hold the 4 corners of image
Dim W&, H&, sinr!, cosr!, i&, x2&, y2& ' variables for image manipulation
W& = _Width(Image&): H& = _Height(Image&)
px(0) = -W& / 2: py(0) = -H& / 2 'left top corner
px(1) = -W& / 2: py(1) = H& / 2 ' left bottom corner
px(2) = W& / 2: py(2) = H& / 2 ' right bottom
px(3) = W& / 2: py(3) = -H& / 2 ' right top
sinr! = Sin(-radianRotation): cosr! = Cos(-radianRotation) ' rotation helpers
For i& = 0 To 3 ' calc new point locations with rotation and zoom
x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle _Seamless(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle _Seamless(0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
An Image of a spike is manipulated for different uses, see screenshots.
Again I run out of room in post but have unlimited space?
Anyway here is last screen shot and zip.
This RotoZoom nails demo is a great way to make 3D land texture! I didn't even think of this.
