11-05-2022, 04:57 AM
Zebra Puzzle 2 Sweep
I rewrote the Zebra Puzzle because I was feeling guilty reviewing the results of last round of scenario elimination and coding the next. Good for practice but this really solves it blindly.
Now it's coded to eliminate scenarios by coding in what I was looking for and doing the elimination from there. To do that I needed to know where each house number started and ended so I kept the original scenario array at 15625 and just added an " X" to the end of it when that scenario was eliminated. This takes longer because I am running through 15625 scenarios at each round and for neighbor checks at each solved neighbor value that has a condition in the 16 Clues. The Build works much better and can be used to generate a list of permutations for all kinds of things.
Code: (Select All)
Option _Explicit
_Title "Zebra Puzzle 2 Sweep" 'b+ start 2021-09-05 2022-10-29
' ref http://rosettacode.org/wiki/Zebra_puzzle
' restart 2022-10-27 add split
' 2022-10-29 make and use build sub for combining and ordering permutations
' generate ALL possible scenarios of house 1 number/order, 2 color, 3 nation, 4 drink, 5 smoke, 6 animal
' 2022-10-29 add old Wrd$() tool to find nth word in string.
' 2022-10-29 add Sub aCopy (a() As String, b() As String)
' 2022-10-29 add Sub AddEnd (a() As String, addon As String)
' 2022-10-29 3 phases of elimination and down to Sol'n in blink of the eye!
' 2022-11-02 Zebra Puzzle 2 Sweep is an attempt to code the observations I made between 3 eliminations rounds
' After first elimination from 15625 to 38 I observed House 1 had to be yellow, water Dunhills
' Add a Shared Solution Array and a sub that reads through survivor scenarios and looks for only 1 option for a house
' eg house 1 is only yellow so put yellow under color for house 1 and remove all other houses with yellow as option
' 2022-11-03 Since I am rebuilding this I want to do the build over too, more like I did in JB translation.
' 2022-11-04 OK it runs through supposedly without assistance by programmer.
$Console:Only
Print
Print " The Zebra Puzzle has 16 Clues:"
Print
Print " 1. There are five houses."
Print " 2. The English man lives in the red house."
Print " 3. The Swede has a dog."
Print " 4. The Dane drinks tea."
Print " 5. The green house is immediately to the left of the white house."
Print " 6. They drink coffee in the green house."
Print " 7. The man who smokes Pall Mall has birds."
Print " 8. In the yellow house they smoke Dunhill."
Print " 9. In the middle house they drink milk."
Print " 10. The Norwegian lives in the first house."
Print " 11. The man who smokes Blend lives in the house next to the house with cats."
Print " 12. In a house next to the house where they have a horse, they smoke Dunhill."
Print " 13. The man who smokes Blue Master drinks beer."
Print " 14. The German smokes Prince."
Print " 15. The Norwegian lives next to the blue house."
Print " 16. They drink water in a house next to the house where they smoke Blend"
Print
Print " The Puzzle is, Who owns the zebra?"
Print
Dim Shared Soln$(1 To 6, 1 To 5), Flag$ ' quality columns and house number rows
Dim Shared order$, color$, nation$, drink$, smoke$, animal$, testC$, testH$
Dim As Long i, test1, test2
Dim startT
' from 1-16 there are 5 house in order from left to right that have:
order$ = "1 2 3 4 5" 'left to right
color$ = "red green white yellow blue"
nation$ = "English Swede Dane Norwegian German"
drink$ = "tea coffee milk beer water"
smoke$ = "Pall_Malls Dunhill Blend Blue_Master Prince"
animal$ = "dog birds cats horse zebra?"
Print " 15,625 = (5 ^ 6) possible scenarios of :"
Print " 5 House Choices: "; order$
Print " with 5 Colors Choices: "; color$
Print " with 5 Nationalities Choices: "; nation$
Print " with 5 Drink Choices: "; drink$
Print " with 5 Smokes Choices: "; smoke$
Print " and finally 5 Animals Choices: "; animal$
Print
ReDim Shared scen$(1 To 1) ' container for all the permutations make this shared so sub can use without parameter
' that built as I want list: order color nation drink smoke animal = 6 items in order
' note: at moment temp$ and scen$ arrays are the same
startT = Timer(.01)
Build animal$
Build smoke$
Build drink$
Build nation$
Build color$
Build order$
For i = 1 To UBound(scen$) ' elimination round
'2. The English man lives in the red house.
test1 = InStr(scen$(i), "English") > 0: test2 = InStr(scen$(i), "red") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'3. The Swede has a dog.
test1 = InStr(scen$(i), "Swede") > 0: test2 = InStr(scen$(i), "dog") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'4. The Dane drinks tea.
test1 = InStr(scen$(i), "Dane") > 0: test2 = InStr(scen$(i), "tea") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'5. The green house is immediately to the left of the white house.
' green <> 1, 2 or 5 so 3 or 4 white 4 or 5 because blue is 2 and green and white are sequential
testC$ = Wrd$(scen$(i), 2): testH$ = Wrd$(scen$(i), 1)
If testC$ = "green" Then
If testH$ = "3" Or testH$ = "4" Then Else scen$(i) = scen$(i) + " X"
ElseIf testC$ = "white" Then
If testH$ = "4" Or testH$ = "5" Then Else scen$(i) = scen$(i) + " X"
End If
' house 4 can only be green or white or wont have sequence
If testH$ = "4" Then
If testC$ = "green" Or testC$ = "white" Then Else scen$(i) = scen$(i) + " X"
End If
'6. They drink coffee in the green house.
test1 = InStr(scen$(i), "coffee") > 0: test2 = InStr(scen$(i), "green") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'7. The man who smokes Pall Mall has birds.
test1 = InStr(scen$(i), "Pall_Malls") > 0: test2 = InStr(scen$(i), "birds") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'8. In the yellow house they smoke Dunhill.
test1 = InStr(scen$(i), "yellow") > 0: test2 = InStr(scen$(i), "Dunhill") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'9. In the middle house they drink milk.
test1 = InStr(scen$(i), "3") > 0: test2 = InStr(scen$(i), "milk") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'10. The Norwegian lives in the first house.
test1 = InStr(scen$(i), "Norwegian") > 0: test2 = InStr(scen$(i), "1") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'11. The man who smokes Blend lives in the house next to the house with cats.
test1 = InStr(scen$(i), "Blend") > 0: test2 = InStr(scen$(i), "cats") > 0
If test1 Or test2 Then ' not in same house
If test1 And test2 Then scen$(i) = scen$(i) + " X"
End If
'12. In a house next to the house where they have a horse, they smoke Dunhill.
test1 = InStr(scen$(i), "horse") > 0: test2 = InStr(scen$(i), "Dunhill") > 0
If test1 Or test2 Then ' not in same house
If test1 And test2 Then scen$(i) = scen$(i) + " X"
End If
'13. The man who smokes Blue Master drinks beer.
test1 = InStr(scen$(i), "Blue_Master") > 0: test2 = InStr(scen$(i), "beer") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'14. The German smokes Prince.
test1 = InStr(scen$(i), "German") > 0: test2 = InStr(scen$(i), "Prince") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
'15. The Norwegian lives next to the blue house.
' the Norwegian is in house 1 so blue house is house 2
test1 = InStr(scen$(i), "blue") > 0: test2 = InStr(scen$(i), "2") > 0
If test1 Or test2 Then ' if have one must have both or dump
If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
End If
' 16. They drink water in a house next to the house where they smoke Blend
test1 = InStr(scen$(i), "water") > 0: test2 = InStr(scen$(i), "Blend") > 0
If test1 Or test2 Then ' not in same house
If test1 And test2 Then scen$(i) = scen$(i) + " X"
End If
Next
showScen ' OK still works with 38 surv after first elim
Print String$(80, "+")
Print
Do
Flag$ = ""
EvalElimRun
If Flag$ <> "" Then Print Flag$
If Flag$ <> "" Then showScen
Loop Until Flag$ = ""
Print Timer(.01) - startT ' aprox 5.6 secs without printing
Print: Print String$(80, "="): Print
showSolution
Function House& (val$)
Dim As Long row, col
For row = 1 To 5
For col = 1 To 6
If Soln$(col, row) = val$ Then House& = row: Exit Function
Next
Next
End Function
Sub showSolution
Dim As Long row, col
Print pad$("House"); pad$("Color"); pad$("Nation"); pad$("Drink"); pad$("Smoke"); pad$("Pet")
Print
For row = 1 To 5
For col = 1 To 6
Print pad$(Soln$(col, row));
Next
Print
Next
End Sub
Function pad$ (s$)
pad$ = Left$(s$ + String$(13, " "), 13)
End Function
Sub EvalElimRun ' here I coded what I coded manually before supposedly without knowing what is going to sieve through
Dim As Long s, h, item
Dim H$
For h = 1 To 5
H$ = _Trim$(Str$(h))
s = (h - 1) * 3125 + 1
' find first house still in the running
While Wrd$(scen$(s), 7) = "X" And s < h * 3125
s = s + 1
Wend ' still active
ReDim first$(1 To 6) ' get it's values
For item = 1 To 6
first$(item) = Wrd$(scen$(s), item) ' get first values for house
Next
' if all values match first we have exclusive
ReDim NoMatch(1 To 6) As Long
s = s + 1
While s <= h * 3125 ' run through section with house # h check if items match the very first active found
If Wrd$(scen$(s), 7) <> "X" Then ' scen s still in running
For item = 1 To 6
If NoMatch(item) = 0 Then ' so far all these are matching
If first$(item) <> Wrd$(scen$(s), item) Then NoMatch(item) = 1 ' dang
End If
Next
End If
s = s + 1
Wend
' process matches
For item = 1 To 6
If NoMatch(item) = 0 Then ' found something unique for house!
If Soln$(item, h) = "" Then ' did we already know?
Soln$(item, h) = first$(item)
' now throw out every other scen$ with that item in another house
For s = 1 To 15625
If Wrd$(scen$(s), 7) <> "X" Then ' scen s still in running
If Wrd$(scen$(s), 1) <> H$ Then
If Wrd$(scen$(s), item) = first$(item) Then scen$(s) = scen$(s) + " X": Flag$ = "Change" ' signal a change
End If
End If
Next
End If
End If
Next
Next
' more 16. They drink water in a house next to the house where they smoke Blend"
If House&("water") Then ' water is a solution so house # is determined and Blend is a neighbor
For s = 1 To 15625
If Wrd$(scen$(s), 7) <> "X" Then
If Wrd$(scen$(s), 5) = "Blend" Then
If Abs(House&("water") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
End If
End If
Next
End If
If House&("Blend") Then ' Blend is a solution so house # is determined next door water
For s = 1 To 15625
If Wrd$(scen$(s), 7) <> "X" Then
If Wrd$(scen$(s), 4) = "water" Then
If Abs(House&("Blend") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
End If
End If
Next
End If
' more 12. In a house next to the house where they have a horse, they smoke Dunhill.
If House&("Dunhill") Then ' Dunhill is a solution so house # is determined next door horse
For s = 1 To 15625
If Wrd$(scen$(s), 7) <> "X" Then
If Wrd$(scen$(s), 6) = "horse" Then
If Abs(House&("Dunhill") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
End If
End If
Next
End If
If House&("horse") Then ' horse is a solution so next door is Dunhill
For s = 1 To 15625
If Wrd$(scen$(s), 7) <> "X" Then
If Wrd$(scen$(s), 5) = "Dunhill" Then
If Abs(House&("horse") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
End If
End If
Next
End If
' more 11. The man who smokes Blend lives in the house next to the house with cats.
If House&("Blend") Then ' Blend is a sloution so next door cats
For s = 1 To 15625
If Wrd$(scen$(s), 7) <> "X" Then
If Wrd$(scen$(s), 6) = "cats" Then
If Abs(House&("Blend") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
End If
End If
Next
End If
If House&("cats") Then ' cats is a solution so next door Blend
For s = 1 To 15625
If Wrd$(scen$(s), 7) <> "X" Then
If Wrd$(scen$(s), 5) = "Blend" Then
If Abs(House&("cats") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
End If
End If
Next
End If
End Sub
Sub Build (wordStr$) ' redo build to handle any word list in string form
Dim As Long nW, nS, mW, w1, w2, i
Dim w$
nW = wCnt(wordStr$)
nS = UBound(scen$) ' shared array we are building
If nS = 0 Or nS = 1 Then
mW = nW
ReDim temp$(1 To nW) ' getting started with first list
For w1 = 1 To nW
temp$(w1) = Wrd$(wordStr$, w1)
Next
Else
mW = nS * nW
ReDim temp$(1 To nS * nW)
For w2 = 1 To nW
w$ = Wrd$(wordStr$, w2)
For w1 = 1 To nS
i = i + 1
temp$(i) = w$ + " " + scen$(w1)
Next
Next
End If
ReDim scen$(1 To mW) 'rewrite scen$
For i = 1 To mW
scen$(i) = temp$(i)
Next
End Sub
Sub showScen ' the scenarios not eliminated
Dim As Long i, c
For i = 1 To 15625
If Wrd$(scen$(i), 7) <> "X" Then c = c + 1: Print c, scen$(i)
Next
End Sub
' This duplicates JB word(string, wordNumber) base 1, space as default delimiter
' by returning the Nth word of source string s
' this function assumes s has been through wPrep
Function Wrd$ (ss$, wNumber)
Dim s$, w$
Dim As Long c, i
's$ = wPrep(ss$)
s$ = ss$ 'don't change ss$
If Len(s$) = 0 Then Wrd$ = "": Exit Function
w$ = "": c = 1
For i = 1 To Len(s$)
If Mid$(s$, i, 1) = " " Then
If c = wNumber Then Wrd$ = w$: Exit Function
w$ = "": c = c + 1
Else
w$ = w$ + Mid$(s$, i, 1)
End If
Next
If c <> wNumber Then Wrd$ = " " Else Wrd$ = w$
End Function
Function wCnt (s$)
Dim c As Integer, p As Integer, ip As Integer
's = wPrep(s)
If Len(s$) = 0 Then wCnt = 0: Exit Function
c = 1: p = 1: ip = InStr(p, s$, " ")
While ip
c = c + 1: p = ip + 1: ip = InStr(p, s$, " ")
Wend
wCnt = c
End Function
b = b + ...