Rosetta Code Challenges

[bplus]

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