REM WordCube Challenge and Solver REM Copyright 2002 by Mark Congdon REM You may make review this code, and make changes for personal use. REM Before distributing changes you have made, you must receive permission REM from Mark Congdon (mcphn@yahoo.com). $INCLUDE "RAPIDQ.INC" $APPTYPE GUI $INCLUDE "openfile.inc" $INCLUDE "inputbox.inc" RANDOMIZE TIMER $RESOURCE APPICON AS "QMARK.ICO" Application.IcoHandle = APPICON $RESOURCE WAVShake AS "shake.wav" $RESOURCE WAVerror AS "chord.wav" $RESOURCE WAVenter AS "ding.wav" $RESOURCE ICO_check AS "check.ico" $RESOURCE ICO_x AS "x.ico" DIM IconList AS QIMAGELIST IconList.Height = 16 IconList.Width = 16 IconList.AddICOHandle ICO_check IconList.AddICOHandle ICO_x REM ************************************* REM DECLARE ROUTINES REM ************************************* DECLARE SUB RedrawMain DECLARE SUB RedrawCubes DECLARE SUB ShowCube (cubenum&, letter$) DECLARE SUB ShowGauge DECLARE SUB HideGauge DECLARE SUB DisableInput DECLARE SUB EnableInput DECLARE SUB Set4X4 DECLARE SUB Set5X5 DECLARE SUB CustomSize DECLARE SUB SetMinLength DECLARE SUB SetRotatingLetters DECLARE SUB SetSoundOpt DECLARE SUB SelectDCT DECLARE SUB JustMix DECLARE SUB JustPlay DECLARE SUB MixAndPlay DECLARE SUB MixPuzzle DECLARE SUB MixPuzzleFast DECLARE SUB LookUpWord DECLARE SUB SaveSettings DECLARE SUB AboutShow DECLARE SUB abtShowLicenseTxt DECLARE SUB abtShowCreditsTxt DECLARE SUB abtStartEmail DECLARE SUB ffKeyPress (KeyPressed AS BYTE) DECLARE SUB ffChange DECLARE SUB FillAndSolve DECLARE SUB FillPuzzle DECLARE SUB entryResize DECLARE SUB entryDone DECLARE SUB entryClose DECLARE SUB entryKeyPress (KeyPressed AS BYTE) DECLARE SUB entryChange DECLARE SUB entryDisplay DECLARE SUB entryTimerTick DECLARE FUNCTION FindWordInDCT (chkword$, DCT$) AS WORD DECLARE FUNCTION FindWordInPuzzle (chkword$) AS WORD DECLARE SUB FindWordInPuzzle2 (row AS WORD, col AS WORD, tmpword$, chkword$) DECLARE SUB rsltDisplay DECLARE SUB rsltResize DECLARE SUB rsltClose DECLARE SUB rsltSortWordDn DECLARE SUB rsltSortWordUp DECLARE SUB rsltSortLenDn DECLARE SUB rsltSortLenUp DECLARE SUB rsltSort DECLARE SUB SolveIt DECLARE SUB FindWords (row AS INTEGER,col AS INTEGER,inwrd AS STRING) DECLARE SUB MakeDCT DECLARE SUB MakeDCT_WriteTable DECLARE SUB MakeTXTfromDCT DECLARE SUB FindAllWords (inwrd AS STRING) DECLARE SUB AddWord DECLARE SUB RemoveWord REM ************************************* REM SET UP GLOBAL VARIABLES REM ************************************* CONST LTRDIST$ = "AAAAAAABBCCCDDDDEEEEEEEEEEEEEFFFGGHHHIIIIIIIJKLLLMMMNNNNNNNNOOOOOOOPPPQRRRRRRRRSSSSSSTTTTTTTTTUUUVVWWXYYZ" DIM frmHid AS QFORM DIM TXTFile as QFILESTREAM DIM DCTFile as QFILESTREAM DIM DC2File as QFILESTREAM DIM OutFile as QFILESTREAM DIM foundword(1 TO 10) AS STRING DIM foundcnt& DIM arr(1 TO Rows*Cols) AS STRING DIM used(1 TO Rows*Cols) AS INTEGER DIM FontName AS STRING DIM INIFileName$ DIM TMPFileName$ INIFileName$ = "WC.INI" TMPFileName$ = "~WC.TMP" ' ----------------------------- ' window and cube dimensions ' ----------------------------- DIM WndWidth AS INTEGER DIM WndHeight AS INTEGER DIM cubesize AS INTEGER cubesize = 35 WndWidth = Cols*cubesize + 50 if WndWidth < 250 then WndWidth = 250 WndHeight = Rows*cubesize + 120 ' ----------------------------- ' objects with dynamic properties ' ----------------------------- DIM cube(1 to 81) AS QIMAGE CREATE BoggleFont AS QFONT Color = 0 END CREATE REM ************************************* REM READ INI FILE REM ************************************* Rows = 5 Cols = 5 MinLength& = 5 RotateLetters = False FontName = "Verdana" Sounds = True DCTSelected$ = "BEGINNER.DCT" If FileExists(INIFileName$) then TXTFile.Open (INIFileName$, fmOpenRead) WHILE Not TXTFile.EOF tmp$ = UCASE$(RTRIM$(LTRIM$(TXTFile.ReadLine))) if instr(tmp$,"=")>1 AND INSTR(TMP$,"=")4 OR Cols<>4) AND (Rows<>5 OR Cols<>5)," (***)","") OnClick = CustomSize END CREATE CREATE mnuline2 AS QMENUITEM Caption = STRING$(30,"-") END CREATE CREATE SelectDCTItem AS QMENUITEM Caption = "&Select dictionary to use ("+MID$(DCTSelected$,RINSTR(DCTSelected$,"\")+1)+")" OnClick = SelectDCT END CREATE CREATE MinLenItem AS QMENUITEM Caption = "Set Minimum Word &Length ("+STR$(MinLength&)+")" OnClick = SetMinLength END CREATE CREATE RotateItem AS QMENUITEM Caption = "Rotating Letters On/off ("+IIF(RotateLetters=True,"On","Off")+")" OnClick = SetRotatingLetters END CREATE CREATE SoundOptItem AS QMENUITEM Caption = "Sounds On/Off ("+IIF(Sounds=True,"On","Off")+")" OnClick = SetSoundOpt END CREATE CREATE mnuline3 AS QMENUITEM Caption = STRING$(30,"-") END CREATE CREATE SaveSettingsItem AS QMENUITEM Caption = "&Save these settings as default" OnClick = SaveSettings END CREATE END CREATE CREATE WordsMenu AS QMENUITEM Caption = "&Words" CREATE MakeDCTItem AS QMENUITEM Caption = "&Make dictionary file from text wordlist" OnClick = MakeDCT END CREATE CREATE MakeTXTItem AS QMENUITEM Caption = "&Uncompress dictionary file to text file" OnClick = MakeTXTfromDCT END CREATE CREATE AddWordItem AS QMENUITEM Caption = "&Add a word to the current dictionary ("+MID$(DCTSelected$,RINSTR(DCTSelected$,"\")+1)+")" OnClick = AddWord END CREATE CREATE RemoveWordItem AS QMENUITEM Caption = "&Remove a word from the current dictionary ("+MID$(DCTSelected$,RINSTR(DCTSelected$,"\")+1)+")" OnClick = RemoveWord END CREATE CREATE LookUpItem AS QMENUITEM Caption = "&Look up a word" OnClick = LookUpWord END CREATE END CREATE CREATE HelpMenu AS QMENUITEM Caption = "&Help" CREATE AboutItem AS QMENUITEM Caption = "&About" OnClick = AboutShow END CREATE END CREATE END CREATE CREATE btnMix AS QBUTTON Caption = "Mix 'n Play" OnClick = MixAndPlay END CREATE CREATE btnFill AS QBUTTON Caption = "Fill 'n Solve" OnClick = FillAndSolve END CREATE CREATE Gauge AS QGAUGE Kind = gkHorizontalBar ShowText = True ShowHint = False END CREATE OnResize = RedrawMain END CREATE frmMain.DelBorderIcons(biMaximize) REM ************************************* REM DISPLAY ROUTINES REM ************************************* SUB RedrawMain WndWidth = Cols*cubesize + 50 if WndWidth < 250 then WndWidth = 250 WndHeight = Rows*cubesize + 120 frmMain.Height = WndHeight frmMain.Width = WndWidth btnMix.Top = 10+Rows*cubesize+20 btnMix.Height = 30 btnMix.Width = INT(WndWidth/2)-40 btnMix.Left = INT((WndWidth/4) - (btnMix.Width/2)) btnFill.Top = 10+Rows*cubesize+20 btnFill.Height = 30 btnFill.Width = INT(WndWidth/2)-40 btnFill.Left = INT((3*WndWidth/4) - (btnFill.Width/2)) Gauge.Top = 10+Rows*cubesize+20 Gauge.Height = 30 Gauge.Width = WndWidth - 30 Gauge.Left = 10 RedrawCubes END SUB SUB RedrawCubes GridLeft& = (WndWidth-(cubesize*Cols))/2 - 3 For i = 1 to Rows For j = 1 to Cols tmp = (i-1)*Cols + j cube(tmp).Parent = frmMain cube(tmp).Left = GridLeft&+(j-1)*cubesize cube(tmp).Top = 10+(i-1)*cubesize cube(tmp).Width = cubesize cube(tmp).Height = cubesize cube(tmp).Rectangle (1,1,cubesize-1,cubesize-1,0) ShowCube (tmp, arr(tmp)) Next j Next i for i = Rows*Cols+1 to 81 cube(i).Parent = frmHid next i END SUB SUB ShowCube (cubenum&, letter$) if letter$ = "Q" then cubetxt$ = "Qu" BoggleFont.Size = 14 else cubetxt$ = letter$ BoggleFont.Size = 18 end if texttop& = INT ((cubesize - BoggleFont.Size - 12) / 2) cube(cubenum&).Font = BoggleFont cube(cubenum&).FillRect (2,2,cubesize-3,cubesize-3,&HFFFFFF) tmp% = cube(cubenum&).TextWidth(cubetxt$) textleft& = (cubesize-tmp%) / 2 cube(cubenum&).TextOut (textleft&,texttop&,cubetxt$,&H000000,&HFFFFFF) if RotateLetters = True then rndnum& = RND*4 cube(cubenum&).Rotate ((cubesize-1)/2,(cubesize-1)/2,90*rndnum&) end if END SUB SUB ShowGauge btnMix.Parent = frmHid btnFill.Parent = frmHid Gauge.Parent = frmMain END SUB SUB HideGauge Gauge.Parent = frmHid btnMix.Parent = frmMain btnFill.Parent = frmMain END SUB SUB DisableInput btnMix.Enabled = False btnFill.Enabled = False PlayMenu.Enabled = False OptionsMenu.Enabled = False WordsMenu.Enabled = False HelpMenu.Enabled = False END SUB SUB EnableInput btnMix.Enabled = True btnFill.Enabled = True PlayMenu.Enabled = True OptionsMenu.Enabled = True WordsMenu.Enabled = True HelpMenu.Enabled = True END SUB REM ************************************* REM OPTION ROUTINES REM ************************************* SUB Set4X4 Rows = 4 Cols = 4 SET4X4ITEM.Caption = "&4x4 Puzzle (***)" SET5X5ITEM.Caption = "&5x5 Puzzle" CustomSizeItem.Caption = "&Custom Size Puzzle" RedrawMain MixPuzzleFast END SUB SUB Set5X5 Rows = 5 Cols = 5 SET4X4ITEM.Caption = "&4x4 Puzzle" SET5X5ITEM.Caption = "&5x5 Puzzle (***)" CustomSizeItem.Caption = "&Custom Size Puzzle" RedrawMain MixPuzzleFast END SUB SUB CustomSize tmp$ = STR$(Rows) InputBox ("Rows (1-9):","Enter the number of rows",@tmp$,@rtval&) if rtval& <> 0 then EXIT SUB tmpRows& = VAL(tmp$) if tmpRows& < 1 OR tmpRows& > 9 then MESSAGEBOX ("Invalid number of rows. The number of rows must be between 1 and 9, inclusive.","Error",0) EXIT SUB end if tmp$ = STR$(Cols) InputBox ("Columns (1-9):","Enter the number of columns",@tmp$,@rtval&) if rtval& <> 0 then EXIT SUB tmpCols& = VAL(tmp$) if tmpCols& < 1 OR tmpCols& > 9 then MESSAGEBOX ("Invalid number of columns. The number of columns must be between 1 and 9, inclusive.","Error",0) EXIT SUB end if Rows = tmpRows& Cols = tmpCols& SET4X4ITEM.Caption = "&4x4 Puzzle" SET5X5ITEM.Caption = "&5x5 Puzzle" CustomSizeItem.Caption = "&Custom Size Puzzle (***)" RedrawMain MixPuzzleFast END SUB SUB SetMinLength tmp$ = STR$(MinLength&) InputBox ("Minimum length (2-9):","Enter the minimum word length",@tmp$,@rtval&) if rtval& <> 0 then EXIT SUB tmpLen& = VAL(tmp$) if tmpLen& < 2 or tmpLen& > 9 then MESSAGEBOX ("Invalid length. The minimum word length must be between 2 and 9, inclusive.","Error",0) EXIT SUB end if MinLength& = tmpLen& MinLenItem.Caption = "Set Minimum Word &Length ("+STR$(MinLength&)+")" END SUB SUB SetRotatingLetters if RotateLetters = True then RotateLetters = False else RotateLetters = True end if RotateItem.Caption = "Rotating Letters On/off ("+IIF(RotateLetters=True,"On","Off")+")" RedrawCubes END SUB SUB SetSoundOpt if Sounds = True then Sounds = False else Sounds = True end if SoundOptItem.Caption = "Sounds On/Off ("+IIF(Sounds=True,"On","Off")+")" END SUB SUB SelectDCT OpenFile ("*.DCT","","Select Dictionary File",@DCTFileName$,@rtval&) if rtval& = 0 then DCTSelected$ = DCTFileName$ end if SelectDCTItem.Caption = "&Select dictionary to use ("+MID$(DCTSelected$,RINSTR(DCTSelected$,"\")+1)+")" AddWordItem.Caption = "&Add a word to the current dictionary ("+MID$(DCTSelected$,RINSTR(DCTSelected$,"\")+1)+")" RemoveWordItem.Caption = "&Remove a word from the current dictionary ("+MID$(DCTSelected$,RINSTR(DCTSelected$,"\")+1)+")" END SUB REM ************************************* REM SIMPLE ROUTINES REM ************************************* SUB MixAndPlay DisableInput MixPuzzle entryDisplay EnableInput END SUB SUB JustMix DisableInput MixPuzzle EnableInput END SUB SUB JustPlay DisableInput entryDisplay EnableInput END SUB SUB MixPuzzle if Sounds then PLAYWAV WAVShake, SND_ASYNC strttimer! = TIMER WHILE TIMER <= strttimer!+0.8 tmp$ = LTRDIST$ FOR i = 1 to Rows*Cols rndnum& = RND*(LEN(tmp$)-1) + 1 arr(i) = MID$(tmp$,rndnum&,1) tmp2$ = IIF(rndnum&>1,LEFT$(tmp$,rndnum&-1),"") + IIF(rndnum&1,LEFT$(tmp$,rndnum&-1),"") + IIF(rndnum& 0 then EXIT SUB if LEN(tmp$) = 0 then EXIT SUB if FindWordInDCT(tmp$, "UNABRIDGED.DCT") then MESSAGEBOX (CHR$(34)+tmp$+CHR$(34)+" IS in the unabridged dictionary","Found!",0) else MESSAGEBOX (CHR$(34)+tmp$+CHR$(34)+" is NOT in the unabridged dictionary","Not Found...",0) end if END SUB SUB SaveSettings TXTFile.Open (INIFileName$, fmCreate) TXTFile.WriteLine "Rows="+STR$(Rows) TXTFile.WriteLine "Cols="+STR$(Cols) TXTFile.WriteLine "MinLength="+STR$(MinLength&) TXTFile.WriteLine "Rotate="+IIF(RotateLetters,"TRUE","FALSE") TXTFile.WriteLine "Dictionary="+DCTSelected$ TXTFile.WriteLine "Font="+FontName TXTFile.WriteLine "Sounds="+IIF(Sounds,"TRUE","FALSE") TXTFile.Close END SUB FUNCTION PointValue (testword$) AS WORD if LEN(testword$) < 5 then PointValue = 1 if LEN(testword$) = 5 then PointValue = 2 if LEN(testword$) = 6 then PointValue = 3 if LEN(testword$) = 7 then PointValue = 5 if LEN(testword$) > 7 then PointValue = 11 END FUNCTION REM ************************************* REM ABOUT FORM REM ************************************* CREATE abtFontLrg AS QFONT Size = 15 END CREATE CREATE abtFontMed AS QFONT Size = 12 END CREATE CREATE abtFontNrm AS QFONT Size = 8 END CREATE CREATE abtFontLnk AS QFONT Size = 8 Color = &HFF0000 END CREATE abtFontLnk.AddStyles(fsUnderline) CREATE frmAbout AS QFORM Caption = "WordCube: About" ClientWidth = 210 ClientHeight = 210 Center BorderStyle = bsDialog CREATE abtImg AS QIMAGE ICOHandle = APPICON Left = 10 Top = 5 AutoSize = True END CREATE CREATE abtLbl1 AS QLABEL Caption = "WordCube" Font = abtFontLrg AutoSize = True Top = 0 Left = abtImg.Left + abtImg.Width + INT((frmAbout.ClientWidth - abtLbl1.Width - (2*abtImg.Left) - abtImg.Width) / 2) END CREATE CREATE abtLbl2 AS QLABEL Caption = "Challenge and Solver" Font = abtFontMed AutoSize = True Top = abtLbl1.Height Left = abtImg.Left + abtImg.Width + INT((frmAbout.ClientWidth - abtLbl2.Width - (2*abtImg.Left) - abtImg.Width) / 2) END CREATE CREATE abtLbl2b AS QLABEL Caption = "Version 1.4" Font = abtFontMed AutoSize = True Top = abtLbl2.Top+abtLbl2.Height Left = abtImg.Left + abtImg.Width + INT((frmAbout.ClientWidth - abtLbl2b.Width - (2*abtImg.Left) - abtImg.Width) / 2) END CREATE CREATE abtLbl3 AS QLABEL Caption = "Copyright © 2002 by Mark Congdon" Font = abtFontNrm AutoSize = True Top = abtLbl2b.Top+abtLbl2b.Height+10 Left = INT((frmAbout.ClientWidth - abtLbl3.Width) / 2) END CREATE CREATE abtLbl4 AS QLABEL Caption = "All Rights Reserved." Font = abtFontNrm AutoSize = True Top = abtLbl3.Top+abtLbl3.Height Left = INT((frmAbout.ClientWidth - abtLbl4.Width) / 2) END CREATE CREATE abtLbl5 AS QLABEL Caption = "See LICENSE.TXT for more details." Font = abtFontLnk AutoSize = True Top = abtLbl4.Top+abtLbl4.Height Left = INT((frmAbout.ClientWidth - abtLbl5.Width) / 2) Cursor = crHandPoint OnClick = abtShowLicenseTxt END CREATE CREATE abtLbl6 AS QLABEL Caption = "This program is freeware. If you enjoy it," Font = abtFontNrm AutoSize = True Top = abtLbl5.Top+abtLbl5.Height+10 Left = INT((frmAbout.ClientWidth - abtLbl6.Width) / 2) END CREATE CREATE abtLbl7 AS QLABEL Caption = "please email me at ." Font = abtFontLnk AutoSize = True Top = abtLbl6.Top+abtLbl6.Height Left = INT((frmAbout.ClientWidth - abtLbl7.Width) / 2) Cursor = crHandPoint OnClick = abtStartEmail END CREATE CREATE abtLbl8 AS QLABEL Caption = "I have many people to thank for the tools" Font = abtFontNrm AutoSize = True Top = abtLbl7.Top+abtLbl7.Height+10 Left = INT((frmAbout.ClientWidth - abtLbl8.Width) / 2) END CREATE CREATE abtLbl9 AS QLABEL Caption = "that have made this program possible." Font = abtFontNrm AutoSize = True Top = abtLbl8.Top+abtLbl8.Height Left = INT((frmAbout.ClientWidth - abtLbl9.Width) / 2) END CREATE CREATE abtLbl10 AS QLABEL Caption = "See CREDITS.TXT for details." Font = abtFontLnk AutoSize = True Top = abtLbl9.Top+abtLbl9.Height Left = INT((frmAbout.ClientWidth - abtLbl10.Width) / 2) Cursor = crHandPoint OnClick = abtShowCreditsTxt END CREATE END CREATE SUB AboutShow frmAbout.ShowModal END SUB SUB abtShowLicenseTxt RUN("notepad license.txt") END SUB SUB abtShowCreditsTxt RUN("notepad credits.txt") END SUB SUB abtStartEmail RUN("start mailto:mcphn@yahoo.com") END SUB REM ************************************* REM FILL PUZZLE FORM, GLOBALS, AND ROUTINES REM ************************************* CREATE frmFillPuzzle AS QFORM Caption = "Fill Puzzle" ClientWidth = 55 ClientHeight = 15 Top = 0 Left = 0 BorderStyle = bsToolWindow CREATE ffLabel1 AS QLABEL Caption = "Enter the letters for the puzzle." Top = 0 Left = 10 AutoSize = True END CREATE CREATE ffLabel2 AS QLABEL Caption = "Hit SPACE to leave unchanged." Top = 14 Left = 10 AutoSize = True END CREATE CREATE ffEntry AS QRICHEDIT Top = 0 Left = 0 Height = 10 Width = 0 OnKeyPress = ffKeyPress OnChange = ffChange END CREATE END CREATE DIM ffActiveBtn AS INTEGER SUB ffKeyPress (KeyPressed AS BYTE) if KeyPressed = 27 then RedrawCubes frmFillPuzzle.Close end if END SUB SUB ffChange cnt% = 0 for i = 1 to Len(ffEntry.Text) char$ = UCASE$(MID$(ffEntry.Text,i,1)) if INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ ",char$) > 0 then cnt% = cnt% + 1 if cnt% <= Rows*Cols then if char$=" " then ShowCube (cnt%,arr(cnt%)) else ShowCube (cnt%,char$) arr(cnt%) = char$ end if end if end if next i ffActiveBtn = cnt%+1 if ffActiveBtn <= Rows*Cols then ShowCube (ffActiveBtn,"?") else frmFillPuzzle.Close end if END SUB SUB FillAndSolve FillPuzzle if ffActiveBtn > Rows*Cols then SolveIt END SUB SUB FillPuzzle DisableInput ffActiveBtn = 1 ShowCube (1, "?") ffEntry.Text = "" frmFillPuzzle.Width = frmMain.ClientWidth frmFillPuzzle.Height = 60 frmFillPuzzle.Top = frmMain.Top + frmMain.Height - frmFillPuzzle.Height frmFillPuzzle.Left = frmMain.Left + INT(frmMain.Width/2) - INT(frmFillPuzzle.Width/2) frmFillPuzzle.ShowModal RedrawCubes EnableInput END SUB REM ************************************* REM WORD ENTRY AND RESULTS FORMS REM ************************************* CREATE entryRedFont AS QFONT Color = &H0000FF END CREATE DIM entryCount AS INTEGER CREATE entryTimer AS QTIMER Interval = 1000 Enabled = 0 OnTimer = entryTimerTick END CREATE CREATE frmWordEntry AS QForm ClientHeight = 300 ClientWidth = 200 Caption = "Your Words" CREATE entryWordEdit AS QRICHEDIT Top = 25 Height = 25 Left = 10 Width = frmWordEntry.ClientWidth - 20 OnKeyPress = entryKeyPress OnChange = entryChange END CREATE CREATE entryLblErr AS QLABEL Caption = "" Top = 52 Height = 15 Left = 10 AutoSize = True Font = entryRedFont END CREATE CREATE entryListView AS QLISTVIEW Top = 70 Left = 0 Width = frmWordEntry.ClientWidth Height = frmWordEntry.ClientHeight - 130 ViewStyle = vsReport AddColumns "Word","Len","Pts" Column(0).Width = INT(frmWordEntry.ClientWidth*.5) Column(1).Width = INT(frmWordEntry.ClientWidth*.2) Column(2).Width = INT(frmWordEntry.ClientWidth*.2) ColumnClick = False SmallImages = IconList LargeImages = IconList END CREATE CREATE entryLblTimer AS QLABEL Caption = "0:00" Top = frmWordEntry.ClientHeight - 50 Height = 20 Left = 2 AutoSize = True END CREATE CREATE entryLblTotal AS QLABEL Caption = "Total Points:" Top = frmWordEntry.ClientHeight - 50 Height = 20 Left = frmWordEntry.ClientWidth - 60 AutoSize = True END CREATE CREATE entryBtnDone AS QBUTTON Caption = "&Done" OnClick = entryDone Top = frmWordEntry.ClientHeight - 30 Left = INT((frmWordEntry.ClientWidth - 70) / 2) Height = 20 Width = 70 END CREATE CREATE entryLbl1 AS QLABEL Caption = "Enter a word and hit Enter..." Top = 5 Height = 15 Left = 10 AutoSize = True END CREATE OnResize = entryResize END CREATE CREATE frmResults AS QForm ClientHeight = 300 ClientWidth = 200 Caption = "My Words" CREATE rsltListView AS QListView Top = 10 Left = 0 Width = frmResults.ClientWidth Height = frmResults.ClientHeight - 60 ViewStyle = vsReport SortType = tsText AddColumns "Word","Len","Pts" Column(0).Width = INT(frmResults.ClientWidth*.5) Column(1).Width = INT(frmResults.ClientWidth*.2) Column(2).Width = INT(frmResults.ClientWidth*.2) ColumnClick = False SmallImages = IconList LargeImages = IconList END CREATE CREATE rsltSortWordUpImg AS QIMAGE Top = 0 Left = rsltListView.Column(0).Width - 20 Height = 7 Width = 7 Transparent = True Line(0,6,6,6,0) Line(0,6,3,0,0) Line(3,0,6,6,0) Paint(3,3,0,0) OnClick = rsltSortWordUp END CREATE CREATE rsltSortWordDnImg AS QIMAGE Top = 0 Left = rsltListView.Column(0).Width - 10 Height = 7 Width = 7 Transparent = True Line(0,0,6,0,0) Line(0,0,3,6,0) Line(3,6,6,0,0) Paint(3,3,0,0) OnClick = rsltSortWordDn END CREATE CREATE rsltSortLenUpImg AS QIMAGE Top = 0 Left = rsltListView.Column(0).Width + rsltListView.Column(1).Width - 20 Height = 7 Width = 7 Transparent = True Line(0,6,6,6,0) Line(0,6,3,0,0) Line(3,0,6,6,0) Paint(3,3,0,0) OnClick = rsltSortLenUp END CREATE CREATE rsltSortLenDnImg AS QIMAGE Top = 0 Left = rsltListView.Column(0).Width + rsltListView.Column(1).Width - 10 Height = 7 Width = 7 Transparent = True Line(0,0,6,0,0) Line(0,0,3,6,0) Line(3,6,6,0,0) Paint(3,3,0,0) OnClick = rsltSortLenDn END CREATE CREATE rsltLblTotal AS QLABEL Caption = "Total Points:" Top = frmResults.ClientHeight - 50 Height = 20 Left = frmResults.ClientWidth - 60 AutoSize = True END CREATE CREATE rsltBtnClose AS QBUTTON Caption = "&Close" OnClick = rsltClose Top = frmResults.ClientHeight - 30 Left = INT((frmResults.ClientWidth - 70) / 2) Height = 20 Width = 70 END CREATE OnResize = rsltResize END CREATE REM ************************************* REM WORD ENTRY AND RESULTS ROUTINES REM ************************************* SUB entryResize entryListView.Width = frmWordEntry.ClientWidth entryListView.Height = frmWordEntry.ClientHeight - 130 entryListView.Column(0).Width = INT(frmWordEntry.ClientWidth*.5) entryListView.Column(1).Width = INT(frmWordEntry.ClientWidth*.2) entryListView.Column(2).Width = INT(frmWordEntry.ClientWidth*.2) entryBtnDone.Left = INT((frmWordEntry.ClientWidth - 70) / 2) entryBtnDone.Top = frmWordEntry.ClientHeight - 30 entryWordEdit.Width = frmWordEntry.ClientWidth - 20 entryLblTotal.Top = frmWordEntry.ClientHeight - 50 entryLblTotal.Left = frmWordEntry.ClientWidth - entryLblTotal.Width - 10 entryLblTimer.Top = frmWordEntry.ClientHeight - 50 END SUB SUB entryDone entryTimer.Enabled = 0 entryWordEdit.Enabled = False entryBtnDone.Caption = "&Close" entryBtnDone.OnClick = entryClose SolveIt END SUB SUB entryClose frmResults.Close frmWordEntry.Close END SUB SUB entryKeyPress (KeyPressed AS BYTE) if KeyPressed = 13 then wordtofind$ = UCASE$(LTRIM$(RTRIM$(entryWordEdit.Text))) if LEN(wordtofind$) < MinLength& then if Sounds then PLAYWAV WAVerror, SND_ASYNC entryLblErr.Caption = "That word is too short" elseif FindWordInDCT(wordtofind$, DCTSelected$) = False AND FindWordInDCT(wordtofind$, "UNABRIDGED.DCT") = False then if Sounds then PLAYWAV WAVerror, SND_ASYNC entryLblErr.Caption = "I can't find that word in the dictionary" elseif FindWordInPuzzle(wordtofind$) = False then if Sounds then PLAYWAV WAVerror, SND_ASYNC entryLblErr.Caption = "That word isn't in the puzzle" else tmp% = 0 for i = 0 to entryListView.ItemCount-1 if entryListView.Item(i).Caption = wordtofind$ then tmp% = 1 next i if tmp% = 1 then if Sounds then PLAYWAV WAVerror, SND_ASYNC entryLblErr.Caption = "You've already used that word" else if Sounds then PLAYWAV WAVenter, SND_ASYNC entryLblErr.Caption = "" entryListView.AddItems wordtofind$ entryListView.AddSubItem entryListView.ItemCount-1, STR$(LEN(wordtofind$)) entryListView.AddSubItem entryListView.ItemCount-1, STR$(PointValue(wordtofind$)) entryListView.Item(entryListView.ItemCount-1).ImageIndex = 0 PointTotal& = 0 for i = 0 to entryListView.ItemCount-1 PointTotal& = PointTotal& + VAL(entryListView.SubItem(i,1)) next i entryLblTotal.Caption = "Total Points: "+STR$(PointTotal&) entryLblTotal.Left = frmWordEntry.ClientWidth - entryLblTotal.Width - 10 entryLblErr.Caption = "" end if end if entryWordEdit.Text = "" elseif KeyPressed = 27 then entryLblErr.Caption = "" entryWordEdit.Text = "" end if END SUB SUB entryChange if INSTR(entryWordEdit.Text,CHR$(13)) > 0 OR INSTR(entryWordEdit.Text,CHR$(27)) > 0 then entryWordEdit.Text = "" end if END SUB SUB entryDisplay frmWordEntry.ClientHeight = 300 frmWordEntry.ClientWidth = 200 frmWordEntry.Top = frmMain.Top frmWordEntry.Left = frmMain.Left - frmWordEntry.Width if frmWordEntry.Left < 0 then frmWordEntry.Left = 0 frmWordEntry.Width = frmMain.Left end if entryListView.Clear entryLblErr.Caption = "" entryLblTotal.Caption = "Total Points: 0" entryLblTimer.Caption = "0:00" entryBtnDone.Caption = "&Done" entryBtnDone.OnClick = entryDone entryBtnDone.Enabled = False entryWordEdit.Enabled = True entryBtnDone.Enabled = True frmWordEntry.Show entryCount = 0 entryTimer.Enabled = 1 WHILE frmWordEntry.Visible = True DOEVENTS WEND entryListView.Clear END SUB SUB entryTimerTick entryCount = entryCount + 1 entryLblTimer.Caption = STR$(INT(entryCount/60))+":"+RIGHT$("00"+STR$(entryCount MOD 60),2) END SUB FUNCTION FindWordInDCT (chkword$, DCT$) AS WORD rtnval% = False DCTFile.Open(DCT$, fmOpenRead) for i = 1 to LEN(chkword$) char$ = UCASE$(MID$(chkword$,i,1)) if char$ = "Q" then i = i + 1 if INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ",char$)=0 then exit for idx% = ASC(char$)-ASC("A") BITTBL& = DCTFile.ReadNum(4) WHILE (BITTBL& AND 1) = 1 tmp& = BITTBL&-1 DCTFile.Seek (tmp&,soFromBeginning) BITTBL& = DCTFile.ReadNum(4) WEND if ((BITTBL& SHR (31-idx%)) AND 1) = 1 then TBLCNT% = 0 for j = 1 to idx% if ((BITTBL& SHR (32-j)) AND 1) = 1 then TBLCNT% = TBLCNT%+1 next j DCTFile.Seek (4*TBLCNT%,soFromCurrent) loc& = DCTFile.ReadNum (4) if (loc& AND 1) = 1 then if i = LEN(chkword$) then rtnval% = True exit for end if loc& = loc& - 1 end if if loc& = 0 then exit for DCTFile.Seek (loc&,soFromBeginning) else exit for end if next i DCTFile.Close FindWordInDCT = rtnval% END FUNCTION DIM bfound AS WORD FUNCTION FindWordInPuzzle (chkword$) AS WORD for tmp = 1 TO Rows*Cols used(tmp) = 0 next tmp bfound = False for i = 1 to Rows for j = 1 to Cols FindWordInPuzzle2 (i, j, "", chkword$) if bfound then exit for next j if bfound then exit for next i if bFound then FindWordInPuzzle = True else FindWordInPuzzle = False end if END FUNCTION SUB FindWordInPuzzle2 (row AS WORD, col AS WORD, tmpword$, chkword$) DIM tmp AS STRING DIM i AS INTEGER DIM j AS INTEGER tmp = tmpword$ + IIF(arr((row-1)*Cols+col)="Q","QU",arr((row-1)*Cols+col)) if tmp = chkword$ then bfound = True elseif LEN(tmp) < LEN(chkword$) then if tmp = LEFT$(chkword$,LEN(tmp)) then used((row-1)*Cols+col)=1 for i = -1 to 1 for j = -1 to 1 IF NOT (row+i=0 OR row+i>Rows OR col+j=0 or col+j>Cols) THEN IF used((row+i-1)*Cols+col+j)=0 THEN FindWordInPuzzle2 (row+i,col+j,tmp,chkword$) END IF END IF if bfound then exit for next j if bfound then exit for next i used((row-1)*Cols+col)=0 end if end if END SUB DIM rsltSortCol% DIM rsltSortDir% rsltSortCol% = 0 rsltSortDir% = 1 SUB rsltDisplay PointTotal& = 0 rsltListView.Clear for i = 1 to foundcnt& rsltListView.AddItems foundword(i) rsltListView.AddSubItem i-1, STR$(LEN(foundword(i))) rsltListView.AddSubItem i-1, STR$(PointValue(foundword(i))) rsltListView.Item(i-1).ImageIndex = 0 PointTotal& = PointTotal& + PointValue(foundword(i)) for j = 1 to entryListView.ItemCount if entryListView.Item(j-1).Caption = rsltListView.Item(i-1).Caption then entryListView.Item(j-1).ImageIndex = 1 rsltListView.Item(i-1).ImageIndex = 1 exit for end if next j next i rsltLblTotal.Caption = "Total Points: "+STR$(PointTotal&) rsltLblTotal.Left = frmResults.ClientWidth - rsltLblTotal.Width - 10 rsltSortCol% = 0 frmResults.ClientHeight = 300 frmResults.ClientWidth = 200 frmResults.Top = frmMain.Top frmResults.Left = frmMain.Left + frmMain.Width if frmResults.Left+frmResults.Width > Screen.Width then frmResults.Width = Screen.Width - frmResults.Left if frmResults.Left+frmResults.Width > Screen.Width then frmResults.Left = Screen.Width - frmResults.Width end if end if frmResults.Show if frmWordEntry.Visible = True then chkentryform% = True else chkentryform% = False WHILE frmResults.Visible = True DOEVENTS if chkentryform% = True then if frmWordEntry.Visible = False then EXIT WHILE end if WEND rsltListView.Clear frmWordEntry.Close frmResults.Close END SUB SUB rsltResize rsltListView.Width = frmResults.ClientWidth rsltListView.Height = frmResults.ClientHeight - 60 rsltListView.Column(0).Width = INT(frmResults.ClientWidth*.5) rsltListView.Column(1).Width = INT(frmResults.ClientWidth*.2) rsltListView.Column(2).Width = INT(frmResults.ClientWidth*.2) rsltBtnClose.Left = INT((frmResults.ClientWidth - 70) / 2) rsltBtnClose.Top = frmResults.ClientHeight - 30 rsltSortWordUpImg.Left = rsltListView.Column(0).Width - 20 rsltSortWordDnImg.Left = rsltListView.Column(0).Width - 10 rsltSortLenUpImg.Left = rsltListView.Column(0).Width + rsltListView.Column(1).Width - 20 rsltSortLenDnImg.Left = rsltListView.Column(0).Width + rsltListView.Column(1).Width - 10 rsltLblTotal.Top = frmResults.ClientHeight - 50 rsltLblTotal.Left = frmResults.ClientWidth - rsltLblTotal.Width - 10 END SUB SUB rsltClose frmWordEntry.Close frmResults.Close END SUB SUB rsltSortWordDn rsltSortDir% = -1 rsltSortCol% = 1 rsltSort END SUB SUB rsltSortWordUp rsltSortDir% = 1 rsltSortCol% = 1 rsltSort END SUB SUB rsltSortLenDn rsltSortDir% = -1 rsltSortCol% = 2 rsltSort END SUB SUB rsltSortLenUp rsltSortDir% = 1 rsltSortCol% = 2 rsltSort END SUB SUB rsltSort for i = 1 to foundcnt&-1 for j = i+1 to foundcnt& swap% = -1 if rsltSortCol% = 2 then if rsltSortDir% * (LEN(foundword(j))-LEN(foundword(i))) < 0 then swap% = 1 else swap% = 0 end if else for k = 1 to LEN(foundword(i)) if rsltSortDir%=1 AND LEN(foundword(j)) MID$(foundword(j),k,1) then if rsltSortDir% * (ASC(MID$(foundword(i),k,1)) - ASC(MID$(foundword(j),k,1))) > 0 then swap% = 1 exit for else swap% = 0 exit for end if end if next k end if if swap% = -1 then if rsltSortDir%=-1 AND LEN(foundword(j))>LEN(foundword(i)) then swap% = 1 else swap% = 0 end if end if if swap% = 1 then SWAP foundword(i),foundword(j) next j next i rsltListView.Clear for i = 1 to foundcnt& rsltListView.AddItems foundword(i) rsltListView.AddSubItem i-1, STR$(LEN(foundword(i))) rsltListView.AddSubItem i-1, STR$(PointValue(foundword(i))) for j = 1 to entryListView.ItemCount if entryListView.Item(j-1).Caption = rsltListView.Item(i-1).Caption then entryListView.Item(j-1).ImageIndex = 1 rsltListView.Item(i-1).ImageIndex = 1 exit for end if next j next i END SUB REM ************************************* REM SOLVE IT! REM ************************************* SUB SolveIt DIM i AS INTEGER, j AS INTEGER, wrd AS STRING for tmp = 1 TO Rows*Cols used(tmp) = 0 next tmp ' make sure the dictionary file is available If FILEEXISTS(DCTSelected$)=0 then MESSAGEBOX("Dictionary File Not Found","Error",0) EXIT SUB End if ' prepare the screen DisableInput Gauge.Position = 0 Gauge.Max = Rows*Cols ShowGauge ' recursively look for words OutFile.Open(TMPFileName$, fmCreate) DCTFile.Open(DCTSelected$, fmOpenRead) for i = 1 TO Rows for j = 1 to Cols wrd = "" Gauge.Position = (i-1)*Cols+j FindWords (i, j, wrd) next j next i OutFile.Close DCTFile.Close ' convert output file into array with unique entries foundcnt&=0 OutFile.Open(TMPFileName$, fmOpenRead) WHILE NOT OutFile.EOF nextwrd$ = UCASE$(RTRIM$(LTRIM$(OutFile.ReadLine))) found&=1 if nextwrd$ = "" then found& = 0 for i = 1 to foundcnt& if foundword(i)=nextwrd$ then found&=0 next i if found&=1 then foundcnt& = foundcnt& + 1 if foundcnt& MOD 10 = 0 then REDIM foundword(1 to foundcnt&+10) AS STRING foundword(foundcnt&) = nextwrd$ end if WEND OutFile.Close KILL TMPFileName$ HideGauge rsltDisplay EnableInput END SUB ' ----------------------------- ' recursive routine ' ----------------------------- SUB FindWords (row AS INTEGER,col AS INTEGER,inwrd AS STRING) DIM i AS INTEGER, j AS INTEGER DIM loc AS INTEGER, idx AS INTEGER DIM ltr AS STRING, testwrd AS STRING DIM saveloc AS INTEGER DIM BITTBL AS INTEGER, TBLCNT AS INTEGER DOEVENTS ' check the bit table and lookup values saveloc = DCTFile.Position ltr = arr((row-1)*Cols+col) testwrd = IIF(ltr="Q",inwrd+"QU",inwrd+ltr) idx = ASC(ltr)-ASC("A") BITTBL = DCTFile.ReadNum(4) WHILE (BITTBL AND 1) = 1 tmp& = BITTBL-1 DCTFile.Seek (tmp&,soFromBeginning) BITTBL = DCTFile.ReadNum(4) WEND if ((BITTBL SHR (31-idx)) AND 1) = 1 then TBLCNT = 0 for i = 1 to idx if ((BITTBL SHR (32-i)) AND 1) = 1 then TBLCNT = TBLCNT+1 next i DCTFile.Seek (4*TBLCNT,soFromCurrent) loc = DCTFile.ReadNum (4) if (loc AND 1) = 1 then if Len(testwrd)>=MinLength& then OutFile.WriteLine testwrd loc = loc - 1 end if if loc > 0 then DCTFile.Seek (loc,soFromBeginning) used((row-1)*Cols+col)=1 for i = -1 to 1 for j = -1 to 1 IF NOT (row+i=0 OR row+i>Rows OR col+j=0 or col+j>Cols) THEN IF used((row+i-1)*Cols+col+j)=0 THEN FindWords (row+i,col+j,testwrd) END IF END IF next j next i end if end if ' clean up before ending this recursive layer used((row-1)*Cols+col)=0 DCTFile.Seek (saveloc,soFromBeginning) END SUB REM ************************************* REM DICTIONARY CREATION ROUTINES REM ************************************* SUB MakeDCT DIM wrd AS STRING DIM loc AS INTEGER OpenFile ("","","Select Word List Text File",@TXTFileName$,@rtval&) if rtval& <> 0 then EXIT SUB FileName$ = MID$(TXTFileName$,RINSTR(TXTFileName$,"\")+1,RINSTR(TXTFileName$,".")-RINSTR(TXTFileName$,"\")-1) InputBox ("Dictionary Name:","Enter a name for the dictionary file",@FileName$,@rtval&) if rtval& <> 0 then EXIT SUB DCTFileName$ = IIF(RIGHT$(CURDIR$,1)="\",CURDIR$+FileName$+".DCT",CURDIR$+"\"+FileName$+".DCT") if FileExists(DCTFileName$) <> 0 then if MESSAGEDLG("That dictionary file already exists. Do you want to overwrite it?", mtWarning, mbYes OR mbNo, 0) = mrNo then EXIT SUB end if DisableInput Gauge.Max = 100 Gauge.Position = 0 ShowGauge TXTFile.Open(TXTFileName$, fmOpenRead) DCTFile.Open(TMPFileName$, fmCreate) for i = 1 to 26 DCTFile.WriteNum (0, 4) next i WHILE NOT TXTFile.EOF wrd = UCASE$(RTRIM$(LTRIM$(TXTFile.ReadLine))) Gauge.Position = INT(100*((TXTFile.Position / TXTFile.Size) / 2)) if wrd = "" then EXIT WHILE Skipword = 0 for i = 1 to LEN(wrd) if INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ",MID$(wrd,i,1))=0 then Skipword = 1 EXIT FOR ELSEIF MID$(wrd,i,1)="Q" then if i=LEN(wrd) then Skipword = 1 EXIT FOR ELSEIF MID$(wrd,i+1,1)<>"U" then Skipword = 1 EXIT FOR end if end if next i if LEN(wrd) = 1 then Skipword = 1 if Skipword = 0 then DCTFile.Seek (0,soFromBeginning) for i = 1 to LEN(wrd) idx = 4*(ASC(MID$(wrd,i,1))-ASC("A")) if MID$(wrd,i,1)="Q" then i=i+1 DCTFile.Seek (idx,soFromCurrent) loc = DCTFile.ReadNum(4) if i = LEN(wrd) then loc = loc OR 1 DCTFile.Seek (-4,soFromCurrent) DCTFile.WriteNum (loc, 4) else if loc=0 or loc=1 then loc = loc + DCTFile.Size DCTFile.Seek (-4,soFromCurrent) DCTFile.WriteNum (loc, 4) DCTFile.Seek (0,soFromEnd) for j = 1 to 26 DCTFile.WriteNum (0, 4) next j DCTFile.Seek (-26*4, soFromCurrent) else if (loc AND 1) = 1 then loc = loc - 1 DCTFile.Seek (loc,soFromBeginning) end if end if next i end if WEND TXTFile.Close DCTFile.Close ' second pass (compress the dictionary file) DCTFile.Open(TMPFileName$, fmOpenRead) DC2File.Open(DCTFileName$, fmCreate) MakeDCT_WriteTable DC2File.Close DCTFile.Close KILL TMPFileName$ HideGauge EnableInput END SUB ' ----------------------------- ' recursive routine ' ----------------------------- SUB MakeDCT_WriteTable DIM i AS INTEGER DIM loc AS INTEGER, idx AS INTEGER, outloc AS INTEGER DIM savelocold AS INTEGER, savelocnew AS INTEGER DIM BITTBL AS INTEGER, TBLCNT AS INTEGER DOEVENTS savelocold = DCTFile.Position savelocnew = DC2File.Position BITTBL = 0 TBLCNT = 0 for i = 1 to 26 loc = DCTFile.ReadNum(4) if loc > 0 then BITTBL = BITTBL OR (1 SHL (32-i)) TBLCNT = TBLCNT + 1 end if next i DC2File.WriteNum (BITTBL,4) for i = 1 to TBLCNT DC2File.WriteNum (0,4) next i TBLCNT = 0 for i = 1 to 26 if savelocold = 0 then Gauge.Position = 50 + 50*(i/26) DCTFile.Seek (savelocold+(i-1)*4, soFromBeginning) loc = DCTFile.ReadNum (4) if loc > 0 then TBLCNT = TBLCNT+1 DC2File.Seek (savelocnew+4+(TBLCNT-1)*4, soFromBeginning) if loc = 1 then DC2File.WriteNum (1,4) else outloc = DC2File.Size if (loc AND 1) = 1 then DC2File.WriteNum (outloc+1,4) loc = loc-1 else DC2File.WriteNum (outloc,4) end if DC2File.Seek (outloc, soFromBeginning) DCTFile.Seek (loc, soFromBeginning) MakeDCT_WriteTable end if end if next i END SUB REM ************************************* REM DICTIONARY DECOMPRESSION ROUTINES REM ************************************* SUB MakeTXTfromDCT DIM wrd AS STRING DIM loc AS INTEGER OpenFile ("*.DCT","","Select Dictionary File to uncompress",@DCTFileName$,@rtval&) if rtval& <> 0 then EXIT SUB FileName$ = MID$(DCTFileName$,RINSTR(DCTFileName$,"\")+1,RINSTR(DCTFileName$,".")-RINSTR(DCTFileName$,"\")-1) + ".TXT" InputBox ("Text File Name:","Enter a name for the exported text file",@FileName$,@rtval&) if rtval& <> 0 then EXIT SUB TXTFileName$ = IIF(RIGHT$(CURDIR$,1)="\",CURDIR$+FileName$,CURDIR$+"\"+FileName$) if FileExists(TXTFileName$) <> 0 then if MESSAGEDLG("That text file already exists. Do you want to overwrite it?", mtWarning, mbYes OR mbNo, 0) = mrNo then EXIT SUB end if DisableInput Gauge.Max = 26 Gauge.Position = 0 ShowGauge DCTFile.Open(DCTFileName$, fmOpenRead) TXTFile.Open(TXTFileName$, fmCreate) FindAllWords ("") TXTFile.Close DCTFile.Close HideGauge EnableInput END SUB ' ----------------------------- ' recursive routine ' ----------------------------- SUB FindAllWords (inwrd AS STRING) DIM i AS INTEGER, j AS INTEGER DIM loc AS INTEGER, idx AS INTEGER DIM ltr AS STRING, testwrd AS STRING DIM saveloc AS INTEGER DIM BITTBL AS INTEGER, TBLCNT AS INTEGER DOEVENTS ' check the bit table and lookup values saveloc = DCTFile.Position for idx = 0 to 25 if saveloc = 0 then Gauge.Position = idx+1 testwrd = inwrd + CHR$(ASC("A")+idx) DCTFile.Seek (saveloc, soFromBeginning) BITTBL = DCTFile.ReadNum(4) WHILE (BITTBL AND 1) = 1 tmp& = BITTBL-1 DCTFile.Seek (tmp&,soFromBeginning) BITTBL = DCTFile.ReadNum(4) WEND if ((BITTBL SHR (31-idx)) AND 1) = 1 then TBLCNT = 0 for i = 1 to idx if ((BITTBL SHR (32-i)) AND 1) = 1 then TBLCNT = TBLCNT+1 next i DCTFile.Seek (4*TBLCNT,soFromCurrent) loc = DCTFile.ReadNum (4) if (loc AND 1) = 1 then TXTFile.WriteLine testwrd loc = loc - 1 end if if loc > 0 then DCTFile.Seek (loc,soFromBeginning) FindAllWords (testwrd) end if end if next idx ' clean up before ending this recursive layer DCTFile.Seek (saveloc,soFromBeginning) END SUB REM ************************************* REM DICTIONARY MODIFICATION ROUTINES REM ************************************* SUB AddWord tmp$ = "" InputBox ("Word to add:","Enter the word you would like added",@tmp$,@rtval&) if rtval& <> 0 then EXIT SUB if LEN(tmp$)=0 then EXIT SUB addword$ = UCASE$(RTRIM$(LTRIM$(tmp$))) validword% = True for i = 1 to LEN(addword$) if INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ",MID$(addword$,i,1))=0 then validword% = False if MID$(addword$,i,1) = "Q" then if i=LEN(addword$) then validword% = False elseif MID$(addword$,i+1,1) <> "U" then validword% = False end if end if next i if validword% = False then MESSAGEBOX (addword$+" is not a valid word.","Add Word",0) EXIT SUB end if ' add the word added% = False DCTFile.Open(DCTSelected$, fmOpenReadWrite) for i = 1 to LEN(addword$) char$ = UCASE$(MID$(addword$,i,1)) if char$ = "Q" then i = i + 1 idx% = ASC(char$)-ASC("A") BITTBL& = DCTFile.ReadNum(4) WHILE (BITTBL& AND 1) = 1 tmp& = BITTBL&-1 DCTFile.Seek (tmp&,soFromBeginning) BITTBL& = DCTFile.ReadNum(4) WEND if ((BITTBL& SHR (31-idx%)) AND 1) = 0 then BITTBL& = BITTBL& OR (1 SHL (31-idx%)) if DCTFile.Position = DCTFile.Size then DCTFile.Seek (-4,soFromCurrent) DCTFile.WriteNum (BITTBL&,4) DCTFile.WriteNum (0,4) DCTFile.Seek (-4,soFromCurrent) else saveloc& = DCTFile.Position DCTFile.Seek (-4,soFromCurrent) DCTFile.WriteNum (DCTFile.Size+1,4) DCTFile.Seek (DCTFile.Size,soFromBeginning) DCTFile.WriteNum (BITTBL&,4) TBLCNT% = 0 for j = 0 to idx%-1 if ((BITTBL& SHR (31-j)) AND 1) = 1 then TBLCNT% = TBLCNT%+1 DCTFile.Seek (saveloc& + 4*(TBLCNT%-1),soFromBeginning) tmp& = DCTFile.ReadNum (4) DCTFile.Seek (DCTFile.Size,soFromBeginning) DCTFile.WriteNum (tmp&,4) end if next j saveloc2& = DCTFile.Size DCTFile.Seek (DCTFile.Size,soFromBeginning) DCTFile.WriteNum (0,4) for j% = idx%+1 to 25 if ((BITTBL& SHR (31-j%)) AND 1) = 1 then TBLCNT% = TBLCNT%+1 DCTFile.Seek (saveloc& + 4*(TBLCNT%-1),soFromBeginning) tmp& = DCTFile.ReadNum (4) DCTFile.Seek (DCTFile.Size,soFromBeginning) DCTFile.WriteNum (tmp&,4) end if next j% DCTFile.Seek (saveloc2&,soFromBeginning) end if if i = LEN(addword$) then DCTFile.WriteNum (1,4) added% = True else DCTFile.WriteNum (DCTFile.Size,4) DCTFile.Seek (DCTFile.Size,soFromBeginning) DCTFile.WriteNum (0,4) end if else TBLCNT% = 0 for j = 1 to idx% if ((BITTBL& SHR (32-j)) AND 1) = 1 then TBLCNT% = TBLCNT%+1 next j DCTFile.Seek (4*TBLCNT%,soFromCurrent) loc& = DCTFile.ReadNum (4) if i = LEN(addword$) then if (loc& AND 1) = 0 then loc& = loc& OR 1 DCTFile.Seek (-4,soFromCurrent) DCTFile.WriteNum (loc&,4) added% = True end if else if loc& = 0 or loc& = 1 then loc& = DCTFile.Size + loc& DCTFile.Seek (-4,soFromCurrent) DCTFile.WriteNum (loc&,4) DCTFile.Seek (DCTFile.Size,soFromBeginning) DCTFile.WriteNum (0,4) else if (loc& AND 1) = 1 then loc& = loc& - 1 DCTFile.Seek (loc&,soFromBeginning) end if end if else exit for end if next i DCTFile.Close ' display the result if added% = True then MESSAGEBOX (addword$+" was successfully added to "+DCTSelected$,"Add Word",0) else MESSAGEBOX (addword$+" could not be added to "+DCTSelected$+" because it is already in the dictionary.","Add Word",0) end if END SUB SUB RemoveWord tmp$ = "" InputBox ("Word to remove:","Enter the word you would like removed",@tmp$,@rtval&) if rtval& <> 0 then EXIT SUB if LEN(tmp$)=0 then EXIT SUB rmvword$ = UCASE$(RTRIM$(LTRIM$(tmp$))) ' remove the word deleted% = False DCTFile.Open(DCTSelected$, fmOpenReadWrite) for i = 1 to LEN(rmvword$) char$ = UCASE$(MID$(rmvword$,i,1)) if char$ = "Q" then i = i + 1 if INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ",char$)=0 then exit for idx% = ASC(char$)-ASC("A") BITTBL& = DCTFile.ReadNum(4) WHILE (BITTBL& AND 1) = 1 tmp& = BITTBL&-1 DCTFile.Seek (tmp&,soFromBeginning) BITTBL& = DCTFile.ReadNum(4) WEND if ((BITTBL& SHR (31-idx%)) AND 1) = 1 then TBLCNT% = 0 for j = 1 to idx% if ((BITTBL& SHR (32-j)) AND 1) = 1 then TBLCNT% = TBLCNT%+1 next j DCTFile.Seek (4*TBLCNT%,soFromCurrent) loc& = DCTFile.ReadNum (4) if (loc& AND 1) = 1 then loc& = loc& - 1 if i = LEN(rmvword$) then DCTFile.Seek (-4,soFromCurrent) DCTFile.WriteNum (loc&,4) deleted% = True exit for end if end if if loc& = 0 then exit for DCTFile.Seek (loc&,soFromBeginning) else exit for end if next i DCTFile.Close ' display the result if deleted% = True then MESSAGEBOX (rmvword$+" was successfully removed from "+DCTSelected$,"Remove Word",0) else MESSAGEBOX (rmvword$+" could not be removed from "+DCTSelected$+" because it could not be found in the dictionary.","Remove Word",0) end if END SUB REM ************************************* REM FLIP THE SWITCH... HERE WE GO REM ************************************* RedrawMain MixPuzzleFast HideGauge frmMain.ShowModal