Emordnilap's

[PhilOfPerth]

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.

Sorry bplus; I posted my code to a different thread because I didn't want to "corrupt" yours with my puny effort- especially when it doesn't work! 
I'll try and get it deleted.