The program below doesn't work on rows 4 and 5, leaving that to be filled in by the human. The clues included in the programming narrow the solutions down to 19. Within the program colors red, white, blue, green are kept as 1, 2, 3, 4 respectively.
Dim bd(8, 8), col$, solCt, solCtPart
Dim ctCol(4, 8) ' colors r,w,b,g; columns
Private Sub cmdStart_Click()
col$ = ".rwbg"
' start with row 8
x$ = "1234": h$ = x$
Do
CurrentX = 1: CurrentY = 1: Print x$;
clr = Val(Mid(x$, 1, 1)): bd(8, 1) = clr: bd(8, 7) = clr: ctCol(clr, 1) = 1: ctCol(clr, 7) = 1
clr = Val(Mid(x$, 2, 1)): bd(8, 2) = clr: bd(8, 3) = clr: ctCol(clr, 2) = 1: ctCol(clr, 3) = 1
clr = Val(Mid(x$, 3, 1)): bd(8, 4) = clr: bd(8, 5) = clr: ctCol(clr, 4) = 1: ctCol(clr, 5) = 1
clr = Val(Mid(x$, 4, 1)): bd(8, 6) = clr: bd(8, 8) = clr: ctCol(clr, 6) = 1: ctCol(clr, 8) = 1
good = 1
If bd(8, 3) = 1 Then good = 0
If bd(8, 5) <> 3 Then good = 0
If bd(8, 6) <> 2 Then good = 0
If bd(8, 7) <> 1 And bd(8, 7) <> 4 Then good = 0
If good Then
placeRow7
End If
clr = Val(Mid(x$, 1, 1)): bd(8, 1) = clr: bd(8, 7) = clr: ctCol(clr, 1) = 0: ctCol(clr, 7) = 0
clr = Val(Mid(x$, 2, 1)): bd(8, 2) = clr: bd(8, 3) = clr: ctCol(clr, 2) = 0: ctCol(clr, 3) = 0
clr = Val(Mid(x$, 3, 1)): bd(8, 4) = clr: bd(8, 5) = clr: ctCol(clr, 4) = 0: ctCol(clr, 5) = 0
clr = Val(Mid(x$, 4, 1)): bd(8, 6) = clr: bd(8, 8) = clr: ctCol(clr, 6) = 0: ctCol(clr, 8) = 0
permute x$
Loop Until x$ = h$
Print solCt
End Sub
Sub placeRow7()
x$ = "1234": h$ = x$
Do
CurrentX = 1: CurrentY = 2: Print x$;
DoEvents
clr = Val(Mid(x$, 1, 1)): bd(7, 1) = clr: bd(7, 2) = clr: ctCol(clr, 1) = ctCol(clr, 1) + 1: ctCol(clr, 2) = ctCol(clr, 2) + 1
clr = Val(Mid(x$, 2, 1)): bd(7, 3) = clr: bd(7, 5) = clr: ctCol(clr, 3) = ctCol(clr, 3) + 1: ctCol(clr, 5) = ctCol(clr, 5) + 1
clr = Val(Mid(x$, 3, 1)): bd(7, 4) = clr: bd(7, 6) = clr: ctCol(clr, 4) = ctCol(clr, 4) + 1: ctCol(clr, 6) = ctCol(clr, 6) + 1
clr = Val(Mid(x$, 4, 1)): bd(7, 7) = clr: bd(7, 8) = clr: ctCol(clr, 7) = ctCol(clr, 7) + 1: ctCol(clr, 8) = ctCol(clr, 8) + 1
good = 1
If bd(7, 2) = 3 And bd(8, 2) = 3 Then good = 0
If bd(7, 5) = 3 And bd(8, 5) = 3 Then good = 0
If bd(7, 6) = 2 And bd(8, 6) = 2 Then good = 0
If bd(7, 6) = 1 And bd(8, 6) = 1 Then good = 0
If bd(7, 8) = 2 And bd(8, 8) = 2 Then good = 0
If bd(7, 8) = 4 And bd(8, 8) = 4 Then good = 0
If bd(7, 3) = 1 Then good = 0
If bd(7, 7) <> 1 And bd(7, 7) <> 4 Then good = 0
If good Then
placeRow6
End If
clr = Val(Mid(x$, 1, 1)): bd(7, 1) = clr: bd(7, 2) = clr: ctCol(clr, 1) = ctCol(clr, 1) - 1: ctCol(clr, 2) = ctCol(clr, 2) - 1
clr = Val(Mid(x$, 2, 1)): bd(7, 3) = clr: bd(7, 5) = clr: ctCol(clr, 3) = ctCol(clr, 3) - 1: ctCol(clr, 5) = ctCol(clr, 5) - 1
clr = Val(Mid(x$, 3, 1)): bd(7, 4) = clr: bd(7, 6) = clr: ctCol(clr, 4) = ctCol(clr, 4) - 1: ctCol(clr, 6) = ctCol(clr, 6) - 1
clr = Val(Mid(x$, 4, 1)): bd(7, 7) = clr: bd(7, 8) = clr: ctCol(clr, 7) = ctCol(clr, 7) - 1: ctCol(clr, 8) = ctCol(clr, 8) - 1
permute x$
Loop Until x$ = h$
End Sub
Sub placeRow6()
x$ = "1234": h$ = x$
Do
CurrentX = 1: CurrentY = 3: Print x$; solCtPart; solCt
DoEvents
clr = Val(Mid(x$, 1, 1)): bd(6, 1) = clr: bd(6, 6) = clr: ctCol(clr, 1) = ctCol(clr, 1) + 1: ctCol(clr, 6) = ctCol(clr, 6) + 1
clr = Val(Mid(x$, 2, 1)): bd(6, 2) = clr: bd(6, 8) = clr: ctCol(clr, 2) = ctCol(clr, 2) + 1: ctCol(clr, 8) = ctCol(clr, 8) + 1
clr = Val(Mid(x$, 3, 1)): bd(6, 3) = clr: bd(6, 4) = clr: ctCol(clr, 3) = ctCol(clr, 3) + 1: ctCol(clr, 4) = ctCol(clr, 4) + 1
clr = Val(Mid(x$, 4, 1)): bd(6, 5) = clr: bd(6, 7) = clr: ctCol(clr, 5) = ctCol(clr, 5) + 1: ctCol(clr, 7) = ctCol(clr, 7) + 1
good = 1
For colm = 1 To 8
For colr = 1 To 4
If ctCol(colr, colm) > 2 Then good = 0: Exit For
Next
Next
If bd(6, 2) = 3 And (bd(7, 2) = 3 Or bd(8, 2) = 3) Then good = 0
If bd(6, 3) = 1 Then good = 0
If bd(6, 5) = 3 Or bd(7, 5) = 3 Then good = 0
If bd(6, 6) = 2 Or bd(7, 6) = 2 Then good = 0
'If bd(6, 6) <> 1 And bd(8, 6) = 1 Then good = 0
If bd(6, 8) = 2 And (bd(7, 8) = 2 Or bd(8, 8) = 2) Then good = 0
'If bd(6, 8) <> 4 And bd(8, 8) = 4 Then good = 0
If bd(7, 2) <> 3 And bd(8, 2) <> 3 Then good = 0
If bd(7, 8) <> 2 And bd(8, 8) <> 2 Then good = 0
If bd(6, 8) = 4 And (bd(7, 8) = 4 Or bd(8, 8) = 4) Then good = 0
If bd(6, 7) <> 1 And bd(6, 7) <> 4 Then good = 0
If good Then
placeRow3
End If
clr = Val(Mid(x$, 1, 1)): bd(6, 1) = clr: bd(6, 6) = clr: ctCol(clr, 1) = ctCol(clr, 1) - 1: ctCol(clr, 6) = ctCol(clr, 6) - 1
clr = Val(Mid(x$, 2, 1)): bd(6, 2) = clr: bd(6, 8) = clr: ctCol(clr, 2) = ctCol(clr, 2) - 1: ctCol(clr, 8) = ctCol(clr, 8) - 1
clr = Val(Mid(x$, 3, 1)): bd(6, 3) = clr: bd(6, 4) = clr: ctCol(clr, 3) = ctCol(clr, 3) - 1: ctCol(clr, 4) = ctCol(clr, 4) - 1
clr = Val(Mid(x$, 4, 1)): bd(6, 5) = clr: bd(6, 7) = clr: ctCol(clr, 5) = ctCol(clr, 5) - 1: ctCol(clr, 7) = ctCol(clr, 7) - 1
permute x$
Loop Until x$ = h$
End Sub
Sub placeRow3()
x$ = "1122344": h$ = x$
Do
DoEvents
colm = 1
For i = 1 To 7
bd(3, colm) = Val(Mid(x$, i, 1))
ctCol(Val(Mid(x$, i, 1)), colm) = ctCol(Val(Mid(x$, i, 1)), colm) + 1
If bd(3, colm) = 3 Then
colm = colm + 1: bd(3, colm) = 3
ctCol(Val(Mid(x$, i, 1)), colm) = ctCol(Val(Mid(x$, i, 1)), colm) + 1
End If
colm = colm + 1
Next
good = 1
For colm = 1 To 8
For colr = 1 To 4
If ctCol(colr, colm) > 2 Then good = 0: Exit For
Next
Next
If bd(3, 2) = 3 Then good = 0
If bd(3, 5) = 3 Then good = 0
If bd(3, 6) = 2 Then good = 0
If bd(3, 7) = 1 Or bd(3, 7) = 4 Then good = 0
If bd(3, 6) = 1 And bd(6, 6) <> 1 Or bd(3, 6) <> 1 And bd(6, 6) = 1 Then good = 0
If bd(3, 8) = 4 And bd(6, 8) <> 4 Or bd(3, 8) <> 4 And bd(6, 8) = 4 Then good = 0
If good Then
placeRow1
End If
colm = 1
For i = 1 To 7
ctCol(Val(Mid(x$, i, 1)), colm) = ctCol(Val(Mid(x$, i, 1)), colm) - 1
If bd(3, colm) = 3 Then
colm = colm + 1
ctCol(Val(Mid(x$, i, 1)), colm) = ctCol(Val(Mid(x$, i, 1)), colm) - 1
End If
colm = colm + 1
Next
permute x$
Loop Until x$ = h$
End Sub
Sub placeRow1()
x$ = "112244": h$ = x$
Do
colm = 1
For i = 1 To 6
bd(1, colm) = Val(Mid(x$, i, 1))
ctCol(Val(Mid(x$, i, 1)), colm) = ctCol(Val(Mid(x$, i, 1)), colm) + 1
If bd(1, colm) = 4 Then
colm = colm + 1: bd(1, colm) = 3
ctCol(3, colm) = ctCol(3, colm) + 1
End If
colm = colm + 1
Next
good = 1
For colm = 1 To 8
For colr = 1 To 4
If ctCol(colr, colm) > 2 Then good = 0: Exit For
Next
If good = 0 Then Exit For
Next
If bd(1, 2) = 3 And bd(7, 2) <> 3 Or bd(1, 2) <> 3 And bd(7, 2) = 3 Then good = 0
If bd(1, 5) = 3 And bd(8, 5) <> 3 Or bd(1, 5) <> 3 And bd(8, 5) = 3 Then good = 0
If bd(1, 6) = 2 And bd(8, 6) <> 2 Or bd(1, 6) <> 2 And bd(8, 6) = 2 Then good = 0
'If bd(1, 6) = 1 And bd(3, 6) <> 1 Then good = 0
'If bd(3, 6) = 1 And bd(1, 6) <> 1 And bd(5, 6) <> 1 Then good = 0
If bd(1, 7) = 1 Or bd(1, 7) = 4 Then good = 0
If bd(1, 8) = 2 And bd(7, 8) <> 2 Or bd(1, 8) <> 2 And bd(7, 8) = 2 Then good = 0
'If bd(1, 8) = 4 And bd(3, 8) <> 4 Then good = 0
If good Then
placeRow2
End If
colm = 1
For i = 1 To 6
bd(1, colm) = Val(Mid(x$, i, 1))
ctCol(Val(Mid(x$, i, 1)), colm) = ctCol(Val(Mid(x$, i, 1)), colm) - 1
If bd(1, colm) = 4 Then
colm = colm + 1: bd(1, colm) = 3
ctCol(3, colm) = ctCol(3, colm) - 1
End If
colm = colm + 1
Next
permute x$
Loop Until x$ = h$
End Sub
Sub placeRow2()
x$ = "11223344": h$ = x$
Do
colm = 1
For i = 1 To 8
bd(2, colm) = Val(Mid(x$, i, 1))
ctCol(Val(Mid(x$, i, 1)), colm) = ctCol(Val(Mid(x$, i, 1)), colm) + 1
colm = colm + 1
Next
good = 1
For colm = 1 To 8
For colr = 1 To 4
If ctCol(colr, colm) > 2 Then good = 0: Exit For
Next
If good = 0 Then Exit For
Next
If InStr(x$, "3") < 5 Then good = 0
If InStr(Mid(x$, 5), "1") > 0 Then good = 0
If bd(2, 2) = 3 And bd(8, 2) <> 3 Or bd(2, 2) <> 3 And bd(8, 2) = 3 Then good = 0
If bd(2, 5) = 3 Then good = 0
If bd(2, 6) = 2 Then good = 0
If bd(8, 8) = 2 And bd(2, 8) <> 2 Then good = 0
'If bd(2, 6) = 1 And bd(4, 6) <> 1 Then good = 0
'If bd(4, 6) = 1 And bd(2, 6) <> 1 And bd(6, 6) <> 1 Then good = 0
If bd(2, 7) = 1 Or bd(2, 7) = 4 Then good = 0
If bd(2, 8) = 2 And bd(8, 8) <> 2 Or bd(2, 8) <> 2 And bd(8, 8) = 2 Then good = 0
'If bd(2, 8) = 4 And bd(4, 8) <> 4 Then good = 0
If bd(2, 8) = 2 And (bd(1, 8) = 2 Or bd(3, 8) = 2) Then good = 0
If bd(1, 8) <> 4 And bd(2, 8) <> 4 And bd(3, 8) <> 4 And bd(6, 8) <> 4 And bd(7, 8) <> 4 And bd(8, 8) <> 4 Then good = 0
'If bd(1, 6) <> 1 And bd(3, 6) <> 1 And bd(3, 6) <> 1 And bd(6, 6) <> 1 And bd(7, 6) <> 1 And bd(8, 6) <> 1 Then good = 0
If good Then
ReDim ctc(4)
For i = 1 To 8
ctc(bd(i, i)) = ctc(bd(i, i)) + 1
If bd(i, i) > 0 And ctc(bd(i, i)) > 2 Then
good = 0: Exit For
End If
Next
ReDim ctc(4)
For i = 1 To 8
ctc(bd(i, 9 - i)) = ctc(bd(i, 9 - i)) + 1
If bd(i, 9 - i) > 0 And ctc(bd(i, 9 - i)) > 2 Then
good = 0: Exit For
End If
Next
If good Then
Open "Red White Blue Green alt.txt" For Append As #2
For r = 1 To 8
For c = 1 To 8
Print #2, Mid(col$, bd(r, c) + 1, 1);
Next
Print #2,
Next
Print #2,
Close 2
solCt = solCt + 1
End If
solCtPart = solCtPart + 1
End If
colm = 1
For i = 1 To 8
ctCol(Val(Mid(x$, i, 1)), colm) = ctCol(Val(Mid(x$, i, 1)), colm) - 1
colm = colm + 1
Next
permute x$
Loop Until x$ = h$
End Sub
Sub permute(a$)
x$ = ""
For i = Len(a$) To 1 Step -1
l$ = x$
x$ = Mid$(a$, i, 1)
If x$ < l$ Then Exit For
Next
If i = 0 Then
For j = 1 To Len(a$) \ 2
x$ = Mid$(a$, j, 1)
Mid$(a$, j, 1) = Mid$(a$, Len(a$) - j + 1, 1)
Mid$(a$, Len(a$) - j + 1, 1) = x$
Next
Else
For j = Len(a$) To i + 1 Step -1
If Mid$(a$, j, 1) > x$ Then Exit For
Next
Mid$(a$, i, 1) = Mid$(a$, j, 1)
Mid$(a$, j, 1) = x$
For j = 1 To (Len(a$) - i) \ 2
x$ = Mid$(a$, i + j, 1)
Mid$(a$, i + j, 1) = Mid$(a$, Len(a$) - j + 1, 1)
Mid$(a$, Len(a$) - j + 1, 1) = x$
Next
End If
End Sub
The potential solutions identified by the program:
gbrgbwwr gbrgbwwr gbrgbwwr gbrgbwwr
grgrwbbw rrgwgbbw rrggwbbw rrgwgbbw
rwrwggbb wwrgrgbb wgrwrgbb gwrrwgbb
........ ........ ........ ........
........ ........ ........ ........
brwwgbgr brwwgbgr brwwgbgr brwwgbgr
bbwrwrgg bbwrwrgg bbwrwrgg bbwrwrgg
rggbbwrw rggbbwrw rggbbwrw rggbbwrw
gbrgbwwr gbrgbwwr gbrgbwwr gbrgbwwr
wrgrgbbw rwgrgbbw rwgrgbbw rrggwbbw
rwrgwgbb wwrgrgbb wgrwrgbb gwrwrgbb
........ ........ ........ ........
........ ........ ........ ........
brwwgbgr brwwgbgr brwwgbgr brwwgbgr
bbwrwrgg bbwrwrgg bbwrwrgg bbwrwrgg
rggbbwrw rggbbwrw rggbbwrw rggbbwrw
gbrgbwwr gbrgbwwr gbrgbwwr gbrgbwwr
wrgrgbbw wrgrgbbw wrgrgbbw rwgrgbbw
rgrwwgbb wwrgrgbb wgrwrgbb gwrwrgbb
........ ........ ........ ........
........ ........ ........ ........
brwwgbgr brwwgbgr brwwgbgr brwwgbgr
bbwrwrgg bbwrwrgg bbwrwrgg bbwrwrgg
rggbbwrw rggbbwrw rggbbwrw rggbbwrw
gbrgbwwr gbrgbwwr gbrgbwwr gbrgbwwr
rwgrgbbw grgrwbbw grgrwbbw wrgrgbbw
wrrgwgbb wwrgrgbb wgrwrgbb gwrwrgbb
........ ........ ........ ........
........ ........ ........ ........
brwwgbgr brwwgbgr brwwgbgr brwwgbgr
bbwrwrgg bbwrwrgg bbwrwrgg bbwrwrgg
rggbbwrw rggbbwrw rggbbwrw rggbbwrw
gbrgbwwr gbrgbwwr gbrgbwwr
rrggwbbw rrgwgbbw rwgrgbbw
wwrrggbb wgrrwgbb grrwwgbb
........ ........ ........
........ ........ ........
brwwgbgr brwwgbgr brwwgbgr
bbwrwrgg bbwrwrgg bbwrwrgg
rggbbwrw rggbbwrw rggbbwrw
The bolded template is the only one that can be worked into a full solution:
gbrgbwwr
rwgrgbbw
wgrwrgbb
grbbwrwg
wwbgrgrb
brwwgbgr
bbwrwrgg
rggbbwrw
|
|
Posted by Charlie
on 2008-01-14 18:59:19 |
computer/human collaboration
