Nice simple interface, John. Makes a good starting point I think. What I might suggest is not requiring any clicks on the User part. As soon as two numbers are entered the computer analzes and acts accordingly. Then when it's the computer's turn, have him display his response for say (2-5 secs), then go ahead.
Just a thought. If someone would like to play with sprites (I think that's what they are called), this would be a good starting point.
And while we're on the subject of Logic Games, I'd advise anyone to try Genius Move. A penguin pushes ice blocks around. Sound Silly? It is, but it'll keep you up at night, that's for sure. Dunno how many levels there are but I've been stuck at 38 for over a year. And still keep trying - when I (unfortunately) think about it.
It's $20 after a free trial but plenty worth it. At least for my money.
-
Yes, the interface is kinda chees... minimal, there aren't any chatting robots here, but maybe test it out for the logic accuracy. I was thinking about going to four rows too, 9 7 5 & 3.
Code:#COMPILE EXE #DIM ALL DECLARE FUNCTION robotLogic(r() AS LONG) AS LONG DECLARE FUNCTION rndGuess(bArr() AS LONG) AS LONG FUNCTION PBMAIN () AS LONG LOCAL ii, hTurn, robLog AS LONG LOCAL si, mistake, rn, iPrompt AS STRING DIM botArr(1 TO 3) AS LONG ARRAY ASSIGN botArr() = 7,5,3 RANDOMIZE ? "The object of the game is to make your opponent remove the last robot ® from the three rows of robots. " & _ "You can remove any number of robots, even all in the chosen row, but only from one row at a time. Good luck." _ ,,"Robot Nom" DO IF mistake = "" THEN IF hTurn = 0 THEN hTurn = 1 rn = "Robot Nom: Human, Your Turn" iPrompt = "Choose row, then how many robots to remove: eg. " & FORMAT$(rndGuess(botArr())) IF botArr(1) + botArr(2) + botArr(3) = 0 THEN ? "Oof, my perfect moves were not enough to beat a humaaaan!" & $CRLF & $CRLF & _ " But anyway, thanks for the lesson.",,"Robot Nom" EXIT FUNCTION END IF ELSE hTurn = 0 rn = "Robot Nom: Superior Robot Turn" iPrompt = "My perfect robot move is entered below. Simply click OK to continue. robLog = robotLogic(botArr()) IF robLog = 999 THEN EXIT FUNCTION END IF END IF IF robLog > 0 THEN mistake = FORMAT$(robLog) robLog = 0 END IF si = INPUTBOX$(iPrompt & $CRLF & $CRLF & _ "1" & SPACE$((7 - botArr(1)) + 3 + (7 - botArr(1)) \ 2) & REPEAT$(botArr(1), CHR$(&hae) & $SPC) & $CRLF & _ "2" & SPACE$((5 - botArr(2)) + 6 + (5 - botArr(2)) \ 2) & REPEAT$(botArr(2), CHR$(&hae) & $SPC) & $CRLF & _ "3" & SPACE$((3 - botArr(3)) + 9 + (3 - botArr(3)) \ 2) & REPEAT$(botArr(3), CHR$(&hae) & $SPC) & $CRLF _ ,rn,mistake) IF si = "" THEN EXIT DO mistake = "" si = RETAIN$(si, ANY "1234567") IF LEN(si) <> 2 THEN mistake = "Please re-enter last move" ITERATE DO END IF IF VAL(LEFT$(si, 1)) <= 3 AND VAL(LEFT$(si, 1)) > 0 AND VAL(RIGHT$(si, 1)) > 0 THEN botArr(VAL(LEFT$(si, 1))) = botArr(VAL(LEFT$(si, 1))) - VAL(RIGHT$(si, 1)) IF botArr(VAL(LEFT$(si, 1))) < 0 THEN botArr(VAL(LEFT$(si, 1))) = botArr(VAL(LEFT$(si, 1))) + VAL(RIGHT$(si, 1)) mistake = "Please re-enter last move" END IF ELSE mistake = "Please re-enter last move" END IF LOOP END FUNCTION FUNCTION robotLogic(r() AS LONG) AS LONG LOCAL s,sr AS STRING LOCAL x, s1,s2,s3, si1,si2,si3, ii, robAns, rChoice, rndCnt AS LONG DIM youLose(753) AS LONG, isValid(753) AS LONG, rb(1 TO 3) AS LONG IF r(1) + r(2) + r(3) = 0 THEN ? "Game over. Thanks for the match!",,"Robot Nom": FUNCTION = 999: EXIT FUNCTION FOR x = 1 TO 3: rb(x) = r(x): NEXT 'leaving any two rows = 1 and other row > 1 IF (rb(1) = 1 AND (rb(2) = 1 OR rb(3) = 1) OR _ rb(2) = 1 AND rb(3) = 1) AND rb(1) + rb(2) + rb(3) > 3 THEN IF rb(1) <> 1 THEN rb(1) = 1 IF rb(2) <> 1 THEN rb(2) = 1 IF rb(3) <> 1 THEN rb(3) = 1 robAns = rb(1) * 100 + rb(2) * 10 + rb(3) GOTO convertAns 'two rows equal ELSEIF rb(1) = rb(2) OR rb(1) = rb(3) OR rb(2) = rb(3) THEN IF rb(1) = rb(2) THEN IF rb(1) = 0 THEN rb(3) = 1 ELSE rb(3) = 0 ELSEIF rb(1) = rb(3) THEN IF rb(1) = 0 THEN rb(2) = 1 ELSE rb(2) = 0 ELSEIF rb(3) = rb(2) THEN IF rb(3) = 0 THEN rb(1) = 1 ELSE rb(1) = 0 END IF robAns = rb(1) * 100 + rb(2) * 10 + rb(3) GOTO convertAns 'one row is 0 ELSEIF rb(1) = 0 OR rb(2) = 0 OR rb(3) = 0 THEN 'see if any row is 1 IF rb(1) = 1 OR rb(2) = 1 OR rb(3) = 1 THEN IF rb(1) <> 1 THEN rb(1) = 0 IF rb(2) <> 1 THEN rb(2) = 0 IF rb(3) <> 1 THEN rb(3) = 0 robAns = rb(1) * 100 + rb(2) * 10 + rb(3) GOTO convertAns END IF 'make rows even IF rb(1) = 0 THEN IF rb(2) > rb(3) THEN rb(2) = rb(3) ELSE rb(3) = rb(2) ELSEIF rb(2) = 0 THEN IF rb(1) > rb(3) THEN rb(1) = rb(3) ELSE rb(3) = rb(1) ELSE IF rb(1) > rb(2) THEN rb(1) = rb(2) ELSE rb(2) = rb(1) END IF 'handle very end play IF rb(1) = 1 OR rb(2) = 1 THEN IF rb(1) = 1 THEN rb(1) = 0 ELSE rb(3) = 0 END IF robAns = rb(1) * 100 + rb(2) * 10 + rb(3) GOTO convertAns END IF x = rb(1) * 100 + rb(2) * 10 + rb(3) 'make validation array isValid(123) = 1 isValid(132) = 1 isValid(142) = 1 isValid(143) = 1 isValid(152) = 1 isValid(153) = 1 isValid(213) = 1 isValid(231) = 1 isValid(241) = 1 isValid(243) = 1 isValid(251) = 1 isValid(253) = 1 isValid(312) = 1 isValid(321) = 1 isValid(341) = 1 isValid(342) = 1 isValid(351) = 1 isValid(352) = 1 isValid(412) = 1 isValid(413) = 1 isValid(421) = 1 isValid(423) = 1 isValid(431) = 1 isValid(432) = 1 isValid(451) = 1 isValid(452) = 1 isValid(453) = 1 isValid(512) = 1 isValid(513) = 1 isValid(521) = 1 isValid(523) = 1 isValid(531) = 1 isValid(532) = 1 isValid(541) = 1 isValid(542) = 1 isValid(543) = 1 isValid(612) = 1 isValid(613) = 1 isValid(621) = 1 isValid(623) = 1 isValid(631) = 1 isValid(632) = 1 isValid(641) = 1 isValid(642) = 1 isValid(643) = 1 isValid(651) = 1 isValid(652) = 1 isValid(653) = 1 isValid(712) = 1 isValid(713) = 1 isValid(721) = 1 isValid(723) = 1 isValid(731) = 1 isValid(732) = 1 isValid(741) = 1 isValid(742) = 1 isValid(743) = 1 isValid(751) = 1 isValid(752) = 1 isValid(753) = 1 'possible win array. If = 1 then human loses youLose(123) = 0 youLose(132) = 0 youLose(142) = 1 youLose(143) = 1 youLose(152) = 1 youLose(153) = 1 youLose(213) = 0 youLose(231) = 0 youLose(241) = 1 youLose(243) = 1 youLose(251) = 1 youLose(253) = 1 youLose(312) = 0 youLose(321) = 0 youLose(341) = 1 youLose(342) = 1 youLose(351) = 1 youLose(352) = 1 youLose(412) = 1 youLose(413) = 1 youLose(421) = 1 youLose(423) = 1 youLose(431) = 1 youLose(432) = 1 youLose(451) = 0 youLose(452) = 1 youLose(453) = 1 youLose(512) = 1 youLose(513) = 1 youLose(521) = 1 youLose(523) = 1 youLose(531) = 1 youLose(532) = 1 youLose(541) = 0 youLose(542) = 1 youLose(543) = 1 youLose(612) = 1 youLose(613) = 1 youLose(621) = 1 youLose(623) = 1 youLose(631) = 1 youLose(632) = 1 youLose(641) = 1 youLose(642) = 0 youLose(643) = 1 youLose(651) = 1 youLose(652) = 1 youLose(653) = 0 youLose(712) = 1 youLose(713) = 1 youLose(721) = 1 youLose(723) = 1 youLose(731) = 1 youLose(732) = 1 youLose(741) = 1 youLose(742) = 1 youLose(743) = 0 youLose(751) = 1 youLose(752) = 0 youLose(753) = 1 IF youLose(x) = 1 THEN FOR ii = 752 TO 123 STEP -1 IF isValid(ii) = 1 THEN IF youLose(ii) = 0 THEN IF ii < x THEN s1 = x \ 100 s2 = (x - s1 * 100) \ 10 s3 = x MOD 10 si1 = ii \ 100 si2 = (ii - si1 * 100) \ 10 si3 = ii MOD 10 IF s1 = si1 AND s2 = si2 OR _ s1 = si1 AND s3 = si3 OR _ s2 = si2 AND s3 = si3 THEN robAns = ii: GOTO convertAns END IF END IF END IF END IF NEXT ? "I found no win! error somewhere." ELSE s1 = x \ 100 s2 = (x - s1 * 100) \ 10 s3 = x MOD 10 si1 = s1: si2 = s2: si3 = s3 reRand: rChoice = RND(1, 3) 'I got no good move IF s1 - s2 <> 1 AND s1 - s3 <> 1 AND s1 > 1 AND rChoice = 1 THEN DECR s1 'one off top row ELSEIF s2 - s1 <> 1 AND s2 - s3 <> 1 AND s2 > 1 AND rChoice = 2 THEN DECR s2 'one off mid row ELSEIF s3 - s1 <> 1 AND s3 - s2 <> 1 AND s3 > 1 AND rChoice = 3 THEN DECR s3 'one off low row ELSE INCR rndCnt IF rndCnt < 3 GOTO reRand 'try the above more competitive method 3x IF s1 >= s2 AND s1 >= s3 AND rChoice = 1 THEN DECR s1 ELSEIF s2 >= s1 AND s2 >= s3 AND rChoice = 2 THEN DECR s2 ELSEIF rChoice = 3 THEN DECR s3 END IF END IF IF s1 = si1 AND s2 = si2 AND s3 = si3 GOTO reRand robAns = s1 * 100 + s2 * 10 + s3 END IF convertAns: s1 = robAns \ 100 s2 = (robAns - s1 * 100) \ 10 s3 = robAns MOD 10 IF r(1) <> s1 THEN FUNCTION = 10 + r(1) - s1 ELSEIF r(2) <> s2 THEN FUNCTION = 20 + r(2) - s2 ELSEIF r(3) <> s3 THEN FUNCTION = 30 + r(3) - s3 ELSE IF s1 >= s2 AND s1 >= s3 THEN FUNCTION = 11 ELSEIF s2 >= s1 AND s2 >= s3 THEN FUNCTION = 21 ELSE FUNCTION = 31 END IF END IF END FUNCTION FUNCTION rndGuess(bArr() AS LONG) AS LONG LOCAL x AS LONG IF bArr(1) + bArr(2) + bArr(3) > 0 THEN DO: x = RND(1, 3): LOOP WHILE bArr(x) = 0 END IF IF x = 1 THEN FUNCTION = x * 10 + RND(1, bArr(1)) IF x = 2 THEN FUNCTION = x * 10 + RND(1, bArr(2)) IF x = 3 THEN FUNCTION = x * 10 + RND(1, bArr(3)) END FUNCTIONLeave a comment:
-
Bingo
Right On The Money, Marco. Good job. That was it. I even remember the name of the author - Leo Christopher. I think he used to write articles in the TRS 80 Mags of the time (there were two or three) teaching programming techniques. They were the only source (pretty much) for those who had no experience with computers and had to write our own software.
The Win version (Android Nim) is the same game but I recall the TRS 80 version as being hipper and more cheeky. This one (logic aside) just seems sophomoric. (Not that 30 yro memories could have dulled the edges. Wasn't everything just, ah .., better in the old days?) The logic is still cool though.
I tried the DOS version (a C version written 12+ years later - not the the original in Basic which would have been cool to try) but it wouldn't run. It closes immediately as soon as the program ran.Leave a comment:
-
Probably it was Android Nim.
A video from the PET version:
YouTube - ANDROID NIM - Game for the Commodore PET
Windows version by the original author and some info:
Bye!Last edited by Marco Pontello; 22 Apr 2008, 07:58 PM.Leave a comment:
-
Ahhhh the ole' "Trash-80"
Back when "Hard-Drive" meant "Cassette-Tape"
GAWWWWD....I loved that machine.....(It is probably what 1st got me programming even before a friend of mine got this "Whizzy-Bang" Commodore-64, that you could even play games on, and better than Atari???)
I wish I could remember the name of the game, but maybe a google for 80's computer games, TRS-80 may pull something up...(pretty sure some of the sites dedicated to the old games and emulators, but not sure on source code, so it would take some doing)
If I had the time, I would be interested in file size of the original, vs a PB port, vs (a more sadistic idea of .NET languages, and M$ 6 languages) to see how an original idea can grow and grow for the same concept of the game (code MUST stay as close to the original as possible though for a true test)
(Hey is it me? or is there no "Devil" / "Evil" icon to be used for the word "Sadistic"?????)
Gosta...if you can think of the name, I am sure we can find it....(hmmmmm...I wonder if that ole' beater of mine is still sitting in my parents basement? and even more if it still works????)Leave a comment:
-
Hey there Gösta, I remember a game/puzzle like that--tho I never saw a computer version of it. It was three lines of 1's and, alternating turns, you cross off any number of 1's in only one row per turn, the object being to force the opponent to cross off the last 1. I don't remember the exact 1-count per line either, but it was three odd numbers almost for sure.
I've been looking for it but can't find anything about it either. There is some trick where you can always win by, like, keeping two rows even and one odd or whatever. Clearly, I didn't memorize the trick. Suffice it to say that against anyone who knew the method, I always lost.Code:111111111 11111 111
At least I never played it for any (significant) bucks. 
Leave a comment:
-
The way John packed these strings into longs and dwords got me to thinking about an early computer game for the TRS 80's. It was a tricky logic game. 3 rows of robots, each of an odd number (5, 7 & 9 IIRC). The TRS 80's were character oriented only (about zero graphics capabilities) and advanced programmers would use packed strings to create little blocky characters that could "dance". (Using an upper ASCCI set that could be put together to make "graphics")
In this particular two player game, either player could pick as many robots from a row as he wanted as long as he left at least 1. The game would go until one player had to pick the last robot from a row.
What made this particular game so neat (other than its clever simplicity) was the really clunky nature of the guiding robot who would either eagerly nod "yes" or shake his head sadly for "no" when player made a choice. Just had to make you chuckle. Every once in a while it will pop into my mind and I will do a lazy half hearted search for it but never could find it. (Probably help if I recalled the name.)
I wonder if any here recall the game and/or if there is a Windows version avl.
============================================================
"Anything that is too stupid to be spoken is sung."
Voltaire (1694-1778)
============================================================Leave a comment:
-
From what I have noticed in POFFS and some other un-archived forums is that Windows will use the 1st icon alphanumerically declared in your resource file. So in this case (assuming the icons are "Anchor.ico" and "Zero.ico" then your program shows "Zero.ico" but the icon in Windows explorer will show "Anchor.ico" even though you declared your small icon to be "Zero.ico"Leave a comment:
-
Re the Icon, to reset the icon on the desktop you'll have to do that via Properties/Set Icon (right click on the shortcut). I looked in the Sub Create_Shortcut code (which is nearly all C&P'ed from POFFS) but could find no reference to which Icon is used. The OpSys may use a number something, wheras I refence by name in the PBR.
Note I made a couple minor changes in the GUI (chgd Font in Textboxes, ...):
=========================================
"We are not retreating
we are advancing in another Direction."
General Douglas MacArthur (1880-1964)
=========================================Leave a comment:
-
Never noticed. The anchor is an icon I use sometimes in my stuff. I'll correct it. Probably never changed in the Desktop icon code.Originally posted by John Gleason View PostLast edited by Gösta H. Lovgren-2; 8 Mar 2008, 12:29 PM.Leave a comment:
-
The kid I referred to is "Zero". For some reason, my main icon is a blue anchor on a white background. "Zero" is on the little taskbar & explorer icon.As for the icon, it's "Zero" from Beetle Bailey. I'm not familiar with "the kid". Who would that be?
This code below does up to 14-word sequences for 4,5, and 6 letters. The catch? After a couple searches (occasionally maybe even on the second search) it page faults. But the first search has always worked, so you'll get the answer at least. That's why I call it the Research Only version. :thinking: If ya think about it, what are a couple clicks to restart the program in the big scheme of things? As of a few days ago, finding a 14-word connection would have taken, what, 14 days? weeks? months? hehheh
'Code:'5 ltr ''SWIMS-CRAMP. It produced SWIMS SLIMS SLAMS CLAMS CLAMP CRAMP. ' Inword = UCASE$("creepy") ' outWord = UCASE$("shocks") ' Inword = UCase$("voting") ' outWord = UCase$("server") ' Word_Connections.Bas ' ' This project started here: 'http://www.powerbasic.com/support/pbforums/showthread.php?t=36427 ' ' The files are here: 'http://www.SwedesDock.com/powerbasic/Word_Connections.exe 'http://www.SwedesDock.com/powerbasic/z_WC_All_Files_Needed.zip ' ' ' GUI by Gösta H. Lovgren (Feb 2008) ' Solving functions by John Gleason (Feb 2008) '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' ' Changes required for adding new letter connection Functions ' 1) Just add to Select Case in "Sub John_Solver" ' ' 2) Rem these two lines in new Function ' ' If ii3 < 8 Then ? "Note: Only up to eight sequences will be shown of possibly 100's" & $CrLf & $CrLf & _ ' RTrim$(sTemp) 'there can be hundreds, so ii3 limits it to 8 results ' ' 3) Add these two lines at same place ' ' ReDim Preserve Sequences$(UBound(Sequences$()) + 1) ' Sequences$(UBound(Sequences$())) = sTemp ' ' 4) Add these lines at beginning in newly added Functions ' inWord = First_Word$ ' outWord = Last_Word$ ' ' 5) Rem any "inword = " in Function ' Rem any outWord = " in Function ' ' 6) Search & Replace: ' "? RTrim$(sTemp)" ' With ' "'? RTrim$(sTemp)" ' ' Fingers Crossed, I think that's all that's needed ' ' 'Latest replacemts: '1 at here: (in functions 3, 4 & 5) ' Local inWord As String * %NUMBofLETTERS3, outWord As String * %NUMBofLETTERS3 ' add : ' inWord = First_Word$ ' outWord = Last_Word$ ' '2 Rem all "Print #2, inWord, outWord" 's ' Insert underneath: ' ReDim Preserve Sequences$(UBound(Sequences$()) + 1) ' Sequences$(UBound(Sequences$())) = sTemp ' '------------------------------------------------------------------------------ ' Note - you may have to Rem "Call Backup" in PBMain if I forget. {oh well} ' If so you'll probably get an msgbox or error when exitting. '------------------------------------------------------------------------------ ' This program may be used for any purpose whatsoever; ' sale, gift, sharing, swapped for dope, ... ' Only after sending certified checks for an appropriate amount to ' John and myself. '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ #COMPILE EXE #DIM ALL '------------------------------------------------------------------------------ ' ** My normal Includes ** '------------------------------------------------------------------------------ #INCLUDE "WIN32API.INC" '#Include "C:\Power Basic\Includes\clipboard.inc" '#Include "C:\Power Basic\Includes\Common_Constants.inc" '#Include "c:\Power Basic\Includes\Fonts.inc" '#Include "c:\Power Basic\Includes\Colors.inc" '#Include "C:\Power Basic\Includes\Common_Macros.inc" '#Include "C:\Power Basic\Includes\process_memoryinfo.inc" '#Include "C:\Power Basic\Includes\Common_Subs_Funcs.inc" '#Resource "C:\Power Basic\Icons\Icons.pbr" '#Include "C:\Power Basic\Includes\File_Exist.inc" '#Include "C:\Power Basic\Includes\Variables_Common_to_All_Programs.inc" '------- End my "normal Includes" not needed in this progam though ------ ' ' Includes specific to this program: ' ' 'my stuff loaded In PB Main ' #Include g_Include_Name$ ' creates g_All_Words$ ' #RESOURCE "Icons.pbr" ' ' ' GLOBAL First_Word$, Last_Word$, Sequences$() '------------------------------------------------------------------------------ TYPE GoodWords Wrd AS STRING * 28 lng AS LONG Good AS LONG ' END TYPE %Box_Height = 20 %Char_Width = 5 %Btn_01 = 1002 %Word_Start = 1003 %Word_Done = 1004 %Working_Label = 1005 %Btn_CB_Toggle = 1006 %ID_EXIT = 1007 %About = 1008 %Cb_All = 1009 %CB_One = 1010 %Cb_Results_Only = 1011 %Btn_Shortcut = 1012 %Cb_Show_It = 1013 %CB_Dialog_Box = 1014 %CB_Erase_It = 1015 %Btn_02 = 1016 '------------------------------------------------------------------------------ ' GLOBAL g_Words$() 'only used to build g_Include_Name$, not used otherwise in prog GLOBAL g_CB_All_or_One& '= 2 as default at startup for Clipboard stuff GLOBAL g_All_Words$ ' All words in 1 string for data checking, assigned vis the above include GLOBAL hMenu AS DWORD GLOBAL hdlg AS DWORD GLOBAL First_Word$, Last_Word$, Sequences$() GLOBAL g_Include_Name$ '= CurDir$ & "Check_Words_5_6.Inc" '5-6 words GLOBAL g_Icon_Id$ '------------------------------------------------------------------------------ ' ** Macros ** '------------------------------------------------------------------------------ ' MACRO Common_Locals LOCAL Reps& LOCAL Number_of_Words&, Words_In_File&, Word_Len& LOCAL total_Words_in_File$ LOCAL W$, w1$, w2$, w3$ LOCAL WL$(), Word_List$ LOCAL Used_Words$() LOCAL Ttls&(), tb_len& LOCAL Chn$, Fw$, Lw$, sw$ 'in Swede_Solver ' Variables_Common_to_All_Programs LOCAL a&, a1&, a2&, a3&, a4&, a5&, Ans&, askii&, Askii_Last& LOCAL b&, Box_Height&, Box_Width&, Btn_Width&, Btn_Height& LOCAL Beep_Freq AS DWORD, Beep_Duration AS DWORD LOCAL Beep_Ctr&, Beep_b& LOCAL Caption$, chk$ LOCAL col&, col1&, col2&, col3&, col4&, col5& LOCAL ctr&, ctr1&, ctr2&, ctr3&, ctr4&, ctr5& LOCAL End_Marked&, Start_Marked& LOCAL er$ 'used for error msgs LOCAL Flag&, Flag1&, Flag2&, Flag3&, Flag4&, Flag5& LOCAL Fle$, Fle1$, Fle2$, Fle3$, Fle4$, Fle5$ LOCAL Flen&, Flen1&, Flen2&, Flen3&, Flen4&, Flen5& LOCAL Fn$, Fn1$, Fn2$, Fn3$, Fn4$, Fn5$ LOCAL fnum&, fnum1&, fnum2&, fnum3&, fnum4&, fnum5& GLOBAL g_Timer# LOCAL hght&, hFont&, Highlighted_Word_Flag& LOCAL i&, i1&, i2&, i3&, i4&, i5& LOCAL Id&, Id1&, Id2&, Id3&, Id4&, Id5& LOCAL l$, l1$, l2$, l3$, l4$, l5$ LOCAL lbl$, Last_i&, lRslt& LOCAL ln&, ln1&, ln2&, ln6&, ln4&, ln5& LOCAL m$, m1$, m2$, m3$, m4$, m5$ LOCAL n$, n1$, n2$, n3$, n4$, n5$ LOCAL nm$, nm1$, nm2$, nm3$, nm4$, nm5$ LOCAL NumLines& LOCAL Row&, Row1&, Row2&, Row3&, Row4&, Row5& LOCAL rn&, rn1& LOCAL s$, s1$, s2$, s3$, s4$, s5$ LOCAL Sln&, sp$, Stile&, stp& LOCAL t$, t1$, t2$, t3$, t4$, t5$ LOCAL Tb_Height&, Tgl$ LOCAL temp$ LOCAL ttl&, ttl1&, ttl2&, ttl3&, ttl4&, ttl5& LOCAL tmp$(), tmp1$(), tmp1$(), tmp2$(), tmp3$(), tmp4$(), tmp5$() LOCAL u$, url$ LOCAL v&, vlu& LOCAL Wdth&, Wait& LOCAL x1&, x2&, x3&, x4&, x5& LOCAL y&, y1&, y2&, y3&, y4&, y5& Wait = 20'2000 'for display purposes %Top = %MB_TASKMODAL 'keep for older msgbox msgs 'Common RGB Colors from Win32Api.Inc ' %Black = &H000000??? ' %Blue = &HFF0000??? ' %Green = &H00FF00??? ' %Cyan = &HFFFF00??? ' %Red = &H0000FF??? ' %Magenta = &HFF00FF??? ' %Yellow = &H00FFFF??? ' %White = &HFFFFFF??? ' %Gray = &H808080??? ' %LtGray = &HC0C0C0??? %Purple = &hFF5588 %BabyBlue = 167 + (241 * 256) + (252 * 256 * 256) %Pink = 255 + (132 * 256) + (132 * 256 * 256) %Cream = 252 + (241 * 256) + (167 * 256 * 256) %BiliousYG = %Cream + 1000 ' Bilious Yellow Green %MintGreen = &HD0FFD0 %Win_Gray = &hEAE9E8 END MACRO ' MACRO Is_It_Valid = i = INSTR(g_All_Words$, " " & sw$ & " ") ' MACRO m_Done = DIALOG END hDlg ' MACRO Label_ClipBoard SELECT CASE g_CB_All_or_One CASE 0 lbl$ = "Add All Chains to Clipboard" CASE 1 lbl$ = "Add Only the Current Chain to Clipboard" CASE 2 lbl$ = "Add Only Results to Clipboard" END SELECT CONTROL SET TEXT CBHNDL, %Btn_CB_Toggle, lbl$ END MACRO ' ' MACRO m_T_into_Tmp_Array ctr = PARSECOUNT(t$, $CRLF) DIM tmp$(ctr) PARSE t$, tmp$(), $CRLF END MACRO ' MACRO Label_Bum_Input BEEP lbl$ = $CRLF & $CRLF & "! ! ! ! ! ! !" & $CRLF & $CRLF & _ lbl$ & $CRLF & $CRLF & "! ! ! ! ! ! !" CONTROL SET COLOR hDlg, %Working_Label, %YELLOW, %Purple CONTROL SET TEXT hDlg, %Working_Label, lbl$ EXIT SUB END MACRO ' MACRO Label_Set_Main CONTROL SET COLOR hDlg, %Working_Label, -1, %Win_Gray lbl$ = $CRLF & _ "Solving Algorithm " & $CRLF & _ " Courtesy of: " & $CRLF & $CRLF & _ " John Gleason " & $CRLF & $CRLF & _ " and " & $CRLF & _ " PowerBASIC Forums" CONTROL SET TEXT hDlg, %Working_Label, lbl$ END MACRO ' MACRO Label_Set_Working CONTROL SET COLOR hDlg, %Working_Label, -1, %YELLOW lbl$ = $CRLF & _ "Working" & $CRLF & _ "on" & $CRLF & _ "Algorithm" & $CRLF & _ "for" & $CRLF & _ MCASE$(First_Word$) & " " & MCASE$(Last_Word$) CONTROL SET TEXT hDlg, %Working_Label, lbl$ SLEEP Wait END MACRO ' MACRO Label_Set_No_Answer CONTROL SET COLOR hDlg, %Working_Label, %WHITE, %Pink lbl$ = $CRLF & $CRLF & "No Chains found!" & _ $CRLF & $CRLF & _ First_Word$ & " to " & Last_Word$ & $CRLF & $CRLF & _ "Solved in " & $CRLF & _ USING$(".## Seconds ", TIMER - g_Timer) CONTROL SET TEXT hDlg, %Working_Label, lbl$ REPLACE $CRLF WITH " " IN lbl$ t$ = lbl$ Set_Clipboard SLEEP Wait SLEEP Wait END MACRO ' MACRO Label_Set_Done CONTROL SET COLOR hDlg, %Working_Label, -1, %BabyBlue lbl$ = $CRLF & _ MCASE$(First_Word$) & $CRLF & _ "to " & $CRLF & _ MCASE$(Last_Word$) & $CRLF & $CRLF & _ USING$("# Answer Chains", Flag) & $CRLF & _ "(in the Clipboard)" & $CRLF & $CRLF & _ "Solved in" & $CRLF & _ USING$(" .## Seconds", TIMER - g_Timer) CONTROL SET TEXT hDlg, %Working_Label, lbl$ SLEEP Wait SLEEP Wait END MACRO ' MACRO m_Input_Open fnum = FREEFILE OPEN fn$ FOR INPUT AS #fnum m$ = fn$ 'for err msg m1$ = "m_Input_Open" m_Err_Msg END MACRO ' MACRO m_Output_Open fnum = FREEFILE OPEN fn$ FOR OUTPUT AS #fnum m$ = fn$ 'for err msg m1$ = "m_Output_Open" m_Err_Msg END MACRO ' MACRO pf = PRINT #fnum, ' MACRO pf1 = PRINT #fnum1, ' MACRO pf2 = PRINT #fnum2, ' MACRO m_Binary_Open fnum = FREEFILE OPEN fn$ FOR BINARY AS fnum flen = LOF(fnum) Fle$ = SPACE$(flen)'create a space to put the file GET fnum,,fle$ 'put the file in the space CLOSE fnum m$ = fn$ m1$ = "m_Binary_Open" m_Err_Msg 'Msgbox if an error END MACRO ' MACRO m_Err_Msg IF ERR THEN Stile = %MB_SYSTEMMODAL OR _ %MB_ICONERROR OR _ %MB_ICONWARNING ? m$ & $CRLF & $CRLF & _ m1$ & $CRLF & $CRLF & _ USING$("# ", ERR) & ERROR$(ERR),_ Stile, _ " In " & FUNCNAME$ END IF RESET m$, m1$ END MACRO ' MACRO mb MSGBOX m$ & $CRLF & $CRLF & m1$, _ %MB_TASKMODAL, _ " In " & FUNCNAME$ RESET m$, m1$ END MACRO ' MACRO mb_Alert MSGBOX m$ & $CRLF & $CRLF & m1$, _ %MB_TASKMODAL OR %MB_ICONWARNING, _ " In " & FUNCNAME$ RESET m$, m1$ END MACRO ' MACRO Only_The_Results END MACRO ' '------------------------------------------------------------------------------ ' 'John's stuff '------------------------------------------------------------------------------ ' '------------------------------------------------------------------------------ ' '------------------------------------------------------------------------------ ' '------------------------------------------------------------------------------ ' $NULL3 = CHR$(0,0,0,32) $NULL4 = CHR$(0,0,0,0,32) $NULL5 = CHR$(0,0,0,0,0,32) $NULL6 = CHR$(0,0,0,0,0,0,32) %NUMBofLETTERS3 = 3 %NUMBofLETTERS4 = 4 %NUMBofLETTERS5 = 5 %NUMBofLETTERS6 = 6 %NUMBERofWORDS3 = 853 %NUMBERofWORDS4 = 3130 %NUMBERofWORDS5 = 6919 %NUMBERofWORDS6 = 11492 %ARRAYsIZE1 = 100 'if there is a GPF, try making one or more of these array size equates larger %ARRAYsIZE2 = 2000 ' " %ARRAYsIZE3 = 8000 ' " %ARRAYsIZE4 = 32000 ' " %ARRAYsIZE5 = 48000 ' " %ARRAYsIZE6 = 96000 ' " %RDTSC = &h310f #INCLUDE "fiveLetterWordsCompresAsm.inc" 'contains function fiveLetterWords() which is all 5-letter words compressed #INCLUDE "sixLetterWordsCompresAsm.inc" 'contains function sixLetterWords() which is all 6-letter words compressed #INCLUDE "fourLetterWordsCompresAsm.inc" 'contains function fourLetterWords() which is all 4-letter words compressed #INCLUDE "threeLetterWordsCompresAsm.inc" 'contains function threeLetterWords() which is all 3-letter words compressed MACRO J_mFirstMatchForDifference(mNUMBERofWORDS, mNUMBofLETTERS) index = 0 FOR ii3 = 0 TO mNUMBERofWORDS 'starting with inWord, test it for any 1-letter-different matches IF wordOrig6(ii3) = inWord THEN FOR ii2 = 1 TO mNUMBofLETTERS acacia(ii2) = word6(ii3) AND blank(ii2) FOR ii = 0 TO mNUMBERofWORDS IF (word6(ii) AND blank(ii2)) = acacia(ii2) THEN IF ii <> ii3 THEN 'eliminate match with itself a1(index) = word6(ii) as1(index) = wordOrig6(ii) & inWord INCR index END IF END IF NEXT NEXT END IF NEXT index2 = 0 FOR ii3 = 0 TO mNUMBERofWORDS 'starting with outWord, test it for any 1-letter-different matches IF wordOrig6(ii3) = outWord THEN FOR ii2 = 1 TO mNUMBofLETTERS acacia(ii2) = word6(ii3) AND blank(ii2) FOR ii = 0 TO mNUMBERofWORDS IF (word6(ii) AND blank(ii2)) = acacia(ii2) THEN IF ii <> ii3 THEN 'eliminate match with itself b1(index2) = word6(ii) bs1(index2) = wordOrig6(ii) & outWord INCR index2 END IF END IF NEXT NEXT END IF NEXT END MACRO MACRO J_mMatchAndRemoveDupes(index, index2, index3, index4, a1, a2, b1, b2, as1, as2, bs1, bs2, mLASTaRRAYsIZE, mNUMBERofWORDS, mNUMBofLETTERS) FOR ii4 = 0 TO index - 1 FOR ii3 = 0 TO mNUMBERofWORDS 'starting with a1(), test it for any 1-letter-different matches IF word6(ii3) = a1(ii4) THEN FOR ii2 = 1 TO mNUMBofLETTERS acacia(ii2) = word6(ii3) AND blank(ii2) FOR ii = 0 TO mNUMBERofWORDS IF (word6(ii) AND blank(ii2)) = acacia(ii2) THEN IF ii <> ii3 THEN 'eliminate match with itself a2(index3) = word6(ii) as2(index3) = wordOrig6(ii) & as1(ii4) INCR index3 END IF END IF NEXT NEXT END IF NEXT NEXT FOR ii4 = 0 TO index2 - 1 FOR ii3 = 0 TO mNUMBERofWORDS 'starting with b(1), test it for any 1-letter-different matches IF word6(ii3) = b1(ii4) THEN FOR ii2 = 1 TO mNUMBofLETTERS acacia(ii2) = word6(ii3) AND blank(ii2) FOR ii = 0 TO mNUMBERofWORDS IF (word6(ii) AND blank(ii2)) = acacia(ii2) THEN IF ii <> ii3 THEN 'eliminate match with itself b2(index4) = word6(ii) bs2(index4) = wordOrig6(ii) & bs1(ii4) INCR index4 END IF END IF NEXT NEXT END IF NEXT NEXT 'eliminate duplicates in a2() and as2() < this is the human readable version of a2() ARRAY SORT a2(), TAGARRAY as2() ii2 = 0 FOR ii = 0 TO mLASTaRRAYsIZE - 1 IF a2(ii) = 0 THEN ITERATE FOR IF a2(ii) = a2(ii + 1) THEN ITERATE FOR ELSE a2(ii2) = a2(ii) as2(ii2) = as2(ii) INCR ii2 END IF NEXT IF a2(mLASTaRRAYsIZE - 1) <> a2(mLASTaRRAYsIZE) THEN 'handle last element a2(ii2) = a2(mLASTaRRAYsIZE) as2(ii2) = as2(mLASTaRRAYsIZE) INCR ii2 END IF FOR ii = ii2 TO mLASTaRRAYsIZE a2(ii) = 0 as2(ii) = "" NEXT 'eliminate duplicates in b2() and bs2() < this is the human readable version of b2() ARRAY SORT b2(), TAGARRAY bs2() ii2 = 0 FOR ii = 0 TO mLASTaRRAYsIZE - 1 IF b2(ii) = 0 THEN ITERATE FOR IF b2(ii) = b2(ii + 1) THEN ITERATE FOR ELSE b2(ii2) = b2(ii) bs2(ii2) = bs2(ii) INCR ii2 END IF NEXT IF b2(mLASTaRRAYsIZE - 1) <> b2(mLASTaRRAYsIZE) THEN 'handle last element (mLASTaRRAYsIZE) b2(ii2) = b2(mLASTaRRAYsIZE) bs2(ii2) = bs2(mLASTaRRAYsIZE) INCR ii2 END IF FOR ii = ii2 TO mLASTaRRAYsIZE b2(ii) = 0 bs2(ii) = "" NEXT END MACRO MACRO J_mFindSolution3letters(as1, bs1, seqLenMax) IF ASC(bs1(ii2)) < 65 THEN EXIT FOR IF ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 2) = ASC(bs1(ii2), 2) OR _ ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) OR _ ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) THEN maxSeqLen = seqLenMax FOR ii4 = 1 TO maxSeqLen q4(ii4) = CVQ(MID$(as1(ii), (maxSeqLen - ii4) * %NUMBofLETTERS3 + 1, %NUMBofLETTERS3)) q4(ii4 + maxSeqLen) = CVQ(MID$(bs1(ii2), (ii4 - 1) * %NUMBofLETTERS3 + 1, %NUMBofLETTERS3)) NEXT FOR ii5 = 1 TO maxSeqLen + maxSeqLen - 2 FOR ii4 = 1 TO %NUMBofLETTERS3 FOR ii6 = ii5 + 2 TO maxSeqLen + maxSeqLen IF (q4(ii5) AND blankq(ii4)) = (q4(ii6) AND blankq(ii4)) AND q4(ii5) > 0 THEN IF extend < ii6 THEN extend = ii6 END IF NEXT NEXT FOR ii6 = ii5 + 1 TO extend - 1 q4(ii6) = 0 NEXT extend = 0 NEXT sTemp = SPACE$(maxSeqLen * (%NUMBofLETTERS3 + 1) * 2 - 1) FOR ii4 = 1 TO maxSeqLen * 2 MID$(sTemp, (ii4 - 1) * (%NUMBofLETTERS3 + 1) + 1, %NUMBofLETTERS3) = MKQ$(q4(ii4)) NEXT INCR ii3 REPLACE $NULL3 WITH "" IN sTemp ' Print #2, sTemp REDIM PRESERVE Sequences$(UBOUND(Sequences$()) + 1) Sequences$(UBOUND(Sequences$())) = sTemp ' m$ = stemp:mb END IF END MACRO MACRO J_mFindSolution4letters(as1, bs1, seqLenMax) IF ASC(bs1(ii2)) < 65 THEN EXIT FOR IF ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 2) = ASC(bs1(ii2), 2) _ AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) OR _ ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) _ AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) OR _ ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) _ AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) OR _ ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 2) = ASC(bs1(ii2), 2) _ AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) THEN maxSeqLen = seqLenMax FOR ii4 = 1 TO maxSeqLen q4(ii4) = CVQ(MID$(as1(ii), (maxSeqLen - ii4) * %NUMBofLETTERS4 + 1, %NUMBofLETTERS4)) q4(ii4 + maxSeqLen) = CVQ(MID$(bs1(ii2), (ii4 - 1) * %NUMBofLETTERS4 + 1, %NUMBofLETTERS4)) NEXT FOR ii5 = 1 TO maxSeqLen + maxSeqLen - 2 FOR ii4 = 1 TO %NUMBofLETTERS4 FOR ii6 = ii5 + 2 TO maxSeqLen + maxSeqLen IF (q4(ii5) AND blankq(ii4)) = (q4(ii6) AND blankq(ii4)) AND q4(ii5) > 0 THEN IF extend < ii6 THEN extend = ii6 END IF NEXT NEXT FOR ii6 = ii5 + 1 TO extend - 1 q4(ii6) = 0 NEXT extend = 0 NEXT sTemp = SPACE$(maxSeqLen * (%NUMBofLETTERS4 + 1) * 2 - 1) FOR ii4 = 1 TO maxSeqLen * 2 MID$(sTemp, (ii4 - 1) * (%NUMBofLETTERS4 + 1) + 1, %NUMBofLETTERS4) = MKQ$(q4(ii4)) NEXT INCR ii3 REPLACE $NULL4 WITH "" IN sTemp ' Print #2, sTemp REDIM PRESERVE Sequences$(UBOUND(Sequences$()) + 1) Sequences$(UBOUND(Sequences$())) = sTemp END IF END MACRO MACRO J_mFindSolution5letters(as1, bs1, seqLenMax) IF ASC(bs1(ii2)) < 65 THEN EXIT FOR IF ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) _ AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) OR _ ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) _ AND ASC(as1(ii), 5) = ASC(bs1(ii2), 5) OR _ ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) _ AND ASC(as1(ii), 5) = ASC(bs1(ii2), 5) OR _ ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) _ AND ASC(as1(ii), 5) = ASC(bs1(ii2), 5) OR _ ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) _ AND ASC(as1(ii), 5) = ASC(bs1(ii2), 5) THEN maxSeqLen = seqLenMax FOR ii4 = 1 TO maxSeqLen q4(ii4) = CVQ(MID$(as1(ii), (maxSeqLen - ii4) * %NUMBofLETTERS5 + 1, %NUMBofLETTERS5)) q4(ii4 + maxSeqLen) = CVQ(MID$(bs1(ii2), (ii4 - 1) * %NUMBofLETTERS5 + 1, %NUMBofLETTERS5)) NEXT FOR ii5 = 1 TO maxSeqLen + maxSeqLen - 2 FOR ii4 = 1 TO %NUMBofLETTERS5 FOR ii6 = ii5 + 2 TO maxSeqLen + maxSeqLen IF (q4(ii5) AND blankq(ii4)) = (q4(ii6) AND blankq(ii4)) AND q4(ii5) > 0 THEN IF extend < ii6 THEN extend = ii6 END IF NEXT NEXT FOR ii6 = ii5 + 1 TO extend - 1 q4(ii6) = 0 NEXT extend = 0 NEXT sTemp = SPACE$(maxSeqLen * (%NUMBofLETTERS5 + 1) * 2 - 1) FOR ii4 = 1 TO maxSeqLen * 2 MID$(sTemp, (ii4 - 1) * (%NUMBofLETTERS5 + 1) + 1, %NUMBofLETTERS5) = MKQ$(q4(ii4)) NEXT INCR ii3 REPLACE $NULL5 WITH "" IN sTemp ' Print #2, sTemp REDIM PRESERVE Sequences$(UBOUND(Sequences$()) + 1) Sequences$(UBOUND(Sequences$())) = sTemp END IF END MACRO MACRO J_mFindSolution6letters(as1, bs1, seqLenMax) IF ASC(bs1(ii2)) < 65 THEN EXIT FOR IF ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) _ AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) AND ASC(as1(ii), 5) = ASC(bs1(ii2), 5) OR _ ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) _ AND ASC(as1(ii), 5) = ASC(bs1(ii2), 5) AND ASC(as1(ii), 6) = ASC(bs1(ii2), 6) OR _ ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) _ AND ASC(as1(ii), 5) = ASC(bs1(ii2), 5) AND ASC(as1(ii), 6) = ASC(bs1(ii2), 6) OR _ ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 4) = ASC(bs1(ii2), 4) _ AND ASC(as1(ii), 5) = ASC(bs1(ii2), 5) AND ASC(as1(ii), 6) = ASC(bs1(ii2), 6) OR _ ASC(as1(ii), 1) = ASC(bs1(ii2), 1) AND ASC(as1(ii), 2) = ASC(bs1(ii2), 2) AND ASC(as1(ii), 3) = ASC(bs1(ii2), 3) _ AND ASC(as1(ii), 5) = ASC(bs1(ii2), 5) AND ASC(as1(ii), 6) = ASC(bs1(ii2), 6) THEN 'make SURE it is shortest possible sequence... maxSeqLen = seqLenMax 'this is per side, eg. PINS PANS PARS is three long max at this point FOR ii4 = 1 TO maxSeqLen 'this loop splits up string into quads to make comparison easier q4(ii4) = CVQ(MID$(as1(ii), (maxSeqLen - ii4) * %NUMBofLETTERS6 + 1, %NUMBofLETTERS6)) q4(ii4 + maxSeqLen) = CVQ(MID$(bs1(ii2), (ii4 - 1) * %NUMBofLETTERS6 + 1, %NUMBofLETTERS6)) NEXT __ __ __ __ __ __ __ __ __ __ FOR ii5 = 1 TO maxSeqLen + maxSeqLen - 2 'eg. this loop removes "PANS" from this: PINS PANS PUNS FOR ii4 = 1 TO %NUMBofLETTERS6 'it also removes "split dupes" eg. POLE DOLE POLE becomes POLE FOR ii6 = ii5 + 2 TO maxSeqLen + maxSeqLen IF (q4(ii5) AND blankq(ii4)) = (q4(ii6) AND blankq(ii4)) AND q4(ii5) > 0 THEN IF extend < ii6 THEN extend = ii6 END IF NEXT NEXT FOR ii6 = ii5 + 1 TO extend - 1 q4(ii6) = 0 NEXT extend = 0 NEXT sTemp = SPACE$(maxSeqLen * (%NUMBofLETTERS6 + 1) * 2 - 1)'+ 1 is for space separator, - 1 eliminates 'trailing space FOR ii4 = 1 TO maxSeqLen * 2 'convert quads back to string MID$(sTemp, (ii4 - 1) * (%NUMBofLETTERS6 + 1) + 1, %NUMBofLETTERS6) = MKQ$(q4(ii4)) NEXT INCR ii3 REPLACE $NULL6 WITH "" IN sTemp 'get rid of dupes ' Print #2, sTemp REDIM PRESERVE Sequences$(UBOUND(Sequences$()) + 1) Sequences$(UBOUND(Sequences$())) = sTemp END IF END MACRO MACRO FUNCTION superRandom MACROTEMP superR LOCAL superR AS DWORD !dw %RDTSC !Xor eax, edx !mov superR, eax END MACRO = superR DECLARE FUNCTION twoSixLetterWords() AS LONG DECLARE FUNCTION twoFiveLetterWords() AS LONG DECLARE FUNCTION twoFourLetterWords() AS LONG DECLARE FUNCTION twoThreeLetterWords() AS LONG 'FUNCTION twoFourLetterWords(inWord AS STRING * %NUMBofLETTERS4, outWord AS STRING * %NUMBofLETTERS4) AS LONG FUNCTION J_twoFourLetterWords() AS LONG Common_Locals LOCAL lineo AS STRING, ii, ii2, ii3, ii4, ii5, ii6, extend, index, index2, index3, index4 AS LONG LOCAL index5, index6, index7, index8, index9, index10, index11, index12, endLoop, maxSeqLen AS LONG LOCAL sTemp, allFourLetterWords AS STRING, wo6ptr AS BYTE PTR DIM q4(10) AS QUAD, acacia(6) AS LONG, blank(6) AS LONG, blankq(8) AS QUAD DIM wordOrig6(%NUMBERofWORDS4) AS STRING * %NUMBofLETTERS4 DIM a1(%ARRAYsIZE1) AS LONG, a2(%ARRAYsIZE2) AS LONG, a3(%ARRAYsIZE3) AS LONG, a4(%ARRAYsIZE4) AS LONG, a5(%ARRAYsIZE5) AS LONG, a6(%ARRAYsIZE6) AS LONG DIM b1(%ARRAYsIZE1) AS LONG, b2(%ARRAYsIZE2) AS LONG, b3(%ARRAYsIZE3) AS LONG, b4(%ARRAYsIZE4) AS LONG, b5(%ARRAYsIZE5) AS LONG, b6(%ARRAYsIZE6) AS LONG DIM as1(%ARRAYsIZE1) AS STRING, as2(%ARRAYsIZE2) AS STRING, as3(%ARRAYsIZE3) AS STRING, as4(%ARRAYsIZE4) AS STRING, as5(%ARRAYsIZE5) AS STRING, as6(%ARRAYsIZE6) AS STRING DIM bs1(%ARRAYsIZE1) AS STRING, bs2(%ARRAYsIZE2) AS STRING, bs3(%ARRAYsIZE3) AS STRING, bs4(%ARRAYsIZE4) AS STRING, bs5(%ARRAYsIZE5) AS STRING, bs6(%ARRAYsIZE6) AS STRING LOCAL inWord AS STRING * %NUMBofLETTERS4, outWord AS STRING * %NUMBofLETTERS4 inWord = First_Word$ outWord = Last_Word$ '----------------------------------------------------------- 'put words in a fast to use LONG format and store in word6() array. 6 is max letters for this technique, 4 used here. 'if 7 or more needed (12 max), the algo would need to go to QUAD/8. '----------------------------------------------------------- allFourLetterWords = fourLetterWords() DIM word6(%NUMBERofWORDS4) AS LONG AT STRPTR(allFourLetterWords) wo6ptr = VARPTR(wordOrig6(0)) FOR ii = 0 TO %NUMBERofWORDS4 'create human readable 4-letter word list ii2 = word6(ii) AND &b00000000000011111000000000000000 SHIFT RIGHT ii2, 15 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000111110000000000 SHIFT RIGHT ii2, 10 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000000001111100000 SHIFT RIGHT ii2, 05 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000000000000011111 @wo6ptr = ii2 + &h40 INCR wo6ptr NEXT '----------------------------------------------------------- 'Array is now filled with all 4 letter words. 'Next, find words that are 1 letter different... '----------------------------------------------------------- blank(1) = &b11111111111111111111111111100000 'first make blanks mask to test each of 4 1-letter differences blank(2) = &b11111111111111111111110000011111 blank(3) = &b11111111111111111000001111111111 blank(4) = &b11111111111100000111111111111111 blankq(1) = &b11111111111111111111111100000000 'make blanks mask for quad comparison testing, ie. CVQ blankq(2) = &b11111111111111110000000011111111 blankq(3) = &b11111111000000001111111111111111 blankq(4) = &b00000000111111111111111111111111 '--------------------------------------------------------------------------- 'this code creates 2 random words to try for a solution sequence '--------------------------------------------------------------------------- ' Inword = wordOrig6(((Rnd * &h10000 + Rnd * &h100000000) Xor superRandom) Mod %NUMBERofWORDS4) ' outWord = wordOrig6(((Rnd * &h10000 + Rnd * &h100000000) Xor superRandom) Mod %NUMBERofWORDS4) ' Print #2, inWord, outWord '----------------------end random words------------------------------------- ' Ready to go... J_mFirstMatchForDifference(%NUMBERofWORDS4, %NUMBofLETTERS4) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE1 'solution logic here after all possible matches found IF ASC(as1(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE1 J_mFindSolution4letters(as1, bs1, 2) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1: EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get second arrays of words that are 1 letter different from the previously found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index, index2, index3, index4, a1, a2, b1, b2, as1, as2, bs1, bs2, %ARRAYsIZE2, %NUMBERofWORDS4, %NUMBofLETTERS4) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE2 'solution logic here after all possible matches found IF ASC(as2(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE2 j_mFindSolution4letters(as2, bs2, 3) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1: EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get third arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index3, index4, index5, index6, a2, a3, b2, b3, as2, as3, bs2, bs3, %ARRAYsIZE3, %NUMBERofWORDS4, %NUMBofLETTERS4) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE3 - 1 'solution logic here after all possible matches found IF ASC(as3(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE3 - 1 J_mFindSolution4letters(as3, bs3, 4) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1: EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get fourth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index5, index6, index7, index8, a3, a4, b3, b4, as3, as4, bs3, bs4, %ARRAYsIZE4, %NUMBERofWORDS4, %NUMBofLETTERS4) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE4 - 1 'solution logic here after all possible matches found IF ASC(as4(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE4 - 1 J_mFindSolution4letters(as4, bs4, 5) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1:EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get fifth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index7, index8, index9, index10, a4, a5, b4, b5, as4, as5, bs4, bs5, %ARRAYsIZE5, %NUMBERofWORDS4, %NUMBofLETTERS4) ' ii3 = 0 FOR ii = 0 TO %ARRAYsIZE5 - 1 'solution logic here after all possible matches found IF ASC(as5(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE5 - 1 J_mFindSolution4letters(as5, bs5, 6) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1:EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get sixth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index9, index10, index11, index12, a5, a6, b5, b6, as5, as6, bs5, bs6, %ARRAYsIZE6, %NUMBERofWORDS4, %NUMBofLETTERS4) ' ii3 = 0 FOR ii = 0 TO %ARRAYsIZE6 - 1 'solution logic here after all possible matches found IF ASC(as6(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE6 - 1 J_mFindSolution4letters(as6, bs6, 7) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1 'ii3 is number of solutions found END FUNCTION 'FUNCTION twoFiveLetterWords(inWord AS STRING * %NUMBofLETTERS5, outWord AS STRING * %NUMBofLETTERS5) AS LONG FUNCTION J_twoFiveLetterWords() AS LONG Common_Locals LOCAL lineo AS STRING, ii, ii2, ii3, ii4, ii5, ii6, index, index2, index3, index4 AS LONG LOCAL index5, index6, index7, index8, index9, index10, index11, index12, endLoop, maxSeqLen AS LONG LOCAL sTemp, allFiveLetterWords AS STRING, wo6ptr AS BYTE PTR DIM q4(10) AS QUAD, acacia(6) AS LONG, blank(6) AS LONG, blankq(8) AS QUAD DIM wordOrig6(%NUMBERofWORDS5) AS STRING * %NUMBofLETTERS5 DIM a1(%ARRAYsIZE1) AS LONG, a2(%ARRAYsIZE2) AS LONG, a3(%ARRAYsIZE3) AS LONG, a4(%ARRAYsIZE4) AS LONG, a5(%ARRAYsIZE5) AS LONG, a6(%ARRAYsIZE6) AS LONG DIM b1(%ARRAYsIZE1) AS LONG, b2(%ARRAYsIZE2) AS LONG, b3(%ARRAYsIZE3) AS LONG, b4(%ARRAYsIZE4) AS LONG, b5(%ARRAYsIZE5) AS LONG, b6(%ARRAYsIZE6) AS LONG DIM as1(%ARRAYsIZE1) AS STRING, as2(%ARRAYsIZE2) AS STRING, as3(%ARRAYsIZE3) AS STRING, as4(%ARRAYsIZE4) AS STRING, as5(%ARRAYsIZE5) AS STRING, as6(%ARRAYsIZE6) AS STRING DIM bs1(%ARRAYsIZE1) AS STRING, bs2(%ARRAYsIZE2) AS STRING, bs3(%ARRAYsIZE3) AS STRING, bs4(%ARRAYsIZE4) AS STRING, bs5(%ARRAYsIZE5) AS STRING, bs6(%ARRAYsIZE6) AS STRING LOCAL x AS STRING, q1, q2 AS QUAD 'remove LOCAL extend AS LONG LOCAL inWord AS STRING * %NUMBofLETTERS5, outWord AS STRING * %NUMBofLETTERS5 inWord = First_Word$ outWord = Last_Word$ '----------------------------------------------------------- 'put words in a fast to use LONG format and store in word6() array. 6 is max letters for this technique, 4 used here. 'if 7 or more needed (12 max), the algo would need to go to QUAD/8. '----------------------------------------------------------- allFiveLetterWords = fiveLetterWords() DIM word6(%NUMBERofWORDS5) AS LONG AT STRPTR(allFiveLetterWords) wo6ptr = VARPTR(wordOrig6(0)) FOR ii = 0 TO %NUMBERofWORDS5 'create human readable 5-letter word list ii2 = word6(ii) AND &b00000001111100000000000000000000 SHIFT RIGHT ii2, 20 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000011111000000000000000 SHIFT RIGHT ii2, 15 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000111110000000000 SHIFT RIGHT ii2, 10 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000000001111100000 SHIFT RIGHT ii2, 05 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000000000000011111 @wo6ptr = ii2 + &h40 INCR wo6ptr NEXT '----------------------------------------------------------- 'Array is now filled with all 6 letter words. 'Next, find words that are 1 letter different... '----------------------------------------------------------- blank(1) = &b11111111111111111111111111100000 'first make blanks mask to test each of 5 1-letter differences blank(2) = &b11111111111111111111110000011111 blank(3) = &b11111111111111111000001111111111 blank(4) = &b11111111111100000111111111111111 blank(5) = &b11111110000011111111111111111111 blankq(1) = &h0ffffffff00 'make blanks mask for quad comparison testing, ie. CVQ blankq(2) = &h0ffffff00ff blankq(3) = &h0ffff00ffff blankq(4) = &h0ff00ffffff blankq(5) = &h000ffffffff '--------------------------------------------------------------------------- 'this code creates 2 random words to try for a solution sequence '--------------------------------------------------------------------------- 'Inword = wordOrig6(((Rnd * &h10000 + Rnd * &h100000000) Xor superRandom) Mod %NUMBERofWORDS5) 'outWord = wordOrig6(((Rnd * &h10000 + Rnd * &h100000000) Xor superRandom) Mod %NUMBERofWORDS5) ' Print #2, inWord, outWord '----------------------end random words------------------------------------- ' Ready to go... J_mFirstMatchForDifference(%NUMBERofWORDS5, %NUMBofLETTERS5) '----------------------------------------------------------- 'Now get second arrays of words that are 1 letter different from the previously found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index, index2, index3, index4, a1, a2, b1, b2, as1, as2, bs1, bs2, %ARRAYsIZE2, %NUMBERofWORDS5, %NUMBofLETTERS5) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE2 - 1 'solution logic here after all possible matches found IF ASC(as2(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE2 - 1 J_mFindSolution5letters(as2, bs2, 3) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1: EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get third arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index3, index4, index5, index6, a2, a3, b2, b3, as2, as3, bs2, bs3, %ARRAYsIZE3, %NUMBERofWORDS5, %NUMBofLETTERS5) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE3 - 1 'solution logic here after all possible matches found IF ASC(as3(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE3 - 1 J_mFindSolution5letters(as3, bs3, 4) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1: EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get fourth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index5, index6, index7, index8, a3, a4, b3, b4, as3, as4, bs3, bs4, %ARRAYsIZE4, %NUMBERofWORDS5, %NUMBofLETTERS5) ' ? JOIN$(as4(), " ") ' ? JOIN$(bs4(), " ") ' ii3 = 0 FOR ii = 0 TO %ARRAYsIZE4 - 1 'solution logic here after all possible matches found IF ASC(as4(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE4 - 1 J_mFindSolution5letters(as4, bs4, 5) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1:EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get fifth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index7, index8, index9, index10, a4, a5, b4, b5, as4, as5, bs4, bs5, %ARRAYsIZE5, %NUMBERofWORDS5, %NUMBofLETTERS5) ' ii3 = 0 FOR ii = 0 TO %ARRAYsIZE5 - 1 'solution logic here after all possible matches found IF ASC(as5(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE5 - 1 J_mFindSolution5letters(as5, bs5, 6) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1:EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get sixth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index9, index10, index11, index12, a5, a6, b5, b6, as5, as6, bs5, bs6, %ARRAYsIZE6, %NUMBERofWORDS5, %NUMBofLETTERS5) ' ii3 = 0 FOR ii = 0 TO %ARRAYsIZE6 - 1 'solution logic here after all possible matches found IF ASC(as6(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE6 - 1 J_mFindSolution5letters(as6, bs6, 7) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1 'ii3 is number of solutions found END FUNCTION 'FUNCTION twoSixLetterWords(inWord AS STRING * %NUMBofLETTERS6, outWord AS STRING * %NUMBofLETTERS6) AS LONG FUNCTION J_twoSixLetterWords() AS LONG Common_Locals LOCAL lineo AS STRING, ii, ii2, ii3, ii4, ii5, ii6, index, index2, index3, index4 AS LONG LOCAL index5, index6, index7, index8, index9, index10, index11, index12, endLoop, maxSeqLen AS LONG LOCAL sTemp, allSixLetterWords AS STRING, wo6ptr AS BYTE PTR DIM q4(10) AS QUAD, acacia(6) AS LONG, blank(6) AS LONG, blankq(8) AS QUAD DIM wordOrig6(%NUMBERofWORDS6) AS STRING * %NUMBofLETTERS6 DIM a1(%ARRAYsIZE1) AS LONG, a2(%ARRAYsIZE2) AS LONG, a3(%ARRAYsIZE3) AS LONG, a4(%ARRAYsIZE4) AS LONG, a5(%ARRAYsIZE5) AS LONG, a6(%ARRAYsIZE6) AS LONG DIM b1(%ARRAYsIZE1) AS LONG, b2(%ARRAYsIZE2) AS LONG, b3(%ARRAYsIZE3) AS LONG, b4(%ARRAYsIZE4) AS LONG, b5(%ARRAYsIZE5) AS LONG, b6(%ARRAYsIZE6) AS LONG DIM as1(%ARRAYsIZE1) AS STRING, as2(%ARRAYsIZE2) AS STRING, as3(%ARRAYsIZE3) AS STRING, as4(%ARRAYsIZE4) AS STRING, as5(%ARRAYsIZE5) AS STRING, as6(%ARRAYsIZE6) AS STRING DIM bs1(%ARRAYsIZE1) AS STRING, bs2(%ARRAYsIZE2) AS STRING, bs3(%ARRAYsIZE3) AS STRING, bs4(%ARRAYsIZE4) AS STRING, bs5(%ARRAYsIZE5) AS STRING, bs6(%ARRAYsIZE6) AS STRING LOCAL extend AS LONG, inWord AS STRING * %NUMBofLETTERS6, outWord AS STRING * %NUMBofLETTERS6 '----------------------------------------------------------- 'put words in a fast to use LONG format and store in word6() array. 6 is max letters for this technique, 4 used here. 'if 7 or more needed (12 max), the algo would need to go to QUAD/8. '----------------------------------------------------------- allSixLetterWords = sixLetterWords() DIM word6(%NUMBERofWORDS6) AS LONG AT STRPTR(allSixLetterWords) wo6ptr = VARPTR(wordOrig6(0)) FOR ii = 0 TO %NUMBERofWORDS6 'create human readable 5-letter word list ii2 = word6(ii) AND &b00111110000000000000000000000000 SHIFT RIGHT ii2, 25 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000001111100000000000000000000 SHIFT RIGHT ii2, 20 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000011111000000000000000 SHIFT RIGHT ii2, 15 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000111110000000000 SHIFT RIGHT ii2, 10 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000000001111100000 SHIFT RIGHT ii2, 05 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000000000000011111 @wo6ptr = ii2 + &h40 INCR wo6ptr NEXT '----------------------------------------------------------- 'Array is now filled with all 6 letter words. 'Next, find words that are 1 letter different... '----------------------------------------------------------- blank(1) = &b11111111111111111111111111100000 'first make blanks mask to test each of 6 1-letter differences blank(2) = &b11111111111111111111110000011111 blank(3) = &b11111111111111111000001111111111 blank(4) = &b11111111111100000111111111111111 blank(5) = &b11111110000011111111111111111111 blank(6) = &b11000001111111111111111111111111 blankq(1) = &h0ffffffffff00 'make blanks mask for quad comparison testing, ie. CVQ blankq(2) = &h0ffffffff00ff blankq(3) = &h0ffffff00ffff blankq(4) = &h0ffff00ffffff blankq(5) = &h0ff00ffffffff blankq(6) = &h000ffffffffff '--------------------------------------------------------------------------- 'this code creates 2 random words to try for a solution sequence '--------------------------------------------------------------------------- 'Inword = wordOrig6(((Rnd * &h10000 + Rnd * &h100000000) Xor superRandom) Mod %NUMBERofWORDS6) 'outWord = wordOrig6(((Rnd * &h10000 + Rnd * &h100000000) Xor superRandom) Mod %NUMBERofWORDS6) inword = First_Word$ OutWord = Last_Word$ ' Print #2, inWord, outWord '----------------------end random words------------------------------------- ' Inword = UCASE$("heydey") 'you can try your own 2 words here ' outWord = UCASE$("mayday") ' Ready to go... J_mFirstMatchForDifference(%NUMBERofWORDS6, %NUMBofLETTERS6) '----------------------------------------------------------- 'Now get second arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index, index2, index3, index4, a1, a2, b1, b2, as1, as2, bs1, bs2, %ARRAYsIZE2, %NUMBERofWORDS6, %NUMBofLETTERS6) '----------------------------------------------------------- 'Now get third arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index3, index4, index5, index6, a2, a3, b2, b3, as2, as3, bs2, bs3, %ARRAYsIZE3, %NUMBERofWORDS6, %NUMBofLETTERS6) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE3 - 1 'solution logic here after all possible matches found IF ASC(as3(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE3 - 1 J_mFindSolution6letters(as3, bs3, 4) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1: EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get fourth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index5, index6, index7, index8, a3, a4, b3, b4, as3, as4, bs3, bs4, %ARRAYsIZE4, %NUMBERofWORDS6, %NUMBofLETTERS6) ' ? JOIN$(as4(), " ") ' ? JOIN$(bs4(), " ") ii3 = 0 FOR ii = 0 TO %ARRAYsIZE4 - 1 'solution logic here after all possible matches found IF ASC(as4(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE4 - 1 J_mFindSolution6letters(as4, bs4, 5) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1:EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get fifth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index7, index8, index9, index10, a4, a5, b4, b5, as4, as5, bs4, bs5, %ARRAYsIZE5, %NUMBERofWORDS6, %NUMBofLETTERS6) ' ii3 = 0 FOR ii = 0 TO %ARRAYsIZE5 - 1 'solution logic here after all possible matches found IF ASC(as5(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE5 - 1 J_mFindSolution6letters(as5, bs5, 6) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1:EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get sixth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index9, index10, index11, index12, a5, a6, b5, b6, as5, as6, bs5, bs6, %ARRAYsIZE6, %NUMBERofWORDS6, %NUMBofLETTERS6) ' ii3 = 0 FOR ii = 0 TO %ARRAYsIZE6 - 1 'solution logic here after all possible matches found IF ASC(as6(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE6 - 1 J_mFindSolution6letters(as6, bs6, 7) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1 'ii3 is number of solutions found END FUNCTION 'FUNCTION twoThreeLetterWords(inWord AS STRING * %NUMBofLETTERS4, outWord AS STRING * %NUMBofLETTERS4) AS LONG FUNCTION J_twoThreeLetterWords() AS LONG Common_Locals LOCAL lineo AS STRING, ii, ii2, ii3, ii4, ii5, ii6, extend, index, index2, index3, index4 AS LONG LOCAL index5, index6, index7, index8, endLoop, maxSeqLen AS LONG LOCAL sTemp, allThreeLetterWords AS STRING, wo6ptr AS BYTE PTR DIM q4(10) AS QUAD, acacia(6) AS LONG, blank(6) AS LONG, blankq(8) AS QUAD DIM wordOrig6(%NUMBERofWORDS3) AS STRING * %NUMBofLETTERS3 DIM a1(%ARRAYsIZE1) AS LONG, a2(%ARRAYsIZE2) AS LONG, a3(%ARRAYsIZE3) AS LONG, a4(%ARRAYsIZE4) AS LONG DIM b1(%ARRAYsIZE1) AS LONG, b2(%ARRAYsIZE2) AS LONG, b3(%ARRAYsIZE3) AS LONG, b4(%ARRAYsIZE4) AS LONG DIM as1(%ARRAYsIZE1) AS STRING, as2(%ARRAYsIZE2) AS STRING, as3(%ARRAYsIZE3) AS STRING, as4(%ARRAYsIZE4) AS STRING DIM bs1(%ARRAYsIZE1) AS STRING, bs2(%ARRAYsIZE2) AS STRING, bs3(%ARRAYsIZE3) AS STRING, bs4(%ARRAYsIZE4) AS STRING LOCAL inWord AS STRING * %NUMBofLETTERS3, outWord AS STRING * %NUMBofLETTERS3 inWord = First_Word$ outWord = Last_Word$ '----------------------------------------------------------- 'put words in a fast to use LONG format and store in word6() array. 6 is max letters for this technique, 4 used here. 'if 7 or more needed (12 max), the algo would need to go to QUAD/8. '----------------------------------------------------------- allThreeLetterWords = threeLetterWords() DIM word6(%NUMBERofWORDS3) AS LONG AT STRPTR(allThreeLetterWords) wo6ptr = VARPTR(wordOrig6(0)) FOR ii = 0 TO %NUMBERofWORDS3 'create human readable 4-letter word list ii2 = word6(ii) AND &b00000000000000000111110000000000 SHIFT RIGHT ii2, 10 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000000001111100000 SHIFT RIGHT ii2, 05 @wo6ptr = ii2 + &h40 INCR wo6ptr ii2 = word6(ii) AND &b00000000000000000000000000011111 @wo6ptr = ii2 + &h40 INCR wo6ptr NEXT '----------------------------------------------------------- 'Array is now filled with all 4 letter words. 'Next, find words that are 1 letter different... '----------------------------------------------------------- blank(1) = &b11111111111111111111111111100000 'first make blanks mask to test each of 4 1-letter differences blank(2) = &b11111111111111111111110000011111 blank(3) = &b11111111111111111000001111111111 blankq(1) = &b11111111111111111111111100000000 'make blanks mask for quad comparison testing, ie. CVQ blankq(2) = &b11111111111111110000000011111111 blankq(3) = &b11111111000000001111111111111111 '--------------------------------------------------------------------------- 'this code creates 2 random words to try for a solution sequence '--------------------------------------------------------------------------- 'Inword = wordOrig6(((Rnd * &h10000 + Rnd * &h100000000) Xor superRandom) Mod %NUMBERofWORDS3) 'outWord = wordOrig6(((Rnd * &h10000 + Rnd * &h100000000) Xor superRandom) Mod %NUMBERofWORDS3) ' Print #2, inWord, outWord '----------------------end random words------------------------------------- ' Ready to go... J_mFirstMatchForDifference(%NUMBERofWORDS3, %NUMBofLETTERS3) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE1 'solution logic here after all possible matches found IF ASC(as1(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE1 J_mFindSolution3letters(as1, bs1, 2) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1: EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get second arrays of words that are 1 letter different from the previously found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index, index2, index3, index4, a1, a2, b1, b2, as1, as2, bs1, bs2, %ARRAYsIZE2, %NUMBERofWORDS3, %NUMBofLETTERS3) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE2 'solution logic here after all possible matches found IF ASC(as2(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE2 J_mFindSolution3letters(as2, bs2, 3) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1: EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get third arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index3, index4, index5, index6, a2, a3, b2, b3, as2, as3, bs2, bs3, %ARRAYsIZE3, %NUMBERofWORDS3, %NUMBofLETTERS3) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE3 - 1 'solution logic here after all possible matches found IF ASC(as3(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE3 - 1 J_mFindSolution3letters(as3, bs3, 4) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1: EXIT FUNCTION 'ii3 is number of solutions found '----------------------------------------------------------- 'Now get fourth arrays of words that are 1 letter different from the last found arrays... '----------------------------------------------------------- J_mMatchAndRemoveDupes(index5, index6, index7, index8, a3, a4, b3, b4, as3, as4, bs3, bs4, %ARRAYsIZE4, %NUMBERofWORDS3, %NUMBofLETTERS3) ii3 = 0 FOR ii = 0 TO %ARRAYsIZE4 - 1 'solution logic here after all possible matches found IF ASC(as4(ii)) < 65 THEN EXIT FOR FOR ii2 = 0 TO %ARRAYsIZE4 - 1 J_mFindSolution3letters(as4, bs4, 5) NEXT NEXT IF ii3 > 0 THEN FUNCTION = 1 'ii3 is number of solutions found END FUNCTION 'End John's stuff ' '------------------------------------------------------------------------------ ' '------------------------------------------------------------------------------ ' '------------------------------------------------------------------------------ ' '------------------------------------------------------------------------------ ' '------------------------------------------------------------------------------ '**************************************************************************** '**************************************************************************** SUB Good_Words_Only 'only load words that can be expanded ' Wrd As String * 28 ' lng As Long ' Good As Long ' common_Locals g_timer = TIMER fn$ = CURDIR$ & "\Data_Words.txt" m_Input_open LOCAL gw() AS GoodWords DIM gw(110000) RESET ctr WHILE fn$ <> "End Words" 'Not Eof(fnum) INPUT #fnum, flen, fn$ INCR ctr4 IF flen > 4 AND flen < 7 THEN ' 5& 6 ltrs only fn$ = UCASE$(fn$) sw$ = fn$ a = ASC(fn$) i = 0 'valid return FOR ctr1 = 1 TO LEN(fn$) FOR ctr2 = 65 TO 90'A-Z LSET sw$ = fn$ 'faster MID$ (sw$, ctr1) = CHR$(ctr2)'replace letter IF sw$ <> fn$ THEN 'case of same letter being replaced Is_It_Valid IF i THEN EXIT FOR 'got a match so exit END IF NEXT ctr2 IF i THEN EXIT FOR 'got a match so exit NEXT ctr1 gw(ctr).Wrd = fn$ gw(ctr).lng = flen gw(ctr).Good = i INCR ctr END IF WEND CLOSE 'Is_It_Valid m$ = USING$("#, Good Words out of #, .## secs to read", ctr, ctr4, TIMER - g_timer): mb) END SUB '------------------------------------------------------------------ FUNCTION MakeFontEx(BYVAL FontName AS STRING, _ BYVAL PointSize AS LONG, _ BYVAL fBold AS LONG, _ BYVAL fItalic AS LONG, _ BYVAL fUnderline AS LONG) AS LONG ' Borrowed from Borje Hagsten ' MakeFontEx(FontName, PointSize, fBold, fItalic, fUnderline) LOCAL hDC AS LONG, CyPixels AS LONG hDC = GetDC(%HWND_DESKTOP) CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY) ReleaseDC %HWND_DESKTOP, hDC PointSize = 0 - (PointSize * CyPixels) \ 72 FUNCTION = CreateFont( _ PointSize, 0, _ 'height, width(default=0) 0, 0, _ 'escapement(angle), orientation fBold, _ 'weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700) fItalic, _ 'Italic fUnderline, _ 'Underline %FALSE, _ 'StrikeThru - who needs it? %ANSI_CHARSET, %OUT_TT_PRECIS, _ %CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _ %FF_DONTCARE , BYCOPY FontName) 'Put below in Common_Locals code ' Local hFont_Arial As Dword ' Local hFont_Comic As Dword ' Local hFont_Courier As Dword ' ' Examples: ' hFont_Courier = MakefontEx("Courier New", 12, %FW_NORMAL, %FALSE, %FALSE) ' hFont_Arial = MakefontEx("Arial", 10, %FW_Normal, %FALSE, %FALSE) ' hFont_Comic = MakefontEx("Comic MS Sans", 10, %FW_Normal, %TRUE, %FALSE) ' ' Change font in any control (textbox, label, etc.) ' Control Send hDlg, %IDC_TextBox1, %WM_SETFONT, hFont_Comic, 0 ' Different Font Weights '%FW_DONTCARE = 0 '%FW_THIN = 100 '%FW_EXTRALIGHT = 200 '%FW_LIGHT = 300 '%FW_NORMAL = 400 '%FW_MEDIUM = 500 '%FW_SEMIBOLD = 600 '%FW_BOLD = 700 '%FW_EXTRABOLD = 800 '%FW_HEAVY = 900 ' '%FW_ULTRALIGHT = %FW_EXTRALIGHT '%FW_REGULAR = %FW_NORMAL '%FW_DEMIBOLD = %FW_SEMIBOLD '%FW_ULTRABOLD = %FW_EXTRABOLD '%FW_BLACK = %FW_HEAVY END FUNCTION '------------------------------------------------------------------ '**************************************************************************** 'Shortcut code below here ' all C&P'ed from POFFS - dunno who to credit. Wayne Diamond? '-Note shortcut functions begin with "z_sc_" to group together ' ======================================================================================= ' IIDs for shortcut creator ' ======================================================================================= $CLSID_ShellLink = GUID$("{00021401-0000-0000-C000-000000000046}") $IID_IShellLink = GUID$("{000214EE-0000-0000-C000-000000000046}") $IID_IPersistFile = GUID$("{0000010B-0000-0000-C000-000000000046}") %CLSCTX_INPROC_SERVER = &H1 ' Component is allowed in the same process space. ' ======================================================================================= ' ======================================================================================= ' Returns a pointer to a specified interface on an object to which a client currently ' holds an interface pointer. ' ======================================================================================= FUNCTION z_sc_IUnknown_QueryInterface _ (BYVAL pthis AS DWORD PTR, BYREF riid AS GUID, BYREF ppvObj AS DWORD) AS LONG LOCAL HRESULT AS LONG CALL DWORD @@pthis[0] USING z_sc_IUnknown_QueryInterface (pthis, riid, ppvObj) TO HRESULT FUNCTION = HRESULT END FUNCTION ' ======================================================================================= ' ======================================================================================= ' Decrements the reference count for the calling interface on a object. If the reference ' count on the object falls to 0, the object is freed from memory. ' ======================================================================================= FUNCTION z_sc_IUnknown_Release _ (BYVAL pthis AS DWORD PTR) AS DWORD LOCAL DWRESULT AS DWORD CALL DWORD @@pthis[2] USING z_sc_IUnknown_Release (pthis) TO DWRESULT FUNCTION = DWRESULT END FUNCTION ' ======================================================================================= ' ======================================================================================= ' Retrieves the description string for a Shell link object. ' ======================================================================================= FUNCTION z_sc_IShellLink_SetDescription _ (BYVAL pthis AS DWORD PTR, BYREF pszName AS ASCIIZ) AS LONG LOCAL HRESULT AS LONG CALL DWORD @@pthis[7] USING z_sc_IShellLink_SetDescription (pthis, pszName) _ TO HRESULT FUNCTION = HRESULT END FUNCTION ' ======================================================================================= ' ======================================================================================= ' Sets the name of the working directory for a Shell link object. ' ======================================================================================= FUNCTION z_sc_IShellLink_SetWorkingDirectory (BYVAL pthis AS DWORD PTR, BYREF pszDir AS ASCIIZ) AS LONG LOCAL HRESULT AS LONG CALL DWORD @@pthis[9] USING z_sc_IShellLink_SetWorkingDirectory (pthis, pszDir)_ TO HRESULT FUNCTION = HRESULT END FUNCTION ' ======================================================================================= ' ======================================================================================= ' Sets the command-line arguments for a Shell link object. ' ======================================================================================= FUNCTION z_sc_IShellLink_SetArguments _ (BYVAL pthis AS DWORD PTR, BYREF pszArgs AS ASCIIZ) AS LONG LOCAL HRESULT AS LONG CALL DWORD @@pthis[11] USING z_sc_IShellLink_SetArguments (pthis, pszArgs) _ TO HRESULT FUNCTION = HRESULT END FUNCTION ' ======================================================================================= ' ======================================================================================= ' Sets the show command for a Shell link object. The show command sets the initial show ' state of the window. ' ======================================================================================= FUNCTION z_sc_IShellLink_SetShowCmd _ (BYVAL pthis AS DWORD PTR, BYVAL iShowCmd AS LONG) AS LONG LOCAL HRESULT AS LONG CALL DWORD @@pthis[15] USING z_sc_IShellLink_SetShowCmd (pthis, iShowCmd) _ TO HRESULT FUNCTION = HRESULT END FUNCTION ' ======================================================================================= ' ======================================================================================= ' Sets the path and file name of a Shell link object. ' ======================================================================================= FUNCTION z_sc_IShellLink_SetPath (BYVAL pthis AS DWORD PTR, BYREF pszFile AS ASCIIZ) _ AS LONG LOCAL HRESULT AS LONG CALL DWORD @@pthis[20] USING z_sc_IShellLink_SetPath (pthis, pszFile) _ TO HRESULT FUNCTION = HRESULT END FUNCTION ' ======================================================================================= ' ======================================================================================= ' Saves the object into the specified file. ' ======================================================================================= DECLARE FUNCTION z_sc_Proto_IPersistFile_Save _ (BYVAL pthis AS DWORD PTR, _ BYVAL pszFileName AS DWORD, _ BYVAL fRemember AS LONG) AS LONG ' ======================================================================================= FUNCTION z_sc_IPersistFile_Save _ (BYVAL pthis AS DWORD PTR, _ BYVAL strFileName AS STRING, _ BYVAL fRemember AS LONG) AS LONG LOCAL HRESULT AS LONG LOCAL pszFileName AS DWORD IF LEN(strFileName) THEN strFileName = UCODE$(strFileName) & $NUL pszFileName = STRPTR(strFileName) END IF CALL DWORD @@pthis[6] USING z_sc_Proto_IPersistFile_Save _ (pthis, pszFileName, fRemember) TO HRESULT FUNCTION = HRESULT END FUNCTION ' ======================================================================================= '// Prototypes DECLARE FUNCTION z_sc_IShellLink_Call0( BYVAL pUnk AS LONG ) AS LONG DECLARE FUNCTION z_sc_IShellLink_Call1( BYVAL pUnk AS LONG, BYVAL p1 AS LONG ) AS LONG DECLARE FUNCTION z_sc_IShellLink_Call2( BYVAL pUnk AS LONG, BYVAL p1 AS LONG, BYVAL p2 AS LONG ) AS LONG FUNCTION z_sc_SpecialFolder(pidl AS DWORD) AS STRING ' by Wayne Diamond 12-03-01 ' [URL=http://www.powerbasic.com/support/forums/Forum7/HTML/001233.html]http://www.powerbasic.com/support/forums/Forum7/HTML/001233.html[/URL] LOCAL TmpAsciiz AS ASCIIZ * %MAX_PATH CoInitialize BYVAL 0 IF ISFALSE(SHGetSpecialFolderLocation(BYVAL %HWND_DESKTOP, BYVAL pidl, BYVAL VARPTR(pidl))) THEN SHGetPathFromIDList BYVAL pidl, TmpAsciiz CoTaskMemFree BYVAL pidl END IF CoUninitialize FUNCTION = TmpAsciiz END FUNCTION FUNCTION z_sc_createShortcut(CSIDL AS DWORD, link AS STRING, source AS STRING, workDir AS STRING) AS LONG ' adapted from Edwin Knoppert's code 07-10-03 ' [URL=http://www.powerbasic.com/support/forums/Forum7/HTML/001980.html]http://www.powerbasic.com/support/forums/Forum7/HTML/001980.html[/URL] 'CSIDL - CSIDL_DESKTOP, CSIDL_PROGRAMS, CSIDL_STARTUP, etc 'link - link file to be created like "My calc.lnk" 'source - file/document where the shortcut should point to like "c:\windows\calc.exe". 'workDir - folder where the executable document/file should start in, best not to leave empty. LOCAL CLSID_ShellLink AS STRING * 16 LOCAL IID_IShellLink AS STRING * 16 LOCAL IID_Persist AS STRING * 16 LOCAL nResult AS LONG, pShellLnk AS DWORD PTR, pPersist AS DWORD PTR LOCAL sTarget AS STRING, szUniLnkName AS ASCIIZ * (2 * %MAX_PATH) LOCAL sArguments AS STRING, sComment AS STRING CLSID_ShellLink = MKL$(&H00021401) & CHR$(0, 0, 0, 0, &HC0, 0, 0, 0, 0, 0, 0, &H46) IID_IShellLink = MKL$(&H000214EE) & CHR$(0, 0, 0, 0, &HC0, 0, 0, 0, 0, 0, 0, &H46) IID_Persist = MKL$(&H0000010B) & CHR$(0, 0, 0, 0, &HC0, 0, 0, 0, 0, 0, 0, &H46) sArguments = "": sComment = "" CoInitialize BYVAL 0& IF CoCreateInstance(BYVAL VARPTR(CLSID_ShellLink), BYVAL 0&, 1, BYVAL VARPTR(IID_IShellLink), pShellLnk) = 0 THEN '// IShellLink::SetPath CALL DWORD @@pShellLnk[20] USING z_sc_IShellLink_Call1(pShellLnk, STRPTR(source)) '// IShellLink::SetsArguments CALL DWORD @@pShellLnk[11] USING z_sc_IShellLink_Call1(pShellLnk, STRPTR(sArguments)) '// IShellLink::SetWorkingDirectory CALL DWORD @@pShellLnk[9] USING z_sc_IShellLink_Call1(pShellLnk, STRPTR(workDir)) '// IShellLink::SetnShowCmd CALL DWORD @@pShellLnk[15] USING z_sc_IShellLink_Call1(pShellLnk, %SW_SHOW) '// IShellLink::SetDescription CALL DWORD @@pShellLnk[7] USING z_sc_IShellLink_Call1(pShellLnk, STRPTR(sComment)) '// Obtain persist interface (QueryInterface) CALL DWORD @@pShellLnk[0] USING z_sc_IShellLink_Call2(pShellLnk, VARPTR(IID_Persist), VARPTR(pPersist)) IF nResult = %S_OK THEN '// Convert to unicode sTarget = z_sc_SpecialFolder(CSIDL) + "\" + link MultiByteToWideChar %CP_ACP, 0, BYVAL STRPTR(sTarget), LEN(sTarget), BYVAL VARPTR(szUniLnkName), %MAX_PATH * 2 '// IPersistFile::Save CALL DWORD @@pPersist[6] USING z_sc_IShellLink_Call2(pPersist, VARPTR(szUniLnkName), 1) '// Release CALL DWORD @@pPersist[2] USING z_sc_IShellLink_Call0(pPersist) END IF '// Release CALL DWORD @@pShellLnk[2] USING z_sc_IShellLink_Call0(pShellLnk) FUNCTION = -1 END IF CoUninitialize END FUNCTION ' ' ======================================================================================= ' Creates a shortcut ' ======================================================================================= FUNCTION z_sc_CreateLink ( _ BYVAL csidl AS LONG _ ' // Value specifying the folder for which to retrieve the location. , szLinkName AS ASCIIZ _ ' // Name of the shortcut , szExePath AS ASCIIZ _ ' // Path of the executable file , szArguments AS ASCIIZ _ ' // Arguments , szWorkingDir AS ASCIIZ _ ' // Working directory , BYVAL nShowCmd AS DWORD _ ' // Show command flag , szComment AS ASCIIZ _ ' // Comment ) AS LONG LOCAL hr AS LONG ' // HRESULT LOCAL psl AS DWORD ' // IShellLink interface reference LOCAL ppf AS DWORD ' // IPersistFile interrace reference LOCAL CLSID_ShellLink AS GUID ' // ShellLink class identifier LOCAL IID_IShellLink AS GUID ' // IShellLink interface identifier LOCAL IID_IPersistFile AS GUID ' // IPersistFile interface identifier LOCAL pidl AS DWORD ' // Item identifier list specifying the folder location LOCAL szFileName AS ASCIIZ * %MAX_PATH ' // Name of the .LNK file ' // Fills the guids CLSID_ShellLink = $CLSID_ShellLink IID_IShellLink = $IID_IShellLink IID_IPersistFile = $IID_IPersistFile ' // Creates an instance of the IShellLink interface hr = CoCreateInstance(CLSID_ShellLink, BYVAL %Null, %CLSCTX_INPROC_SERVER, IID_IShellLink, psl) IF hr <> %S_OK THEN EXIT FUNCTION ' // Sets the properties of the shortcut hr = z_sc_IShellLink_SetPath(psl, szExePath) hr = z_sc_IShellLink_SetArguments(psl, szArguments) hr = z_sc_IShellLink_SetWorkingDirectory(psl, szWorkingDir) hr = z_sc_IShellLink_SetShowCmd(psl, nShowCmd) hr = z_sc_IShellLink_SetDescription(psl, szComment) ' // Retrieves a pointer to the IPersistFile interface hr = z_sc_IUnknown_QueryInterface(psl, IID_IPersistFile, ppf) IF hr = %S_OK THEN ' // Retrieves an item identifier list specifying the desktop folder location hr = SHGetSpecialFolderLocation(%HWND_DESKTOP, csidl, pidl) IF hr = %NOERROR THEN ' // Retrieves the path from the item identifier list hr = SHGetPathFromIDList(BYVAL pidl, szFileName) ' // Frees the memory allocated for the item identifier list CoTaskMemFree pidl IF ISTRUE(hr) THEN ' // Full path szFileName = szFileName & "\" & szLinkName & ".LNK" ' // Saves the shortcut file hr = z_sc_IPersistFile_Save(ppf, szFileName, %TRUE) END IF FUNCTION = %TRUE END IF ' // Releases the IPersistFile interface z_sc_IUnknown_Release(ppf) END IF ' // Releases the IShellLink interface z_sc_IUnknown_Release psl END FUNCTION ' ======================================================================================= '-Note shortcut functions begin with "z_sc_" ' SUB Create_Shortcut LOCAL hr AS LONG, _ csidl AS LONG , _ szLinkName AS ASCIIZ * %Max_Path, _ ' // Name of the shortcut szExePath AS ASCIIZ * %Max_Path, _ ' // Path of the executable file szArguments AS ASCIIZ * %Max_Path, _ ' // Arguments szWorkingDir AS ASCIIZ * %Max_Path, _ ' // Working directory nShowCmd AS DWORD , _ ' // Show command flag szComment AS ASCIIZ * %Max_Path ' // Comment csidl = %CSIDL_DESKTOP szLinkName = "Swede's & John's Connections" szExePath = CURDIR$ & "\Word_Connections.exe" szArguments = "" szWorkingDir = CURDIR$ szComment = "Wonnerful Wunnerful Program" hr = z_sc_CreateLink(csidl, szLinkName, szExePath, _ szArguments, szWorkingDir, %SW_NORMAL, szComment) IF ISTRUE (hr)THEN LOCAL m$, m1$ m$ = "See Desktop": m1$ = "Shortcut Created" mb_Alert ELSE m$ = "CreateLink failed":mb_Alert END IF END SUB 'End shortcut code '**************************************************************************** '**************************************************************************** '**************************************************************************** '------------------------------------------------------------------------------ '<== Start of Clipboard as an Include ==> 'Clipboard stuff gotten from Poffs but I forget from whom ' 'Note t$ must be initialized - Local t$ FUNCTION Clipboard_Set_Text ALIAS "Clipboard_Set_Text" _ (BYVAL sText AS STRING) EXPORT AS LONG LOCAL hData AS LONG, hGlob AS LONG ' ** Create a global memory object and copy the data into it hData = GlobalAlloc(%GMEM_MOVEABLE OR %GMEM_DDESHARE, LEN(sText) + 1) hGlob = GlobalLock(hData) POKE$ hGlob, sText + CHR$(0) GlobalUnlock hData ' ** Open the clipboard IF ISFALSE(OpenClipboard(%Null)) THEN GlobalFree hData EXIT FUNCTION END IF ' ** Paste the data into the clipboard EmptyClipboard 'WinAPI FUNCTION = SetClipboardData(%CF_TEXT, hData) 'WinAPI CloseClipboard 'WinAPI END FUNCTION ' FUNCTION Clipboard_Get_Text ALIAS "Clipboard_Get_Text"() EXPORT AS STRING LOCAL zPtr AS ASCIIZ PTR OpenClipboard 0 'WinAPI zPtr = GetClipboardData(%CF_TEXT) IF zPtr <> 0 THEN FUNCTION = @zPtr CloseClipboard 'WinAPI END FUNCTION ' ' MACRO Get_Clipboard = t$ = Clipboard_Get_Text 'put cb in tb at program start ' MACRO Set_Clipboard = Clipboard_Set_Text(t$) ' '<== End of Clipboard as an Include ==> ' MACRO Check_Words_Validity CONTROL GET TEXT hDlg, %Word_Start TO First_Word$ First_Word$ =UCASE$(First_Word$) CONTROL GET TEXT hDlg, %Word_Done TO Last_Word$ Last_Word$ = UCASE$(Last_Word$) RESET lbl$ 'data tests IF LEN(First_Word$) <> LEN(Last_Word$) THEN m$ = "Words must be the Same Length": 'mb_Alert: Exit Sub lbl$ = m$ ELSEIF LEN(First_Word$) < 2 THEN m$ = "Words must be longer than 1 letter": 'mb_Alert: Exit Sub lbl$ = m$ ELSEIF LEN(First_Word$) > 10 THEN m$ = "Words must be 10 letters or less long": 'mb_Alert: Exit Sub lbl$ = m$ ELSEIF First_Word$ = Last_Word$ THEN m$ = "Words must different": 'mb_Alert: Exit Sub lbl$ = m$ ELSE 'm$="Okay": mb END IF IF lbl$ > "A" THEN Label_Bum_Input BEEP EXIT SUB END IF Word_Len = LEN(First_Word$) 'check to make sure words are in array Flag = INSTR(g_All_Words$, " " & First_Word$ & " ") IF Flag = 0 THEN m$ = First_Word$ & " is not an eligible word" lbl$ = m$ Label_Bum_Input BEEP EXIT SUB END IF Flag = INSTR(g_All_Words$, " " & Last_Word$ & " ") IF Flag = 0 THEN m$ = Last_Word$ & " is not an eligible word" lbl$ = m$ Label_Bum_Input BEEP EXIT SUB END IF Number_of_Words = UBOUND(g_Words) END MACRO ' '------------------------------------------------------------------------------ ' ** Globals ** '------------------------------------------------------------------------------ ' MACRO Top_of_John_Solver Common_Locals Check_Words_Validity 'returns Word_len & g_Words$() ' First_Word$, Last_Word$ Label_Set_Working g_Timer = TIMER ' m$ = Using$("#, #, array elements ", %NUMBERofWORDS, UBound(g_Words$())): mb ' Erase Sequences$ 'array to hold answers REDIM Sequences$(0) END MACRO ' MACRO m_Count_Uniques RESET flag FOR ctr = LBOUND(Sequences$) TO UBOUND(Sequences$) IF Ctr > LBOUND(Sequences$) THEN 'in case of duplicate strings IF Sequences$(ctr) <> Sequences$(ctr - 1) THEN INCR flag END IF END IF NEXT ctr END MACRO ' MACRO Bottom_of_John_Solver IF UBOUND(Sequences$) > 0 THEN 'solution found ARRAY SORT Sequences$() ' m_Count_Uniques'count uniques first t2$ = MCASE$(First_Word$) & " to " & MCASE$(Last_Word$) & _ USING$(" has # Answer Sequences ", Flag) & _ USING$("(.## Seconds)", TIMER - g_Timer) & $CRLF t3$ = t2$ 'Case CB Answers only FOR ctr = LBOUND(Sequences$) TO UBOUND(Sequences$) t1$ = " " 'indent IF Ctr > LBOUND(Sequences$) THEN 'in case of duplicate strings IF Sequences$(ctr) = Sequences$(ctr - 1) THEN ITERATE FOR t1$ = " (Duplicate)" END IF END IF t2$ = t2$ & Sequences$(ctr) & t1$ & $CRLF NEXT ctr Get_Clipboard IF t$ = "No Word Progression Chain yet." THEN RESET t$ 'start new - first time through END IF SELECT CASE g_CB_All_or_One CASE 0 'add chain t$ = t$ & $CRLF & t2$ CASE 1' only this chain t$ = t2$ CASE 2' Only the Results t$ = t$ & t3$ END SELECT Set_Clipboard Label_Set_Done ' ELSE t$ = t$ & t3$ Set_Clipboard Label_Set_No_Answer END IF ' Label_Set_Main END MACRO '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ FUNCTION CB_Show(Pass_Hndl AS DWORD) AS LONG ' Common_Locals 'Locals used in macros ' Local Start_Marked As Long, End_Marked As Long ' Local Highlighted_Word_Flag As Long LOCAL m$, m1$ LOCAL Beep_Freq AS DWORD, Beep_Duration AS DWORD, Beep_Ctr&, Beep_b& ' m$ = Using$("# # ", Start_Marked, Start_Marked):mb LOCAL wd&, ht&, stile&, t$, tmp$(), ctr&, dlg1 AS DWORD LOCAL NewDialogHandle AS DWORD t$ = Clipboard_Get_Text m_T_into_Tmp_Array wd = 500 ht = 300 stile = %WS_CAPTION OR _ %WS_SYSMENU DIALOG NEW dlg1, "Clipboard Contents (Alt F4 to close)", _ ,, wd, ht, _ stile _ TO NewDialogHandle ' Dialog Set Color NewDialogHandle, -1&, %Blue Stile = %ES_MULTILINE OR _ %ES_READONLY OR _ %WS_HSCROLL OR _ %WS_VSCROLL CONTROL ADD TEXTBOX, NewDialogHandle, %CB_Dialog_Box, _ t$, _ 1, 1, wd-3, ht, _ Stile LOCAL hfont&, fnt$, fw& fnt$ ="Comic Sans MS" fw = %FW_Normal hFont = MakefontEx(fnt$, 14, fw, %FALSE, %FALSE) CONTROL SEND NewDialogHandle, %CB_Dialog_Box, _ %WM_SETFONT, hFont, 0 DIALOG SHOW MODAL NewDialogHandle', Call GHL_Spelling_CB END FUNCTION ' '------------------------------------------------------------------------------ ' ' ' '------------------------------------------------------------------------------ SUB John_Solver Top_of_John_Solver ' returns First_Word$, Last_Word$ ln = LEN(First_Word$) SELECT CASE ln CASE 3 J_twothreeLetterWords CASE 4 J_twoFourLetterWords CASE 5 J_twoFiveLetterWords CASE 6 J_twoSixLetterWords END SELECT CLOSE Bottom_of_John_Solver END SUB '------------------------------------------------------------------------------ SUB Testing common_locals m$ = "Testing":mb END SUB ' 'Macro Is_It_Valid = i = InStr(g_All_Words$, " " & sw$ & " ") ' SUB Solver_Swede Top_of_John_Solver ' The Macro Top_of_John_Solver has Common_Locals called and ' returns First_Word$, Last_Word$ ln = LEN(First_Word$) fw$ = UCASE$(First_Word$) 'working lw$ = UCASE$(Last_Word$) 'working 'testing fw$ = UCASE$("snoop") lw$ = UCASE$("utter") chn$ = fw$ & " " RESET flag WHILE Flag = 0 RESET Flag Chn$ = FW$ & " - " 'start of chain sw$ = fw$ ln1 = 1 FOR ctr1 = 1 TO ln 'word length FOR ctr = 65 TO 90 'A-Z MID$(sw$, ctr1) = CHR$(ctr) Is_It_Valid 'returns i& IF i THEN 'yes i = INSTR(Chn$, sw$) 'is it in the chain already? IF i = 0 THEN 'no chn$ = chn$ & sw$ & " " 'add to chain if good INCR flag END IF END IF sw$ = fw$ 'check next letter NEXT ctr NEXT ctr1 Flag = 1 WEND m$ = USING$(" Matched in .## Seconds", TIMER - g_timer) m1$ = chn$: mb t$ = chn$: Set_Clipboard m_Done 'close program now instead of returning to GUI ' Call Testing ' Bottom_of_John_Solver 'Macro sets Clipboard & Labels 'checks Sequences$() for answers END SUB 'THINK CHINK CLINK BLINK BLIND BLAND BRAND BRAID BRAIL BRAIN 'THINK CHINK CLINK BLINK BLIND BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK BLINK BLIND BLEND BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK BLINK BLIND BLOND BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK CLANK BLANK BLANC BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK CLANK BLANK BLAND BRAND BRAID BRAIL BRAIN 'THINK CHINK CLINK CLANK BLANK BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK PLINK PLANK PLANT PLAIT PLAIN BLAIN BRAIN 'THINK THANK SHANK STANK STAND STAID STAIN SLAIN BLAIN BRAIN 'THINK THICK CHICK CRICK CRACK TRACK TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRACK TRACT BRACT TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRACK TRACT TRAIT TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRACK TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRACK TRACT TRAIT TRAIN GRAIN BRAIN 'THINK THICK TRICK TRACK TRACT TRAPT TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRICE Trace TRACK TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRICE Trace TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRICE Trace TRACT TRAIT TRAIN GRAIN BRAIN 'THINK THICK TRICK TRUCK TRACK TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRUCK TRACK TRACT TRAIT TRAIN GRAIN BRAIN 'THINK THINE TRINE TRIPE TRIPS TRAPS TRAPT TRAIT TRAIN BRAIN 'THINK THINS THENS THEWS TREWS BREWS BROWS BROWN BRAWN BRAIN 'THINK THINS THENS THEWS TREWS TROWS BROWS BROWN BRAWN BRAIN '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' ** CallBacks ** '------------------------------------------------------------------------------ CALLBACK FUNCTION CB_Dialog_Processor() Common_Locals SELECT CASE AS LONG CBMSG CASE %WM_INITDIALOG t$ = "No Word Progression Chain yet." Set_Clipboard ' CASE %WM_COMMAND ' Process control notifications SELECT CASE AS LONG CBCTL ' CASE %ID_EXIT DIALOG END CBHNDL ' CASE %Btn_01 'Call WP_Answer 'Word_Progression_Puzzle CALL John_Solver 'Call Solver_Swede ' ' CASE %Cb_All g_CB_All_or_One = 0 Label_Clipboard ' CASE %Cb_One g_CB_All_or_One = 1 Label_Clipboard ' CASE %Cb_Results_Only g_CB_All_or_One = 2 'Reset t$ 'Set_Clipboard 'empty it Label_Clipboard ' CASE %Cb_Show_It, %Btn_02 CB_Show(CBHNDL) ' CASE %CB_Erase_It RESET t$ Set_Clipboard 'empty it Label_Clipboard ' CASE %Btn_Shortcut CALL Create_Shortcut ' END SELECT END SELECT END FUNCTION '------------------------------------------------------------------------------ ' MACRO Fill_G_Words_Array 'g_Words$(ctr) = "ASCII_Value Word" ' ie " 2099 ANTIDISESTABLISHMENTARIANISM" ' or " 131 AB" ' fnum = FreeFile fn$ = CURDIR$ & "\Words.txt" '<-- file created beforehand OPEN fn$ FOR BINARY AS #fnum m$ = "Fill_G_Words_Array":m_Err_Msg ctr = LOF(#fnum) IF ctr = 0 THEN ' m_beep m$ = fn$:m1$ = "File not found": mb CLOSE EXIT SUB END IF temp$ = SPACE$(ctr) 'make big string GET #fnum, 1, temp$ CLOSE #fnum ctr = PARSECOUNT(temp$, $CRLF) REDIM g_Words$(ctr) PARSE temp$, g_Words$(), $CRLF END MACRO ' '**************************************************************************** '**************************************************************************** MACRO w_Build_Word_List RESET Word_List$ FOR ctr = LBOUND(g_Words$) TO UBOUND(g_Words$) Word_List$ = Word_List$ & g_Words$(ctr) & " " NEXT ctr W1$ = Word_List$ END MACRO ' SUB WP_Answer 'THINK CHINK CLINK BLINK BLIND BLAND BRAND BRAID BRAIL BRAIN 'THINK CHINK CLINK BLINK BLIND BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK BLINK BLIND BLEND BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK BLINK BLIND BLOND BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK CLANK BLANK BLANC BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK CLANK BLANK BLAND BRAND BRAID BRAIL BRAIN 'THINK CHINK CLINK CLANK BLANK BLAND BRAND BRAID BRAIN 'THINK CHINK CLINK PLINK PLANK PLANT PLAIT PLAIN BLAIN BRAIN 'THINK THANK SHANK STANK STAND STAID STAIN SLAIN BLAIN BRAIN 'THINK THICK CHICK CRICK CRACK TRACK TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRACK TRACT BRACT TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRACK TRACT TRAIT TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRACK TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRACK TRACT TRAIT TRAIN GRAIN BRAIN 'THINK THICK TRICK TRACK TRACT TRAPT TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRICE Trace TRACK TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRICE Trace TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRICE Trace TRACT TRAIT TRAIN GRAIN BRAIN 'THINK THICK TRICK TRUCK TRACK TRACT TRAIT TRAIN BRAIN 'THINK THICK TRICK TRUCK TRACK TRACT TRAIT TRAIN GRAIN BRAIN 'THINK THINE TRINE TRIPE TRIPS TRAPS TRAPT TRAIT TRAIN BRAIN 'THINK THINS THENS THEWS TREWS BREWS BROWS BROWN BRAWN BRAIN 'THINK THINS THENS THEWS TREWS TROWS BROWS BROWN BRAWN BRAIN 'THINK = CHINK THANK THICK THINE THING THINS ' CHINK = CLINK CHUNK CHICK CHIRK CHINA CHINE CHINO CHINS ' THANK = SHANK THANE ' THICK = TRICK ' THINE = RHINE SHINE WHINE TRINE TWINE ' THING = OHING TYING THONG ' THINS = SHINS TWINS THENS 'SWIMS-CRAMP. It produced SWIMS SLIMS SLAMS CLAMS CLAMP CRAMP. Common_Locals g_Timer = TIMER Label_Set_Working Check_Words_Validity 'returns Word_len & g_Words$() ' First_Word$, Last_Word$ w_Build_Word_List 'returns Word_List$, w1$ w$ = First_Word$ Flag = 0 'Maybe Do Loop WHILE w$ <> Last_Word$ w$ = Last_Word$ ' W1$ = Word_List$ ' While 'what? ' ' wend WEND m$ = USING$("Done #, # letter Words", UBOUND(g_Words$), Word_Len) m1$ = USING$("Took .## seconds ", TIMER - g_timer) mb Label_Set_Main END SUB '************************************************************* '------------------------------------------------------------------------------ ' ** Dialogs ** '------------------------------------------------------------------------------ ' MACRO m_Add_Option = MENU ADD STRING, pu, m$, id, Stile ' MACRO m_Add_Bar = MENU ADD STRING, pu, "-", 0, 0 ' bar ' SUB Setup_Menus 'common_Locals - can't use, 2 many conflicts with C&P'ed code 'Locals for attaching a top menu bar menu 'Global hMenu As Dword LOCAL pu AS DWORD LOCAL hPopup1, _ hPopup2, _ hPopup3, _ hPopup4, _ hPopup5, _ hPopup6, _ hPopup7, _ hPopup8, _ hPopup10 AS DWORD ' hPopup9, _ LOCAL u$, ctr&, ln&, Stile&, id&, m$, m1$, n$, s$, sz$ u$ = SPACE$(30)'creates equal spacing on bar Stile = %MF_ENABLED ' ** First create a top-level menu: MENU NEW BAR TO hMenu ' ** Add a top-level menu item with a popup menu: MENU NEW POPUP TO hPopup1 'assign a popup value pu = hPopup1 'easier to C&P when adding menus 'also allows easy moving of menus & menu items around RSET u$ = "&F File " MENU ADD POPUP, hMenu, u$, pu, Stile 'assign to popup handle M$ = "&X Exit": id = %ID_EXIT: m_Add_Option m_Add_Bar 'Menu Add String, pu, "-", 0, 0 ' bar M$ = "&A Add Link to Word Connections on Desktop": id = %Btn_Shortcut: m_Add_Option m_Add_Bar 'Menu Add String, pu, "-", 0, 0 ' bar ' ** Add a top-level menu item with a popup menu: MENU NEW POPUP TO hPopup2 'assign a popup value pu = hPopup2 'easier to C&P when adding menus RSET u$ = "&L Clipboard " MENU ADD POPUP, hMenu, u$, pu, Stile 'assign to popup handle M$ = "&A All Chains to Clipboard - Every Connection found. (Starting default setting)" id = %Cb_All: m_Add_Option m_Add_Bar m$ = "&R Results Only to Clipboard - No Connections" id = %Cb_Results_Only: m_Add_Option m_Add_Bar m$ = "&K Keep only the Current Connection to Clipboard" id = %CB_One: m_Add_Option m_Add_Bar m$ = "&S Show Clipboard Contents" id = %CB_Show_It: m_Add_Option m_Add_Bar m$ = "&E Empty Clipboard" id = %CB_Erase_It: m_Add_Option ' MENU ATTACH hMenu, hDlg 'now add it to the dialog END SUB ' FUNCTION Setup_Main_Dialog(BYVAL hParent AS DWORD) AS LONG Common_Locals 'Local Row&, Col&, col1&, Wdth&, Hght&, tb_Len&, lbl$, m$, m1$ Wdth = 300 Hght = (%Box_Height * 9) - 5 '160 DIALOG NEW PIXELS, hDlg, "Word Connection Solver Research Only", _ 250, 200, Wdth, Hght, _ %WS_SYSMENU, _ TO hDlg DIALOG SET ICON hDlg, g_Icon_Id$ '"Zero" DIALOG SET COLOR hDlg, -1&, %Cream Row = 1 Col = 185 Box_Width = 108 Stile = %SS_CENTER CONTROL ADD LABEL, hDlg, %Working_Label, lbl$, _ Col, Row + 10, _ Box_Width, %Box_Height * 7, _ Stile x1 = 2 ' frame size CONTROL ADD FRAME, hDlg, -1, "", _ Col - x1 - 1, Row, _ Box_Width + (4 * x1), (%Box_Height * 7) + (7 * x1) Label_Set_Main '5 ltr ''SWIMS-CRAMP. It produced SWIMS SLIMS SLAMS CLAMS CLAMP CRAMP. ' Inword = UCASE$("creepy") ' outWord = UCASE$("shocks") ' Inword = UCase$("voting") ' outWord = UCase$("server") Row = 12 Col = 10 t1$ = "Snoop" t2$ = "Utter" lbl$ = " Starting Word:" tb_len = LEN(lbl$) * 5 CONTROL ADD LABEL, hDlg, 131, lbl$, _ Col, Row, tb_len, %Box_Height CONTROL SET COLOR hDlg, 131, -1, %Cream CONTROL ADD TEXTBOX, hDlg, %Word_Start, t1$, _ Col + tb_len + 5, Row, tb_len, %Box_Height RSET lbl$ = "Finishing Word:" Row = Row + (%Box_Height * 2) CONTROL ADD LABEL, hDlg, 132, lbl$, _ Col, Row, tb_len, %Box_Height CONTROL SET COLOR hDlg, 132, -1, %Cream CONTROL ADD TEXTBOX, hDlg, %Word_Done, t2$, _ Col + tb_len + 5, Row, tb_len, %Box_Height ' lbl$ = "All Chains in Clipboard" tb_len = LEN(lbl$) * 7 ' Row = Row + (%Box_Height * 2) ' Control Add Button, hDlg, %Btn_CB_Toggle, lbl$, _ ' Col, Row, _ ' tb_len, %Box_Height * 1.8 LOCAL Sz# sz = 1.5 lbl$ = "&S Solve Word Connection" Row = Row + (%Box_Height * 2) - 12 CONTROL ADD BUTTON, hDlg, %Btn_01, lbl$, _ Col, Row, _ tb_len, %Box_Height * Sz lbl$ = "&C Show the Clipboard" Row = Row + (%Box_Height * 2 ) CONTROL ADD BUTTON, hDlg, %Btn_02, lbl$, _ Col, Row, _ tb_len, %Box_Height * Sz CALL Setup_Menus DIALOG SHOW MODAL hDlg, CALL CB_Dialog_Processor TO lRslt FUNCTION = lRslt END FUNCTION '------------------------------------------------------------------------------ SUB Back_Up 'use while working Common_locals t$ = "\Word_Connections.bas" fn$ = CURDIR$ & t$ fle$ = "h:" & t$ '\Z-Post.bas" FILECOPY fn$, fle$ M$ = "Copied " & fn$ & $CRLF & _ "to " & fle$ t1$ = m$ m_Err_Msg t$ = "\Word_Connections.exe" 'to test it as standalone fn$ = CURDIR$ & t$ fle$ = "h:" & t$ '\Z-Post.bas" FILECOPY fn$, fle$ M$ = "Copied " & fn$ & $CRLF & _ "to " & fle$ t2$ = m$ m_Err_Msg 't1$ = $CrLf & String$(Len(m$), "*") & $CrLf ' m$ = t1$ & $CrLf & t$ m$ = t1$ m1$ = t2$ mb_Alert END SUB '------------------------------------------------------------------------------ SUB Hex_Test Common_Locals ' part of first line of John's Function fiveLetterWords() As String '&h00208C61,&h002084A4,&h00110469,&h00208961,&h00408D01 ' hex$ DIM d_a AS DWORD, s_b AS STRING, q_c AS QUAD 'don't conflict with Common_Locals DIM d_a1 AS DWORD, s_b1 AS STRING, q_c1 AS QUAD 'don't conflict with Common_Locals 'Hex$ examples 'a = &H0FFFFFFFF ' Unsigned literal 'b = Hex$(a) ' "FFFFFFFF" 'c = a ' 4294967295 'b = Hex$(c) ' "FFFFFFFF" 'c = Val("&H" + b) ' -1&& (signed conversion) 'b = Hex$(c) ' "FFFFFFFF" 'c = Val("&H0" + b) ' 4294967295&& 'b = Hex$(c) ' "FFFFFFFF" d_a = &h00208C61 'first letter? or a Quad? t$ = STR$(d_a) 'a$ = ACODE$(UnicodeStrExpression) 'a$ = UCODE$(AnsiStrExpression) m$ = USING$(" da = #, ", d_a):mb END SUB SUB All_Words_in_1_string Common_Locals IF g_All_Words$ > "A" THEN m$ = "g_All_Words$ Done":mb ' Exit Sub ' done already END IF ' m$ = "at array 1":mb ' 3 ltr 4ltr 5ltr 6ltr wiggle room REDIM g_Words$(853 + 3130 + 6918 + 11492 + 100) 'num words possible 110,000 g_timer = TIMER g_All_Words$ = SPACE$(1045000)'actually need 1,044,750 bytes x1 = 2 'place to put word - 1st space blank fn$ = CURDIR$ & "\Data_Words.txt" m_Input_Open WHILE NOT EOF(fnum) '110,000 lines INPUT #fnum, flen, fn$ 'flen = word length IF flen < 3 THEN ITERATE LOOP '4-6 length only IF flen > 6 THEN EXIT LOOP IF INSTR(fn$, "End Word") THEN EXIT LOOP g_Words$(ctr)= fn$ 'array to build All_Word.inc file with INCR ctr ' g_All_Words$ = g_All_Words$ & " " & UCase$(fn$)'<-- takes 107.1 seconds MID$(g_All_Words$, x1) = UCASE$(fn$) & " " '<-- takes .2 seconds x1 = x1 + LEN(fn$) + 1'+1 to put space in between WEND CLOSE #fnum ARRAY SORT g_Words$() 'now make Include file ln = 210 'shorten lines to avoid "Source Line too long error msg (255? max)" RESET ctr1 fn$ = g_Include_Name$ 'CurDir$ & "\Words_5_6_len.inc" m_OutPut_Open pf "g_All_Words$ = " & $DQ; FOR ctr = LBOUND(g_Words$()) TO UBOUND(g_Words$()) IF ASC(g_Words$(ctr)) > 63 THEN pf " " & g_Words$(ctr); ctr1 = ctr1 + LEN(g_Words$(ctr)) + 1 IF ctr1 > ln THEN 'make another line RESET ctr1 pf " " & $DQ 'end this line pf "g_All_Words$ = g_All_Words$ & " & $DQ ;'new line END IF END IF NEXT ctr pf " " & $DQ 'last line CLOSE #fnum m$ = USING$("#, gAllWords long took .# Exiting now.", LEN(TRIM$(g_All_Words$)), TIMER-g_timer): mb ' m$ = Right$(g_All_Words$, 500):mb CLOSE END SUB ' SUB Data_Words_into_Array(Word_Length&) Common_Locals g_timer = TIMER fn$ = CURDIR$ & "\Data_Words.txt" m_Input_Open ' Exit Sub ' If UBound(g_Words$()) > 1000 Then ' Close ' Exit Sub 'already loaded ' End If ERASE g_Words$ 'jic WHILE NOT EOF(fnum) INPUT #fnum, flen, fn$ 'variables already declared so use them again IF flen = Word_Length& THEN REDIM PRESERVE g_Words$(UBOUND(g_Words$) + 1) g_Words$(UBOUND(g_Words$)) = fn$ END IF WEND CLOSE #fnum '+1 as array is 0 bound ' m$ = Using$(" ##,### ## letter Words", UBound(g_Words$) + 1, Word_Length&) ' m1$ = Using$("Took .## seconds to build the array", Timer - g_timer) ' mb END SUB 'Create data statements for use later SUB Data_Words_Create_File Common_Locals Fill_G_Words_Array REDIM tmp(LBOUND(g_words) TO UBOUND(g_Words))' As String * 30 'longest word 'strip words of ascii values FOR ctr = LBOUND(g_words) TO UBOUND(g_Words) RSET tmp$(Ctr)= MID$(g_Words$(ctr), 7) NEXT ctr ARRAY SORT tmp$() 'now sort according to string length fn$ = CURDIR$ & "\Data_Words.txt" m_Output_Open REDIM Ttls&(2 TO 30) 'largest word size FOR ctr = LBOUND(g_words) TO UBOUND(g_Words) t$ = TRIM$(tmp$(ctr)) 'convenience IF ASC(t$) > 64 THEN 'case of blank lines INCR ctr1 INCR Ttls&(LEN(t$)) pf USING$(" ##", LEN(t$)) & ", " & _ TRIM$(tmp$(ctr)) END IF NEXT ctr pf USING$(" ##", -1) & ", " & "End Words" pf 'blank line pf USING$("#, elements #, Data Words", UBOUND(g_Words), ctr1) 'mb pf 'now put word count FOR ctr = LBOUND(ttls) TO UBOUND (ttls) pf USING$(" ##,### ## letter words ", ttls(ctr), ctr) NEXT ctr CLOSE ERASE tmp$ 'don't need it any more END SUB '------------------------------------------------------------------------------ ' ** Main Application Entry Point ** '------------------------------------------------------------------------------ FUNCTION PBMAIN() '''''' Call Data_Words_Create_File 'not needed anymore ' Call Hex_Test:Exit Function Common_Locals ' Call Back_Up 'while working ' Call Good_Words_Only g_CB_All_or_One = 0' Chains as default for Clipboard g_Icon_Id$ = "Zero" g_timer = TIMER g_Include_Name$ = CURDIR$ & "\Check_Words_3_4_5_6.Inc" '4-6 word lengths ' All_Words_in_1_String only builds the Include.Inc ' Must Rem "#Include" below to run All_Words_in_1_String ' Call All_Words_in_1_String: Exit Function 'local q2, q1 as quad ' queryPerformanceCounter q1 #INCLUDE "Check_Words_3_4_5_6b.Inc" 'Words put in g_All_Words$ ' queryPerformanceCounter q2 ' ? str$(q2 - q1) '? str$(len(g_All_Words$)):exit function ' m$ = Using$("#, gAllwords$ took .## secs to load", _ ' Len(G_All_Words$), Timer-g_timer):mb_Alert Setup_Main_Dialog %HWND_DESKTOP END FUNCTION '------------------------------------------------------------------------------ '**************************************************************** '**************************************************************** '**************************************************************** '**************************************************************** '**************************************************************** 'Leave a comment:
-
John, you're the guy doing the solving algos. I just thought it was neat to display all possibilities, even extremely long lists. But given the memory requirements you cite, one has to draw a line somewhere. And I'm quite happy with your line.
As for the icon, it's "Zero" from Beetle Bailey. I'm not familiar with "the kid". Who would that be?Leave a comment:
-
Gösta, there's one other question you might ask about increasing the sequence length: If you can increase it (5-letters for now) to 12-word max in 10 minutes total programming time, what's the big whoop?
It's so close to being recursive, that's all it took. It took 30 minutes to question if it was worth trying. woof
Code:SKULL SKULK SKUNK SKINK SLINK BLINK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SKINK SLINK BLINK BLIND BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SKINK SLINK BLINK BLIND BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SKINK SLINK BLINK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK CLUNK CLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK CLUNK CLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK CLUNK CLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK CLUNK CLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SKINK SLINK BLINK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SKINK SLINK CLINK CLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK CLUNK CLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK CLUNK CLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK FLUNK FLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK FLUNK FLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK FLUNK FLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK FLUNK FLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK FLUNK FLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK PLANT PLAIT PLAIN BLAIN BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK PLANT PLAIT PLAIN BLAIN BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK PLANT PLAIT PLAIN BLAIN BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLINK BLINK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK SLUNK PLUNK PLANK BLANK BLAND BRAND BRAID BRAIN SKULL SKILL SHILL SHALL SHAWL SHAWN SPAWN SPAIN SLAIN BLAIN BRAIN SKULL SKILL SHILL SHALL SHAWL SHAWN SPAWN SPAIN SLAIN BLAIN BRAIN SKULL SKILL SHILL SHALL SHAWL SHAWN SPAWN SPAIN SLAIN BLAIN BRAIN SKULL SKILL SHILL SHALL SHAWL SHAWN SPAWN SPAIN SLAIN BLAIN BRAIN SKULL SKILL SHILL SHALL SHAWL SHAWS CHAWS CRAWS CRAWL BRAWL BRAIL BRAIN SKULL SKILL SHILL SHALL SHAWL SHAWN SPAWN SPAIN SLAIN BLAIN BRAIN SKULL SKULK SKUNK SLUNK SLUNG SLANG SLANT PLANT PLAIT PLAIN BLAIN BRAIN SKULL SKULK SKUNK SLUNK SLINK BLINK BLANK BLAND BRAND BRAID BRAIN SKULL SKULK SKUNK STUNK STANK STAND STAID STAIN SLAIN BLAIN BRAIN SKULL SKULK SKUNK STUNK STANK STAND STAID STAIN SLAIN BLAIN BRAIN SKULL SKILL STILL STALL STALK STANK STAND STAID STAIN SLAIN BLAIN BRAIN SKULL SKILL STILL STILE STELE STERE STERN STEIN STAIN SLAIN BLAIN BRAIN
Leave a comment:
-
It isn't really a set limit as such, rather the algo just ends after it fails to find a sequence in ten words. It compares start-word five-word sequences to end-word five-word sequences, and if there is no answer, end function.Where do you set the 10 word limit?
I could add a six-word compare to increase the potential sequence length to 12 max, but the comparison array for six words must account for the possibility of an exponentially larger data set than even five, which is already 32000 thirty-byte elements. Six words would probably need 128000 36-byte elements to avoid GPF's, and seven words (14 word max sequence) might need 512K 42-byte elements. For the seven-word array alone, that's at least 21MB of memory needed. Add in the previous six allocated arrays and the program uses, oh, 40 or 50 megs of RAM, and the processing time of that memory (the arrays) increases exponentially too.
The question one might ask is, "How long of a sequence is long enough?" If it's a computer programming competition, welp, pull out all the stops. I'm going for EIGHTEEN WORD SHORTEST SEQUENCES. It may take a memory upgrade, many minutes/hours per pair, and days/weeks to find a single valid connection, but when your pride is at stake, what's a cool eighty-three hours of cpu time? It's just a li'l blip geologically speaking, right?
Now if it's a human solving a pair, I'm thinking 90% are seriously challanged by HAND-FOOT, 99.9% by THINK-BRAIN, and a whopping (100 - 10^-8)% by BRAIN-SKULL. (Notice that I haven't even gotten to six-letter words yet).
btw, the icons are coo, and tho the main icon is ABSOLUTELY appropriate, I think I'd like "the kid" for the main icon too.Leave a comment:
-
Okay, tried several things but no success. Even GPF'ed when exiting. Enough for me on that subject. Ain't fixin what ain't broke.Maybe I'll fool around and see it it can be raised without causing any aberrant behavior.
======================================
High thoughts must have high language.
Aristophanes
======================================Leave a comment:
-
Clever. you must be REALLY intriqued with this sequence stuff {grin}.Originally posted by John Gleason View Post
Where do you set the 10 word limit? In the Macro calls? is it "seqLenMax"? Maybe I'll fool around and see it it can be raised without causing any aberrant behavior.This technique can overcome the 10 word sequence max find limitation.
PS. Been meaning to ask. How do you like the Icon? Seems appropriate given the time we are each spending on this. {grin}Leave a comment:
-
Check this out:
BRAIN TRAIN TRAIT TRACT TRACK TRICK THICK THINK THINS SHINS SKINS SKINK SKUNK SKULK SKULL
So I was able to get a mega sequence where the original program came up with:
"No Chains found! BRAIN to SKULL..." I just went BRAIN to THINK and THINK to SKULL. This technique can overcome the 10 word sequence max find limitation. You can then test for shorter solutions by trying various segments of the above solution, like BRAIN to SKULK for example: SKULK SKUNK STUNK STANK STAND STAID STAIN SLAIN BLAIN BRAIN, then add SKULL and voila! 11 word shortest sequence: SKULL SKULK SKUNK STUNK STANK STAND STAID STAIN SLAIN BLAIN BRAINLeave a comment:
-
Here are the updated files:
http://www.swedesdock.com/powerbasic/WC_3456.exe (688k)
http://www.swedesdock.com/powerbasic/WC_3456.bas (95k)Leave a comment:
-
Found it. In my code as I thought. My Bad. Sequences$() holds every solution you find. And a lot are duplicates. (as is to be expected.) For example HAT to CAR can be arrived at 33 ways but only 14 are unique. So before I put the array in the Clipboard. I Sort it and don't insert duplicates. What I'll do now is report only the uniques instead of Ubound(array).Originally posted by Gösta H. Lovgren-2 View Post
Also I will change the Clipboard default to "All Chains" from "Results Only".Leave a comment:
-
I thought that exact thing, especially with the 3 and 4-letter sequences. I thought, "Why do I even need this program to do these? I can get these answers." There was just one little snag: Then I tried to solve the connection myself with no computer help.Now why in the heck can't I do these in pencil?
Leave a comment:
Leave a comment: