RosettaCodeData/Task/Weird-numbers/FreeBASIC/weird-numbers.basic
2023-07-01 13:44:08 -04:00

54 lines
1.5 KiB
Text

Function GetFactors(n As Long,r() As Long) As Long
Redim r(0)
r(0)=1
Dim As Long count,acc
For z As Long=2 To n\2
If n Mod z=0 Then
count+=1:redim preserve r(0 to count)
r(count)=z
acc+=z
End If
Next z
Return 1+acc
End Function
sub sumcombinations(arr() As Long,n As Long,r As Long,index As Long,_data() As Long,i As Long,Byref ans As Long,ref As Long)
Dim As Long acc
If index=r Then
For j As Long=0 To r-1
acc+=_data(j)
If acc=ref Then ans=1:Return
If acc>ref then return
Next j
Return
End If
If i>=n Or ans<>0 Then Return
_data(index) = arr(i)
sumcombinations(arr(),n,r,index + 1,_data(),i+1,ans,ref)
sumcombinations(arr(),n,r,index,_data(),i+1,ans,ref)
End sub
Function IsWeird(u() As Long,num As Long) As Long
Redim As Long d()
Dim As Long ans
For r As Long=2 To Ubound(u)
Redim d(r)
ans=0
sumcombinations(u(),Ubound(u)+1,r,0,d(),0,ans,num)
If ans =1 Then Return 0
Next r
Return 1
End Function
Redim As Long u()
Dim As Long SumFactors,number=2,count
Do
number+=2
SumFactors=GetFactors(number,u())
If SumFactors>number Then
If IsWeird(u(),number) Then Print number;" ";:count+=1
End If
Loop Until count=25
Print
Print "first 25 done"
Sleep