'(VB) Constructing and counting fill matrices Const nmax = 6 'computing time increases strongly with nmax Const c = 36 '>= nmax * (nmax + 1) / 2: 'maximum number of matrix elements Dim nr(c), ri(c), le(c), up(c) ' see structure Dim smax 'number of matrix elements Dim aa(c) 'terms of the sequence Sub main_program() 'matrices are encoded as strings of length n*(n+1)/2 'The k-th element in the m-th row is placed in the 'position number k+m*(m-1)/2 of the string. Erase aa() prot$ = "1," 'the sequence as a string For n = 2 To nmax pro$ = "" 'the matrix as a string smax = n * (n + 1) / 2 Call structure(n) Do Call create_matrix(pro$, n) If pro$ = "" Then Exit Do Call check_matrix((pro$), n, ok) If ok Then aa(n) = aa(n) + 1 Loop prot$ = prot$ + Str(aa(n)) If n < nmax Then prot$ = prot$ + "," Next Cells(1, 1).Value = prot$ 'output Excel End Sub Sub structure(n) For m = 1 To n b = (m * (m + 1)) \ 2 'last element of row number m a = b - m + 1 'first element of row number m For s = a To b 's is the position in the string nr(s) = m 'number of the row in the matrix ri(s) = (s > a) 'false if s is the first element le(s) = (s < b) 'false if s is the last element up(s) = (m < n) 'false if s is in the last row Next Next End Sub Sub create_matrix(pro$, n) 'strings of length n*(n+1)/2 with n "1"-terms are created If pro$ = "" Then pro$ = String(smax - n, "0") + String(n, "1") Else s = InStr(pro$, "1") If s > 1 Then Mid(pro$, s - 1, 2) = "10" Else s2 = InStr(pro$, "01") If s2 = 0 Then pro$ = "": Exit Sub s1 = InStr(pro$, "0") h$ = String(s2 - s1, "0") + String(s1, "1") + "0" Mid(pro$, 1, s2 + 1) = h$ End If End If End Sub Sub check_matrix(pro$, n, ok) 'It is checked if each "0" can be replaced by "1" Do Until InStr(pro$, "0") = 0 chg = False s = 0 Do s = InStr(s + 1, pro$, "0") If s = 0 Then Exit Do ok = False If up(s) Then ok = check_triple(pro$, n, s, nr(s), nr(s) + 1, chg) If Not ok And ri(s) Then ok = check_triple(pro$, n, s, -1, -nr(s), chg) If Not ok And le(s) Then ok = check_triple(pro$, n, s, 1, 1 - nr(s), chg) Loop If Not chg Then Exit Sub Loop End Sub Function check_triple(pro$, n, s, t1, t2, chg) 'The replacement is checked and done if possible ok = (Mid(pro$, s + t1, 1) + Mid(pro$, s + t2, 1) = "11") If ok Then chg = True: Mid(pro$, s, 1) = "1" check_triple = ok End Function