Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60
Dim As Single xc, yc, a, x1, y1, s, e, r, degree10, at, xoff, yoff, radius, x, y, cnt
Dim sa$
Dim cc As _Unsigned Long
degree10 = _Pi(2 / 36)
xc = 400: yc = 300
r = 250
Do
Cls
cc = _RGB32(Rnd * 155 + 100, Rnd * 255, Rnd * 255, Rnd * 200 + 55)
s = Rnd * _Pi(2): e = Rnd * _Pi(2)
For a = 0 To _Pi(1.999) Step degree10
' Regular East = 0 calcs
x1 = xc + r * Cos(a)
y1 = yc + r * Sin(a)
at = Int(_R2D(_Atan2(y1 - yc, x1 - xc)) + .0001)
If at < 0 Then at = at + 360
sa$ = _Trim$(Str$(at))
xoff = _PrintWidth(sa$) / 2
yoff = 16 / 2
_PrintString (x1 - xoff, y1 - yoff), sa$
Next
radius = Rnd * 100 + 100
Arc 400, 300, radius, s, e, cc
PieSlice 400, 300, radius - 10, s, e, cc, 1 ' test all fills !!!!
Print "Start Angle:"; Int(_R2D(s)) ' covert to degrees
Print "End Angle:"; Int(_R2D(e))
Print: Print "zzz, Press any...."
Sleep
Loop Until _KeyDown(27)
Cls
_KeyClear
_Title "Failure if the Screen floods by a bad Paint Job, any ky quits."
Do
cc = _RGB32(Rnd * 155 + 100, Rnd * 255, Rnd * 255, Rnd * 200 + 55)
s = Rnd * _Pi(2): e = Rnd * _Pi(2)
radius = Rnd * 100 + 10
x = Rnd * _Width: y = Rnd * _Height
Arc x, y, radius, s, e, cc
PieSlice x, y, radius - 5, s, e, cc, 1 ' test all fills !!!!
_Limit 1
cnt = cnt + 1
If cnt Mod 50 = 49 Then Cls
Loop While InKey$ = ""
Sub Arc (CX, CY, R, RAStart, RAStop, C~&) ' rev 2024-10-14
'CX, CY Center Circle point, R = radius, C~& = color
' RaStart and RAStop are Radian angles,
' RAStart is first angle clockwise from due East = 0 Radians
' Arc will start drawing there and go clockwise until raEnd is reached
'note in Basic: degrees start due East = 0 and go clockwise
Dim raEnd, stepper, a
If RAStop < RAStart Then raEnd = RAStop + _Pi(2) Else raEnd = RAStop
stepper = 1 / R
For a = RAStart To raEnd Step stepper
If (a - RAStart) < stepper Then
PSet (CX + R * Cos(a), CY + R * Sin(a)), C~&
Else
Line -(CX + R * Cos(a), CY + R * Sin(a)), C~&
End If
Next
End Sub
Sub PieSlice (XC, YC, R, RStart, REnd, C As _Unsigned Long, FillTF) 'rev 2024-10-15
' XC, YC Center for arc circle with radius R
' RStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians
' REnd is Radian End Angle
' Arc will start at rStart and go clockwise around to rEnd Radians
Dim rStop, rMid, stepper, a, x, y
Dim bc As _Unsigned Long
bc = _RGB32(_Red32(C), _Green32(C), _Blue32(C))
If REnd < RStart Then rStop = REnd + _Pi(2) Else rStop = REnd
rMid = rStop - RStart
Line (XC, YC)-(XC + R * Cos(RStart), YC + R * Sin(RStart)), bc
Line (XC, YC)-(XC + R * Cos(rStop), YC + R * Sin(rStop)), bc
stepper = 1 / R ' the bigger the radius the smaller the steps
For a = RStart To rStop Step stepper
x = XC + R * Cos(a)
y = YC + R * Sin(a)
If a > RStart Then Line -(x, y), bc Else PSet (x, y), bc
Next
If FillTF Then Paint (XC + R / 2 * Cos(RStart + rMid / 2), YC + R / 2 * Sin(RStart + rMid / 2)), C, bc
End Sub
Wow, brilliant!! Great job!
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
Please visit my Website at: http://oldendayskids.blogspot.com/
10-29-2024, 01:58 PM (This post was last modified: 10-30-2024, 05:45 PM by bplus.)
Roll Image Down (opens) or Up (closes)
Should fit any image inside a given box on screen and maintain the images width : height ratio.
Code: (Select All)
_Title "Roll Open and Close an Image" ' b+ 2024-10-29
Const SW = 1200, SH = 700
Screen _NewImage(SW, SH, 32): _ScreenMove 0, 0
i = _LoadImage("New PieSlice.PNG")
Do
BoxRollDown 10, 10, _Width - 20, _Height - 20, i, 1
_PrintString (500, _Height - 40), "Press any to roll up."
Sleep
Cls
BoxRollDown 10, 10, _Width - 20, _Height - 20, i, 0
_PrintString (500, _Height - 40), "Press any to roll down."
Sleep
Cls
Loop
Sub BoxRollDown (x, y, w, h, i, DownTF)
' not likely the box w, h is same scale as image w, h
' so what fits what?
saveAD = _AutoDisplay
iw = _Width(i)
ih = _Height(i)
wR = w / iw
hR = h / ih
If wR < hR Then ' use w scale to accommodate smallest change
scale = w / iw
xo = 0: yo = (h - ih * scale) / 2
Else ' use h to accomadate smallest change
scale = h / ih
xo = (w - iw * scale) / 2: yo = 0
End If
' mult scale to fit box
Line (x, y)-Step(w, h), , B ' draw box
Line (x + xo, y + yo)-Step(iw * scale, ih * scale), &HFFFFFF00, B ' fit image inside
If DownTF Then
For yy = 0 To ih
_PutImage (x + xo, y + yo)-Step(iw * scale, yy * scale), i, 0, (0, 0)-(iw, yy)
_Display
_Limit 120
Next
Else
For yy = ih To 0 Step -1
Line (x + xo, y + yo)-Step(iw * scale, ih * scale), &HFF000000, BF
Line (x + xo, y + yo)-Step(iw * scale, ih * scale), &HFFFFFF00, B ' fit image inside
_PutImage (x + xo, y + yo)-Step(iw * scale, yy * scale), i, 0, (0, 0)-(iw, yy)
_Display
_Limit 120
Next
End If
If saveAD Then _AutoDisplay
End Sub
"Preserving width : height ratio", and thereby NOT distorting the images circles or text beyond recognition.
This is a way to draw lines from a Point x, y at an angle for a given length, fatness and color.
I used it to boldly present the Maze lines in Flipping Hex Maze code. Also included is FatLine which needs the Circle Fill sub FCirc. Here is the demo:
Code: (Select All)
_Title "FatPALline test" 'b+ 2024-11-01
Screen _NewImage(801, 590, 32): _ScreenMove 240, 60
Type BoardType
As Single x, y, flipped, flipping, a
End Type
Dim Shared ubX, ubY
ubX = 18: ubY = 16
Dim Shared b(ubX, ubY) As BoardType
Dim Shared cellR, xspacing!, yspacing!
cellR = 25
xspacing! = 2 * cellR * Cos(_D2R(30)): yspacing! = cellR * (1 + Sin(_D2R(30)))
Dim xoffset!
Color &HFF000000, &HFFAAAAFF
Do
m = (m + 1) Mod ubX
Cls
For y = 0 To ubY
If y Mod 2 = 0 Then xoffset! = .5 * xspacing! Else xoffset! = 0
For x = 0 To ubX
b(x, y).x = x * xspacing! + xoffset! + .5 * xspacing! - 20
b(x, y).y = y * yspacing! + .5 * yspacing! - 20
If Rnd < .002 Then b(x, y).flipping = 1
showCell x, y
Next
Next
_Display
_Limit 60
Loop
Sub showCell (c, r)
If b(c, r).flipping Then b(c, r).a = b(c, r).a + _Pi(1 / 90)
If b(c, r).a >= _Pi(1 / 3) Then
b(c, r).flipping = 0: b(c, r).a = 0
If b(c, r).flipped Then b(c, r).flipped = 0 Else b(c, r).flipped = 1
End If
If b(c, r).flipped Then
For a = _Pi(1 / 6) To _Pi(2) Step _Pi(2 / 3)
FatPALline b(c, r).x, b(c, r).y, a + b(c, r).a, cellR, 4, &HFF000000
Next
Else
For a = _Pi(.5) To _Pi(2) Step _Pi(2 / 3)
FatPALline b(c, r).x, b(c, r).y, a + b(c, r).a, cellR, 4, &HFF000000
Next
End If
End Sub
' ++++++++++++++++++ Featured Subroutines for Drawing +++++++++++++++++++++++
' needs Fcirc because needs FatLine
Sub FatPALline (BaseX, BaseY, RAngle, Lngth, Fat, K As _Unsigned Long) ' point angle length line
Dim x2, y2
x2 = BaseX + Lngth * Cos(RAngle)
y2 = BaseY + Lngth * Sin(RAngle)
FatLine BaseX, BaseY, x2, y2, Fat, K
End Sub
' 2023-09-27 000Test/Graphics/FatLine test and demo
Sub FatLine (x, y, x2, y2, wide As Integer, c As _Unsigned Long)
' this sub needs fcirc
Dim dx, dy, distance, r
dx = x2 - x
dy = y2 - y
distance = _Hypot(dx, dy)
r = Int(wide / 2)
If distance Then ' bullet proof
dx = dx / distance
dy = dy / distance
If r = 0 Then
Line (x, y)-(x2, y2), c
Else
Dim i As Long
While i <= distance
FCirc x + i * dx, y + i * dy, r, c
i = i + 1
Wend
End If
Else
If r = 0 Then ' bullet proof
PSet (x, y), c
Else
FCirc x, y, r, c
End If
End If
End Sub
Sub FCirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
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 Sub
_Title "Vince sphere hold mouse for grid then drag mouse to rotate, wheel to zoom." 'bplus mod vince code 2025-02-09
DefDbl A-Z
Dim Shared pi, p, q, uu, vv
zoom = 200
sw = 800
sh = 600
Screen _NewImage(sw, sh, 32)
'img = _LoadImage("Worldmap.png")
img = _LoadImage("bluemarble_small.png")
w = _Width(img)
h = _Height(img)
pi = 4 * Atn(1)
du = 2 * pi / 24
dv = pi / 14
vv = -pi / 6
drag = 0
_Source img
_Dest 0
Do
oz = zoom
Do
mx = _MouseX
my = _MouseY
mb = _MouseButton(1)
zoom = zoom - 10 * _MouseWheel
Loop While _MouseInput
Cls
'uu = uu + 0.01
'vv = vv + 0.01
If mb And drag = 1 Then
uu = (mx - omx) * pi / sh ' from -mx
vv = (my - omy) * pi / sh
End If
If mb And drag = 0 Then
omx = mx
omy = my
drag = 1
End If
If mb = 0 And drag = 1 Then
drag = 0
End If
For v = -pi / 2 To pi / 2 - .5 / zoom Step 1 / zoom '3/zoom ' bplus fix
For u = 0 To 2 * pi - .5 / zoom Step 1 / zoom ' 3/zoom ' bplus fix
r = Cos(v)
z = Sin(v)
x = r * Cos(u)
y = r * Sin(u)
xx = x
yy = y
zz = z
rotz x, y, z, uu
rotx x, y, z, vv
sx = 0
sy = -1
sz = 0
proj xx, yy, zz
pp = sw / 2 + zoom * p
qq = sh / 2 - zoom * q
If pp > 0 And pp < sw And qq > 0 And qq < sh Then
If (x * sx + y * sy + z * sz) < 0 Then
Dim c As _Unsigned Long
cx = (w * u / (2 * pi)) Mod w
cy = (h - h * (v + pi / 2) / pi) Mod h
c = Point(cx, cy)
PSet (sw / 2 - zoom * p, sh / 2 - zoom * q), c ' bplus fix +zoom in x
End If
End If
Next
Next
If drag Or (zoom <> oz) Then
For v = 0 To 2 * pi Step dv
For u = 0 To 2 * pi Step du
r = Cos(v)
z = Sin(v)
x = r * Cos(u)
y = r * Sin(u)
rotz x, y, z, uu
rotx x, y, z, vv
sx = 0
sy = -1
sz = 0
Color _RGB(100, 100, 100)
If (x * sx + y * sy + z * sz) < 0 Then
r = Cos(v)
proj r * Cos(u), r * Sin(u), Sin(v)
PSet (sw / 2 + zoom * p, sh / 2 - zoom * q)
proj r * Cos(u + du), r * Sin(u + du), Sin(v)
Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)
r = Cos(v + dv)
proj r * Cos(u + du), r * Sin(u + du), Sin(v + dv)
Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)
proj r * Cos(u), r * Sin(u), Sin(v + dv)
Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)
r = Cos(v)
proj r * Cos(u), r * Sin(u), Sin(v)
Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)
End If
Next
Next
End If
_Limit 30
_Display
Loop Until _KeyHit = 27
Sleep
System
Sub proj (x, y, z)
'p = x + 0.707*y
'q = z + 0.707*y
rotz x, y, z, uu
rotx x, y, z, vv
d = 10
p = x * d / (10 + y)
q = z * d / (10 + y)
End Sub
Sub rotx (x, y, z, a)
xx = x
yy = y * Cos(a) - z * Sin(a)
zz = y * Sin(a) + z * Cos(a)
x = xx
y = yy
z = zz
End Sub
Sub roty (x, y, z, a)
xx = x * Cos(a) + z * Sin(a)
yy = y
zz = -x * Sin(a) + z * Cos(a)
x = xx
y = yy
z = zz
End Sub
Sub rotz (x, y, z, a)
xx = x * Cos(a) - y * Sin(a)
yy = x * Sin(a) + y * Cos(a)
zz = z
_Title "Outline Image: a few SLEEP steps press any..." 'b+ update OutLine Image 2025-02-13
' original code was from 2020-10-28 when Dav was working on coloring app around Halloween.
' Attempt at making a coloring book outlines.
' Results: well maybe this will help layout your masterpiece :)
' The last image is black outlines with shading or grey level hints
DefLng A-Z
Dim Shared xmax, ymax
iFile$ = _OpenFileDialog$("Select an Image to Outline", _CWD$, "*.png|*.jpg", "Image Files")
If iFile$ <> "" Then
img = _LoadImage(iFile$, 32)
xmax = _Width(img&)
ymax = _Height(img&)
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim gs(xmax, ymax), gs2(xmax, ymax)
_PutImage , img
nRound = 64 'this rounds to 4 shades of gray <<< fiddle with this number dividing 256 for a shade grade
For y = 0 To ymax - 1
For x = 0 To xmax - 1
c~& = Point(x, y)
r = _Red32(c~&)
g = _Green32(c~&)
b = _Blue32(c~&)
gs(x, y) = Int(((r + g + b) / 3) / nRound) * nRound 'round the grey
Next
Next
Sleep
Color , &HFFFFFFFF: Cls
For y = 0 To ymax - 1
For x = 0 To xmax - 1
PSet (x, y), _RGB32(gs(x, y), gs(x, y), gs(x, y), 90)
Next
Next
Sleep
Color , &HFFFFFFFF: Cls
For y = 0 To ymax - 1
For x = 0 To xmax - 1
If gs(x, y) <> gs(x + 1, y) Then PSet (x, y), &HFF000000: gs2(x, y) = 1
Next
Next
For x = 0 To xmax - 1
For y = 0 To ymax - 1
If gs(x, y) <> gs(x, y + 1) Then PSet (x, y), &HFF000000: gs2(x, y) = 1
Next
Next
Sleep
' adding back in the shades of gray
'Color , &HFFFFFFFF: Cls
'For x = 0 To xmax - 1
' For y = 0 To ymax - 1
' If gs2(x, y) Then PSet (x, y), &HFF000000
' Next
'Next
'For y = 0 To ymax - 1
' For x = 0 To xmax - 1
' PSet (x, y), _RGB32(gs(x, y), gs(x, y), gs(x, y), 90)
' Next
'Next
End If
