' Constantes de Kaprekar. Enero 2025.
' https://sites.google.com/site/abugarins/, abugarins@gmail.com
'
' Escoge un numero entero positivo. Ordena sus digitos en orden ascendente y restalo a la ordenacion descendente de los mismos.
' Repite el proceso hasta que obtengas una constante.
'
Option _Explicit
Screen _NewImage(1260, 940, 32)
_FullScreen
Dim Pr As Integer, Lon As Integer, Vi As Integer, I As Integer, J As Integer
Dim N1 As Integer, N2 As Integer, Di As Integer, An As Integer, Lin As Integer, Nu As Integer
Dim Ni As String, Au As String * 1, N11 As String, N22 As String, Dii As String, Tmp As String
On Error GoTo Erro
Pr = 1
Nu = 0
Cls
Line Input "Numero inicial (F=fin):"; Ni
If _Trim$(UCase$(Ni)) = "F" Then End
Cls
Print "Numero incial:"; Ni
Print
Lin = Len(Ni)
For I = 1 To Lin
J = Asc(Mid$(Ni, I, 1))
If Not (J >= 48 And J <= 57) Then
Print "Ha de ser un numero entero positivo.";
Beep
Line Input Tmp
Run
End If
Next I
While Pr = 1
Nu = Nu + 1
Ni = _Trim$(Ni)
Lon = Len(Ni)
'Print "Longitud:"; Str$(Lon)
Vi = Val(Ni)
N11 = Ni
N1 = Val(N11)
For I = 1 To Lon - 1
For J = I + 1 To Lon
If Val(Mid$(N11, I, 1)) < Val(Mid$(N11, J, 1)) Then
Au = Mid$(N11, J, 1)
Mid$(N11, J, 1) = Mid$(N11, I, 1)
Mid$(N11, I, 1) = Au
End If
Next J
Next I
N1 = Val(N11)
'Print N11; " - ";
N22 = Ni
N2 = Val(N22)
For I = 1 To Lon - 1
For J = I + 1 To Lon
If Val(Mid$(N22, I, 1)) > Val(Mid$(N22, J, 1)) Then
Au = Mid$(N22, J, 1)
Mid$(N22, J, 1) = Mid$(N22, I, 1)
Mid$(N22, I, 1) = Au
End If
Next J
Next I
N2 = Val(N22)
If N1 = N2 Then
Print "Constante de kaprekar trivial = 0."
Exit While
End If
Di = N1 - N2
Dii = Str$(Di)
If Di = An Then
Print " "; N11; " - "; N22; " = "; Dii; " (Constante de kaprekar para numeros de"; Str$(Lin); " cifras)."
Exit While
Else
Print Nu; ": "; N11; " - "; N22; " = "; Dii
'Print N22; " = "; Dii
An = Di
Ni = _Trim$(Dii)
'Con retencion de ceros
While Len(Ni) < Lin
Ni = "0" + Ni
Wend
End If
Print
If InKey$ = Chr$(27) Then End
Wend
Line Input " "; Tmp
Run
Erro:
Print
Beep
Print ">>> ERROR "; Err; "("; _ErrorMessage$; ") en linea "; _ErrorLine; " <<<";
Beep
End
Comentarios sobre la versión: Versión 1.0 (0)
No hay comentarios