+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: Emordnilap's (/showthread.php?tid=3255)
Emordnilap's - bplus - 12-08-2024
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 SubSeems like there are way more Palindromes than Emordnilaps.
zip has source and unixdict.txt file for a word list to check.
RE: Emordnilap's - PhilOfPerth - 12-08-2024
(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.
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.
RE: Emordnilap's - JRace - 12-08-2024
Neat.
My long-time favorite emordnilap: boobytrap.
RE: Emordnilap's - PhilOfPerth - 12-08-2024
(12-08-2024, 02:45 AM)JRace Wrote: Neat.
My long-time favorite emordnilap: boobytrap.
Hmm, yeah. They may end up being similies too!
RE: Emordnilap's - bplus - 12-08-2024
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 IfRE: Emordnilap's - bplus - 12-08-2024
OK 596 pairs found in the Scrabble Word List for 2006.
let's see a longer one in the machine:
that's one found in video.
here is (fixed) zip for bigger word file and counting and showing all pairs 3 letters and up:
RE: Emordnilap's - bplus - 12-08-2024
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:
RE: Emordnilap's - Petr - 12-08-2024
Nicely done, BPlus
RE: Emordnilap's - bplus - 12-08-2024
Thanks Petr!
I reran the word list for 3 letters and above and got 886 pairs from the Scrabble Word List file.
Here they are!
Code: (Select All)
1 abo oba
2 abos soba
3 abut tuba
4 ado oda
5 ados soda
6 agar raga
7 agas saga
8 agenes senega
9 ahs sha
10 aider redia
11 air ria
12 airts stria
13 ajar raja
14 alan nala
15 alif fila
16 amen nema
17 amis sima
18 anger regna
19 animal lamina
20 animes semina
21 anon nona
22 ante etna
23 apod dopa
24 arb bra
25 are era
26 ares sera
27 aril lira
28 arris sirra
29 arum mura
30 ate eta
31 ates seta
32 auks skua
33 avid diva
34 avo ova
35 bad dab
36 bag gab
37 bal lab
38 bals slab
39 ban nab
40 bard drab
41 bas sab
42 bat tab
43 bats stab
44 bed deb
45 beef feeb
46 ben neb
47 bid dib
48 big gib
49 bin nib
50 bins snib
51 bird drib
52 bis sib
53 blub bulb
54 bog gob
55 bonk knob
56 bos sob
57 bots stob
58 bows swob
59 boy yob
60 bra arb
61 brad darb
62 brag garb
63 bro orb
64 bros sorb
65 bud dub
66 bulb blub
67 bun nub
68 buns snub
69 bur rub
70 burd drub
71 burg grub
72 bus sub
73 but tub
74 buts stub
75 cam mac
76 cap pac
77 cares serac
78 cep pec
79 ceps spec
80 cis sic
81 cite etic
82 cod doc
83 cor roc
84 cram marc
85 dab bad
86 dag gad
87 dah had
88 dahs shad
89 dal lad
90 dam mad
91 dap pad
92 darb brad
93 dart trad
94 daw wad
95 deb bed
96 debut tubed
97 decaf faced
98 decal laced
99 dedal laded
100 deem meed
101 deep peed
102 deeps speed
103 deer reed
104 dees seed
105 deet teed
106 deets steed
107 def fed
108 defer refed
109 deffer reffed
110 degami imaged
111 deifier reified
112 deil lied
113 deke eked
114 del led
115 delf fled
116 deliver reviled
117 dels sled
118 demit timed
119 denier reined
120 denies seined
121 denim mined
122 dens sned
123 depot toped
124 depots stoped
125 derat tared
126 derats stared
127 dessert tressed
128 desserts stressed
129 devas saved
130 devil lived
131 dew wed
132 dewans snawed
133 dexes sexed
134 dial laid
135 dialer relaid
136 diaper repaid
137 dib bid
138 dif fid
139 dig gid
140 dim mid
141 dinar ranid
142 diol loid
143 diols sloid
144 diva avid
145 doc cod
146 dog god
147 dom mod
148 don nod
149 doom mood
150 door rood
151 dopa apod
152 dor rod
153 dormin nimrod
154 dorp prod
155 dos sod
156 doser resod
157 dot tod
158 drab bard
159 drail liard
160 draw ward
161 drawer reward
162 draws sward
163 dray yard
164 drib bird
165 drub burd
166 dual laud
167 dub bud
168 duel leud
169 duo oud
170 dup pud
171 dups spud
172 eat tae
173 edile elide
174 edit tide
175 eel lee
176 eked deke
177 elide edile
178 elides sedile
179 emes seme
180 emir rime
181 emit time
182 emits stime
183 enol lone
184 era are
185 ergo ogre
186 eros sore
187 ervil livre
188 esnes sense
189 eta ate
190 etas sate
191 etic cite
192 etna ante
193 even neve
194 evil live
195 eviler relive
196 faced decaf
197 fed def
198 feeb beef
199 fer ref
200 fid dif
201 fila alif
202 fir rif
203 fires serif
204 fled delf
205 flog golf
206 flow wolf
207 fool loof
208 gab bag
209 gad dag
210 gal lag
211 gals slag
212 gam mag
213 gan nag
214 gar rag
215 garb brag
216 gas sag
217 gat tag
218 gateman nametag
219 gater retag
220 gats stag
221 gay yag
222 gel leg
223 gelder redleg
224 gem meg
225 gen neg
226 get teg
227 gib big
228 gid dig
229 gip pig
230 girt trig
231 gnar rang
232 gnat tang
233 gnats stang
234 gnaws swang
235 gnus sung
236 gob bog
237 god dog
238 golf flog
239 gorp prog
240 got tog
241 grub burg
242 gul lug
243 gulp plug
244 guls slug
245 gum mug
246 gums smug
247 guns snug
248 gut tug
249 guv vug
250 habus subah
251 had dah
252 hahs shah
253 hales selah
254 hap pah
255 hay yah
256 hep peh
257 hey yeh
258 hon noh
259 hoop pooh
260 hop poh
261 imaged degami
262 iron nori
263 jar raj
264 kay yak
265 keel leek
266 keels sleek
267 keep peek
268 keets steek
269 kips spik
270 kiths shtik
271 knaps spank
272 knar rank
273 knits stink
274 knob bonk
275 know wonk
276 korat tarok
277 lab bal
278 laced decal
279 lad dal
280 laded dedal
281 lag gal
282 lager regal
283 laid dial
284 lair rial
285 lamina animal
286 lap pal
287 lares seral
288 larum mural
289 las sal
290 laud dual
291 led del
292 lee eel
293 leek keel
294 leer reel
295 lees seel
296 leet teel
297 leets steel
298 leg gel
299 leper repel
300 les sel
301 let tel
302 leud duel
303 lever revel
304 levins snivel
305 liar rail
306 liard drail
307 lied deil
308 lin nil
309 lion noil
310 lira aril
311 lit til
312 live evil
313 lived devil
314 livre ervil
315 lobo obol
316 loid diol
317 lone enol
318 loof fool
319 loom mool
320 loons snool
321 loop pool
322 loops spool
323 loot tool
324 looter retool
325 loots stool
326 lop pol
327 lotos sotol
328 lug gul
329 mac cam
330 macs scam
331 mad dam
332 maes seam
333 mag gam
334 man nam
335 map pam
336 maps spam
337 mar ram
338 marc cram
339 marcs scram
340 mart tram
341 mat tam
342 maws swam
343 may yam
344 meed deem
345 meet teem
346 meg gem
347 meter retem
348 mho ohm
349 mid dim
350 mils slim
351 mined denim
352 mir rim
353 mis sim
354 mod dom
355 mon nom
356 mood doom
357 mool loom
358 moor room
359 moot toom
360 mop pom
361 mor rom
362 mos som
363 mot tom
364 mug gum
365 mura arum
366 mural larum
367 mures serum
368 mus sum
369 muton notum
370 muts stum
371 nab ban
372 nag gan
373 nala alan
374 nam man
375 namer reman
376 nametag gateman
377 nap pan
378 naps span
379 naw wan
380 neb ben
381 neep peen
382 neg gen
383 nema amen
384 net ten
385 neve even
386 neves seven
387 new wen
388 nib bin
389 nil lin
390 nimrod dormin
391 nip pin
392 nips spin
393 nit tin
394 nod don
395 noh hon
396 noil lion
397 nolos solon
398 nom mon
399 nona anon
400 nonet tenon
401 nori iron
402 nos son
403 not ton
404 notes seton
405 notum muton
406 now won
407 nub bun
408 nus sun
409 nut tun
410 nuts stun
411 oat tao
412 oba abo
413 obol lobo
414 oda ado
415 ogre ergo
416 ohm mho
417 oohs shoo
418 oot too
419 orb bro
420 oud duo
421 ova avo
422 pac cap
423 pacer recap
424 pad dap
425 pah hap
426 pal lap
427 pals slap
428 pam map
429 pan nap
430 pans snap
431 par rap
432 part trap
433 parts strap
434 pas sap
435 pat tap
436 paw wap
437 paws swap
438 pay yap
439 pec cep
440 peed deep
441 peek keep
442 peels sleep
443 peen neep
444 pees seep
445 peh hep
446 per rep
447 perp prep
448 pets step
449 pig gip
450 pin nip
451 pins snip
452 pis sip
453 pit tip
454 plug gulp
455 poh hop
456 pol lop
457 pols slop
458 pom mop
459 pooh hoop
460 pool loop
461 pools sloop
462 poons snoop
463 port trop
464 ports strop
465 pot top
466 pots stop
467 pow wop
468 pows swop
469 prat tarp
470 prep perp
471 prod dorp
472 prog gorp
473 pud dup
474 pupils slipup
475 puris sirup
476 pus sup
477 put tup
478 rag gar
479 raga agar
480 rail liar
481 raj jar
482 raja ajar
483 ram mar
484 rang gnar
485 ranid dinar
486 rank knar
487 rap par
488 raps spar
489 rat tar
490 rats star
491 raw war
492 ray yar
493 rebus suber
494 rebut tuber
495 recap pacer
496 recaps spacer
497 redes seder
498 redia aider
499 redips spider
500 redleg gelder
501 redraw warder
502 redrawer rewarder
503 reed deer
504 reel leer
505 rees seer
506 ref fer
507 refed defer
508 reffed deffer
509 reflet telfer
510 reflow wolfer
511 regal lager
512 regna anger
513 reified deifier
514 reined denier
515 reknit tinker
516 reknits stinker
517 relaid dialer
518 relit tiler
519 relive eviler
520 reman namer
521 remeet teemer
522 remit timer
523 rennet tenner
524 rep per
525 repaid diaper
526 repel leper
527 repins sniper
528 repot toper
529 repots stoper
530 res ser
531 resod doser
532 retag gater
533 retem meter
534 retool looter
535 retros sorter
536 revel lever
537 reviled deliver
538 reward drawer
539 rewarder redrawer
540 ria air
541 rial lair
542 rif fir
543 rim mir
544 rime emir
545 roc cor
546 rod dor
547 rom mor
548 rood door
549 room moor
550 rot tor
551 rub bur
552 sab bas
553 sag gas
554 saga agas
555 sakis sikas
556 sal las
557 sallets stellas
558 sap pas
559 saps spas
560 saros soras
561 sat tas
562 sate etas
563 saved devas
564 saw was
565 scam macs
566 scares seracs
567 scram marcs
568 seam maes
569 secret terces
570 seder redes
571 sedile elides
572 seed dees
573 seeks skees
574 seel lees
575 seep pees
576 seer rees
577 seined denies
578 sel les
579 selah hales
580 selahs shales
581 seme emes
582 semina animes
583 senega agenes
584 sense esnes
585 ser res
586 sera ares
587 serac cares
588 seracs scares
589 seral lares
590 serif fires
591 serum mures
592 seta ates
593 seton notes
594 seven neves
595 sexed dexes
596 sha ahs
597 shad dahs
598 shah hahs
599 shales selahs
600 shoo oohs
601 shtik kiths
602 sib bis
603 sic cis
604 sikas sakis
605 sim mis
606 sima amis
607 sip pis
608 sirra arris
609 sirs sris
610 sirup puris
611 sit tis
612 six xis
613 skees seeks
614 skeets steeks
615 skips spiks
616 skua auks
617 slab bals
618 slag gals
619 slap pals
620 sled dels
621 sleek keels
622 sleep peels
623 sleeps speels
624 sleet teels
625 sleets steels
626 slim mils
627 slipup pupils
628 slit tils
629 sloid diols
630 sloop pools
631 sloops spools
632 slop pols
633 slug guls
634 smart trams
635 smug gums
636 smuts stums
637 snap pans
638 snaps spans
639 snaw wans
640 snawed dewans
641 snaws swans
642 sned dens
643 snib bins
644 snip pins
645 sniper repins
646 snips spins
647 snit tins
648 snivel levins
649 snool loons
650 snoop poons
651 snoops spoons
652 snoot toons
653 snot tons
654 snow wons
655 snub buns
656 snug guns
657 sob bos
658 soba abos
659 sod dos
660 soda ados
661 solon nolos
662 som mos
663 son nos
664 soras saros
665 sorb bros
666 sore eros
667 sorter retros
668 sotol lotos
669 sow wos
670 spacer recaps
671 spam maps
672 span naps
673 spank knaps
674 spans snaps
675 spar raps
676 spas saps
677 spat taps
678 spay yaps
679 spaz zaps
680 spec ceps
681 speed deeps
682 speels sleeps
683 spider redips
684 spik kips
685 spiks skips
686 spin nips
687 spins snips
688 spirt trips
689 spirts strips
690 spit tips
691 spool loops
692 spools sloops
693 spoons snoops
694 sports strops
695 spot tops
696 spots stops
697 sprat tarps
698 sprits stirps
699 spud dups
700 sris sirs
701 stab bats
702 stag gats
703 stang gnats
704 star rats
705 stared derats
706 stat tats
707 staw wats
708 steed deets
709 steek keets
710 steeks skeets
711 steel leets
712 steels sleets
713 stellas sallets
714 step pets
715 stet tets
716 stew wets
717 stime emits
718 stink knits
719 stinker reknits
720 stirps sprits
721 stob bots
722 stool loots
723 stop pots
724 stoped depots
725 stoper repots
726 stops spots
727 stot tots
728 stow wots
729 stows swots
730 strap parts
731 straw warts
732 stressed desserts
733 stria airts
734 strips spirts
735 strop ports
736 strops sports
737 strow worts
738 struts sturts
739 stub buts
740 stum muts
741 stums smuts
742 stun nuts
743 sturts struts
744 sub bus
745 subah habus
746 suber rebus
747 sulu ulus
748 sum mus
749 sun nus
750 sung gnus
751 sup pus
752 swam maws
753 swang gnaws
754 swans snaws
755 swap paws
756 sward draws
757 swat taws
758 sway yaws
759 swob bows
760 swop pows
761 swot tows
762 swots stows
763 tab bat
764 tae eat
765 tag gat
766 tam mat
767 tang gnat
768 tao oat
769 tap pat
770 taps spat
771 tar rat
772 tared derat
773 tarok korat
774 tarp prat
775 tarps sprat
776 tas sat
777 tats stat
778 tav vat
779 taw wat
780 taws swat
781 teed deet
782 teel leet
783 teels sleet
784 teem meet
785 teemer remeet
786 teg get
787 tel let
788 telfer reflet
789 ten net
790 tenner rennet
791 tenon nonet
792 terces secret
793 tets stet
794 tew wet
795 tide edit
796 til lit
797 tiler relit
798 tils slit
799 time emit
800 timed demit
801 timer remit
802 tin nit
803 tinker reknit
804 tins snit
805 tip pit
806 tips spit
807 tis sit
808 tod dot
809 tog got
810 tom mot
811 ton not
812 tons snot
813 too oot
814 tool loot
815 toom moot
816 toons snoot
817 top pot
818 toped depot
819 toper repot
820 tops spot
821 tor rot
822 tort trot
823 tots stot
824 tow wot
825 tows swot
826 trad dart
827 tram mart
828 trams smart
829 trap part
830 tressed dessert
831 trig girt
832 trips spirt
833 trop port
834 trot tort
835 trow wort
836 tub but
837 tuba abut
838 tubed debut
839 tuber rebut
840 tug gut
841 tun nut
842 tup put
843 ulus sulu
844 vat tav
845 vug guv
846 wad daw
847 wan naw
848 wans snaw
849 wap paw
850 war raw
851 ward draw
852 warder redraw
853 warts straw
854 was saw
855 wat taw
856 wats staw
857 way yaw
858 wed dew
859 wen new
860 wet tew
861 wets stew
862 wolf flow
863 wolfer reflow
864 won now
865 wonk know
866 wons snow
867 wop pow
868 wort trow
869 worts strow
870 wos sow
871 wot tow
872 wots stow
873 xis six
874 yag gay
875 yah hay
876 yak kay
877 yam may
878 yap pay
879 yaps spay
880 yar ray
881 yard dray
882 yaw way
883 yaws sway
884 yeh hey
885 yob boy
886 zaps spazRE: Emordnilap's - PhilOfPerth - 12-08-2024
(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!
I'll try and get it deleted.