All about flooble | fun stuff | Get a free chatterbox | Free JavaScript | Avatars    
perplexus dot info

Home > General > Word Problems
The mad hatter (Posted on 2014-06-09) Difficulty: 3 of 5
My collection of headgear consists of 8 different hats:
1. BERET 2. DERBY 3. FEDORA 4. FEZ
5. PILEUS 6. PILLBOX 7. TEMBEL 8. YARMULKE


Taking one letter from some of the bolded words in a certain order one can create a valid English word like a 7-letter ZEALOTS (4138675) ; or even an 8-letter word YARMULKE (23175684) - the order of hats appearing in the brackets.

Please add some samples of words, of seven or eight letters, formed as described above, using each word at most once and specifying the order of the chosen hats.

No Solution Yet Submitted by Ady TZIDON    
No Rating

Comments: ( Back to comment list | You must be logged in to post comments.)
computer program | Comment 2 of 5 |
The version of the program for 7-letter words is shown as it is the more complicated, allowing for one of the hat words not to be used, by allowing the selection point for one of the items to be beyond the end of the source word:

DefDbl A-Z
Dim crlf$, src(8) As String, foundWord$

Function mform$(x, t$)
  a$ = Format$(x, t$)
  If Len(a$) < Len(t$) Then a$ = Space$(Len(t$) - Len(a$)) & a$
  mform$ = a$
End Function

Private Sub Form_Load()
 ChDir "C:Program Files (x86)DevStudioVBprojects looble"
 Open "madhatter7new.txt" For Output As #2
 Text1.Text = ""
 crlf$ = Chr(13) + Chr(10)
 Form1.Visible = True
 DoEvents
 src(1) = "bert"
 src(2) = "derby"
 src(3) = "fedora"
 src(4) = "fez"
 src(5) = "pileus"
 src(6) = "pilbox"
 src(7) = "tembl"
 src(8) = "yarmulke"
 alw1 = 1
 For a = 1 To Len(src(1)) + 1
  If a > Len(src(1)) Then alw1 = 0
 For b = 1 To Len(src(2)) + alw1
  If b > Len(src(2)) Then alw1 = 0
 For c = 1 To Len(src(3)) + alw1
  If c > Len(src(3)) Then alw1 = 0
  Text1.Text = Text1.Text & Str(a) & Str(b) & Str(c) & "     "
  DoEvents
 For d = 1 To Len(src(4)) + alw1
  If d > Len(src(4)) Then alw1 = 0
 For e = 1 To Len(src(5)) + alw1
  If e > Len(src(5)) Then alw1 = 0
 For f = 1 To Len(src(6)) + alw1
  If f > Len(src(6)) Then alw1 = 0
 For g = 1 To Len(src(7)) + alw1
  If g > Len(src(7)) Then alw1 = 0
 For h = 1 To Len(src(8)) + alw1
  DoEvents
  If h > Len(src(8)) Then alw1 = 0
  anag$ = Mid(src(1), a, 1) + Mid(src(2), b, 1) + Mid(src(3), c, 1) + Mid(src(4), d, 1) + Mid(src(5), e, 1) + Mid(src(6), f, 1) + Mid(src(7), g, 1) + Mid(src(8), h, 1)
  seq$ = ""
  If a <= Len(src(1)) Then seq$ = seq$ + "1"
  If b <= Len(src(2)) Then seq$ = seq$ + "2"
  If c <= Len(src(3)) Then seq$ = seq$ + "3"
  If d <= Len(src(4)) Then seq$ = seq$ + "4"
  If e <= Len(src(5)) Then seq$ = seq$ + "5"
  If f <= Len(src(6)) Then seq$ = seq$ + "6"
  If g <= Len(src(7)) Then seq$ = seq$ + "7"
  If h <= Len(src(8)) Then seq$ = seq$ + "8"
  If Len(anag$) = 7 Then
    Do
     done = 1
     For i = 1 To 6
      If Mid(anag$, i, 1) > Mid(anag$, i + 1, 1) Then
       hold$ = Mid(anag$, i + 1, 1)
       Mid(anag$, i + 1, 1) = Mid(anag$, i, 1)
       Mid(anag$, i, 1) = hold$
       hold$ = Mid(seq$, i + 1, 1)
       Mid(seq$, i + 1, 1) = Mid(seq$, i, 1)
       Mid(seq$, i, 1) = hold$
       done = 0
      End If
     Next
    Loop Until done
    If isMatch(anag$) Then
      ReDim used(8)
      bldseq$ = ""
      For i = 1 To Len(foundWord$)
        lt$ = Mid(foundWord$, i, 1)
        strt = 1
        Do
         ix = InStr(strt, anag$, lt$)
         cube = Val(Mid(seq$, ix, 1))
         If used(cube) Then strt = ix + 1: ix = 0
         used(cube) = 1
        Loop While ix = 0
        bldseq$ = bldseq$ + LTrim(Str(cube))
      Next
      Print #2, foundWord$ & " " & bldseq$
      DoEvents
    End If
    If h > Len(src(8)) Then alw1 = 1
  End If
 Next
  If g > Len(src(7)) Then alw1 = 1
 Next
  If f > Len(src(6)) Then alw1 = 1
 Next
  If e > Len(src(5)) Then alw1 = 1
 Next
  If d > Len(src(4)) Then alw1 = 1
 Next
  If c > Len(src(3)) Then alw1 = 1
 Next
  If b > Len(src(2)) Then alw1 = 1
 Next
  If a > Len(src(1)) Then alw1 = 1
 Next
 Close 2
 Text1.Text = Text1.Text & "done part 1" + crlf
 
Shell "sort < madhatter7new.txt > madhatter7news.txt"
t = Timer + 20
While Timer < t: Wend
 
 
  Open "madhatter7news.txt" For Input As #1
 Open "mad hatter 7.txt" For Output As #2

 crlf$ = Chr(13) + Chr(10)
 Form1.Visible = True
 DoEvents
 Do
  Line Input #1, l$
  p$ = w$
  w$ = Left$(l$, 7)
  If w$ = p$ Then
   Print #2, " "; Right(l$, 7);
  Else
   Print #2,
   Print #2, w$; " "; Right(l$, 7);
  End If
 Loop Until EOF(1)
 Close
  
End Sub
Function isMatch(anag$)
  Open "wordsanadct7.txt" For Binary As #10
  l$ = Space$(15)
  high = LOF(10) / 15
  low = 1
  Do
   md = Int((high + low) / 2)
   Get #10, (md - 1) * 15 + 1, l$
   ana$ = Left(l$, 7): wd$ = Right(l$, 7)
   If ana$ = anag$ Then Exit Do
   If ana$ < anag$ Then low = md + 1
   If ana$ > anag$ Then high = md - 1
  Loop Until high < low
  If ana$ = anag$ Then foundWord$ = wd$: isMatch = 1 Else isMatch = 0
  Close 10
End Function

The shell function did not actually work, presumably because the directory change didn't affect the contents of the shelled Command Prompt action. So the sort was done manually when the next Open failed to find its input, and then the program was continued.

The output was further filtered by throwing out words that couldn't be found in a smaller word list than was used for the anagram dictionary files.

I don't know how much of the output will fit in one post, so the 7-letter words will appear in the next post, and the 8-letter words will follow.

BTW while ZEALOTS and YARMULKE do not appear in the condensed (filtered) output, they were in the original files.

Yarmulke had only one way: the way shown, but zealots had several:

4138675 4186375 4237615 4238615 4238675 4286315 4286375 4287315 4287615 4387615 4738615 4786315 4837615

Edited on June 9, 2014, 10:16 pm
  Posted by Charlie on 2014-06-09 22:02:42

Please log in:
Login:
Password:
Remember me:
Sign up! | Forgot password


Search:
Search body:
Forums (0)
Newest Problems
Random Problem
FAQ | About This Site
Site Statistics
New Comments (5)
Unsolved Problems
Top Rated Problems
This month's top
Most Commented On

Chatterbox:
Copyright © 2002 - 2017 by Animus Pactum Consulting. All rights reserved. Privacy Information