Rosetta Code Challenges

[bplus]

The posts in this thread are from Rosetta Code Challenges.

You are free to post improvements.

Better IMHO is less LOC (Lines Of Code) but try to hold off on using so many colons on a line: none is perfect, one or 2 reasonable, 10 ridiculous! = too much)
_____________________________________________________________________________________________

Ken was asking about this today.

Bulls and cows: http://rosettacode.org/wiki/Bulls_and_cows

Code: (Select All)

_Title "Bulls and Cows" ' found at Rosetta for Qbasic, copy 2019-01-31

'challenge is to develope AI player for this game

DefInt A-Z

Dim secret As String
Dim guess As String
Dim c As String
Dim bulls, cows, guesses, i

Randomize Timer
Do While Len(secret) < 4
    c = Chr$(Int(Rnd * 10) + 48)
    If InStr(secret, c) = 0 Then secret = secret + c
Loop

guesses = 0
Do
    Input "Guess a 4-digit number with no duplicate digits: "; guess
    guess = LTrim$(RTrim$(guess))
    If Len(guess) = 0 Then Exit Do

    If Len(guess) <> 4 Or Val(guess) = 0 Then
        Print "** You should enter 4 numeric digits!"
        GoTo looper
    End If

    bulls = 0: cows = 0: guesses = guesses + 1
    For i = 1 To 4
        c = Mid$(secret, i, 1)
        If Mid$(guess, i, 1) = c Then
            bulls = bulls + 1
        ElseIf InStr(guess, c) Then
            cows = cows + 1
        End If
    Next i
    Print bulls; " bulls, "; cows; " cows"

    If guess = secret Then
        Print "You won after "; guesses; " guesses!"
        Exit Do
    End If
    looper:
Loop

[SierraKen]

LOL Thanks B+ but it's not the game I was thinking about. The one I was thinking about had little graphics of animals in the pen moving around, I should have explained it better. But this little game is pretty neat. I like random number games. Reminds me of one of my very first games I made in BASIC programming class at High School.

[bplus]

Yeah, I posted it to show it was not the game you were talking about, no animals or sounds just a logic brain puzzle.

[bplus]

The Zebra Puzzle

ref: https://rosettacode.org/wiki/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.

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

[bplus]

This was given at Rosetta Code as a problem similar to Zebra Puzzle but it's a pretty straight forward check all possible see what sticks.

Dinesman Multi-Dwelling

Code: (Select All)

_Title "Dinemans Multi_Dwelling - Rosetta Code" ' b+ found 2022-10-30  too easy
' ref: https://rosettacode.org/wiki/Dinesman%27s_multiple-dwelling_problem
'Baker does not live on the top floor.
'Cooper does not live on the bottom floor.
'Fletcher does not live on either the top or the bottom floor.
'Miller lives on a higher floor than does Cooper.
'Smith does not live on a floor adjacent to Fletcher's.
'Fletcher does not live on a floor adjacent to Cooper's

' nim soln same as Ada:
'Baker lives on floor 3
'Cooper lives on floor 2
'Fletcher lives on floor 4
'Miller lives on floor 5
'Smith lives on floor 1

' b <> 5     ' 1 to 4
' c <> 1      ' 2 to 5
' f <> 1 and f <> 5   ' 2 to 4
' m > c      then c <> 5   m <> 1
' s <> f + 1 and s <> f - 1
' f <> c + 1 and f <> c - 1

'everyone seems to go from 1 to 5        is there another solution going from 5 to 1?  no because the other codes dont quit when one is found
For b = 4 To 1 Step -1
    For c = 4 To 2 Step -1
        If c <> b Then
            For f = 4 To 2 Step -1
                If (f <> c) And (f <> b) Then
                    For m = 5 To 2 Step -1
                        If (m <> f) And ((m <> c) And (m <> b)) Then
                            For s = 5 To 1 Step -1
                                If ((s <> m) And (s <> f)) And ((s <> c) And (s <> b)) Then
                                    If (f <> c + 1) And (f <> c - 1) Then
                                        If s <> f + 1 And s <> f - 1 Then
                                            If m > c Then
                                                Print "Baker ="; b
                                                Print "Cooper ="; c
                                                Print "Fletcher ="; f
                                                Print "Miller ="; m
                                                Print "Smith ="; s
                                            End If
                                        End If
                                    End If
                                End If
                            Next
                        End If
                    Next
                End If
            Next
        End If
    Next
Next
Print "              End of Run"

Only one solution sticks, Smith gets the dreaded first floor.

The other related problem, 12 Statements, is giving me more trouble but it was past my bedtime. Maybe today I can figure it out.
https://rosettacode.org/wiki/Twelve_statements

[SpriggsySpriggs]

I used to peruse those challenges to see what I could do. Fellippe tried getting everyone on board with that a while back. Just so many things on that site.

[bplus]

I used to peruse those challenges to see what I could do. Fellippe tried getting everyone on board with that a while back. Just so many things on that site.

Yes, I can't seem to get enough challenges that make me think but are doable. Here is great place to copy the masters!

Twelve Statements (Boolean Logic + Binary Scenarios Puzzle)

I did figure out Twelve Statements but I had to add Else clauses in Statement 4 and 8 handlers that make the statement True if the first condition is not. (Plus Statement 12 was missing a TF(7) in the total.)
Statement 4:  If statement 5 is true, then statements 6 and 7 are both true.
                    So where are we if 5 is NOT true?
                    Well I guess if I want to match Rosetta single unique solution I have to say:
                    ELSE statement(4) = 1

the same happens in
Statement 8: If statement 7 is true, then 5 and 6 are both true.
                    So where are we if 7 is NOT true?
                    Well I guess if I want to match Rosetta single unique solution I have to say:
                    ELSE statement(8) = 1

BTW allot of these statements have symmetric complements:
The first 6, the last 6
The evens, the odds
Statement 4 and statement 8

Here using 1 not -1, so be careful with IF's ANDs...

2 ^ 12 is the number of permutations of True and False (1 and 0) so convert all numbers 0 to 2^12 - 1 to Binary and you run all the possible ways T and F, 1 and 0, can be arranged in 12 digits slots. So run the numbers and see which one(s) produce a consistent match with the 12 statements. As usual with Rosetta Code problems the problem is setup to produce one or unique set of solutions. 

Code: (Select All)

Option _Explicit
_Title "12 Statements - Rosetta Code" ' b+  found 2022-10-30
'ref:     https://rosettacode.org/wiki/Twelve_statements

'     12 Statements
' 1.  This is a numbered list of twelve statements.
' 2.  Exactly 3 of the last 6 statements are true.
' 3.  Exactly 2 of the even-numbered statements are true.
' 4.  If statement 5 is true, then statements 6 and 7 are both true.
' 5.  The 3 preceding statements are all false.
' 6.  Exactly 4 of the odd-numbered statements are true.
' 7.  Either statement 2 or 3 is true, but not both.
' 8.  If statement 7 is true, then 5 and 6 are both true.
' 9.  Exactly 3 of the first 6 statements are true.
'10.  The next two statements are both true.
'11.  Exactly 1 of statements 7, 8 and 9 are true.
'12.  Exactly 4 of the preceding statements are true.

' Solution at Rosetta Code is with statements 1 3 4 6 7 11 true.

'VVVVVVVV mass comment method
'$If  Then
ReDim As Long n, TF(1 To 12), wrong, i
For n = 0 To 4095
    Dec2BinArr12 n, TF() ' get a TF scenario and compare to 12 statements
    ReDim st(1 To 12) As Long
    ' 1.  This is a numbered list of twelve statements.
    st(1) = 1

    ' 2.  Exactly 3 of the last 6 statements are true.
    If ((TF(7) + TF(8) + TF(9) + TF(10) + TF(11) + TF(12)) = 3) Then st(2) = 1

    ' 3.  Exactly 2 of the even-numbered statements are true.
    If ((TF(2) + TF(4) + TF(6) + TF(8) + TF(10) + TF(12)) = 2) Then st(3) = 1

    ' 4.  If statement 5 is true, then statements 6 and 7 are both true.
    If TF(5) Then
        If ((TF(6) + TF(7)) = 2) Then st(4) = 1
    Else ' we need next to say true??
        st(4) = 1 ' ?  not working the other way every other TF will be 0 anyway
    End If

    ' 5.  The 3 preceding statements are all false.
    If ((TF(4) + TF(3) + TF(2)) = 0) Then st(5) = 1

    ' 6.  Exactly 4 of the odd-numbered statements are true.
    If ((TF(1) + TF(3) + TF(5) + TF(7) + TF(9) + TF(11)) = 4) Then st(6) = 1

    ' 7.  Either statement 2 or 3 is true, but not both.
    If ((TF(2) + TF(3)) = 1) Then st(7) = 1

    ' 8.  If statement 7 is true, then 5 and 6 are both true.
    If TF(7) Then
        If ((TF(5) + TF(6)) = 2) Then st(8) = 1
    Else '
        st(8) = 1 ' ??? this is like 4  which fixed things when I added else like here
    End If

    ' 9.  Exactly 3 of the first 6 statements are true.
    If ((TF(1) + TF(2) + TF(3) + TF(4) + TF(5) + TF(6)) = 3) Then st(9) = 1

    '10.  The next two statements are both true.
    If ((TF(11) + TF(12)) = 2) Then st(10) = 1

    '11.  Exactly 1 of statements 7, 8 and 9 are true.
    If ((TF(7) + TF(8) + TF(9)) = 1) Then st(11) = 1

    '12.  Exactly 4 of the preceding statements are true.
    If ((TF(1) + TF(2) + TF(3) + TF(4) + TF(5) + TF(6) + TF(7) + TF(8) + TF(9) + TF(10) + TF(11)) = 4) Then st(12) = 1

    wrong = 0
    For i = 1 To 12
        If st(i) <> TF(i) Then wrong = wrong + 1
    Next
    If wrong = 0 Then
        For i = 1 To 12
            Print i; TF(i); st(i)
        Next
        Print "This matches the Binary of"; n
        Print
        Print "zzz... press any to continue"
        Sleep
        Cls
    End If
Next
Print "End of Run."
'$End If

'' test sub Dec2BinArr12
'VVVVVVVV mass comment method
$If  Then
        ReDim out12(0) As Long, k As Long, j As Long
        'For k = 4095 - 20 To 4095 ' << check tail end
        For k = 0 To 20 ' << check from end
        Dec2BinArr12 k, out12()
        Print k,
        For j = 1 To 12
        Print out12(j);
        Next
        Print
        Next
$End If

Sub Dec2BinArr12 (dec As Long, out12() As Long)
    ReDim out12(1 To 12) As Long, j As Long
    For j = 0 To 11
        If (dec And 2 ^ j) > 0 Then out12(j + 1) = 1
    Next
End Sub

BTW the solution is number 1133 converted to Binary.

PS This is first time I used $IF for mass commenting out code, very handy. Thanks @Pete

[MasterGy]

Hi ! Bplus! You brought me a great puzzle for the evening!

I thought a lot about how it could be. I can't check back. Among the solutions is 1, which might be correct. I'm not sure.

Code: (Select All)

'1  3  4  6  7  11
Dim Shared ans(20)

For t = 0 To 4095: ' Locate 1, 1: Print t
    For t2 = 1 To 12
        ans(t2) = Sgn(t And 2 ^ (t2 - 1))
    Next t2

    add = 0: count = 0

    For t2 = 1 To 12
        add = add + Abs(ans(t2) = quest(t2))
        count = count + 1
    Next t2

    If add + 1 = count Then
        Print "find:  ";:
        For t3 = 1 To 12 Step 1
            If ans(t3) Then Print t3;
        Next t3
        Print
    End If
Next t

Function quest (which)
    Select Case which
        Case 1: ans = 1
        Case 2: add = 0: For t = 7 To 12: add = add + ans(t): Next t: ans = add = 3
        Case 3: add = 0: For t = 2 To 12 Step 2: add = add + ans(t): Next t: ans = add = 2
        Case 4: ans = ans(5) And ans(6) And ans(7)
        Case 5: ans = ans(2) = 0 And ans(3) = 0 And ans(4)
        Case 6: add = 0: For t = 1 To 11 Step 2: add = add + ans(t): Next t: ans = add = 4
        Case 7: ans = (ans(2) Or ans(3)) * ((ans(2) And ans(3)) = 0)
        Case 8: ans = ans(5) And ans(6) And ans(7)
        Case 9: add = 0: For t = 1 To 6: add = add + ans(t): Next t: ans = add = 3
        Case 10: ans = ans(11) And ans(12)
        Case 11: add = 0: For t = 7 To 9: add = add + ans(t): Next t: ans = add = 1
        Case 12: add = 0: For t = 1 To 11: add = add + ans(t): Next t: ans = add = 4
    End Select
    quest = Abs(Sgn(ans))
End Function

[bplus]

Hi MasterGy, 

Nice to see your approach to this, I will study later but looks like you need to narrow solutions down a bit more.
Probably have to change at least statement 4 and 8 handlers.
   

The good news, the solution is in that group!
I will also try your way for 4 and 8 and see what happens in my code. Thanks!

[bplus]

When I translated Twelve Statements to JB, I added near misses for extra RC credit. I also trimmed the fat and got it down to 35 LOC:

Code: (Select All)

_Title "12 Statements #2 Missing by 1" ' b+ 2022-10-31
Dim As Long i, saveI
For n = 0 To 4095 ' 2 ^ 12 = 4096 permutations of TF for 12 digits positions
    ReDim As Long st(12), TF(12) 'reset and get a TF scenario and compare to 12 statements
    For i = 0 To 11
        If n And 2 ^ i Then TF(i + 1) = 1
    Next
    st(1) = 1
    If ((TF(7) + TF(8) + TF(9) + TF(10) + TF(11) + TF(12)) = 3) Then st(2) = 1
    If ((TF(2) + TF(4) + TF(6) + TF(8) + TF(10) + TF(12)) = 2) Then st(3) = 1
    If TF(5) Then
        If ((TF(6) + TF(7)) = 2) Then st(4) = 1
    Else ' say true??
        st(4) = 1 ' to match solution at RC
    End If
    If ((TF(4) + TF(3) + TF(2)) = 0) Then st(5) = 1
    If ((TF(1) + TF(3) + TF(5) + TF(7) + TF(9) + TF(11)) = 4) Then st(6) = 1
    If ((TF(2) + TF(3)) = 1) Then st(7) = 1
    If TF(7) Then
        If ((TF(5) + TF(6)) = 2) Then st(8) = 1
    Else ' say true?
        st(8) = 1 ' ??? this is like 4  which fixed things when I added 1 = true here
    End If
    If ((TF(1) + TF(2) + TF(3) + TF(4) + TF(5) + TF(6)) = 3) Then st(9) = 1
    If ((TF(11) + TF(12)) = 2) Then st(10) = 1
    If ((TF(7) + TF(8) + TF(9)) = 1) Then st(11) = 1
    If ((TF(1) + TF(2) + TF(3) + TF(4) + TF(5) + TF(6) + TF(7) + TF(8) + TF(9) + TF(10) + TF(11)) = 4) Then st(12) = 1
    wrong = 0: s$ = ""
    For i = 1 To 12
        If st(i) <> TF(i) Then wrong = wrong + 1: saveI = i
        If TF(i) Then s$ = s$ + _Trim$(Str$(i)) + " " Else s$ = s$ + "_ "
    Next
    If wrong = 1 Then Print "Near miss, true at: "; s$; " missed at "; _Trim$(Str$(saveI))
    If wrong = 0 Then Print " Solution! true at: "; s$; " <<<<<<<<<<<<<"
Next