Code: (Select All)
Option _Explicit
_Title "emordnilap's found" ' b+ 2024-12-07
' 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.
' try the unixdict.txt file
Dim As Long index, fl, p, np, i, j, wCnt, test, emors
Dim buf$, wd$, b$
ReDim words$(1 To 1), emord$(1 To 1)
Open "unixdict.txt" For Binary As #1
' http://www.puzzlers.org/pub/wordlists/unixdict.txt
fl = LOF(1): buf$ = Space$(fl)
Get #1, , buf$
Close #1
p = 1: index = 0
While p < fl
np = InStr(p, buf$, Chr$(10))
If np Then
wd$ = Mid$(buf$, p, np - p): Print wd$
If Len(wd$) > 1 Then StrAppend words$(), wd$: wCnt = wCnt + 1
p = np + 1
Else
p = fl
End If
Wend
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
Sleep
_Title "Emordnilap Machine"
Screen _NewImage(700, 700, 32)
_ScreenMove 340, 20
Randomize Timer
Dim As Long r
Do
r = Int(Rnd * emors) + 1
EmordnilapMachine emord$(r)
_Delay .2
Loop Until _KeyDown(27)
Sub EmordnilapMachine (eword$)
Dim As Long cx, cy, wl, th, tw, xoff, l
Dim As Double a, mid, r
cx = _Width / 2: cy = _Height / 2: wl = Len(eword$): th = 64
mid = wl / 2
For a = 0 To 2 * _Pi - .001 Step _Pi(2 / 360)
Cls
For l = 1 To wl
r = th * ((l - .5) - mid)
Text cx + r * Cos(a) - 16, cy + r * Sin(a) - 16, th, &HFFFFFFFF, Mid$(eword$, l, 1)
Next
If Abs(a - _Pi) < .001 Or Abs(a - 2 * _Pi - .001) < .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
Seems like there are way more Palindromes than Emordnilaps.
zip has source and unixdict.txt file for a word list to check.
b = b + ...