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, Western Australia.)
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 "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
