12-08-2024, 05:14 PM
Emordnilap Machine With Gears
Code: (Select All)
Option _Explicit
_Title "emordnilap machine with gears" ' b+ 2024-12-08
' I saw this https://www.youtube.com/shorts/65_8t1OEZSc and was inspired!
' an emordnilap is palindrome spelled backwards
' If a word spelled backwards is also a word the 2 words are an emordnilap pair.
' using Scrabble Word List 2006.txt file for more words
Dim As Long index, fl, p, np, i, j, wCnt, test, emors
Dim buf$, wd$, b$, nl$
ReDim words$(1 To 1), emord$(1 To 1)
nl$ = Chr$(13) + Chr$(10)
Open "Scrabble Word List 2006.txt" For Binary As #1
fl = LOF(1): buf$ = Space$(fl)
Get #1, , buf$
Close #1
p = 1: index = 0
While p < fl
np = InStr(p, buf$, nl$)
If np Then
wd$ = Mid$(buf$, p, np - p): Print wd$
If Len(wd$) > 1 Then StrAppend words$(), wd$: wCnt = wCnt + 1
p = np + 2
Else
p = fl
End If
Wend
Print "words$() loaded..."
For i = 1 To wCnt
wd$ = words$(i)
b$ = "": j = 1
While j <= Len(wd$)
b$ = Mid$(wd$, j, 1) + b$
j = j + 1
Wend
If b$ <> wd$ Then ' NOT Palindrome! So lookup to see if word in words()
test = Find&(words$(), b$)
If test Then
If Len(wd$) > 3 Then
StrAppend emord$(), wd$: emors = emors + 1
Print emors, wd$, b$
'If emors Mod 20 = 19 Then Sleep: Cls
End If
End If
End If
Next
Print " For Scrabble file 596 pairs should have been found."
Print " press any for the Emordnilap Machine to run random display..."
Sleep
_Title "Emordnilap Machine"
Screen _NewImage(700, 700, 32)
_ScreenMove 340, 20
Randomize Timer
Dim As Long r
Do
r = Int(Rnd * emors) + 1
If Len(emord$(r)) >= 5 Then
EmordnilapMachine emord$(r)
_Delay .2
End If
Loop Until _KeyDown(27)
Sub EmordnilapMachine (eword$)
Dim As Long cx, cy, wl, th, l
Dim As Double a, mid, r, gx, gy, nt, sq, gr, a2
nt = 18: sq = 5: gr = gearRadius(nt, sq): a2 = _Pi / nt
cx = _Width / 2: cy = _Height / 2: wl = Len(eword$): th = 64
mid = wl / 2
For a = 0 To 2 * _Pi Step _Pi(2 / 360)
Cls
For l = 1 To wl
r = th * ((l - .5) - mid)
gx = cx + r * Cos(a)
gy = cy + r * Sin(a)
If l Mod 2 = 0 Then
gear gx, gy, nt, sq, 2 * a, &HFF0000FF
Else
gear gx, gy, nt, sq, -a + .5 * a2, &HFFFF0000
End If
Text gx - 15, gy - 28, th, &HFFFFFFFF, Mid$(eword$, l, 1)
Next
If Abs(a - _Pi) < .001 Or Abs(a - 2 * _Pi) < .001 Then _Delay .2
_Display
_Limit 30
Next
End Sub
Function Find& (SortedArr$(), x$)
Dim As Long low, hi, test
low = LBound(SortedArr$): hi = UBound(SortedArr$)
While low <= hi
test = Int((low + hi) / 2)
If SortedArr$(test) = x$ Then
Find& = test: Exit Function
Else
If SortedArr$(test) < x$ Then low = test + 1 Else hi = test - 1
End If
Wend
End Function
Sub StrAppend (arr() As String, addItem$) ' update 2024-12-06 to test for empty first slot
If arr(LBound(arr)) = "" Then
arr(LBound(arr)) = addItem$
Else
ReDim _Preserve arr(LBound(arr) To UBound(arr) + 1) As String
arr(UBound(arr)) = addItem$
End If
End Sub
Sub Text (x, y, textHeight, K As _Unsigned Long, txt$)
Dim fg As _Unsigned Long, bg As _Unsigned Long, cur&, i&
fg = _DefaultColor: bg = _BackgroundColor: cur& = _Dest
i& = _NewImage(8 * Len(txt$), 16, 32)
_Dest i&: Color K, _RGBA32(0, 0, 0, 0): _PrintString (0, 0), txt$
_PutImage (x, y)-Step(Len(txt$) * textHeight / 2, textHeight), i&, cur&
Color fg, bg: _FreeImage i&: _Dest cur&
End Sub
Function gearRadius (nteeth, sqtooth)
gearRadius = .5 * sqtooth / Sin(.5 * _Pi / nteeth)
End Function
Sub gear (x, y, nteeth, sqtooth, raOffset, K As _Unsigned Long)
Dim radius, ra, x2, y2
Dim As _Unsigned Long K1
radius = .5 * sqtooth / Sin(.5 * _Pi / nteeth)
For ra = 0 To 2 * _Pi Step 2 * _Pi / nteeth
x2 = x + (radius + sqtooth) * Cos(ra + raOffset)
y2 = y + (radius + sqtooth) * Sin(ra + raOffset)
thic x, y, x2, y2, sqtooth, K
Next
'to speed things up and reduce blicking just do a circle fill x, y already set and pen color too
For ra = _Pi / nteeth To 2 * _Pi Step 2 * _Pi / nteeth
x2 = x + radius * Cos(ra + raOffset)
y2 = y + radius * Sin(ra + raOffset)
thic x, y, x2, y2, sqtooth, K
Next
Color _RGB32(155, 70, 35)
FC3 x, y, .9 * radius, K
FC3 x, y, .2 * radius, &HFF000000
thic x, y, x + (.2 * radius + sqtooth) * Cos(raOffset), y + (.2 * radius + sqtooth) * Sin(raOffset), sqtooth, &HFF000000
End Sub
Sub thic (x1, y1, x2, y2, thick, K As _Unsigned Long)
Dim t2, a, x3, y3, x4, y4, x5, y5, x6, y6
t2 = thick / 2
If t2 < 1 Then t2 = 1
a = _Atan2(y2 - y1, x2 - x1)
x3 = x1 + t2 * Cos(a + _Pi(.5))
y3 = y1 + t2 * Sin(a + _Pi(.5))
x4 = x1 + t2 * Cos(a - _Pi(.5))
y4 = y1 + t2 * Sin(a - _Pi(.5))
x5 = x2 + t2 * Cos(a + _Pi(.5))
y5 = y2 + t2 * Sin(a + _Pi(.5))
x6 = x2 + t2 * Cos(a - _Pi(.5))
y6 = y2 + t2 * Sin(a - _Pi(.5))
filltri x6, y6, x4, y4, x3, y3, K
filltri x3, y3, x5, y5, x6, y6, K
End Sub
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' no suffix punctuation use the Global Default Type as Long or Single or Double
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
' found at QB64.net: http://www.qb64.net/forum/index.php?topic=14425.0
Sub filltri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim a&
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest 0
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
Zip with Scrabble words:
b = b + ...