07-23-2023, 01:08 AM
(This post was last modified: 07-23-2023, 12:58 PM by James D Jarvis.)
working on a larger image generation projects and realized a little piece of it looked like crop circles, so here we go with a goofy low end crop circle demo:
edit: darn aliens
Code: (Select All)
'crop circles version 0.1
'by James D. Jarvis, July 2023
'this is modifed from a larger image generation program I am working on so if you read the code some of thsi is goign to be strange
'there are likely stubs and variables not actually used in the cropcircle generation that are used in the original, but it works for a goofy little demo
ymax = 800
xmax = 800
'$dynamic
Screen _NewImage(xmax, ymax, 32)
Dim flrklr As _Unsigned Long
tilescale = 4
Type roomtype
fill As Integer
rx As Integer
ry As Integer
nw As Integer
sw As Integer
ew As Integer
ww As Integer
cnx As Integer
End Type
Dim Shared rm(0) As roomtype
Dim Shared floorklr As _Unsigned Long
Dim Shared wallklr As _Unsigned Long
Dim Shared emptyklr As _Unsigned Long
floorklr = _RGB32(220, 220, 0)
wallklr = _RGB32(50, 50, 50)
emptyklr = _RGB32(80, 200, 15)
Type band_type
rad As Integer
s As Integer
e As Integer
spoke As Integer
thk As Single
End Type
Dim Shared band(0) As band_type
Dim Shared oring(0) As band_type
Dim Shared tessfix
Dim Shared roomfix, excludeturrets
Dim Shared fillcellchance, defaulthallwidth
Dim Shared bumpchance, antennachance
bumpchance = 20
antennachance = 60
floorgrid = 0
forcegeneration = 0
linkgeneration = 0
tessfix = 0
roomfix = 0
fillcellchance = 50
firstpass = 1
Cls
Do
Cls , emptyklr
'grassfill 0, 0, xmax, ymax
cb = 2 + Int(Rnd * 8)
ReDim band(cb) As band_type
mr = Int(_Height / 4 + Rnd * _Height / 6)
mrp = Int(mr / cb)
r = 0
For c = 1 To cb
r = r + Int((mrp / 3) * Int(2 + Rnd * 2))
band(c).rad = r
If c = 1 Then
band(c).s = Int(Rnd * 360)
band(c).e = band(c).s + band(c).s + (10 * Int(Rnd * 36))
Else
band(c).s = band(c - 1).spoke - (Int(1 + Rnd * 60) * 3)
band(c).e = band(c - 1).spoke + (Int(1 + Rnd * 60) * 3)
ppx1 = cx + band(c - 1).rad * Cos(0.01745329 * band(c - 1).spoke)
ppy1 = cy + band(c - 1).rad * Sin(0.01745329 * band(c - 1).spoke)
ppx2 = cx + band(c).rad * Cos(0.01745329 * band(c - 1).spoke)
ppy2 = cy + band(c).rad * Sin(0.01745329 * band(c - 1).spoke)
fatline ppx1, ppy1, ppx2, ppy2, 2, floorklr
End If
bsiz = band(c).e - band(c).s
band(c).spoke = Int(band(c).s + Rnd * bsiz)
If Rnd * 100 < bumpchance Then
rs = band(c).s: re = band(c).e
bsiz = re - rs
nb = Int((1 + Rnd * 12) / Int(1 + Rnd * 4))
If nb < 1 Then nb = 1
For bb = 1 To nb
srangle = Int(rs + Rnd * bsiz)
erangle = srangle + (Int(2 + Rnd * 11) * 3)
bd = Int(1 + Rnd * 5) * tilescale
If Rnd * 200 < bumpchance Then bd = bd * 2
For d = 0.5 To bd Step 0.5
fatarc cx, cy, 2, band(c).rad + d, srangle, erangle, floorklr
Next d
Next bb
End If
Next
roomcount = 0
lastcount = 0
For b = 1 To cb
rs = band(b).s: re = band(b).e
bsiz = re - rs
mrbc = (bsiz * 0.01745329 * band(b).rad) / ((tilescale * tilescale) * 4)
roomcount = roomcount + Int(1 + Rnd * mrbc)
ReDim _Preserve rm(roomcount) As roomtype
For r = lastcount + 1 To roomcount
rangle = Int(rs + Rnd * bsiz)
'rangle = Int(Rnd * 90) * 4
rm(r).rx = cx + band(b).rad * Cos(0.01745329 * rangle)
rm(r).ry = cy + band(b).rad * Sin(0.01745329 * rangle)
rm(r).nw = 3 + Int(Rnd * 6) * tilescale
rm(r).sw = 3 + Int(Rnd * 6) * tilescale
rm(r).ew = 3 + Int(Rnd * 6) * tilescale
rm(r).ww = 3 + Int(Rnd * 6) * tilescale
If (Rnd * 101) < fillcellchance Then
rm(r).fill = Int(1 + Rnd * 10) * (tilescale / 2)
Else
rm(r).fill = 0
End If
If rm(r).fill = 0 Then
' Circle (rm(r).rx, rm(r).ry), rm(r).nw, floorklr
fatarc rm(r).rx, rm(r).ry, 2, rm(r).nw, 0, 359, floorklr
Else
fcirc rm(r).rx, rm(r).ry, rm(r).fill, floorklr
End If
Next r
lastcount = roomcount
Next b
For c = 1 To cb
cx = _Width \ 2: cy = _Height \ 2
fatarc cx, cy, 2, band(c).rad, band(c).s, band(c).e, floorklr
If c > 1 Then
k = Int(c / 2 + Rnd * (c * 1.2))
For n = 1 To k
rs = band(c - 1).s: re = band(c - 1).e
bsiz = re - rs
ang = Int(rs + Rnd * bsiz)
ppx1 = cx + band(c - 1).rad * Cos(0.01745329 * ang)
ppy1 = cy + band(c - 1).rad * Sin(0.01745329 * ang)
ppx2 = cx + band(c).rad * Cos(0.01745329 * ang)
ppy2 = cy + band(c).rad * Sin(0.01745329 * ang)
fatline ppx1, ppy1, ppx2, ppy2, 2, floorklr
Next
End If
If c = cb Then
rs = band(c).s: re = band(c).e
bsiz = re - rs
ang = -1 * Int(rs + Rnd * bsiz)
fx = 0
fy = 0
ppx2 = cx + band(c).rad * Cos(0.01745329 * ang)
ppy2 = cy + band(c).rad * Sin(0.01745329 * ang)
cc = cb
Do
cc = cc - 1
xc = cx + band(cc).rad * Cos(0.01745329 * ang)
yc = cy + band(cc).rad * Sin(0.01745329 * ang)
If Point(xc, yc) <> emptyklr Then
fx = xc
fy = yc
End If
Loop Until fx <> 0 And fy <> 0 Or cc = 1
If fx = 0 Then
fx = cx
fy = cy
rs = band(1).s: re = band(1).e
bsiz = re - rs
ang = Int(rs + Rnd * bsiz)
tx = cx + band(1).rad * Cos(0.01745329 * ang)
ty = cy + band(1).rad * Sin(0.01745329 * ang)
fatline cx, cy, tx, ty, 2, floorklr
End If
fatline fx, fy, ppx2, ppy2, 2, floorklr
End If
Next c
For a = 1 To 5
If Rnd * 100 < antennachance Then
tb = Int(1 + Rnd * cb)
rs = band(tb).s: re = band(tb).e
bsiz = re - rs
bangle = Int(rs + Rnd * bsiz)
DB = mr + 20
dx = cx + DB * Cos(0.01745329 * bangle)
dy = cy + DB * Sin(0.01745329 * bangle)
ppx2 = cx + band(tb).rad * Cos(0.01745329 * bangle)
ppy2 = cy + band(tb).rad * Sin(0.01745329 * bangle)
fatline dx, dy, ppx2, ppy2, 2, floorklr
Select Case Int(1 + Rnd * 16)
' Select Case 14
Case 1, 2
fcirc dx, dy, Int(5 + Rnd * 10), floorklr
Case 3, 4, 5, 6, 7, 8
fangs = bangle - Int(2 + Rnd * 10)
fange = bangle + Int(2 + Rnd * 10)
bd = Int(1 + Rnd * 5) * tilescale
For d = 0.5 To bd Step 0.5
fatarc cx, cy, 2, DB + d, fangs, fange, floorklr
Next d
Case 10, 11, 12
fanga = Int(2 + Rnd * 10) * 10
bd = Int(2 + Rnd * 10) * tilescale
For da = bangle - fanga To bangle + fanga
DB = mr + 20
nx = dx + bd * Cos(0.01745329 * da)
ny = dy + bd * Sin(0.01745329 * da)
fatline dx, dy, nx, ny, 2, floorklr
Next da
Case 13, 14, 15, 16
orrc = Int(2 + Rnd * 3)
ReDim oring(orrc) As band_type
r2 = 0
For o = 1 To orrc
r2 = r2 + Int(2 + Rnd * 2) * tilescale
oring(o).rad = r2
oring(o).s = 0
oring(o).e = 359
oring(o).thk = 0.75
fatarc dx, dy, 2, oring(o).rad, 0, 359, floorklr
Next o
End Select
End If
Next
Do
redraw = 0
Do
_Limit 60
kk$ = InKey$
If firstpass = 1 Then
firstpass = 0
redraw = 1
kk$ = "go"
End If
Loop Until kk$ <> ""
Select Case kk$
Case "c" 'copy to clipboard.... this is only supported in windows
_ClipboardImage = dngi&
Case "m", "M"
rrr$ = Str$(tilescale)
getroun$ = _InputBox$("Shape Magnitude", "Enter new magnitude (4) is standard.", rrr$)
tilescale = Int(Val(getroun$))
If tilescale < 1 Then tilescale = 1
Case Else
redraw = 1
End Select
Loop Until redraw = 1
Loop Until kk$ = Chr$(27)
Sub fcirc (CX As Long, CY As Long, R, klr As _Unsigned Long)
'draw a filled circle with the quickest filled circle routine in qb64, not my development
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
Line (CX - X, CY)-(CX + X, CY), klr, 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), klr, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), klr, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), klr, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), klr, BF
Wend
End Sub
Sub fatarc (cx, cy, thk, r, sang, eang, klr As _Unsigned Long)
For rangle = sang To eang Step 0.5
ax = cx + r * Cos(0.01745329 * rangle)
ay = cy + r * Sin(0.01745329 * rangle)
fcirc ax, ay, thk, klr
Next rangle
End Sub
Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)
'draw a line with dots with a radial thickness of r from x0,y0 to x1,y1 in color klr
If r > 0.5 Then
If Abs(y1 - y0) < Abs(x1 - x0) Then
If x0 > x1 Then
lineLow x1, y1, x0, y0, r, klr
Else
lineLow x0, y0, x1, y1, r, klr
End If
Else
If y0 > y1 Then
lineHigh x1, y1, x0, y0, r, klr
Else
lineHigh x0, y0, x1, y1, r, klr
End If
End If
Else
Line (x0, y0)-(x1, y1), klr 'line with r of <= 0.5 don't render properly so we force them to be 1 pixel wide on screen
End If
End Sub
Sub lineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
yi = 1
If dy < 0 Then
yi = -1
dy = -dy
End If
d = (dy + dy) - dx
y = y0
For x = x0 To x1
fcirc x, y, r, klr
If d > 0 Then
y = y + yi
d = d + ((dy - dx) + (dy - dx))
Else
d = d + dy + dy
End If
Next x
End Sub
Sub lineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
xi = 1
If dx < 0 Then
xi = -1
dx = -dx
End If
D = (dx + dx) - dy
x = x0
For y = y0 To y1
fcirc x, y, r, klr
If D > 0 Then
x = x + xi
D = D + ((dx - dy) + (dx - dy))
Else
D = D + dx + dx
End If
Next y
End Sub
Function inscreen (xx, yy)
'check if point is inside the boreders of the current screen
ii = 1
If xx < 1 Or xx > _Width - 1 Then ii = 0
If yy < 1 Or yy > _Height - 1 Then ii = 0
inscreen = ii
End Function
Sub paintifborder (xx, yy, klr As _Unsigned Long)
If xx = 0 Or xx = _Width Or yy = 0 Or yy = _Height Then
PSet (xx, yy), klr
End If
End Sub
Sub grassfill (x1, y1, x2, y2)
Cls
Line (x1, y1)-(x2, y2), _RGB32(40, 240, 40), BF
For yy = y1 To y2
For xx = x1 To x2 Step 2
bx = Int(Rnd * 2)
Line (xx + bx, yy)-(xx + bx, yy - Int(Rnd * 3)), _RGB32(55 + Int(Rnd * 10), 225 + Int(Rnd * 10), 15 + Int(Rnd * 10))
Next
Next
End Subedit: darn aliens
