' 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.
' 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.
Hey, that's my file!
I've written a file called Emordnilaps that searches the dictionary for all words that have a palindrome! I use it to help with a few word-games i've written or am writing!
Not nearly as professional as yours, of course, but it gets the job done.
I'll work through yours and see what I can use to improve mine, if that's ko.
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
Please visit my Website at: http://oldendayskids.blogspot.com/
12-08-2024, 03:03 AM (This post was last modified: 12-08-2024, 03:03 AM by PhilOfPerth.)
(12-08-2024, 02:45 AM)JRace Wrote: Neat.
My long-time favorite emordnilap: boobytrap.
Hmm, yeah. They may end up being similies too!
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
Please visit my Website at: http://oldendayskids.blogspot.com/
12-08-2024, 02:27 PM (This post was last modified: 12-08-2024, 02:29 PM by bplus.)
Yeah as Phil brought up, I kept emord's > 3 letters, there were 316 or 158 pairs from unixdict.txt before I restricted to >3 letters to show on the Machine.
lines 37 and up:
Code: (Select All)
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
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 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
' 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.
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
Please visit my Website at: http://oldendayskids.blogspot.com/
