The Zebra Puzzle
I've been sitting on this problem for over a year, finally got the approach worked out and solved the thing tod... yesterday.
Looks pretty good in Console Window that scrolling is great feature! This is a little like telling a story.
Looks pretty good in Console Window that scrolling is great feature! This is a little like telling a story.
Code: (Select All)
Option _Explicit
_Title "15625 Scenarios Elimination" '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!
$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 order$, color$, nation$, drink$, smoke$, animal$, testC$, testH$, testS$, testA$, testN$
Dim As Long b, i, OK, test1, test2
' 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?"
' arrays to hold little lists of 5
ReDim o$(1 To 1), c$(1 To 1), n$(1 To 1), d$(1 To 1), s$(1 To 1), a$(1 To 1)
Split order$, " ", o$()
Split color$, " ", c$()
Split nation$, " ", n$()
Split drink$, " ", d$()
Split smoke$, " ", s$()
Split animal$, " ", a$()
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 scen$(1 To 1) ' container for all the permutations
ReDim temp$(1 To 1) ' 2nd container for sifting out eliminated scenarios
For b = 1 To 5
Select Case b
Case 1: build s$(), a$(), temp$()
Case 2: build d$(), scen$(), temp$()
Case 3: build n$(), scen$(), temp$()
Case 4: build c$(), scen$(), temp$()
Case 5: build o$(), scen$(), temp$()
End Select
aCopy temp$(), scen$() ' copy temp to scen$() array
Next
' OK 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
ReDim surv$(0) ' store all scenarios we couldn't eliminate, surv$ for survivors!
For i = 1 To UBound(temp$) ' elimination round
OK = -1
'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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
ElseIf testC$ = "white" Then
If testH$ = "4" Or testH$ = "5" Then Else OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
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 OK = 0
End If
If OK Then AddEnd surv$(), scen$(i) ' not eliminated save in survivors
Next
ReDim scen$(0) ' copy surv$() into scen$() for next round
aCopy surv$(), scen$() 'put servivors back into scenario's
Print
Print " Use the 16 statements to go from 15,625 scenarios to 38:"
For i = 1 To UBound(scen$) ' check copy OK
Print i, scen$(i)
Next
Print String$(80, "=")
ReDim surv$(0) ' to reload
For i = 1 To UBound(scen$)
OK = -1
' OK for house 1 we only have 1 choice for color, drink and smoke: yellow, water, dunhill
' if they are in any other house we can eliminate them
testH$ = Wrd$(scen$(i), 1)
If testH$ <> "1" Then
If InStr(scen$(i), "yellow") > 0 Then OK = 0
If InStr(scen$(i), "water") > 0 Then OK = 0
If InStr(scen$(i), "Dunhill") > 0 Then OK = 0
End If
'12. In a house next to the house where they have a horse, they smoke Dunhill.
' we know dunhill is house 1 so horse is house 2
If testH$ <> "2" And Wrd$(scen$(i), 6) = "horse" Then OK = 0
If testH$ = "2" And Wrd$(scen$(i), 6) <> "horse" Then OK = 0
'' Also only red is coming up in house 3 no other choice it must go there!
testC$ = Wrd$(scen$(i), 2)
If testC$ = "red" Then
If testH$ <> "3" Then OK = 0
End If
'' Also since house 3 aint going to be green then house 4 must be and so house 5 must be white!
If testC$ = "green" Then
If testH$ <> "4" Then OK = 0
End If
If testC$ = "white" Then
If testH$ <> "5" Then OK = 0
End If
If OK Then
AddEnd surv$(), scen$(i)
End If
Next
ReDim scen$(0)
aCopy surv$(), scen$() 'put servivors back into scenario's
Print
Print " Notice for House #1 only choice is: yellow, water and Dunhill, so no other house can use those."
Print " Also #12. In a house next to the house where they have a horse, they smoke Dunhill."
Print " We know Dunhill is in house 1 so horse has to be House 2"
Print " Also: For House 3, green is not a choice only red, so that settles green at 4 and white at 5."
Print " Imposing those requirements from observations 38 scenarios are reduced to 11!"
Print
For i = 1 To UBound(scen$) ' check copy OK
Print i, scen$(i)
Next
Print String$(80, "=")
Print
ReDim surv$(0) ' to reload
For i = 1 To UBound(scen$)
OK = -1
' last of conditions
'11. The man who smokes Blend lives in the house next to the house with cats.
'16. They drink water in a house next to the house where they smoke Blend
' House 2 has only one option and that is with Blends and house 1 must have cats because house 3 doesnt
testH$ = Wrd$(scen$(i), 1)
testS$ = Wrd$(scen$(i), 5)
testA$ = Wrd$(scen$(i), 6)
testN$ = Wrd$(scen$(i), 3)
If testS$ = "Blend" And testH$ <> "2" Then OK = 0
If testS$ <> "Blend" And testH$ = "2" Then OK = 0
If testA$ = "cats" And testH$ <> "1" Then OK = 0
If testA$ <> "cats" And testH$ = "1" Then OK = 0
' also House 2 has to be the Dane
If testH$ <> "2" And testN$ = "Dane" Then OK = 0
If OK Then
AddEnd surv$(), scen$(i)
End If
Next
ReDim scen$(0)
aCopy surv$(), scen$() 'put servivors back into scenario's
Print " Now we can take another look at these House positioning requirements:"
Print " 11. The man who smokes Blend lives in the house next to the house with cats."
Print " 16. They drink water in a house next to the house where they smoke Blend"
Print " House 2 has only one option and that is with Blends and house 1 must have cats because house 3 doesn't."
Print
For i = 1 To UBound(scen$) ' check copy OK
Print i, scen$(i)
Next
Print
Print " And with the last cut from Blends connection to House 2, we arrive at the only possible solution!"
Print " The German could not have the Blends nor cats, Blend is at House 2 and cats at House 1. He's got the Zebra!"
Print: Print " b+"
Sleep
' sort of a brute force way to build list of all possible scenario's
Sub build (list1$(), list2$(), outList$()) 'all lists base 1
Dim As Long ub1, ub2, i, j, outI
ub1 = UBound(list1$): ub2 = UBound(list2$)
ReDim outList$(1 To ub1 * ub2)
For i = 1 To ub1
For j = 1 To ub2
outI = outI + 1
outList$(outI) = list1$(i) + " " + list2$(j)
Next
Next
End Sub
Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
dpos = InStr(curpos, SplitMeString, delim)
Do Until dpos = 0
loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
arrpos = arrpos + 1
If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
curpos = dpos + LD
dpos = InStr(curpos, SplitMeString, delim)
Loop
loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
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
Sub AddEnd (a() As String, addon As String)
Dim lba As Long, uba As Long
lba = LBound(a): uba = UBound(a)
ReDim _Preserve a(lba To uba + 1) As String
a(uba + 1) = addon
End Sub
Sub aCopy (a() As String, b() As String)
Dim lba As Long, uba As Long, i As Long
lba = LBound(a): uba = UBound(a)
ReDim b(lba To uba) As String
For i = lba To uba
b(i) = a(i)
Next
End Sub
b = b + ...