Pete (2021)

Go to Adv of Code page on Pete's site: https://tryonhayes.com/about-me/advent-of-code/


Day 3 Worksheet:   (Partial)     (Binary Diagnostics)

Pete Day3 Data
# A B C D E
1 011110011110        
2 101101001111   101010000101   CO2 scrubber rating
3 000000010101   2693    
4 100111001010   000111111101   oxygen generator rating
5 110000011010   509    
6 011101010101        
7 011110001100   1370737   life support rating
8 010111111001        
9 111011100101        

Day 3 Code:

Reformat Code
# Day3 Code
1 Sub Button1_Click()
2 Dim n, i As Integer
3 Dim nOne, nZero, j As Integer
4 Dim nCount As Integer
5 Dim twoRuns As Integer
6 Dim testDigit As Integer
7
8
9 n = 1
10 Do While Cells(n, 1) <> "" ' count the number of original data values
11 .... n = n + 1
12 Loop
13 n = n - 1
14
15 For twoRuns = 1 To -1 Step -2
16 ....
17 .... copyColumn
18 ....
19 .... For j = 1 To 12 'for every position, sort and throw out values
20 ........ nOne = 0
21 ........ nZero = 0
22 ........ For i = 1 To n 'count the occurence of 1 and 0 in a given column
23 ............. If Cells(i, 2) <> "" Then
24 ................ If Mid(Cells(i, 2), j, 1) = "1" Then
25 .................... nOne = nOne + 1
26 ................ Else
27 .................... nZero = nZero + 1
28 ................ End If
29 ............ End If
30 ........ Next i
31 .........
32 ....... If nOne * twoRuns + twoRuns > nZero * twoRuns Then 'if equal, put a 1 in the place
33 ......... 'twoRuns adds 1 to the '1' count, meaning it doesn't need the = case
34 ......... 'it flips it to negative for the '0' count
35 .......... testDigit = 1
36 ........ Else
37 ........... testDigit = 0
38 ....... End If
39 .........
40 ......... For i = 1 To n 'check the digit and copy only the selected ones to the next column
41 ............ If Cells(i, 2) <> "" Then
42 ................ If Val(Mid(Cells(i, 2), j, 1)) = testDigit Then
43 .................... Cells(3 + twoRuns, 3) = Cells(i, 2)
44 ................ Else
45 .................... Cells(i, 2) = ""
46 ................ End If
47 ............ End If
48 ........ Next i
49 ....
50 .... Next j
51
52 .... Cells(4 + twoRuns, 3) = convertBinary(Cells(3 + twoRuns, 3))
53 ....
54 Next twoRuns
55
56 Cells(7, 3) = Cells(3, 3) * Cells(5, 3)
57
58 End Sub
59
60
61
62 Function convertBinary(binNumb As String)
63
64 Dim i As Integer
65 Dim temp As Integer
66
67 temp = 0
68 For i = 1 To Len(binNumb)
69 .... temp = temp + Val(Mid(binNumb, i, 1)) * 2 ^ (Len(binNumb) - i)
70 Next i
71
72 .... convertBinary = temp
73 ....
74 End Function
75
76 Sub copyColumn()
77 '
78 .... Columns("A:A").Select
79 .... Selection.Copy
80 .... Range("B1").Select
81 .... ActiveSheet.Paste
82 .... Range("C3").Select
83 End Sub

Day 4 Worksheet:   (Partial)     (Bingo)

Pete Day4 Data
# A B ... K L M N O P Q
1 93,35,66,15,6, ... 93                
2   35   Every Square            
3 14 33 79 61 44 66   74 -1 -1 -1 -1 70  
4 85 60 38 13 48 15   -1 -1 -1 76 88 161  
5 51 34 11 19 7 6   89 -1 -1 69 -1 155  
6 21 30 73 6 76 51   20 -1 3 0 -1 21  
7 41 4 65 18 91 49   -1 -1 -1 -1 24 20  
8   67   181 -5 -1 143 109 427 Sum of grid
9 3 82 68 26 93 16             16 Count of '-1'
10 61 90 29 69 92 77             443 Sum of bingo grid
11 60 94 99 6 83 80                
12 77 80 2 58 55 8   Worst       Best    
13 59 65 95 38 62 1   88 Number of called numbers     30    
14   57   22 ID # of Square     94    
15 41 9 73 71 74 99   87 Last number called     39    
16 66 24 45 5 55 92   36975 Score     27027    
17 97 82 53 63 16 14   Best Square            
18 12 19 88 87 27 9   29 26 19 -1 -1 72  
19 31 8 75 98 83 13   12 88 -1 42 -1 140  
20   23   95 63 78 21 53 310  
21 63 24 86 90 45 33   -1 -1 -1 -1 -1 -5  
22 41 92 42 83 77 11   10 46 24 87 -1 166  
23 64 28 54 94 10 43   145 222 119 148 49 683 Sum of grid
24 15 93 57 29 50 50             10 Count of '-1'
25 23 39 37 48 38 60             693 Sum of bingo grid
26   96                
27 1 31 7 0 54 40   Worst Square            
28 9 59 79 19 96 25   -1 -1 -1 -1 -1 -5  
29 51 14 77 38 45 22   20 54 -1 -1 -1 71  
30 30 76 42 65 91 39   84 64 -1 -1 -1 145  
31 72 60 37 43 71 56   -1 -1 76 -1 45 118  
32   18   -1 -1 -1 -1 82 78  
33 22 81 40 97 27 2   101 115 72 -5 124 407 Sum of grid
34 83 28 41 1 76 7             18 Count of '-1'
35 69 68 64 57 78 34             425 Sum of bingo grid
36 59 38 63 89 29 68                
37 8 58 18 66 72 26                

Day 4 Code:

Reformat Code
# Day4 Code
1 Sub playBingo()
2 .... Dim i, pos As Integer
3 .... Dim dataString As String
4 .... Dim j As Integer
5 .... Dim k As Integer
6 .... Dim done As Boolean
7 .... Dim nPlays As Integer
8 .... Dim nCard, lastNumber As Integer
9 .... Dim nPossiblePlays As Integer
10 ....
11 .... Cells(13, 15) = 1000
12 .... Cells(13, 11) = 0
13 .... 'parse string of bingo numbers and put into column B, count number of possible plays
14 .... nPossiblePlays = 1
15 .... dataString = Cells(1, 1)
16 .... Do While Len(dataString) > 0
17 ........ pos = InStr(dataString, ",")
18 ........ If pos > 0 Then
19 ............ Cells(nPossiblePlays, 2) = Val(Left(dataString, pos - 1))
20 ............ dataString = Mid(dataString, pos + 1, 1000)
21 ............ nPossiblePlays = nPossiblePlays + 1
22 ........ Else
23 ............ Cells(nPossiblePlays, 2) = Val(dataString)
24 ............ dataString = ""
25 ........ End If
26 .... Loop
27 ....
28
29 .... nCard = 1
30 .... Do While Cells(nCard * 6 - 3, 1) <> "" 'look at every card in the input data and decide how many plays it takes to win
31 ........
32 ....... 'copy bingo card from input list of data to cell(3,12)
33 ........ For j = 1 To 5
34 ............. For i = 1 To 5
35 ................ Cells(j + 2, i + 10) = Val(Mid(Cells(nCard * 6 - 4 + j, 1), (i - 1) * 3 + 1, 3))
36 ............ Next i
37 ........ Next j
38
39 .... 'go through all numbers until Bingo is reached
40 .... nPlays = 0
41 .... done = False
42 .... For k = 1 To nPossiblePlays
43 ........ pos = Cells(k, 2)
44 ....
45 ........ For i = 11 To 15
46 ............ For j = 3 To 7
47 ................ If Cells(j, i) = pos And Not done Then
48 .................... Cells(j, i) = -1
49 ................ End If
50 ................ If Cells(j, 16) = -5 Or Cells(8, i) = -5 Then
51 .................... done = True
52 .................... If nPlays = 0 Then
53 ........................ nPlays = k
54 ........................ lastNumber = pos
55 .................... End If
56 ................ End If
57 ............ Next j
58 ........ Next i
59 .... Next k
60 ...
61 .... If nPlays < Cells(13, 15) Then 'fill in final data for best card
62 ........ Cells(13, 15) = nPlays
63 ........ Cells(14, 15) = nCard
64 ........ Cells(15, 15) = lastNumber
65 ........ Call copyCard
66 .... End If
67 ....
68 .... If nPlays > Cells(13, 11) Then 'fill in final data for worst card
69 ........ Cells(13, 11) = nPlays
70 ........ Cells(14, 11) = nCard
71 ........ Cells(15, 11) = lastNumber
72 ........ Call copyLosingCard
73 .... End If
74
75 .... nCard = nCard + 1
76 .... Loop
77 ....
78 End Sub
79
80
81
82 Sub copyCard() 'winning
83 '
84 .... Range("K3:P10").Select
85 .... Selection.Copy
86 .... Range("K18").Select
87 .... ActiveSheet.Paste
88 .... Range("K12").Select
89 End Sub
90
91 Sub copyLosingCard()
92 '
93 .... Range("K3:P10").Select
94 .... Selection.Copy
95 .... Range("K28").Select
96 .... ActiveSheet.Paste
97 .... Range("K12").Select
98 End Sub

Day 5 Solution:     (Hydrothermal Vents)

Day 5 Code:

Reformat Code
# Day5 Code
1 Sub parseData()
2 ... Dim i As Integer
3 ... Dim pos, pos2, pos3 As Integer
4 ...
5 i = 2
6 Do While Cells(i, 1) <> ""
7 ...
8 .... pos = InStr(Cells(i, 1), ",")
9 .... Cells(i, 2) = Val(Left(Cells(i, 1), pos - 1))
10 .... pos2 = InStr(Cells(i, 1), "->")
11 .... Cells(i, 3) = Val(Mid(Cells(i, 1), pos + 1, pos2 - pos))
12 .... pos3 = InStr(pos + 1, Cells(i, 1), ",")
13 ..... Cells(i, 4) = Val(Mid(Cells(i, 1), pos2 + 2, pos3 - pos2))
14 ..... Cells(i, 5) = Val(Mid(Cells(i, 1), pos3 + 1, 20))
15 ..... If Cells(i, 2) = Cells(i, 4) Then 'it's vertical
16 ........ Cells(i, 6) = 999
17 ........ If Cells(i, 3) > Cells(i, 5) Then
18 ............ Cells(i, 7) = -1 'y1 is greater than y2
19 ........ Else
20 ............ Cells(i, 7) = 1
21 ........ End If
22 .... ElseIf Cells(i, 3) = Cells(i, 5) Then ' it's horizontal
23 ........ Cells(i, 6) = 0
24 ........ If Cells(i, 2) > Cells(i, 4) Then
25 ............ Cells(i, 7) = -1
26 ........ Else
27 ............ Cells(i, 7) = 1
28 ........ End If
29 .... Else 'it's a diagonal
30 ........ Cells(i, 6) = (Cells(i, 5) - Cells(i, 3)) / (Cells(i, 4) - Cells(i, 2)) 'calculate slope
31 ........ If Cells(i, 2) > Cells(i, 4) Then
32 ............ Cells(i, 7) = -1
33 ........ Else
34 ............ Cells(i, 7) = 1
35 ........ End If
36 .... End If
37 ....
38 .... i = i + 1
39 ...
40 Loop
41 ...
42 ... Cells(3, 9) = i - 2 'saves counted number of transects
43 ...
44 End Sub
45
46 Sub millionPoints()
47
48 Dim n, i As Integer
49 Dim j As Integer
50 Dim stepCode As Integer
51 Dim x, y As Integer
52 Dim slope, direction As Integer
53 Dim p(1000, 1000) As Integer
54 Dim pCount As Integer
55 Dim includeDiagonals As Boolean
56 Dim includeGraphics As Boolean
57
58
59 n = Cells(3, 9)
60 pCount = 0
61 includeDiagonals = (LCase(Left(Cells(8, 9), 1)) = "y")
62 includeGraphics = (LCase(Left(Cells(7, 9), 1)) = "y")
63
64 ... If includeGraphics Then 'draw 1000x1000 box
65 ........ Application.CommandBars("Drawing").Visible = True
66 ......... ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1001, 1001).Select
67 ......... Selection.ShapeRange.Fill.ForeColor.SchemeColor = 43
68 ......... Selection.ShapeRange.Fill.Visible = msoTrue
69 .... End If
70
71 .. For i = 2 To n + 1
72 ........ slope = Cells(i, 6)
73 ........ direction = Cells(i, 7)
74
75 ........ If slope = 0 Then
76 ............ If includeGraphics Then
77 ................ ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 5)).Select
78 ............ End If
79 ............ For j = Cells(i, 3 - direction) To Cells(i, 3 + direction)
80 ............... If p(j, Cells(i, 3)) = 1 Then 'if there is one previous occurence, flag this as an intersection
81 .................... pCount = pCount + 1
82 .................... If includeGraphics Then ActiveSheet.Shapes.AddShape(msoShapeOval, j, Cells(i, 3), 1, 1).Select
83 ............... End If
84 ............... p(j, Cells(i, 3)) = p(j, Cells(i, 3)) + 1
85 ............ Next j
86 ........ End If
87 ........
88 ........ If slope = 999 Then
89 ............... If includeGraphics Then
90 .................... ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 5)).Select
91 ................ End If
92 ............ For j = Cells(i, 4 - direction) To Cells(i, 4 + direction)
93 ................ If p(Cells(i, 2), j) = 1 Then
94 ..................... pCount = pCount + 1
95 .................... If includeGraphics Then ActiveSheet.Shapes.AddShape(msoShapeOval, Cells(i, 2), j, 1, 1).Select
96 ................ End If
97 ................ p(Cells(i, 2), j) = p(Cells(i, 2), j) + 1
98 ............ Next j
99 ........ End If
100
101 ........ If includeDiagonals Then
102 ............ If slope = 1 Or slope = -1 Then
103 ................ If includeGraphics Then
104 .................... ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 5)).Select
105 ................ End If
106 ................ For j = Cells(i, 3 - direction) To Cells(i, 3 + direction)
107 .................... x = j
108 .................... y = Cells(i, 4 - direction) + slope * (x - Cells(i, 3 - direction))
109 ................... If p(x, y) = 1 Then
110 ........................ pCount = pCount + 1
111 ........................ If includeGraphics Then ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, 1, 1).Select
112 ................... End If
113 ................... p(x, y) = p(x, y) + 1
114 ................ Next j
115 ............ End If
116 ........ End If
117 ........
118 .... Next i
119 .................................
120 ... If includeDiagonals Then
121 ........ Cells(5, 9) = pCount
122 .... Else
123 ........ Cells(4, 9) = pCount
124 .... End If
125
126 End Sub
127
128
129 Sub noGraphics()
130 .... Sheets("graphics").Cells(7, 9) = "No"
131 End Sub
132
133 Sub GraphicsIncluded()
134 .... Sheets("graphics").Cells(7, 9) = "Yes"
135 End Sub
136
137 Sub noDiagonals()
138 .... Sheets("graphics").Cells(8, 9) = "No"
139 End Sub
140
141 Sub DiagonalsIncluded()
142 .... Sheets("graphics").Cells(8, 9) = "Yes"
143 End Sub

Day 6 Worksheet:   (Partial)     (Lanternfish Population Growth)

Pete Day6 Data
# A B C D E F G H I J K L
1 Data-> 1,5,5,1...                    
2                        
3                        
4                        
5   Age -> 0 1 2 3 4 5 6 7 8  
6   Test Data ->   1 1 2 1          
7   Initial Count -> 0 79 42 52 56 71 0 0 0  
8                       Total
9 Parsed Day Number                   Fish Count
10 Data 0   79 42 52 56 71       300
11 1 1 79
(=D10)		 42
(=E10)		 52
(=F10)		 56
(=G10)		 71
(=H10)		 0
(=I10)		 0
(=J10+C10)		 0
(=K10)		 0
(=C10)		 300
12 5 2 42 52 56 71 0 0 79 0 79 379
13 5 3 52 56 71 0 0 79 42 79 42 421
14 1 4 56 71 0 0 79 42 131 42 52 473
15 5 5 71 0 0 79 42 131 98 52 56 529
16 1 6 0 0 79 42 131 98 123 56 71 600
17 5 7 0 79 42 131 98 123 56 71 0 600
18 3 8 79 42 131 98 123 56 71 0 0 600
19 1 9 42 131 98 123 56 71 79 0 79 679
20 3 10 131 98 123 56 71 79 42 79 42 721

Day 6 Code:

Sub readData()

Dim fileName As String

Dim textLine As String

Dim i As Integer

.... i = 1

.... fileName = Application.GetOpenFilename

.... Open fileName For Input As #1

.... Do Until EOF(1)

........ Line Input #1, textLine

........ Cells(i, 2) = textLine

........ i = i + 1

.... Loop

.... Close #1

End Sub

Sub parseData()

.... Dim i As Integer

.... Dim tempStr As String

.... Dim pos As Integer

....

.... i = 1

.... tempStr = Cells(1, 2)

....

.... Do While Len(tempStr) > 0

........ pos = InStr(tempStr, ",")

........ If pos > 0 Then

............ Cells(i + 10, 1) = Val(Left(tempStr, pos - 1))

............ tempStr = Mid(tempStr, pos + 1, 1000)

............ i = i + 1

........ Else

............ Cells(i + 10, 1) = Val(tempStr)

............ tempStr = ""

........ End If

.... Loop

End Sub


Day 7 Worksheet:   (Partial)     (Fuel Consumption)

Pete Day7 Data
# A (1) D (4) E (5) F (6) G (7) H (8) I (9) J (10) K (11) L (12) M (13) N (14) O (15) P (16) Q (17) R (18) S (19) T (20) U (21) V (22) W (23) X (24) Y (25) Z (26)
1 1101                                              
2 1                                              
3 29                                              
4 67                                              
5 1102 Minimum 0 97 207 289 330 361 396 422 435 449 456 464 468 472 475 477 478 479 479 479 479 479
6 0 Maximum 1958 1567 1310 1117 952 828 747 686 633 599 569 549 532 521 513 507 501 497 494 492 490 489
7 1 N of points 1000                                          
8 65 Cost 93397632                                          
9 1008     Meetup
Coordinate		 Cost                                      
10 65   0 479 93412261                                      
11 35   1 480 93407334                                      
12 66   2 481 93403408                                      
13 1005   3 482 93400482                                      
14 66   4 483 93398557                                      
15 28   5 484 93397632                                      
16 1   6 485 93397707                                      
17 67   7 486 93398783                                      
18 65   8 487 93400859                                      
19 20   9 488 93403936                                      
20 4   10 489 93408013                                      
21 0                                              
22 1001     341534 answer part A                                      
23 65     93397632 answer part B                                      
24 1                                              
25 65                                              

Day 7 Code:

Dim Part_B As Boolean

Sub PartA()

.... Part_B = False

End Sub

Sub PartB()

.... Part_B = True

End Sub

Sub readData()

Dim fileName As String

Dim textLine As String

Dim i As Integer

.... i = 1

.... fileName = Application.GetOpenFilename

.... Open fileName For Input As #1

.... Do Until EOF(1)

........ Line Input #1, textLine

........ Cells(i, 2) = textLine

........ i = i + 1

.... Loop

.... Close #1

End Sub

Sub parseData()

.... Dim i As Integer

.... Dim tempStr As String

.... Dim pos As Integer

.... Dim maxLength As Integer

.... Dim minN, maxN As Integer

.... Dim n As Integer

....

.... i = 0

.... minN = 10000

.... maxN = 0

....

.... tempStr = Cells(1, 2)

.... maxLength = Len(tempStr)

....

.... Do While Len(tempStr) > 0

........ pos = InStr(tempStr, ",")

........ i = i + 1

........ If pos > 0 Then

............ n = Val(Left(tempStr, pos - 1))

............ tempStr = Mid(tempStr, pos + 1, maxLength)

........ Else

............ n = Val(tempStr)

............ tempStr = ""

........ End If

........ Cells(i, 1) = n

........ If n < minN Then minN = n

........ If n > maxN Then maxN = n

.... Loop

.... Cells(5, 5) = minN

.... Cells(6, 5) = maxN

.... Cells(7, 5) = i

....

End Sub

Sub graphIt()

Dim i As Integer

Dim meetpt As Integer

Dim c As Integer

Dim mn, mx As Long

Dim minCost As Long

Dim matchMeetPt As Integer

Dim sum As Long

Dim trial As Integer

Dim done As Boolean

Dim distance As Long

Dim cost As Long

mn = Cells(5, 5)

mx = Cells(6, 5)

minCost = 999999999 ' Cells(7, 5) * mx 'number of points * maximum distance

done = False

trial = 1

Do While Not done

.... For c = 0 To 10 'graph (cost vs coordinate on line) 11 points spread through the data set.

........ sum = 0

........ meetpt = mn + Int((mx - mn) * c / 10) 'Cells(8, 5)

........

........ For i = 1 To Cells(7, 5) 'calculate the cost, checking each of all 1000 points

............ distance = Abs(meetpt - Cells(i, 1))

............ If Part_B Then

................ cost = distance * (distance + 1) / 2

............ Else

................ cost = distance

............ End If

............ sum = sum + cost

........ Next i

........

........ 'place calculated values into data grid

........ Cells(8, 5) = minCost

........ Cells(c + 10, 6) = meetpt 'meetup point

........ Cells(c + 10, 7) = sum 'calculated cost

........ If sum < minCost Then 'keep track of whether it is the minimum value

............ minCost = sum

............ matchMeetPt = meetpt

........ End If

........

.... Next c

....

.... 'Narrow the block of data to be examined (set new minimum and maximum

.... If mx - mn < 11 Then

........ done = True

.... Else

........ If matchMeetPt - mn <= 5 Then

............ 'don't change, you're close

........ Else

............ mn = mn + Int((matchMeetPt - mn) / 4)

........ End If

........ If mx - matchMeetPt <= 5 Then

............ 'don't change, you're close

........ Else

............ mx = mx - Int((mx - matchMeetPt) / 4)

........ End If

........ If mx - mn < 10 Then

............ mx = mn + 10 'force 11 sequential points

........ End If

........ Cells(5, 5 + trial) = mn

........ Cells(6, 5 + trial) = mx

........ trial = trial + 1

.... End If

.... Call ChangeCharts 'refreshes the graph

....

Loop 'go back to try a new set of 11 points

Cells(8, 10) = ""

End Sub

Sub calculateSums()

Dim i As Integer

Dim n As Integer

Dim sum As Long

n = Cells(7, 5)

Cells(1, 4) = 1

For i = 2 To n

.... Cells(i, 4) = Cells(i - 1, 4) + i

Next i

End Sub

Sub ChangeCharts() 'forces a refresh of the graph. Taken from https://stackoverflow.com/questions/28582897/refresh-all-charts-without-blinking

Application.ScreenUpdating = False 'This line disable the on screen update for better performance, the blink you see, you could delete both lanes but it will run slower

Dim myChart As ChartObject

For Each myChart In ActiveSheet.ChartObjects

.... myChart.Chart.Refresh

Next myChart

Application.ScreenUpdating = True 'This line reenable the on screen update for better performance, the blink you see, you could delete both lanes but it will run slower

Dim i As Long 'slows the process down so one can see the graph

For i = 1 To 100

.... Cells(8, 10) = "slow down..."

Next i

End Sub


Day 8 Worksheet:     (Partial)     (Decoding Digital Display Output)

Day 8 Data
# A B C D E F G H I J K L M N O P Q R X Y Z AA AB AC AD AE AF AG AH AI AJ AK AL
1   bgeacd dbfag bcadegf agdce dgfbce bgc bdgca aedcgf bc abec | gcdfbe cbea bc gbc   bgeacd dbfag bcadegf agdce dgfbce bgc bdgca aedcgf bc abec gcdfbe cbea bc gbc   y069y x235x 8 x235x y069y 7 x235x y069y 1 4 0 4 1 7 417
2   bdeag gdbaec cd dgc abcfg ebcd dgfabe cdfeag cgadb bdagfce | becd acfgde bgcaed eadgbc   bdeag gdbaec cd dgc abcfg ebcd dgfabe cdfeag cgadb bdagfce becd acfgde bgcaed eadgbc   x235x y069y 1 7 x235x 4 y069y y069y x235x 8 4 0 9 9 4099
3 Number of data lines acbfg bcf ebacg fb fcbgea cbdfge cgeabd agcfd aebf bdaefgc | fbcdeg cfb ebgca bf   acbfg bcf ebacg fb fcbgea cbdfge cgeabd agcfd aebf bdaefgc fbcdeg cfb ebgca bf   x235x 7 x235x 1 y069y y069y y069y x235x 4 8 0 7 5 1 751
4 200 bfcde dfgb gecbdf fdc fdcega fd ebdca gfcaedb gcfbe cbagef | dbfec gbfd bcdfe dfc   bfcde dfgb gecbdf fdc fdcega fd ebdca gfcaedb gcfbe cbagef dbfec gbfd bcdfe dfc   x235x 4 y069y 7 y069y 1 x235x 8 x235x y069y 3 4 3 7 3437
5   dbgeaf bad acdfbe ab agbdf bgcdf fdgae fcgbdea fgecda egab | ba dab abd gbae   dbgeaf bad acdfbe ab agbdf bgcdf fdgae fcgbdea fgecda egab ba dab abd gbae   y069y 7 y069y 1 x235x x235x x235x 8 y069y 4 1 7 7 4 1774
6 Sum of codes feagcb cdfagb egda bdg dg fdcagbe ebcga bedfc bgecd dbcgea | eafgbc bcdfage dg egad   feagcb cdfagb egda bdg dg fdcagbe ebcga bedfc bgecd dbcgea eafgbc bcdfage dg egad   y069y y069y 4 7 1 8 x235x x235x x235x y069y 6 8 1 4 6814
7 Part B bacfedg afbgc dbcgaf afgecd acd bfagce bgda ad adfbc ecbdf | dca dca abdg dcbef   bacfedg afbgc dbcgaf afgecd acd bfagce bgda ad adfbc ecbdf dca dca abdg dcbef   8 x235x y069y y069y 7 y069y 4 1 x235x x235x 7 7 4 2 7742
8 936117 eagfb efcdba faceg gfdce cea afbcegd ac afdegb gafcbe gbac | fegcd geafc edbcaf bcag   eagfb efcdba faceg gfdce cea afbcegd ac afdegb gafcbe gbac fegcd geafc edbcaf bcag   x235x y069y x235x x235x 7 8 1 y069y y069y 4 2 3 0 4 2304
9   cfb bgfce ebgdf fc gdfeab acdbfeg cgeab ecfd badfcg ebcfgd | ecgab eagcb efbacdg fc   cfb bgfce ebgdf fc gdfeab acdbfeg cgeab ecfd badfcg ebcfgd ecgab eagcb efbacdg fc   7 x235x x235x 1 y069y 8 x235x 4 y069y y069y 2 2 8 1 2281
10   adfec ebdcgf bfced bec fagcdeb gbcd cb fbgde deagbf afecgb | bce cb fdgeb bc   adfec ebdcgf bfced bec fagcdeb gbcd cb fbgde deagbf afecgb bce cb fdgeb bc   x235x y069y x235x 7 8 4 1 x235x y069y y069y 7 1 5 1 7151
11   bgfaec dcfga ed acedgfb fdebgc dec fdeb gedcba gfced cebfg | cde agcbde gfaecb cde   bgfaec dcfga ed acedgfb fdebgc dec fdeb gedcba gfced cebfg cde agcbde gfaecb cde   y069y x235x 1 8 y069y 7 4 y069y x235x x235x 7 0 6 7 7067
12   bgefc cfgbea dfgaecb dg dbcg dcefa dfbegc dgfce afgedb fgd | cfged gdf fbgdea gafecb   bgefc cfgbea dfgaecb dg dbcg dcefa dfbegc dgfce afgedb fgd cfged gdf fbgdea gafecb   x235x y069y 8 1 4 x235x y069y x235x y069y 7 3 7 0 6 3706
13   fcbade dagbe gacb gaedfc bdaecfg bgfde dbaec baegcd ga dga | ag gad gcab ga   fcbade dagbe gacb gaedfc bdaecfg bgfde dbaec baegcd ga dga ag gad gcab ga   y069y x235x 4 y069y 8 x235x x235x y069y 1 7 1 7 4 1 1741
14   cfgdeb cbfade fac badfc ca gafdce gfdebac bfadg fbdce aceb | ebdcf deagfc ac ebfcd   cfgdeb cbfade fac badfc ca gafdce gfdebac bfadg fbdce aceb ebdcf deagfc ac ebfcd   y069y y069y 7 x235x 1 y069y 8 x235x x235x 4 5 0 1 5 5015
15   debfcg fgde cfaedgb ecbag cbeadf gf gbf fdceb fcebg dfagbc | gbfec gf agbce bfcagd   debfcg fgde cfaedgb ecbag cbeadf gf gbf fdceb fcebg dfagbc gbfec gf agbce bfcagd   y069y 4 8 x235x y069y 1 7 x235x x235x y069y 3 1 2 0 3120
16   fdcebag cbeagd gafed dfbgc cgedfa beg be edgafb edbfg eabf | gbcfd acgefd cfdageb afged   fdcebag cbeagd gafed dfbgc cgedfa beg be edgafb edbfg eabf gbcfd acgefd cfdageb afged   8 y069y x235x x235x y069y 7 1 y069y x235x 4 2 6 8 5 2685
17   bgad efdbcg aecfdgb fgebca ga cgade acbedg adfce aeg cgdeb | gdecfb fgdceb adceg ga   bgad efdbcg aecfdgb fgebca ga cgade acbedg adfce aeg cgdeb gdecfb fgdceb adceg ga   4 y069y 8 y069y 1 x235x y069y x235x 7 x235x 6 6 3 1 6631
18   acefd efdb cgabfe be fegcbda gbacd cagefd eab acebfd acbed | be debf feacgb becad   acefd efdb cgabfe be fegcbda gbacd cagefd eab acebfd acbed be debf feacgb becad   x235x 4 y069y 1 8 x235x y069y 7 y069y x235x 1 4 0 3 1403
19 N of 1,4,7,8 edbcag dgefcab ce fgdcb eafc afgceb gfbae cbe degafb bfgce | fcgbd ec dbaegc efgdba   edbcag dgefcab ce fgdcb eafc afgceb gfbae cbe degafb bfgce fcgbd ec dbaegc efgdba   y069y 8 1 x235x 4 y069y x235x 7 y069y x235x 2 1 0 6 2106
20 Part A bfcdge gfcbda aegfcdb dg cdgbe dbfce dgb fged cdefba caebg | dbg bgd gdfe dg   bfcdge gfcbda aegfcdb dg cdgbe dbfce dgb fged cdefba caebg dbg bgd gdfe dg   y069y y069y 8 1 x235x x235x 7 4 y069y x235x 7 7 4 1 7741
21 92 bfeadc dbfcgea bgdaf decfg efdabg cgba fbdagc ca fca gdcfa | cafdg gacb bdfeag ac   bfeadc dbfcgea bgdaf decfg efdabg cgba fbdagc ca fca gdcfa cafdg gacb bdfeag ac   y069y 8 x235x x235x y069y 4 y069y 1 7 x235x 3 4 6 1 3461
22 99 edbcfg cdgfae gedaf egcfd beagfc fga bcfdgae cgda debfa ag | defgc efabgc fcegadb fegda   edbcfg cdgfae gedaf egcfd beagfc fga bcfdgae cgda debfa ag defgc efabgc fcegadb fegda   y069y y069y x235x x235x y069y 7 8 4 x235x 1 5 0 8 3 5083
23 83 gafcb fcgadb gdca gbadf ad fbegd befcag fda ebgdcaf fbaecd | agcbf dbafcg dgafb abgfcd   gafcb fcgadb gdca gbadf ad fbegd befcag fda ebgdcaf fbaecd agcbf dbafcg dgafb abgfcd   x235x y069y 4 x235x 1 x235x y069y 7 8 y069y 5 9 3 9 5939
24 78 cga gafce gecbfda dbacgf defac febcg cfbdeg afegcb bgae ga | cdbgef ebdagcf caefg geba   cga gafce gecbfda dbacgf defac febcg cfbdeg afegcb bgae ga cdbgef ebdagcf caefg geba   7 x235x 8 y069y x235x x235x y069y y069y 4 1 6 8 3 4 6834
25 Total gfebcda ab dfabg abcfgd gdbfc abgc becgdf bcedfa adfge fab | abf fab ba agbc   gfebcda ab dfabg abcfgd gdbfc abgc becgdf bcedfa adfge fab abf fab ba agbc   8 1 x235x y069y x235x 4 y069y y069y x235x 7 7 7 1 4 7714
26 352 fagce ceabfgd cdea cbfaeg dgafce egcdf bfaegd gbcdf fde ed | de aedgbf fecagd fcebga   fagce ceabfgd cdea cbfaeg dgafce egcdf bfaegd gbcdf fde ed de aedgbf fecagd fcebga   x235x 8 4 y069y y069y x235x y069y x235x 7 1 1 0 9 6 1096
27   fcbad fe afge ebagd fde fbdegac fgbced fdgeba fabed edcgba | debga bdgae bafdc efag   fcbad fe afge ebagd fde fbdegac fgbced fdgeba fabed edcgba debga bdgae bafdc efag   x235x 1 4 x235x 7 8 y069y y069y x235x y069y 5 5 2 4 5524

Day 8 Code:

'Day 8 - bad wiring

Sub readData()

Dim fileName As String

Dim textLine As String

Dim i As Integer

.... i = 1

.... fileName = Application.GetOpenFilename

.... Open fileName For Input As #1

.... Do Until EOF(1)

........ Line Input #1, textLine

........ Cells(i, 2) = textLine

........ i = i + 1

.... Loop

.... Close #1

....

.... Cells(4, 1) = i - 1

End Sub

Sub parseData()

'breaks data string into individual blocks for each digit

.... Dim i, j As Integer

.... Dim tempStr As String

.... Dim shortString As String

.... Dim pos As Integer

.... Dim n As Integer

....

.... n = Cells(4, 1)

.......

... For i = 1 To n

................

............ tempStr = Cells(i, 2)

............ j = 3

............

............ Do While Len(tempStr) > 0

................ pos = InStr(tempStr, " ")

................ If pos > 0 Then

.................... shortStr = Left(tempStr, pos - 1)

.................... tempStr = Mid(tempStr, pos + 1, 1000)

................ Else

.................... shortStr = tempStr

.................... tempStr = ""

................ End If

............

................ If shortStr <> "|" Then

.................... j = j + 1

.................... Cells(i, j) = shortStr

................. End If

..................

............ Loop

...........

.... Next i

....

End Sub

Sub stepI()

'identifies singles digits that have unique number of segments

' (1, 4, 7, 8) and counts the number of each

' The sum of these counts is the answer to part A

' Also lists the possibilities of the other digits

Dim i, j, k As Integer

Dim n As Integer

n = Cells(4, 1)

For i = 21 To 24

.... Cells(i, 1) = ""

Next i

For i = 1 To n

.... For j = 4 To 13

........ If Len(Cells(i, j)) = 5 Then

............ Cells(i, j + 20) = "x235x"

........ End If

........ If Len(Cells(i, j)) = 6 Then

............ Cells(i, j + 20) = "y069y"

........ End If

........ If Len(Cells(i, j)) = 2 Then 'it is "1"

............ Cells(i, j + 20) = 1

........ End If

........ If Len(Cells(i, j)) = 3 Then

............ Cells(i, j + 20) = 7

......... End If

........ If Len(Cells(i, j)) = 4 Then 'it is "4"

............ Cells(i, j + 20) = 4

........ End If

......... If Len(Cells(i, j)) = 7 Then

............ Cells(i, j + 20) = 8

........ End If

.... Next j

....

.... For j = 14 To 17

........ If Len(Cells(i, j)) = 5 Then

............ Cells(i, j + 20) = "x235x"

........ End If

........ If Len(Cells(i, j)) = 6 Then

............ Cells(i, j + 20) = "y069y"

........ End If

........ If Len(Cells(i, j)) = 2 Then 'it is "1"

............ Cells(i, j + 20) = 1

............ Cells(21, 1) = Cells(21, 1) + 1

........ End If

........ If Len(Cells(i, j)) = 3 Then

............ Cells(i, j + 20) = 7

............ Cells(22, 1) = Cells(22, 1) + 1

........ End If

........ If Len(Cells(i, j)) = 4 Then 'it is "4"

............ Cells(i, j + 20) = 4

............ Cells(23, 1) = Cells(23, 1) + 1

........ End If

......... If Len(Cells(i, j)) = 7 Then

............ Cells(i, j + 20) = 8

............ Cells(24, 1) = Cells(24, 1) + 1

........ End If

.... Next j

Next i

.

End Sub

Sub stepII()

' checks for occurences of direct overlap.

' eg. If a '1' shares its segments with a 5-segment digit, it must be a '3', but can't be a '2' or '5'

Dim i, j, k As Integer

Dim c As Integer

Dim n As Integer

n = Cells(4, 1)

For i = 1 To n

....

.... For k = 34 To 37

....

........ If Len(Cells(i, k)) > 1 Then

............ For j = 4 To 17

....

................ If Len(Cells(i, j)) = 2 Then 'it is "1"

...................

........................ If Len(Cells(i, k - 20)) = 6 Then 'if digit is 6 segment [069]

............................ If contains(Cells(i, k - 20), Cells(i, j)) Then

................................ Cells(i, k) = xOut(Cells(i, k), 3) 'remove 6

............................ Else

................................ Cells(i, k) = 6

............................ End If

........................ End If

..........................

.......................... If Len(Cells(i, k - 20)) = 5 Then 'if digit is 5 segment [235]

............................ If contains(Cells(i, k - 20), Cells(i, j)) Then

................................ Cells(i, k) = 3

............................ Else

.................................. Cells(i, k) = xOut(Cells(i, k), 3) 'remove 3

............................ End If

........................ End If

...................

................ End If

........

................ If Len(Cells(i, j)) = 3 Then 'it's a '7'

....................

........................ If Len(Cells(i, k - 20)) = 6 Then 'if digit is 6 segment [069]

............................ If contains(Cells(i, k - 20), Cells(i, j)) Then

................................ Cells(i, k) = xOut(Cells(i, k), 3) 'remove 6

............................ Else

................................ Cells(i, k) = 6

............................ End If

........................ End If

..........................

.......................... If Len(Cells(i, k - 20)) = 5 Then 'if digit is 5 segment [235]

............................ If contains(Cells(i, k - 20), Cells(i, j)) Then

................................ Cells(i, k) = 3

............................ Else

.................................. Cells(i, k) = xOut(Cells(i, k), 3) 'remove 3

............................ End If

........................ End If

................

................ End If

.....

................ If Len(Cells(i, j)) = 4 Then 'it is "4"

...................

........................ If Len(Cells(i, k - 20)) = 6 Then 'if digit is 6 segment [069]

............................ If contains(Cells(i, k - 20), Cells(i, j)) Then

................................ Cells(i, k) = 9 'it is 9

............................ Else

............................

................................ Cells(i, k) = xOut(Cells(i, k), 4) 'remove 9

............................ End If

........................ End If

....................

................ End If

..............

............ Next j

........ End If

.... Next k

Next i

End Sub

Sub stepIII()

' counts the number of shared segments with a '4' and 5 segment digits

' if 2 shared segments, it must be a 2, if 3 shared segments, it must be a 5

Dim i, j, k As Integer

Dim c As Integer

Dim n As Integer

n = Cells(4, 1)

For i = 1 To n

....

.... For k = 34 To 37

....

........ If Len(Cells(i, k)) > 1 Then

............ For j = 4 To 17

....

................ If Len(Cells(i, j)) = 4 Then 'it is "4"

...................

.......................... If Len(Cells(i, k - 20)) = 5 Then 'if digit is 5 segment [235]

............................ If containsCount(Cells(i, k - 20), Cells(i, j)) = 2 Then

................................ Cells(i, k) = 2

............................ ElseIf containsCount(Cells(i, k - 20), Cells(i, j)) = 3 Then

.................................. Cells(i, k) = 5

............................ End If

........................ End If

...................

................ End If

........

............ Next j

........ End If

.... Next k

Next i

End Sub

Sub stepIV()

' cleans up output

Dim i, j, k As Integer

Dim sum As Long

Dim numberString As String

Dim n As Integer

n = Cells(4, 1)

For i = 1 To n

........ For j = 34 To 37

............ Cells(i, j) = stripToOneDigit(Cells(i, j)) 'if it's down to one digit, remove the ..

........ Next j

........ numberString = ""

........ For j = 34 To 37

............ numberString = numberString & Cells(i, j)

........ Next j

........ If Len(numberString) = 4 Then

............ Cells(i, 38) = numberString 'put the final answer of the 4 digit code into place

........ End If

Next i

End Sub

Function stripToOneDigit(numberStr As String) As String

' if there is only one choice left, it replaces the cell value with a single digit

.... If Mid(numberStr, 3, 2) = ".." Then

........ stripToOneDigit = Mid(numberStr, 2, 1)

.... ElseIf Mid(numberStr, 2, 1) = "." And Mid(numberStr, 4, 1) = "." Then

........ stripToOneDigit = Mid(numberStr, 3, 1)

.... ElseIf Mid(numberStr, 2, 2) = ".." Then

......... stripToOneDigit = Mid(numberStr, 4, 1)

.... Else

......... stripToOneDigit = numberStr

.... End If

....

End Function

Function containsCount(mainStr As String, subStr As String) As Integer

' counts the number of overlapping segments between two digit codes

.... Dim i As Integer

.... Dim tc As Integer

....

.... tc = 0

.... For i = 1 To Len(subStr)

........ If InStr(mainStr, Mid(subStr, i, 1)) > 0 Then

............ tc = tc + 1

........ End If

.... Next i

.... containsCount = tc

End Function

Function contains(mainStr As String, subStr As String) As Boolean

' checks to see whether one digit code is completely contained in a second code

' could be replaced by containsCount function

.... Dim i As Integer

.... Dim tc As Boolean

....

.... tc = True

.... For i = 1 To Len(subStr)

........ If InStr(mainStr, Mid(subStr, i, 1)) = 0 Then

............ tc = False

........ End If

.... Next i

.... contains = tc

End Function

Function xOut(xString As String, place As Integer) As String

' removes a given possiblity from the set of multiple choices

.... If Len(xString) = 5 Then

........ xOut = Left(xString, place - 1) & "." & Right(xString, 5 - place)

.... Else

........ xOut = xString

.... End If

End Function


Day 9:     (Smoke Basins)

Day 9 Worksheet:   (Partial)

Pete Day 9 Worksheet
# Col 104 Col 105 Col 106
1 9897656789865467895698765469899988672134598894345689864101378965457932349943210987654789653198789434   Number of r/c
2 8789542499996878954329984398789976561012987789245678953212567892345791998899329899765678969997668912   100
3 7678943978987989965998993297649875432129876567956789864487678991056899877778939769886789998766457899   100
4 4578999868998996899867894976532986543299876476897899987569899989167898766567898654998898998655345678   Top 3 basins
5 2456987657679535679756799988643498657987654345789978899789998878998919954349997543219967987543237889   102
6 1234896545568986798645678999754989767898765456998769759899987765789329863238898659301256798793156891 38 96
7 2346789432379997987434689489899879898919876567899954346998796434678997642127789798512345989989247892 12 92
8 8756894210998989876545694378987868999101998688999863238987684323457789751015678987654459878678956994 15  
9 9769995679876978998656789469876957893212999899989764649876576212345678953223489698866598754567897989 8 Product of top 3
10 9878989989885467899787896598765648789329876959879986768985432101567789998654599549977987543468998978 12 900864
11 3989879897654345689998998679954324595498754347669897979699564323459998949765678923989295432389989567 22  
12 2997669789731287899899649799878212989987543233456789897598765434569767959878789313993197643578965456 41 Sum of Risk Level
13 9876548678954345997678998998965359878995432102345898795439896556978956899989895429894298754567989967 48 607
14 9754334567895456789567987897895498769896654233457987689649987667989349989999976598789349865678999898 18  
15 8843212689986687993479876756789987656789999354569698789798998798996498679889988987679459996989239799 35  
16 7654303568987798932349965345690976543245878965689459899987899899459987598679299998598998989993198677 20  
17 9965214589298999421298764234892987632124567899893234999896757996598796476599101976467987979954989556 5  
18 9876423499349988942359982123899876543012568998990123598765346989987654323478919765359896868899876434 8  
19 9987834568959876899494321015789987654423458987781349987544235677898773212467899854298795756799764323 20  
20 8798945679998975697985432123456799797634567896532398765432136456987654543588978975697654345878954212 5  
21 6569987989897854586976543434589899898765778999994569976543012345699896698678967896989543234667994334 50  
22 4323599999765632324989876565678935999876889998789678998652134456789998789789656799976532123456789765 5  
23 3212678998654321012497987676799323497989996897678989998543445967997659899895346898798943434678999876 70  
24 5323799998776432423456798989893214986797965986599999897654597888976545998921234987659975665789875987 49  
25 5435678989886543434567899699954399865456797998989999798975679999987631987654345799543986796789653498 32  
26 6547899767987656756778985467895987654357789219878797549986998921299890198765489898752397898997621359 41  
27 7656999348999987897899876579999898983234679109767689920199887990123989989987568999643498959876533578 11  
28 9767898769987899998986988989987689876123793298656577891298796789939878976597679998759979347987897689 -96  
29 0978999898776878999765399999976467965234999987545456792987665667898769897498989899898765456899989797 31  
30 1999686999654767897654239899897379894349898765432345789876543456789456789329595789999876567988778965 3  
31 9765534498743456899761098756789298789498789877521234568997431367890239899939424699998997879876567893 41  
32 7654321239654569989943199645678999688997678988432345789789545689965498999898935988977898989865438942 3  
33 8969210149875698779899986432349997567789499996544656795678957897896987898767899976756779995987546891 14  
34 9898991268989987667678964321259986455679989987655767893567898956989876987656998765634567894398656789 12  
35 8796989357899986554567893210198998234598776498789878912379939347978945698768987654323979976498787891 52  
36 7645678968999975423589999321297986123987654339891989701588921299866734569979498962109898997569898910 51  
37 8958789989998764312399998432986544016799543210910196532347893987654321368989329879298787898978929921 61  
38 9769896599987655503457897553497432135698765432399987648656789499965873456993210998987656789989939892 16  
39 7978965439876543217568998664987643446999876543478999759867892349876754567894329987542545691299899789 16  
40 6989753212987654328678959989999987556899997664567899867999943458987876989965998765431236789498788678 77  

Day 9 Code:

Sub readData()

Dim fileName As String

Dim textLine As String

Dim i As Integer

.... i = 1

.... fileName = Application.GetOpenFilename

.... Open fileName For Input As #1

.... Do Until EOF(1)

........ Line Input #1, textLine

........ Cells(i, 104) = textLine

........ i = i + 1

.... Loop

.... Close #1

....

.... Cells(2, 106) = i - 1

.... Cells(3, 106) = Len(Cells(1, 104))

End Sub

Sub parseData() 'separates out the string of data, putting one digit in each cell

.... 'leaves a border of '10' around the grid (which was just entered in ss)

.... Dim i, j As Integer

.... Dim c As Integer

.... Dim tempStr As String

...

.... Dim n As Integer

....

.... n = Cells(2, 106) 'number of rows and columns

.....

... For i = 1 To n

........ tempStr = Cells(i, 104)

......... For j = 1 To n

............. Cells(i + 1, j + 1) = Mid(tempStr, j, 1)

.............. c = Cells(i + 1, j + 1) * 20

.............. Cells(i + 1, j + 1).Interior.Color = RGB(c, c, 200 - c) 'sets color according to value of cell

.............. If Cells(i + 1, j + 1) = 9 Then

................ Cells(i + 1, j + 1).Interior.Color = RGB(150, 50, 50)

.............. End If

......... Next j

.... Next i

End Sub

Sub findRiskLevel()

Dim i, j As Integer

Dim c As Integer

Dim n As Integer

n = Cells(2, 106)

c = 0

For i = 2 To n + 1

.... For j = 2 To n + 1

....

........ If Cells(i, j) < Cells(i - 1, j) Then

........ If Cells(i, j) < Cells(i + 1, j) Then

........ If Cells(i, j) < Cells(i, j - 1) Then

........ If (Cells(i, j) < Cells(i, j + 1)) Then

................

............ c = c + 1 + Val(Cells(i, j)) 'add the elevation +1 to the sum for the risk level

............

........ End If

........ End If

........ End If

........ End If

........

.... Next j

Next i

... Cells(13, 106) = c 'the sum of all the risk levels

... Cells(13, 106).Select

...

End Sub

Sub findBasins()

.... Dim i, j, k As Integer

.... Dim c, r As Integer

.... Dim tempCount As Integer

.... Dim n As Integer

.... Dim ii As Integer

.... Dim jj As Integer

.... n = Cells(2, 106)

.... r = 5

.... c = 105

.... For i = 2 To n + 1

........ For j = 2 To n + 1

............

............ If Cells(i, j) < 9 Then

................ ii = i 'there was some type definition problem with just using i and j. This sets the types to what is needed

................ 'Presumably it has to do with the fact that the digits came from strings

................ jj = j

................ tempCount = countBasin(ii, jj) 'recursive function. Counts cell(i,j) and looks at neighboring cells

................ r = r + 1

................ Cells(r, c) = tempCount

...............

............ End If

........

........ Next j

.... Next i

.... For j = 1 To 3

........ For i = 1 To r

............ If Cells(i, 105) > Cells(j + 4, 106) Then

........................ Cells(j + 4, 106) = Cells(i, 105)

............... End If

........ Next i

........ For i = 1 To r

............ If Cells(j + 4, 106) = Cells(i, 105) Then

................ Cells(i, 105) = -Cells(i, 105)

............ End If

........ Next i

.... Next j

............

.... Cells(10, 106) = Cells(5, 106) * Cells(6, 106) * Cells(7, 106)

End Sub

Function countBasin(i As Integer, j As Integer) As Integer

If Cells(i, j) < 9 Then

.... Cells(i, j) = 11

.... countBasin = 1 + countBasin(i - 1, j) + countBasin(i + 1, j) + countBasin(i, j - 1) + countBasin(i, j + 1)

Else

.... countBasin = 0

End If

End Function


Day 10 Worksheet:     (Partial)     (Syntax Scoring)

Pete Day 10 Worksheet
# Col 1 Col 3 Col 8 Col 10 Col 11 Col 12 Col 13 Col 20 Col 21 Col 22
1 Day 10: Syntax Scoring Raw data from C:\Users\pete\Documents\Day2Day\AdventOfCode\Day10.txt status bad character bad char points Additional char score Additional char score (for sorting)   Char id # Points
2   {<{[<((<[<({<{(){}}(()())>[<<><>>((){})]}(<<{}{}>(<><>)>))(<[(<>{}){()()}]{{{}[]}(()())}>[       116349723 27407414683   ( 1 1
3 N data lines ((<{[<([<<{[<(()())([]())>)<<<{}{}>{[][]}>{<<>>(()[])}>}<(((()[])[{}<>])[<[]{}>{{}[]}])[[({}{}) corrupt data 11 3   27175232813   { 2 3
4 98 ({(<[([((<(<[(<>{}){()[]}]<[[]<>]<(){}]>><{(<>())[<>{}]}{(<>[])(<>{})}>)([(<(){}>[(){}]){{()[]}{<>{}}}][<<[] corrupt data 14 57   23059473694   < 3 4
5   {{{[(([{{{[{[(()())[<>[]]]{([]{}){()<>}}}]{{{((){})[[][]]}[[{}{}]<[]()>]}(<(<>()){{}{}>>([{}() corrupt data 13 25137   22645199869   [ 4 2
6 len line 1 [<{{{[[(<[(([<{}[]>{()()}][[<>{}]]))]([<<{{}[]}>>([(<>[])<(){}>][[{}{}](()())])]{[{[<><>]}((<>{})[       2816133597 21136588946   ) 11 3
7 90 {<[<[[<<(<<<<(<>[])(<>[])>{([]())}>[{{[]()}}<({}())[<>()]>]>{[((<>{})[[]<>])([()<>]{<>()})](((<>()       1551554948 17556164724   } 12 1197
8   ([({({[{(([<[<[]>]>]<<({[]()}<[]<>>)[[()[]]{[]{}}]>>))((<<{<<><>>}{(<>{})<[]()>}>([[<>{}]<<>{}>       578791661 17506461621   > 13 25137
9   {(<([{{{{(((({{}[]}))){[(({}<>))({<><>}<[][]])][<<[]{}>[{}{}]>{<[]>{[]{}}}]})({[{([]<>)([]<>)} corrupt data 14 57   17034119799   ] 14 57
10 Part A {([{{{(([<[[[<(){}>{()[]}][([]<>)<[]{}>]]<{(<>())[[]()]}[{(){}}[()<>]]>]([({[]{}}{()[])){{<>()}{()[]}}])>[<[ corrupt data 11 3   10839418066        
11 390993 [([{<{(<({<{[[<>{}][<>[]]]<{{}<>}<{}{}>>}[({()[]])[[<>()]({}<>)]]>{<([{}<>]<[]<>>)[{[]()}{{}[]}]>[[{[][] corrupt data 14 57   5736122716        
12   {{<(<{(<[<(((<[]<>><{}[]>))({(<>{}){[][]}}([[]()]({}<>))>)>[((((()<>)<<>[]>){(<>{}){<>{}}})(<({}( corrupt data 13 25137   5512771472        
13 Part B {{[{<{<([{[<{[{}{}]{(){}}}{{[]<>}<()[]>}>]<[({[][]}<{}<>>)(<{}{}><[]()>)]<[{<>{}}(()())]([[]{}]<[]<>>)>>>[{[{ corrupt data 13 25137   5511668458        
14 2391385187 <(([<<{{<(([(({}{})[[]{}])[<{}>(<>{})]]<([{}{}]{()[]})>))({(<(()<>)<<><>>>(([]<>)))}<<<[()       3656155909 5311638568        
15   <<<(({{([{({({()()}<<>[]>)<{()[]}[<>()>>}){[<[<>{}][<><>]>[{()[]}[<><>]]]<<[<>[]]{<>()}>>}}[(<[[(){}](() corrupt data 13 25137   5251817999        
16   <<[[{{([(([([[<>{}][(){}]])]{({{()}(<>{})}{{{}<>}{<><>}})(([<><>])({{}[]}<<><>>))})([{({()<>}<[][]>)}]))       183449 5198005824        
17   [(<<<<<{[<({[{{}[]}<()<>>]<[{}[]][[]<>]>})>[<<{(()())({}<>)}{({}())(<>[]]}><<<{}<>>([]<>)><[ corrupt data 14 57   4580044622        
18   <<({({{([(<([[{}()]<[]{}>]<<<>()>>)><{(<{}<>><{}()>)<{(){}}[<>]>}{([[]{}][[]<>])<({}()){{}[       17034119799 4554530297        
19   {<{([[[[[{<<[[{}{}]([]<>)]{{{}()}[<><>]}><[<()()>[{}{}]](((){})<()>>>>}]<{({{([]()){{}<>}}<{<>{}}({}{} corrupt data 13 25137   4230962036        
20   {[{[[<[((<(<<{<>}{()[]}>><{<<>[]>[()[]]}{{()()}[()[]]}>)(({[[]](<>[])}{({}())<{}()>})([[{}[]]<[]()>][{       4217310963 4217310963        
21   [{[(({[{{([[[<()()>{{}{}}]{([]<>){<><>}}]](<<<(){}>(()())>{[[]]{<>{}}>>))<[<((<>{}){(){}}){[{}<>]}>([[<>< corrupt data 13 25137   3656155909        
22   <{<(<([(<[({<<[]()>[[]{}]>(<{}<>>)}(<[{}[]][{}[]]>{<{}[]>[(){}]}))[<(<[]<>>{{}<>}]([[][]]<()<>>)>{({{}<>}[<>[ corrupt data 14 57   3650916573        
23   {({({{<({[{[{<<>()>[[]{}]}](([{}<>]{()()})[([]()){[]()}})}[[((()())[()<>])(<<>{}><{}>)]]]<([{([] corrupt data 12 1197   2858155937        
24   (<[([{({<([<(([]<>)<()[]>){{<>{}}[()()]}>])(([({[]()}<{}{}>)][<{{}[]}({})>[[<><>][<><>]]])<[({()[]}[[]{       21136588946 2816133597        
25   {{{<{{[[{[[<({[]()}{()[]})<[<>()][()()]>>(({{}{}}))][({[(){}](()[]]}){{<<>()>({})}{<{}[]>[{}<>]}}]]{[< corrupt data 14 57   2756895183        
26   {<([((<{<<<{(({}{})<<>[]>)(((){}){[]})}{({[]<>}[[]{}])<[{}[]][()()]>}}[{([<>()][<>{}]){(<> corrupt data 12 1197   2391385187        
27   {([([(({[<[[[(())(<>[])]{[()()][<>]}]]>([{[(<><>)(<>())]<(()<>)[<><>]>}({{<>{}}({})}([{}][       2756895183 1922949608        
28   ([[[({[{{<{{{[{}()]{(){}}}[{()}({}[])]}[{[[]<>>(()[])}<{[][]}{[]}>]}>}}]}{[<[[[[(({}{}){{}[]} corrupt data 13 25137   1698145961        
29   <[{<([<({((([[<>{}]([]())]<[()[]]<()<>>>){<<{}{}>[<><>]>[((){}){{}<>}]}))}({[({[()())(<>[])}{({}())}){([()[] corrupt data 11 3   1551554948        
30   {([[{[<<[[<{([<>()][{}{}])<([]{})(()[])>}{{{()()}{[][]}}<[[]{}]<<>{}>>}>(({<()()>({}())}[{<>[]}({}<>)])([[<       27407414683 1210664836        
31   ({[<{{[<{{(((([]<>){<>()})([()<>]([]{})))){{<{()()}[{}<>]>}({<{}[]>}{([]<>)<{}[]>})}}<<([{{}()}[{}[]]]<{(       10839418066 1159121681        
32   <({{([{[({<([({}())[()[]]]{([]{})})(([[]{}]{{}[]})([{}()><()<>>))>(<(({}{})<{}{}>)[{<><>}{[] corrupt data 13 25137   1119668443        
33   [{[{<{([[[<[[{[][]}(<>{})]{{[]<>}[{}{}]}]><{({{}()}<[]()})}>]{{(<[[][]]{[]()}>{(()())(<>[])})( corrupt data 12 1197   941271409        
34   (<{(<[[<{[[<<([]<>)<{}{}>>({{}[]}({}()))>]({([[]<>]([]())){[<>{}]<{}()>}}[{({}())[(){}]}(({}{})[[]]       356993346 668505572        
35   <[<<([{[{<{{<[[][]]<<>[]>>({<>{}}[<><>])}([[{}<>]<()()>][<[][]>(()[])])}[({[()()][[]()]}[{{}()}<[]<>>])]>{<       46304364 578791661        
36   <(([[{(([[([[{{}()}{[]}]]<((<><>}({}[]))((()())[()[]])>)[{{<[]<>>((){})}}<(<(){}>{{}[]})({()}{{}<>})>]]<[(<{ corrupt data 12 1197   466535939        
37   [{<(((<(<({(({{}()}{<><>})[{[][]}{(){}}])({{[]{}}[<>{}]>)})>((([<(<><>){{}<>}><[<>{}]>]([[<>[]][{}{} corrupt data 13 25137   356993346        
38   [<{{({([({({{{()<>}([][])>}((({}<>)(()[]))<(<>()){{}<>}>)){[([()()](<>[]))]{({[]}[[]{}])([[]<> corrupt data 13 25137   356874314        
39   {({[<{(<<([[[<{}{}>[{}{}]](<<>>(()))]{[([]<>)<{}{}>]<[<><>]>}]<[[{{}<>}<<>{}>][([]<>)<(){}       5511668458 133339362        
40   ([{{{[[(<<[<[[<>]{[]}]((<>{})({}[]))>({{()[]}<<><>>}{{<>{}}({})})]{{{{[][]}<{}()>}}<[[<><>][{}<>]]<       1210664836 126712098        
41   [<{<{<[{{[([(([]<>))[{<>()}<{}{}>]]{[<<>{}>[(){}]){<[][]>[<><>]}})](([<([]{})[{}()]>(({}())(<>{}))] corrupt data 11 3   116349723        
42   [<[<{(<(([{<{([]{}){[][]}}><{[{}[]]([]<>)}[[()[]]<()()>]>}][{(<[(){}]{()<>}><<[]()>[[]()]>){[[<>[]](()[])       668505572 76087331        
43   <(<<<([[<([[({[]<>}<[]()>){{<>[]}[{}{}]}]([[[][]]<[]()>])]<{{(<><>){<>[]}}}{(<[][])(()[]))[([]{})[[ corrupt data 11 3   46779223        
44   (([{<{{([<<{({[]{}}[()[]])[<()()><()[]>]}[(<()>[()()])[[<>[]]]]>>{{{{<[]()>[()<>]}}{{<()[]>[()[]]}<[[][]]       1159121681 46304364        
45   (<<[([[{{({<[([][])<{}()]][<()()>(()())]>})}<([[{(()<>)<[]()>}((()[])[<>{}])]]([<{(){}}({}<>)>][< corrupt data 14 57   41916842        
46   [<<((<[<<{(((({}()))({<>{}}([]<>))){{<()<>><{}[]>}{(()())}}){({([]<>)<<>{}>})}}<{{<[()][<><>]>{{[]       4580044622 34366812        
47   <{[<[((([{<{{{<>[]}[[]()]}([<><>])}>((<<<>()>({}<>)><[{}[]]<()[]>>)[{{[][]}{()<>}}[{()<>}(()[])]])}(([<{{       23059473694 13270968        
48   {<{<[(({([<[<[[][])([]{})>[{(){}}[[]<>]]][(<{}<>>{()<>}){[<><>]{{}[]}}]>([[<[][]>{[]<>}]({[][]}(()()))]{ corrupt data 11 3   8825864        
49   (<{{{[{<{(<[({{}[]})]><<{(()<>)[{}{}]}{<()()>}>>)[[(({()<>}(<>{})))([<(){}>(()<>)]{((){})([][])})]       5446096 5446096        
50   <<[(<([<(({[{({}{})}<{()<>}{<>{}}>][([[]()](()<>))]}[[({{}()}<[]{}>)[<[]()>[()()]]]((<{}{}       5198005824 183449        

Day 10 Code:

'Day 10 - Syntax Scoring

Dim gAry(500) As Integer 'global array, functioning as a stack

Sub readData()

Dim fileName As String

Dim textLine As String

Dim i As Integer

.... i = 1

.... fileName = Application.GetOpenFilename

.... Cells(1, 3) = "Raw data from " & fileName

.... Open fileName For Input As #1

.... Do Until EOF(1)

........ Line Input #1, textLine

........ Cells(i + 1, 3) = textLine

........ i = i + 1

.... Loop

.... Close #1

....

.... Cells(3, 1) = "N data lines"

.... Cells(4, 1) = i - 1

.... Cells(6, 1) = "len line 1"

.... Cells(7, 1) = Len(Cells(2, 3))

End Sub

Sub pushStack(i As Integer)

'pushes one integer onto the end of the stack, increments the counter in cell 0

.... Dim n As Integer

....

.... n = gAry(0)

.... n = n + 1

.... gAry(0) = n

.... gAry(n) = i

....

End Sub

Function popStack() As Integer

'pops one integer off the end of the stack, decrements the counter in cell 0

.... Dim n As Integer

....

.... n = gAry(0)

.... popStack = gAry(n)

.... n = n - 1

.... gAry(0) = n

End Function

Function charCode(cd As String) As Integer

'converts character from input string into an integer

'matching closing characters are 10 higher than initial opening characters

.... If cd = "(" Then

........ charCode = 1

.... ElseIf cd = "{" Then

........ charCode = 2

.... ElseIf cd = "<" Then

........ charCode = 3

.... ElseIf cd = "[" Then

........ charCode = 4

.... ElseIf cd = ")" Then

........ charCode = 11

.... ElseIf cd = "}" Then

........ charCode = 12

.... ElseIf cd = ">" Then

........ charCode = 13

.... ElseIf cd = "]" Then

........ charCode = 14

.... Else

........ charCode = 99

.... End If

End Function

Sub parseData() 'main calculations

.... Dim i, j As Integer

.... Dim cx As Integer

.... Dim cd As String

.... Dim bad As Boolean

.... Dim pts(25) As Integer

.... Dim score As Long

.... Dim partScore As Long

.... Dim n As Integer

.... Dim nGood As Integer

.... 'assigns point values for each character for scoring both parts A and B and puts them in pts() array for calculations

.... For i = 2 To 9

........ pts(Cells(i, 21)) = Cells(i, 22)

.... Next i

.... nGood = 0

....

.... i = 2

.... Do While Cells(i, 3) <> "" 'loop through every line of input

........

........ 'initialize values for a new string of data

........ gAry(0) = 0 'gAry is used to hold the size of the array

........ bad = False

........ score = 0

........ Cells(i, 12) = ""

....

........ 'process each character in data string

........ For j = 1 To Len(Cells(i, 3))

............ cd = Mid(Cells(i, 3), j, 1)

........... cx = charCode(cd)

........... If cx < 10 Then

................ 'it's an opening character, push onto stack, do nothing else

................ Call pushStack(cx)

............ ElseIf cx < 20 Then

................ 'it's a closing character

................ If gAry(0) > 0 Then

.................... 'if there is a saved character, pop it off the stack and check to see if it matches

.................... If popStack <> cx - 10 And Not bad Then

........................ 'it doesn't match. flag as bad data

........................ Cells(i, 8) = "corrupt data"

........................ Cells(i, 10) = cx

........................ Cells(i, 11) = pts(cx)

........................ bad = True

.................... End If

................ End If

............ End If

........ Next j

..............

........ If Not bad Then

............ 'if it's not bad data, fill out the rest of the closing characters and score the line

............ Do While gAry(0) > 0

................ 'pop an opening character off the stack, and figure out how many points the matching closing character is worth

................ partScore = pts(popStack)

................ 'score = 5 * score + partScore

................ 'tried to use variable, but had problems with too large numbers. I thought type 'Long' would do it, but evidently not.

................ Cells(i, 12) = Cells(i, 12) * 5 + partScore

............ Loop

............ nGood = nGood + 1

............

........ End If

........

........ 'copy to a second column for sorting

........ Cells(i, 13) = Cells(i, 12)

........

........ i = i + 1

.... Loop

....

.... Call sortCodes

....

.... 'place answer to part B in cell

.... Cells(14, 1) = Cells(Int(nGood / 2) + 2, 13)

....

........

End Sub

Sub sortCodes()

'recorded macro from Excel

.... Columns("M:M").Select

.... ActiveWorkbook.Worksheets("Syntax").Sort.SortFields.Clear

.... ActiveWorkbook.Worksheets("Syntax").Sort.SortFields.Add Key:=Range("M2:M1000"), _

........ SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

.... With ActiveWorkbook.Worksheets("Syntax").Sort

........ .SetRange Range("M1:M1000")

........ .Header = xlYes

........ .MatchCase = False

........ .Orientation = xlTopToBottom

........ .SortMethod = xlPinYin

........ .Apply

.... End With

.... Range("M26").Select

End Sub


Day 11 Worksheet:     (Flashing Octopus)

Pete Day 11 Worksheet
# 1 3 11 12 13 14 15 16 17 18 19 20 21 22
1     Raw Data Initial Energy Grid                        
2     8448854321     8 4 4 8 8 5 4 3 2 1  
3 N of steps   4447645251     4 4 4 7 6 4 5 2 5 1  
4 100   6542573645     6 5 4 2 5 7 3 6 4 5  
5     4725275268                          
6 Pause   6442514153     6 4 4 2 5 1 4 1 5 3  
7 1000   4515734868     4 5 1 5 7 3 4 8 6 8  
8     5513676158                          
9     3257376185     3 2 5 7 3 7 6 1 8 5  
10 Part A   2172424467     2 1 7 2 4 2 4 4 6 7  
11 1546   6775163586     6 7 7 5 1 6 3 5 8 6  
12                                
13 Part B                              
14 100                              
15                                
16                                
17         T 6 6 6 9 7 3 2 2 2 2 T
18         T 6 6 6 9 1 3 2 2 2 2 T
19                                
20                                
21                                
22                                
23                                
24                                
25                               .

Day 11 Code:

'Day 11 - Octopus Flash

Dim a(12, 12) As Integer

Dim f(12, 12) As Boolean

Dim gNflash As Integer

Sub readData()

Dim fileName As String

Dim textLine As String

Dim i As Integer

.... i = 1

.... fileName = Application.GetOpenFilename

.... Cells(1, 3) = "Raw data from " & fileName

.... Open fileName For Input As #1

.... Do Until EOF(1)

........ Line Input #1, textLine

........ Cells(i + 1, 3) = textLine

........ i = i + 1

.... Loop

.... Close #1

....

... ' Cells(3, 1) = "N data lines"

.... Cells(4, 1) = i - 1

... ' Cells(6, 1) = "len line 1"

.... Cells(7, 1) = Len(Cells(2, 3))

End Sub

Sub parseData() '

Dim i As Integer

Dim j As Integer

Dim k As Integer

Dim kn As Integer

Dim lastNflash As Integer

Dim allFLASH As Boolean

kn = Cells(4, 1)

gNflash = 0

k = 1

lastNflash = 0

allFLASH = False

'initialize borders as true. This keeps recursive call from trying to go past borders

For i = 1 To 12

.... f(i, 1) = True ' f represents 'yes, octopus has flashed'

.... f(i, 12) = True

Next i

For j = 1 To 12

.... f(1, j) = True

.... f(12, j) = True

Next j

'parse original data into array

'fill array into top 10 lines of ss

For i = 2 To 11

For j = 2 To 11

.... a(i, j) = Mid(Cells(i, 3), j - 1, 1)

.... f(i, j) = False

.... Cells(i, j + 10) = a(i, j)

Next j

Next i

'step through n steps.

' Part A stops after 100 steps

' Part B requires kn to be set at a large number and the loop stops when all octopuses flash at once

Do While k <= kn And Not allFLASH

'add 1 to every octopus

For i = 2 To 11

For j = 2 To 11

.... a(i, j) = a(i, j) + 1

Next j

Next i

'Examine all octopus. if over 9, then call flash for octopus

For i = 2 To 11

For j = 2 To 11

...

.... If a(i, j) > 9 Then

........ If Not f(i, j) Then

............ Call flash(i, j)

........ End If

.... End If

Next j

Next i

'Examine all octopus. If cell is 10 or larger, reset to 0

For i = 2 To 11

For j = 2 To 11

.... If a(i, j) > 9 Then

........ a(i, j) = 0

........ f(i, j) = False

.... End If

Next j

Next i

'If the change in number of flashes during this step is 100, that means that all flashed.

'That's the end for part B

If gNflash - lastNflash = 100 Then

.... allFLASH = True

End If

lastNflash = gNflash

Call displayArray

k = k + 1

Loop

'fill array into rows 14+

Call displayArray

'Answer for Part A (number of flashes in 100 steps

Cells(11, 1) = gNflash

'Answer for Part B (number of steps taken to get all to flash at once)

Cells(14, 1) = k - 1

........

End Sub

Sub flash(m As Integer, n As Integer)

.... Dim ii As Integer

.... Dim jj As Integer

........

.... f(m, n) = True 'set f value to 'true', octopus in cell did flash

.... gNflash = gNflash + 1 'add 1 to global counter of total number of flashes

.... 'examine every octopus that is within 1 cell of the one in question

.... 'if it has not flashed, add 1 to it's energy level

.... 'it that brings it up to 10, check to see if it has flashed already. If it has not, call Flash recursively.

.... For ii = m - 1 To m + 1

.... For jj = n - 1 To n + 1

........ If Not f(ii, jj) Then

............ a(ii, jj) = a(ii, jj) + 1

........ End If

........ If a(ii, jj) > 9 And Not f(ii, jj) Then

...

............ Call flash(ii, jj)

........ End If

.... Next jj

.... Next ii

....

End Sub

Sub displayArray()

Dim pause As Long

Dim i As Long

pause = Cells(7, 1)

'fill array into rows 14+

For i = 2 To 11

For j = 2 To 11

.... Cells(i + 13, j + 10) = a(i, j)

Next j

Next i

For i = 1 To pause

....

Next i

End Sub


Day 12 Worksheet:     (Partial)       (Cave Passages)

Pete Day12 Worksheet
# A B F G H O P Q R S T
1     Example 1     Start Cave End Cave     Number of Paths: Individual Paths
2     10 start-AA   AA bb AA-bb   36 DT s~-AA | AA-bb | bb-AA | AA-bb | bb-AA | AA-cc | cc-AA | AA-d~
3 starting line   36 start-bb   AA cc AA-cc     DT s~-AA | AA-bb | bb-AA | AA-bb | bb-AA | AA-d~
4 2     AA-cc   AA d~ AA-d~     DT s~-AA | AA-bb | bb-AA | AA-bb | bb-d~
5       AA-bb   bb AA bb-AA     DT s~-AA | AA-bb | bb-AA | AA-cc | cc-AA | AA-bb | bb-AA | AA-d~
6 last line     bb-dd   bb d~ bb-d~     DT s~-AA | AA-bb | bb-AA | AA-cc | cc-AA | AA-bb | bb-d~
7 11     AA-end   bb dd bb-dd     DT s~-AA | AA-bb | bb-AA | AA-cc | cc-AA | AA-cc | cc-AA | AA-d~
8       bb-end   cc AA cc-AA     T s~-AA | AA-bb | bb-AA | AA-cc | cc-AA | AA-d~
9 Identify Problem (A or B)         dd bb dd-bb     T s~-AA | AA-bb | bb-AA | AA-d~
10 b   Example 2     s~ AA s~-AA     T s~-AA | AA-bb | bb-d~
11     19 dc-end   s~ bb s~-bb     DT s~-AA | AA-bb | bb-dd | dd-bb | bb-AA | AA-cc | cc-AA | AA-d~
12 Display paths (Y or N)   103 HN-start             DT s~-AA | AA-bb | bb-dd | dd-bb | bb-AA | AA-d~
13 y     start-kj             DT s~-AA | AA-bb | bb-dd | dd-bb | bb-d~
14       dc-start             DT s~-AA | AA-cc | cc-AA | AA-bb | bb-AA | AA-bb | bb-AA | AA-d~
15       dc-HN             DT s~-AA | AA-cc | cc-AA | AA-bb | bb-AA | AA-bb | bb-d~
16       LN-dc             DT s~-AA | AA-cc | cc-AA | AA-bb | bb-AA | AA-cc | cc-AA | AA-d~
17       HN-end             T s~-AA | AA-cc | cc-AA | AA-bb | bb-AA | AA-d~
18       kj-sa             T s~-AA | AA-cc | cc-AA | AA-bb | bb-d~
19       kj-HN             DT s~-AA | AA-cc | cc-AA | AA-bb | bb-dd | dd-bb | bb-AA | AA-d~
20       kj-dc             DT s~-AA | AA-cc | cc-AA | AA-bb | bb-dd | dd-bb | bb-d~
21     Example 3               DT s~-AA | AA-cc | cc-AA | AA-cc | cc-AA | AA-bb | bb-AA | AA-d~
22     226 fs-end             DT s~-AA | AA-cc | cc-AA | AA-cc | cc-AA | AA-bb | bb-d~
23     3509 he-DX             DT s~-AA | AA-cc | cc-AA | AA-cc | cc-AA | AA-d~
24       fs-he             T s~-AA | AA-cc | cc-AA | AA-d~
25       start-DX             T s~-AA | AA-d~
26       pj-DX             DT s~-bb | bb-AA | AA-bb | bb-AA | AA-cc | cc-AA | AA-d~
27       end-zg             DT s~-bb | bb-AA | AA-bb | bb-AA | AA-d~
28       zg-sl             DT s~-bb | bb-AA | AA-bb | bb-d~
29       zg-pj             DT s~-bb | bb-AA | AA-cc | cc-AA | AA-bb | bb-AA | AA-d~
30       pj-he             DT s~-bb | bb-AA | AA-cc | cc-AA | AA-bb | bb-d~
31       RW-he             DT s~-bb | bb-AA | AA-cc | cc-AA | AA-cc | cc-AA | AA-d~
32       fs-DX             T s~-bb | bb-AA | AA-cc | cc-AA | AA-d~
33       pj-RW             T s~-bb | bb-AA | AA-d~
34       zg-RW             T s~-bb | bb-d~
35       start-pj             DT s~-bb | bb-dd | dd-bb | bb-AA | AA-cc | cc-AA | AA-d~
36       he-WI             DT s~-bb | bb-dd | dd-bb | bb-AA | AA-d~
37       zg-he             DT s~-bb | bb-dd | dd-bb | bb-d~
38       pj-fs              
39       start-RW              

Day 12 Code:

Dim gLine As Long 'global variable holding the count of the number of paths

'Day 12 - Passage Pathing

'counting up the number of possible paths through a series of caves

Sub readData()

Dim fileName As String

Dim textLine As String

Dim i As Integer

.... i = 1

.... fileName = Application.GetOpenFilename

.... Cells(1, 3) = "Raw data from " & fileName

.... Open fileName For Input As #1

.... Do Until EOF(1)

........ Line Input #1, textLine

........ Cells(i + 1, 3) = textLine

........ i = i + 1

.... Loop

.... Close #1

....

..... Cells(4, 1) = i - 1

.

End Sub

Sub countPaths()

'initial subroutine of the calculations

Dim i As Integer

Dim nLine As Integer

Dim strS As String

Dim pathStr As String

'initialize variables

.... strS = "s~"

.... gLine = 1

.... Cells(2, 19) = 0

.... Columns("T:T").Select

.... Selection.ClearContents

.... Range("T1").Select

.... Cells(1, 20) = "Individual Paths"

.... i = 2

Do While Cells(i, 15) <> ""

....... i = i + 1

Loop

Cells(7, 1) = i - 1 'last line of data in purple (O-Q) columns

'starts the process of finding paths

'finds a path that starts with the 'strS' which is set at 's~'

pathStr = findPath(strS)

End Sub

Function findPath(startStr As String) As String

'recursive function

'input: a string that holds a series of caves that have been built as the start of a path

'output: if not at the end, a string that has one more cave on it than before, which is passed

' to a recursive call of the function

' If the added cave is the exit, the global count variable is incremented as the recursive chain ends.

.... Dim i As Integer

.... Dim n As Integer

.

.... Dim tempStr As String

.... Dim passStr As String

.... Dim indPath As String

....

.... n = Cells(7, 1)

.... i = 2

.... tempStr = Right(startStr, 2) 'the last cave in the string passed to this function

..

.... If tempStr = "d~" Then 'the starting string is identified as complete, having the end cave already as the last element

........ 'As a complete path, the count of paths is incremented and displayed in a cell

........ gLine = gLine + 1

........ Cells(2, 19) = gLine - 1

........ If UCase(Cells(13, 1)) = "Y" Then 'if the user selected to diplay individual paths, the string is placed in column T

............ Cells(gLine, 20) = startStr

........ End If

....

.... Else 'the last cave in the input string is NOT the 'end' cave

....

........ For i = 2 To n 'consider every pair of caves in the data set

........

............. If tempStr = Cells(i, 15) Then ' the new line starts with the last cave

................ If InStr(startStr, Cells(i, 16)) = 0 Or Cells(i, 16) < "ZZZ" Or _

........................ Left(startStr, 1) = "T" Then

................ 'Checks for 3 conditions:

................ ' The InStr function checks to see if the new 2nd cave is already present in the string of caves

................ ' < "ZZZ" checks to see if the cave is a large (upper case letters) cave in which case it can be visited multiple times

................ ' 1st letter = "T" is code that the 'visit one small cave twice' option has not been used yet.

.................... If startStr = "s~" Then 'the very first instance of this function being called

........................ passStr = Cells(i, 17) 'sets the string to be passed as the new pair, without the initial letters

........................ If UCase(Cells(10, 1)) = "B" Then 'if Problem B, "T" is placed at the beginning of the string as a code for the two visits to one small cave

............................ passStr = "T " & passStr

........................ End If

.................... Else 'it is NOT the first instance. The new pair of caves is added to the previous string of caves

........................ passStr = startStr & " | " & Cells(i, 17)

.................... End If

....................

.................... If InStr(startStr, Cells(i, 16)) > 0 And Cells(i, 16) > "ZZZ" Then

........................ 'The new 2nd cave of the pair is 'small' (lower case) and has been visited before

........................ 'The letter 'D' is placed at the front of the string to negate the power of the 'T'

............................ passStr = "D" & passStr

.................... End If

.

.................... indPath = findPath(passStr) 'recursively call the function again, passing in the string with the addition

............................................ 'of another pair of caves

..................

...................

................. End If 'processing and adding a valid new pair of caves

............. End If 'looking at a new line that starts with the last cave

........

........ Next i 'loop looking at every potential pair of caves

... End If 'the consideration of the string of caves passed to the function

...

End Function 'findPath

Sub parseDatax()

'processes the data given in the problem set (pasted into column G) and places it as pairs of caves in columns O-Q

'all pairs are listed twice with each cave listed first, except for the starting and ending pairs.

Dim i, j As Integer

Dim tempStr As String

Dim pos As Integer

Dim lStr As String

Dim rStr As String

.... Columns("O:Q").Select

.... Selection.ClearContents

.... Range("O1").Select

.... Cells(1, 15) = "Start Cave"

.... Cells(1, 16) = "End Cave"

....

i = Cells(4, 1) 'starting line identified by user

j = 2

Do While Cells(i, 7) <> "" 'parses data in column G, starting with the line identified by the user

.... tempStr = Cells(i, 7)

.... pos = InStr(tempStr, "-")

.... lStr = Left(tempStr, pos - 1)

.... rStr = Mid(tempStr, pos + 1, 10)

.... 'lists each line of data twice, once with each cave in the start position

....

.... If lStr <> "end" And rStr <> "start" Then 'does not list a line starting with 'end' or ending with 'start'

........ Cells(j, 15) = lStr

........ Cells(j, 16) = rStr

........ j = j + 1

.... End If

.... If rStr <> "end" And lStr <> "start" Then

........ Cells(j, 16) = lStr

....... Cells(j, 15) = rStr

........ j = j + 1

.... End If

.... i = i + 1

Loop

i = 2

Do While Cells(i, 15) <> ""

.... If Cells(i, 15) = "start" Then

........ Cells(i, 15) = "s~"

.... End If

.... If Cells(i, 16) = "end" Then

........ Cells(i, 16) = "d~"

.... End If

.... Cells(i, 17) = Cells(i, 15) & "-" & Cells(i, 16)

.... i = i + 1

. Loop

Call sortSteps

End Sub

Sub sortSteps()

'

.... Columns("O:Q").Select

.... ActiveWorkbook.Worksheets("Flash").Sort.SortFields.Clear

.... ActiveWorkbook.Worksheets("Flash").Sort.SortFields.Add Key:=Range("O2:O1000") _

........ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

.... ActiveWorkbook.Worksheets("Flash").Sort.SortFields.Add Key:=Range("P2:P1000") _

........ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

.... With ActiveWorkbook.Worksheets("Flash").Sort

........ .SetRange Range("O1:Q1000")

........ .Header = xlYes

........ .MatchCase = False

........ .Orientation = xlTopToBottom

........ .SortMethod = xlPinYin

........ .Apply

.... End With

.... Range("O2").Select

End Sub


Create your website for free! This website was made with Webnode. Create your own for free today! Get started