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 "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
horizon% = Int(ymax * .6)
For i = 550 To 0 Step -1 ' the sun
FC3 400, horizon%, i, midInk~&(255, 255, 0, 50, 50, 208, i / 550)
Next
For i = horizon% To ymax ' the land
Line (0, i)-(xmax, i), midInk~&(200, 200, 60, 45, 48, 0, (i - horizon%) / (ymax - horizon%))
Next
Sleep
' blend 2 colors according to fractional distance of 2nd to first color
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' fill circle #3 mod
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
horizon% = Int(ymax * .6)
For i = 550 To 0 Step -1 ' the sun
FC3 400, horizon%, i, midInk~&(255, 255, 0, 50, 50, 208, i / 550)
Next
For i = horizon% To ymax ' the land
Line (0, i)-(xmax, i), midInk~&(200, 200, 60, 45, 48, 0, (i - horizon%) / (ymax - horizon%))
Next
For r = 450 To 350 Step -.25
drawArc 400, horizon% + 50, r, _Pi, _Pi, rainbow~&((r - 350) / 100, 40)
Next
Sleep
' blend 2 colors according to fractional distance of 2nd to first color
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' fill circle #3 mod
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
Function rainbow~& (fraction, alpha)
radians = fraction * 2 * _Pi
b = Sin(radians) * 127 + 128
g = Sin(radians - 2 / 3 * _Pi) * 127 + 128
r = Sin(radians + 2 / 3 * _Pi) * 127 + 128
rainbow~& = _RGB32(r, g, b, alpha)
End Function
Sub drawArc (xc, yc, radius, rStart, rMeasure, colr As _Unsigned Long)
' xc, yc Center for arc circle
' rStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians
' rMeasure is the measure of Arc in Radain units, use _D2R for conversion from Degrees to Radians
' Arc will start at rStart and go clockwise around for rMeasure Radians
Dim rEnd, stepper, a, x, y
rEnd = rStart + rMeasure
stepper = 1 / radius ' the bigger the radius the smaller the steps
For a = rStart To rEnd Step stepper
x = xc + radius * Cos(a)
y = yc + radius * Sin(a)
If a > rStart Then Line -(x, y), colr Else PSet (x, y), colr
Next
End Sub
Update: added an Alpha setting to the Rainbow~&(fraction) coloring Function.
05-03-2025, 02:28 PM (This post was last modified: 05-09-2025, 11:06 AM by bplus.)
OK a better? Rainbow with Modified MidInk~& for Alpha control and Modified ROY G BIV adding a much needed Cyan after Green and before Blue.
Code: (Select All)
_Title "Rainbow Test 2 Modified MidInk and ROY G BIV" ' b+ 2025-05-03 ROY G Cyan BIV with modified MidInk~&
Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60
Const xmax = 800
Const ymax = 600
horizon% = Int(ymax * .6)
For a = 0 To 255 Step 5
Cls
For i = 600 To 0 Step -1 ' the sun
FC3 400, horizon% + 50, i, midInk~&(255, 255, 0, 50, 50, 208, i / 600, 200)
Next
For i = horizon% To ymax ' the land
Line (0, i)-(xmax, i), midInk~&(200, 200, 60, 45, 48, 0, (i - horizon%) / (ymax - horizon%), 255)
Next
For r = 400 To 331 Step -.25
If r > 390 Then
c~& = midInk~&(255, 0, 0, 255, 127, 0, 1 - ((r - 390) / 10), a)
ElseIf r > 380 Then
c~& = midInk~&(255, 127, 0, 255, 255, 0, 1 - ((r - 380) / 10), a)
ElseIf r > 370 Then
c~& = midInk~&(255, 255, 0, 0, 255, 0, 1 - ((r - 370) / 10), a)
ElseIf r > 360 Then
c~& = midInk~&(0, 255, 0, 0, 255, 255, 1 - ((r - 360) / 10), a)
ElseIf r > 350 Then
c~& = midInk~&(0, 255, 255, 0, 0, 255, 1 - ((r - 350) / 10), a)
ElseIf r > 340 Then
c~& = midInk~&(0, 0, 255, 75, 0, 230, 1 - ((r - 340) / 10), a)
Else
c~& = midInk~&(75, 0, 230, 248, 0, 211, 1 - ((r - 330) / 10), a)
End If
drawArc 400, horizon% + 50, r, _Pi, _Pi, c~&
Next
_Display
' _Limit 100
Next
Sleep
' 2025-05-03 Modified MidInk~& to control Alpha out put
' blend 2 colors according to fractional distance of 2nd to first color
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##, A%)
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##, A%)
End Function
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' fill circle #3 mod
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
Sub drawArc (xc, yc, radius, rStart, rMeasure, colr As _Unsigned Long)
' xc, yc Center for arc circle
' rStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians
' rMeasure is the measure of Arc in Radain units, use _D2R for conversion from Degrees to Radians
' Arc will start at rStart and go clockwise around for rMeasure Radians
Dim rEnd, stepper, a, x, y
rEnd = rStart + rMeasure
stepper = 1 / radius ' the bigger the radius the smaller the steps
For a = rStart To rEnd Step stepper
x = xc + radius * Cos(a)
y = yc + radius * Sin(a)
If a > rStart Then Line -(x, y), colr Else PSet (x, y), colr
Next
End Sub
Update:
At first I thought this was better than the Rainbow~&(fraction) coloring Function but now with Alpha setting added to maybe not better at all. Rainbow~&(fraction) coloring Function spreads color span very evenly OR I used a too dark a Green for MidInk~&() color Function.
Tweaking numbers and using less alpha, BTW this MidInk~&(fraction) coloring Function is also modified with an Alpha setting!
Code: (Select All)
_Title "Rainbow Test 2 Modified MidInk and ROY G BIV" ' b+ 2025-05-03 ROY G Cyan BIV with modified MidInk~&
Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60
Const xmax = 800
Const ymax = 600
horizon% = Int(ymax * .6)
For a = 0 To 10 Step 5
Cls
For i = 600 To 0 Step -1 ' the sun
FC3 400, horizon% + 50, i, midInk~&(255, 255, 0, 50, 50, 208, i / 600, 200)
Next
For i = horizon% To ymax ' the land
Line (0, i)-(xmax, i), midInk~&(200, 200, 60, 45, 48, 0, (i - horizon%) / (ymax - horizon%), 255)
Next
For r = 400 To 331 Step -.25
If r > 390 Then
c~& = midInk~&(255, 50, 50, 255, 127, 100, 1 - ((r - 390) / 10), a)
ElseIf r > 380 Then
c~& = midInk~&(255, 127, 100, 255, 255, 0, 1 - ((r - 380) / 10), a)
ElseIf r > 370 Then
c~& = midInk~&(255, 255, 0, 100, 255, 100, 1 - ((r - 370) / 10), a)
ElseIf r > 360 Then
c~& = midInk~&(100, 255, 100, 0, 255, 255, 1 - ((r - 360) / 10), a)
ElseIf r > 350 Then
c~& = midInk~&(0, 255, 255, 100, 100, 255, 1 - ((r - 350) / 10), a)
ElseIf r > 340 Then
c~& = midInk~&(100, 100, 255, 75, 0, 230, 1 - ((r - 340) / 10), a)
Else
c~& = midInk~&(75, 0, 230, 248, 0, 211, 1 - ((r - 330) / 10), a)
End If
drawArc 400, horizon% + 50, r, _Pi, _Pi, c~&
Next
_Display
' _Limit 100
Next
Sleep
' 2025-05-03 Modified MidInk~& to control Alpha out put
' blend 2 colors according to fractional distance of 2nd to first color
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##, A%)
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##, A%)
End Function
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' fill circle #3 mod
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
Sub drawArc (xc, yc, radius, rStart, rMeasure, colr As _Unsigned Long)
' xc, yc Center for arc circle
' rStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians
' rMeasure is the measure of Arc in Radain units, use _D2R for conversion from Degrees to Radians
' Arc will start at rStart and go clockwise around for rMeasure Radians
Dim rEnd, stepper, a, x, y
rEnd = rStart + rMeasure
stepper = 1 / radius ' the bigger the radius the smaller the steps
For a = rStart To rEnd Step stepper
x = xc + radius * Cos(a)
y = yc + radius * Sin(a)
If a > rStart Then Line -(x, y), colr Else PSet (x, y), colr
Next
End Sub
01-27-2026, 08:46 PM (This post was last modified: 01-27-2026, 08:48 PM by bplus.)
Mr Amazing Cubed!
This my first attempt at running a gif image. Thank you Wiki and Zom B for setting up code to run Gif Images! For my first attempt lets try running the images thru _MapTriangle!
Code: (Select All)
_Title "Mr Amazing Cubed" ' b+ 2026-01-27 Thank you Wiki and Zom-B !!
Dim Shared Dbg: Dbg = 0 Dim Shared powerOf2&(11) For a = 0 To 11: powerOf2&(a) = 2 ^ a: Next a
Type GIFDATA file As Integer sigver As String * 6 width As _Unsigned Integer height As _Unsigned Integer bpp As _Unsigned _Byte sortFlag As _Byte ' Unused colorRes As _Unsigned _Byte colorTableFlag As _Byte bgColor As _Unsigned _Byte aspect As Single ' Unused numColors As _Unsigned Integer palette As String * 768 End Type
Type FRAMEDATA addr As Long left As _Unsigned Integer top As _Unsigned Integer width As _Unsigned Integer height As _Unsigned Integer localColorTableFlag As _Byte interlacedFlag As _Byte sortFlag As _Byte ' Unused palBPP As _Unsigned _Byte minimumCodeSize As _Unsigned _Byte transparentFlag As _Byte 'GIF89a-specific (animation) values userInput As _Byte ' Unused disposalMethod As _Unsigned _Byte delay As Single transColor As _Unsigned _Byte End Type
Type xy As Single x, y End Type
Screen _NewImage(700, 700, 32) _ScreenMove 300, 0
' draw points for cube 3 faces showing Dim c(0 To 6) As xy c(0).x = 350: c(0).y = 350 For i = 1 To 6 c(i).x = 350 + 340 * Cos(i * _Pi / 3) c(i).y = 350 + 340 * Sin(i * _Pi / 3) Next
Dim sb As Long ' image container sb = _NewImage(_Width, _Height, 32)
' Open gif file. This reads the headers and palette but not the image data. ' The array will be redimentioned to fit the exact number of frames in the file. Dim gifData As GIFDATA, frameData(0 To 0) As FRAMEDATA
filename$ = "steve1973.gif" '<<<<<<<<<<<< Enter a file name here!!!
If Len(filename$) = 0 Then End openGif filename$, gifData, frameData()
' Loop away. frame = 0 Cls , &HFF771017 Do While _KeyDown(27) = 0
' Request a frame. If it has been requested before, it is re-used, ' otherwise it is read and decoded from the file. '_PutImage (0, 0), getGifFrame&(gifData, frameData(), frame) _PutImage , getGifFrame&(gifData, frameData(), frame), sb ' store image in sb container _Delay frameData(frame).delay frame = (frame + 1) Mod (UBound(frameData) + 1)
Sub openGif (filename$, gifData As GIFDATA, frameData() As FRAMEDATA) Static file = FreeFile: gifData.file = file Open "B", gifData.file, filename$
Get file, , gifData.sigver Get file, , gifData.width Get file, , gifData.height Get file, , byte~%% gifData.bpp = (byte~%% And 7) + 1 gifData.sortFlag = (byte~%% And 8) > 0 gifData.colorRes = (byte~%% \ 16 And 7) + 1 gifData.colorTableFlag = (byte~%% And 128) > 0 gifData.numColors = 2 ^ gifData.bpp Get file, , gifData.bgColor Get file, , byte~%% If byte~%% = 0 Then gifData.aspect = 0 Else gifData.aspect = (byte~%% + 15) / 64
If gifData.sigver <> "GIF87a" And gifData.sigver <> "GIF89a" Then _Dest 0: Print "Invalid version": End If Not gifData.colorTableFlag Then _Dest 0: Print "No Color Table": End
palette$ = Space$(3 * gifData.numColors) Get file, , palette$ gifData.palette = palette$ If Dbg And 1 Then Print "sigver ="; gifData.sigver Print "width ="; gifData.width Print "height ="; gifData.height Print "bpp ="; gifData.bpp Print "sortFlag ="; gifData.sortFlag Print "colorRes ="; gifData.colorRes Print "colorTableFlag ="; gifData.colorTableFlag Print "bgColor ="; gifData.bgColor Print "aspect ="; gifData.aspect Print "numColors ="; gifData.numColors For i = 0 To gifData.numColors - 1 Print Using "pal(###) = "; i; Print Hex$(_RGB32(Asc(gifData.palette, i * 3 + 1), Asc(gifData.palette, i * 3 + 2), Asc(gifData.palette, i * 3 + 3))) Next End If Do Get file, , byte~%% If Dbg And 2 Then Print "Chunk: "; Hex$(byte~%%) Select Case byte~%% Case &H2C ' Image Descriptor If frame > UBound(frameData) Then ReDim _Preserve frameData(0 To frame * 2 - 1) As FRAMEDATA End If
Get file, , frameData(frame).left Get file, , frameData(frame).top Get file, , frameData(frame).width Get file, , frameData(frame).height Get file, , byte~%% frameData(frame).localColorTableFlag = (byte~%% And 128) > 0 frameData(frame).interlacedFlag = (byte~%% And 64) > 0 frameData(frame).sortFlag = (byte~%% And 32) > 0 frameData(frame).palBPP = (byte~%% And 7) + 1 frameData(frame).addr = Loc(file) + 1
If frameData(frame).localColorTableFlag Then Seek file, Loc(file) + 3 * 2 ^ frameData(frame).palBPP + 1 End If Get file, , frameData(frame).minimumCodeSize If Dbg And 2 Then Print "addr ="; Hex$(frameData(frame).addr - 1) Print "left ="; frameData(frame).left Print "top ="; frameData(frame).top Print "width ="; frameData(frame).width Print "height ="; frameData(frame).height Print "localColorTableFlag ="; frameData(frame).localColorTableFlag Print "interlacedFlag ="; frameData(frame).interlacedFlag Print "sortFlag ="; frameData(frame).sortFlag Print "palBPP ="; frameData(frame).palBPP Print "minimumCodeSize ="; frameData(frame).minimumCodeSize End If If localColors Then _Dest 0: Print "Local color table": End If frameData(frame).disposalMethod > 2 Then Print "Unsupported disposalMethod: "; frameData(frame).disposalMethod: End skipBlocks file
frame = frame + 1 Case &H3B ' Trailer Exit Do Case &H21 ' Extension Introducer Get file, , byte~%% ' Extension Label If Dbg And 2 Then Print "Extension Introducer: "; Hex$(byte~%%) Select Case byte~%% Case &HFF, &HFE ' Application Extension, Comment Extension skipBlocks file Case &HF9 If frame > UBound(frameData) Then ReDim _Preserve frameData(0 To frame * 2 - 1) As FRAMEDATA End If
Get 1, , byte~%% ' Block Size (always 4) Get 1, , byte~%% frameData(frame).transparentFlag = (byte~%% And 1) > 0 frameData(frame).userInput = (byte~%% And 2) > 0 frameData(frame).disposalMethod = byte~%% \ 4 And 7 Get 1, , delay~% If delay~% = 0 Then frameData(frame).delay = 0.1 Else frameData(frame).delay = delay~% / 100 Get 1, , frameData(frame).transColor If Dbg And 2 Then Print "frame ="; frame Print "transparentFlag ="; frameData(frame).transparentFlag Print "userInput ="; frameData(frame).userInput Print "disposalMethod ="; frameData(frame).disposalMethod Print "delay ="; frameData(frame).delay Print "transColor ="; frameData(frame).transColor End If skipBlocks file Case Else Print "Unsupported extension Label: "; Hex$(byte~%%): End End Select Case Else Print "Unsupported chunk: "; Hex$(byte~%%): End End Select Loop
ReDim _Preserve frameData(0 To frame - 1) As FRAMEDATA End Sub
Sub skipBlocks (file) Do Get file, , byte~%% ' Block Size If Dbg And 2 Then Print "block size ="; byte~%% Seek file, Loc(file) + byte~%% + 1 Loop While byte~%% End Sub
Function getGifFrame& (gifData As GIFDATA, frameData() As FRAMEDATA, frame) If frameData(frame).addr > 0 Then If Dbg And 4 Then Print "addr ="; Hex$(frameData(frame).addr - 1) Print "left ="; frameData(frame).left Print "top ="; frameData(frame).top Print "width ="; frameData(frame).width Print "height ="; frameData(frame).height Print "localColorTableFlag ="; frameData(frame).localColorTableFlag Print "interlacedFlag ="; frameData(frame).interlacedFlag Print "sortFlag ="; frameData(frame).sortFlag Print "palBPP ="; frameData(frame).palBPP Print "minimumCodeSize ="; frameData(frame).minimumCodeSize Print "transparentFlag ="; frameData(frame).transparentFlag Print "userInput ="; frameData(frame).userInput Print "disposalMethod ="; frameData(frame).disposalMethod Print "delay ="; frameData(frame).delay Print "transColor ="; frameData(frame).transColor End If w = frameData(frame).width h = frameData(frame).height img& = _NewImage(w, h, 256) frame& = _NewImage(gifData.width, gifData.height, 256)
_Dest img& decodeFrame gifData, frameData(frame)
_Dest frame& If frameData(frame).localColorTableFlag Then _CopyPalette img& Else For i = 0 To gifData.numColors - 1 _PaletteColor i, _RGB32(Asc(gifData.palette, i * 3 + 1), Asc(gifData.palette, i * 3 + 2), Asc(gifData.palette, i * 3 + 3)) Next End If
If frame Then Select Case frameData(frame - 1).disposalMethod Case 0, 1 _PutImage , frameData(frame - 1).addr Case 2 Cls , gifData.bgColor _ClearColor gifData.bgColor End Select Else Cls , gifData.bgColor End If
If frameData(frame).transparentFlag Then _ClearColor frameData(frame).transColor, img& End If _PutImage (frameData(frame).left, frameData(frame).top), img& _FreeImage img&
If framedata.interlacedFlag Then interlacedPass = 0: interlacedStep = 8 bitPointer = 0 blockSize = 0 blockPointer = 0 x = 0 y = 0
file = gifdata.file Seek file, framedata.addr
If framedata.localColorTableFlag Then palette$ = Space$(3 * 2 ^ framedata.palBPP) Get 1, , palette$
For i = 0 To gifdata.numColors - 1 c& = _RGB32(Asc(palette$, i * 3 + 1), Asc(palette$, i * 3 + 2), Asc(palette$, i * 3 + 3)) _PaletteColor i, c& Next End If
Get file, , byte ' minimumCodeSize
Do GoSub GetCode stackPointer = 0 If code = clearCode Then 'Reset & Draw next color direct nvc = minCode ' \ codeSize = startCodeSize ' Preset default codes maxCode = startMaxCode ' /
GoSub GetCode currentCode = code
lastColor = code colorStack(stackPointer) = lastColor stackPointer = 1 ElseIf code <> endCode Then 'Draw direct color or colors from suffix currentCode = code If currentCode = nvc Then 'Take last color too currentCode = oldCode colorStack(stackPointer) = lastColor stackPointer = stackPointer + 1 End If
While currentCode >= minCode 'Extract colors from suffix colorStack(stackPointer) = suffix(currentCode) stackPointer = stackPointer + 1 currentCode = prefix(currentCode) 'Next color from suffix is described in Wend ' the prefix, else prefix is the last col.
lastColor = currentCode ' Last color is equal to the colorStack(stackPointer) = lastColor ' last known code (direct, or from stackPointer = stackPointer + 1 ' Prefix) suffix(nvc) = lastColor 'Automatically, update suffix prefix(nvc) = oldCode 'Code from the session before (for extracting from suffix) nvc = nvc + 1
If nvc > maxCode And codeSize < 12 Then codeSize = codeSize + 1 maxCode = maxCode * 2 + 1 End If End If
For i = stackPointer - 1 To 0 Step -1 PSet (x, y), colorStack(i) x = x + 1 If x = framedata.width Then x = 0 If framedata.interlacedFlag Then y = y + interlacedStep If y >= framedata.height Then Select Case interlacedPass Case 0: interlacedPass = 1: y = 4 Case 1: interlacedPass = 2: y = 2 Case 2: interlacedPass = 3: y = 1 End Select interlacedStep = 2 * y End If Else y = y + 1 End If End If Next
oldCode = code Loop Until code = endCode
Get file, , byte Exit Sub
GetCode: If bitPointer = 0 Then GoSub ReadByteFromBlock: bitPointer = 8 WorkCode& = LastChar \ powerOf2&(8 - bitPointer) While codeSize > bitPointer GoSub ReadByteFromBlock
ReadByteFromBlock: If blockPointer = blockSize Then Get file, , byte: blockSize = byte a$ = Space$(blockSize): Get file, , a$ blockPointer = 0 End If blockPointer = blockPointer + 1 LastChar = Asc(Mid$(a$, blockPointer, 1)) Return End Sub
Sub codeGif (gifData As GIFDATA, frameData() As FRAMEDATA) For i = 0 To UBound(frameData) If frameData(i).addr < 0 Then _FreeImage frameData(i).addr Next
Close gifData.file End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long) Dim D As Long Static a& D = _Dest If a& = 0 Then a& = _NewImage(1, 1, 32) _Dest a& _DontBlend a& ' '<<<< new 2019-12-16 fix PSet (0, 0), K _Blend a& '<<<< new 2019-12-16 fix _Dest D _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3) End Sub
