Hola a todos, tras darle muchas vueltas he conseguido hacer un Triangulo de Pascal desde VB6.
Para que veais que no es un C&P os dire como llegue a la conclusion y os explicare cada paso que doy en los comentarios que aparecen en el code.
Deduccion:
Sabia que habia que resolverlo con una matriz, asi que hice una de 5x5 introduciendo los números que me deberian salir, algo asi:
1 0 0 0 0
1 1 0 0 0
1 2 1 0 0
1 3 3 1 0
1 4 6 4 1
Bien, una vez aqui pense cual era la logica de los numeros una vez dentro de la matriz...
Llegue a la conclusion de que todo elemento viene dado de la suma del que tiene encima con el de la izquierda del que tiene encima (que mal me explico)... :-\
Unos ejemplos:
*El numero 4 sale de la suma del que tiene envima ( el 1) y el de la izquierda al que tiene encima (el 3)
*El numero 2 sale de la suma del que tiene envima ( el 1) y el de la izquierda al que tiene encima (otro 1)
Una vez aqui, os resultara muy facil entender la siguiente formula:
Matriz(x,y) = Matriz(x-1,y) + Martiz(x-1,y-1)
Me dejo de rodeos y os dejo el code:
' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com) //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se //
' // respete la autoria y se me comuniquen esos cambios. //
' // *Visita http://foro.rthacker.net //
' ////////////////////////////////////////////////////////////////
Rem Insertar TextBox con la propiedad Multiline = True y ScrollBars = Both
Option Explicit
Public Sub Generate_Pascal_Triangle(ByVal tTextBox As TextBox, ByVal iPotency As Integer)
'//Declaro variables
Dim lNumbersArray() As Double
Dim dNumber As Double
Dim x As Long
Dim y As Long
'//Si la Potencia es menor a 3 sale del procedimiento
If iPotency > 2 Then
'//Redimensiono mi matriz con tantas filas y columnas como me indique la potencia
ReDim lNumbersArray(iPotency, iPotency)
'//Edito la primera linea de mi matriz puesto que la necesito como base
lNumbersArray(1, 1) = 1
For x = 2 To iPotency
lNumbersArray(x, 1) = 0
Next
For x = 2 To iPotency
For y = 1 To iPotency
'//Si estoy en la primera columna no podria sumar otro elemento de mi matriz que
'este más a la izquierda, si ocurre eso asigo a mi variable dNumber el valor 0
If (y - 1) < 1 Then
dNumber = 0
Else
dNumber = lNumbersArray(x - 1, y - 1)
End If
'//Utilizo la fórmula que puse antes
lNumbersArray(x, y) = dNumber + lNumbersArray(x - 1, y)
Next
Next
With tTextBox
.Text = vbNullString '//Limpio el TextBox
.Alignment = 2 '//Pongo el texto centrado para que se aprecie mejor la piramide
For x = 1 To iPotency
For y = 1 To iPotency
'//Represento la matriz ya editada prescindiendo de los ceros
If lNumbersArray(x, y) <> 0 Then .Text = .Text & lNumbersArray(x, y) & Chr$(32)
Next
'//Nueva linea despues de acabar una fila
.Text = .Text & vbCrLf
Next
End With
'//Borro mi matriz
Erase lNumbersArray '//Esto es prescindible ;)
End If
End Sub
Un ejemplito:
Private Sub Form_Load()
Call Generate_Pascal_Triangle(Text1, 10)
End Sub
Obtenriamos este resultado en el TextBox:
1
1 1
1 2 1
1 3 3 1
1 4 6 4 1
1 5 10 10 5 1
1 6 15 20 15 6 1
1 7 21 35 35 21 7 1
1 8 28 56 70 56 28 8 1
1 9 36 84 126 126 84 36 9 1
Esto es todo, espero que os sirva... :P
Espero el siguiente reto
Salu2! ;)
MMM se me hace familiar...
http://foro.elhacker.net/programacion_visual_basic/source_triangulo_pascal-t279857.0.html;msg1379201
Cita de: BlackZeroX▓▓▒▒░░ en 3 Enero 2010, 22:36 PM
bueno andaba aburrido e hice el codigo para generar el triangulo de pascal
se nesesitan
2 textBox (textbox 2 en propiedad multilinea = true)
1 CommandButton
'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo //
' ////////////////////////////////////////////////////////////////
Option Explicit
Public Function GenerateTrianglePascal(ByVal nLineas As Long) As String
On Error GoTo 1
Dim a As Long
Dim b As Long
Dim CelVar() As Double
If nLineas > 0 Then
ReDim CelVar(nLineas, nLineas)
For a = 1 To nLineas
For b = 1 To a: DoEvents
CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
GenerateTrianglePascal = GenerateTrianglePascal & CelVar(a, b) & IIf(Not b = a, String(3, " "), "")
Next b
If a <> nLineas Then GenerateTrianglePascal = GenerateTrianglePascal & vbCrLf
Next a
1: Erase CelVar
End If
End Function
Private Sub Form_Load()
Text2.Alignment = 2 ' // Modo centralizado
End Sub
Private Sub Command1_Click()
Text2.Text = GenerateTrianglePascal(Val(Text1.Text))
End Sub
con dowhile y doevents
'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo //
' ////////////////////////////////////////////////////////////////
Option Explicit
Public Function GenerateTrianglePascal(ByVal nLineas As Long) As String
On Error GoTo 1
Dim a As Long
Dim b As Long
Dim CelVar() As Double
If nLineas > 0 Then
ReDim CelVar(nLineas, nLineas)
a = 1: Do While a <= nLineas
b = 1: Do While b <= a: DoEvents
CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
GenerateTrianglePascal = GenerateTrianglePascal & CelVar(a, b) & IIf(Not b = a, String(2, " "), "")
b = b + 1: Loop
If a <> nLineas Then GenerateTrianglePascal = GenerateTrianglePascal & vbCrLf
a = a + 1: Loop
1: Erase CelVar
End If
End Function
Private Sub Form_Load()
Text2.Alignment = 2 ' // Modo centralizado
End Sub
Private Sub Command1_Click()
Text2.Text = GenerateTrianglePascal(Val(Text1.Text))
End Sub
Código ligeramente mejorado ya se se queda tanto tiempo muerto!¡.
'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo //
' ////////////////////////////////////////////////////////////////
Option Explicit
Public Sub GenerateTrianglePascal(ByVal nLineas As Long, ByRef OutData As String)
'On Error GoTo 1
Dim a As Long
Dim b As Long
Dim Puntero As Long
Dim Longitud As Long
Dim Temporal As String
Dim CelVar() As Double
Dim OutDataTemp As String
Const KiloByte As Long = 5120
If nLineas > 0 Then
ReDim CelVar(nLineas, nLineas)
Puntero = 1
OutDataTemp = Space(KiloByte)
Temporal = Space(255)
For a = 1 To nLineas
For b = 1 To a: DoEvents
CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
Temporal = CelVar(a, b) & IIf(a <> b, " ", "")
Longitud = Len(Temporal)
Mid(OutDataTemp, Puntero, Longitud) = Temporal
Puntero = Puntero + Longitud
If Puntero > KiloByte Then
OutData = OutData & OutDataTemp
OutDataTemp = Space(KiloByte)
Puntero = 2
End If
Next b
If a <> nLineas Then
Puntero = Puntero
Mid(OutDataTemp, Puntero, 2) = vbCrLf
Puntero = Puntero + 2
End If
Caption = a
Next a
1: Erase CelVar
End If
OutData = OutData & Trim$(OutDataTemp)
End Sub
Private Sub Form_Load()
Text2.Alignment = 2 ' // Modo centralizado
End Sub
Private Sub Command1_Click()
Dim datas As String
Call GenerateTrianglePascal(Val(Text1.Text), datas)
Text2.Text = datas
End Sub
la longitud de los números esta limitada por el buffer que solo le asigne 255 caracteres.
El limite de lineas es de 932 si es que no se aumentan los buffers de memoria
P.D.: El código en lugar de hacerle un redim a celvar(x,x) puede hacerse de esta forma Celver(1,x) pero decidí dejar los registros anteriores por si alguien deseaba hacerles cambios aun que de esta forma en la que lo deje gasta mas memoria ram en el modo celvar(1,x) no gastaría tanta pero tendría que estarse usando copymemori (API) para mover el de 1 a 0 y sacar los nuevos valores.
Dulces Lunas!¡
Este es el MAS RAPIDO y "OPTIMO" (Solo se debe sustituir el iif() por un If Then y unos cuantos Val en los iff() aqui mismo debajo del original lo pongo corregido) solo por si se me confunden con mi cita:
'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo //
' ////////////////////////////////////////////////////////////////
Option Explicit
Public Sub GenerateTrianglePascal(ByVal nLineas As Long, ByRef OutData As String)
'On Error GoTo 1
Dim a As Long
Dim b As Long
Dim Puntero As Long
Dim Longitud As Long
Dim Temporal As String
Dim CelVar() As Double
Dim OutDataTemp As String
Const KiloByte As Long = 5120
If nLineas > 0 Then
ReDim CelVar(nLineas, nLineas)
Puntero = 1
OutDataTemp = Space(KiloByte)
Temporal = Space(255)
For a = 1 To nLineas
For b = 1 To a: DoEvents
CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
Temporal = CelVar(a, b) & IIf(a <> b, " ", "")
Longitud = Len(Temporal)
Mid(OutDataTemp, Puntero, Longitud) = Temporal
Puntero = Puntero + Longitud
If Puntero > KiloByte Then
OutData = OutData & OutDataTemp
OutDataTemp = Space(KiloByte)
Puntero = 2
End If
Next b
If a <> nLineas Then
Puntero = Puntero
Mid(OutDataTemp, Puntero, 2) = vbCrLf
Puntero = Puntero + 2
End If
Caption = a
Next a
1: Erase CelVar
End If
OutData = OutData & Trim$(OutDataTemp)
End Sub
Private Sub Form_Load()
Text2.Alignment = 2 ' // Modo centralizado
End Sub
Private Sub Command1_Click()
Dim datas As String
Call GenerateTrianglePascal(Val(Text1.Text), datas)
Text2.Text = datas
End Sub
Codigo Optimo a mi Criterio Visto.
'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo //
' ////////////////////////////////////////////////////////////////
Option Explicit
Public Sub GenerateTrianglePascal(ByVal nLineas As Long, ByRef OutData As String)
'On Error GoTo 1
Dim a As Long
Dim b As Long
Dim Puntero As Long
Dim Longitud As Long
Dim Temporal As String
Dim CelVar() As Double
Dim OutDataTemp As String
Const KiloByte As Long = 5120 ' // Buffer Limite
If nLineas > 0 Then
ReDim CelVar(nLineas, nLineas)
Puntero = 1
OutDataTemp = Space(KiloByte)
Temporal = Space(255)
For a = 1 To nLineas
For b = 1 To a: DoEvents
Rem Start CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
If b = 1 Then
CelVar(a, b) = 1
Else
CelVar(a, b) = CelVar(a - 1, b - 1) + CelVar(a - 1, b)
End If
Rem End CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
Rem Start Temporal = CelVar(a, b) & IIf(a <> b, " ", "")
Temporal = CelVar(a, b)
If a <> b Then
Temporal = Temporal & " "
End If
Rem End Temporal = CelVar(a, b) & IIf(a <> b, " ", "")
Longitud = Len(Temporal)
Mid(OutDataTemp, Puntero, Longitud) = Temporal
Puntero = Puntero + Longitud
If Puntero > KiloByte Then
OutData = OutData & OutDataTemp
OutDataTemp = Space(KiloByte)
Puntero = 2
End If
Next b
If a <> nLineas Then
Puntero = Puntero
Mid(OutDataTemp, Puntero, 2) = vbCrLf
Puntero = Puntero + 2
End If
Caption = a
Next a
1: Erase CelVar
End If
OutData = OutData & Trim$(OutDataTemp)
End Sub
Private Sub Form_Load()
Text2.Alignment = 2 ' // Modo centralizado
End Sub
Private Sub Command1_Click()
Dim datas As String
Call GenerateTrianglePascal(Val(Text1.Text), datas)
Text2.Text = datas
End Sub
Dulce Infierno Lunar!¡.
Gracias Black! ;) :D
No tenia ni idea que habias hecho uno tu!!
Voy a estudiarlo con detenimiento
Una vez mas:
Gracias! ;D