Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Emordnilap's
#10
(12-08-2024, 02:09 AM)bplus Wrote:
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!  Blush
I'll try and get it deleted.
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply


Messages In This Thread
Emordnilap's - by bplus - 12-08-2024, 02:09 AM
RE: Emordnilap's - by PhilOfPerth - 12-08-2024, 02:42 AM
RE: Emordnilap's - by JRace - 12-08-2024, 02:45 AM
RE: Emordnilap's - by PhilOfPerth - 12-08-2024, 03:03 AM
RE: Emordnilap's - by bplus - 12-08-2024, 02:27 PM
RE: Emordnilap's - by bplus - 12-08-2024, 03:30 PM
RE: Emordnilap's - by bplus - 12-08-2024, 05:14 PM
RE: Emordnilap's - by Petr - 12-08-2024, 06:47 PM
RE: Emordnilap's - by bplus - 12-08-2024, 08:50 PM
RE: Emordnilap's - by PhilOfPerth - 12-08-2024, 11:12 PM



Users browsing this thread: 3 Guest(s)