128 lines
6.2 KiB
VB.net
128 lines
6.2 KiB
VB.net
Imports System.Console
|
|
Imports DT = System.DateTime
|
|
Imports Lsb = System.Collections.Generic.List(Of SByte)
|
|
Imports Lst = System.Collections.Generic.List(Of System.Collections.Generic.List(Of SByte))
|
|
Imports UI = System.UInt64
|
|
|
|
Module Module1
|
|
Const MxD As SByte = 15
|
|
|
|
Public Structure term
|
|
Public coeff As UI : Public a, b As SByte
|
|
Public Sub New(ByVal c As UI, ByVal a_ As Integer, ByVal b_ As Integer)
|
|
coeff = c : a = CSByte(a_) : b = CSByte(b_)
|
|
End Sub
|
|
End Structure
|
|
|
|
Dim nd, nd2, count As Integer, digs, cnd, di As Integer()
|
|
Dim res As List(Of UI), st As DT, tLst As List(Of List(Of term))
|
|
Dim lists As List(Of Lst), fml, dmd As Dictionary(Of Integer, Lst)
|
|
Dim dl, zl, el, ol, il As Lsb, odd As Boolean, ixs, dis As Lst, Dif As UI
|
|
|
|
' converts digs array to the "difference"
|
|
Function ToDif() As UI
|
|
Dim r As UI = 0 : For i As Integer = 0 To digs.Length - 1 : r = r * 10 + digs(i)
|
|
Next : Return r
|
|
End Function
|
|
|
|
' converts digs array to the "sum"
|
|
Function ToSum() As UI
|
|
Dim r As UI = 0 : For i As Integer = digs.Length - 1 To 0 Step -1 : r = r * 10 + digs(i)
|
|
Next : Return Dif + (r << 1)
|
|
End Function
|
|
|
|
' determines if the nmbr is square or not
|
|
Function IsSquare(nmbr As UI) As Boolean
|
|
If (&H202021202030213 And (1UL << (nmbr And 63))) <> 0 Then _
|
|
Dim r As UI = Math.Sqrt(nmbr) : Return r * r = nmbr Else Return False
|
|
End Function
|
|
|
|
'// returns sequence of SBbytes
|
|
Function Seq(from As SByte, upto As Integer, Optional stp As SByte = 1) As Lsb
|
|
Dim res As Lsb = New Lsb()
|
|
For item As SByte = from To upto Step stp : res.Add(item) : Next : Return res
|
|
End Function
|
|
|
|
' Recursive closure to generate (n+r) candidates from (n-r) candidates
|
|
Sub Fnpr(ByVal lev As Integer)
|
|
If lev = dis.Count Then
|
|
digs(ixs(0)(0)) = fml(cnd(0))(di(0))(0) : digs(ixs(0)(1)) = fml(cnd(0))(di(0))(1)
|
|
Dim le As Integer = di.Length, i As Integer = 1
|
|
If odd Then le -= 1 : digs(nd >> 1) = di(le)
|
|
For Each d As SByte In di.Skip(1).Take(le - 1)
|
|
digs(ixs(i)(0)) = dmd(cnd(i))(d)(0)
|
|
digs(ixs(i)(1)) = dmd(cnd(i))(d)(1) : i += 1 : Next
|
|
If Not IsSquare(ToSum()) Then Return
|
|
res.Add(ToDif()) : count += 1
|
|
WriteLine("{0,16:n0}{1,4} ({2:n0})", (DT.Now - st).TotalMilliseconds, count, res.Last())
|
|
Else
|
|
For Each n In dis(lev) : di(lev) = n : Fnpr(lev + 1) : Next
|
|
End If
|
|
End Sub
|
|
|
|
' Recursive closure to generate (n-r) candidates with a given number of digits.
|
|
Sub Fnmr(ByVal list As Lst, ByVal lev As Integer)
|
|
If lev = list.Count Then
|
|
Dif = 0 : Dim i As SByte = 0 : For Each t In tLst(nd2)
|
|
If cnd(i) < 0 Then Dif -= t.coeff * CULng(-cnd(i)) _
|
|
Else Dif += t.coeff * CULng(cnd(i))
|
|
i += 1 : Next
|
|
If Dif <= 0 OrElse Not IsSquare(Dif) Then Return
|
|
dis = New Lst From {Seq(0, fml(cnd(0)).Count - 1)}
|
|
For Each i In cnd.Skip(1) : dis.Add(Seq(0, dmd(i).Count - 1)) : Next
|
|
If odd Then dis.Add(il)
|
|
di = New Integer(dis.Count - 1) {} : Fnpr(0)
|
|
Else
|
|
For Each n As SByte In list(lev) : cnd(lev) = n : Fnmr(list, lev + 1) : Next
|
|
End If
|
|
End Sub
|
|
|
|
Sub init()
|
|
Dim pow As UI = 1
|
|
' terms of (n-r) expression for number of digits from 2 to maxDigits
|
|
tLst = New List(Of List(Of term))() : For Each r As Integer In Seq(2, MxD)
|
|
Dim terms As List(Of term) = New List(Of term)()
|
|
pow *= 10 : Dim p1 As UI = pow, p2 As UI = 1
|
|
Dim i1 As Integer = 0, i2 As Integer = r - 1
|
|
While i1 < i2 : terms.Add(New term(p1 - p2, i1, i2))
|
|
p1 = p1 / 10 : p2 = p2 * 10 : i1 += 1 : i2 -= 1 : End While
|
|
tLst.Add(terms) : Next
|
|
' map of first minus last digits for 'n' to pairs giving this value
|
|
fml = New Dictionary(Of Integer, Lst)() From {
|
|
{0, New Lst() From {New Lsb() From {2, 2}, New Lsb() From {8, 8}}},
|
|
{1, New Lst() From {New Lsb() From {6, 5}, New Lsb() From {8, 7}}},
|
|
{4, New Lst() From {New Lsb() From {4, 0}}},
|
|
{6, New Lst() From {New Lsb() From {6, 0}, New Lsb() From {8, 2}}}}
|
|
' map of other digit differences for 'n' to pairs giving this value
|
|
dmd = New Dictionary(Of Integer, Lst)()
|
|
For i As SByte = 0 To 10 - 1 : Dim j As SByte = 0, d As SByte = i
|
|
While j < 10 : If dmd.ContainsKey(d) Then dmd(d).Add(New Lsb From {i, j}) _
|
|
Else dmd(d) = New Lst From {New Lsb From {i, j}}
|
|
j += 1 : d -= 1 : End While : Next
|
|
dl = Seq(-9, 9) ' all differences
|
|
zl = Seq(0, 0) ' zero difference
|
|
el = Seq(-8, 8, 2) ' even differences
|
|
ol = Seq(-9, 9, 2) ' odd differences
|
|
il = Seq(0, 9)
|
|
lists = New List(Of Lst)()
|
|
For Each f As SByte In fml.Keys : lists.Add(New Lst From {New Lsb From {f}}) : Next
|
|
End Sub
|
|
|
|
Sub Main(ByVal args As String())
|
|
init() : res = New List(Of UI)() : st = DT.Now : count = 0
|
|
WriteLine("{0,5}{1,12}{2,4}{3,14}", "digs", "elapsed(ms)", "R/N", "Rare Numbers")
|
|
nd = 2 : nd2 = 0 : odd = False : While nd <= MxD
|
|
digs = New Integer(nd - 1) {} : If nd = 4 Then
|
|
lists(0).Add(zl) : lists(1).Add(ol) : lists(2).Add(el) : lists(3).Add(ol)
|
|
ElseIf tLst(nd2).Count > lists(0).Count Then
|
|
For Each list As Lst In lists : list.Add(dl) : Next : End If
|
|
ixs = New Lst() : For Each t As term In tLst(nd2) : ixs.Add(New Lsb From {t.a, t.b}) : Next
|
|
For Each list As Lst In lists : cnd = New Integer(list.Count - 1) {} : Fnmr(list, 0) : Next
|
|
WriteLine(" {0,2} {1,10:n0}", nd, (DT.Now - st).TotalMilliseconds)
|
|
nd += 1 : nd2 += 1 : odd = Not odd : End While
|
|
res.Sort() : WriteLine(vbLf & "The {0} rare numbers with up to {1} digits are:", res.Count, MxD)
|
|
count = 0 : For Each rare In res : count += 1 : WriteLine("{0,2}:{1,27:n0}", count, rare) : Next
|
|
If System.Diagnostics.Debugger.IsAttached Then ReadKey()
|
|
End Sub
|
|
End Module
|