Lp11 Aplicaciones Windows Form

Lenguaje de programación 2015 \11 Aplicaciones Windows Forms \Ismael Véliz Vilca -745-
11 APLICACIONES EN WINDOWS FORM

Indice
11.1 EJEMPLO DE APLICACIÓN COMPLETA CON MENUS Y BARRA DE
HERRAMIENTAS 773
11.2 TEMAS FRACTALES 786
11.3 MONTAÑA FRACTAL(corregir) 800
11.4 DIAGRAMAS DE VORONOI EN MODO GRAFICO 809
11.5 TRABAJO DE APLICACIÓN DE REDES DE OPTIMIZACION 813
11.6 SIMULACION DE POLITICAS DE INVENTARIOS DE CONTROL DE
INVENTARIOS 826
11.7 TRIANGULACION DE DELAUNAY 830
1.8 PROGRAMA EDUCATIVO EL PUREK(para aprender operaciones matemáticas)
837
11.9 APLICACIÓN DE TRADUCTOR DE ARCHIVOS 843
11.10 BUSCADOR 846
11.11 PROBLEMA DE CRUCE 851
11.12 PROGRAMA DE LOCALIZACION DE LOTES 853
11.13 MODELADO 3D si tiene los siguientes puntos para un cubo realizar el modelado
3D 876
11.15 PROBLEMA DE CONDUCCION DE VEHICULOS 879
11.16 PROBLEMA DE CONDUCCION DE VEHICULOS USADO BITMAPS 885
11.18 MOVER UN ARCHIVO DE TEXTO Elaborar un programa que mueva un archivo
de texto por la pantalla 895
11.19 VER UNA PARTE DE LA PANTALLA Modificar el programa para ver parte de
una pantalla(corregir) 898
11.20 MADURACION DE UNA FRUTA (ejemplo platanos) 904
11.21 JUEGO DEL PACMAN (corregir) 911
11.22 APLICACIONES DE REDES NEURONALES PERCEPTRON 920
11.23 APLICACIONES DE LOGICA DIFUSA EN CONTROL DE TEMPERATURA 930
11.24 APLICACIÓN DEL MODELOS DEL SIMPLEX 935
11.25 APLICACIÓN DEL MODELOS DEL SIMPLEX METODO GRAFICO 949
11.26 GRAFICA DE FUNCIONES EN 2D Y 3D 959
11.26 GENERACION DE MONTAÑAS CON AUTOMATAS CELULARES(corregir) 968
12 28 Prender y Apagar un Foco con Arduino 978
11-30 PROCESAMIENTO DE IMAGNES EN VISUAL BASIC 2012 995
11.34 TRANSFORMACIONES CON BITMAPS 1031

11.34 JUEGO DE LA SERPIENTE O GUSANO 1035
11.35 TRABAJO CON BITMAPS 1039
11.35 PROBLEMA DEL BARQUITO EN MODO VISUAL 1044
11.1 EJEMPLO DE APLICACIÓN COMPLETA CON MENUS Y BARRA DE

HERRAMIENTAS
1. TRABAJANDO CON INTERFACES DE MULTIPLES DOCUMENTOS
Cuando trabajamos con aplicaciones Windows, existen dos tipos de interfaces o formas
de presentar la información en pantalla , éstas son:
1. Interface de Simple Documentos (SDI): Presenta un documento en su propia
ventana, cada ventana es independiente. Por ejemplo se usan SDI, el bloc de notas,
el Paint, el WordPad, Office 2000, etc.
2. Interface de Múltiples Documentos (MDI) : Presenta todos los documentos sobre
una ventana principal (Formulario padre) sobre la cual se muestra cada documento
en su ventana secundaria (Formulario hijo). Por ejemplo , se usan MDI: el Visual
Estudio.NET, SQL Enterprise Manager, Office 97, etc.
El ejemplo trata sobre un Editor de documentos similar al Wordpad , pero con funciones
básicas . Este ejemplo trabaja con dos formularios ; el primero es un formulario MDI
padre que tiene un menú principal , barras de herramientas y barra de estado; el
segundo formulario es la base para crear formularios MDI hijos que representan un
documento donde pueda escribir textos enriquecidos. Formato rtf
1. Crear un Aplicación Windows en Visual Basic .NET llamado FormularioMDI

2. En el Diseñador de formularios Windows, arrastrar 1 control MenuStrip1, 1
ToolStrip1,1 StatusStrip1, 1 OpenFileDialog, 1 SaveFileDialog, 1 ColorDialog, 1
FontDialog, 1 Timer , luego configurar las propiedades tal como se muestra en el
siguiente cuadro:
Objeto Propiedad Valor

Form1 isMdiContainer True
Text Editor de Documentos v 1.0
MenuStrip1 Name MenuStrip1
OpenFileDialog1 Name OpenFileDialog1
SaveFileDialog1 Name SaveFileDialog1
ColorDialog1 Name ColorDialog1
FontDialog1 Name FontDialog1
Timer1 Name Timer1
ToolStrip1 Name ToolStrip1
StatusStrip1 name StatusStrip1
3. Seleccione el control MenuStrip1 y en la parte superior donde dice “Escriba aqui”,

Escriba directamente los textos del Menú y configure sus propiedades tal como se
muestra en el siguiente cuadro:

MenuItem1 Name mnuArchivo
Text &Archivo
MenuItem11 Name mnuNuevo
ShortCut CtrlN
Text &Nuevo
MenuItem12 Name mnuAbrir
ShortCut CtrlA
Text &Abrir
MenuItem13 Name mnuGuardar
ShortCut CtrlG
Text &Guardar
MenuItem14 Name mnuLinea1
Text -
MenuItem15 Name mnuSalir
ShortCut CtrlS
Text &Salir
MenuItem2 Name mnuEdición
Text &Edición
MenuItem21 Name mnuCopiar
ShortCut CtrlC
Text &Copiar
MenuItem22 Name mnuCortar
ShortCut CtrlX
Text Co&rtar
MenuItem23 Name MnuPegar
ShortCut CtrlV
Text &Pegar
MenuItem3 Name mnuFormato
Text &Formato
MenuItem31 Name mnuFuente
Text Fuente
MenuItem32 Name mnuFondo
Text Color de Fondo
MenuItem4 Name mnuUtilitario
Text &Utilitarios
MenuItem41 Name mnuWindows
Text Windows
MenuItem411 Name mnuCalculadora
Text Calculadora
MenuItem412 Name MnuBloc
Text Bloc de Notas
MenuItem413 Name mnuExplorador
Text Explorador
MenuItem42 Name MnuOffice
Text Office
MenuItem421 Name MnuWord
Text Word
MenuItem422 Name MnuExcel
Text Excel
MenuItem423 Name mnuInternet
Text Internet Explorer
MenuItem5 Name mnuVentana
Text &Ventana
MenuItem51 Name Cascada
Tag 0
Text Cascada
MenuItem52 Name mnuMHorizontal
Tag 1
Text Mosaico Horizontal
MenuItem53 Name mnuMVertical
Tag 2
Text Mosaico Vertical
MenuItem54 Name mnuOIcons
Tagr 3
Text Organizar Iconos
MenuItem55 Name MnuLinea2
Text -
MenuItem56 Name MnuListar
MdiList True
Text Listar Ventanas
Para cambiar el nombre de cada menú hacer clic en menu strip y luego editar
elementos
Aparece el siguiente cuadro

Elija DropDownItems
Hay podria cambiar los nombres

Tambien podria cambiar con el cuadro de propiedades
4. Seleccione el control ToolStrip1 y Clic al botón de abrir diálogo de la propiedad
items, luego añadir nueve botones y configurar sus propiedades , tal como se
meustran en el siguiente cuadro:
En image escoger

ToolBarButton1 Name tbbNuevo
Image …\bitmaps\Tlbr_W95\New.bmp
ToolTipText Nuevo
Tag Nuevo
ToolBarButton2 Name tbbAbrir
ImageIndex \bitmaps\Tlbr_W95\Open.bmp
ToolTipText Abrir
Tag Abrir
ToolBarButton3 Name tbbGuardar
ImageIndex Save.bmp
ToolTipText Guardar
Tag Guardar
ToolBarButton4 Name tbbSeparador1
Style Separator
Tag Separator1
ToolBarButton5 Name tbbCopiar
ImageIndex …\bitmaps\Tlbr_W95\Copy.bmp
ToolTipText Copiar
Tag Copiar
ToolBarButton6 Name tbbCortar
ImageIndex …\bitmaps\Tlbr_W95\Copy.bmp
ToolTipText Cortar
Tag Cortar
ToolBarButton7 Name tbbPegar
ImageIndex …\bitmaps\Tlbr_W95\paste.bmp
ToolTipText Pegar
Tag Pegar
ToolBarButton8 Name tbbSeparador2
Style Separator
Tag Separator2
ToolBarButton9 Name tbbSalir
ImageIndex …\bitmaps\Tlbr_W95\redo.bmp6
ToolTipText Salir
Tag Salir
Al final debe quedar así

5. Seleccione el control StatusStrip1 y Clic al botón de editar elementos luego añadir

tres paneles y configurar sus propiedades , tal como se muestran en el siguiente
cuadro:

StatusBarPanel1 Name sbpNombre
Icon …\Icons\Writing\Book01A.ico
Width
StatusBarPanel2 Name sbpMayuscula
Text CAPS
StatusBarPanel3 Name sbpFechaHora
6. Añadir un segundo formulario; del menú “Project” elegir “Add” Windows Form” ,
escribir como nombre frmDocumento y clic “Open”.
7. Seleccionar el formulario frmDocumento arrastrar un control ContextMenu y 1
RichTextBox, luego configurar sus propiedades, tal como se muestra en el siguiente
cuadro.

Form2 Text Documento
ContextMenuStrip2 Name ContextMenuStrip2
RichTextBox1 Name RichTextBox1
ContextMenu ContextMenuStrip
Dock Fill
8. El diseño del formulario deberia quedar así
9. Regresar al formulario frmEditor y en la ventana explorador de soluciones dar

click en el botón “View Code” copiar el siguiente código
CODIGO DEL FORMULARIO
Imports System.IO 'Usar Path

Public Class Form1
Private intNumDoc As Integer
Private Sub IniciarConfiguracion(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MyBase.Load
Clipboard.SetDataObject("")
sbpFechaHora.Text = Now.ToLongTimeString
sbpFechaHora.ToolTipText = Now.ToLongDateString
End Sub
Private Sub NuevoDocumento(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuNuevo.Click
intNumDoc = intNumDoc + 1
Dim X As New frmDocumento()
X.MdiParent = Me
X.Text = "Documento " & intNumDoc.ToString
sbpNombre.Text = "Documento " & intNumDoc.ToString
X.Show()
End Sub
Private Sub AbrirDocumento(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuAbrir.Click
With OpenFileDialog1 'Dialogo de Abrir
.Title = "Abrir Documento rtf"
.Filter = "Documento rtf|*.rtf"
If .ShowDialog = DialogResult.OK Then
If Me.MdiChildren.Length = 0 Then MnuNuevo.PerformClick()
Dim rtb As RichTextBox = Me.ActiveMdiChild.Controls(0)
rtb.LoadFile(.FileName, RichTextBoxStreamType.RichText)
Me.ActiveMdiChild.Text = Path.GetFileName(.FileName)
sbpNombre.Text = Path.GetFileName(.FileName)
End If
End With
End Sub
Private Sub GuardarDocumento(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuGuardar.Click
If Me.MdiChildren.Length > 0 Then
With SaveFileDialog1 'Dialogo de Guardar
.Title = "Guardar Documento rtf"
.Filter = "Documento rtf|*.rtf"
rtb.SaveFile(.FileName, RichTextBoxStreamType.RichText)
Me.ActiveMdiChild.Text = Path.GetFileName(.FileName)
sbpNombre.Text = Path.GetFileName(.FileName)
End If
End With
End If
End Sub
Private Sub Salir(ByVal sender As System.Object, ByVal e As System.EventArgs)
Handles mnuSalir.Click
Me.Close()
End Sub
Private Sub CopiarTexto(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles mnuCopiar.Click
If rtb.SelectedText <> "" Then Clipboard.SetDataObject(rtb.SelectedText)
End If
End Sub
Private Sub CortarTexto(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles mnuCortar.Click
If rtb.SelectedText <> "" Then
Clipboard.SetDataObject(rtb.SelectedText)
rtb.SelectedText = ""
End If
End If
End Sub
Private Sub PegarTexto(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuPegar.Click
rtb.SelectedText = Clipboard.GetDataObject.GetData("Text")
End If
End Sub
Private Sub CambiarFuente(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuFuente.Click
With FontDialog1 'Dialogo de Fuente
.ShowColor = True
If .ShowDialog() = DialogResult.OK Then
rtb.Font = .Font
rtb.ForeColor = .Color
End If
End With
End If
End Sub
Private Sub CambiarColorFondo(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuFondo.Click
With ColorDialog1 'Dialogo de Colores
rtb.BackColor = .Color
End If
End With
End If
End Sub
Private Sub AbrirCalculadora(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuCalculadora.Click
Process.Start("Calc.exe")
End Sub
Private Sub AbrirBlocNotas(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuBlocDeNotas.Click
Process.Start("Notepad.exe")
End Sub
Private Sub AbrirExplorador(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuExplorador.Click
Process.Start("Explorer.exe")
End Sub
Private Sub AbrirWord(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuWord.Click
Process.Start("Winword.exe")
End Sub
Private Sub AbrirExcel(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuExcel.Click
Process.Start("Excel.exe")
End Sub
Private Sub INTERNET(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuExcel.Click
Process.Start("IEXPLORE.EXE")
End Sub
Private Sub AbrirInternet(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuInternet.Click
Process.Start("IExplore.exe")
End Sub
Private Sub PresentarVentanas(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuCascada.Click, mnuMHorizontal.Click,
mnuMVertical.Click, mnuOIconos.Click
Me.LayoutMdi(sender.TAG)
End Sub
Private Sub MostrarNombre(ByVal sender As Object, ByVal e As System.EventArgs)

Handles MyBase.MdiChildActivate
If Me.ActiveMdiChild Is Nothing Then
sbpNombre.Text = ""
Else
sbpNombre.Text = Me.ActiveMdiChild.Text
End If
End Sub
Private Sub VerHora(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles Timer1.Tick
sbpFechaHora.Text = Now.ToLongTimeString
End Sub
Private Sub ToolStrip1_ItemClicked(ByVal sender As System.Object, ByVal e As
System.Windows.Forms.ToolStripItemClickedEventArgs) Handles
ToolStrip1.ItemClicked
Select Case e.ClickedItem.Tag
Case "Nuevo"
MnuNuevo.PerformClick()
Case "Abrir"
MnuAbrir.PerformClick()
Case "Guardar"
MnuGuardar.PerformClick()
Case "Copiar"
mnuCopiar.PerformClick()
Case "Cortar"
mnuCortar.PerformClick()
Case "Pegar"
MnuPegar.PerformClick()
Case "Salir"
mnuSalir.PerformClick()
End Select
End Sub
Private Sub ListarToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e
As System.EventArgs) Handles Listar.Click
If Me.ActiveMdiChild Is Nothing Then
sbpNombre.Text = ""
Else
sbpNombre.Text = Me.ActiveMdiChild.Text
End If
End Sub
End Class
Ejecute el programa . la aplicación debera quedar asi
Nota clic derecho en el menú strip y clic en insertar elementos estándar

Y automáticamente se inserta los elementos estándar
Lo mismo puede hacer con toolstrip y automáticamente adiciona los controles estándar
Al presionar editar elementos aparece el cuadro
Que nos permite editar los elementos

11.2 TEMAS FRACTALES
FRACTAL De Wikipedia, la enciclopedia libre
En la naturaleza también aparece la geometría

fractal, como en esta romanescu.
Un fractal es un objeto geométrico cuya estructura
básica, fragmentada o irregular, se repite a
diferentes escalas.1 El término fue propuesto por el
matemático Benoît Mandelbrot en 1975 y deriva del
Latín fractus, que significa quebrado o fracturado. Muchas estructuras naturales son de
tipo fractal. La propiedad matemática clave de un objeto genuinamente fractal es que
su dimensión métrica fractal es un número no entero.
Alfombra de Sierpinski De Wikipedia, la enciclopedia libre
La alfombra de Sierpiński es un conjunto fractal descrito por primera vez por Wacław
Sierpiński en 1916.1 Constituye una generalización a dos dimensiones del conjunto de
Cantor. Comparte con él muchas propiedades: también es un conjunto compacto, no
numerable y de medida nula. Su dimensión de Hausdorff-Besicovitch es
Construcción
La construcción de la alfombra de Sierpinski se define de forma recursiva:
1. Comenzamos con un cuadrado.
2. El cuadrado se corta en 9 cuadrados congruentes, y eliminamos el cuadrado
central.
3. El paso anterior vuelve a aplicarse recursivamente a cada uno de los 8
cuadrados restantes.
La alfombra de Sierpinski es el límite de este proceso tras un número infinito de
iteraciones.
Construcción de la alfombra de Sierpinski:
Paso 1 Paso 2 Paso 3 Paso 4 Paso 5
Código en Visual Basic (Ver en la aplicación)

Triángulo de Sierpinski De Wikipedia, la enciclopedia libre

El triángulo de Sierpiński es un fractal que se puede construir a partir de cualquier
triángulo.
(ver aplicación)
CREACION DE UNA MONTAÑA FRACTAL
Considerando los cuatros triangulos
Aleatorizando (modelizacion de terrenos )
( ver en la aplicacion)
ARBOLES CON RECURSIVIDAD
Copo de nieve de Koch
El copo de nieve de Koch, también llamado estrella de

Koch, es una curva cerrada continua pero no
diferenciable en ningún punto descrita por el matemático
sueco Helge von Koch en 1904 en un artículo titulado
"Acerca de una curva continua que no posee tangentes y
obtenida por los métodos de la geometría elemental".1 2
En lenguaje actual, diríamos que es una curva fractal. Su
construcción más simple se realiza mediante un proceso iterativo que se inicia
partiendo en tres un segmento de recta e insertando dos más en el tercero medio a
manera de un triángulo equilátero, el proceso se repite infinidad de veces. La curva de
Koch es un caso particular de curva de De Rham.
Código en Visual Basic ( ver en la aplicacion)
CODIGO EN VISUAL BASIC
CODIGO DEL MODULO 1
Imports System.Drawing
Module Module1
Public Const dx As Single = 0.6
Public nro As Integer
Public ColorPen As Color = Color.FromArgb(255, 0, 0)
Public ColorBrocha As Color = Color.FromArgb(0, 255, 0)
Public ColorFondo As Color = Color.FromArgb(255, 255, 255)
Public Nombre As String
Public grosor As Integer = 1
''***********
Public ancho As Integer = 500
Public alto As Integer = 500
Public ancho1 As Integer = 400
Public alto1 As Integer = 400
Public Cx As Integer = 0
Public Cy As Integer = 0
Public Cx1 As Integer
Public Cy1 As Integer
Public Const alfa As Single = 1.047
Function distancia(ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single,
ByVal y2 As Single)
distancia = Math.Sqrt(Math.Pow(x2 - x1, 2) + Math.Pow(y2 - y1, 2))
End Function
End Module
Public Class Form1
Private Sub GrosorDeLineaToolStripMenuItem_Click(sender As Object, e As
EventArgs) Handles GrosorDeLineaToolStripMenuItem.Click
grosor = InputBox("Ingrese grosor de linea", "Tamaño Linea", 2)
End Sub
Private Sub MnuAlfombraDeSierpinski_Click(sender As Object, e As EventArgs)
Handles MnuAlfombraDeSierpinski.Click
nro = nro + 1
Nombre = "Alfombra de Sierpiński "
FrmAlfombra.MdiParent = Me
FrmAlfombra.Text = Nombre & nro.ToString
FrmAlfombra.Show()
End Sub
Private Sub MnuTriánguloDeSierpinski_Click(sender As Object, e As EventArgs)
Handles MnuTriánguloDeSierpinski.Click
nro = nro + 1
Nombre = "Alfombra de Sierpiński "
frmTriangulo.MdiParent = Me
frmTriangulo.Text = Nombre & nro.ToString
frmTriangulo.Show()
End Sub
Private Sub MnuMontañaFractal_Click(sender As Object, e As EventArgs) Handles
MnuMontañaFractal.Click
nro = nro + 1
Nombre = "Montaña Fractal "
frmMontaña.MdiParent = Me
frmMontaña.Text = Nombre & nro.ToString
frmMontaña.Show()
End Sub
Private Sub MnuArbolFractal_Click(sender As Object, e As EventArgs) Handles

MnuArbolFractal.Click
nro = nro + 1
Nombre = "Arbol Fractal "
FrmArbol.MdiParent = Me
FrmArbol.Text = Nombre & nro.ToString
FrmArbol.Show()
End Sub
Private Sub MnuCopoNieveDeKoch_Click(sender As Object, e As EventArgs)
Handles MnuCopoNieveDeKoch.Click
nro = nro + 1
Nombre = "Copo de nieve de Koch "
frmCopoNieve.MdiParent = Me
frmCopoNieve.Text = Nombre & nro.ToString
frmCopoNieve.Show()
End Sub
Private Sub ColorPencilToolStripMenuItem_Click(sender As Object, e As EventArgs)
Handles MnuColorPencil.Click
ColorDialog1.ShowDialog()
ColorPen = ColorDialog1.Color
End Sub
Private Sub ColorFondoToolStripMenuItem_Click(sender As Object, e As EventArgs)
Handles MnuColorFondo.Click
ColorFondo = ColorDialog1.Color
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
ColorPen = Color.FromArgb(255, 0, 0)
ColorBrocha = Color.FromArgb(255, 255, 255)
ColorFondo = Color.FromArgb(0, 0, 0)
End Sub
Private Sub MnuColorBrocha_Click(sender As Object, e As EventArgs) Handles
MnuColorBrocha.Click
ColorBrocha = ColorDialog1.Color
End Sub
Private Sub MnPresentarVentana(sender As Object, e As EventArgs) Handles
MnCascada.Click, MnuHorizontal.Click, MnuVertical.Click, MnuOrgIconos.Click
Me.LayoutMdi(sender.TAG)
End Sub
End Class
CODIGO DEL FORMULARIO FRMALFOMBRA
Public Class FrmAlfombra

Public grafico1 As Graphics
Public pen1 As Pen
Public brocha1 As SolidBrush
Public colorPen1 As Color
Public colorbrocha1 As Color
Public ColorFondo1 As Color
Dim grosor1 As Integer
Sub CuadroRecursivo(ByVal Cx As Integer, ByVal Cy As Integer, ByVal Ancho As

Integer, ByVal Alto As Integer)
Dim fila As Integer, col As Integer
ancho1 = Ancho / 3 : alto1 = Alto / 3
Cy1 = Cy
For fila = 1 To 3
Cx1 = Cx
For col = 1 To 3
If fila = 2 And col = 2 Then
grafico1.FillRectangle(brocha1, Cx1, Cy1, ancho1, alto1)
Else
' Grafico.DrawRectangle(Pens.Green, Cx1, Cy1, ancho1, alto1)
End If
Cx1 = Cx1 + ancho1
Next
Cy1 = Cy1 + alto1
Next fila
If (Ancho > 10) Then
For fila = 0 To 2
For col = 0 To 2
CuadroRecursivo(Cx + col * Ancho / 3, Cy + fila * Alto / 3, Ancho / 3, Alto / 3)
Next
Next
End If
End Sub
Private Sub frmFractal_Paint(sender As Object, e As PaintEventArgs) Handles

MyBase.Paint
Cx = 10
Cy = 10
grafico1 = CreateGraphics()
pen1 = New Pen(colorPen1, grosor1)
brocha1 = New SolidBrush(ColorBrocha1)
grafico1.Clear(ColorFondo1)
CuadroRecursivo(Cx, Cy, ancho, alto)
End Sub
Private Sub FrmAlfombra_Load(sender As Object, e As EventArgs) Handles

MyBase.Load
Me.Width = alto
Me.Height = alto
colorPen1 = ColorPen
colorbrocha1 = ColorBrocha
ColorFondo1 = ColorFondo
grosor1 = grosor1
End Sub
End Class
CODIGO DEL FORMULARIO FRMTRIANGULO
Public Class frmTriangulo

Dim grafico2 As Graphics
Dim pen2 As Pen
Dim brocha2 As SolidBrush
Dim colorPen2 As Color
Dim colorbrocha2 As Color
Dim ColorFondo2 As Color
Sub triangulo(ByVal px1 As Single, ByVal py1 As Single, ByVal px2 As Single, ByVal
py2 As Single, _
ByVal px3 As Single, ByVal py3 As Single)
Dim px12 As Single, py12 As Single, px13 As Single, py13 As Single, px23 As
Single, py23 As Single
grafico2.DrawLine(pen2, px1, py1, px2, py2)
If (distancia(px1, py1, px2, py2) > 5) Then
px12 = (px1 + px2) / 2.0
px13 = (px1 + px3) / 2.0
px23 = (px2 + px3) / 2.0
py12 = (py1 + py2) / 2.0
py13 = (py1 + py3) / 2.0
py23 = (py2 + py3) / 2.0
triangulo(px1, py1, px12, py12, px13, py13)
End If
End Sub
Private Sub frmTriangulo_Paint(sender As Object, e As PaintEventArgs) Handles

Me.Paint
Dim Px1 As Integer = 300, py1 As Integer = 10, px2 As Integer = 500, py2 As
Integer = 400
Dim px3 As Integer = 100, py3 As Integer = 400
brocha2 = New SolidBrush(colorbrocha2)
triangulo(Px1, py1, px2, py2, px3, py3)
End Sub
Private Sub frmTriangulo_Load(sender As Object, e As EventArgs) Handles
MyBase.Load
Me.Width = ancho
Me.Height = alto
grosor2 = grosor
End Sub
End Class
CODIGO DEL FORMULARIO MONTAÑA FRACTAL
Public Class frmMontaña

Dim pen3 As Pen
Sub trianguloM(ByVal px1 As Single, ByVal py1 As Single, ByVal px2 As Single,
ByVal py2 As Single, ByVal px3 As Single, ByVal py3 As Single)
Dim valor As Integer = 10
Dim px12 As Single, py12 As Single, px13 As Single, py13 As Single
Dim px23 As Single, py23 As Single
If (distancia(px1, py1, px2, py2) > 50) Then
' triangulo del punto1
pen3.Color = ColorFondo3
pen3.Color = colorPen3
px12 = (px1 + px2) / 2.0 - valor + Int(Rnd(2 * valor))
py12 = (py1 + py2) / 2.0 - valor + Int(Rnd(2 * valor))
trianguloM(px12, py12, px23, py23, px13, py13)
End If
End Sub
Private Sub frmMontaña_Paint(sender As Object, e As PaintEventArgs) Handles

Me.Paint
Integer = 400
Dim px3 As Integer = 10, py3 As Integer = 400
'brocha3 = New SolidBrush(ColorBrocha3)
grafico3.Clear(ColorFondo)
Randomize()
trianguloM(Px1, py1, px2, py2, px3, py3)
End Sub
Private Sub frmMontaña_Load(sender As Object, e As EventArgs) Handles

MyBase.Load
Me.Width = alto
Me.Height = alto
grosor3 = grosor
End Sub
End Class
CODIGO DEL FORMULARIO FRMARBOL
Public Class FrmArbol

Dim pen4 As Pen
Sub Arbol(ByVal x As Single, ByVal y As Single, ByVal t As Single, ByVal teta As

Single, ByVal w As Single, ByVal valor As Single)
'// t=largo
Dim x1 As Single, y1 As Single, t1 As Single
If (t > 1) Then '//condición de paro
' If (valor >= 1) Then '//condición de paro
pen4.Width = valor
x1 = x + t * Math.Cos(teta)
y1 = y + t * Math.Sin(teta)
grafico4.DrawLine(pen4, x, y, x1, y1)
t1 = t / 1.8 '1.7
' Se llama recursivamente al sistema}
Arbol(x1, y1, t1, teta - w, w, valor - dx)
Arbol(x1, y1, t1, teta, w, valor - dx)
Arbol(x1, y1, t1, teta + w, w, valor - dx)
End If
End Sub
Private Sub FrmArbol_Paint(sender As Object, e As PaintEventArgs) Handles
Me.Paint
pen4 = New Pen(ColorPen)
brocha4 = New SolidBrush(ColorBrocha)
grafico4.Clear(ColorFondo)
Arbol(150, 300, 120, 3 * Math.PI / 2.0, 0.5, 5)
Arbol(350, 300, 100, 3 * Math.PI / 2.0, 0.4, 4)
Arbol(420, 300, 50, 3 * Math.PI / 2.0, 0.3, 3)
End Sub
Private Sub FrmArbol_Load(sender As Object, e As EventArgs) Handles

MyBase.Load
Me.Width = alto
Me.Height = alto
grosor4 = grosor
End Sub
End Class
CODIGO DEL FORMULARIO COPODE NIEVE
Public Class frmCopoNieve

Dim pen5 As Pen
Sub Fractal(ByVal px1 As Single, ByVal py1 As Single, ByVal px2 As Single, ByVal
py2 As Single)
Dim ax As Single, ay As Single
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single, x3 As Single, y3 As
Single, rx As Single, ry As Single
ax = (px2 - px1) / 3.0
ay = (py2 - py1) / 3.0
pen5.Color = colorPen5
grafico5.DrawLine(pen5, Cx + px1, Cy + py1, Cx + px2, Cy + py2)
x1 = Cx + px1 + ax
y1 = Cy + py1 + ay
rx = ax * Math.Cos(alfa) - ay * Math.Sin(alfa)
ry = ax * Math.Sin(alfa) + ay * Math.Cos(alfa)
x2 = x1 + rx
y2 = y1 + ry
x3 = Cx + px1 + 2 * ax
y3 = Cy + py1 + 2 * ay
grafico5.DrawLine(pen5, x1, y1, x2, y2)
pen5.Color = ColorFondo5
' System.Threading.Thread.Sleep(vel) ' 1 segundo
If distancia(px1, py1, px2, py2) > 10 Then
Fractal(px1 + ax, py1 + ay, px1 + ax + rx, py1 + ay + ry)
Fractal(px1 + ax + rx, py1 + ay + ry, px1 + 2 * ax, py1 + 2 * ay)
Fractal(px1, py1, px1 + ax, py1 + ay)
Fractal(px1 + 2 * ax, py1 + 2 * ay, px2, py2)
End If
End Sub
Private Sub frmCopoNievePaint(sender As Object, e As EventArgs) Handles

MyBase.Paint
Cx = ancho / 2
Cy = alto / 2
pen5 = New Pen(ColorPen, grosor5)
brocha5 = New SolidBrush(colorbrocha5)
grafico5.DrawLine(pen5, Cx, 0, Cx, alto)
grafico5.DrawLine(pen5, 0, Cy, ancho, Cy)
Integer = 0
Dim Px3 As Integer = 100, py3 As Integer = 0
px2 = Px1 * Math.Cos(2 * alfa) - py1 * Math.Sin(2 * alfa)
py2 = Px1 * Math.Sin(2 * alfa) + py1 * Math.Cos(2 * alfa)
Px3 = px2 * Math.Cos(2 * alfa) - py2 * Math.Sin(2 * alfa)
py3 = px2 * Math.Sin(2 * alfa) + py2 * Math.Cos(2 * alfa)
'' pen.Color = Color.Blue
grafico5.DrawLine(pen5, Cx + Px1, Cy + py1, Cx + px2, Cy + py2)
grafico5.DrawLine(pen5, Cx + px2, Cy + py2, Cx + Px3, Cy + py3)
grafico5.DrawLine(pen5, Cx + Px3, Cy + py3, Cx + Px1, Cy + py1)
Fractal(Px1, py1, Px3, py3)
Fractal(Px3, py3, px2, py2)
Fractal(px2, py2, Px1, py1)
End Sub
Private Sub frmCopoNieve_Load_1(sender As Object, e As EventArgs) Handles

MyBase.Load
Me.Width = alto
Me.Height = alto
grosor5 = grosor
End Sub
End Class
FRACTALES DE MALDEBROT
Option Explicit On
Option Strict On
Module Module1
Public brocha As SolidBrush
Public Const limite As Integer = 200
Public Grafico As Graphics
Public nc As Integer = 5
Public nf As Integer = 6 '6
Public Pen As Pen
Public vel As Integer = 10
Public nx As Integer = 100
Public ny As Integer = 100
Public MaxIter As Integer = 10
'/* E s t a b l e c e el tamaño i n i c i a l de l a ventana de v i s u a l i z a c i ó n . */

'Public winWidth As Integer = 500 'Public winHeight As Integer = 500
'// Establace los limites del area rectangular del plano complejo “
Public xComplexMin As Single = -2 ' -200 * 4 '-2.0
Public xComplexMax As Single = 0.5 ' 50 * 8 ' 0.5
Public yComplexMin As Single = -1.25 '-125 * 4 '-1.25
Public yComplexMax As Single = 1.25 '125 * 4 '1.25
Public complexWidth As Single = xComplexMax - xComplexMin
Public complexHeight As Single = yComplexMax - yComplexMin
Public Ex As Single = 100
Public Ey As Single = 100
Public Cx As Single = 300
Public cy As Single = 300
Public Structure Color1
Public r As Integer
Public g As Integer
Public b As Integer
End Structure
Public Structure complexNum
Public x As Single
Public y As Single
End Structure
'/* Calcula el cuadrado de un número c o m p l e j o . */

Function complexSquare(ByVal z As complexNum) As complexNum
Dim zSquare As complexNum
zSquare.x = z.x * z.x - z.y * z.y
zSquare.y = 2 * z.x * z.y
'complexSquare = zSquare
Return zSquare
End Function
Function mandelSqTransf(ByVal z0 As complexNum, ByVal maxIter As Integer) As

Integer
Dim z As complexNum = z0
Dim count As Integer = 0
'/* Sale cuando z * z > 4 */
Dim valor As Single
valor = z.x * z.x + z.y * z.y
While (valor <= 8.0) And (count < maxIter)
z = complexSquare(z)
z.x += z0.x
z.y += z0.y
count += 1
valor = z.x * z.x + z.y * z.y
End While
Return count
End Function
End Module
CODIGO DE FORMULARIO
Option Explicit On
Option Strict On
Imports System.Drawing.Drawing2D
Public Class Form1
Dim Pen As Pen
Dim Grafico As Graphics
Dim brocha As SolidBrush
Sub plotPoint(ByVal zx As Single, ByVal zy As Single)
Grafico.FillRectangle(brocha, Cx + zx * Ex, cy + zy * Ey, 4, 4)
End Sub
Sub mandelbrot(ByVal nx As Integer, ByVal ny As Integer, ByVal maxIter As Integer)

Dim zx As Single
Dim zy As Single
Dim z, zlncr As complexNum
Dim ptColor As Color1
Dim iterCount As Integer
zlncr.x = complexWidth / nx
zlncr.y = complexHeight / ny
For z.x = xComplexMin To xComplexMax Step zlncr.x
For z.y = yComplexMin To yComplexMax Step zlncr.y
iterCount = mandelSqTransf(z, maxIter)
If (iterCount >= maxIter) Then
'/* Establece el color de los p u n t o s en n e g r o . */
ptColor.r = 0
ptColor.g = 0
ptColor.b = 0
Else
If (iterCount > (maxIter / 8)) Then
'/* Establece el color de los puntos en naranja . */
ptColor.r = 255
ptColor.g = 125
ptColor.b = 0
Else
'/* E s t a b l e c e el c o l o r de l o s p u n t o s en r o j o . */
ptColor.r = 255 '1.0
ptColor.g = 0
ptColor.b = 0
Else
'/* E s t a b l e c e el c o l o r de l o s puntos en azul o s c u r o . */
ptColor.r = 128 ' 0.5
ptColor.r = 0
ptColor.g = 0
Else
'/* E s t a b l e c e el c o l o r de l o s puntos en a m a r i l l o . */
ptColor.r = 255
ptColor.g = 255
ptColor.b = 0
Else
'/* E s t a b l e c e el c o l o r de l o s puntos en * verde o s c u r o . */
ptColor.r = 0
ptColor.b = 0
ptColor.g = 80 ' 0.3
Else
'/* E s t a b l e c e e l c o l o r de l os * puntos en c í a n . */
ptColor.r = 0
ptColor.g = 255
ptColor.b = 255
End If
End If
End If
End If
End If
End If
brocha.Color = Drawing.Color.FromArgb(ptColor.r, ptColor.g, ptColor.b)
zx = z.x
zy = z.y
plotPoint(zx, zy)
Next
Next
End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As

Grafico = PictureBox1.CreateGraphics
Pen = New Pen(Color.Red, 2)
brocha = New SolidBrush(Color.FromArgb(0, 255, 0))
End Sub
Private Sub BtnFractal_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles BtnFractal.Click
btnIniciarTodo_Click(sender, e)
mandelbrot(nx, ny, MaxIter)
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles BtnIniciar.Click
DataGridView1.ColumnCount = 2
DataGridView1.RowCount = 7
DataGridView1.Columns(1).Width = 70
For fila = 0 To DataGridView1.RowCount - 1
DataGridView1.Rows(fila).HeaderCell.Value = fila.ToString
Next
DataGridView1.Columns(0).HeaderText = "PARAMETROS"
DataGridView1.Columns(1).HeaderText = "VALOR"
DataGridView1.Rows(0).Cells(0).Value = "Nx"
DataGridView1.Rows(0).Cells(1).Value = nx
DataGridView1.Rows(1).Cells(0).Value = "Ny"
DataGridView1.Rows(1).Cells(1).Value = ny
DataGridView1.Rows(2).Cells(0).Value = "MaxIter"
DataGridView1.Rows(2).Cells(1).Value = MaxIter
DataGridView1.Rows(3).Cells(0).Value = "Cx"
DataGridView1.Rows(3).Cells(1).Value = Cx
DataGridView1.Rows(4).Cells(0).Value = "Cy"
DataGridView1.Rows(4).Cells(1).Value = Cy
DataGridView1.Rows(5).Cells(0).Value = "Ex"
DataGridView1.Rows(5).Cells(1).Value = Ex
DataGridView1.Rows(6).Cells(0).Value = "Ey"
DataGridView1.Rows(6).Cells(1).Value = Ey
End Sub
Private Sub btnIniciarTodo_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles btnIniciarTodo.Click
nx = CInt(DataGridView1.Rows(0).Cells(1).Value)
ny = CInt(DataGridView1.Rows(1).Cells(1).Value)
MaxIter = CInt(DataGridView1.Rows(2).Cells(1).Value)
Cx = CSng(DataGridView1.Rows(3).Cells(1).Value)
cy = CSng(DataGridView1.Rows(4).Cells(1).Value)
Ex = CSng(DataGridView1.Rows(5).Cells(1).Value)
Ey = CSng(DataGridView1.Rows(6).Cells(1).Value)
End Sub
Private Sub Button1_Click_1(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles BtnBorrar.Click
Grafico.Clear(Color.White)
End Sub
End Class
11.3 MONTAÑA FRACTAL

Imports System.IO
Module Module1
Public Structure Puntos
Public X As Single
Public Y As Single
Public Z As Single
Public Rela As Integer
End Structure
Public modelo As Integer = 0
Public AnguloX As Integer = 0
Public AnguloY As Integer = 0
Public AnguloZ As Integer = 0
Public Const maximo As Integer = 7000
Public P(maximo) As Puntos
Public P1(maximo) As Puntos
Public pincel As Pen
Public Brocha As SolidBrush
Public valor As Single = 100 ' mas alto la monta
Public factor As Single = 0.5 ' 0.5 ' se relaciona con el valor factor proyeccion
Public Ndivisiones As Integer = 5
Public ContPuntos As Integer
Public MiFuente As New Font("Verdana", 24, FontStyle.Bold)
Public Tx As Single = 0
Public Ty As Single = 0
Public tz As Single = 0
Public Ez As Single = 1
Public VEx As Single = 0.1
Public VEy As Single = 0.1
Public VEz As Single = 0.1
Public CARAS(maximo, 4) As Integer
Public Normales(maximo, 4) As Single
Public D As Single = 1000
Public contcaras As Integer
Public ver1 As Integer, ver2 As Integer, ver3 As Integer, ver4 As Integer
Public Modo As Integer = 0
Public NombreArchivoPuntos = "E:\datos\puntos4x28.txt"
Public NombreArchivoCaras = "E:\datos\caras4x28.txt"
Sub RotacionXYZ(P() As Puntos, ByVal AnguloX As Single, ByVal AnguloY As
Single, ByVal anguloZ As Single, np As Integer)
Dim x1 As Single, y1 As Single, z1 As Single
Dim fila As Integer = 0
Dim arx = AnguloX * Math.PI / 180
For fila = 0 To np - 1
x1 = P(fila).X
y1 = P(fila).Y
z1 = P(fila).Z
x2 = x1
y2 = CSng(y1 * Math.Cos(arx) - z1 * Math.Sin(arx))
z2 = CSng(y1 * Math.Sin(arx) + z1 * Math.Cos(arx))
P(fila).X = x2
P(fila).Y = y2
P(fila).Z = z2
Next
Dim ary = AnguloY * Math.PI / 180
x1 = P(fila).X
y1 = P(fila).Y
z1 = P(fila).Z
x2 = CSng(x1 * Math.Cos(ary) - z1 * Math.Sin(ary))

y2 = y1
z2 = CSng(-x1 * Math.Sin(ary) + z1 * Math.Cos(ary))
P(fila).X = x2
P(fila).Y = y2
P(fila).Z = z2
Next
REM rotacion Z
Dim arz = anguloZ * Math.PI / 180
x1 = P(fila).X
y1 = P(fila).Y
z1 = P(fila).Z
x2 = CSng(x1 * Math.Cos(arz) - y1 * Math.Sin(arz))
y2 = CSng(x1 * Math.Sin(arz) + y1 * Math.Cos(arz))
z2 = z1
P(fila).X = x2
P(fila).Y = y2
P(fila).Z = z2
Next
End Sub
Sub TraslacionXYZ(P() As Puntos, ByVal tx As Single, ByVal ty As Single, ByVal tz
As Single, nf As Integer)
Dim fila As Integer
For fila = 0 To nf - 1
P(fila).X = P(fila).X + tx
P(fila).Y = P(fila).Y + ty
P(fila).Z = P(fila).Z + tz
Next
End Sub
Sub EscaladoXYZ(P() As Puntos, ByVal tx As Single, ByVal ty As Single, ByVal tz As
Single, nf As Integer)
Dim fila As Integer
P(fila).X = P(fila).X * ex
P(fila).Y = P(fila).Y * ey
P(fila).Z = P(fila).Z * ez
Next
End Sub
Sub CopiarVector(ByVal A() As Puntos, ByRef B() As Puntos, ByVal n As Integer)
Dim fila As Integer
For fila = 0 To n
B(fila) = A(fila)
Next
End Sub
Sub ObtenerNormales()
Dim Pe As Single, R As Single
Dim AX As Single, Ay As Single, Az As Single, Bx As Single, By As Single, Bz As
Single
Dim NX As Single, Ny As Single, Nz As Single, Nx1 As Single, Ny1 As Single, Nz1
As Single
Form1.ListBox1.Items.Add("Normales")
For fila = 0 To contcaras - 1
x1 = P1(CARAS(fila, 0)).X
y1 = P1(CARAS(fila, 0)).Y
z1 = P1(CARAS(fila, 0)).Z
AX = x2 - x1
Ay = y2 - y1
Az = z2 - z1
Bx = x3 - x2
By = y3 - y2
Bz = z3 - z2
NX = Ay * Bz - Az * By
Ny = AX * Bz - Az * Bx
Nz = AX * By - Ay * Bx
'PRODUCTO(CRUZ)
R = Math.Sqrt(NX * NX + Ny * Ny + Nz * Nz)
If R > 0 Then
Nx1 = NX / R
Else
Nx1 = 1000
End If
If R > 0 Then
Ny1 = Ny / R
Else
Ny1 = 1000
End If
If R > 0 Then
Nz1 = Nz / R
Else
Nz1 = 1000
End If
Pe = Nx1 * 0 + Ny1 * 0 + Nz1 * D
Normales(fila, 0) = Nx1
Normales(fila, 1) = Ny1
Normales(fila, 2) = Nz1
Normales(fila, 3) = Pe
Form1.ListBox1.Items.Add("normal" & Normales(fila, 2))
Next
End Sub
Sub RecuperarPuntos(ByVal nombrearchivo As String, P() As Puntos, ByRef nf As
Integer)
Dim srLector As StreamReader
srLector = New StreamReader(nombrearchivo)
Dim fila As Integer = 0, col As Integer
Dim cadena As String = ""
Dim subcadena As String
Dim pos As Integer = 0
Dim inicio As Integer = 1
cadena = srLector.ReadLine()
Do While Not (cadena Is Nothing)
cadena = cadena & Chr(9)
inicio = 1
For col = 0 To 4
pos = InStr(inicio, cadena, Chr(9))
subcadena = Mid(cadena, inicio, pos - inicio)
Select Case col
Case 0 : P(fila).nro = CInt(subcadena)
Case 1 : P(fila).X = CSng(subcadena)
Case 2 : P(fila).Y = CSng(subcadena)
Case 3 : P(fila).Z = CSng(subcadena)
Case 4 : P(fila).Rela = CInt(subcadena)
P(fila).nro = subcadena
End Select
inicio = pos + 1
Next
fila = fila + 1
Loop
nf = fila - 1
Console.WriteLine("Archivo {0} leido satisfactoriamente", nombrearchivo)
srLector.Close()
End Sub
Sub RecuperarCaras(ByVal nombrearchivo As String, P(,) As Integer, ByRef nf As

Integer)
inicio = 1
For col = 0 To 3
Select Case col
Case 0 : CARAS(fila, 0) = CInt(subcadena)
End Select
inicio = pos + 1
Next
fila = fila + 1
Loop
nf = fila - 1
srLector.Close()
End Sub
End Module
Option Explicit On
Imports System.IO
Public Class Form1
Sub Iniciar()
Dim fila As Integer
For fila = 1 To 5
DataGridView1.Columns(fila).Width = 50
Next
Next
DataGridView1.Columns(1).HeaderText = "UNIDAD"
DataGridView1.Columns(2).HeaderText = "EjeX"
DataGridView1.Columns(3).HeaderText = "Eje Y"
DataGridView1.Columns(4).HeaderText = "Eje Z"
DataGridView1.Columns(5).HeaderText = "D o W"
DataGridView1.Rows(0).Cells(0).Value = "ROTACION EJE"

DataGridView1.Rows(0).Cells(1).Value = "Grados"
DataGridView1.Rows(0).Cells(2).Value = AnguloX
DataGridView1.Rows(0).Cells(3).Value = AnguloY
DataGridView1.Rows(0).Cells(4).Value = AnguloZ
DataGridView1.Rows(1).Cells(0).Value = "TRASLACION EJE"

DataGridView1.Rows(1).Cells(1).Value = "Unidades"
DataGridView1.Rows(1).Cells(2).Value = Tx
DataGridView1.Rows(1).Cells(3).Value = Ty
DataGridView1.Rows(1).Cells(4).Value = tz
DataGridView1.Rows(1).Cells(5).Value = D
DataGridView1.Rows(2).Cells(0).Value = "ESCALADO EJE"

DataGridView1.Rows(2).Cells(4).Value = Ez
DataGridView1.Rows(3).Cells(0).Value = "Modo (0,1) vel modelo Nro Divisiones"

DataGridView1.Rows(3).Cells(2).Value = Modo
DataGridView1.Rows(3).Cells(3).Value = vel
DataGridView1.Rows(3).Cells(4).Value = modelo
DataGridView1.Rows(3).Cells(5).Value = Ndivisiones
End Sub
Sub Rectangulo(ByVal px1 As Single, ByVal py1 As Single, ByVal pz1 As Single, _
ByVal px2 As Single, ByVal py2 As Single, ByVal pz2 As Single, _
ByVal ndivisiones As Integer, ByVal valor As Single, _
ByVal ver1 As Integer, ByVal ver2 As Integer, ByVal ver3 As Integer, ByVal ver4
As Integer)
Dim v1 As Integer, v2 As Integer, v3 As Integer, v4 As Integer
Dim v12 As Integer, v23 As Integer, v34 As Integer, v14 As Integer
Dim vmedio As Integer
Dim px12 As Single, py12 As Single, pz12 As Single
Dim xmed As Single, ymed As Single, zmed As Single
Dim puntocentral As Integer
If (ndivisiones > 1) Then
xmed = (px1 + px2 + px3 + px4) / 4.0
ymed = (py1 + py2 + py3 + py4) / 4.0
'zmed = (pz1 + pz2 + pz3 + pz4) / 4.0 + Int(Rnd() * valor)
zmed = (pz1 + pz2 + pz3 + pz4) / 4.0 - valor + Int(Rnd() * 2 * valor)
ContPuntos = ContPuntos + 1
puntocentral = ContPuntos
P(ContPuntos).nro = ContPuntos
P(ContPuntos).X = xmed
P(ContPuntos).Y = ymed
P(ContPuntos).Z = zmed
P(ContPuntos).Rela = puntocentral
vmedio = puntocentral
px12 = (px1 + px2) / 2.0
px23 = (px2 + px3) / 2.0
px34 = (px3 + px4) / 2.0
px14 = (px1 + px4) / 2.0
py12 = (py1 + py2) / 2.0

py23 = (py2 + py3) / 2.0
py34 = (py3 + py4) / 2.0
py14 = (py1 + py4) / 2.0
pz12 = (pz1 + pz2) / 2.0

pz23 = (pz2 + pz3) / 2.0
pz34 = (pz3 + pz4) / 2.0
pz14 = (pz1 + pz4) / 2.0
P(ContPuntos).X = px12
P(ContPuntos).Y = py12
P(ContPuntos).Z = pz12
v12 = ContPuntos
v23 = ContPuntos
' CARAS(ContCaras).P3 = P(ContPuntos).nro
v34 = ContPuntos
v14 = ContPuntos
v1 = ver1
v2 = ver2
v3 = ver3
v4 = ver4
Rectangulo(px1, py1, pz1, px12, py12, pz12, xmed, ymed, zmed, px14, py14,
pz14, ndivisiones - 1, valor * factor, v1, v12, vmedio, v14)
Rectangulo(px12, py12, pz12, px2, py2, pz2, px23, py23, pz23, xmed, ymed,
zmed, ndivisiones - 1, valor * factor, v12, v2, v23, vmedio)
Rectangulo(xmed, ymed, zmed, px23, py23, pz23, px3, py3, pz3, px34, py34,
pz34, ndivisiones - 1, valor * factor, vmedio, v23, v3, v34)
Rectangulo(px14, py14, pz14, xmed, ymed, zmed, px34, py34, pz34, px4, py4,
pz4, ndivisiones - 1, valor * factor, v14, vmedio, v34, v4)
Else
If ndivisiones = 1 Then
CARAS(contcaras, 0) = ver1
contcaras = contcaras + 1
End If
End If
End Sub
Sub graficarCara(ByVal contcaras As Integer)
Dim X1 As Single, y1 As Single, z1 As Single
Dim X2 As Single, y2 As Single, z2 As Single
Dim Figura(3) As Point
Dim col As Integer
Dim color1 As Integer
For fila = 0 To contcaras - 1
For col = 0 To 2
X1 = P1(CARAS(fila, col)).X
y1 = P1(CARAS(fila, col)).Y
z1 = P1(CARAS(fila, col)).Z
X2 = P1(CARAS(fila, col + 1)).X
y2 = P1(CARAS(fila, col + 1)).Y
z2 = P1(CARAS(fila, col + 1)).Z
px1 = (X1 * D) / (D + z1)
py1 = (y1 * D) / (D + z1)
px2 = (X2 * D) / (D + z2)
py2 = (y2 * D) / (D + z2)
Figura(col).X = px1
Figura(col).Y = py1
Next
Figura(3).X = px2
Figura(3).Y = py2
If Normales(fila, 2) > 0 Then 'solo dibuja si el normal es mayor que 0
Select Case Modo
Case 0
Grafico.DrawPolygon(pincel, Figura)
Case 1
color1 = Normales(fila, 2) * 255
Select Case modelo
Case 0 ' gris
Brocha.Color = Color.FromArgb(color1, color1, color1)
Case 1 ' rojo
Brocha.Color = Color.FromArgb(color1, 0, 0)
Case 2 ' verde
Brocha.Color = Color.FromArgb(0, color1, 0)
Case 3 ' azul
Brocha.Color = Color.FromArgb(0, 0, color1)
Case 4 ' rojo-verde
Brocha.Color = Color.FromArgb(255 - color1, color1, 0)
Case 5 ' verde-rojo
Brocha.Color = Color.FromArgb(color1, 255 - color1, 0)
Case 6 ' amarillo -azul
Brocha.Color = Color.FromArgb(color1, color1, 255 - color1)
Brocha.Color = Color.FromArgb(255 - color1, 255 - color1, 255 - color1)
End Select
Grafico.FillPolygon(Brocha, Figura, FillMode.Alternate)
Case 2
color1 = Normales(fila, 2) * 255
Select Case modelo
Case 0 ' gris
Brocha.Color = Color.FromArgb(color1, color1, color1)
Case 1 ' rojo
Brocha.Color = Color.FromArgb(color1, 0, 0)
Case 2 ' verde
Brocha.Color = Color.FromArgb(0, color1, 0)
Case 3 ' azul
Brocha.Color = Color.FromArgb(0, 0, color1)
Case 4 ' rojo-verde
Brocha.Color = Color.FromArgb(255 - color1, color1, 0)
Case 5 ' verde-rojo
Brocha.Color = Color.FromArgb(color1, 255 - color1, 0)
Brocha.Color = Color.FromArgb(color1, color1, 255 - color1)
Brocha.Color = Color.FromArgb(255 - color1, 255 - color1, 255 - color1)
End Select
Grafico.FillPolygon(Brocha, Figura, FillMode.Alternate)
Grafico.DrawPolygon(pincel, Figura)
End Select
End If
' Grafico.DrawLine(pincel, px1, py1, px2, py2)
Next
End Sub
Dim col As Integer
PictureBox1.Width = ancho + 10
PictureBox1.Height = alto + 10
PictureBox1.BackColor = ColorFondo
MiFuente = New Font("arial", 11, FontStyle.Bold)
Brocha = New SolidBrush(Color.Red)
pincel = New Pen(Color.Blue, 1)
Iniciar()
For col = 0 To 4
DataGridView2.Columns(col).Width = 60
Next
End Sub
Private Sub MnuMontaña_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles btnMontaña.Click
Dim i, j As Integer
Grafico.Clear(Color.Black)
Randomize()
Dim Px1 As Integer = 100, py1 As Integer = 100, pz1 As Integer = 10
Dim px2 As Integer = 600, py2 As Integer = 100, pz2 As Integer = 10
contcaras = 0
ver1 = 0
ver2 = 1
ver3 = 2
ver4 = 3
P(0).nro = 0 : P(0).X = Px1 : P(0).Y = py1 : P(0).Z = pz1 : P(0).Rela = 1
P(1).nro = 1 : P(1).X = px2 : P(1).Y = py2 : P(1).Z = pz2 : P(1).Rela = 2
ContPuntos = 3
ListBox1.Items.Clear()
ListBox1.Items.Add("CANTIDAD de divisiones " & Ndivisiones)
Randomize()
Rectangulo(Px1, py1, pz1, px2, py2, pz2, px3, py3, pz3, px4, py4, pz4,
Ndivisiones, valor, ver1, ver2, ver3, ver4)
ListBox1.Items.Add("CANTIDAD DE Caras " & contcaras)
ListBox1.Items.Add("CANTIDAD DE puntos " & ContPuntos)
For i = 0 To ContPuntos
ListBox1.Items.Add("Punto Nro" & P(i).nro & " X " & P(i).X & " Y " & P(i).Y & " Z "
& P(i).Z & "rela " & P(i).Rela)
Next
pincel.Color = Color.Red
Dim swEscritor As StreamWriter
swEscritor = New StreamWriter("E:\DATOS\FRACTAL.txt")
swEscritor.WriteLine("{0}{1}{2}{3}{4}{5}{6}{7}{8}", P(i).nro, Chr(9), P(i).X, Chr(9),
P(i).Y, Chr(9), P(i).Z, Chr(9), P(i).Rela)
Next
swEscritor.Close()
swEscritor = New StreamWriter("E:\DATOS\CARAS.txt")
For i = 0 To contcaras
For j = 0 To 3
swEscritor.Write("{0} {1}", CARAS(i, j), Chr(9))
Next
swEscritor.WriteLine()
Next
swEscritor.Close()
CopiarVector(P, P1, ContPuntos)
ObtenerNormales()
graficarCara(contcaras)
End Sub
Private Sub MnGraficar_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles btnMontaña.Click
End Sub
Private Sub BtnIniciarTodo_Click(sender As Object, e As EventArgs) Handles

BtnIniciarTodo.Click
AnguloX = DataGridView1.Rows(0).Cells(2).Value
AnguloY = DataGridView1.Rows(0).Cells(3).Value
AnguloZ = DataGridView1.Rows(0).Cells(4).Value
Tx = DataGridView1.Rows(1).Cells(2).Value
Ty = DataGridView1.Rows(1).Cells(3).Value
tz = DataGridView1.Rows(1).Cells(4).Value
D = DataGridView1.Rows(1).Cells(5).Value
Ex = DataGridView1.Rows(2).Cells(2).Value
Ey = DataGridView1.Rows(2).Cells(3).Value
Ez = DataGridView1.Rows(2).Cells(4).Value
Modo = DataGridView1.Rows(3).Cells(2).Value
vel = DataGridView1.Rows(3).Cells(3).Value
modelo = DataGridView1.Rows(3).Cells(4).Value
Ndivisiones = DataGridView1.Rows(3).Cells(5).Value

RotacionXYZ(P1, AnguloX, AnguloY, AnguloZ, ContPuntos)
TraslacionXYZ(P1, Tx, Ty, tz, ContPuntos)
EscaladoXYZ(P1, Ex, Ey, Ez, ContPuntos)
End Sub
Sub MostrarPuntos(np As Integer)

Dim fila As Integer
DataGridView2.Rows(fila).Cells(0).Value = P(fila).nro
DataGridView2.Rows(fila).Cells(1).Value = P(fila).X
DataGridView2.Rows(fila).Cells(2).Value = P(fila).Y
DataGridView2.Rows(fila).Cells(3).Value = P(fila).Z
DataGridView2.Rows(fila).Cells(4).Value = P(fila).Rela
Next
End Sub
Private Sub MostrarCaras(np As Integer)

Dim fila As Integer
DataGridView2.Rows(fila).Cells(0).Value = CARAS(fila, 0)
Next
End Sub
Sub btnAbrir_Click(sender As Object, e As EventArgs) Handles btnAbrir.Click
RecuperarPuntos(NombreArchivoPuntos, P, ContPuntos)
' DataGridView2.ColumnCount = 5
' DataGridView2.RowCount = ContPuntos
' MostrarPuntos(ContPuntos) ' muestra los datos en el datagrid view
RecuperarCaras(NombreArchivoCaras, CARAS, contcaras)
DataGridView2.RowCount = contcaras
MostrarCaras(contcaras) ' muestra los datos en el datagrid view
ListBox1.Items.Add("CANTIDAD DE Caras " & contcaras)
ListBox1.Items.Add("CANTIDAD DE puntos " & ContPuntos)
ListBox1.Items.Add("Punto Nro" & P(i).nro & " X " & P(i).X & " Y " & P(i).Y & " Z
" & P(i).Z & "rela " & P(i).Rela)
Next
ObtenerNormales()
End Sub
Private Sub btnBorrar_Click(sender As Object, e As EventArgs) Handles

btnBorrar.Click
End Sub
Private Sub BtnGraficar_Click(sender As Object, e As EventArgs) Handles
BtnGraficar.Click
End Sub
Private Sub txtRotacion_KeyDown(sender As Object, e As KeyEventArgs) Handles

txtRotacion.KeyDown
Select Case e.KeyCode
Case 65 ' A rotacion inverso de X
If AnguloX >= -3600 Then
AnguloX = AnguloX - 1
Else
AnguloX = 3600
End If
Case 66 ' B Inverso De Y
If AnguloY >= -3600 Then
AnguloY = AnguloY - 1
Else
AnguloY = 3600
End If
Case 67 ' C ROTACION Inverso de C

If AnguloZ >= -36000 Then
AnguloZ = AnguloZ - 1
Else
AnguloZ = 3600
End If
Case 88 ' ROTACION EJE X

If AnguloX <= 3600 Then
AnguloX = AnguloX + 1
Else
AnguloX = 0
End If
Case 89 ' ROTACION EJE Y

If AnguloY <= 3600 Then
AnguloY = AnguloY + 1
Else
AnguloY = 0
End If
Case 90 ' ROTACION EJE Z
If AnguloZ <= 3600 Then
AnguloZ = AnguloZ + 1
Else
AnguloZ = 0
End If
End Select
BtnIniciarTodo_Click(sender, e)
txtRotacion.Text = ""
End Sub
Private Sub txtTraslacion_KeyDown(sender As Object, e As KeyEventArgs) Handles
txtTraslacion.KeyDown
Case 65 ' A inverso de X
If Tx >= -limite Then
Tx = Tx - 1
Else
Tx = limite
End If
If Ty >= -limite Then
Ty = Ty - 1
Else
Ty = limite
End If
Case 67 ' C traslacion Inverso de C

If tz >= -limite Then
tz = tz - 1
Else
tz = limite
End If

If Tx <= limite Then
Tx = Tx + 1
Else
Tx = -limite
End If
Case 89 ' TRASLACION TROTACION EJE Y
If Ty <= limite Then
Ty = Ty + 1
Else
Ty = -limite
End If
If tz <= limite Then
tz = tz + 1
Else
tz = -limite
End If
End Select
DataGridView1.Rows(1).Cells(2).Value = Tx
DataGridView1.Rows(1).Cells(3).Value = Ty
'*************
txtTraslacion.Text = ""
End Sub
Private Sub txtescalado_KeyDown(sender As Object, e As KeyEventArgs) Handles

txtescalado.KeyDown
If Ex >= -limite Then
Ex = Ex - VEx
Else
Ex = limite
End If
If Ey >= -limite Then
Ey = Ey - VEy
Else
Ey = limite
End If

If Ez >= -limite Then
Ez = Ez - VEz
Else
Ez = limite
End If
Case 88 ' ESCALADO EJE X
If Ex <= limite Then
Ex = Ex + VEx
Else
Ex = -limite
End If

If Ey <= limite Then
Ey = Ey + VEy
Else
Ey = -limite
End If
Case 90 ' escalado eJE Z
If Ez <= limite Then
Ez = Ez + VEz
Else
Ez = -limite
End If
End Select
txtescalado.Text = ""
End Sub
Private Sub btnAuto_Click(sender As Object, e As EventArgs) Handles btnAuto.Click

Timer1.Start()
End Sub
Private Sub BtnDetener_Click(sender As Object, e As EventArgs) Handles
BtnDetener.Click
Timer1.Stop()
End Sub
Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick

Else
AnguloY = AnguloX + 1
Else
Else
AnguloX = 0
End If
End If
End If
End Sub
End Class
TRIANGULACION DE DELAUNAY Y VORONOI ( aumentar opción para grafico de

voronoi)
Imports System.IO
Module Module2
'Public NombreArchivo As String = "E:\datos\puntos6.txt"
Public NombreArchivo As String = "E:\datos\puntos20.txt"
Public Const Maxfilas As Integer = 200
Public Const Maxcol As Integer = 200
Public Const Maxpuntos As Integer = 2000
Public camino As Integer = 0
Public np As Integer = 20
Public np1 As Integer = 0
Public A(Maxfilas, Maxcol) As Integer
Public B(Maxfilas, Maxcol) As Integer
Public X(Maxpuntos) As Integer
Public Y(Maxpuntos) As Integer
Public VX(Maxpuntos) As Integer
Public VY(Maxpuntos) As Integer
Public relleno(Maxpuntos) As Integer
Public nf As Integer = 100
Public cx As Integer = 2
Public cy As Integer = 2
Public tam As Integer = 40
Sub IniciarPuntosMatriz(ByRef A(,) As Integer, X() As Integer, Y() As Integer, Z() As
Integer, np As Integer)
Dim fila As Integer
A(Y(fila), X(fila)) = Z(fila)
Next
End Sub
Sub IniciarMatriz(ByVal A(,) As Integer, ByVal nf As Integer, ByVal nc As Integer,
valor As Integer)
Dim fila, col As Integer
For col = 0 To nc - 1
A(fila, col) = valor
Next
Next
End Sub
Sub MatrizVectorXYZ(ByVal A(,) As Integer, ByRef X() As Integer, ByRef Y() As
Integer, ByRef Z() As Integer, nf As Integer)
Dim fila As Integer
X(fila) = A(fila, 0)
Y(fila) = A(fila, 1)
Z(fila) = A(fila, 2)
Next
End Sub
Sub VerPantalla(ByVal cx As Integer, ByVal cy As Integer, ByVal A(,) As Integer,
ByVal nf As Integer, ByVal nc As Integer)
Console.SetCursorPosition(cx + col, cy + fila)
Console.ForegroundColor = A(fila, col)
Console.Write("{0}", Hex(A(fila, col)))
Next
Next
End Sub
Sub crecerCirculo(ByVal A(,) As Integer, ByVal X() As Integer, ByVal Y() As Integer,
ByVal nf As Integer, _
ByVal nc As Integer, ByVal relleno() As Integer, ByVal r As Single, ByVal np As Integer)
Dim x1 As Integer, y1 As Integer, k As Integer
For k = 0 To np - 1
For y1 = CInt(Y(k) - r) To CInt(Y(k) + r)
For x1 = CInt(X(k) - r) To CInt(X(k) + r)
If (Math.Pow(x1 - X(k), 2) + Math.Pow(y1 - Y(k), 2) <= r * r) And (x1 > 0)
And (x1 < Maxcol) And (y1 > 0) And (y1 < Maxfilas) Then
If (A(y1, x1) = 0) Then
A(y1, x1) = relleno(k)
End If
End If
Next
Next
Next
End Sub
Sub MostrarVectores(Vx() As Integer, Vy() As Integer, Ne As Integer)
Dim fila As Integer
For fila = 0 To Ne - 1
Console.WriteLine("{0} {1} {2} {3} {4} ", fila, vbTab, Vx(fila), vbTab, Vy(fila))
Next
End Sub
Sub GrabarVectores(Vx() As Integer, Vy() As Integer, Ne As Integer)
Dim fila As Integer
Dim archivo As StreamWriter
archivo = New StreamWriter("E:\datos\delaunay.txt")
archivo.WriteLine("{0} {1} {2} {3} {4} ", fila, vbTab, Vx(fila), vbTab, Vy(fila))
Next
archivo.Close()
End Sub
Function EncontrarValor(VX() As Integer, VY() As Integer, np As Integer, valor1 As
Integer, valor2 As Integer)
Dim res As Integer = 0
Dim fila As Integer
If valor1 = VX(fila) And valor2 = VY(fila) Then
res = 1
Exit For
End If
Next
Return res
End Function
Sub EncontrarPares(ByRef A(,) As Integer, ByVal nf As Integer, ByVal nc As Integer,
VX() As Integer, VY() As Integer, ByRef np1 As Integer, relleno1 As
Integer)
Dim R1 As Integer
Dim R2 As Integer
Dim cont As Integer = np1
If A(fila, col) = relleno1 Then
If A(fila, col + 1) <> camino And A(fila, col + 1) <> relleno1 Then
R1 = EncontrarValor(VX, VY, cont, relleno1, A(fila, col + 1))
R2 = EncontrarValor(VX, VY, cont, A(fila, col + 1), relleno1)
If R1 = 0 And R2 = 0 Then
VX(cont) = relleno1
VY(cont) = A(fila, col + 1)
cont = cont + 1
End If
End If
If A(fila, col - 1) <> camino And A(fila, col - 1) <> relleno1 Then
R1 = EncontrarValor(VX, VY, cont, relleno1, A(fila, col - 1))
R2 = EncontrarValor(VX, VY, cont, A(fila, col - 1), relleno1)
VX(cont) = relleno1
VY(cont) = A(fila, col - 1)
cont = cont + 1
End If
End If
If A(fila + 1, col) <> camino And A(fila + 1, col) <> relleno1 Then
R1 = EncontrarValor(VX, VY, cont, relleno1, A(fila + 1, col))
R2 = EncontrarValor(VY, VX, cont, relleno1, A(fila + 1, col))
VX(cont) = relleno1
VY(cont) = A(fila + 1, col)
cont = cont + 1
End If
End If
If A(fila - 1, col) <> camino And A(fila - 1, col) <> relleno1 Then
R1 = EncontrarValor(VX, VY, cont, relleno1, A(fila - 1, col))
R2 = EncontrarValor(VY, VX, cont, relleno1, A(fila - 1, col))
VX(cont) = relleno1
VY(cont) = A(fila - 1, col)
cont = cont + 1
End If
End If
End If
Next
Next
np1 = cont
End Sub
Sub JuegoVida(ByRef A(,) As Integer, ByVal nf As Integer, ByVal nc As Integer)
Dim B(Maxfilas, Maxcol) As Integer
Dim relleno1 As Integer
IniciarMatriz(B, nf, nc, 0)
Dim fila, col, vecinos, x1, y1, x2, y2, fila1, col1 As Integer
For k = 0 To np - 1
relleno1 = relleno(k)
vecinos = 0
If fila > 1 Then
y1 = fila - 1
Else
y1 = fila
End If
If fila < nf - 1 Then
y2 = fila + 1
Else
y2 = fila
End If
If col > 1 Then
x1 = col - 1
Else
x1 = col
End If
If col < nc Then
x2 = col + 1
Else
x2 = col
End If
For fila1 = y1 To y2
For col1 = x1 To x2
If (fila1 = fila And col1 = col) Then Continue For
If A(fila1, col1) = relleno1 Then vecinos = vecinos + 1
Next
Next
If vecinos = 8 Then
B(fila, col) = 0
Else
B(fila, col) = A(fila, col)
End If
Next
Next
IniciarMatriz(A, nf, nc, 0)
TransferirMatriz(B, A, nf, nc)
Next
End Sub
Sub TransferirMatriz(ByVal MA(,) As Integer, ByRef MB(,) As Integer, ByVal nf As
Integer, ByVal nc As Integer)
For fila = 0 To nf
For col = 0 To nc
MB(fila, col) = MA(fila, col)
Next
Next
End Sub
Sub linea(ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As
Single)
Dim i As Integer, vel As Single = 10
Dim mayor, ancho, alto, partex, partey, px, py, dx, dy As Single
If (x2 - x1 = 0 And y2 - y1 = 0) Then Exit Sub
ancho = Math.Abs(x2 - x1)

alto = Math.Abs(y2 - y1)
If (x1 <= x2) Then
dx = 1
Else
dx = -1
End If
If (y1 <= y2) Then
dy = 1
Else
dy = -1
End If
If (ancho > alto) Then
mayor = ancho
Else
mayor = alto
End If
partex = ancho / mayor
partey = alto / mayor
For i = 0 To CInt(mayor)
px = i * partex * dx
py = i * partey * dy
A(y1 + py, x1 + px) = 14
'Console.SetCursorPosition(CInt(x1 + px), CInt(y1 + py))
'Console.WriteLine("*")
Next
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByRef A(,) As Integer, ByVal
nf As Integer, ByVal nc As Integer)
inicio = 1
A(fila, col) = CInt(CSng(Val(subcadena)))
inicio = pos + 1
Next
Next
Console.WriteLine("Archivo leido satisfactoriamente")
srLector.Close()
End Sub
Sub MostrarMatriz(ByVal A(,) As Integer, ByVal nf As Integer, ByVal nc As Integer)
Dim fila, col, c1 As Integer
Console.Write("{0} ", A(fila, col))
Next
Console.WriteLine()
Next
End Sub
End Module
CODIGO DEL MODULO 1
Module Module1
Sub graficar(VX() As Integer, VY() As Integer, np1 As Integer)
Dim x1, y1, x2, y2 As Single
Dim fila As Integer
For fila = 0 To np1 - 1
x1 = X(VX(fila) - 1)
y1 = Y(VX(fila) - 1)
x2 = X(VY(fila) - 1)
y2 = Y(VY(fila) - 1)
linea(x1, y1, x2, y2)
Next
End Sub
Sub Main()
Dim r As Integer
RecuperarMatriz(NombreArchivo, A, np, 3)
MatrizVectorXYZ(A, X, Y, relleno, np)
MostrarVectores(X, Y, np)
For r = 0 To 50
crecerCirculo(A, X, Y, nf, nc, relleno, r, np)
Next
VerPantalla(cx, cy, A, nf, nc)
Console.ReadLine()
JuegoVida(A, nf, nc)
For r = 0 To np - 1
EncontrarPares(A, nf, nc, VX, VY, np1, relleno(r))
Next
Console.WriteLine("resultados")
MostrarVectores(VX, VY, np1)
GrabarVectores(VX, VY, np1)
Console.ForegroundColor = 14
graficar(VX, VY, np1)
Console.ReadLine()
End Sub
End Module
Public Class Form1
Dim grafico As Graphics
Dim Pincel As Pen
Dim Pincel1 As Pen
Sub graficarGrafica(VX() As Integer, VY() As Integer, np1 As Integer)
Dim fila As Integer
For fila = 0 To np1 - 1
x1 = X(VX(fila) - 1)
y1 = Y(VX(fila) - 1)
x2 = X(VY(fila) - 1)
y2 = Y(VY(fila) - 1)
grafico.DrawLine(Pincel1, cx + x1 * tam, cy + y1 * tam, cx + x2 * tam, cy + y2 *
tam)
Next
End Sub
Sub VerPantallaGrafica(ByVal cx As Integer, ByVal cy As Integer, ByVal A(,) As
Integer, ByVal nf As Integer, ByVal nc As Integer)
Dim verde As Integer
verde = A(fila, col)
brocha.Color = Color.FromArgb(0, verde * 10, 0)
grafico.DrawRectangle(Pincel, cx + col * tam, cy + fila * tam, tam, tam)
grafico.FillRectangle(brocha, cx + col * tam, cy + fila * tam, tam, tam)
Next
Next
End Sub
DataGridView1.RowCount = np
DataGridView1.Columns(0).HeaderText = "Nro"
DataGridView1.Columns(1).HeaderText = "X"
DataGridView1.Columns(2).HeaderText = "Y"
DataGridView1.Columns(3).HeaderText = "Z"
For fila = 0 To 3
Next fila
txtPuntos.Text = np
grafico = PictureBox1.CreateGraphics
Pincel = New Pen(Color.Red, 1)
Pincel1 = New Pen(Color.Yellow, 3)
brocha = New SolidBrush(Color.Green)
End Sub
Sub MostrarVectoresCuadricula(Vx() As Integer, Vy() As Integer, Vz() As Integer, Ne
As Integer)
Dim fila As Integer
DataGridView1.Rows(fila).Cells(0).Value = fila
DataGridView1.Rows(fila).Cells(1).Value = Vx(fila)
DataGridView1.Rows(fila).Cells(2).Value = Vy(fila)
DataGridView1.Rows(fila).Cells(3).Value = Vz(fila)
Next
End Sub
Private Sub btnAbrir_Click(sender As Object, e As EventArgs) Handles btnAbrir.Click
MostrarVectoresCuadricula(X, Y, relleno, np)
End Sub
Private Sub btnGrafico_Click(sender As Object, e As EventArgs) Handles

btnGrafico.Click
' VerPantallaGrafica(cx, cy, A, nf, nc)
graficarGrafica(VX, VY, np1)
End Sub
Private Sub btnProcesar_Click(sender As Object, e As EventArgs) Handles
btnProcesar.Click
Dim r As Integer
MostrarVectores(X, Y, np)
For r = 0 To 180
crecerCirculo(A, X, Y, nf, nc, relleno, r, np)
Next
JuegoVida(A, nf, nc)
VerPantallaGrafica(cx, cy, A, nf, nc)
For r = 0 To np - 1
EncontrarPares(A, nf, nc, VX, VY, np1, relleno(r))
Next
ListBox1.Items.Add("resultados")
MostrarvectoresLista(VX, VY, np1)
graficarGrafica(VX, VY, np1)
End Sub
Sub MostrarvectoresLista(VX() As Integer, Vy() As Integer, np As Integer)
Dim fila As Integer
ListBox1.Items.Add(CStr(fila) + " X= " + CStr(VX(fila)) + " Y= " +
CStr(Vy(fila)))
Next
End Sub
End Class
Con 40 punto y varian de 020 y que no se repitan

Puntos primero rellena da myro menro adecuardo 40 puntos
Primero las grandes las pequeña
1 grandes
Sus ámbitos y las pequeñas
11.5 TRABAJO DE APLICACIÓN DE REDES DE OPTIMIZACION
Determinación de Trayectorias de transporte
Una empresa de transporte desea hacer el recorrido de mínima distancia entre la

ubicación 1 y la 39 de la figura mostrada abajo que considera las alternativas de
desplazamiento para las Urbanizaciones de Dolores y Amauta, donde los arcos
muestran las distancias recorridas en metros.
Se tiene los siguientes puntos. -Se pide
 Graficar arbol de expansion minima

 Graficar el recorrido minimo de un punto a otro
 Mostrar el flujo maximo de un punto a otro
 Mostrar el recorrido minimo que realiza un camion de un punto a otro
 Otros aportes
PUNTO X y R1 R2 R3
0 55 120 1 12 -1
1 130 100 0 11 2
2 190 70 1 3 10
3 320 40 2 4 6
4 360 30 3 5 -1
5 400 110 4 6 32
6 345 125 3 7 31
7 300 143 6 30 8
8 255 170 9 7 -1
9 260 183 8 10 -1
10 220 170 2 11 14
11 175 188 1 10 12
12 70 201 0 11 13
13 82 266 12 16 14
14 247 234 15 10 13
15 269 299 14 16 39
16 93 319 13 17 15
17 100 371 16 18 21
18 217 371 17 20 19
19 260 360 39 18 24
20 220 410 18 21 23
21 110 425 17 22 20
22 110 480 21 23 -1
23 240 460 22 20 24
24 310 450 23 25 19
25 340 450 24 26 37
26 340 400 27 25 36
27 330 360 26 28 -1
28 350 320 39 27 29
29 370 310 28 34 30
30 350 260 31 7 29
31 420 250 30 32 -1
32 450 230 33 5 -1
33 470 290 32 38 -1
34 410 300 29 33 -1
35 420 350 36 34 27
36 450 380 37 35 -1
37 460 420 25 38 36
38 500 410 37 33 -1
39 320 320 19 15 28
Option Explicit On
Public Class Form1
Dim BrochaSólida As SolidBrush
Dim pen As Pen
Dim pen1 As Pen
Dim penArbol As Pen
Sub ObtenerRuta(ByVal i As Integer, ByVal j As Integer)
Dim Sij As Integer
Sij = S(i, j)
If Sij = j Then
Ruta(ner) = i
ListBox1.Items.Add(" i " & i & " J " & j & " SIJ " & Sij)
ner = ner + 1
Else
ObtenerRuta(i, Sij)
ObtenerRuta(Sij, j)
End If
End Sub
Sub Graficar(ByVal X() As Single, ByVal Y() As Single, ByRef R(,) As Integer, _
ByVal nf As Integer, ByVal nc As Integer, ByVal ex As Single, ByVal ey As
Single)
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
If R(fila, col) = 1 Then
x1 = X(fila) * ex
y1 = Y(fila) * ey
x2 = X(col) * ex
y2 = Y(col) * ey
Grafico.DrawLine(pen, x1, y1, x2, y2)
End If
Next
Next
End Sub
Private Sub MnuIniciar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuIniciar.Click
ex = Val(TxtEx.Text)
ey = Val(TxtEy.Text)
ner = 0
iniciar()
End Sub
pen = New Pen(Color.FromArgb(255, 0, 0), 5)
pen1 = New Pen(Color.FromArgb(0, 0, 255), 3)
penArbol = New Pen(Color.FromArgb(0, 255, 0), 5)
End Sub
Private Sub MnuGraficarRuta_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuGraficarRuta.Click
Dim fila As Integer
Dim p1 As Integer, p2 As Integer
For fila = 0 To ner - 2
p1 = Ruta(fila)
p2 = Ruta(fila + 1)
Grafico.DrawLine(pen1, X(p1) * ex, Y(p1) * ey, X(p2) * ex, Y(p2) * ey)
Next
End Sub
Private Sub MnuGraficarPuntos_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuGraficarPuntos.Click
Dim k As Integer
LeerArchivo(X, Y, np)
Dim MiFuente As New Font("Verdana", 10, FontStyle.Bold)
For k = 0 To np - 1
Grafico.DrawString(k, MiFuente, Brushes.Blue, X(k) * ex, Y(k) * ey)
Grafico.DrawEllipse(Pens.Green, X(k) * ex, Y(k) * ey, ex, ey)
Next
End Sub
Private Sub MnuGraficarLineas_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuGraficarLineas.Click
Graficar(X, Y, Relaciones, np, np, ex, ey)
End Sub
Private Sub MnuBorrar_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuBorrar.Click
End Sub
Private Sub MnuRecuperarPuntos_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuRecuperarPuntos.Click
End Sub
Private Sub MnuRecuperarRelaciones_Click(ByVal sender As System.Object, ByVal
e As System.EventArgs) Handles MnuRecuperarRelaciones.Click
RecuperarPuntosRelaciones(PuntosRelaciones, np, np - 1)
End Sub
Private Sub MnuProcesar_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuProcesar.Click
FormarRelaciones(PuntosRelaciones, Relaciones, np, np)
ObtenerDistancias(X, Y, np, D, Relaciones)
End Sub
Private Sub MnuObtenerRecorridos_Click(ByVal sender As System.Object, ByVal e
As System.EventArgs) Handles MnuObtenerRecorridos.Click
ObtenerRecorridos(S, np)
End Sub
Private Sub MnRecuperarDistancias_Click(ByVal sender As System.Object, ByVal e
As System.EventArgs) Handles MnRecuperarDistancias.Click
RecuperarDistancias(D, np, np)
End Sub
Private Sub MnunGrabarDistancias_Click(ByVal sender As System.Object, ByVal e

As System.EventArgs) Handles MnunGrabarDistancias.Click
GrabarMatriz(D, np, np)
End Sub
Private Sub MnuGrabarRecorrido_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuGrabarRecorrido.Click
GrabarMatrizRecorrido(S, np, np)
End Sub
Private Sub MnuFloyd_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuFloyd.Click
floyd(D, S, np)
End Sub
Private Sub MnuObteneRuta_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuObteneRuta.Click
origen = Val(txtOrigen.Text)
destino = Val(Txtdestino.Text)
ner = 0
ObtenerRuta(origen, destino)
Ruta(ner) = destino
ner = ner + 1
End Sub
Private Sub MnuProcesoGeneral_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuProcesoGeneral.Click
MnuIniciar_Click(sender, e)
MnuRecuperarPuntos_Click(sender, e)
MnuRecuperarRelaciones_Click(sender, e)
MnuProcesar_Click(sender, e)
MnuObtenerRecorridos_Click(sender, e)
MnuGraficarPuntos_Click(sender, e)
MnuGraficarLineas_Click(sender, e)
MnuFloyd_Click(sender, e)
MnunGrabarDistancias_Click(sender, e)
MnuGrabarRecorrido_Click(sender, e)
MnuObteneRuta_Click(sender, e)
MnuGraficarRuta_Click(sender, e)
End Sub
Private Sub MnuGraficarArbol_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuGraficarArbol.Click
x1 = X(CFila(fila)) * ex
y1 = Y(CFila(fila)) * ey
x2 = X(CCol(fila)) * ex
y2 = Y(CCol(fila)) * ey
Grafico.DrawLine(penArbol, x1, y1, x2, y2)
Next
End Sub
Private Sub MnuIniciarArbol_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuIniciarArbol.Click
InicioArbol()
End Sub
Private Sub MnuBorrararbol_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuBorrararbol.Click
Grafico.Clear(Color.FloralWhite)
End Sub
Private Sub GraficarPuntosArbol_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuGraficarPuntosArbol.Click
MnuGraficarPuntos_Click(sender, e)
End Sub
Private Sub MnuProcesoArbol_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuProcesoArbol.Click
MnuIniciarArbol_Click(sender, e)
MnuGraficarArbol_Click(sender, e)
GraficarPuntosArbol_Click(sender, e)
End Sub
Private Sub RecuperarGraficoToolStripMenuItem_Click(ByVal sender As

System.Object, ByVal e As System.EventArgs) Handles MnuRecuperarGrafico.Click
Dim nombre As String
OpenFileDialog1.ShowDialog()
nombre = OpenFileDialog1.FileName
Me.Text = nombre
PictureBox1.Load(nombre)
End Sub
Private Sub MnuSalir_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuSalir.Click
Me.Close()
End Sub
End Class
CODIGO DEL MODULO
Module Module1
Sub InicioArbol()
Dim contador As Integer = 0
Dim k As Integer
Dim k1 As Integer
Dim filamenor As Integer
Dim menor As Single = 1000
C(0) = 0
For k = 0 To nc1 - 1
C1(k) = k + 1
Next
While nc1 > 0
menor = 1000
colMenor = 0
filamenor = 0
For k = 0 To nc - 1
p1 = C(k)
For k1 = 0 To nc1 - 1
p2 = C1(k1)
d1 = distancia(X(p1), Y(p1), X(p2), Y(p2))
If (d1 < menor) And d1 > 0 Then
menor = d1
filamenor = C(k)
colMenor = k1
End If
Next
Next
CFila(contador) = filamenor
CCol(contador) = C1(colMenor)
contador = contador + 1
C(nc) = C1(colMenor)
nc = nc + 1
nc1 = nc1 - 1
For k1 = colMenor To nc1 - 1
C1(k1) = C1(k1 + 1)
Next
End While
ne = contador
End Sub
Function distanciaTotalArbol(ByVal CFila() As Integer, ByVal CCol() As Integer,
ByVal np As Integer)
Dim fila As Integer
Dim d1 As Single
Dim dt As Single = 0
d1 = distancia(X(CFila(fila)), Y(CFila(fila)), X(CCol(fila)), Y(CCol(fila)))
dt = dt + d1
Next
Return dt
End Function
End Module
MODULO 2
Option Explicit On
Imports System.IO
Module Module2
Public ne As Integer
Public d1 As Single
Public C(Npuntos) As Integer
Public C1(Npuntos) As Integer
Public CCol(Npuntos) As Integer
Public CFila(Npuntos) As Integer
Public colMenor As Integer
Public Const Npuntos As Integer = 5
Public cont As Integer = 0
Public D(Npuntos, Npuntos) As Single
Public destino As Integer = 4
Public ex As Single = 6
Public ey As Single = 2
Public nc1 As Integer = Npuntos - 1
Public ner As Integer = 0
Public np As Integer = Npuntos
Public origen As Integer = 0
Public p1 As Integer
Public p2 As Integer
Public PuntosRelaciones(Npuntos, Npuntos) As Integer
Public Relaciones(Npuntos, Npuntos) As Integer
Public Ruta(Npuntos) As Integer
Public S(Npuntos, Npuntos) As Integer
Public srLector As StreamReader
Public X(Npuntos) As Single
Public Y(Npuntos) As Single
Sub iniciar()
IniciarPantalla(PuntosRelaciones, np, np)
IniciarPantalla(Relaciones, np, np)
IniciarPantalla(S, np, np)
End Sub
Sub LeerArchivo(ByVal X() As Single, ByVal Y() As Single, ByVal nf As Integer)
srLector = New StreamReader("e:\DATOS\puntos2x5.txt")
Dim cadena As String
pos = InStr(1, cadena, Chr(9))
If pos > 0 Then
X(fila) = Val(Mid(cadena, 1, pos - 1))
Y(fila) = Val(Mid(cadena, pos + 1, Len(cadena)))
End If
REM srLector.Close()
Next
End Sub
Public Sub RecuperarPuntosRelaciones(ByVal A(,) As Integer, ByVal nf As Integer,

ByVal nc As Integer)
srLector = New StreamReader("e:\DATOS\Relaciones4X5.txt")
Dim longitud As String
Dim cont As Integer = 0
longitud = Len(cadena)
inicio = 1
cont = 0
Do
If pos > 0 Then
A(fila, cont) = Val(subcadena)
inicio = pos + 1
cont += 1
Else
subcadena = Mid(cadena, inicio, longitud - inicio + 1)
cont += 1
Exit Do
End If
Loop While (inicio <= longitud)
Next
srLector.Close()
End Sub
Public Sub RecuperarDistancias(ByVal A(,) As Single, ByVal nf As Integer, ByVal nc
As Integer)
srLector = New StreamReader("e:\DATOS\Dist8x8.txt")
inicio = 1
cont = 0
Do
If pos > 0 Then
inicio = pos + 1
cont += 1
Else
cont += 1
Exit Do
End If
Next
srLector.Close()
End Sub
Sub FormarRelaciones(ByVal A(,) As Integer, ByRef R(,) As Integer, ByVal nf As

If A(fila, col) >= 0 Then
R(fila, A(fila, col)) = 1
End If
Next
Next
End Sub
Sub IniciarPantalla(ByVal A(,) As Integer, ByVal nf As Integer, ByVal nc As Integer)
A(fila, col) = -1
Next
Next
End Sub
Function distancia(ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single,
ByVal y2 As Single) As Single
distancia = Math.Sqrt(Math.Pow(x2 - x1, 2) + Math.Pow(y2 - y1, 2))
End Function
Sub ObtenerDistancias(ByVal X() As Single, ByVal Y() As Single, ByVal np As

Integer, ByVal D(,) As Single, ByVal Relaciones(,) As Integer)
Dim d1 As Single
For col = 0 To np - 1
d1 = distancia(X(fila), Y(fila), X(col), Y(col))
If Relaciones(fila, col) > 0 Then
D(fila, col) = d1
Else
If (fila <> col) Then
D(fila, col) = 999
Else
D(fila, col) = 0
End If
End If
Next
Next
End Sub
Sub ObtenerRecorridos(ByRef S(,) As Integer, ByVal np As Integer)
S(fila, col) = col
Next
Next
End Sub
Sub floyd(ByRef D(,) As Single, ByRef S(,) As Integer, ByVal np As Integer)
Dim i As Integer, j As Integer, k As Integer = 0
For k = 0 To np - 1
For i = 0 To np - 1
For j = 0 To np - 1
If D(i, k) + D(k, j) < D(i, j) Then
If (i <> j) And (j <> k) And (i <> k) Then
D(i, j) = D(i, k) + D(k, j)
S(i, j) = k
End If
End If
Next
Next
Next
End Sub
Sub GrabarMatriz(ByVal A(,) As Single, ByVal nf As Integer, ByVal nc As Integer)

Dim swEscritor = New StreamWriter("e:\DATOS\D5x5.txt")
swEscritor.Write("{0}{1} ", A(fila, col), Chr(9))
Next
Next
swEscritor.Close()
End Sub
Sub GrabarMatrizRecorrido(ByVal A(,) As Integer, ByVal nf As Integer, ByVal nc As
Integer)
Dim swEscritor = New StreamWriter("e:\DATOS\S5x5.txt")
Next
Next
swEscritor.Close()
End Sub
Function distanciaRuta(ByVal ruta() As Integer, ByVal X() As Single, ByVal Y() As

Single, ByVal ner As Integer) As Single
Dim fila As Integer
Dim p1 As Integer, p2 As Integer
Dim suma As Single, d As Single
For fila = 0 To ner - 2
p1 = ruta(fila)
p2 = ruta(fila + 1)
d = distancia(X(p1), Y(p1), X(p2), Y(p2))
suma = suma + d
Next
Return suma
End Function
End Module
11.6 SIMULACION DE POLITICAS DE INVENTARIOS DE CONTROL DE

INVENTARIOS
x P(x) acum L 2
1 5,00 5 Q 10
2 20,00 25 C1 0,1
3 40,00 65 C3 5
4 25,00 90 Z 10
5 10,00 100 z 4
SUMA 100
Public Class Form1
Dim ColorFondo As Color = Color.FromArgb(255, 255, 255)
Dim pen As Pen
Dim pen2 As Pen
Dim pen3 As Pen
Dim ancho = 600, alto = 400
Dim BrochaSolida As SolidBrush
Sub mostrar(ByVal vector() As Single, ByVal n As Integer)
Dim i As Integer
For i = 0 To n - 1
ListBox1.Items.Add(i & " " & vector(i))
Next
End Sub
Sub MostrarMatriz(ByRef A(,) As Single, ByVal nf As Integer, ByVal nc As Integer)
Next
DataGridView1.Rows(fila).Cells(col).Value = A(fila, col)
Next
Console.WriteLine()
Next
End Sub
Private Sub BtnIniciar_Click(ByVal sender As System.Object, ByVal e As

Iniciar()
nfilas = Val(txtNper.Text)
ex = Val(txtEx.Text)
ey = Val(txtEy.Text)
Z1 = Val(txtZ.Text)
z2 = Val(txtz2.Text)
demora = Val(txtL.Text)
C1 = Val(txtC1.Text)
C3 = Val(txtC3.Text)
rellenar(vector, nro, p, nprob, nfilas)
mostrar(vector, nfilas)
RellenarMatriz(A, nro, vector, nfilas)
DataGridView1.RowCount = nfilas
DataGridView1.Columns(0).HeaderText = "Per"
DataGridView1.Columns(1).HeaderText = "I1"
DataGridView1.Columns(2).HeaderText = "R"
DataGridView1.Columns(3).HeaderText = "I2"
DataGridView1.Columns(4).HeaderText = "Ped"
DataGridView1.Columns(5).HeaderText = "Llega"
DataGridView1.Columns(6).HeaderText = "C1"
DataGridView1.Columns(7).HeaderText = "C3"
DataGridView1.Columns(8).HeaderText = "Ct"
DataGridView1.Columns(9).HeaderText = "ctAc"
MostrarMatriz(A, nfilas, ncol)
GrabarMatriz(A, nfilas, ncol)
Console.ReadLine()
End Sub
Private Sub BtnGraficar_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles BtnGraficar.Click
Dim MiFuente = New Font("arial", 11, FontStyle.Bold)
For fila = 0 To nfilas - 1
x1 = A(fila, 0)
y1 = A(fila, 1)
Grafico.DrawString(fila, MiFuente, BrochaSolida, Cx + x1 * ex, Cy)
Next
Grafico.DrawLine(pen, 0, Cy, ancho, Cy)
Grafico.DrawLine(pen, cx, 0, cx, alto)
x1 = A(fila, 0)
y1 = A(fila, 1)
Grafico.FillRectangle(Brushes.Blue, Cx + x1 * ex, Cy + y1 * ey, ex - ex / 10,
A(fila, 1) * ey * -1)
Next
' graficando el INVENTARIOl
x1 = A(fila - 1, 0)
y1 = A(fila - 1, 1)
x2 = A(fila, 0)
y2 = A(fila, 1)
Grafico.DrawLine(pen2, Cx + x1 * ex, Cy + y1 * ey, Cx + x2 * ex, Cy + y2 * ey)
' graficando el costo total
x1 = A(fila - 1, 0)
y1 = A(fila - 1, 8)
x2 = A(fila, 0)
y2 = A(fila, 8)
Grafico.DrawLine(pen3, Cx + x1 * ex, Cy + y1 * ey, Cx + x2 * ex, Cy + y2 * ey)
Next
txtCi.Text = CAcum
End Sub
Private Sub BtnBorrar_Click(ByVal sender As System.Object, ByVal e As
End Sub
pen2 = New Pen(Color.Red, 1)
pen3 = New Pen(Color.Green, 2)
BrochaSolida = New SolidBrush(Color.Red)
End Sub
End Class
CODIGO DEL MODULO 1
Imports System.IO
Module Module1
Public Const maxfilas As Integer = 365
Public Const nprob As Integer = 10
Public ncol As Integer = 10
Public nfilas As Integer = maxfilas
Public vector(maxfilas) As Single
Public nro(nprob) As Single
Public p(nprob) As Single
Public A(nfilas, ncol) As Single
Public C1 As Single = 0.1
Public C3 As Single = 5
Public Z1 As Single = 10
Public z2 As Single = 4
Public demora As Single = 2 'L
Public hizopedido As Integer = 0
Public Cy As Single = 200
Public ey As Single = -10
Public CAcum As Single = 0
Sub RellenarMatriz(ByRef A(,) As Single, ByVal nro() As Single, ByVal vector() As
Single, ByVal np As Integer)
Dim fila As Integer
Dim I1 As Single = 8, I2 As Single, r As Integer
Dim t As Single = 0
Dim pedido As Single
Dim cmantenimiento As Single = 0, caprovisionamiento As Single = 0
Dim Ctotal As Single = 0
fila = 0
' primero inicializamos
A(fila, 0) = nro(fila)
A(fila, 1) = Z1
A(fila, 2) = vector(fila)
I2 = A(fila, 1) - vector(0)
A(fila, 3) = I2
A(fila, 4) = pedido
cmantenimiento = C1 * A(fila, 1)
A(fila, 6) = cmantenimiento
A(fila, 7) = caprovisionamiento
Ctotal = cmantenimiento + caprovisionamiento
A(fila, 8) = Ctotal
CAcum = Ctotal
A(fila, 9) = Ctotal
A(fila, 0) = fila
r = vector(fila)
A(fila, 0) = fila
I1 = A(fila - 1, 3)
A(fila, 5) = 0
If t >= demora Then ' llega el pedido
I1 = I1 + pedido
A(fila - 1, 5) = pedido
t=0
pedido = 0
hizopedido = 0
Else
t=t+1
End If
A(fila, 1) = I1
A(fila, 2) = vector(fila)
I2 = I1 - r
A(fila, 3) = I2
A(fila, 4) = 0
If (I2 < z2) Then
If hizopedido = 0 Then ' solo aumenta cuando no se hizo pedido
pedido = Z1 - I2
A(fila, 4) = pedido
t=0
hizopedido = 1
End If
End If
' calculo de costos
A(fila, 6) = 0
A(fila, 7) = 0
If A(fila, 1) > 0 Then
cmantenimiento = C1 * A(fila, 1)
A(fila, 6) = cmantenimiento
End If
If A(fila, 4) > 0 Then
caprovisionamiento = C3
Else
caprovisionamiento = 0
End If
A(fila, 7) = caprovisionamiento
Ctotal = cmantenimiento + caprovisionamiento
A(fila, 8) = Ctotal
CAcum = CAcum + Ctotal
A(fila, 9) = CAcum
Next
End Sub
Sub GrabarMatriz(ByVal A(,) As Single, ByVal nf As Integer, ByVal nc As Integer)
Dim swEscritor = New StreamWriter("E:\DATOS\Invent5x30.txt")
Next
Next
swEscritor.Close()
End Sub
Function generar(ByVal nro() As Single, ByVal p() As Single, ByVal n As Integer) As
Integer
Dim r As Integer, ng As Integer, i As Integer
r = Int(Rnd() * 100)
For i = 0 To n - 1
If (p(i) > r) Then
ng = nro(i)
Exit For
End If
Next
Return ng
End Function
Sub rellenar(ByVal vector() As Single, ByVal nro() As Single, ByVal p() As Single,
ByVal nprob As Integer, ByVal nper As Integer)
Dim i As Integer
Randomize()
For i = 0 To nper - 1
vector(i) = generar(nro, p, nprob)
Next
End Sub
Sub Iniciar()
nro(0) = 1 : nro(1) = 2 : nro(2) = 3 : nro(3) = 4 : nro(4) = 5
p(0) = 5
p(1) = 25
p(2) = 65
p(3) = 90 : p(4) = 100
End Sub
End Module
11.7 TRIANGULACION DE DELAUNAY (HECHO CAMBIAR Y MODIFICAR

CODIGO DEL FORMULARIO 1
Option Explicit On
Public Class Form1
Dim x1 As Integer
Dim y1 As Integer
Dim x2 As Integer
Dim y2 As Integer
Dim p1 As Integer
Dim p2 As Integer
Dim nsr As Integer = 0
Dim fila As Integer
Sub imprimirVector(ByVal X() As Integer, ByVal ne As Integer)
Dim fila As Integer
For fila = 0 To ne - 1
ListBox1.Items.Add(" X " & X(fila))
Next
End Sub
Sub imprimir(ByVal X() As Integer, ByVal Y() As Integer, ByVal ne As Integer)

Dim fila As Integer
ListBox1.Items.Add(" X " & X(fila) & " Y " & Y(fila))
Next
End Sub
Sub graficarTriangulos()
For fila = 0 To Np - 1
p1 = MRel(fila, 0)
x1 = X(p1)
y1 = Y(p1)
For col = 1 To Np - 1
p2 = MRel(fila, col)
If MRel(fila, col) >= 0 Then
x2 = X(p2)
y2 = Y(p2)
If x1 = x2 And y1 = y2 Then
Else
Grafico.DrawLine(pen, x1 * tam, y1 * tam, x2 * tam, y2 * tam)
End If
End If
Next
Next
BrochaSolida.Color = Color.White
For k = 0 To Np - 1
Grafico.DrawString(k + 1, MiFuente, BrochaSolida, X(k) * tam, Y(k) * tam)
Next
End Sub
Sub MostrarMatriz(ByVal Cx As Integer, ByVal Cy As Integer, ByVal A(,) As Integer,
ByVal nfilas As Integer, ByVal ncol As Integer)
Dim indice As Integer
For col = 0 To ncol - 1
indice = A(fila, col)
BrochaSolida.Color = Color.FromArgb(MColores(indice, 0), MColores(indice,
1), MColores(indice, 2))
Grafico.FillRectangle(BrochaSolida, col * tam + Cx, fila * tam + Cy, tam, tam)
Next col
Next fila
End Sub
pen = New Pen(Color.Yellow, 2)
BrochaSolida = New SolidBrush(Color.Red)
End Sub
Private Sub BtnPrincipal_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles btnPrincipal.Click
relleno(fila) = fila + 1
Next
recuperarPuntos(X, Y, Np)
nombreColores = "E:\SI2014B\DATOSTXT\colores3x50.txt"
RecuperarArchivo(MColores, 50, 3, nombreColores)
IniciarMatriz(MRel, Np, Np, -1)
IniciarMatriz(Matriz, nf, nc, 0)
MostrarMatriz(cx, cy, matriz, nf, nc)
imprimir(X, Y, Np)
REM al crecer obtien cuales son sus vecinos
For r = 0 To 100
crecerCirculo(Matriz, X, Y, nf, nc, relleno, r, Np)
Next
MostrarMatriz(Cx, Cy, Matriz, nf, nc)
For fila = 0 To nseres - 1
contavecinos(relleno(fila), vecinos, nvecinos)
restar(vecinos, nvecinos)
AsignarMatriz(MRel, vecinos, nvecinos, fila)
ListBox1.Items.Add("ser " & relleno(fila))
imprimirVector(vecinos, nvecinos)
Next
graficarTriangulos()
End Sub
Private Sub btnBorrar_Click(ByVal sender As System.Object, ByVal e As
End Sub
Private Sub btnMostrar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnMostrar.Click
End Sub
Private Sub btnCargar_Click(sender As Object, e As EventArgs) Handles
btnCargar.Click
End Sub
Private Sub BtnTriangulos_Click(sender As Object, e As EventArgs) Handles
BtnTriangulos.Click
graficarTriangulos()
End Sub
End Class
CODIGO DEL MODULO 1
Imports System.IO
Module module1
Public Cx As Integer = 10, Cy As Integer = 10
Public npuntos As Integer
Public Matriz(NFilas, NCol) As Integer
Public Const NFilas As Integer = 500, NCol As Integer = 700, maximo = 100
Public Np As Integer = 40
Public relleno(NCol) As Integer
Public X(Np) As Integer
Public Y(Np) As Integer
Public nf As Integer = NFilas, nc As Integer = NCol
Public MRel(Np, Np) As Integer
Public nseres As Integer = 40
Public vecinos(maximo) As Integer
Public nvecinos As Integer
Public pen As Pen
Public Color As Color
Public BrochaSolida As SolidBrush
Public nombreColores As String
Public MColores(50, 3) As Integer
Public Ex As Single = tam
Public ey As Single = -tam
Sub contavecinos(ByRef ser As Integer, ByRef Vecinos() As Integer, ByRef nvecinos

As Integer)
Dim cont = 0
Vecinos(0) = ser
cont = 1
If (Matriz(fila, col) = ser) Then
valor = 0
For k = 0 To cont - 1
If Matriz(fila, col + 1) = Vecinos(k) Then
valor = 1
Exit For
End If
Next
If valor = 0 Then
Vecinos(cont) = Matriz(fila, col + 1)
cont = cont + 1
End If
valor = 0
If Matriz(fila - 1, col) = Vecinos(k) Then
valor = 1
Exit For
End If
Next
If valor = 0 Then
Vecinos(cont) = Matriz(fila - 1, col)
cont = cont + 1
End If
valor = 0
If Matriz(fila, col - 1) = Vecinos(k) Then
valor = 1
Exit For
End If
Next
If valor = 0 Then
Vecinos(cont) = Matriz(fila, col - 1)
cont = cont + 1
End If
valor = 0
If Matriz(fila + 1, col) = Vecinos(k) Then
valor = 1
Exit For
End If
Next
If valor = 0 Then
Vecinos(cont) = Matriz(fila + 1, col)
cont = cont + 1
End If
End If
Next
Next
nvecinos = cont
End Sub
Public Sub RecuperarArchivo(ByVal A(,) As Integer, ByVal nf As Integer, ByVal nc As

Integer, ByVal nombre As String)
srLector = New StreamReader(nombre)
inicio = 1
cont = 0
Do
If pos > 0 Then
inicio = pos + 1
cont += 1
Else
cont += 1
Exit Do
End If
Next
srLector.Close()
End Sub
Sub crecerCirculo(ByVal A(,) As Integer, ByVal X() As Integer, ByVal Y() As Integer,
ByVal nf As Integer, _
ByVal nc As Integer, ByVal relleno() As Integer, ByVal r As Single, ByVal np
As Integer)
Dim x1 As Integer, y1 As Integer, k As Integer
For k = 0 To np - 1
For y1 = Y(k) - r To Y(k) + r
For x1 = X(k) - r To X(k) + r
If (Math.Pow(x1 - X(k), 2) + Math.Pow(y1 - Y(k), 2) <= r * r) And (x1 > 0)
And (x1 < NCol) And (y1 > 0) And (y1 < NFilas) Then
If (A(y1, x1) = 0) Then
A(y1, x1) = relleno(k)
End If
End If
Next
Next
Next
End Sub
Sub IniciarMatriz(ByVal A(,) As Integer, ByVal nf As Integer, ByVal nc As Integer,
ByVal nro As Integer)
A(fila, col) = nro
Next
Next
End Sub
Sub recuperarPuntos(ByRef X() As Integer, ByRef Y() As Integer, ByVal ne As
Integer)
Dim srLector = New StreamReader("E:\SI2014B\DATOSTXT\puntos2x40.txt")
pos = InStr(1, cadena, Chr(9)) ' pos tabulador
If pos > 0 Then
subcadena = Mid(cadena, 1, pos - 1)
X(fila) = Val(subcadena)
subcadena = Mid(cadena, pos + 1, longitud)
Y(fila) = Val(subcadena)
End If
Next
srLector.Close()
End Sub
Sub AsignarMatriz(ByRef M(,) As Integer, ByVal V() As Integer, ByVal ne As Integer,
ByVal nfila As Integer)
Dim col As Integer
For col = 0 To ne - 1
M(nfila, col) = V(col)
Next
End Sub
Sub Iniciarvector(ByVal A() As Integer, ByVal ne As Integer)
Dim fila As Integer
A(fila) = -1
Next
End Sub
Sub restar(ByRef a() As Integer, ByVal ne As Integer)
Dim fila As Integer
a(fila) = a(fila) - 1
Next
End Sub
End Module
1.8 PROGRAMA EDUCATIVO EL PUREK(para aprender operaciones matemáticas)
Option Explicit On
Public Class Form1
Dim nro1 As Integer
Dim nro2 As Integer
Dim resultado As Integer
Dim pen1 As Pen
Dim pen2 As Pen
Dim Color As Color
Dim BrochaSolida As SolidBrush
Dim Cx As Integer = 300, Cy As Integer = 300
Dim ex As Integer = 1, ey As Integer = -1
Dim ancho As Integer = 600, alto As Integer = 600
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub MostrarMatriz(ByVal Cx As Integer, ByVal Cy As Integer, ByVal A(,) As Integer,
ByVal nfilas As Integer, ByVal ncol As Integer)
Dim indice As Integer
Dim factor As Single = 0.1
Dim tam1 As Integer = tam * (1 - factor)
indice = A(fila, col)
BrochaSolida.Color = Color.FromArgb(MColores(indice, 0), MColores(indice,
1), MColores(indice, 2))
Grafico.FillRectangle(BrochaSolida, Cx + col * tam + tam * factor, Cy + fila *
tam * ey - tam1 - factor, tam1, tam1)
Next col
Next fila
End Sub
pen2 = New Pen(Color.Green, 1)
BrochaSolida = New SolidBrush(Color.Blue)
End Sub
IniciarMatriz(Matriz, nf, nc, 0)
End Sub
Private Sub btnTablero_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles btnTablero.Click
BrochaSolida.Color = Color.Blue
Grafico.DrawLine(pen1, 0, Cy, ancho, Cy)
Grafico.DrawLine(pen1, Cx, 0, Cx, alto)
For k = -NCol To NCol
Grafico.DrawString(k, MiFuente, BrochaSolida, Cx + k * tam, Cy)
Grafico.DrawLine(pen2, Cx + k * tam, 0, Cx + k * tam, alto)
Next
For k = -NFilas To NFilas
Grafico.DrawString(k, MiFuente, BrochaSolida, Cx, Cy + k * tam * ey)
Grafico.DrawLine(pen2, 0, Cy + k * tam, ancho, Cy + k * tam)
Next
End Sub

End Sub
Private Sub BtnSumar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles BtnSumar.Click
Dim ex As Integer = 1
IniciarColores()
Iniciarvector(VUnidades1, 0, 0, NCol - 1)
Iniciarvector(VDecenas1, 0, 0, NCol - 1)
Iniciarvector(VCentenas1, 0, 0, NCol - 1)
Iniciarvector(VMillares1, 0, 0, NCol - 1)
Dim contUnidades As Integer = 0
Dim contdecenas As Integer = 0
Dim ContCentenas As Integer = 0
Dim ContMillares As Integer = 0
Dim Valores1(5) As Integer
Dim tope1 As Integer = 4
Dim residuo As Integer
Dim cociente As Integer
nro1 = txtNro1.Text
nro2 = txtNro2.Text
Iniciarvector(Valores1, 0, 0, 5)
Dim cont As Integer
Dim numero As Integer
cont = 0
numero = nro1
tope1 = 1000
tope2 = 1000
While numero > 0
cociente = numero \ tope1
residuo = numero - cociente * tope1
Valores1(cont) = cociente
numero = residuo
tope1 = tope1 \ 10
cont = cont + 1
End While
numero = nro2
cont = 0
While numero > 0
numero = residuo
tope2 = tope2 \ 10
cont = cont + 1
End While
resultado = nro1 + nro2
txtResultado.Text = resultado
contUnidades = 0
contdecenas = 0
ContCentenas = 0
ContMillares = 0
' sumando unidades
Iniciarvector(VUnidades1, 1, 0, Valores1(3) - 1)
contUnidades = Valores1(3) + Valores2(3)
If contUnidades < 10 Then
Iniciarvector(VUnidades1, 1, Valores1(3), Valores2(3) - 1)
Else
contdecenas = contdecenas + 1
Iniciarvector(VDecenas1, 0, 0, nc - 1)
Iniciarvector(VDecenas1, 2, 0, contdecenas - 1)
contUnidades = contUnidades - 10
Iniciarvector(VUnidades1, 0, 0, nc - 1)
Iniciarvector(VUnidades1, 1, 0, contUnidades - 1)
End If
Sleep(140)
' sumando decenas
Iniciarvector(VDecenas1, 2, 0, Valores1(2) - 1)
contdecenas = contdecenas + Valores1(2) + Valores2(2)
If contdecenas < 10 Then
Iniciarvector(VDecenas1, 2, Valores1(2), Valores2(2) - 1)
Else
ContCentenas = ContCentenas + 1
Iniciarvector(VCentenas1, 0, 0, nc - 1)
Iniciarvector(VCentenas1, 3, 0, ContCentenas - 1)
contdecenas = contdecenas - 10
Iniciarvector(VDecenas1, 0, 0, nc - 1)
Iniciarvector(VDecenas1, 2, 0, contdecenas - 1)
End If
Sleep(140)
' sumando centenas

Iniciarvector(VCentenas1, 3, 0, Valores1(1) - 1)
ContCentenas = ContCentenas + Valores1(1) + Valores2(1)
If ContCentenas < 10 Then
Iniciarvector(VCentenas1, 3, Valores1(1), Valores2(1) - 1)
Else
ContMillares = ContMillares + 1
Iniciarvector(VMillares1, 0, 0, nc - 1)
Iniciarvector(VMillares1, 4, 0, ContMillares - 1)
ContCentenas = ContCentenas - 10
Iniciarvector(VCentenas1, 0, 0, nc - 1)
Iniciarvector(VCentenas1, 3, 0, ContCentenas - 1)
End If
MostrarVector(VUnidades1, NCol - 1, 0, ex) REM unidades es primera fila
MostrarVector(VDecenas1, NCol - 1, 1, ex) REM decenas segunda fila}
MostrarVector(VCentenas1, NCol - 1, 2, ex) REM centenas tercera fila
MostrarVector(VMillares1, NCol - 1, 3, ex) REM decenas segunda fila
End Sub
Sub MostrarVector(ByVal A() As Integer, ByVal nc As Integer, ByVal fila As Integer,

ByVal ex As Integer)
Dim col As Integer, indice As Integer
Dim tam1 As Integer = tam * (1 - factor)
For col = 0 To nc
indice = A(col)
Sleep(80)
BrochaSolida.Color = Color.FromArgb(MColores(indice, 0), MColores(indice, 1),
MColores(indice, 2))
Grafico.FillRectangle(BrochaSolida, Cx + col * tam * ex + tam * factor * ex, Cy +
fila * tam * ey - tam1 - factor, tam1, tam1)
Next
End Sub
Private Sub btnRestar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnRestar.Click
IniciarColores()
Iniciarvector(VUnidades1, 0, 0, NCol - 1)
Dim contUnidades As Integer = 0
Dim residuo As Integer
Dim cociente As Integer
Dim cadena1 As String
nro1 = txtNro1.Text
nro2 = txtNro2.Text
Dim cont As Integer
Dim numero As Integer
cont = 0
numero = nro1
tope1 = 1000
tope2 = 1000
While numero > 0
numero = residuo
tope1 = tope1 \ 10
cont = cont + 1
End While
numero = nro2
cont = 0
While numero > 0
numero = residuo
tope2 = tope2 \ 10
cont = cont + 1
End While
resultado = nro1 - nro2
txtResultado.Text = resultado
contUnidades = 0
' RESTANDO UNIDADES
Iniciarvector(VUnidades1, 0, 0, nc - 1)
contUnidades = Valores1(3) - Valores2(3)
Iniciarvector(VUnidades1, 1, 0, Math.Abs(contUnidades) - 1)
ex = -1
Else
ex = 1
End If
End If
MostrarVector(VUnidades1, NCol - 1, 0, ex) REM unidades es primera fila
End Sub
End Class
CODIGO DEL MODULO
Module Module1
Public Matriz(NFilas, NCol) As Integer
Public Const NFilas As Integer = 10, NCol As Integer = 10, maximo = 5
Public relleno(maximo) As Integer
Public nf As Integer = NFilas, nc As Integer = NCol
Public VUnidades1(NCol) As Integer
Public VDecenas1(NCol) As Integer
Public VCentenas1(NCol) As Integer
Public VMillares1(NCol) As Integer
Public MColores(maximo, 3) As Integer
Sub Iniciarvector(ByRef A() As Integer, ByVal nro As Integer, ByVal inicial As Integer,
ByVal final As Integer)
Dim fila As Integer
For fila = inicial To inicial + final
A(fila) = nro
Next
End Sub
Sub IniciarColores()
MColores(0, 0) = 255
MColores(1, 1) = 0
MColores(1, 2) = 0
MColores(2, 0) = 0
MColores(2, 1) = 0
MColores(3, 0) = 0
MColores(3, 2) = 0
MColores(4, 2) = 0
End Sub
Sub IniciarMatriz(ByRef A(,) As Integer, ByVal nf As Integer, ByVal nc As Integer,

ByVal nro As Integer)
A(fila, col) = nro
Next
Next
End Sub
End Module
11.9 APLICACIÓN DE TRADUCTOR DE ARCHIVOS
Imports System.IO
Module Module1
Public A(10) As String
Public B(10) As String
End Module
Imports System.IO
Public Class Form1
Public srLector1 As StreamReader
Public srLector2 As StreamReader
Public swEscritor As StreamWriter
Public A(200) As String
Public B(200) As String
Public nterminos As Integer = 0
Public Linea As String

Public texto As String = ""
Public texto2 As String = ""
Public ContadorLin As Integer = 1
Dim fila As Integer
Private Sub btnCargar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnCargar.Click
srLector1 = New StreamReader("e:\datos\datos1.txt")
Linea = srLector1.ReadLine()
Do While Not (Linea Is Nothing)
ContadorLin += 1
texto = texto & Linea & vbCrLf
Linea = srLector1.ReadLine()
Loop
TextBox1.Text = texto
Me.Text = ContadorLin
srLector1.Close()
Console.ReadLine()
End Sub
Private Sub btnCambiar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnCambiar.Click
Dim nombre1 As String
texto2 = texto
For fila = 0 To nterminos
nombre1 = A(fila)
nombre2 = B(fila)
texto2 = Replace(texto2, nombre1, nombre2)
Next
TextBox1.Text = texto
TextBox2.Text = texto2
End Sub
Private Sub btnTerminos_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnTerminos.Click
srLector2 = New StreamReader("E:\datos\terminos1.txt")
Dim subcadena1 As String
cadena = srLector2.ReadLine()
subcadena1 = Mid(cadena, 1, pos - 1)
A(cont) = subcadena1
subcadena2 = Mid(cadena, pos + 1, Len(cadena) - pos)
B(cont) = subcadena2
cadena = srLector2.ReadLine()
cont += 1
Loop
Me.Text = "term" & cont
srLector2.Close()
nterminos = cont
For i = 0 To nterminos - 1
ListBox1.Items.Add(A(i))
ListBox2.Items.Add(B(i))
Next
End Sub
Private Sub BTNPRUEBA_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnGrabar.Click
swEscritor = New StreamWriter("e:\datos\datos2.txt")
' escribir líneas
swEscritor.WriteLine(texto2)
swEscritor.Close()
End Sub
End Class
11.10 BUSCADOR
CODIGO DEL MODULO
Imports System.IO
Module module1
'/*** declaraciones
Public Const maxfilas As Integer = 20, maxcol As Integer = 30
Public Matriz(maxfilas, maxcol) As Integer
Public Cx As Integer = 1, Cy As Integer = 1
Public dir As Integer = 0, valor As Integer = 0
Public final As Integer = 0, cont As Integer = 0
Public nfilasPantalla = 22, NcolPantalla = 32
Public nf As Integer
Public nc As Integer
Public Objetos(maxfilas * maxcol)
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub RecuperarArchivo(ByVal A(,) As Integer, ByVal nf As Integer, ByVal nc As

Integer)
srLector = New StreamReader("e:\DATOS\Matriz30x20.txt")
inicio = 1
cont = 0
Do
If pos > 0 Then
inicio = pos + 1
cont += 1
Else
cont += 1
Exit Do
End If
Next
srLector.Close()
End Sub
End Module
Public Class Form1
Dim fila As Integer
Dim col As Integer
Dim tam As Integer = 20
Dim nf As Integer
Dim nc As Integer
Dim Color As Color
Dim BrochaSólida As SolidBrush
Public Structure Buscador
Public dir1 As Integer, dir2 As Integer, dir3 As Integer, dir4 As Integer ' declarar
matrices de 4
Public Cx As Integer
Public Cy As Integer
Public np As Integer
Public Valor As Integer, rojo As Integer, verde As Integer, azul As Integer, Direc As
Integer
End Structure
Public Objeto1 As Buscador
Sub InicializarObjeto(ByRef Objeto1 As Buscador)
Objeto1.Cx = 14
Objeto1.Cy = 13
Objeto1.rojo = 255
Objeto1.verde = 0
Objeto1.azul = 0
Objeto1.Valor = 1
Objeto1.dir1 = 0
Objeto1.dir2 = 0
Objeto1.dir3 = 0
Objeto1.dir4 = 0
Objeto1.np = 0
Objeto1.nro = 0
End Sub
Function obtenerDir(ByVal d1 As Integer, ByVal d2 As Integer, ByVal d3 As Integer,

ByVal d4 As Integer) As Integer
If d1 = 1 Then obtenerDir = 1 : Exit Function
obtenerDir = 0
End Function
Function evaluar(ByRef objeto1 As Buscador, ByVal Matriz(,) As Integer, ByVal

camino As Integer, ByVal meta As Integer) As Integer
Dim cont As Integer = 0, Cx As Integer, Cy As Integer, Direc As Integer = 0, i As
Integer
Dim resultado As Integer = 0
objeto1.dir1 = 0
objeto1.dir2 = 0
objeto1.dir3 = 0
objeto1.dir4 = 0
Cx = objeto1.Cx
Cy = objeto1.Cy
' primero evalua si ya encontro la metas
If Matriz(Cy, Cx + 1) = meta Then
objeto1.dir1 = 1
cont = cont + 1
evaluar = 1
Exit Function
End If
If Matriz(Cy - 1, Cx) = meta Then
objeto1.dir2 = 1
cont = cont + 1
evaluar = 1
Exit Function
End If
If Matriz(Cy, Cx - 1) = meta Then
objeto1.dir3 = 1
cont = cont + 1
evaluar = 1
Exit Function
End If
If Matriz(Cy + 1, Cx) = meta Then
objeto1.dir4 = 1
cont = cont + 1
evaluar = 1
Exit Function
End If
'// si no encuentra meta evalua si hay camino
If Matriz(Cy, Cx + 1) = camino Then
objeto1.dir1 = 1
cont = cont + 1
End If
If Matriz(Cy - 1, Cx) = camino Then
objeto1.dir2 = 1
cont = cont + 1
End If
If Matriz(Cy, Cx - 1) = camino Then
objeto1.dir3 = 1
cont = cont + 1
End If
If Matriz(Cy + 1, Cx) = camino Then
objeto1.dir4 = 1
cont = cont + 1
End If
objeto1.np = cont
Direc = obtenerDir(objeto1.dir1, objeto1.dir2, objeto1.dir3, objeto1.dir4)
objeto1.Direc = Direc
evaluar = 0
End Function
Sub MostrarObjeto(ByVal figura As Buscador, ByVal Cx As Integer, ByVal Cy As
Integer)
Grafico.FillRectangle(Brushes.Red, figura.Cx * tam + Cx, figura.Cy * tam + Cy, tam,
tam)
End Sub
Sub MostrarPunto(ByVal Objeto1 As Buscador, ByVal Cx As Integer, ByVal Cy As

Integer, ByVal valor As Integer)
Select Case valor
Case 0 : Color = Color.FromArgb(255, 255, 255)
End Select
End Sub
Sub MostrarMatrizEnPantalla(ByVal Cx As Integer, ByVal Cy As Integer, ByVal A(,)

As Integer, ByVal nfilas As Integer, ByVal ncol As Integer)
Select Case Matriz(fila, col)
Case 0 : Grafico.FillRectangle(Brushes.White, col * tam + Cx, fila * tam + Cy, tam, tam)
Case 2 : Grafico.FillRectangle(Brushes.Gray, col * tam + Cx, fila * tam + Cy, tam, tam)
Case 3 : Grafico.FillRectangle(Brushes.Green, col * tam + Cx, fila * tam + Cy, tam, tam)
Case 4 : Grafico.FillRectangle(Brushes.Yellow, col * tam + Cx, fila * tam + Cy, tam, tam)
Case 5 : Grafico.FillRectangle(Brushes.Gold, col * tam + Cx, fila * tam + Cy, tam, tam)
Case 9 : Grafico.FillRectangle(Brushes.Blue, col * tam + Cx, fila * tam + Cy, tam, tam)
End Select
Next col
Next fila
End Sub

nf = 20
nc = 30
Objeto1 = New Buscador
InicializarObjeto(Objeto1)
PictureBox1.Width = nc * tam + 1
PictureBox1.Height = nf * tam + 1
End Sub
Private Sub BtnPrincipal_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles BtnPrincipal.Click
Dim Px2 As Integer = 0, Py2 As Integer = 0, valorbuscado As Integer = 2, huella
As Integer = 4
Dim camino As Integer = 0, terminado As Integer = 0, retorno As Integer = 5
Dim meta As Integer = 9, resultado As Integer = 0, dir As Integer = 0
Dim valor As Integer = 0, final As Integer = 0, cont As Integer = 0, NroObjeto As
Integer = 0
InicializarObjeto(Objeto1)
RecuperarArchivo(Matriz, nf, nc)
final = 0
Matriz(5, 7) = 9 ' para probar la metas
MostrarMatrizEnPantalla(Cx, Cy, Matriz, nf, nc)
MostrarObjeto(Objeto1, Cx, Cy)
NroObjeto = 0
Objetos(NroObjeto) = Objeto1
Matriz(Objeto1.Cy, Objeto1.Cx) = huella
PictureBox1.Refresh()
Do
Do
resultado = evaluar(Objeto1, Matriz, camino, meta)
If resultado = 1 Then GoTo fin
dir = Objeto1.Direc
Select Case dir
Case 1 : Objeto1.Cx = Objeto1.Cx + 1
Case 2 : Objeto1.Cy = Objeto1.Cy - 1
Case 3 : Objeto1.Cx = Objeto1.Cx - 1
Case 4 : Objeto1.Cy = Objeto1.Cy + 1
Case Else : terminado = 1
End Select
Matriz(Objeto1.Cy, Objeto1.Cx) = huella
MostrarPunto(Objeto1, Cx, Cy, huella)
NroObjeto = NroObjeto + 1
cont = cont + 1
Objeto1.nro = NroObjeto
Objetos(NroObjeto) = Objeto1
Loop While terminado = 0
terminado = 0
Do
Objeto1 = Objetos(NroObjeto)
resultado = evaluar(Objeto1, Matriz, camino, meta)
dir = Objeto1.Direc
If (NroObjeto < 0) Then GoTo fin
If dir > 0 Then
terminado = 1
Else
Matriz(Objeto1.Cy, Objeto1.Cx) = retorno
MostrarPunto(Objeto1, Cx, Cy, retorno)
NroObjeto = NroObjeto - 1
If (NroObjeto < 0) Then GoTo fin
cont = cont + 1
'Sleep(10)
End If
Loop While terminado = 0
If NroObjeto < 0 Then final = 1
Loop While final = 0
fin:
If NroObjeto > 0 Then
MsgBox(" X= " & Objetos(NroObjeto).cx & " Y = " & Objetos(NroObjeto).cy & " Mov ="
& cont)
Else
MsgBox(" no se encontro la meta y se hizo " & cont & " Movimientos ")
End If
End Sub
Private Sub btnBorrar_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles btnBorrar.Click
End Sub
End Class
11.11 PROBLEMA DE CRUCE
Se ingresas 4 puntos ( puntos inicial y final de dos rectas) determiner si esos puntos se
Cruzan o no se Cruzan
Module Module1
Sub Main()
Dim resultado1 As Integer = 0 ' " 0 no hay cruce 1 hay cruce
RecuperarPuntos(X, Y, np)
Console.WriteLine(" vector X")
Imprimir(X, np)
Console.WriteLine(" vector Y")
Imprimir(Y, np)
resultado1 = Interseccion(X, Y)
Console.WriteLine()
If resultado1 = 1 Then
Console.WriteLine(" EL valor es =={0} HAY CRUCE ", resultado1)
Else
Console.WriteLine(" EL valor es =={0} no hay cruce ", resultado1)
End If
Console.ReadLine()
End Sub
End Module
CODIGO DEL MODULO 2
Imports System.IO
Module Module2
Public X(4) As Single
Public Y(4) As Single
Public Sub RecuperarPuntos(ByVal X() As Single, ByVal Y() As Single, ByVal nf As
Integer)
Dim fila As Integer
Dim pos As Integer
Dim srLector = New StreamReader("E:\datos\Puntos2x4.txt")
X(fila) = Mid(cadena, 1, pos - 1)
Y(fila) = Mid(cadena, pos + 1, Len(cadena))
Next
srLector.Close()
End Sub
Function Interseccion(ByVal X() As Single, ByVal Y() As Single) As Integer
Dim XA(4) As Single
Dim YA(4) As Single
Dim xmin As Single
Dim ymin As Single
Dim xmax As Single
Dim ymax As Single
Dim px As Single
Dim py As Single
copiar(X, XA, 4)
limites(XA, xmin, xmax)
REM Console.WriteLine(" valores de xmin {0} xmax {1} ", xmin, xmax)
copiar(Y, YA, 4)
limites(YA, ymin, ymax)
If (X(0) = X(2) And Y(0) = Y(2)) Or (X(1) = X(3) And Y(1) = Y(3)) Then
resultado = 0
Else
px = ((X(0) * Y(1) - Y(0) * X(1)) * (X(2) - X(3)) - (X(0) - X(1)) * (X(2) * Y(3) - Y(2) *
X(3))) / ((X(0) - X(1)) * (Y(2) - Y(3)) - (Y(0) - Y(1)) * (X(2) - X(3)))
py = ((X(0) * Y(1) - Y(0) * X(1)) * (Y(2) - Y(3)) - (Y(0) - Y(1)) * (X(2) * Y(3) - Y(2) *
X(3))) / ((X(0) - X(1)) * (Y(2) - Y(3)) - (Y(0) - Y(1)) * (X(2) - X(3)))
If px >= xmin And px <= xmax And py >= ymin And py <= ymax Then
resultado = 1
Else
resultado = 0
End If
End If
Return resultado
End Function
Sub Imprimir(ByVal X() As Single, ByVal ne As Integer)

Dim fila As Integer
Console.Write(" {0} ", X(fila))
Next
End Sub
Sub copiar(ByVal A() As Single, ByRef B() As Single, ByVal ne As Integer)
Dim fila As Integer
B(fila) = A(fila)
Next
End Sub
Sub Ordenar(ByVal A() As Single, ByVal np As Integer)
Dim fila As Integer
Dim col As Integer
Dim temp As Single
For col = fila + 1 To np - 1
If (A(col) < A(fila)) Then
temp = A(fila)
A(fila) = A(col)
A(col) = temp
End If
Next col
Next fila
End Sub
Sub limites(ByRef A() As Single, ByRef xmin As Single, ByRef xmax As Single)
Ordenar(A, np)
xmin = A(1)
xmax = A(2)
End Sub
End Module
11.12 PROGRAMA DE LOCALIZACION DE LOTES

Option Explicit On
Public Class Form1
Dim px1 As Integer
Dim py1 As Integer
Dim ColorFondo As Color = Color.FromArgb(255, 255, 255)
Dim pen1 As Pen
Dim pen2 As Pen
Dim X(maxfilas) As Single
Dim Y(maxfilas) As Single
Dim Cx As Integer = 100
Dim Cy As Integer = 300
Dim ex As Single = 1
Dim ey As Single = -1
End Sub
End Sub
Private Sub Btndibujar_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles Btndibujar.Click
Dim fila As Integer
Dim resultado1 As Integer = 0
Dim cadenaPos As String
Dim psx As Integer
Dim psy As Integer
Dim pos As Integer
Dim px1 As Integer = 16
Dim py1 As Integer = 6
Grafico.DrawLine(pen1, 0, Cy, Cx * 2, Cy)
Grafico.DrawLine(pen1, Cx, 0, Cx, Cy * 2)
RecuperarTabla(Tabla, nreg, ncampos)
MostrarTabla(Tabla, nreg, ncampos)
For fila = 0 To nreg - 1
cadena1 = Tabla(fila, 2)
np = Tabla(fila, 1)
cadenaPos = Tabla(fila, 3)
pos = InStr(1, cadenaPos, ";")
psx = Mid(cadenaPos, 1, pos - 1)
psy = Mid(cadenaPos, pos + 1, Len(cadenaPos))
ObtenerVectores(X, Y, np, cadena1)
graficar(X, Y, Cx, Cy, ex, ey, np)
Next
End Sub
Sub graficar(ByVal X() As Single, ByVal Y() As Single, ByVal Cx As Integer, ByVal cy
As Integer, ByVal ex As Single, ByVal ey As Single, ByVal np As Integer)
Dim fila As Integer
For fila = 1 To np
Grafico.DrawLine(pen2, Cx + X(fila - 1) * ex, cy + Y(fila - 1) * ey, Cx + X(fila) *
ex, cy + Y(fila) * ey)
Next
End Sub
Private Sub PictureBox1_MouseDown(ByVal sender As System.Object, ByVal e As
System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseDown
Dim informe As String
Dim retorno As Integer = 0
Dim fila As Integer
Dim resultado1 As Integer = 0
Dim psx As Integer
Dim psy As Integer
Dim pos As Integer
Dim cadenaPos As String
Me.Text = "X = " & e.X & " Y = " & e.Y
px1 = e.X - Cx
py1 = -(e.Y - Cy)
txtX.Text = px1
txtY.Text = py1
X1(0) = px1
Y1(0) = py1
fila = 1
For fila = 0 To nreg - 1
cadena1 = Tabla(fila, 2)
np = Tabla(fila, 1)
cadenaPos = Tabla(fila, 3)
pos = InStr(1, cadenaPos, ";")
psx = Mid(cadenaPos, 1, pos - 1)
psy = Mid(cadenaPos, pos + 1, Len(cadenaPos))
ObtenerVectores(X, Y, np, cadena1)
X1(1) = psx
Y1(1) = psy
valor = 0
For k = 1 To np
X1(2) = X(k - 1) : Y1(2) = Y(k - 1)
X1(3) = X(k) : Y1(3) = Y(k)
resultado1 = Interseccion(X1, Y1)
If resultado1 = 1 Then
valor = 1
Exit For
End If
Next
ListBox1.Items.Add(" EL valor es == " & valor)
If valor = 0 Then
informe = Tabla(fila, 4)
Exit For
End If
Next
If valor = 0 Then
TextBox1.Text = informe
Else
TextBox1.Text = "FUERA"
End If
End Sub
End Class
CODIGO DEL MODULO
Imports System.IO
Module Module2
Public cadena As String
Public Const maxcol As Integer = 20
Public resultado As Integer = 0
Public Tabla(maxfilas, maxfilas) As String
Public X1(maxfilas) As Single
Public Y1(maxfilas) As Single
Public XA(maxfilas) As Single
Public YA(maxfilas) As Single
Public xmin As Single
Public xmax As Single
Public ymin As Single
Public ymax As Single
Public nreg As Integer = 4
Public ncampos As Integer = 5
Public nf As Integer = maxfilas, nc As Integer = maxcol
Public np As Integer
Public Ser As Integer = 1
Public espacio As Integer = 0
Public Sub RecuperarTabla(ByVal A(,) As String, ByVal nf As Integer, ByVal nc As

Integer)
Dim srLector = New StreamReader("E:\datos\Tabla5x2.txt")
Dim cadena As String, subcadena As String
Dim pos As Integer = 0, fila1 As Integer, longitud As String
Dim inicio As Integer = 1, cont As Integer = 0
For fila1 = 0 To nf - 1
inicio = 1 : cont = 0
Do
If pos > 0 Then
A(fila1, cont) = subcadena
inicio = pos + 1
cont += 1
Else
A(fila1, cont) = subcadena
cont += 1
Exit Do
End If
Next
srLector.Close()
End Sub
Sub MostrarTabla(ByVal A(,) As String, ByVal nf As Integer, ByVal nc As Integer)
Console.WriteLine()
Next
Next
End Sub
Function Interseccion(ByVal X() As Single, ByVal Y() As Single) As Integer

Dim px As Single
Dim py As Single
copiar(X, XA, 4)
limites(XA, xmin, xmax)
copiar(Y, YA, 4)
limites(YA, ymin, ymax)
px = ((X(0) * Y(1) - Y(0) * X(1)) * (X(2) - X(3)) - (X(0) - X(1)) * (X(2) * Y(3) - Y(2) *
X(3))) / ((X(0) - X(1)) * (Y(2) - Y(3)) - (Y(0) - Y(1)) * (X(2) - X(3)))
py = ((X(0) * Y(1) - Y(0) * X(1)) * (Y(2) - Y(3)) - (Y(0) - Y(1)) * (X(2) * Y(3) - Y(2) *
X(3))) / ((X(0) - X(1)) * (Y(2) - Y(3)) - (Y(0) - Y(1)) * (X(2) - X(3)))
If px >= xmin And px <= xmax And py >= ymin And py <= ymax Then
resultado = 1
Else
resultado = 0
End If
Return resultado
End Function
Sub copiar(ByVal A() As Single, ByRef B() As Single, ByVal ne As Integer)

Dim fila As Integer
B(fila) = A(fila)
Next
End Sub
Sub limites(ByRef A() As Single, ByRef xmin As Single, ByRef xmax As Single)
Dim fila As Integer
Dim col As Integer
REM primero ordenamos
Dim temp As Single
For fila = 0 To 2
For col = fila + 1 To 3
If (A(col) < A(fila)) Then
temp = A(fila)
A(fila) = A(col)
A(col) = temp
End If
Next col
Next fila
xmin = A(1)
xmax = A(2)
End Sub
Sub ObtenerVectores(ByRef X() As Single, ByRef Y() As Single, ByVal np As Integer,

ByVal cadena1 As String)
Dim pos1 As Integer
Dim pos2 As Integer
pos2 = 1
pos1 = InStr(1, cadena1, ";")
cadena2 = Mid(cadena1, 1, pos1 - 1)
X(fila) = cadena2
cadena1 = Mid(cadena1, pos1 + 1, Len(cadena1))
pos1 = InStr(1, cadena1, ";")
cadena2 = Mid(cadena1, 1, pos1 - 1)
Y(fila) = cadena2
cadena1 = Mid(cadena1, pos1 + 1, Len(cadena1))
Next
X(np) = X(0)
Y(np) = Y(0)
End Sub
End Module
11.13 MODELADO 3D si tiene los siguientes puntos para un cubo realizar el modelado
3D
CARA X Y Z X Y Z X Y Z X Y Z X Y Z
1 0 0 0 1 0 0 1 1 0 0 1 0 0 0 0
2 1 0 0 1 0 1 1 1 1 1 1 0 1 0 0
3 0 0 1 0 1 1 1 1 1 1 0 1 0 0 1
4 0 0 0 0 1 0 0 1 1 0 0 1 0 0 0
5 0 1 0 1 1 0 1 1 1 0 1 1 0 1 0
6 0 0 0 0 0 1 1 0 1 1 0 0 0 0 0
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
0 1 2 3 4 5 6 7 8 9 10
cubo rx ry rz ex ey ez tx ty tz color
1 0 0 0 8 0.3 4 0 0 0 4 0
2 0 0 0 0.2 2 4 0 0.3 0 5 0
3 0 0 0 8 2 0.2 0 0 4 3 0
4 0 0 0 0.2 2 4 8 0.3 0 2 0
5 0 0 0 2 1 0.2 1 0.3 0 6 0
6 0 0 0 5 2 0.2 3 0.3 0 1 0
7 0 0 0 1 2 0.1 0 0.3 0 4 0
CODIGO DEL MODULO 1

Imports System.IO
Module Module1
Public Color1 As Integer = 1
Public PosObjeto As Integer = 0
Public Const maxplanos As Integer = 10
Public MXYZ(maxfilas, maxcol) As Single
Public MXYZ1(maxfilas, maxcol) As Single ' matriz copia
Public MXYZ2(maxfilas, maxcol) As Single ' matriz copia
Public Mobjetos(maxfilas, maxcol) As Single ' matriz de ojetoscopia
Public Mplanos(maxplanos, maxfilas, maxcol) As Single ' matriz copia 2
Public Mplanos2(maxplanos, maxfilas, maxcol) As Single 'copia de mplanos para
trabajar

Public RoX As Integer = 0
Public Roy As Integer = 0
Public Roz As Integer = 0

Public Ez As Integer = 10
Public Eox As Single = 1
Public Eoy As Single = 1
Public Eoz As Integer = 1
Public modo As Integer = 1
Public nf As Integer = 6 '6
Public Normales(maxfilas, 4) As Single
Public pluma1 As Pen

Public tam As Single = 4
Public tx As Single = 100
Public ty As Single = 100
Public tox As Single = 0
Public toy As Single = 0
Public toz As Single = 0

Public Nobj As Integer = 7
Public NcObj As Integer = 11
Public nombrearchivo As String = "E:\datos\cubo15x6.txt"
' Public nombrearchivoObjetos As String = "E:\datos\Objetos11x4.txt"
Public nombrearchivoObjetos As String = "E:\datos\Casa11x7.txt"
Sub main()
RecuperarMatriz(nombrearchivo, MXYZ, nf, nc)
MostrarMatriz(MXYZ, nf, nc)
Console.ReadLine()
End Sub
Sub CopiarMatriz(ByVal A(,) As Single, ByRef B(,) As Single, ByVal nf As Integer,
Next
Next
End Sub
Sub MostrarMatriz(ByVal A(,) As Single, ByVal nf As Integer, ByVal nc As Integer)

Next
Console.WriteLine()
Next
End Sub
Sub IniciarMatriz(ByVal A(,) As Single, ByVal nf As Integer, ByVal nc As Integer)
A(fila, col) = 0
Next
Next
End Sub
Sub EscaladoXYZ(ByRef A(,) As Single, ByVal Ex As Single, ByVal Ey As Single,
ByVal Ez As Single, nf As Integer, nc As Integer)
Dim ncol As Integer = nc / 4
A(fila, col * 3) = A(fila, col * 3) * Ex
A(fila, col * 3 + 1) = A(fila, col * 3 + 1) * Ey
A(fila, col * 3 + 2) = A(fila, col * 3 + 2) * Ez
Next
Next
End Sub
Sub RotacionXYZ(A(,) As Single, ByVal AnguloX As Single, ByVal AnguloY As
Single, ByVal anguloZ As Single, nf As Integer, nc As Integer)

REM rotacion X
x1 = A(fila, col * 3)
y1 = A(fila, col * 3 + 1)
z1 = A(fila, col * 3 + 2)
x2 = x1
A(fila, col * 3) = x2
A(fila, col * 3 + 1) = y2
A(fila, col * 3 + 2) = z2
Next
Next
REM rotacion Y
y1 = A(fila, col * 3 + 1)
z1 = A(fila, col * 3 + 2)
y2 = y1
A(fila, col * 3 + 1) = y2
A(fila, col * 3 + 2) = z2
Next
Next
REM rotacion Z
y1 = A(fila, col * 3 + 1)
z1 = A(fila, col * 3 + 2)
z2 = z1
A(fila, col * 3 + 1) = y2
A(fila, col * 3 + 2) = z2
Next
Next
End Sub
Function ObtenerNormales(ByVal A(,) As Single, ByRef Normales(,) As Single, ByVal
nf As Integer) As Single
Dim mayor As Single = -100000
Single
As Single
x1 = A(fila, 0)
y1 = A(fila, 1)
z1 = A(fila, 2)
x2 = A(fila, 3)
y2 = A(fila, 4)
z2 = A(fila, 5)
x3 = A(fila, 6)
y3 = A(fila, 7)
z3 = A(fila, 8)
AX = x2 - x1
Ay = y2 - y1
Az = z2 - z1
Bx = x3 - x2
By = y3 - y2
Bz = z3 - z2
'PRODUCTO(CRUZ)
If R > 0 Then
Nx1 = NX / R
Else
Nx1 = 1000
End If
If R > 0 Then
Ny1 = Ny / R
Else
Ny1 = 1000
End If
If R > 0 Then
Nz1 = Nz / R
Else
Nz1 = 1000
End If
Pe = Nx1 * 0 + Ny1 * 0 + Nz1 * D
Normales(fila, 0) = Nx1
Normales(fila, 1) = Ny
Normales(fila, 2) = Nz1
If Nz1 > mayor Then mayor = Nz1
Normales(fila, 3) = Pe
Next
Return mayor
End Function
Sub TraslacionXYZ(A(,) As Single, ByVal tx As Single, ByVal ty As Single, ByVal tz

As Single, nf As Integer, nc As Integer)
A(fila, col * 3) = A(fila, col * 3) + tx
A(fila, col * 3 + 1) = A(fila, col * 3 + 1) + ty
A(fila, col * 3 + 2) = A(fila, col * 3 + 2) + tz
Next
Next
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByVal A(,) As Single, ByVal nf

As Integer, ByVal nc As Integer)
inicio = 1
A(fila, col) = Val(subcadena)
inicio = pos + 1
Next
Next
srLector.Close()
End Sub
Sub CopiarPlanoObjeto(A(,) As Single, Mplanos(,,) As Single, nf As Integer, nc As
Integer, nplano As Integer)
Mplanos(nplano, fila, col) = A(fila, col)
Next
Next
End Sub
Sub ObtenerPlanoObjeto(Mplanos(,,) As Single, A(,) As Single, nf As Integer, nc As
Integer, nplano As Integer)
A(fila, col) = Mplanos(nplano, fila, col)
Next
Next
End Sub
End Module
Imports System.IO
Public Class Form1
Sub Iniciar()
Dim fila As Integer
For fila = 1 To 5
Next
Next
RecuperarMatriz(nombrearchivo, MXYZ, nf, nc)
CopiarMatriz(MXYZ, MXYZ1, nf, nc)
DataGridView1.Columns(5).HeaderText = "D o W"


DataGridView1.Rows(1).Cells(2).Value = tx
DataGridView1.Rows(1).Cells(3).Value = ty

DataGridView1.Rows(3).Cells(0).Value = "Modo (0,1) vel "

DataGridView1.Rows(3).Cells(2).Value = modo
End Sub

Iniciar()
End Sub
Sub graficar(ByVal A(,) As Single, ByRef Normales(,) As Single, ByVal nf As Integer,
ByVal nc As Integer, Color1 As Integer)
Dim x1, y1, z1, mayor As Single
Dim px1, py1 As Single
Dim verde, rojo, azul As Integer

Dim cara As Integer = 0
mayor = ObtenerNormales(A, Normales, nf)
Dim Figura(ncol - 2) As Point
cara = fila
y1 = A(fila, col * 3 + 1)
z1 = A(fila, col * 3 + 2)
px1 = (x1 * D) / (D + z1)
py1 = (y1 * D) / (D + z1)
Figura(col).X = px1
Figura(col).Y = py1
Next
If modo = 1 Then
If Normales(fila, 2) > 0 Then 'solo dibuja si el normal es mayor que 0
Select Case Color1
Case 1
verde = Int((Normales(fila, 2) / mayor) * 255)
brocha1.Color = Drawing.Color.FromArgb(0, verde, 0)
Grafico.FillPolygon(brocha1, Figura, FillMode.Alternate)
Case 2
rojo = Int((Normales(fila, 2) / mayor) * 255)
brocha2.Color = Drawing.Color.FromArgb(rojo, 0, 0)
Case 3
azul = Int((Normales(fila, 2) / mayor) * 255)
brocha3.Color = Drawing.Color.FromArgb(0, 0, azul)
Case 4 ' gris
brocha4.Color = Drawing.Color.FromArgb(rojo, verde, azul)
Case 5 ' ladrillo
brocha5.Color = Drawing.Color.FromArgb(255, verde, azul)
Case 6 ' amarillo
brocha6.Color = Drawing.Color.FromArgb(rojo, verde, 0)
Case 7 'celeste
brocha7.Color = Drawing.Color.FromArgb(0, verde, azul)
Case 8 ' violeta
brocha8.Color = Drawing.Color.FromArgb(rojo, 0, azul)
End Select
End If
Else
Grafico.DrawPolygon(pluma1, Figura)
End If
Next fila
End Sub
Private Sub BtnIniciarTodo_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles BtnIniciarTodo.Click
Dim fila As Integer
AnguloX = CInt(DataGridView1.Rows(0).Cells(2).Value)
AnguloY = CInt(DataGridView1.Rows(0).Cells(3).Value)
AnguloZ = CInt(DataGridView1.Rows(0).Cells(4).Value)
tx = CInt(DataGridView1.Rows(1).Cells(2).Value)
ty = CInt(DataGridView1.Rows(1).Cells(3).Value)
tz = CInt(DataGridView1.Rows(1).Cells(4).Value)
D = CInt(DataGridView1.Rows(1).Cells(5).Value)
Ez = CInt(DataGridView1.Rows(2).Cells(4).Value)
modo = DataGridView1.Rows(3).Cells(2).Value
For fila = 0 To Nobj - 1
' fila = PosObjeto
ObtenerPlanoObjeto(Mplanos, MXYZ1, nf, nc, fila)
Color1 = CInt(DataGridView2.Rows(fila).Cells(10).Value)
CopiarMatriz(MXYZ1, MXYZ2, nf, nc)
RotacionXYZ(MXYZ2, AnguloX, AnguloY, AnguloZ, nf, nc)
EscaladoXYZ(MXYZ2, Ex, Ey, Ez, nf, nc)
TraslacionXYZ(MXYZ2, tx, ty, tz, nf, nc)
graficar(MXYZ2, Normales, nf, nc, Color1)
Next
End Sub
Private Sub TxtEscala_KeyDown(ByVal sender As System.Object, ByVal e As
System.Windows.Forms.KeyEventArgs) Handles TxtEscalado.KeyDown
If Ex >= -limite Then
Ex = Ex - 1
Else
Ex = limite
End If
If Ey >= -limite Then
Ey = Ey - 1
Else
Ey = limite
End If

If Ez >= -limite Then
Ez = Ez - 1
Else
Ez = limite
End If

If Ex <= limite Then
Ex = Ex + 1
Else
Ex = -limite
End If
If Ey <= limite Then
Ey = Ey + 1
Else
Ey = -limite
End If
If Ez <= limite Then
Ez = Ez + 1
Else
Ez = -limite
End If
End Select
' BtnObjeto_Click(sender, e)
TxtEscalado.Text = ""
End Sub
Private Sub txtRotacion_KeyDown(sender As Object, e As
Windows.Forms.KeyEventArgs) Handles txtRotacion.KeyDown
AnguloX = AnguloX - 1
Else
AnguloX = 3600
End If

AnguloY = AnguloY - 1
Else
AnguloY = 3600
End If

AnguloZ = AnguloZ - 1
Else
AnguloZ = 3600
End If

Else
AnguloX = 0
End If

Else
AnguloY = 0
End If
Else
AnguloZ = 0
End If
End Select
End Sub

Dim fila As Integer
pluma1 = New Pen(Color.Red, 2)
brocha1 = New SolidBrush(Color.Green)
brocha2 = New SolidBrush(Color.Red)
brocha3 = New SolidBrush(Color.Blue)
brocha4 = New SolidBrush(Color.Green) 'gris
brocha5 = New SolidBrush(Color.Red) 'ladrillo
brocha6 = New SolidBrush(Color.Blue) 'amarillo
brocha7 = New SolidBrush(Color.Blue) 'celeste
brocha8 = New SolidBrush(Color.Blue) 'violeta
Iniciar()
DataGridView2.RowCount = Nobj + 1
DataGridView2.ColumnCount = NcObj + 1
DataGridView2.Columns(0).HeaderText = "Objeto"
DataGridView2.Columns(1).HeaderText = "ROx"
DataGridView2.Columns(2).HeaderText = "ROy"
DataGridView2.Columns(3).HeaderText = "ROz"
DataGridView2.Columns(4).HeaderText = "EOx"
DataGridView2.Columns(5).HeaderText = "EOy"
DataGridView2.Columns(6).HeaderText = "EOz"
DataGridView2.Columns(7).HeaderText = "TOx"
DataGridView2.Columns(8).HeaderText = "TOy"
DataGridView2.Columns(9).HeaderText = "TOz"
DataGridView2.Columns(10).HeaderText = "Color"
For fila = 0 To NcObj
Next
txtNobj.Text = PosObjeto
End Sub
Private Sub Btnauto_Click(sender As Object, e As EventArgs) Handles Btnauto.Click
Timer1.Interval = vel
Timer1.Start()
End Sub
If AnguloX <= 360 * 5 Then
tx = tx + 0.1
ty = ty + 0.1
tz = tz + 0.1
Ex = Ex + 0.1
Ey = Ey + 0.1
Ez = Ez + 0.1
Else
AnguloX = 0
AnguloY = 0
AnguloZ = 0
tx = 0
ty = 0
tz = 0
Ex = 10
Ey = 10
Ez = 10
End If
End Sub
BtnDetener.Click
Timer1.Stop()
End Sub
Private Sub btnCargarObjeto_Click(sender As Object, e As EventArgs) Handles
btnCargarObjeto.Click
RecuperarMatriz(nombrearchivoObjetos, Mobjetos, Nobj, NcObj)
For fila = 0 To Nobj - 1
For col = 0 To NcObj - 1
DataGridView2.Rows(fila).Cells(col).Value = Mobjetos(fila, col)
Next
Next
End Sub
Private Sub BtnObjeto_Click(sender As Object, e As EventArgs) Handles

BtnObjeto.Click
Dim Fila As Integer
'Grafico.Clear(Color.White)
' obtener el nuevo valor de matriz
For Fila = 0 To Nobj - 1
For col = 0 To NcObj - 1
Mobjetos(Fila, col) = DataGridView2.Rows(Fila).Cells(col).Value
Next
Next
For Fila = 0 To Nobj - 1
Color1 = DataGridView2.Rows(Fila).Cells(10).Value
CopiarMatriz(MXYZ, MXYZ1, nf, nc)
RotacionXYZ(MXYZ1, Mobjetos(Fila, 1), Mobjetos(Fila, 2), Mobjetos(Fila, 3), nf,
nc)
EscaladoXYZ(MXYZ1, Mobjetos(Fila, 4), Mobjetos(Fila, 5), Mobjetos(Fila, 6), nf,
nc)
TraslacionXYZ(MXYZ1, Mobjetos(Fila, 7), Mobjetos(Fila, 8), Mobjetos(Fila, 9),
nf, nc)
CopiarPlanoObjeto(MXYZ1, Mplanos, nf, nc, Fila)
Next
'' graficar los planos obtenidos
'For Fila = 0 To Nobj - 1
' ObtenerPlanoObjeto(Mplanos, MXYZ1, nf, nc, Fila)
' graficar(MXYZ1, Normales, nf, nc, Fila + 1)
'Next
End Sub
Private Sub DataGridview_Click(ByVal sender As Object, ByVal e As

System.EventArgs) Handles DataGridView2.Click
Dim lugar As Integer
lugar = DataGridView2.CurrentRow.Index
txtNobj.Text = lugar
PosObjeto = Val(txtNobj.Text)
End Sub
Private Sub txtTrasObjeto_KeyDown(sender As Object, e As

Windows.Forms.KeyEventArgs) Handles txtTrasObjeto.KeyDown
tox = DataGridView2.Rows(PosObjeto).Cells(7).Value
toy = DataGridView2.Rows(PosObjeto).Cells(8).Value
toz = DataGridView2.Rows(PosObjeto).Cells(9).Value

Case 65 ' A TRSALACIONinverso de X
If tox >= -3600 Then
tox = tox - 1
Else
tox = 3600
End If

If toy >= -3600 Then
toy = toy - 1
Else
toy = 3600
End If

If toz >= -3600 Then
toz = toz - 1
Else
toz = 3600
End If

If tox <= 3600 Then
tox = tox + 1
Else
tox = 0
End If
Case 89 ' ROTACION EJE YAA

If toy <= 3600 Then
toy = toy + 1
Else
toy = 0
End If
Case 90 'TRASLACION EJE Z
If toz <= 3600 Then
toz = toz + 1
Else
toz = 0
End If
End Select
DataGridView2.Rows(PosObjeto).Cells(7).Value = tox
DataGridView2.Rows(PosObjeto).Cells(8).Value = toy
DataGridView2.Rows(PosObjeto).Cells(9).Value = toz
BtnObjeto_Click(sender, e)
txtTrasObjeto.Text = ""
End Sub
Private Sub txtRotObjeto_KeyDown(sender As Object, e As

Windows.Forms.KeyEventArgs) Handles txtRotObjeto.KeyDown
RoX = DataGridView2.Rows(PosObjeto).Cells(1).Value
Roy = DataGridView2.Rows(PosObjeto).Cells(2).Value
Roz = DataGridView2.Rows(PosObjeto).Cells(3).Value

If RoX >= -3600 Then
RoX = RoX - 1
Else
RoX = 3600
End If

If Roy >= -3600 Then
Roy = Roy - 1
Else
Roy = 3600
End If

If Roz >= -3600 Then
Roz = Roz - 1
Else
Roz = 3600
End If
If RoX <= 3600 Then
RoX = RoX + 1
Else
RoX = 0
End If

If Roy <= 3600 Then
Roy = Roy + 1
Else
Roy = 0
End If
If Roz <= 3600 Then
Roz = Roz + 1
Else
Roz = 0
End If
End Select
DataGridView2.Rows(PosObjeto).Cells(1).Value = RoX
DataGridView2.Rows(PosObjeto).Cells(2).Value = Roy
DataGridView2.Rows(PosObjeto).Cells(3).Value = Roz
txtRotObjeto.Text = ""
End Sub
Private Sub txtEscObjeto_KeyDown(sender As Object, e As

Windows.Forms.KeyEventArgs) Handles txtEscObjeto.KeyDown
Eox = DataGridView2.Rows(PosObjeto).Cells(4).Value
Eoy = DataGridView2.Rows(PosObjeto).Cells(5).Value
Eoz = DataGridView2.Rows(PosObjeto).Cells(6).Value

If Eox >= -3600 Then
Eox = Eox - 1
Else
Eox = 3600
End If

If Eoy >= -3600 Then
Eoy = Eoy - 1
Else
Eoy = 3600
End If

If Eoz >= -3600 Then
Eoz = Eoz - 1
Else
Eoz = 3600
End If

If Eox <= 3600 Then
Eox = Eox + 1
Else
Eox = 0
End If

If Eoy <= 3600 Then
Eoy = Eoy + 1
Else
Roy = 0
End If
If Eoz <= 3600 Then
Eoz = Eoz + 1
Else
Eoz = 0
End If
End Select
DataGridView2.Rows(PosObjeto).Cells(4).Value = Eox
DataGridView2.Rows(PosObjeto).Cells(5).Value = Eoy
DataGridView2.Rows(PosObjeto).Cells(6).Value = Eoz
txtEscObjeto.Text = ""
End Sub
Private Sub txtTraslacion_KeyDown(sender As Object, e As

Windows.Forms.KeyEventArgs) Handles txtTraslacion.KeyDown
If tx >= -limite Then
tx = tx - 1
Else
tx = limite
End If
If ty >= -limite Then
ty = ty - 1
Else
ty = limite
End If

If tz >= -limite Then
tz = tz - 1
Else
tz = limite
End If

If tx <= limite Then
tx = tx + 1
Else
tx = -limite
End If
If ty <= limite Then
ty = ty + 1
Else
ty = -limite
End If
If tz <= limite Then
tz = tz + 1
Else
tz = -limite
End If
End Select
End Sub
Private Sub BtnAuto2_Click(sender As Object, e As EventArgs) Handles

BtnAuto2.Click
Timer2.Start()
'Randomize()
End Sub
Sub aleatorio()
Dim robjeto As Integer
Dim rprop As Integer
Dim valorProp As Integer
robjeto = Int(Rnd() * Nobj)
rprop = 1 + Int(Rnd() * 9)
valorProp = DataGridView2.Rows(robjeto).Cells(rprop).Value
Select rprop
Case 1, 2, 3
If valorProp < 3600 Then
valorProp = valorProp + 1
Else
valorProp = 0
End If
Case 4, 5, 6 'escalado
Else
valorProp = 0
End If
Case 7, 8, 9 'traslado
Else
valorProp = 0
End If
End Select
PosObjeto = robjeto
DataGridView2.Rows(PosObjeto).Cells(rprop).Value = valorProp
End Sub
aleatorio()
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
aleatorio()
End Sub
Private Sub btnDetener2_Click(sender As Object, e As EventArgs) Handles
btnDetener2.Click
Timer2.Stop()
End Sub
End Class
MODELADO 3D
La siguiente aplicación permite realizar las operaciones de rotación, traslacion y
escalado 3D
Permite dibujar las siguientes primitivas
Plano
Caja
Piramide
Cono
Esfera
Figura Cargada del archivo
Realiza las operaciones
Borrar
Actualizar. Actualiza los datos que figuran en la cuadricula
Operar. Dibuja las primitivas
Con las teclas X,Y Z se realiza las operaciones de rotación trsalacion y escalado
Y se puede escoger tanto para el objtfo como el fondo
Se trabaja con rellenado usando Vectores Normales
Posteriormente se vera las coordenadas globales y locales
Diseño del formulario

' *********** Codigo del formulario

Imports System.IO
Public Class Form1
Sub GraficarCara(cx As Integer, cy As Integer, XW() As Single, YW() As Single, _
ZW() As Single, cadena As String, ncara As Integer)
Dim mayor As Single
Dim col, P1, np, px1, py1, vrojo, vverde, vazul, vtra As Integer
np = Len(cadena) / 3
Dim Puntos(np - 1) As Point
mayor = ObtenerNormales(XW, YW, ZW, NormalX, NormalY, NormalZ, NormalW,
CadCaras, ncaras)
Dim CadLetra As String
Dim Pos As Integer
Pos = col * 3 + 1
CadLetra = Mid(cadena, Pos, 3)
P1 = Val(CadLetra)
px1 = cx + (XW(P1) * D) / (D + ZW(P1))
py1 = cy - (YW(P1) * D) / (D + ZW(P1))
Puntos(col).X = (px1)
Puntos(col).Y = (py1)
Next
Select Case modorelleno
Case 1
Grafico.DrawPolygon(Pens.Blue, Puntos)
Case 2
If NormalZ(ncara) > 0 Then 'solo dibuja si el normal es mayor que 0
vrojo = Int((NormalZ(ncara) / (mayor)) * rojo)
vverde = Int((NormalZ(ncara) / (mayor)) * verde)
vazul = Int((NormalZ(ncara) / (mayor)) * azul)
brocha.Color = Drawing.Color.FromArgb(vrojo, vverde, vazul)
Grafico.FillPolygon(brocha, Puntos, Drawing2D.FillMode.Alternate)
End If
Case 3
If NormalZ(ncara) > 0 Then 'solo dibuja si el normal es mayor que 0
vrojo = Int((NormalZ(ncara) / (mayor)) * rojo)
vverde = Int((NormalZ(ncara) / (mayor)) * verde)
vazul = Int((NormalZ(ncara) / (mayor)) * azul)
brocha.Color = Drawing.Color.FromArgb(vrojo, vverde, vazul)
End If
Grafico.DrawPolygon(Pens.Red, Puntos)
End Select
End Sub
Sub GraficarObjeto(Cx, Cy, XW, YW, ZW, Cadcaras, ncaras)
Dim col As Integer
Pen.Color = Color.Red
brocha.Color = Color.Green
For col = 0 To ncaras - 1
GraficarCara(Cx, Cy, XW, YW, ZW, Cadcaras(col), col)
Next
End Sub
Pen = New Pen(Color.Blue, 2)
PlumaCoord = New Pen(Color.Blue, 1)
BrochaCoord = New SolidBrush(Color.FromArgb(255, 255, 0))
Iniciar()
Grafico.Clear(Color.FromArgb(rojo1, verde1, azul1))
End Sub
Sub Iniciar()
Dim fila As Integer
For fila = 1 To 5
Next
Next
DataGridView1.Columns(5).HeaderText = "DW/paso"

DataGridView1.Rows(0).Cells(5).Value = prot

DataGridView1.Rows(1).Cells(5).Value = ptras

DataGridView1.Rows(2).Cells(5).Value = pesca
DataGridView1.Rows(3).Cells(0).Value = "Modo (0,1) vel relleno"

DataGridView1.Rows(3).Cells(2).Value = modorelleno
DataGridView1.Rows(3).Cells(4).Value = PonerCoord
DataGridView1.Rows(4).Cells(0).Value = "Objeto l/a/p tipo "

DataGridView1.Rows(4).Cells(2).Value = ancho
DataGridView1.Rows(4).Cells(3).Value = alto
DataGridView1.Rows(4).Cells(4).Value = Profundidad
DataGridView1.Rows(4).Cells(5).Value = TipoObjeto
DataGridView1.Rows(5).Cells(0).Value = "Color RGBA "

DataGridView1.Rows(5).Cells(2).Value = rojo
DataGridView1.Rows(5).Cells(3).Value = verde
DataGridView1.Rows(5).Cells(4).Value = azul
DataGridView1.Rows(5).Cells(5).Value = Transparencia
DataGridView1.Rows(6).Cells(0).Value = "Color RGBAFondo "

DataGridView1.Rows(6).Cells(2).Value = rojo1
DataGridView1.Rows(6).Cells(3).Value = verde1
DataGridView1.Rows(6).Cells(4).Value = azul1
DataGridView1.Rows(6).Cells(5).Value = Transparencia1
End Sub
Private Sub txtRotacion_KeyDown(sender As Object, e As

Windows.Forms.KeyEventArgs) Handles txtRotacion.KeyDown
AnguloX = AnguloX - prot
Else
AnguloX = 3600
End If
AnguloY = AnguloY - prot
Else
AnguloY = 3600
End If

AnguloZ = AnguloZ - prot
Else
AnguloZ = 3600
End If

AnguloX = AnguloX + prot
Else
AnguloX = 0
End If

AnguloY = AnguloY + prot
Else
AnguloY = 0
End If
AnguloZ = AnguloZ + prot
Else
AnguloZ = 0
End If
End Select
MnuActualizar_Click(sender, e)
MnuOperar_Click(sender, e)
End Sub
Private Sub txtTraslacion_KeyDown(sender As Object, e As
Windows.Forms.KeyEventArgs) Handles txtTraslacion.KeyDown
If tx >= -limiteT Then
tx = tx - ptras
Else
tx = limiteT
End If
If ty >= -limiteT Then
ty = ty - ptras
Else
ty = limiteT
End If

If tz >= -limiteT Then
tz = tz - ptras
Else
tz = limiteT
End If

If tx <= limiteT Then
tx = tx + ptras
Else
tx = -limiteT
End If
If ty <= limiteT Then
ty = ty + ptras
Else
ty = -limiteT
End If
If tz <= limiteT Then
tz = tz + ptras
Else
tz = -limiteT
End If
End Select
End Sub
Private Sub TxtEscala_KeyDown(ByVal sender As System.Object, ByVal e As
System.Windows.Forms.KeyEventArgs) Handles TxtEscalado.KeyDown
If Ex >= -limiteE Then
Ex = Ex - pesca
Else
Ex = limiteE
End If
If Ey >= -limiteE Then
Ey = Ey - pesca
Else
Ey = limiteE
End If
If Ez >= -limiteE Then
Ez = Ez - pesca
Else
Ez = limiteE
End If
If Ex <= limiteE Then
Ex = Ex + pesca
Else
Ex = -limiteE
End If
If Ey <= limiteE Then
Ey = Ey + pesca
Else
Ey = -limiteE
End If
If Ez <= limiteE Then
Ez = Ez + pesca
Else
Ez = -limiteE
End If
End Select
TxtEscalado.Text = ""
End Sub
If cont < 500 Then
AnguloX = AnguloX + prot
Else
If cont < 1000 Then
AnguloY = AnguloY + prot
Else
If cont < 2000 Then
AnguloZ = AnguloZ + prot
Else
tx = 0
ty = 0
tz = 0
cont = 0
End If
End If
End If
cont = cont + 1
End Sub
Private Sub MenuCaja(sender As Object, e As EventArgs) Handles mnuCaja.Click

TipoObjeto = 1
End Sub
Private Sub MnuEsfera_Click(sender As Object, e As EventArgs) Handles
MnuEsfera.Click
TipoObjeto = 3
End Sub
Private Sub mnuBorrar_Click(sender As Object, e As EventArgs) Handles

mnuBorrar.Click
End Sub
Private Sub MnuActualizar_Click(sender As Object, e As EventArgs) Handles

MnuActualizar.Click
AnguloX = CInt(DataGridView1.Rows(0).Cells(2).Value)
AnguloY = CInt(DataGridView1.Rows(0).Cells(3).Value)
prot = CInt(DataGridView1.Rows(0).Cells(5).Value)
tx = CInt(DataGridView1.Rows(1).Cells(2).Value)
ty = CInt(DataGridView1.Rows(1).Cells(3).Value)
tz = CInt(DataGridView1.Rows(1).Cells(4).Value)
ptras = CInt(DataGridView1.Rows(1).Cells(5).Value)
Ez = CInt(DataGridView1.Rows(2).Cells(4).Value)
pesca = CInt(DataGridView1.Rows(2).Cells(5).Value)
modorelleno = DataGridView1.Rows(3).Cells(2).Value
PonerCoord = DataGridView1.Rows(3).Cells(4).Value
D = CInt(DataGridView1.Rows(3).Cells(5).Value)
ancho = DataGridView1.Rows(4).Cells(2).Value
alto = DataGridView1.Rows(4).Cells(3).Value
Profundidad = DataGridView1.Rows(4).Cells(4).Value
TipoObjeto = DataGridView1.Rows(4).Cells(5).Value
modorelleno = DataGridView1.Rows(3).Cells(2).Value
rojo = DataGridView1.Rows(5).Cells(2).Value
verde = DataGridView1.Rows(5).Cells(3).Value
azul = DataGridView1.Rows(5).Cells(4).Value
Transparencia = DataGridView1.Rows(5).Cells(5).Value
rojo1 = DataGridView1.Rows(6).Cells(2).Value
verde1 = DataGridView1.Rows(6).Cells(3).Value
azul1 = DataGridView1.Rows(6).Cells(4).Value
Transparencia1 = DataGridView1.Rows(6).Cells(5).Value
End Sub
Private Sub MnuPiramide_Click(sender As Object, e As EventArgs) Handles
MnuPiramide.Click
TipoObjeto = 2
End Sub
Private Sub MnuPlano_Click(sender As Object, e As EventArgs) Handles

MnuPlano.Click
TipoObjeto = 5
End Sub
Private Sub MnuOperar_Click(sender As Object, e As EventArgs) Handles

MnuOperar.Click
Select Case TipoObjeto
Case 5 ' PLANO
nv = 4
ncaras = 1
CopiarVertices(PlanoX, PlanoY, PlanoZ, WX, WY, WZ, nv)
CopiarCaras(CadenasPlano, CadCaras, ncaras)
Case 1
nv = 8
ncaras = 6
CopiarVertices(CuboX, CuboY, CuboZ, WX, WY, WZ, nv)
CopiarCaras(CadenasCubo, CadCaras, ncaras)
Case 2 'piramide
nv = 5
ncaras = 5
CopiarVertices(PiramideX, PiramideY, PiramideZ, WX, WY, WZ, nv)
CopiarCaras(CadenasPiramide, CadCaras, ncaras)
Case 3
Dim col, cont As Integer
Dim px1, py1, pz1, px2, py2, pz2, vang, vseg, arz, arx, radio As Single
Dim psx1, psy1, psz1, psx2, psy2, psz2 As Single
ncaras = (ring) * (Segmentos - 1)
nv = ring * Segmentos
IniciarVector(EsferaX, maximo, 0, -1)
IniciarVector(EsferaY, maximo, 0, -1)
IniciarVector(EsferaZ, maximo, 0, -1)
radio = 2
px1 = radio : py1 = 0 : pz1 = 0
arz = 0
vseg = (Math.PI) * 2 / Segmentos '(Segmentos)
vang = (Math.PI) / (ring - 1)
cont = 0
For col = 0 To ring - 1 'Giro alrededor del eje z
px2 = CSng(px1 * Math.Cos(arz) - py1 * Math.Sin(arz))
py2 = CSng(px1 * Math.Sin(arz) + py1 * Math.Cos(arz))
pz2 = pz1
arz = arz + vang
psx1 = px2
psy1 = py2
psz1 = pz2
arx = 0
' giro alrededor del eje x
For fila = 0 To Segmentos - 1
psx2 = psx1
psy2 = CSng(psy1 * Math.Cos(arx) - psz1 * Math.Sin(arx))
psz2 = CSng(psy1 * Math.Sin(arx) + psz1 * Math.Cos(arx))
cont = fila * ring + col
EsferaX(cont) = psx2
EsferaY(cont) = psy2
EsferaZ(cont) = psz2
arx = arx + vseg
Next
arz = arz + vang
Next
'******************
ObtenerCarasEsfera(CadenaEsfera, ncaras, ring)
CopiarVertices(EsferaX, EsferaY, EsferaZ, WX, WY, WZ, nv)
CopiarCaras(CadenaEsfera, CadCaras, ncaras)
End Select
RotacionXYZ(WX, WY, WZ, AnguloX, AnguloY, AnguloZ, nv)
TraslacionXYZ(WX, WY, WZ, tx, ty, tz, nv)
EscaladoXYZ(WX, WY, WZ, Ex, Ey, Ez, nv)
GraficarObjeto(Cx, Cy, WX, WY, WZ, CadCaras, ncaras)
End Sub
Private Sub MnuAutomatico_Click(sender As Object, e As EventArgs) Handles

MnuAutomatico.Click
Timer1.Start()
End Sub
Private Sub MnuDetener_Click(sender As Object, e As EventArgs) Handles

MnuDetener.Click
Timer1.Stop()
End Sub
End Class
'***************mdoulo 1
Imports System.IO
Module Module1
Public PonerCoord As Integer = 1 ' pone cooordendas
Public rojo As Integer = 255
Public verde As Integer = 255
Public azul As Integer = 255
Public Transparencia As Integer = 0
Public rojo1 As Integer = 0
Public verde1 As Integer = 0
Public azul1 As Integer = 0
Public Transparencia1 As Integer = 0
Public alto As Single = 1
Public ancho As Single = 1
Public BrochaCoord As SolidBrush
Public Cad() As String = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A"}
Public CadCaras(maximo) As String
Public CadCarasTemp(maximo) As String
Public CadenasCubo() As String = {"000003002001", "001002006005",
"004005006007", _
"000004007003", "003007006002", "000001005004",
"000003002001"}
Public CadenasPiramide() As String = {"000001002003", "001004002", "002004003",
"003004000", "000004001"}
Public CadenasPlano() As String = {"000001002003"}
Public CadenaEsfera(maximo) As String
Public cont As Integer
Public CuboX() As Single = {0, 1, 1, 0, 0, 1, 1, 0, 0}
Public CuboY() As Single = {0, 0, 1, 1, 0, 0, 1, 1, 0}
Public CuboZ() As Single = {0, 0, 0, 0, 1, 1, 1, 1, 0}
Public Cz As Integer = 0
Public EsferaX(maximo) As Single
Public EsferaY(maximo) As Single
Public EsferaZ(maximo) As Single
Public Ez As Integer = 80
Public limiteE As Integer = 200
Public limiteT As Integer = 200
Public modorelleno As Integer = 3
Public ncaras As Integer
Public NombreArchivo As String = "E:\datos\esfera5x5.txt"
Public NormalW(maximo) As Single
Public NormalX(maximo) As Single
Public NormalY(maximo) As Single
Public NormalZ(maximo) As Single
Public nv As Integer = 900 '
Public Pen As Pen
Public pesca As Single = 1
Public PiramideX() As Single = {0, 2, 2, 0, 1, 0}
Public PiramideY() As Single = {0, 0, 0, 0, 2, 0}
Public PiramideZ() As Single = {0, 0, 2, 2, 1, 0}
Public PlanoX() As Single = {0, 1, 1, 0, 0}
Public PlanoY() As Single = {0, 0, 1, 1, 0}
Public PlanoZ() As Single = {0, 0, 0, 0, 0}
Public PlumaCoord As Pen
Public Profundidad As Single = 1
Public prot As Single = 10
Public ptras As Single = 1
Public ring As Integer = 16
Public Segmentos As Integer = 16
Public tipo As Integer
Public TipoObjeto As Integer = 1 ' es caja
Public tx As Single = 0
Public ty As Single = 0
Public WX(maximo) As Single
Public WY(maximo) As Single
Public WZ(maximo) As Single
End Module
'***************** mdoulo 2
Imports System.IO
Module Module2
Sub ImprimirVector(CadCaras() As String, n As Integer)
Dim fila As Integer
For fila = 0 To n - 1
Console.WriteLine(" {0} {1} {2}", fila, vbTab, CadCaras(fila))
Next
End Sub
Sub ObtenerCarasEsfera(CadCaras() As String, ByRef ncaras As Integer, np As
Integer)
Dim fila, cont As Integer
For fila = 0 To ncaras - 1
CadCarasTemp(fila) = ""
CadCarasTemp(fila) = CadCarasTemp(fila) + Format(fila, "00#") + Format(fila +
1, "00#") + _
Format(fila + np + 1, "00#") + Format(fila + np, "00#")
Next
cont = 0 ' eliminando las caras fallidas
If fila Mod np = np - 1 Then Continue For
CadCaras(cont) = CadCarasTemp(fila)
cont = cont + 1
Next
ncaras = cont
End Sub
Function ObtenerNormales(X() As Single, Y() As Single, Z() As Single, _
XNORM() As Single, YNORM() As Single, ZNORM() As Single,
WNORM() As Single, _
Cadenas() As String, ncaras As Integer)
Dim Cadena As String
Dim p0, p1, p2 As Integer
Single
As Single
Cadena = Cadenas(fila)
p0 = Val(Mid(Cadena, 1, 3))
x0 = X(p0)
y0 = Y(p0)
z0 = Z(p0)
x1 = X(p1)
y1 = Y(p1)
z1 = Z(p1)
x2 = X(p2)
y2 = Y(p2)
z2 = Z(p2)
AX = x1 - x0
Ay = y1 - y0
Az = z1 - z0
Bx = x2 - x1
By = y2 - y1
Bz = z2 - z1
'PRODUCTO(CRUZ)
If R > 0 Then
Nx1 = NX / R
Ny1 = Ny / R
Nz1 = Nz / R
Else
Nx1 = 1000
Ny1 = 1000
Nz1 = 1000
End If
Pe = Nx1 * 0 + Ny1 * 0 + Nz1 * D
XNORM(fila) = Nx1
YNORM(fila) = Ny1
ZNORM(fila) = Nz1
If Nz1 > mayor Then mayor = Nz1
WNORM(fila) = Pe
Next
Return mayor
End Function
Sub CopiarVertices(X() As Single, Y() As Single, Z() As Single, _
X1() As Single, Y1() As Single, Z1() As Single, nf As Integer)
Dim fila As Integer
X1(fila) = X(fila)
Y1(fila) = Y(fila)
Z1(fila) = Z(fila)
Next
End Sub
Sub CopiarCaras(Caras() As String, Caras1() As String, nf As Integer)
Dim fila As Integer
Caras1(fila) = Caras(fila)
Next
End Sub
Sub EscaladoXYZ(X() As Single, Y() As Single, Z() As Single, _
ByVal Ex As Single, ByVal Ey As Single, ByVal Ez As Single, nf As Integer)
Dim fila As Integer
X(fila) = X(fila) * Ex
Y(fila) = Y(fila) * Ey
Z(fila) = Z(fila) * Ez
Next
End Sub
Sub TraslacionXYZ(X() As Single, Y() As Single, Z() As Single, _
ByVal tx As Single, ByVal ty As Single, ByVal tz As Single, nf As Integer)
Dim fila As Integer
X(fila) = X(fila) + tx
Y(fila) = Y(fila) + ty
Z(fila) = Z(fila) + tz
Next
End Sub
Sub RotacionXYZ(X() As Single, Y() As Single, Z() As Single, _
ByVal AnguloX As Single, ByVal AnguloY As Single, ByVal anguloZ As
Single, nf As Integer)
REM rotacion X
x1 = X(fila)
y1 = Y(fila)
z1 = Z(fila)
x2 = x1
X(fila) = x2
Y(fila) = y2
Z(fila) = z2
Next
REM rotacion Y
x1 = X(fila)
y1 = Y(fila)
z1 = Z(fila)
y2 = y1
X(fila) = x2
Y(fila) = y2
Z(fila) = z2
Next
REM rotacion Z
x1 = X(fila)
y1 = Y(fila)
z1 = Z(fila)
z2 = z1
X(fila) = x2
Y(fila) = y2
Z(fila) = z2
Next
End Sub
Sub IniciarVector(A() As Single, np As Integer, tipo As Integer, valor As Integer)
Dim fila As Integer
If tipo = 1 Then
A(fila) = fila
Else
A(fila) = valor
End If
Next
End Sub
Sub Main()
ncaras = ring * Segmentos
ObtenerCarasEsfera(CadCaras, ncaras, ring)
ImprimirVector(CadCaras, ncaras)
Console.ReadLine()
End Sub
End Module
11.14 PROGRAMACION ADN
Hoy quería presentar un tema un poco relacionado con la entrada sobre combinatoria
algorítmica pero más relacionado con lo que considero que va a ser el futuro de la
computación y (¿por qué no?) un poco de biología. Además aprovecho para
adelantarme a wikipedia que casi no tiene información al respecto de esto.
Empecemos por la parte biológica. El ADN (DNA en inglés, ácido desoxirribonucleico)
es básicamente la información de todo lo que forma un ser vivo. Cada célula tiene
nuestro ADN y éste es quién dicta qué se forma y cuando y de qué manera. Realmente
lo que nos interesa de esto es que es una doble cadena de nucleótidos.
Ejemplo de cadena
La primer parte que nos interesa de todo esto es que en esta doble cadena las dos
partes están pegadas entre sí por una regla muy sencilla. Si de un lado hay una
Adenina, del otro hay una Timina y si de un lado hay una Citosina, del otro hay una
Guanina, por lo que si las escribimos como lista, siempre se ve del siguiente estilo.
ATGTTAACGGTG…
TACAATTGCCAC…
Resulta que uno de los problemas con que TODA la información de cómo estamos
formados esté ahí es que si se modifica en una célula, esa célula puede empezar a
funcionar diferente, a producir otras cosas. Eso es justamente lo que hace un virus. Un
virus no tiene la capacidad de reproducirse solo, pero puede llegar a una célula,
inyectar su ADN y hacer que la célula empiece a producir copias del virus (adentro de
ella) hasta que explota y los virus nuevos van infectando células nuevas hasta matar al
organismo. Sin embargo, como este es un problema que lleva suficiente tiempo, las
células han desarrollado medios para evitar esto (hasta cierto punto). Lo que tienen son
una enzimas llamadas enzimas de corte, que van leyendo una parte del ADN y si
encuentra cierta secuencia (ajena al ADN usual, como lo que pondría un virus) cortan
el ADN en ese momento.
Programa que evalúa si es una cadena adn lo corta y lo replica
Module Module2
Function Replicar(cadena As String) As String
Dim fila As Integer
Dim letra1 As String = "A"
Dim cadena2 As String = ""
For fila = 0 To Len(cadena) - 1
letra1 = cadena(fila)
Select Case letra1
Case "A" : letra2 = "T"
Case "T" : letra2 = "A"
Case "C" : letra2 = "G"
Case "G" : letra2 = "C"
End Select
cadena2 = cadena2 + letra1 + letra2
Next
Return cadena2
End Function
Function EvaluarCadena(ByVal adn As String) As Boolean
Dim largo As Integer, col As Integer
Dim valor As Boolean = True
Dim letra As Char, letra1 As Char
largo = Len(adn)
If largo Mod 2 <> 0 Then
valor = False
Else
For col = 0 To largo - 2 Step 2
letra = adn(col)
letra1 = adn(col + 1)
Select Case letra
Case "A" : If letra1 <> "T" Then
valor = False
Exit For
End If
Case "T" : If letra1 <> "A" Then
valor = False
Exit For
End If
Case "C" : If letra1 <> "G" Then
valor = False
Exit For
End If
Case "G" : If letra1 <> "C" Then
valor = False
Exit For
End If
Case Else
valor = False
Exit For
End Select
Next
End If
EvaluarCadena = valor
End Function
Sub dividir(adn As String, ByRef adn1 As String, ByRef adn2 As String)
Dim col As Integer
adn1 = "" : adn2 = ""
For col = 0 To Len(adn) - 1
If (col Mod 2 = 0) Then
adn1 = adn1 + adn(col)
Else
End If
Next
End Sub
End Module
Module Module1
Sub Main()
Dim resultado As Boolean
Dim adn As String = "ATCGTA", adn1 As String = "", adn2 As String = ""
Console.WriteLine(" Ingrese secuencia")
adn1 = Console.ReadLine
Console.WriteLine("ADN Original {0}", adn)
resultado = EvaluarCadena(adn1)
If resultado = True Then
Console.WriteLine("secuencia correcta")
Else
Console.WriteLine("secuencia INCORRECTA")
End If
If resultado = True Then
dividir(adn, adn1, adn2)
Console.WriteLine("CADENAS DIVIDIDAS")
Console.WriteLine("Cadena 1 {0}", adn1)
Console.WriteLine("Cadena 2 {0}", adn2)
Console.WriteLine("Cadenas Replicada")
Console.WriteLine("Cadena 1 {0}", Replicar(adn1))
Console.WriteLine("Ccadena 2 {0}", Replicar(adn2))
End If
Console.ReadLine()
End Sub
End Module
Las cadenas son
Cadena
Cadena1 izquierda I
Cadena2 Cadena derecha D
I I D I Cadena1R = Replicar(Cadena1, 1) Cadena1R = Replicar(Cadena2,1)

I I D D Cadena1R = Replicar(Cadena1, 1) Cadena1R = Replicar(Cadena2,2)
I D D I Cadena1R = Replicar(Cadena1, 2) Cadena1R = Replicar(Cadena2,1)
I D D D Cadena1R = Replicar(Cadena1, 2) Cadena1R = Replicar(Cadena2,2)
Prueba con opción 2
Pruebe con opción 2, 3 y 4

CODIGO DEL MODULO 2

Module Module2
Public ADN As String
Public Cadena As String
Public Cadena1, Cadena2 As String
Public Cadena1R, Cadena2R As String
Public Nrepli As Integer = 4
Public k As Integer = 0
Public CadR(maxfilas) As String
Public A(maxfilas, maxcol) As String
Public nc As Integer
Sub CadenasMatriz(CadR() As String, filaini As Integer, nf As Integer, nrocol As
Integer)
Dim fila As Integer
For fila = filaini To nf - 1
A(fila, nrocol) = CadR(fila)
Next
End Sub
Sub ReplicarADN(cadena As String, cont As Integer, lim As Integer)
Console.WriteLine("etapa {0} ", cont)
dividir(cadena, Cadena1, Cadena2)
Cadena1R = Replicar(Cadena1, 2) ' izquierdo
Cadena2R = Replicar(Cadena2, 1) ' derecho
k=k+1
CadR(k) = Cadena1R
k=k+1
CadR(k) = Cadena2R
Console.WriteLine("cadena replicada1 IZ {0} ", Cadena1R)
Console.WriteLine("cadena replicada2 DER {0} ", Cadena2R)
If cont < lim Then
ReplicarADN(Cadena1R, cont + 1, lim)
ReplicarADN(Cadena2R, cont + 1, lim)
End If
End Sub
Function Replicar(cadena As String, tipo As Integer) As String
Dim fila As Integer
Dim letra2 As String = "B"
letra1 = cadena(fila)
Select Case letra1
Case "A" : letra2 = "T"
Case "T" : letra2 = "A"
Case "C" : letra2 = "G"
Case "G" : letra2 = "C"
End Select
Select Case tipo
Case 1 : cadena2 = cadena2 + letra2 + letra1 ' izquierdo
Case 2 : cadena2 = cadena2 + letra1 + letra2 ' derecho
End Select
Next
Return cadena2
End Function
Sub ImprimirCadenas(cadena() As String, nf As String)
Dim fila As Integer
For fila = 0 To nf + 1
Console.WriteLine("{0} {1} ", fila, cadena(fila))
Next
End Sub
Sub dividir(adn As String, ByRef adn1 As String, ByRef adn2 As String)
Dim col As Integer
adn1 = "" : adn2 = ""
For col = 0 To Len(adn) - 1
If (col Mod 2 = 0) Then
Else
End If
Next
End Sub
Sub IniciarMatriz(A(,) As String, nf As Integer, nc As Integer)
' A(fila, col) = Str(fila) + ":" + Str(col)
A(fila, col) = ""
Next
Next
End Sub
Sub ImprimirMatriz(A(,) As String, nf As Integer, nc As Integer)
Console.Write(" {0} {1} ", A(fila, col), vbTab)
Next
Console.WriteLine()
Next
End Sub
Function EvaluarCadena(ByVal adn As String) As Boolean

Dim largo As Integer, col As Integer
Dim letra As Char, letra1 As Char
largo = Len(adn)
If largo Mod 2 <> 0 Then
valor = False
Else
For col = 0 To largo - 2 Step 2
letra = adn(col)
letra1 = adn(col + 1)
Select Case letra
Case "A" : If letra1 <> "T" Then
valor = False
Exit For
End If
Case "T" : If letra1 <> "A" Then
valor = False
Exit For
End If
Case "C" : If letra1 <> "G" Then
valor = False
Exit For
End If
Case "G" : If letra1 <> "C" Then
valor = False
Exit For
End If
Case Else
valor = False
Exit For
End Select
Next
End If
EvaluarCadena = valor
End Function
End Module
CODIGO DEL MODULO 1

Module Module1
Sub Main()
Dim Vanterior As Integer
Dim fila As Integer
ADN = "ATCG"
Dim resultado As Boolean
resultado = EvaluarCadena(ADN)
Console.WriteLine("cadena original {0}", ADN)
Cadena = ADN
IniciarMatriz(A, maxfilas, maxcol)
Vanterior = 1
A(0, 0) = Cadena
fila = 0
For fila = 0 To Nrepli - 1
Console.WriteLine("*********repli {0} ", fila)
k=0
CadR(0) = Cadena
ReplicarADN(Cadena, 0, fila)
ImprimirCadenas(CadR, k)
CadenasMatriz(CadR, Vanterior, k + 1, fila + 1)
Vanterior = k + 1
Next
nc = Nrepli + 1
nf = k + 1
Console.WriteLine("la Matriz generada es ")
ImprimirMatriz(A, nf, nc)
Console.ReadLine()
End Sub
End Module
Secuencia ADN
Realizar la siguiente secuencia
Secuencia Origen Produce
1 A H
2 B M
secuencia AB aleatoria de acuerdo a
3 HM una tas
Secuencia AB aletoria a la mitad de
4 MH la tasa
5 H X
6 M Y
7 X Muere
8 Y Muere
Module Module1
Dim ng As Integer = 20
Dim nletras As Integer = 8
Dim tnat As Integer = 10
Sub Main()
Randomize()
Dim fila As Integer
cadena = "ABBA"
cadena = generar(nletras)
cadena = cadena + " "
Console.WriteLine("Cadena Original es {0} ", cadena)
For fila = 1 To ng
cadena = reemplazar(cadena) + " "
Console.WriteLine(" fila {0,2} cadena es {1} ", fila, cadena)
Next
Console.ReadLine()
End Sub
Function reemplazar(cadena As String) As String
Dim pos As Integer
Dim r As Integer
Dim Cadtemporal As String = ""
pos = 0
Do While (pos < Len(cadena) - 1)
If cadena(pos) = "H" And cadena(pos + 1) = "M" Then
r = Int(Rnd() * tnat)
Cadtemporal = Cadtemporal + generarAB(r)
pos = pos + 2
Else
If cadena(pos) = "M" And cadena(pos + 1) = "H" Then
r = Int(Rnd() * tnat / 2)
Cadtemporal = Cadtemporal + generarAB(r)
pos = pos + 2
Else
If cadena(pos) = "A" Then
Cadtemporal = Cadtemporal + "H"
pos = pos + 1
Else
If cadena(pos) = "B" Then
Cadtemporal = Cadtemporal + "M"
pos = pos + 1
Else
If cadena(pos) = "H" Then
Cadtemporal = Cadtemporal + "X"
pos = pos + 1
Else
If cadena(pos) = "M" Then
Cadtemporal = Cadtemporal + "Y"
pos = pos + 1
Else
If cadena(pos) = "X" Then
Cadtemporal = Cadtemporal + ""
pos = pos + 1
Else
If cadena(pos) = "Y" Then
pos = pos + 1
Else
Cadtemporal = Cadtemporal + cadena(pos)
pos = pos + 1
End If
End If
End If
End If
End If
End If
End If
End If
Loop
Return Cadtemporal
End Function
Function generar(ne As Integer) As String
Dim fila As Integer
Dim r As Integer
For fila = 0 To ne
r = 1 + Int(Rnd() * 6)
Select Case r
Case 1 : cadena = cadena + "A"
Case 2 : cadena = cadena + "B"
Case 3 : cadena = cadena + "H"
Case 4 : cadena = cadena + "M"
Case 5 : cadena = cadena + "X"
Case 6 : cadena = cadena + "Y"
End Select
Next
Return cadena
End Function
Function generarAB(ne As Integer) As String
Dim fila As Integer
Dim r As Integer
r = 1 + Int(Rnd() * 100)
If r < 50 Then
cadena = cadena + "A"
Else
cadena = cadena + "B"
End If
Next
Return cadena
End Function
End Module
El mismo problema en modo formulario

Module Module1
Public cadenas(maxfilas) As String
Public grafico As Graphics
Public nletras As Integer = 20
Public tnat As Integer = 10
Public ngen As Integer = 50
Function reemplazar(cadena As String) As String
Dim pos As Integer
Dim r As Integer
Dim Cadtemporal As String = ""
pos = 0
Do While (pos < Len(cadena) - 1)
If cadena(pos) = "H" And cadena(pos + 1) = "M" Then
r = Int(Rnd() * tnat)
Cadtemporal = Cadtemporal + "X" + generarAB(r) + "Y"
pos = pos + 2
Else
If cadena(pos) = "M" And cadena(pos + 1) = "H" Then
r = Int(Rnd() * tnat * 0.5)
Cadtemporal = Cadtemporal + "Y" + generarAB(r) + "X"
pos = pos + 2
Else
If cadena(pos) = "A" Then
Cadtemporal = Cadtemporal + "H"
pos = pos + 1
Else
If cadena(pos) = "B" Then
Cadtemporal = Cadtemporal + "M"
pos = pos + 1
Else
If cadena(pos) = "H" Then
Cadtemporal = Cadtemporal + "X"
pos = pos + 1
Else
If cadena(pos) = "M" Then
Cadtemporal = Cadtemporal + "Y"
pos = pos + 1
Else
If cadena(pos) = "X" Then
pos = pos + 1
Else
If cadena(pos) = "Y" Then
pos = pos + 1
Else
Cadtemporal = Cadtemporal + cadena(pos)
pos = pos + 1
End If
End If
End If
End If
End If
End If
End If
End If
Loop
Return Cadtemporal
End Function
Function generar(ne As Integer) As String
Dim fila As Integer
Dim r As Integer
For fila = 0 To ne
r = 1 + Int(Rnd() * 6)
Select Case r
Case 1 : cadena = cadena + "A"
Case 2 : cadena = cadena + "B"
Case 3 : cadena = cadena + "H"
Case 4 : cadena = cadena + "M"
Case 5 : cadena = cadena + "X"
Case 6 : cadena = cadena + "Y"
End Select
Next
Return cadena
End Function
Function generarAB(ne As Integer) As String
Dim fila As Integer
Dim r As Integer
r = 1 + Int(Rnd() * 100)
If r < 50 Then
cadena = cadena + "A"
Else
cadena = cadena + "B"
End If
Next
Return cadena
End Function
End Module
Public Class Form1

Dim ey As Integer = 10
Dim cx As Integer = 5
Dim cy As Integer = 5
Private Sub ProcesarCadena(sender As Object, e As EventArgs) Handles

BtnProcesar.Click
grafico.Clear(Color.Black)
Randomize()
Dim fila As Integer
cadena = "ABBA"
' cadena = generar(nletras)
cadena = TextBox1.Text
' TextBox1.Text = cadena
cadena = cadena + " "
ListBox1.Items.Add("Cadena Original es " & cadena)
cadenas(0) = cadena
For fila = 1 To ngen
cadena = reemplazar(cadena) + " "
ListBox1.Items.Add(fila & "Cadena " & cadena)
cadenas(fila) = cadena
Next
BtnDibujar_Click(sender, e)
End Sub
Sub ImprimirCadenas(cadena() As String, nf As String)

Dim fila As Integer
For fila = 0 To nf
ListBox1.Items.Add(cadena(fila))
Next
End Sub
End Sub
Sub ImprimirCadenaGrafico(cadena As String, nrofila As Integer)
Dim col As Integer
Dim letra As String
For col = 0 To Len(cadena) - 1
letra = cadena(col)
Select Case letra
Case "A"
grafico.FillRectangle(Brushes.Green, cx + ex * col, cy + ey * nrofila, ex, ey)
Case "B"
grafico.FillRectangle(Brushes.Yellow, cx + ex * col, cy + ey * nrofila, ex, ey)
Case "H"
grafico.FillRectangle(Brushes.Blue, cx + ex * col, cy + ey * nrofila, ex, ey)
Case "M"
grafico.FillRectangle(Brushes.Red, cx + ex * col, cy + ey * nrofila, ex, ey)
Case "X"
grafico.FillRectangle(Brushes.Gray, cx + ex * col, cy + ey * nrofila, ex, ey)
Case "Y"
grafico.FillRectangle(Brushes.Violet, cx + ex * col, cy + ey * nrofila, ex, ey)
End Select
Next
End Sub
Private Sub BtnDibujar_Click(sender As Object, e As EventArgs) Handles

BtnDibujar.Click
Dim fila As Integer
fila = 1
For fila = 0 To ngen
ImprimirCadenaGrafico(cadenas(fila), fila)
Next
End Sub
Private Sub BtnBorrar_Click(sender As Object, e As EventArgs) Handles
BtnBorrar.Click
' ListBox1.Items.Clear()
End Sub
End Class
La secuencia AB genera AAB o ABB la secuencia BA genera AB o BA , AAA genera

AA BBB genera BB
La secuencia AB genera AAB o ABB la secuencia BA genera lA o B
Pruebe otras secuencias

11.19 SECUENCIAS CON CADENAS M un sistema de produccion tiene 3 etapas se
ingresan los tiempos deprocesamiento para cada etapa ( que puede ser tambien con
media y desviacion) el porgrma simular la secuencia de produccion en las estacion
incluyendo almacenamiento temporal
Module Module2
Public filacadena As Integer = 0
Public filagrafico As Integer = 0
Public total As Integer = te1 + te2 + te3
Public AnchoGrafico As Integer = 600
Public Altografico As Integer = 400
Public sepax As Integer = 80
Public sepay As Integer = 16
Public pen As Pen
Public te1 As Integer = 2 '(1, 2)
Public te2 As Integer = 4 '(2, 3, 4)
Public te3 As Integer = 3 '(2, 3)
Public NroProductos As Integer = 2
Public cadenas(50) As String
Public ex As Integer = 1
Public ey As Integer = 1
Function CadenaProducto(NroProductos As Integer, te1 As Integer, te2 As Integer,
te3 As Integer, ByRef nf As Integer) As String()
Randomize()
Dim rte1, rte2, rte3 As Integer
Dim fila, k As Integer
Dim faltante As Integer
Dim cadtotal As String = ""
Dim letra As String
Dim largo1, largo2, largo3 As Integer
For k = 0 To NroProductos - 1
'rte1 = 1 + Int(Rnd() * te1)
rte1 = te1
For fila = 0 To rte1 - 1
If fila < 10 Then
letra = Chr(65 + k) & "0" + Str(fila) & "1"
Else
letra = Chr(65 + k) + Str(fila) & "1"
End If
cadena1 = cadena1 + letra
Next
cadena1 = QuitarEspacios(cadena1)
largo1 = largoCadena(cadena1)
faltante = largo1 - largo2
If faltante > 0 Then
' completa la cadena 2 al mismo largo que la cadena 1
For fila = 0 To faltante - 1
letra = "F000"
Next
End If
' aumenta a la cadena 2
'rte2 = 2 + Int(Rnd() * te2)
rte2 = te2
If fila < 10 Then
letra = Chr(65 + k) & "0" + Str(fila + rte1) & "2"
Else
End If
Next
' compara la cadena 2 con la cadena 3
letra = "F000"
Next
End If
' aumenta a la cadena 3
'rte3 = 2 + Int(Rnd() * te3)
rte3 = te3
If fila < 10 Then
letra = Chr(65 + k) & "0" + Str(fila + rte1 + te2) & "3"
Else
End If
Next
Next
' igualar los largos
letra = "F000"
Next
End If
letra = "F000"
Next
End If
cadtotal = cadenafinal(cadena1, cadena2, cadena3, largo3)
' obtener un vector de cadenas or fila
For fila = 0 To largo3 - 1
cadenas(fila) = Extrae(cadtotal, fila * 12, fila * 12 + 11)
Next
nf = largo3
Return cadenas
End Function
Function QuitarEspacios(ByRef cadena As String) As String
Dim col As Integer
Dim cad As String = ""
For col = 0 To Len(cadena) - 1
If cadena(col) <> " " Then cad = cad + cadena(col)
Next
Return cad
End Function
Function largoCadena(cadena As String) As Integer
Return Len(cadena) / 4
End Function
Sub Imprimircadena(cadena As String, nf As Integer)
Dim fila As Integer
Dim Cadena1 As String
Cadena1 = Extrae(cadena, fila * 4, fila * 4 + 3)
Console.WriteLine("{0}", Cadena1)
Next
End Sub
Function Extrae(cadena As String, pos1 As Integer, pos2 As Integer) As String
Dim subcadena As String = ""
Dim fila As Integer
For fila = pos1 To pos2
subcadena = subcadena + cadena(fila)
Next
Return subcadena
End Function
Function cadenafinal(cadena1 As String, cadena2 As String, cadena3 As String,

nfilas As Integer) As String
Dim fila As Integer
Dim cadfinal As String = ""
Dim c1, c2, c3 As String
c1 = Extrae(cadena1, fila * 4, fila * 4 + 3)
cadfinal = cadfinal + c1 + c2 + c3
Next
Return cadfinal
End Function
End Module
Imports System.IO
Public Class Form1
Sub imprimirVcadenas(cadenas() As String, nfilas As Integer)
Dim fila As Integer
ListBox1.Items.Add(fila & " " & cadenas(fila))
Next
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles
btnProcesar.Click
Dim fila As Integer
cadena1 = cadenas(fila)
DataGridView1.Rows(fila).Cells(0).Value = fila
DataGridView1.Rows(fila).Cells(1).Value = Extrae(cadena1, 0, 3)
Next
End Sub

Dim fila As Integer
DataGridView1.Columns(1).HeaderText = "E1"
For fila = 0 To 3
Next
' *****************
DataGridView2.Columns(0).HeaderText = "te1"
DataGridView2.Rows(0).HeaderCell.Value = "tiempo"
DataGridView2.Rows(1).HeaderCell.Value = "Np/Ficad/fgra"
DataGridView2.Rows(2).HeaderCell.Value = "Interval"
DataGridView2.Rows(0).Cells(0).Value = 2
End Sub
Private Sub btnListar_Click(sender As Object, e As EventArgs) Handles

btnListar.Click
total = te1 + te2 + te3
te1 = DataGridView2.Rows(0).Cells(0).Value
NroProductos = DataGridView2.Rows(1).Cells(0).Value
cadenas = CadenaProducto(NroProductos, te1, te2, te2, nf)
imprimirVcadenas(cadenas, nf)
End Sub

btnBorrar.Click
End Sub
Sub Graficar(cadena As String, fila As Integer)
Dim Color As Color
Dim producto As String = cadena(0)
Dim Nroproducto As String = Extrae(cadena, 1, 2)
Dim maquina As Integer = Extrae(cadena, 3, 3)
Dim porcentaje As Single
Select Case producto
Case "A" : Color = Color.FromArgb(0, 255, 0)
Case "B" : Color = Color.FromArgb(0, 0, 255)
Case "C" : Color = Color.FromArgb(255, 0, 0)
Case "D" : Color = Color.FromArgb(255, 255, 0)
Case "E" : Color = Color.FromArgb(255, 0, 255)
Case "F" : Color = Color.FromArgb(0, 255, 0)
Case "G" : Color = Color.FromArgb(255, 100, 0)
Case "H" : Color = Color.FromArgb(125, 125, 125)
Case "I" : Color = Color.FromArgb(255, 255, 255)
Case "J" : Color = Color.FromArgb(50, 255, 0)
End Select
brocha.Color = Color
pen.Color = Color
If maquina > 0 Then
porcentaje = Nroproducto / total
grafico.FillRectangle(brocha, cx + maquina * sepax * 2 * ex, cy + fila * sepay,
porcentaje * sepax * ex, sepay * ey)
grafico.DrawRectangle(pen, cx + maquina * sepax * 2 * ex, cy + fila * sepay,
sepax * ex, sepay * ey)
End If
End Sub
Private Sub btnGraficar_Click(sender As Object, e As EventArgs) Handles

btnGraficar.Click
Dim fila As Integer
grafico.DrawLine(pen, 0, cy, AnchoGrafico, cy)
grafico.DrawLine(pen, cx, 0, cx, Altografico)
graficarFila(fila, fila)
' ListBox1.Items.Add(cadena1)
Next
End Sub
Sub graficarFila(filaDatos As Integer, filagrafico As Integer)
cadena1 = DataGridView1.Rows(filaDatos).Cells(1).Value
Graficar(cadena1, filagrafico)
End Sub
Private Sub btnMover_Click(sender As Object, e As EventArgs) Handles
btnVerFila.Click
filacadena = DataGridView2.Rows(1).Cells(1).Value
filagrafico = DataGridView2.Rows(1).Cells(2).Value
graficarFila(filacadena, filagrafico)
End Sub
Private Sub btnMover_Click_1(sender As Object, e As EventArgs) Handles

btnMover.Click
cont = 0
Dim intervalo As Integer = DataGridView2.Rows(2).Cells(0).Value
Timer1.Interval = intervalo
Timer1.Interval = 50
Timer1.Enabled = True
End Sub
Private Sub btnManual_Click(sender As Object, e As EventArgs) Handles

btnManual.Click
If cont < nf Then
filacadena = cont
filagrafico = 1
cont = cont + 1
Else
cont = 0
End If
End Sub
If cont < nf Then
filacadena = cont
filagrafico = 1
' System.Threading.Thread.Sleep(vel) ' 1 segundo
' Application.DoEvents()
cont = cont + 1
Else
Timer1.Enabled = False
End If
End Sub
Private Sub btnDetener_Click(sender As Object, e As EventArgs) Handles

btnDetener.Click
End Sub
End Class
11.15 PROBLEMA DE CONDUCCION DE VEHICULOS
CODIGO DEL MODULO
Imports System.IO
Module Module2
Public velocidad As Integer = 100
Public dir As Integer = 1
Public valor As Integer = 0
Public x1 As Integer = 0
Public y1 As Integer = 0
Public pmx, pmy As Integer
Public ancho1 As Integer = 20 '90
Public alto1 As Integer = 10 '90
Public AnchoTotal = 40
Public AltoTotal = 20
Public ex1 As Single = 32, ey1 As Single = 32
Public ex2 As Single = 4, ey2 As Single = 4
Public Posx As Integer = 11 ' col de partida
Public Posy As Integer = 13 ' fila de partida
' ***************************
Public Const maxfilas As Integer = 42, maxcol As Integer = 42 '700 ' 590
Public A(maxfilas, maxcol) As Integer
Public B(maxfilas, maxcol) As Integer
Sub CopiarMatrices(A(,) As Integer, ByRef B(,) As Integer, Cx As Integer, Cy As

Integer, Ancho As Integer, alto As Integer)
For fila = 0 To alto - 1
For col = 0 To Ancho - 1
B(fila, col) = A(Cy + fila, Cx + col)
Next
Next
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByRef A(,) As Integer, ByRef
nc As Integer, ByVal nf As Integer)
inicio = 1
A(fila, col) = subcadena
inicio = pos + 1
Next
fila = fila + 1
Loop
nf = fila
srLector.Close()
End Sub
End Module
Option Explicit On
Imports System.IO
Public Class Form1
Dim Pen1 As Pen
Dim Grafico1 As Graphics
Dim Pen2 As Pen
PictureBox1.Left = 0
PictureBox1.Top = 0
PictureBox1.Width = 800
PictureBox1.Height = 350
Grafico1 = PictureBox1.CreateGraphics
Pen1 = New Pen(Color.Red, 2)
brocha1 = New SolidBrush(Color.FromArgb(255, 255, 0))
Pen2 = New Pen(Color.Red, 1)
brocha2 = New SolidBrush(Color.FromArgb(255, 255, 0))
txtPx.Text = Posx
txtPy.Text = Posy
valor = A(Posy, Posx)
txtValor.Text = valor
txtVel.Text = velocidad
End Sub
Sub MostrarMatriz1(A(,) As Integer, Cx As Integer, Cy As Integer, nc As Integer,

ByVal nf As Integer)
If A(fila, col) = 1 Then
brocha1.Color = Color.Black
Else
brocha1.Color = Color.Green
End If
Grafico1.FillRectangle(brocha1, Cx + col * ex1, Cy + fila * ey1, ex1, ey1)
Grafico1.DrawRectangle(Pen1, Cx + col * ex1, Cy + fila * ey1, ex1, ey1)
Next
Next
End Sub
Sub MostrarMatriz2(A(,) As Integer, Cx As Integer, Cy As Integer, nc As Integer,
brocha2.Color = Color.Black
Else
brocha2.Color = Color.Green
End If
Grafico2.FillRectangle(brocha2, Cx + col * ex2, Cy + fila * ey2, ex2, ey2)
Next
Next
End Sub

BtnBorrar.Click
Grafico1.Clear(Color.Black)
End Sub
Private Sub BtnIniciar_Click(sender As Object, e As EventArgs) Handles
BtnIniciar.Click
Dim NombreArchivo As String = "E:\datos1\circuito40x20.txt"
RecuperarMatriz(NombreArchivo, A, AnchoTotal, AltoTotal)
CopiarMatrices(A, B, 0, 0, ancho1, alto1)
x1 = 0
y1 = 0
pmx = ancho1 / 2.0
pmy = alto1 / 2.0
txtPx.Text = Posx
txtPy.Text = Posy
dir = 1
BtnPosicionar_Click(sender, e)
End Sub
Private Sub Manual_Click(sender As Object, e As EventArgs) Handles

BtnManual.Click
Select Case dir
Case 1 ' a la derecha
If A(Posy, Posx + 1) = camino Then
Posx = Posx + 1
dir = 1
Else
If A(Posy - 1, Posx) = camino Then
Posy = Posy - 1
dir = 2
Else
If A(Posy + 1, Posx) = camino Then
Posy = Posy + 1
dir = 4
Else
If A(Posy, Posx - 1) = camino Then
Posx = Posx - 1
dir = 3
End If
End If
End If
End If
Case 2
Posy = Posy - 1
dir = 2
Else
Posx = Posx + 1
dir = 1
Else
Posx = Posx - 1
dir = 3
Else
Posy = Posx + 1
dir = 4
End If
End If
End If
End If
Case 3
Posx = Posx - 1
dir = 3
Else
Posy = Posy - 1
dir = 1
ElseIf A(Posy + 1, Posx) = camino Then
Posy = Posy + 1
dir = 4
Else
Posy = Posx + 1
dir = 1
End If
End If
End If
Case 4
If A(Posy + 1, Posx) = camino Then
Posy = Posy + 1
dir = 4
Else
Posx = Posx + 1
dir = 1
ElseIf A(Posy, Posx - 1) = camino Then
Posx = Posx - 1
dir = 3
Else
Posy = Posx - 1
dir = 2
End If
End If
End If
End Select
txtPx.Text = Posx
txtPy.Text = Posy
' 'System.Threading.Thread.Sleep(20) ' 1 milisegundo
End Sub
btnMover.Click
vel = txtVel.Text
End Sub
Private Sub btnParar_Click(sender As Object, e As EventArgs) Handles
btnParar.Click
End Sub

Manual_Click(sender, e)
End Sub
Private Sub txtXY_KeyDown(sender As Object, e As KeyEventArgs) Handles
txtXY.KeyDown
BtnBorrar_Click(sender, e)
Case 65 ' A
If Posx > pmx Then
Posx = Posx - 1
End If
Case 66 ' B
If Posy > pmy Then
Posy = Posy - 1
End If
Case 88 ' trslacion eeje x
If Posx <= AnchoTotal - pmx Then
Posx = Posx + 1
End If
If Posy < AltoTotal - pmy Then
Posy = Posy + 1
End If
End Select
txtPx.Text = Posx
txtPy.Text = Posy
txtXY.Text = ""
End Sub
Private Sub Borrar2_Click(sender As Object, e As EventArgs) Handles

BtnBorrar2.Click
End Sub
Private Sub BtnPosicionar_Click(sender As Object, e As EventArgs) Handles

BtnPosicionar.Click
Posx = txtPx.Text
Posy = txtPy.Text
valor = A(Posy, Posx)
If Posx - pmx >= 0 And Posx + pmx <= AnchoTotal And Posy - pmy >= 0 And Posy
+ pmy <= AltoTotal Then
x1 = Posx - ancho1 / 2
y1 = Posy - alto1 / 2
Else
MsgBox("valores erroneos")
Exit Sub
End If
CopiarMatrices(A, B, x1, y1, ancho1, alto1)
MostrarMatriz1(B, x1, y1, ancho1, alto1)
MostrarMatriz2(A, 0, 0, AnchoTotal, AltoTotal)
Grafico2.FillRectangle(Brushes.Yellow, Posx * ex2, Posy * ey2, ex2 * 2, ey2 * 2)
Grafico1.FillRectangle(Brushes.Yellow, x1 + pmx * ex1, y1 + pmy * ey1, ex1, ey1)
Grafico2.DrawRectangle(Pen2, x1 * ex2, y1 * ey2, ancho1 * ex2, alto1 * ey2)
If (valor <> 0) Then MsgBox("erroneo maneje bien")
End Sub
End Class
11.16 PROBLEMA DE CONDUCCION DE VEHICULOS USADO BITMAPS
CODIGO DEL MODULO
Module Module1
Public nultimos As Integer = 0
Public ultimos As Integer = 100
Public paso As Integer = 20
Public menor As Integer
Public Const largo As Integer = 4000
Public li As Integer = 0
Public alcance As Integer = 10
Public Cont As Integer = 0
Public contMalos As Integer = 0
Public Nvecinos As Integer = 0
Public Ndir(4) As Integer ' vector de direcciones
Public RutaX(largo) As Integer ' vector de direcciones
Public RutaY(largo) As Integer ' vector de direcciones
Public RutaXMala(largo) As Integer ' vector de direcciones
Public RutaYMala(largo) As Integer ' vector de direcciones
Public Dirfac(4) As Integer ' 0 no ses factible
Public Sdir(4) As Integer ' vector de suma de direccionesA
Public limiteColor As Integer = 50
Public PosXAuto As Integer
Public PosYAuto As Integer
Public Ex1 As Integer = 1
Public Ey1 As Integer = 1
Public Ex As Integer = 10
Public Ey As Integer = 10
Public AutoX(1) As Integer
Public AutoY(1) As Integer
Public AnchoImagen As Integer
Public AltoImagen As Integer
Public BrochaSólida As SolidBrush
Public Color1 As Color
Public dir As Integer = 1
Public Grafico1 As Graphics
Public imagen As Bitmap
Public fuente1 As RectangleF
Public destino1 As RectangleF
Public rojo, verde, azul As Integer
Sub IniciarVectores()
Dim col As Integer
For col = 0 To 3
Ndir(col) = col + 1
Sdir(col) = 0
Next
For col = 0 To largo
RutaX(0) = 0
RutaY(0) = 0
Next
End Sub
Function buscar(ByVal Cx As Integer, ByVal cy As Integer, ByVal li As Integer, ByVal
ls As Integer) As Boolean
Dim fila As Integer
Dim encontrado As Boolean = False
For fila = li To ls
If Cx = RutaX(fila) And cy = RutaY(fila) Then
encontrado = True
Exit For
End If
Next
Return encontrado
End Function
Function Contavecinos(ByVal Cx As Integer, ByVal cy As Integer, ByVal li As Integer,
ByVal ls As Integer)
Dim fila, col As Integer, nvecinos = 0
For fila = cy - paso To cy + paso
For col = Cx - paso To Cx + paso
If buscar(col, fila, li, ls) = True Then nvecinos = nvecinos + 1
Next
Next
Return nvecinos
End Function
End Module
Public Class Form1
Function ProbarRuta(ByVal Cx As Integer, ByVal Cy As Integer, ByVal AutoX() As
Integer, ByVal Autoy() As Integer) As Boolean
Dim f1 As Boolean = True
'' probar si esta en la colas
If (Cx = AutoX(1) And Cy = Autoy(1)) Then f1 = False
' probar si estan en los ultimos
For fila = li To Cont + 1
If (Cx = RutaX(fila) And Cy = RutaY(fila)) Then
f2 = False
Exit For
End If
Next
Color1 = imagen.GetPixel(Cx, Cy)
azul = Color1.B
If (azul >= limiteColor) Then f3 = False 'tiene que se todos los poner colores con
rojo
' probar si la ruta ha sido y habia retrocidido
For fila = 0 To contMalos
If (Cx = RutaXMala(fila) And Cy = RutaYMala(fila)) Then
f4 = False
Exit For
End If
Next
If f1 = True And f2 = True And f3 = True And f4 = True Then
Return True
Else
Return False
End If
End Function
Function ProbarRutaAlterna(ByVal Cx As Integer, ByVal Cy As Integer, ByVal

AutoX() As Integer, ByVal Autoy() As Integer) As Boolean
Dim f6 As Boolean = True ' s i los 10 no deben estar mas de 5
'Dim nvecinos As Integer = 0
If (Cx = AutoX(1) And Cy = Autoy(1)) Then f4 = False
' probar si esta en la colas
If Cont - ultimos > 0 Then
li = Cont - ultimos
Else
li = 0
End If
For fila = li To Cont
If (Cx = RutaX(fila) And Cy = RutaY(fila)) Then
f1 = False
Exit For
End If
Next
'probar si no es camino
Color1 = imagen.GetPixel(Cx, Cy)
azul = Color1.B
If (azul >= limiteColor) Then f2 = False 'tiene que se todos los colores poner
colores con rojo
' probar si al menos tiene un vecino
Nvecinos = 0
' saber nro de vecinos
For fila = Cy - 1 To Cy + 1
For col = Cx - 1 To Cx + 1
If fila = col Then Continue For
Color1 = imagen.GetPixel(col, fila)
If (Color1.B > limiteColor) Then Nvecinos = Nvecinos + 1
Next
Next
If (Nvecinos <= 0) Then f3 = False
For fila = 0 To contMalos
If (Cx = RutaXMala(fila) And Cy = RutaYMala(fila)) Then
f5 = False
Exit For
End If
Next
nultimos = 0
If Cont > ultimos Then
For fila = Cont - ultimos To Cont
If (Cx = RutaX(fila) And Cy = RutaY(fila)) Then nultimos = nultimos + 1
Next
If nultimos > ultimos / 2 Then f6 = False
End If
If f1 = True And f2 = True And f3 = True And f4 = True And f5 = True And f6 = True
Then
Return True
Else
Return False
End If
End Function
Sub traslados()
Dim valor1 As Integer = tam / 2
' se traslada el auto
grafico2.DrawRectangle(Pens.Yellow, AutoX(0), AutoY(0), tam, tam)
' gragficara todo el rastro
txtPosX.Text = AutoX(0)
TxtPosy.Text = AutoY(0)
fuente3.Width = tam * 2
fuente3.Height = tam * 2
fuente3.X = AutoX(0) - tam
fuente3.Y = AutoY(0) - tam
destino3.Width = tam * 2 * Ex
destino3.Height = tam * 2 * Ey
destino3.X = 0
destino3.Y = 0
Grafico3.DrawImage(imagen, destino3, fuente3, GraphicsUnit.Pixel)
Grafico1.DrawRectangle(Pens.Blue, AutoX(0) - tam, AutoY(0) - tam, tam * 2, tam * 2)
Grafico1.DrawRectangle(Pens.Blue, AutoX(0) - 1, AutoY(0) - 1, 2, 2)
grafico2.DrawRectangle(Pens.Blue, AutoX(0) - tam, AutoY(0) - tam, tam * 2, tam * 2)
valor1 = Ex / 2
Grafico3.FillRectangle(Brushes.Yellow, tam * Ex - valor1, tam * Ey - valor1, Ex, Ey)
End Sub
Private Sub BtnBorrar_Click(ByVal sender As Object, ByVal e As EventArgs)

Handles BtnBorrar.Click
Grafico1.Clear(Color.White)
grafico2.Clear(Color.Black)
End Sub
Private Sub btnMaps_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnMaps.Click
fuente1.Width = AnchoImagen
fuente1.Height = AltoImagen
fuente1.X = 0
fuente1.Y = 0
destino1.Width = AnchoImagen
destino1.Height = AltoImagen
destino1.X = 0
destino1.Y = 0
fuente2.Width = AnchoImagen
fuente2.Height = AltoImagen
fuente2.X = 0
fuente2.Y = 0
destino2.Width = AnchoImagen
destino2.Height = AltoImagen
destino2.X = 0
destino2.Y = 0
Grafico1.DrawImage(imagen, destino1, fuente1, GraphicsUnit.Pixel)
grafico2.DrawImage(imagen, destino2, fuente2, GraphicsUnit.Pixel)
End Sub

Dim fila As Integer
IniciarVectores()
Cont = ultimos
li = 0
PosXAuto = 41
PosYAuto = 210
AutoX(0) = PosXAuto
AutoY(0) = PosYAuto
AutoX(1) = PosXAuto
AutoY(1) = PosYAuto + 1
' inciciar lo vectores de recorrido con los primeros 20
For fila = li To Cont - 1
RutaX(fila) = AutoX(0)
RutaY(fila) = AutoY(0) + Cont - fila - 1
Next
BtnObtColor_Click(sender, e)
traslados()
End Sub
Private Sub BtnObtColor_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles BtnObtColor.Click
' obtener color
Color1 = imagen.GetPixel(PosXAuto, PosYAuto)
rojo = Color1.R
verde = Color1.G
azul = Color1.B
ListBox1.Items.Add(" rojo " & rojo)
ListBox1.Items.Add(" verde " & verde)
ListBox1.Items.Add(" azul " & azul)
End Sub

Grafico1 = PicFuente.CreateGraphics
grafico2 = PicDestino.CreateGraphics
Grafico3 = PicZoom.CreateGraphics
imagen = New Bitmap("E:\datos1\F1HUNGRIA320X310.BMP")
AnchoImagen = imagen.Width
AltoImagen = imagen.Height
End Sub
Private Sub PicFuente_MouseMove(ByVal sender As System.Object, ByVal e As

System.Windows.Forms.MouseEventArgs) Handles PicFuente.MouseMove
Me.Text = " X= " & e.X & " Y =" & e.Y
End Sub
Private Sub PicFuente_MouseDown(ByVal sender As System.Object, ByVal e As
System.Windows.Forms.MouseEventArgs) Handles PicFuente.MouseDown
AutoX(0) = e.X
AutoY(0) = e.Y
AutoX(1) = e.X
AutoY(1) = e.Y + 1
RutaX(0) = AutoX(1)
RutaX(0) = AutoX(1)
PosXAuto = AutoX(0)
PosYAuto = AutoY(0)
traslados()
End Sub
Private Sub txtMover_KeyDown(ByVal sender As Object, ByVal e As
System.Windows.Forms.KeyEventArgs) Handles txtMover.KeyDown
Case 65 ' inversa X
If PosXAuto > 0 Then
PosXAuto = PosXAuto - 1
End If
Case 66 ' Inversa Y
If PosYAuto > 0 Then
PosYAuto = PosYAuto - 1
End If
If PosXAuto < AnchoImagen Then
PosXAuto = PosXAuto + 1
End If
Case 89 '
If PosYAuto < AltoImagen Then
PosYAuto = PosYAuto + 1
End If
End Select
AutoX(1) = AutoX(0)
AutoY(1) = AutoY(0)
AutoX(0) = PosXAuto
AutoY(0) = PosYAuto
btnMaps_Click(sender, e)
traslados()
txtMover.Text = ""
End Sub
Private Sub btnRuta_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnRuta.Click
For fila = 0 To 4
Dirfac(fila) = 0
Next
Dim posX, posY As Integer
Dim resultado As Boolean = True
posX = AutoX(0)
posY = AutoY(0)
If (ProbarRuta(posX + 1, posY, AutoX, AutoY) = True) Then Dirfac(0) = 1
valor = ProbarRuta(posX, posY - 1, AutoX, AutoY)
If (ProbarRuta(posX, posY - 1, AutoX, AutoY) = True) Then Dirfac(1) = 1
If (ProbarRuta(posX - 1, posY, AutoX, AutoY) = True) Then Dirfac(2) = 1
If (ProbarRuta(posX, posY + 1, AutoX, AutoY) = True) Then Dirfac(3) = 1
' encontrar el menor de los factibles que tiene menos vecinos

Sdir(0) = Contavecinos(posX + 1, posY, li, Cont)
Sdir(1) = Contavecinos(posX, posY - 1, li, Cont)
Sdir(2) = Contavecinos(posX - 1, posY, li, Cont)
Sdir(3) = Contavecinos(posX, posY + 1, li, Cont)
ListBox1.Items.Add("sDIR 0 " & Sdir(0))
menor = 100
dir = -1
If Sdir(0) < menor And Dirfac(0) = 1 Then
menor = Sdir(0)
dir = 1
End If
menor = Sdir(1)
dir = 2
End If
menor = Sdir(2)
dir = 3
End If
menor = Sdir(3)
dir = 4
End If
If dir <= 0 Then
RutaXMala(contMalos) = posX
RutaYMala(contMalos) = posY
contMalos = contMalos + 1
Cont = Cont - 1 ' ver si hay menos 1
li = li - 1
AutoX(0) = RutaX(Cont)
AutoY(0) = RutaY(Cont)
AutoX(1) = RutaX(Cont - 1)
AutoY(1) = RutaY(Cont - 1)
Else
Select Case dir
Case 1 : posX = posX + 1
Case 2 : posY = posY - 1
Case 3 : posX = posX - 1
Case 4 : posY = posY + 1
Case Else
'finalizado = True
End Select
AutoX(1) = AutoX(0)
AutoY(1) = AutoY(0)
AutoX(0) = posX
AutoY(0) = posY

PosXAuto = AutoX(0)
PosYAuto = AutoY(0)
btnMaps_Click(sender, e)
traslados()
RutaX(Cont) = posX
RutaY(Cont) = posY
Cont = Cont + 1
li = li + 1
End If
ListBox1.Items.Add("CONT " & Cont)

ListBox1.Items.Add("li " & li)
ListBox1.Items.Add("CONT MALOS " & contMalos)
ListBox1.Items.Add("DIR " & dir)
ListBox1.Items.Add("CABERZA " & AutoX(0) & "Y " & AutoY(0))
ListBox1.Items.Add("COLA " & AutoX(1) & "Y " & AutoY(1))
ListBox1.Items.Add(" imprimiendo la cola")
For col = li To Cont - 1
ListBox1.Items.Add(" col " & " X " & RutaX(col) & " Y " & RutaY(col))
Next
BtnDibujarRuta_Click(sender, e)
End Sub
Private Sub btnMover_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles btnMover.Click
End Sub
Private Sub BtnDetener_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles BtnDetener.Click
End Sub
Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles Timer1.Tick
btnRuta_Click(sender, e)
End Sub
Private Sub BtnDibujarRuta_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles BtnDibujarRuta.Click
Dim fila As Integer
For fila = li To Cont - 1
Grafico3.DrawRectangle(Pens.Red, (RutaX(fila) * Ex - AutoX(0) * Ex) + tam * Ex,
(RutaY(fila) * Ey - AutoY(0) * Ey) + tam * Ey, Ex, Ey)
Grafico1.DrawRectangle(Pens.Red, RutaX(fila) * Ex1, RutaY(fila) * Ey1, Ex1, Ey1)
Next
End Sub
Private Sub BtnPosicionar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles BtnPosicionar.Click
IniciarVectores()
AutoX(0) = txtPosX.Text
AutoY(0) = TxtPosy.Text
AutoX(1) = AutoX(0)
AutoY(1) = AutoY(0) - 1
RutaX(0) = AutoX(1)
RutaY(0) = AutoY(1)
Cont = 0
contMalos = 0
PosXAuto = AutoX(0)
PosYAuto = AutoY(0)
traslados()
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles Retroceder.Click
Cont = Cont - 1 ' ver si hay menos 1
li = li - 1
AutoX(0) = RutaX(Cont)
AutoY(0) = RutaY(Cont)
AutoX(1) = RutaX(Cont - 1)
AutoY(1) = RutaY(Cont - 1)
PosXAuto = AutoX(0)
PosYAuto = AutoY(0)
ListBox1.Items.Add("CONT " & Cont)
ListBox1.Items.Add("li " & li)
ListBox1.Items.Add("CONT MALOS " & contMalos)
ListBox1.Items.Add("DIR " & dir)
ListBox1.Items.Add("CABERZA " & AutoX(0) & "Y " & AutoY(0))
ListBox1.Items.Add("COLA " & AutoX(1) & "Y " & AutoY(1))
BtnDibujarRuta_Click(sender, e)
End Sub
End Class
System.EventArgs) Handles btnGrafico.Click
GrabarDatos()
End Sub
End Class
11.18 MOVER UN ARCHIVO DE TEXTO Elaborar un programa que mueva un

archivo de texto por la pantalla
CODIGO DEL MODULO
Imports System.IO
Module Module2
Public x1, x2 As Integer
Public ex As Single = 30, ey As Single = 30
Public cadena As String = "AREQUIPA, 17 DE MAYO DEL 2010"
Public CadenaBusca As String
Public ASCII, indice As Integer
Public vel As Integer
' ***************************
Public NroLetras As Integer = 0
Public Const maxfilas As Integer = 12, maxcol As Integer = 700 ' 590
Public Const maxfilas1 As Integer = 12, maxcol1 As Integer = 100
Public nf As Integer = 10, nc As Integer = 590
Public nf1 As Integer = 10, nc1 As Integer = 100
Public nf2 As Integer = 10, nc2 As Integer = 90 ' se va copiar esa cantidad
Public Cx1 As Integer = 0, Cy1 As Integer = 0 ' lugar de donde se va a copiar
Public Cx2 As Integer = 60, Cy2 As Integer = 1 ' lugar a pegar en la matriz A
Public Cx3 As Integer = 1, Cy3 As Integer = 1 ' lugar a mostrar la matriz B
Public separa As Integer = 10
Public B(maxfilas1, maxcol1) As String
Public MA(maxfilas, maxcol) As String
Public MB(maxfilas, maxcol) As String
Sub ImprimirMatriz(B(,) As String, ByRef M(,) As String, Cx1 As Integer, Cy1 As

Integer, ancho As Integer, alto As Integer)
For col = 0 To ancho - 1
M(Cy1 + fila, Cx1 + col) = B(fila, col)
Next
Next
End Sub
Sub CopiarMatrices(A(,) As String, ByRef B(,) As String, Cx As Integer, Cy As
Integer, Ancho As Integer, alto As Integer)
For col = 0 To Ancho - 1
B(fila, col) = A(Cy + fila, Cx + col)
Next
Next
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByRef A(,) As String, ByRef nf
inicio = 1
inicio = pos + 1
Next
fila = fila + 1
Loop
nf = fila
srLector.Close()
End Sub
End Module
Public Class Form1

Dim Pen As Pen
End Sub
Sub MostrarMatriz(ByRef A(,) As String, Cx As Integer, Cy As Integer, nc As Integer,

Grafico.FillRectangle(brocha, Cx + col * ex, Cy + fila * ey, ex, ex)
End If
Next
Next
End Sub

BtnBorrar.Click
End Sub
BtnIniciar.Click
Dim col As Integer
cadena = TextBox1.Text
Dim NombreArchivo As String = "E:\datos1\letras590x10.txt"
RecuperarMatriz(NombreArchivo, A, nf, nc)
' MostrarMatriz(Cx, Cy, A, nc, nf)
NroLetras = Len(cadena)
cont = 0
For col = 0 To NroLetras - 1
CadenaBusca = cadena(col)
ASCII = Asc(CadenaBusca)
indice = ASCII - 32
Cx1 = separa * indice
CopiarMatrices(A, B, Cx1, Cy1, nc1, nf1)
ImprimirMatriz(B, MA, cont * separa, Cy1, nc1, nf1)
cont = cont + 1
Next
CopiarMatrices(MA, MB, 0, 0, NroLetras * 10, nf2)
MostrarMatriz(MB, Cx3, Cy3, nc2, nf2)
x1 = 10
End Sub
Private Sub Manual_Click(sender As Object, e As EventArgs) Handles

BtnManual.Click
If x1 < NroLetras * 10 Then
CopiarMatrices(MA, MB, x1, 0, ancho, nf2)
MostrarMatriz(MB, 1, Cy3, ancho, nf2)
x1 = x1 + 1
'System.Threading.Thread.Sleep(20) ' 1 milisegundo
Else
x1 = 1
End If
End Sub

btnMover.Click
vel = TextBox2.Text
End Sub
Private Sub btnParar_Click(sender As Object, e As EventArgs) Handles

btnParar.Click
End Sub
Manual_Click(sender, e)
End Sub
End Class
11.20 MADURACION DE UNA FRUTA (ejemplo platanos)
Public Class Form1
Dim GraficoCombinado As Graphics

Dim Contfactor As Single = 0
Dim Color As Color
Dim Pict As Bitmap
Dim Pict1 As Bitmap
Dim Pict2 As Bitmap
Dim Pict3 As Bitmap
Dim Pict4 As Bitmap
Dim Pict5 As Bitmap
Dim Pict6 As Bitmap
Dim Pict7 As Bitmap
Const maxfilas As Integer = 50, maxcol As Integer = 50
Dim alto As Integer = maxfilas, ancho As Integer = maxcol
Dim Brocha1 As SolidBrush
Dim brochaG As SolidBrush

Dim Rojos1(maxfilas, maxcol) As Integer, Verdes1(maxfilas, maxcol) As Integer,
Azules1(maxfilas, maxcol) As Integer
Dim rojo, verde, azul As Byte

Dim cx As Integer = 1, cy As Integer = 1
Dim velocidad As Single
Dim valor As Single = 0
Private Sub CargarGrafico(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnCargarGrafico.Click
Color = Pict1.GetPixel(col, fila)
Rojos1(fila, col) = Color.R
Verdes1(fila, col) = Color.G
Azules1(fila, col) = Color.B





Next col
Next
End Sub
PictureBox1.Width = ancho + cx
PictureBox1.Height = alto + cy
Cuadro.Width = ancho * 2 + cx
Cuadro.Height = alto * 2 + cy
Pict1 = New Bitmap("e:\datos2\platano1.bmp")
Brocha1 = New SolidBrush(Drawing.Color.Aqua)

brochaG = New SolidBrush(Drawing.Color.Aqua)
GraficoCombinado = Cuadro.CreateGraphics
End Sub
Private Sub Iniciar(sender As Object, e As EventArgs) Handles BtnIniciar.Click

rojo = Rojos1(fila, col)
verde = Verdes1(fila, col)
azul = Azules1(fila, col)
Brocha1.Color = Color.FromArgb(rojo, verde, azul)
Grafico1.FillRectangle(Brocha1, cx + col, cy + fila, 1, 1)






Next
Next
Contfactor = 0
End Sub
Private Sub btnMadurar_Click_1(sender As Object, e As EventArgs) Handles

btnMadurar.Click
velocidad = TextBox1.Text
factor = TextBox2.Text
Timer1.Interval = velocidad
End Sub
btnDetener.Click
End Sub

Contfactor = Contfactor + factor
TextBox4.Text = Contfactor
Graficar(sender, e)
End Sub
Sub graficar12(valor As Single)
Dim rojo12, verde12, azul12 As Integer
rojo12 = Rojos1(fila, col) * (1 - valor) + Rojos2(fila, col) * valor
verde12 = Verdes1(fila, col) * (1 - valor) + Verdes2(fila, col) * valor
azul12 = Azules1(fila, col) * (1 - valor) + Azules2(fila, col) * valor
brochaG.Color = Color.FromArgb(rojo12, verde12, azul12)
GraficoCombinado.FillRectangle(brochaG, cx + col, cy + fila, 1, 1)
Next
Next
End Sub
Next
Next
End Sub

Next
Next
End Sub

Next
Next
End Sub

Next
Next
End Sub

Next
Next
End Sub
Private Sub Graficar(sender As Object, e As EventArgs) Handles btnGraficar.Click

Contfactor = TextBox4.Text
If Contfactor <= 1 Then
graficar12(Contfactor)
Else
graficar23(Contfactor - 1)
Else
Else
Else
Else
Else
Contfactor = 0
End If
End If
End If
End If
End If
End If
End Sub
Private Sub btnManual_Click(sender As Object, e As EventArgs) Handles

btnManual.Click
Contfactor = Contfactor + factor
TextBox4.Text = Contfactor
Graficar(sender, e)
End Sub
End Class
11.21 JUEGO DEL PACMAN
Este juego esta basado en la pagina país de juegos de internet
http://www.paisdelosjuegos.pe/juegos/pacman
se juega con las teclas direccionales
Option Explicit On
Public Class Form1
DataGridView1.RowCount = nf
DataGridView1.ColumnCount = nc
DataGridView1.Columns(col).HeaderText = col
Next
Next
RecuperarMatriz(NombreArchivo, Matriz, nf, nc)
Matriz(pmy, pmx) = 3
MostrarMatriz(Matriz, nf, nc)
txtPorcentaje.Text = contar(Matriz, nf, nc) * 100
DataGridView1.Focus()
End Sub
Private Sub BtnRecuperar_Click(sender As Object, e As EventArgs) Handles
BtnRecuperar.Click
RecuperarMatriz(NombreArchivo, Matriz, nf, nc)
End Sub
Private Sub BtnMostrar_Click(sender As Object, e As EventArgs) Handles
BtnMostrar.Click
End Sub
Private Sub DataGridView1_CellEnter(sender As Object, e As
DataGridViewCellEventArgs) Handles DataGridView1.CellEnter
col = DataGridView1.CurrentCellAddress.X
fila = DataGridView1.CurrentCellAddress.Y
'DataGridView1.CurrentCell.Style.BackColor = Color.FromArgb(255, 0, 0)
TextBox1.Text = "F " & fila & "C" & col
ValorActual = DataGridView1.CurrentCell.Value
txtAnterior.Text = ValorAnterior
txtActual.Text = ValorActual
TextBox2.Text = cont
Select Case ValorActual
Case camino ' entre a la celda de color blanco
If ValorAnterior = relleno Then ' la celda anterior era verde
cont = 0 ' comienza a llenar al vector
' encuentra la fila columna inicial
X(cont) = col
Y(cont) = fila
xini = col
yini = fila
ListBox1.Items.Add("Xini " & xini & " Yini " & yini)
ListBox1.Items.Add("Yfin " & xfin & " Yfin " & yfin)
DataGridView1.CurrentCell.Value = relleno ' ahora la celda es de color verde
Matriz(fila, col) = relleno
Else ' la celda anterior no era verde sigue incrementando contador
cont = cont + 1
X(cont) = col
Y(cont) = fila
DataGridView1.CurrentCell.Value = relleno ' ahora la celda es de color verde
Matriz(fila, col) = relleno
End If
Case relleno ' entre a la celda de color verde
If ValorAnterior = relleno Then ' la celda anterior era verde
' no hace nada
Else ' la celda anterior era blanco ' termina la salida
xfin = col
yfin = fila
Y(cont) = fila
X(cont) = col
ListBox1.Items.Add("Xini " & xini & " Yini " & yini)
ListBox1.Items.Add("Yfin " & xfin & " Yfin " & yfin)
If cont > 2 Then
nelem = cont
cx = (xini + xfin) / 2
cy = (yini + yfin) / 2
' MostrarMatriz(Matriz, nf, nc)
Centroide(X, Y, nelem, centrox, centroy)
'DataGridView1.Rows(cy).Cells(cx).Value = 3
'DataGridView1.Rows(centroy).Cells(centrox).Value = 4
' CENTRO PROMEDIO
If Matriz(cy, cx) = camino Then
Rellenar(cx, cy)
End If
If Matriz(centroy, centrox) = camino Then
Rellenar(centrox, centroy)
End If
txtPorcentaje.Text = contar(Matriz, nf, nc) * 100
End If
End If
End Select
ValorAnterior = ValorActual
End Sub
Private Sub btnVector_Click(sender As Object, e As EventArgs) Handles
btnVector.Click
nelem = cont
MostrarVector(X, Y, nelem)
End Sub
Private Sub btnRellenar_Click(sender As Object, e As EventArgs) Handles
btnRellenar.Click
Rellenar(cx, cy)
End Sub
BtnIniciar.Click
DataGridView1.Rows(fila).Cells(col).Value = 0
Matriz(fila, col) = 0
Next
Next
End Sub
Sub jugar()
Dim pmx1 As Single = pmx
Dim pmy1 As Single = pmy
Dim dist, distmenor
dist = distancia(col, fila, pmx, pmy)
distmenor = dist
Matriz(pmy, pmx) = camino
pmx1 = pmx
pmy1 = pmy
dist = distancia(col, fila, pmx + 1, pmy)
If dist < distmenor And Matriz(pmy, pmx + 1) = camino Then
distmenor = dist
pmx1 = pmx + 1
End If
dist = distancia(col, fila, pmx - 1, pmy)
If dist < distmenor And Matriz(pmy, pmx - 1) = camino Then
distmenor = dist
pmx1 = pmx - 1
End If
dist = distancia(col, fila, pmx, pmy + 1)
If dist < distmenor And Matriz(pmy + 1, pmx) = camino Then
distmenor = dist
pmy1 = pmy + 1
End If
dist = distancia(col, fila, pmx, pmy - 1)
If dist < distmenor And Matriz(pmy - 1, pmx) = camino Then
distmenor = dist
pmy1 = pmy - 1
End If
If pmx1 = pmx And pmy1 = pmy Then
While (1)
pmx = Int(Rnd() * nc)
pmy = Int(Rnd() * nf)
If (Matriz(pmy, pmx) = camino) Then Exit While
End While
Else
pmy = pmy1
pmx = pmx1
End If
vecinos = Contavecinos(Matriz, nf, nc, col, fila)
Matriz(pmy, pmx) = 3
If distmenor < 2 Then
If vecinos < 4 Then
txtvecinos.Text = " muerto"
Else
txtvecinos.Text = " VIVO"
End If
Exit Sub
End If
txtdistancia.Text = distmenor
txtvecinos.Text = vecinos
DataGridView1.Focus()
End Sub
Private Sub btnJugar_Click(sender As Object, e As EventArgs) Handles
btnJugar.Click
End Sub
jugar()
End Sub
End Class
CODIGO DEL MODULO
Imports System.IO
Module module2
'/*** declaraciones
Public NombreArchivo As String = "E:\DATOS\MATRIZ20X20.txt"
Public Matriz(maxfilas, maxcol) As Integer
Public maxelem As Integer = 1000
Public X(maxelem) As Integer ' vector de coordenadas x
Public Y(maxelem) As Integer ' vector de coordenadas y
Public px As Integer = 2 ' objeto identifico
Public py As Integer = 2
Public ser As Integer = 1
Public relleno As Integer = 2
Public nelem As Integer
Public cx As Integer = 0 ' centro dela figura
Public ValorAnterior As Integer = 2 ' verde
Public ValorActual As Integer = 0
Public xini As Integer = 0
Public yini As Integer = 0
Public xfin As Integer = 0
Public yfin As Integer = 0
Public centrox As Integer
Public centroy As Integer
Public cpromx As Integer
Public cpromY As Integer
Public pmx As Integer = 10
Public pmy As Integer = 10
Public pacman As Integer = 3
Public fila As Integer ' fila del pacman
Public col As Integer
Public vecinos As Integer = 0
Sub Rellenar(cx1 As Integer, cy1 As Integer)

Form1.DataGridView1.Rows(cy1).Cells(cx1).Value = relleno
Matriz(cy1, cx1) = relleno
If Matriz(cy1, cx1 + 1) = camino And cx1 < nc - 1 Then
Rellenar(cx1 + 1, cy1)
End If
If cx1 > 0 And Matriz(cy1, cx1 - 1) = camino Then
Rellenar(cx1 - 1, cy1)
End If
If Matriz(cy1 + 1, cx1) = camino And cy1 < nf - 1 Then
Rellenar(cx1, cy1 + 1)
End If
If Matriz(cy1 - 1, cx1) = camino And cy1 > 0 Then
Rellenar(cx1, cy1 - 1)
End If
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, A(,) As Integer, ByVal nf As
inicio = 1
inicio = pos + 1
Next
Next
srLector.Close()
End Sub
Sub MostrarVector(X() As Integer, Y() As Integer, n As Integer)
Dim col As Integer
Form1.ListBox1.Items.Clear()
For col = 0 To n - 1
Form1.ListBox1.Items.Add("col " & col & " X= " & X(col) & " Y= " & Y(col))
Next
End Sub
Sub Centroide(X() As Integer, y() As Integer, Nelem As Integer, ByRef cx As Integer,
ByRef cy As Integer)
Nelem = cont
Dim col
Dim sx As Integer = 0
Dim sy As Integer = 0
For col = 0 To Nelem - 1
sx = sx + X(col)
sy = sy + y(col)
Next
cx = (sx / Nelem)
cy = (sy / Nelem)
End Sub
Function contar(A(,) As Integer, ByVal nf As Integer, ByVal nc As Integer) As Single
Dim suma, fila, col As Integer
If A(fila, col) = relleno Then suma = suma + 1
Next
Next
Return suma / (nf * nc)
End Function
Sub MostrarMatriz(A(,) As Integer, ByVal nf As Integer, ByVal nc As Integer)
Form1.DataGridView1.Rows(fila).Cells(col).Value = A(fila, col)
Select Case A(fila, col)
Case 0
Form1.DataGridView1.Rows(fila).Cells(col).Style.BackColor =
Color.FromArgb(250, 255, 255)
Case 1 ' pacman
Case 2 ' relleno
Case 3 'malo 1
End Select
Next
Next
End Sub
Function distancia(x1 As Single, y1 As Single, x2 As Single, y2 As Single) As Single

Return Math.Sqrt(Math.Pow(x2 - x1, 2) + Math.Pow(y2 - y1, 2))
End Function
Function Contavecinos(A(,) As Integer, nf As Integer, nc As Integer, px As Integer, py
As Integer) As Integer
Dim vecinos As Integer = 0
If px > 0 Then
If A(py, px - 1) = relleno Then vecinos = vecinos + 1
End If
If px < nc - 1 Then
If A(py, px + 1) = relleno Then vecinos = vecinos + 1
End If
If py > 0 Then
If A(py - 1, px) = relleno Then vecinos = vecinos + 1
End If
If py < nf - 1 Then
If A(py + 1, px) = relleno Then vecinos = vecinos + 1
End If
Return vecinos
End Function
End Module
Tarea: elaborar el siguiente juego del pacman
11.22 APLICACIONES DE REDES NEURONALES PERCEPTRON
Para ilustrar la regla de aprendizaje del Perceptrón, se dará solución al problema de

clasificación de patrones ilustrado en la figura 2.1.9
, , ,
Figura 2.1.9 Patrones de entrenamiento
En este caso las salidas toman valores bipolares de 1 o –1, por lo tanto la función de
transferencia a utilizar será hardlims. Según la dimensiones de los patrones de
entrenamiento la red debe contener dos entradas y una salida.
Figura 2.1.10 Red Perceptrón que resolverá el problema de clasificación de patrones
Para decidir si una red tipo Perceptrón puede aplicarse al problema de interés, se debe
comprobar si el problema es linealmente separable, esto puede determinarse
gráficamente de la figura 2.1.9, en donde se observa que existe un gran número de
líneas rectas que pueden separar los patrones de una categoría de los patrones de la
otra, el siguiente paso es asumir arbitrariamente los valores para los pesos y ganancias
iniciales de entrada a la red; el proceso terminará cuando se hayan obtenido los pesos
y ganancias finales que permitan a la red clasificar correctamente todos los patrones
presentados.
Los valores iniciales asignados aleatoriamente a los parámetros de la red son:
Con base en el procedimiento descrito anteriormente, el proceso de aprendizaje de la

red es el siguiente:
De la iteración 0p1estaba mal clasificado, la actualización de pesos permite que este

patrón sea clasificado correctamente.
La iteración 1 lleva a la característica de decisión de la figura 2.1.12
REM ****** module

Module Module3
Public limite As Integer = 10
Public Const np As Integer = 2 REM nro de capas
Public a As Single
Public B(np, 1) As Single
Public B1(np, 1) As Single
Public BrochaSolida As SolidBrush
Public C(maxfilas, maxcol) As Single
Public ColorApagado As Color = Color.Gray
Public Colorprendido As Color = Color.Red
Public e As Single
Public ey As Integer = -1
Public i As Integer
Public k As Integer
Public MA(maxfilas, maxcol) As Single
Public ME1(np, np) As Single
Public ne As Integer = 0 ' nro de errores
Public pen1 As Pen
Public pen2 As Pen
Public R(maxfilas, maxcol) As Single
Public t As Single ' el resultado deseado
Public valorButon1 As Integer = -1
Public valorButon2 As Integer = -1
Public VS(maxfilas) As Single
Public VX(maxfilas) As Single
Public VY(maxfilas) As Single
Public W(1, np) As Single
Public W1(1, np) As Single
Public WX(np, np) As Single
Public X(np, 1) As Single
Public xa, ya, xb, yb As Single
Public XT(np, 1) As Single
Public XT1(np, 1) As Single
End Module
REM ************module 1
Imports System.IO
Module Module1
Sub Escalar(ByVal a(,) As Single, b(,) As Single, e As Single, nc As Integer)
Dim col As Integer
b(0, col) = e * a(0, col)
Next
End Sub
Sub CalcularLinea(W(,) As Single, B(,) As Single, n As Single)
xa = 0
ya = -B(0, 0) / W(0, 1)
yb = 0
xb = -B(0, 0) / W(0, 0)
Console.WriteLine(" valores de x1 {0} y1 {1}", xa, ya)
Console.WriteLine(" valores de x2 {0} y2 {1}", xb, yb)
End Sub
Sub MatrizTranspuesta(ByVal a(,) As Single, ByVal b(,) As Single, ByVal nf As
b(col, fila) = a(fila, col)
Next
Next
End Sub
Sub MultiplicarMatriz(ByVal a(,) As Single, ByVal b(,) As Single, ByRef c(,) As Single, _
ByVal p As Integer, ByVal q As Integer, ByVal r As Integer)
Dim i, j, k As Integer
Dim aux As Single
For i = 0 To p - 1
For k = 0 To r - 1
aux = 0
For j = 0 To q - 1
aux = aux + a(i, j) * b(j, k)
Next
c(i, k) = aux
Next
Next
End Sub
Sub ObtenerVectores(A(,) As Single, X() As Single, Y() As Single, S() As Single, nf

As Integer)
Dim fila As Integer
X(fila) = A(fila, 0)
Y(fila) = A(fila, 1)
S(fila) = A(fila, 2)
Next
End Sub
Sub MostrarVector(X() As Single, nf As Integer)
Dim fila As Integer
Console.Write("{0,4}", X(fila))
Next
End Sub
Sub CopiarMatriz(ByVal A(,) As Single, ByVal B(,) As Single, ByVal nf As Integer,
Next
Next
End Sub
Console.Write("{0,4} ", A(fila, col))
Next
Console.WriteLine()
Next
End Sub
Sub SumarMatrices(ByVal A(,) As Single, B(,) As Single, C(,) As Single, nf As
C(fila, col) = A(fila, col) + B(fila, col)
Next
Next
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByRef A(,) As Single, ByVal nf
inicio = 1
inicio = pos + 1
Next
Next
srLector.Close()
End Sub
Function Hardlims(W(,) As Single, X(,) As Single, t As Single, np As Integer) ' se
obtiene el error y la salida
Dim res As Single
MultiplicarMatriz(W, X, C, 1, 2, 1)
Console.WriteLine("resultado producto")
MostrarMatriz(C, 1, 1)
SumarMatrices(C, B, R, 1, 1)
Console.WriteLine("resultado suma")
MostrarMatriz(R, 1, 1)
If R(0, 0) < 0 Then
res = -1
Else
res = 1
End If
Return res
End Function
Sub ModificarPesos(w(,) As Single, ByRef w1(,) As Single, np As Integer)
MatrizTranspuesta(X, XT, np, 1)
MostrarMatriz(XT, 1, np)
' calcular nuevos pesos
Escalar(XT, XT1, ME1(0, 0), np)
Console.WriteLine("La matriz escalada es ")
MostrarMatriz(XT1, 1, np)
SumarMatrices(w, XT1, w1, 1, np)
' calculo del error
SumarMatrices(w, XT1, w1, 1, np)
End Sub
End Module
REM ********* codigo del formulario
Option Explicit On
Public Class Form1
DataGridView1.DefaultCellStyle.Font = New Font("Arial", 16)
W(0, 0) = -0.7
W(0, 1) = 0.2
B(0, 0) = 0.5
W1(0, 0) = -0.7
W1(0, 1) = 0.2
B1(0, 0) = 0.5
btnFoco.Image = PictureBox3.Image
btnE1.BackColor = ColorApagado
btnE1.Text = "OFF"
btnE2.Text = "ON"
PictureBox3.Width = ancho
PictureBox3.Height = alto
pen2 = New Pen(Color.Blue, 1)
BrochaSolida = New SolidBrush(Color.Black)
Cambio(valorButon1, valorButon2)
End Sub
Sub ObtenerMatriz(ByRef A(,) As Single, ByVal nf As Integer, ByVal nc As Integer)
A(fila, col) = DataGridView1.Rows(fila).Cells(col).Value
Next
Next
End Sub

Next
Next
End Sub
Private Sub btnIniciar_Click(sender As Object, e As EventArgs) Handles
btnIniciar.Click
nf = txtNf.Text
DataGridView1.RowCount = nf + 1
DataGridView1.Columns(2).HeaderText = "t"
End Sub
Private Sub btnCargar_Click(sender As Object, e As EventArgs) Handles
btnCargar.Click
Dim NombreArchivo As String
NombreArchivo = OpenFileDialog1.FileName
RecuperarMatriz(NombreArchivo, MA, nf, nc)
ObtenerVectores(MA, VX, VY, VS, nf)
MostrarMatriz(MA, nf, nc)
Me.Text = "perceptron " + NombreArchivo
End Sub
Private Sub Probar(sender As Object, e As EventArgs) Handles btnProbar.Click
X(0, 0) = TXTe1.Text
X(1, 0) = txtE2.Text
W(0, 0) = TxtW1.Text
W(0, 1) = txtW2.Text
B(0, 0) = txtB.Text
a = Hardlims(W, X, t, 2)
txtSalida.Text = a
Select Case a
Case -1
Case 1
Case Else
End Select
End Sub
Private Sub btnEntrenar_Click(sender As Object, e As EventArgs) Handles
btnEntrenar.Click
ne = 0
cont = 0
Do
ne = 0
' Console.WriteLine("*********Ciclo {0} ", cont)
For i = 0 To nf - 1
' Console.WriteLine("**************ITERACION {0} ", i)
B(0, 0) = B1(0, 0)
CopiarMatriz(W1, W, 1, np)
X(0, 0) = VX(i) : X(1, 0) = VY(i) : t = VS(i)
a = Hardlims(W, X, t, np)
' Console.WriteLine(" *** iteracion {0} salida {1}", i, a)
ME1(0, 0) = t - a
If ME1(0, 0) <> 0 Then ne = ne + 1
' Console.WriteLine("el error es {0}", ME1(0, 0))
' modificacion de pesos y a
ModificarPesos(W, W1, np)
' Console.WriteLine("los nuevos pesos son")
TxtW1.Text = W1(0, 0)
txtW2.Text = W1(0, 1)
' MostrarMatriz(W1, 1, np)
' calcular b
SumarMatrices(B, ME1, B1, 1, 1)
'Console.WriteLine("El nuevo B es {0}", B1(0, 0))
txtB.Text = B1(0, 0)
Next
' Console.WriteLine("nro de errores {0} ", ne)
cont = cont + 1
Loop While (ne > 0)
' Console.WriteLine("***resultados finales ")
'Console.WriteLine("los nuevos pesos son")
TxtW1.Text = W1(0, 0)
txtW2.Text = W1(0, 1)
' calcular b
SumarMatrices(B, ME1, B1, 1, 1)
' Console.WriteLine("El nuevo B es {0}", B1(0, 0))
txtB.Text = B1(0, 0)
End Sub
Sub Cambio(ve1 As Integer, ve2 As Integer)
X(0, 0) = ve1
X(1, 0) = ve2
TXTe1.Text = X(0, 0)
txtE2.Text = X(1, 0)
W(0, 0) = TxtW1.Text
W(0, 1) = txtW2.Text
B(0, 0) = txtB.Text
a = Hardlims(W, X, t, 2)
txtSalida.Text = a
Select Case a
Case -1
Case 1
Case Else
End Select
End Sub
Private Sub entrada1(sender As Object, e As EventArgs) Handles btnE1.Click
If valorButon1 = -1 Then
valorButon1 = 1
btnE1.BackColor = Colorprendido
btnE1.Text = "ON"
Else
valorButon1 = -1
btnE1.Text = "OFF"
End If
End Sub
Private Sub Entrada2(sender As Object, e As EventArgs) Handles btnE2.Click
If valorButon2 = -1 Then
valorButon2 = 1
btnE2.BackColor = Colorprendido
btnE2.Text = "ON"
Else
valorButon2 = -1
btnE2.Text = "OFF"
End If
End Sub
Private Sub BtnGraficar_Click(sender As Object, e As EventArgs) Handles

BtnGraficar.Click
Dim x1 As Integer
Dim y1 As Integer
Dim res As Integer
Dim valor As Integer
For k = -limite To limite
Grafico.DrawString(k, MiFuente, BrochaSolida, cx + k * tam, cy)
Grafico.DrawLine(pen2, cx + k * tam, 0, cx + k * tam, alto)
Next
For k = -limite To limite
Grafico.DrawString(k, MiFuente, BrochaSolida, cx, cy + k * tam * ey)
Grafico.DrawLine(pen2, 0, cy + k * tam, ancho, cy + k * tam)
Next
Grafico.DrawLine(pen1, 0, cy, ancho, cy)
Grafico.DrawLine(pen1, cx, 0, cx, alto)
'REM graficar la funcion
For k = 0 To nf - 1
x1 = VX(k) * tam
y1 = VY(k) * tam
res = VS(k)
valor = tam / 4
If res > 0 Then
Grafico.FillEllipse(Brushes.Blue, cx + x1 - valor, cy + y1 * ey - valor, valor * 2, valor * 2)
Else
Grafico.FillEllipse(Brushes.Red, cx + x1 - valor, cy + y1 * ey - valor, valor * 2, valor * 2)
End If
Next
End Sub

btnBorrar.Click
End Sub
Private Sub PictureBox3_MouseDown(sender As Object, e As MouseEventArgs)

Handles PictureBox3.MouseDown
Dim ValorX As Single
Dim ValorY As Single
ValorX = (e.X - cx) / tam
ValorY = -(e.Y - cy) / tam
TXTe1.Text = ValorX
txtE2.Text = ValorY
valor = tam / 2
Grafico.FillRectangle(Brushes.Green, cx + ValorX * tam - valor, cy + ValorY * ey *
tam - valor, valor * 2, valor * 2)
End Sub
Private Sub btnActualizar_Click(sender As Object, e As EventArgs) Handles
btnActualizar.Click
ObtenerMatriz(MA, nf, nc)
ObtenerVectores(MA, VX, VY, VS, nf)
End Sub
End Class
Problema 4 resuelva el problema de OR (0,1)
ENTRADA1 ENTRADA 2 OR
-1 -1 -1
-1 1 1
1 -1 1
1 1 1
11.23 APLICACIONES DE LOGICA DIFUSA EN CONTROL DE TEMPERATURA
TEMPERATURAS
CATEGORIA Valor Min Valor Medio Valor Maximo
FRIO 0 15 30
TEMPLADO 15 30 45
CALIENTE 25 42 60
MU CALIENTE 50 70 100
CLASE CATEGORIA
Public Class Categoria

Public nombre As String
Public ValorBajo As Single
Public ValorMedio As Single
Public ValorAlto As Single
Public Sub setname(s As String)
nombre = s
End Sub
Public Function getname() As String
Return nombre
End Function
Public Sub PonerValor(ByRef h As Single, ByRef m As Single, ByRef l As Single)
ValorAlto = h
ValorMedio = m
ValorBajo = l
End Sub
Public Function getlowval() As Single
Return ValorBajo
End Function
Public Function getmidval() As Single
Return ValorMedio
End Function
Public Function gethighval() As Single
Return ValorAlto
End Function
Public Function getshare(ByRef input As Single) As Single
' // la función miembro retorna la membresía realtiva
'// de en la Entrada en una categoría. con un maximun de 1.0
Dim output As Single
Dim midlow, highmid As Single
midlow = ValorMedio - ValorBajo
highmid = ValorAlto - ValorMedio
'// si el rango exceed entonces salida =0
If ((input <= ValorBajo) Or (input >= ValorAlto)) Then
output = 0
Else
If (input > ValorMedio) Then
output = (ValorAlto - input) / highmid
Else
If (input = ValorMedio) Then
output = 1.0
Else
output = (input - ValorBajo) / midlow
End If
End If
End If
Return output
End Function
End Class
Option Explicit On
Public Class Form1
Dim Nfilas, Ncol, fila, col As Integer
Function randomnum(maxval As Integer) As Single
'// genera numero aletorio devolverá un entero a maxval
Randomize()
Return Rnd() * maxval
End Function

BtnIniciar.Click
Dim fila1 As Integer
Nfilas = txtFilas.Text
Ncol = 5
DataGridView1.ColumnCount = Ncol
DataGridView1.RowCount = Nfilas + 1 REM //numero de columnas
For col1 = 0 To Ncol - 1
DataGridView1.Columns(col1).Width = 50 REM //ancho de las columnas
Next
' REM Poner nro de las filas
For fila1 = 0 To Nfilas - 1
DataGridView1.Rows(fila1).HeaderCell.Value = Str(fila1)
DataGridView1.Rows(fila1).Cells(0).Value = fila1 + 1
Next
'// Poner TITULOS de COLUMNAS
DataGridView1.Columns(1).HeaderText = "CATEGORIA"
DataGridView1.Columns(2).HeaderText = "VMin"
DataGridView1.Columns(3).HeaderText = "VMedio"
DataGridView1.Columns(4).HeaderText = "VMax"
'// valores por defecto

DataGridView1.Rows(0).Cells(1).Value = "FRIO"
DataGridView1.Rows(1).Cells(1).Value = " TEMPLADO"
DataGridView1.Rows(2).Cells(1).Value = "CALIENTE"
DataGridView1.Rows(3).Cells(1).Value = "Muy CALIENTE"
DataGridView1.Rows(0).Cells(2).Value = "0"
'// Valores de la cuadricula 2
DataGridView2.ColumnCount = 3 REM //numero de columnas
DataGridView2.RowCount = Nfilas + 1 REM //numero de filas
DataGridView2.Columns(0).Width = 40 REM //ancho de la col 0

'// Poner numero de COLUMNAS

DataGridView2.Columns(1).HeaderText = "CATEGORIA"
DataGridView2.Columns(2).HeaderText = "PROB"
End Sub
Private Sub BtnCalcular_Click(sender As Object, e As EventArgs) Handles

BtnCalcular.Click
Dim i As Integer = 0
Dim j As Integer = 0
Dim numcat As Integer = 0
Dim randnum, k As Integer
Dim l, m, h As Single
Dim inval As Single = 1.0
Dim input As String
'""// ***** ver despuesSIN
Dim ptr(10) As Categoria
Dim relprob(10) As Single
Dim valor As Single
Dim total As Single = 0
Dim runtotal As Single = 0
numcat = Nfilas REM // número de categorias
total = 0
For i = 0 To numcat - 1
ptr(i) = New Categoria()
input = DataGridView1.Rows(i).Cells(1).Value
ptr(i).setname(input)
l = DataGridView1.Rows(i).Cells(2).Value
m = DataGridView1.Rows(i).Cells(3).Value
h = DataGridView1.Rows(i).Cells(4).Value
ptr(i).PonerValor(h, m, l)
Next
inval = txtDesc.Text
For j = 0 To numcat - 1
relprob(j) = 100 * ptr(j).getshare(inval)
total = total + relprob(j)
Next
If (total = 0) Then
MessageBox.Show("Presione el boton OK ")
REM Exit if
Return
End If
randnum = randomnum(CInt(total))
j=0
runtotal = relprob(0)
While ((runtotal < randnum) And (j < numcat))
j += 1
runtotal = runtotal + relprob(j)
End While
txtCat.Text = ""
txtCat.Text = ptr(j).getname()
For j = 0 To numcat - 1
DataGridView2.Rows(j).Cells(0).Value = j
DataGridView2.Rows(j).Cells(1).Value = ptr(j).getname()
valor = relprob(j) / total
DataGridView2.Rows(j).Cells(2).Value = valor
Next
End Sub
End Class
11.24 APLICACIÓN DEL MODELOS DEL SIMPLEX

DESCRIPCION Se ha hecho un programa del método simplex usando visual basic del
visual estudio 2012
El programa permite
Ingresar los datos escoger la opción de maximización y minimización
Permite formar las matrices de variables de holgura exceso y artificiales
Permite mostrar las iteraciones paso a paso a colores
Y grabar los datos y los resultados para poder analizar en Excel
Esta en proceso el método grafico y el análisis de senisiblidad
El programa ejecutable no necesita del visual estudio para su ejecución
El programa también realiza análisis de sensibilidad
CJ
CK
Cj-ZJ
zj
Cj-ZJ
zj
Cj-ZJ
Programa simplex2
CJ 200 150 0 0
CK XK B X1 X2 U1 U2 Φ
0 U1 500 3 2 1 0 166,666667
0 U2 400 1 2 0 1 400
0 0 0 0 0
Cj-ZJ 200 150 0 0
200 X1 166,666667 1 0,66666667 0,33333333 0 250
0 U2 233,333333 0 1,33333333 -0,33333333 1 175
zj 33333,3333 200 133,333333 66,6666667 0
Cj-ZJ 0 16,6666667 -66,6666667 0
200 X1 50 1 0 0,5 -0,5
150 X2 175 0 1 -0,25 0,75
zj 36250 200 150 62,5 12,5
Cj-ZJ 0 0 -62,5 -12,5
VARIABLE BASICA
x1 ck Cj-Zj aij ΔCK
max 200 -12,5 -0,5 25 225
min 200 -62,5 0,5 125 75
x2 ck Cj-Zj aij ΔCK
max 150 -62,5 -0,25 250 400
min 150 12,5 0,75 16,6666667 133,333333
restriciones sin dual
u1 max 500 175 -0,25 700 1200
min 500 50 0,5 100 400
u2 max 400 50 -0,5 100 500
min 400 175 0,75 233,333333 166,666667
Las opciones del menú son las siguientes
Utilizacion
Descripcion del software
Escoja iteraciones
Escoja análisis de sensibilidad
Elija el archivo a procesar
CODIGO FUENTE
' ************** MODULE 3

Imports System.IO
Module Module3
Public CadTexto As String = ""
Public M As Single = 1000
Public tipo As Integer = 1 ' maximizacion
Public filaNro As Integer = 0
Public pivote As Single
Public semipivote As Single
Public filaPivote As Integer
Public colPivote As Integer
Public nVartificial As Integer = 0
Public NombreArchivo As String = "E:\DATOS\CONFEC1.txt"
'Public NombreArchivo As String = "E:\DATOS\PRODUCTO2X3.txt"
' Public NombreArchivo As String = "E:\DATOS\TOYKO3X3.txt"
' Public NombreArchivo As String = "E:\DATOS\PANQUESO.txt"
'Public NombreArchivo As String = "E:\DATOS\PINTURAS.txt"
Public NombreArchivoGrabado As String = "E:\DATOS\SimplexResultado.txt"
Public TablaSimplex(maxfilas, maxcol) As String
Public ListadoSimplex(maxfilas) As String
Public Vresto(maxcol) As Single ' vector resto de analisis sensibilidad
Public CRJ(maxcol) As Single ' vector de coefecientes de los recursos
Public XRJ(maxcol) As String ' vector de nombres de los recursos
Public CRJMax(maxcol) As Single ' vector de coefecientes de los recursos lim
superior
Public cRJMin(maxcol) As Single ' vector de nombres de los recursos lim inferior
Public CKLMax(maxcol) As Single
Public CKLMin(maxcol) As Single
Public CReducido(maxcol) As Single
Public PSombra(maxcol) As Single
Public XJ(maxcol) As String
Public CJ(maxcol) As Single
Public CK(maxfilas) As Single
Public XK(maxfilas) As String
Public ZJ(maxfilas) As Single
Public CJ_ZJ(maxfilas) As Single
Public Theta(maxfilas) As Single
Public Z As Single
Public B(maxfilas) As Single
Public B2(maxfilas) As Single
'Public A(3, 6) As Single
Public A(maxfilas, maxcol) As Single
Public A2(maxfilas, maxcol) As Single
' Public A2(3, 6) As Single
Public pos As Integer
Public cadena2 As String
Public Cadentero, cadletra As String
Public largo As Integer
Public ne As Integer = 0
Public NcVar As Integer = 2
Public NfRest As Integer = 2
Public NvHolgura As Integer = 2
Function ObtenerTipo(cadena As String) As Integer
Dim pos As Integer = -1
Dim resul As Integer = -1
pos = InStr(cadena, "MAX")
resul = 1
If pos <= 0 Then
pos = InStr(cadena, "MIN")
resul = 2
End If
Return resul
End Function
Sub copiar(A(,) As Single, A1(,) As Single, B() As Single, B1() As Single, nfrest As
Integer, ncovar As Integer)
For fila = 0 To nfrest - 1
B1(fila) = B(fila)
For col = 0 To NcVar - 1
A1(fila, col) = A(fila, col)
Next
Next
End Sub
Sub LeerArchivo(Nombre As String, A() As String, ByRef nf As Integer)
Dim srLector As StreamReader = New StreamReader(Nombre)
Dim Linea As String
Linea = srLector.ReadLine()
A(cont) = Linea
cont = cont + 1
Loop
srLector.Close()
nf = cont
End Sub
Sub FormaStandar(A() As String, nf As Integer, CRJ() As Single, XRJ() As String, _
ByRef NroVholgura As Integer, ByRef nVartificial As Integer, ByRef Ncvar
As Integer)
Dim pos, fila As Integer
Dim CadRempla As String
Dim CantVa As Integer
pos = InStr(A(fila), "<=")
If pos > 0 Then
CRJ(cont) = B(cont)
XRJ(cont) = "U" + CStr(cont + 1)
cont = cont + 1
A(fila) = Replace(A(fila), "<=", "+1U" & CStr(cont) + " = ")
A(0) = A(0) + "+0U" + CStr(cont) + " "
Else
pos = InStr(A(fila), ">=")
If pos > 0 Then
CRJ(cont) = B(cont)
XRJ(cont) = "E" + CStr(cont + 1)
cont = cont + 1
CadRempla = "-1E" & CStr(cont) & "+1Q" & CStr(cont) + " = "
A(fila) = Replace(A(fila), ">=", CadRempla)
A(0) = A(0) + "-0E" + CStr(cont) + " "
CantVa = CantVa + 1
End If
End If
Next
For fila = 0 To CantVa - 1
A(0) = A(0) + "+" + CStr(M) + "Q" + CStr(fila + 1) + " "
Next
NroVholgura = cont
Ncvar = cont + NroVholgura + CantVa
nVartificial = CantVa
End Sub
Sub ImprimirVectorNumero(A() As Single, ne As Integer)
Dim fila As Integer
Console.WriteLine("{0} {1}", A(fila), vbTab)
Next
End Sub
Sub GrabarMatrizcadena(Nombre As String, A(,) As String, nf As Integer, nc As
Integer)
Dim Archivo As StreamWriter
Archivo = New StreamWriter(NombreArchivoGrabado)
Dim fila As Integer
Archivo.Write("{0} {1}", A(fila, col), vbTab)
Next
Archivo.WriteLine()
Next
Archivo.Close()
End Sub
Sub ImprimirMatrizNumero(A(,) As Single, nf As Integer, nc As Integer)
Dim fila As Integer
Console.Write("{0} {1}", A(fila, col), vbTab)
Next
Console.WriteLine()
Next
End Sub
Sub ImprimirMatrizCadena(A(,) As String, nf As Integer, nc As Integer)
Dim fila As Integer
Console.Write("{0} {1}", A(fila, col), vbTab)
Next
Console.WriteLine()
Next
End Sub
Sub IniciarMatrizCadenas(A(,) As String, nf As Integer, nc As Integer)
A(fila, col) = "0"
Next
Next
End Sub
Sub ImprimirVectorCadena(A() As String, ne As Integer)
Dim fila As Integer
Console.WriteLine("{0} {1}", A(fila), vbTab)
Next
End Sub
Sub ObtenerVectores(inicio As Integer, bCadena As String, CJ() As Single, XJ() As
String, ByRef ne As Integer)
largo = Len(cadena)
Dim posletra As Integer
Console.WriteLine(cadena)
Do
' pos = InStr(inicio + 1, cadena, "+")
pos = PosMasmenos(cadena, inicio)
cadena2 = Mid(cadena, inicio, pos - inicio)
posletra = PrimeraLetra(cadena2) + 1
Cadentero = Mid(cadena2, 1, posletra - 1)
CJ(cont) = Val(Cadentero)
cadletra = Mid(cadena2, posletra, Len(cadena2) - posletra + 1)
XJ(cont) = cadletra
cont = cont + 1
inicio = pos
Loop Until pos > (largo - 1)
ne = cont
End Sub
Function PrimeraLetra(Cadena As String) As Integer
Dim fila As Integer, lug As Integer = 0
For fila = 1 To Len(Cadena)
If Not IsNumeric(Cadena(fila)) Then
lug = fila
Exit For
End If
Next
Return lug
End Function
Function EncontrarPosletra(cadena As String, pos As Integer) As Integer
For col = pos - 1 To 0 Step -1
If cadena(col) = "+" Or cadena(col) = "-" Then
lugar = col
Exit For
End If
Next
Return lugar
End Function
Function PosMasmenos(cadena As String, inicio As Integer) As Integer
Dim col, resultado As Integer
resultado = -1
For col = inicio To Len(cadena) - 1
If cadena(col) = "+" Or cadena(col) = "-" Then
resultado = col + 1
Exit For
End If
Next
Return resultado
End Function
Sub ObtencionDeValores(ListadoSimplex() As String, A(,) As Single, B() As Single,
CRJ() As Single, Ncvar As Integer, nfres As Integer)
Dim cadena As String = "+3X2 +2X2 <=500"
Dim cadena1 As String = XJ(0)
Dim Cadena3 As String
Dim valor As Single
For fila = 0 To NfRest - 1
cadena = Trim(ListadoSimplex(fila + 2)) + "+"
'*******************
pos = InStr(cadena, "=")
lugar = PosMasmenos(cadena, pos)
cadena2 = Mid(cadena, pos + 1, lugar - pos)
B(fila) = Val(cadena2)
CRJ(fila) = B(fila)
For col = 0 To Ncvar - 1
cadena1 = Trim(XJ(col))
pos = InStr(1, cadena, cadena1)
If pos > 0 Then
lugar = EncontrarPosletra(cadena, pos) + 1
Cadena3 = Mid(cadena, lugar, pos - lugar)
valor = Val(Cadena3)
Else
valor = 0
End If
A(fila, col) = valor
Next
Next
End Sub
Sub VectoresUnitarios(CK() As Single, XK() As String)
Dim fila, col, k, filanro As Integer
Dim cont1 As Integer = 0
cont1 = 0
cont0 = 0
If A(fila, col) = 1 Then cont1 = cont1 + 1
If A(fila, col) = 0 Then cont0 = cont0 + 1
Next
' Console.WriteLine(" col {0} cont1 {1} cont0 {2} ", col, cont1, cont0)
If (cont1 = 1 And cont0 = NfRest - 1) Then
' en que fila esta el 1
For k = 0 To NfRest - 1
If A(k, col) = 1 Then
filanro = k
Exit For
End If
Next
' Console.WriteLine("VECTOR UNITARIO en col={0} =fila {1}", col, filanro)
CK(filanro) = CJ(col)
XK(filanro) = XJ(col)
Else
' Console.WriteLine(" no es vector unitario")
End If
Next
End Sub
Function obtenerZ(CK() As Single, B() As Single, nfrest As Integer) As Single
Dim fila As Integer
valor = valor + CK(fila) * B(fila)
Next
Return valor
End Function
Function obtenerZJB(CK() As Single, B() As Single, ZJ() As Single, nfrest As Integer,
ncvar As Integer) As Single
Dim suma As Single
Dim fila As Integer
suma = suma + CK(fila) * B(fila)
Next
Return suma
End Function
Sub obtenerZJA(CK() As Single, A(,) As Single, ZJ() As Single, nfrest As Integer,

ncvar As Integer)
For col = 0 To ncvar - 1
ZJ(col) = 0
ZJ(col) = ZJ(col) + CK(fila) * A(fila, col)
Next
Next
End Sub
Sub obtenerCJ_ZJ(CJ() As Single, ZJ() As Single, CJ_ZJ() As Single, ncvar As
Integer)
Dim col As Integer
CJ_ZJ(col) = CJ(col) - ZJ(col)
Next
End Sub
Function SolucionColumna(CjZj() As Single, ncvar As Integer, tipo As Integer) As
Integer
Dim mayor As Integer = -10000
Dim menor As Integer = 10000
Dim fila As Integer
Dim lug As Integer = -1
Dim retorno As Integer = -1
Select Case tipo
Case 1
For fila = 0 To ncvar - 1
If CjZj(fila) > mayor Then
mayor = CjZj(fila)
lug = fila
End If
Next
If mayor > 0 Then retorno = lug
Case 2
For fila = 0 To ncvar - 1
If CjZj(fila) < menor Then
menor = CjZj(fila)
lug = fila
End If
Next
If menor < 0 Then retorno = lug
End Select
Return retorno
End Function
Function SolucionFila(Theta() As Single, nfrest As Integer) As Integer
Dim fila As Integer
Dim lug As Integer = -1
Dim filaescogidad As Integer = -1
If Theta(fila) > 0 And Theta(fila) < menor Then
menor = Theta(fila)
lug = fila
End If
Next
Return lug
End Function
End Module
MODULE 2
' ********* MODULE 2

Module Module2
Sub Iniciar1()
Dim fila As Integer
'LeerArchivo(NombreArchivo, ListadoSimplex, nf)
Console.WriteLine(" FORMA NORMAL")
ImprimirVectorCadena(ListadoSimplex, nf)
tipo = ObtenerTipo(ListadoSimplex(0))
FormaStandar(ListadoSimplex, nf, CRJ, XRJ, NvHolgura, nVartificial, NcVar)
NfRest = nf - 2 '
Console.WriteLine(" FORMA estandar")
ImprimirVectorCadena(ListadoSimplex, nf)
cadena = "+" + ListadoSimplex(0) + "+"
' inicio =PO InStr(4, cadena, "+")
inicio = PosMasmenos(cadena, 4)
ObtenerVectores(inicio, cadena, CJ, XJ, NcVar)

Console.WriteLine(" resultados Vector Numeros ")
ImprimirVectorNumero(CJ, NcVar)
Console.WriteLine()
Console.WriteLine(" resultados Vector Cadenas ")
ImprimirVectorCadena(XJ, NcVar)
ObtencionDeValores(ListadoSimplex, A, B, CRJ, NcVar, NfRest)
Console.WriteLine("RESULTADCOS Matriz A ")
ImprimirMatrizNumero(A, NfRest, NcVar)
Console.WriteLine("RESULTADCOS Vector B ")
ImprimirVectorNumero(B, NfRest)
VectoresUnitarios(CK, XK)
Console.WriteLine("Ck ")
ImprimirVectorNumero(CK, NfRest)
Console.WriteLine("Xk ")
ImprimirVectorCadena(XK, NfRest)
' proceso de armado de la tabla inicial des simples
fila = 0
IniciarMatrizCadenas(TablaSimplex, nf, NcVar)
TablaSimplex(fila, 0) = "CJ"
TablaSimplex(fila, 3 + col) = CJ(col)
TablaSimplex(fila + 1, 3 + col) = XJ(col)
Next
fila = 1
TablaSimplex(fila, 0) = "CK"
TablaSimplex(fila, 1) = "XK"
TablaSimplex(fila, 2) = "B"
End Sub
Sub Armado(ByRef filaNro As Integer)
Dim col As Integer
TablaSimplex(filaNro + fila, 0) = CK(fila)
TablaSimplex(filaNro + fila, 1) = XK(fila)
TablaSimplex(filaNro + fila, 2) = B(fila)
TablaSimplex(filaNro + fila, 3 + col) = A(fila, col)
Next
Next
filaNro = filaNro + NfRest ' ver despues?
TablaSimplex(filaNro, 0) = "ZJ"
TablaSimplex(filaNro, 2) = obtenerZ(CK, B, NfRest)
Console.WriteLine(" tabla simplex")
TablaSimplex(filaNro, 2) = obtenerZJB(CK, B, ZJ, NfRest, NcVar)
obtenerZJA(CK, A, ZJ, NfRest, NcVar)
TablaSimplex(filaNro, col + 3) = ZJ(col)
Next
obtenerCJ_ZJ(CJ, ZJ, CJ_ZJ, NcVar)
filaNro = filaNro + 1 ' era ilanro+1
TablaSimplex(filaNro, 0) = "CJ-ZJ"
TablaSimplex(filaNro, col + 3) = CJ_ZJ(col)
Next
filaNro = filaNro + 1
End Sub
Sub pivotear(colPivote As Integer, A(,) As Single, B() As Single, A2(,) As Single, B2()
As Single, _
nfrest As Integer, ncvar As Integer)
Theta(fila) = B(fila) / A(fila, colPivote)
Next
filaPivote = SolucionFila(Theta, nfrest)
Console.WriteLine("fila escogida {0} ", filaPivote)
pivote = A(filaPivote, colPivote)
Console.WriteLine("pivote {0} ", pivote)
' comenzamos a pivotear incluyendo B
If fila = filaPivote Then
A2(fila, col) = A(fila, col) / pivote
B2(fila) = B(fila) / pivote
Next
Else
semipivote = A(fila, colPivote)
B2(fila) = B(fila) - B(filaPivote) * semipivote / pivote
A2(fila, col) = A(fila, col) - A(filaPivote, col) * semipivote / pivote
Next
End If
Next
End Sub
Function MayorAIJ(XK() As String, A(,) As Single, filaNro As Integer, ncNVar As
Integer) As Integer
Dim col, pos As Integer
For col = 0 To ncNVar - 1
If XK(col) <> XK(filaNro) Then
If A(filaNro, col) > mayor Then
mayor = A(filaNro, col)
pos = col
End If
End If
Next
Return pos
End Function
Function MenorAIJ(XK() As String, A(,) As Single, filaNro As Integer, ncNVar As
Integer) As Integer
Dim col, pos As Integer
For col = 0 To ncNVar - 1
If XJ(col) <> XK(filaNro) Then
If A(filaNro, col) < menor Then
menor = A(filaNro, col)
pos = col
End If
End If
Next
Return pos
End Function
Function MenorAIJCol(RXJ() As String, A(,) As Single, colnro As Integer, nfRest As
Integer) As Integer
Dim fila, pos As Integer
For fila = 0 To nfRest - 1
If A(fila, colnro) < menor Then
menor = A(fila, colnro)
pos = fila
End If
Next
Return pos
End Function
Function MayorAIJCol(RXJ() As String, A(,) As Single, colnro As Integer, nfRest As
Integer) As Integer
Dim fila, pos As Integer
For fila = 0 To nfRest - 1
If A(fila, colnro) > mayor Then
mayor = A(fila, colnro)
pos = fila
End If
Next
Return pos
End Function
Sub AnalisisSensibilidadVariables(CK() As Single, Creducido() As Single, cklmin() As
Single, _
cklmax() As Single, nfres As Integer, tipo As Integer)
Dim fila, Posmenor, PosVar, PosMayor As Integer
Dim AijMenor, Deltazj, AijMayor, Costoreducido As Single
Select Case tipo
Case 1
For fila = 0 To nfres - 1
PosVar = EncontrarLugarEnVector(XJ, XK(fila), NcVar - nVartificial)
Posmenor = MenorAIJ(XK, A, fila, NcVar - nVartificial)
AijMenor = A(fila, Posmenor)
Deltazj = Math.Abs(CJ_ZJ(Posmenor) / AijMenor)
cklmax(fila) = CK(fila) + Deltazj
' *************
PosMayor = MayorAIJ(XK, A, fila, NcVar - nVartificial)
AijMayor = A(fila, PosMayor)
Deltazj = Math.Abs(CJ_ZJ(PosMayor) / AijMayor)
cklmin(fila) = CK(fila) - Deltazj
Costoreducido = CJ_ZJ(PosVar)
Next
Case 2
PosVar = EncontrarLugarEnVector(XJ, XK(fila), NcVar - nVartificial)

PosMayor = MayorAIJ(XK, A, fila, NcVar - nVartificial)
AijMayor = A(fila, PosMayor)
Deltazj = Math.Abs(CJ_ZJ(PosMayor) / AijMayor)
cklmax(fila) = CK(fila) + Deltazj
' *************
Posmenor = MenorAIJ(XK, A, fila, NcVar - nVartificial)
AijMenor = A(fila, Posmenor)
Deltazj = Math.Abs(CJ_ZJ(Posmenor) / AijMenor)
cklmin(fila) = CK(fila) - Deltazj
Costoreducido = CJ_ZJ(PosVar)
Next
End Select
End Sub
Sub AnalisisSensibilidadRecursos(CRJ() As Single, Psombra() As Single, CrjMin() As
Single, CrjMax() As Single, _
nfres As Integer, tipo As Integer)
Dim PosCol1, PosCol2 As Integer
Dim nrecurso As String = XJ(0)
Dim Posmenor As Integer
Dim AijMenor As Single
Dim Deltazj As Single
Dim Posmayor As Integer
Dim AijMayor As Single
Select Case tipo
Case 1
For col = 0 To NvHolgura - 1
nrecurso = XRJ(col)
PosCol1 = EncontrarLugarEnVector(XJ, nrecurso, NcVar - nVartificial) ' pos
PosCol2 = EncontrarLugarEnVector(XRJ, nrecurso, NcVar - nVartificial) '
pos
Psombra(PosCol2) = -CJ_ZJ(PosCol1)
If PosCol1 >= 0 Then ' solo se no encuentra
Posmenor = MenorAIJCol(XRJ, A, PosCol1, NfRest)
AijMenor = A(Posmenor, PosCol1)
Deltazj = Math.Abs(B(Posmenor) / AijMenor)
CrjMax(col) = CRJ(col) + Deltazj
End If
Next
nrecurso = XRJ(col)
Posmayor = MayorAIJCol(XRJ, A, PosCol1, NfRest)
AijMayor = A(Posmayor, PosCol1)
Deltazj = Math.Abs(B(Posmayor) / AijMayor)
CrjMin(col) = CRJ(col) - Deltazj
End If
Next
Case 2
nrecurso = XRJ(col)
PosCol2 = EncontrarLugarEnVector(XRJ, nrecurso, NcVar - nVartificial) '
pos
Psombra(PosCol2) = -CJ_ZJ(PosCol1)
If PosCol1 >= 0 Then ' solo se encuentra
Posmayor = MayorAIJCol(XRJ, A, PosCol1, NfRest)
AijMayor = A(Posmayor, PosCol1)
Deltazj = Math.Abs(B(Posmayor) / AijMayor)
CrjMax(col) = CRJ(col) + Deltazj
End If
Next
nrecurso = XRJ(col)
Posmenor = MenorAIJCol(XRJ, A, PosCol1, NfRest)
AijMenor = A(Posmenor, PosCol1)
Deltazj = Math.Abs(B(Posmenor) / AijMenor)
CrjMin(col) = CRJ(col) - Deltazj
End If
Next
End Select
End Sub
Sub ImprimirASensibilidad(XK() As String, CK() As Single, Creducido() As Single,

ckimin() As Single, cklmax() As Single, nfres As Integer)
Dim fila As Integer
Console.WriteLine(" {0} {1} {2} {3} {4} ", XK(fila), CK(fila), Creducido(fila),
ckimin(fila), cklmax(fila))
Next
End Sub
Function EncontrarLugarEnVector(Xj() As String, Nombre As String, ne As Integer)

As Integer
Dim fila, posres As Integer
posres = -1
If Trim(Xj(fila)) = Trim(Nombre) Then
posres = fila
Exit For
End If
Next
Return posres
End Function
End Module
' *************** MODULE 1

' *************** MODULE 1
Module Module1
Sub TodoProceso()
Iniciar1()
filaNro = 2
Armado(filaNro)
colPivote = SolucionColumna(CJ_ZJ, NcVar, tipo)
'ImprimirMatrizCadena(TablaSimplex, filaNro + NfRest, NcVar + 3)
While colPivote >= 0
Console.WriteLine("col escogida {0} ", colPivote)
pivotear(colPivote, A, B, A2, B2, NfRest, NcVar)
filaNro = filaNro + NfRest - 2
copiar(A2, A, B2, B, NfRest, NcVar)
VectoresUnitarios(CK, XK)
Armado(filaNro)
colPivote = SolucionColumna(CJ_ZJ, NcVar, tipo)
End While
ImprimirMatrizCadena(TablaSimplex, filaNro + NfRest, NcVar + 3)
GrabarMatrizcadena(NombreArchivoGrabado, TablaSimplex, NfRest + filaNro,
NcVar + 3)
AnalisisSensibilidadVariables(CK, CReducido, CKLMin, CKLMax, NfRest, tipo)
ImprimirASensibilidad(XK, CK, CReducido, CKLMin, CKLMax, NfRest)
AnalisisSensibilidadRecursos(CRJ, PSombra, cRJMin, CRJMax, NfRest, tipo)
ImprimirASensibilidad(XRJ, CRJ, PSombra, cRJMin, CRJMax, NvHolgura)
' AnalisisSensibilidadRecursos()
Console.ReadLine()
End Sub
Sub main()
TodoProceso()
End Sub
End Module

Public Class Form1

Inherits System.Windows.Forms.Form
Sub MostrarVectorCadena(Cadena As String, A() As String, ne As Integer)
Dim fila As Integer
txtSimplex.Text = ""
Cadena = Cadena + A(fila) + vbCrLf
Next
txtSimplex.Text = Cadena
End Sub
Sub AbrirArchivo()
OpenFileDialog1.Title = "Abrir Documento txt"
OpenFileDialog1.Filter = "Documento txt|*.txt"
LeerArchivo(NombreArchivo, ListadoSimplex, nf)
CadTexto = "FORMA NORMAL" + vbCrLf
MostrarVectorCadena(CadTexto, ListadoSimplex, nf)
End Sub
Private Sub MnuaAbrir_Click(sender As Object, e As EventArgs) Handles
MnuAbrir.Click
AbrirArchivo()
End Sub
Private Sub MnuFormaStandar_Click_1(sender As Object, e As EventArgs)
End Sub
Private Sub btnProcesar_Click(sender As Object, e As EventArgs)
End Sub
Sub MostrarMatrizCadena(A(,) As String, nf As Integer, nc As Integer)
Dim fila As Integer
Next
Next
End Sub
Private Sub btnIteraciones_Click(sender As Object, e As EventArgs)
End Sub
Sub MostrarASensibilidad(NroFila As Integer, XK() As String, B() As Single, CK() As
Single, Creducido() As Single, _
cklmin() As Single, cklmax() As Single, nfres As Integer)
Dim fila As Integer
DataGridView2.Rows(NroFila + fila).Cells(0).Value = XK(fila)
DataGridView2.Rows(NroFila + fila).Cells(1).Value = B(fila)
DataGridView2.Rows(NroFila + fila).Cells(2).Value = Creducido(fila)
DataGridView2.Rows(NroFila + fila).Cells(3).Value = CK(fila)
DataGridView2.Rows(NroFila + fila).Cells(4).Value = cklmin(fila)
DataGridView2.Rows(NroFila + fila).Cells(5).Value = cklmax(fila)
Next
End Sub
Private Sub MnuProcesar_Click(sender As Object, e As EventArgs) Handles

MnuProcesar.Click
AbrirArchivo()
TodoProceso()
End Sub
Private Sub VerFormaStandarToolStripMenuItem_Click(sender As Object, e As

EventArgs) Handles VerFormaStandarToolStripMenuItem.Click
FormaStandar(ListadoSimplex, nf, CRJ, XRJ, NvHolgura, nVartificial, NcVar)
CadTexto = "FORMA ESTANDAR" + vbCrLf
MostrarVectorCadena(CadTexto, ListadoSimplex, nf)
End Sub
Private Sub MnuIteraciones_Click(sender As Object, e As EventArgs) Handles

MnuIteraciones.Click
DataGridView1.RowCount = filaNro + NfRest
DataGridView1.ColumnCount = NcVar + 3
DataGridView1.DefaultCellStyle.Font = New Font("Arial Black", 12)
MostrarMatrizCadena(TablaSimplex, filaNro + NfRest, NcVar + 3)
End Sub
Private Sub MnuAnalisisDeSensibilidad_Click(sender As Object, e As EventArgs)

Handles MnuAnalisisDeSensibilidad.Click
Dim col As Integer
DataGridView2.RowCount = NcVar + 4
DataGridView2.DefaultCellStyle.Font = New Font("Arial Black", 12)
Dim Nrofila As Integer = 1
For col = 0 To 5
Next
DataGridView2.Rows(0).Cells(0).Value = "Variable"
DataGridView2.Rows(0).Cells(1).Value = "Valor"
DataGridView2.Rows(0).Cells(2).Value = "CostoReducido"
DataGridView2.Rows(0).Cells(3).Value = "Valor Original"
DataGridView2.Rows(0).Cells(4).Value = "Limite Inferior"
DataGridView2.Rows(0).Cells(5).Value = "Limite Superior"
AnalisisSensibilidadVariables(CK, CReducido, CKLMin, CKLMax, NfRest, tipo)
ImprimirASensibilidad(XK, CK, CReducido, CKLMin, CKLMax, NfRest)
MostrarASensibilidad(Nrofila, XK, CK, B, CReducido, CKLMin, CKLMax, NfRest)
Nrofila = Nrofila + NfRest
DataGridView2.Rows(Nrofila).Cells(0).Value = "Restriccion"
DataGridView2.Rows(Nrofila).Cells(1).Value = "Restante"
DataGridView2.Rows(Nrofila).Cells(2).Value = "Valor Original"
DataGridView2.Rows(Nrofila).Cells(3).Value = "Precio Sombra"
DataGridView2.Rows(Nrofila).Cells(4).Value = "Limite Inferior"
DataGridView2.Rows(Nrofila).Cells(5).Value = "Limite Superior"
Nrofila = Nrofila + 1
AnalisisSensibilidadRecursos(CRJ, PSombra, cRJMin, CRJMax, NfRest, tipo)
MostrarASensibilidad(Nrofila, XRJ, CReducido, PSombra, CRJ, cRJMin, CRJMax,
NvHolgura)
End Sub
End Class
APLICACCION DEL programa a los siguientes problemas
Problema de confecciones
Plan de Producción de Confecciones

Producto Traje Vestido
Cantidad a producir 50 175 ganancia
Margen de Contribución 200 150 36250

Restricciones Total LI Disp Holgura
Lana 3 2 500 <= 500 - .000.
Algodón 1 2 400 <= 400 - .000.
Maximizar (z) = 200x1+ 150x2

Sujeto a:
3x1 +2x2 <=500 (lana)
X1+2x2<=400 (algodón)
X1,x2>=0
Solucioin
Problema de mimimizacion problema dela dieta
Variable x1 x2
Productos Pan queso
Cantidad 1 1 Costo
Costo 4 12 16
Restricciones Usado Requerido ld Exceso
Calorías 2500 5000 7500 7000 >= -500
Proteínas 50 200 250 250 >= 0
Forma original
Min (z) = 4x1+12x2
s.a 2500x1+5000x2 >=7000 ( calorias)
50x1+200x2≥ 250 (proteinas)
X1,X2 ≥0
Forma estándar ( o aumentada con variables artificiales)

Min (z) = 4x1+12x2-0u1-0u2+Mq1+Mq2
s.a 2500x1+5000x2 –u1+Mq1 =7000 ( calorias)
Ejercicio Calcule la solución del siguiente problema
Una compañía manufacturera fabrica 2 productos 1 y 2 y es lo suficientemente

afortunada como para vender todo lo que se puede producir actualmente se tiene
como dato el siguiente
Requerimientos de tiempo de manufacturación para producir una unidad de producto
por departamento
Producto tiempo de manufactura horas
Depto A Depto B Depto C Utilidad
1 2 1 4 10
2 2 2 2 15
Horas Disponibles 160 120 280
Sea x1 la cantidad a producir del producto 1

Sea x2 la cantidad a producir del producto 2
El Modelo es
Max(z) = 10x1+ 15x2

Sujeto a:
2x1+ 2x2 <=160 ( Depto A)
X1+2x2 <=120 ( depto B)
4x1+ 2x2 <=280
X1, x2 > =0
11.25 APLICACIÓN DEL MODELOS DEL SIMPLEX METODO GRAFICO
La siguiente aplicación permite resolver los problemas por el método grafico con n
restricciones y muestra la solución se puede cambiar las escalas
Solución del problema de los productos por el método gráfico
Solucion del problema de confecciones por el método gráfico

Problema de minimización
CODIGO DEL MODULO
Module Module2
Public mayor As Single
Public rUnidadX As Single
Public UnidadX As Single
Public UnidadY As Single
Public ValorMaximoX As Single
Public ValorMaximoY As Single
Public tipofo As Integer ' es maximizacion o miminimizacion
Public dx As Single ' nro de decimales
Public Zmaximo As Single
Public maxx1 As Single, maxx2 As Single
Public Const paso As Integer = 30
Public M1(maxfilas, 2) As Single ' matriz de los coefecientes
Public CJ(2) As Single ' coefecientes de la funcion objetiva
Public B(maxfilas) As Single ' coefecientes de los recursos
Public col As Integer
Public fila As Integer
Public filaIni As Integer = 1
Public numerador As Single
Public denominador As Single
Public dato As Single
Public pen As Pen
Public brocha As Brush
Public ancho = 600, alto = 400
Public Cx As Integer = paso
Public Cy As Integer = alto
Public ey As Single = -2
Public r1 As Single, r2 As Single
Public x1 As Single, x2 As Single, x1a As Single, x2a As Single, z As Single
Public r(maxfilas) As Single, menor As Single
Public resultado As String
Public k As Integer
End Module
CODIGO DEL MODULO
Module Module1
Public nrestric As Integer
Public nva As Integer ' nro de variables artificiales
Public nvar As Integer
Function probarlineaMax(ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As
Single, ByVal y2 As Single _
, ByVal valor As Single, ByVal C() As Single, ByVal B() As Single, ByRef x
As Single, ByRef y As Single)
Dim xx As Single, yy As Single
Dim factible As Integer = 0
Dim menor As Single = Zmaximo
xx = x1
yy = (valor - C(0) * xx) / C(1)
While yy >= 0
menor = Zmaximo
For fila1 = 0 To nrestric - 1
r(fila1) = B(fila1) - (xx * M1(fila1, 0) + yy * M1(fila1, 1))
If r(fila1) < menor Then
menor = r(fila1)
End If
Next
If menor >= 0 Then
factible = 1
x = xx
y = yy
Exit While
Else
xx = xx + dx
yy = (valor - C(0) * xx) / C(1)
End If
End While
probarlineaMax = factible
End Function
Function probarlineaMin(ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single,

ByVal y2 As Single _
, ByVal valor As Single, ByVal C() As Single, ByVal B() As Single, ByRef
x As Single, ByRef y As Single)
Dim factible As Integer = 0
xx = x1
yy = (valor - C(0) * xx) / C(1)
While yy >= 0
menor = Zmaximo
For fila1 = 0 To nrestric - 1
r(fila1) = (xx * M1(fila1, 0) + yy * M1(fila1, 1)) - B(fila1)
If r(fila1) < menor Then
menor = r(fila1)
End If
Next
If menor >= 0 Then
factible = 1
x = xx
y = yy
Exit While
Else
xx = xx + dx
yy = (valor - C(0) * xx) / C(1)
End If
End While
probarlineaMin = factible
End Function
End Module
Option Explicit On
Public Class Form1
tipofo = 1 ' maximizacion
nrestric = 3
nvar = 2
PictureBox1.Width = ancho + paso
PictureBox1.Height = alto + paso
PictureBox1.BackColor = ColorFondo
pen = New Pen(Color.Blue, 2)
dx = 0.1
End Sub
Private Sub PictureBox1_MouseMove(ByVal sender As System.Object, ByVal e As

System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseMove
If e.Button = Windows.Forms.MouseButtons.Left Then
Me.Text = "X = " & e.X & "Y= " & e.Y
x1 = (e.X - Cx) / ex
x2 = -(Cy - e.Y) / ey
z = CJ(0) * x1 + CJ(1) * x2
ListBox1.Items.Add("X1 " & x1)
ListBox1.Items.Add("X2 " & x2)
ListBox1.Items.Add("Z " & z)
menor = 1000
Select Case tipofo
Case 1
For fila = 0 To nrestric - 1
r(fila) = B(fila) - (x1 * M1(fila, 0) + x2 * M1(fila, 1))
ListBox1.Items.Add("r " & fila + 1 & " = " & r(fila))
If r(fila) < menor Then
menor = r(fila)
End If
Next
ListBox1.Items.Add("menor " & menor)
If menor < 0 Then
ListBox1.Items.Add("INFACTIBLE")
Else
ListBox1.Items.Add("FACTIBLE")
End If
Case 2
r(fila) = (x1 * M1(fila, 0) + x2 * M1(fila, 1)) - B(fila)
ListBox1.Items.Add("r " & fila + 1 & " = " & r(fila))
If r(fila) < menor Then
menor = r(fila)
End If
Next
ListBox1.Items.Add("menor " & menor)
If menor < 0 Then
ListBox1.Items.Add("INFACTIBLE")
Else
ListBox1.Items.Add("FACTIBLE")
End If
End Select
End If
End Sub
Sub ImprimirMatriz(ByRef A(,) As Single, ByVal Cy As Integer, ByVal Cx As Integer,

ByVal nf As Integer, ByVal nc As Integer)
DataGridView2.Rows(Cy + fila).Cells(Cx + col).Value = A(fila, col)
Next col
Next fila
End Sub
Sub ImprimirVector(ByVal A() As Single, ByVal Cy As Integer, ByVal Cx As Integer,
ByVal Nc As Integer)
For col = 0 To Nc - 1
DataGridView2.Rows(Cy).Cells(Cx + col).Value = A(col)
Next
End Sub
Private Sub MnuIniciar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuIniciar.Click
' solo trabaja para caso de dos variables
Try
DataGridView1.RowCount = nrestric + filaIni + 2
DataGridView1.Columns(0).HeaderCell.Value = "Variable"
For col = 1 To nvar
DataGridView1.Columns(col).HeaderCell.Value = "X" & col
Next
DataGridView1.Rows(0).Cells(0).Value = " Margen Contr"
DataGridView1.Rows(1).Cells(0).Value = " Restricciones"
DataGridView1.Rows(1).Cells(nvar + 1).Value = " Disponib"
For col = 1 To nrestric
DataGridView1.Rows(1 + col).Cells(0).Value = "R" & col
Next
' obtenemos la matriz M1 y B
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Sub MnuIniciarGrafico_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuIniciarGrafico.Click
DataGridView2.RowCount = nrestric + 3
B(fila) = DataGridView1.Rows(2 + fila).Cells(3).Value
For col = 0 To 1
M1(fila, col) = DataGridView1.Rows(2 + fila).Cells(1 + col).Value
Next
Next
' obtenemos la matriz CJ
For col = 0 To 1
CJ(col) = DataGridView1.Rows(0).Cells(1 + col).Value
Next
' solo son dos variables
DataGridView2.Rows(0).Cells(0).Value = "RESTRICIONES"
DataGridView2.Rows(0).Cells(1).Value = "X1"
DataGridView2.Rows(0).Cells(2).Value = "X2"
DataGridView2.Rows(0).Cells(3).Value = "X1a"
DataGridView2.Rows(0).Cells(4).Value = "X2a"
' obtnenemos los maximos de x1 y x2
maxx1 = -1000
maxx2 = -1000
DataGridView2.Rows(fila + filaIni).Cells(0).Value = "R" & fila + 1
DataGridView2.Rows(fila + filaIni).Cells(1).Value = 0
numerador = DataGridView1.Rows(fila + filaIni + 1).Cells(3).Value
denominador = DataGridView1.Rows(fila + filaIni + 1).Cells(2).Value
dato = numerador / denominador
If dato > maxx1 Then maxx1 = dato
DataGridView2.Rows(filaIni + fila).Cells(2).Value = dato
DataGridView2.Rows(filaIni + fila).Cells(4).Value = 0
' si x2=0
denominador = DataGridView1.Rows(fila + filaIni + 1).Cells(1).Value
dato = numerador / denominador
If dato > maxx2 Then maxx2 = dato
DataGridView2.Rows(filaIni + fila).Cells(3).Value = dato
Next
DataGridView2.Rows(nrestric + filaIni).Cells(0).Value = "maximo"
DataGridView2.Rows(nrestric + filaIni).Cells(2).Value = maxx1
DataGridView2.Rows(nrestric + filaIni).Cells(3).Value = maxx2
Zmaximo = CJ(0) * maxx1 + CJ(1) * maxx2
If maxx1 > maxx2 Then
mayor = maxx1
Else
mayor = maxx2
End If
ValorMaximoX = mayor
ValorMaximoY = mayor
ex = ancho / ValorMaximoX
ey = -ex
TextBox1.Text = ex
TextBox2.Text = ey
TextBox3.Text = ValorMaximoX
TextBox4.Text = ValorMaximoY
rUnidadX = ex
UnidadX = 1
While rUnidadX > 1000
rUnidadX = rUnidadX / 10
UnidadX = UnidadX / 10
End While
While rUnidadX < 10
rUnidadX = rUnidadX * 10
UnidadX = UnidadX * 10
End While
Unidady = UnidadX
TextBox5.Text = UnidadX
TextBox6.Text = Unidady
End Sub
Private Sub MnuGraficar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuGraficar.Click
Dim fila1 As Single
Dim col1 As Single
ex = TextBox1.Text
ey = TextBox2.Text
UnidadX = TextBox5.Text
UnidadY = TextBox6.Text
Borrar(sender, e)
' graficar la escala de x
Dim MiFuente As New Font("Arial", 10, FontStyle.Bold)
Dim Penciles(3) As Color
Dim Brocha As SolidBrush = New SolidBrush(Color.LightGreen)
pen = New Pen(Color.Blue, 2)
Penciles(0) = Color.FromArgb(255, 0, 0)
Cx = paso
Cy = alto
Try
Grafico.DrawLine(pen, Cx, 0, Cx, Cy)
Grafico.DrawLine(pen, Cx, Cy, Cx + ancho, Cy)
Grafico.DrawString("X1", MiFuente, Brushes.Red, ancho - paso, Cy)
Grafico.DrawString("X2", MiFuente, Brushes.Green, Cx - paso, paso)
fila = 0
pen.Color = Penciles(fila)
Brocha.Color = Penciles(fila)
x1 = DataGridView2.Rows(1 + fila).Cells(1).Value
x2 = DataGridView2.Rows(1 + fila).Cells(2).Value
x1a = DataGridView2.Rows(1 + fila).Cells(3).Value
x2a = DataGridView2.Rows(1 + fila).Cells(4).Value
Grafico.DrawLine(pen, Cx + x1 * ex, Cy + x2 * ey, Cx + x1a * ex, Cy + x2a * ey)
Grafico.DrawString("R" & fila + 1, MiFuente, Brocha, Cx + x1 * ex, Cy + x2 * ey)
Next
For col1 = 0 To ValorMaximoX Step UnidadX
Grafico.DrawString(col1, MiFuente, Brushes.Blue, Cx + col1 * ex, Cy)
Next
For fila1 = 0 To ValorMaximoY Step UnidadY
Grafico.DrawString(fila1, MiFuente, Brushes.Blue, Cx - paso, Cy + fila1 * ey)
Next
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Sub MnuResolver_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuResolver.Click
Dim valor As Single
Dim x As Single, y As Single
pen.Color = Color.Red
Dim delta As Single = Zmaximo / 10
Select Case tipofo
Case 1
For valor = 0 To Zmaximo Step dx
x1 = 0
x2 = valor / CJ(1)
x1a = valor / CJ(0)
x2a = 0
resultado = probarlineaMax(x1, x2, x1a, x2a, valor, CJ, B, x, y)
If valor Mod delta = 0 Then
End If
If resultado = 0 Then
ListBox1.Items.Add("X1 " & x)
ListBox1.Items.Add("X2 " & y)
ListBox1.Items.Add("Z " & valor - 1)
Exit Sub
End If
Next
Case 2
For valor = Zmaximo * 10 To 0 Step -dx
x1 = 0
x2 = valor / CJ(1)
x1a = valor / CJ(0)
x2a = 0
resultado = probarlineaMin(x1, x2, x1a, x2a, valor, CJ, B, x, y)
If valor Mod 1 = 0 Then
End If
If resultado = 0 Then
ListBox1.Items.Add("X1 " & x)
ListBox1.Items.Add("X2 " & y)
z = CJ(0) * x + CJ(1) * y
ListBox1.Items.Add("Z " & z)
Exit Sub
End If
Next
End Select
End Sub
Private Sub MnuRellenar_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuRellenar.Click
pen.Color = Color.FromArgb(0, 255, 0)
Dim menor As Single = Zmaximo
Dim fex As Single = (1.0 / ex) * 5
Dim fey As Single = (1.0 / -ey) * 5
Select Case tipofo
Case 1 ' cuando es maximizacion
For yy = 0 To ValorMaximoY Step UnidadX / 10
For xx = 0 To ValorMaximoX Step UnidadY / 10
z = CJ(0) * xx + CJ(1) * yy
menor = Zmaximo
For k = 0 To nrestric - 1
r(k) = B(k) - (xx * M1(k, 0) + yy * M1(k, 1))
If r(k) < menor Then
menor = r(k)
End If
Next
If menor >= 0 Then
Grafico.DrawRectangle(pen, Cx + xx * ex, Cy + yy * ey, 1, 1)
End If
Next xx
Next yy
Case 2 ' cuando es minimizacion

For x2a = 0 To ValorMaximoY Step fex
For x1a = 0 To ValorMaximoX Step fey
z = CJ(0) * x1a + CJ(1) * x2a
menor = Zmaximo
For k = 0 To nrestric - 1
r(k) = (x1a * M1(k, 0) + x2a * M1(k, 1)) - B(k)
If r(k) < menor Then
menor = r(k)
End If
Next
If menor >= 0 Then
Grafico.DrawRectangle(pen, Cx + x1a * ex, Cy + x2a * ey, 1, 1)
End If
Next
Next
End Select
End Sub
Private Sub Borrar(ByVal sender As System.Object, ByVal e As System.EventArgs)

Handles BorrarToolStripMenuItem.Click
End Sub
Private Sub NroDeRestriccionesToolStripMenuItem_Click(ByVal sender As

System.Object, ByVal e As System.EventArgs) Handles
NroDeRestriccionesToolStripMenuItem.Click
nrestric = InputBox("INGRES NRO DE RESTRICCIONES", "nrestric", 2)
End Sub
Private Sub MaximizacionToolStripMenuItem_Click(ByVal sender As System.Object,
ByVal e As System.EventArgs) Handles MaximizacionToolStripMenuItem.Click
tipofo = 1
End Sub
Private Sub MinimizacionToolStripMenuItem_Click(ByVal sender As System.Object,
ByVal e As System.EventArgs) Handles MinimizacionToolStripMenuItem.Click
tipofo = 2
End Sub
Private Sub MnuCero_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles MnuCero.Click
dx = 1
End Sub
Private Sub Mnu1_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles Mnu1.Click
dx = 0.1
End Sub
Private Sub MnuDos_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles MnuDos.Click
dx = 0.01
End Sub
Private Sub mnu3_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles mnu3.Click
dx = 0.001
End Sub
End Class
11.27 GRAFICA DE FUNCIONES EN 2D Y 3D

Module Module1
Public X As Single
Public Y As Single
Public Z As Single
End Structure

Public Gradosx As Single = 0
Public Gradosy As Single = 0
Public Gradosz As Single = 0
Public MP(maxfilas, maxcol) As Puntos
Public MP1(maxfilas, maxcol) As Puntos
Public Cz As Single = 0
Public dx As Single
Public dy As Single
Public Ey As Single = -40
Public GPencil As Integer = 1
Public Indice As Integer = 1
Public k As Integer
Public lix As Single = -5
Public liy As Single = -5
Public lsx As Single = 5
Public lsy As Single = 5
Public Pen As Pen

Public Sub Copiar(MP(,) As Puntos, ByRef MP1(,) As Puntos, nf As Integer, nc As
Integer)
For COL = 0 To nc - 1
MP1(fila, COL).X = MP(fila, COL).X
MP1(fila, COL).Y = MP(fila, COL).Y
MP1(fila, COL).Z = MP(fila, COL).Z
Next
Next
End Sub
Public Sub escalar(Ex As Single, ey As Single, ez As Single)
MP1(fila, COL).X = MP1(fila, COL).X * Ex
MP1(fila, COL).Y = MP1(fila, COL).Y * ey
MP1(fila, COL).Z = MP1(fila, COL).Z * ez
Next
Next
End Sub
Function f(x As Single)
Return x * x
End Function
Function f3d(x As Single, y As Single)
If ((x * x + y * y)) > 0 Then
Return Math.Sin(x * x + y * y) / (x * x + y * y)
Else
Return 1
End If
End Function
End Module
Imports System.IO
Public Class Form1
btnIniciar.Click
DataGridView1.Columns(1).HeaderText = "X (min)"
DataGridView1.Columns(2).HeaderText = "Y (Max)"
DataGridView1.Rows(0).Cells(0).Value = "nc, nf ,D"

DataGridView1.Rows(0).Cells(1).Value = nf
DataGridView1.Rows(0).Cells(2).Value = nc
DataGridView1.Rows(1).Cells(0).Value = "Lim Inferior"

DataGridView1.Rows(1).Cells(1).Value = lix
DataGridView1.Rows(1).Cells(2).Value = liy
DataGridView1.Rows(2).Cells(0).Value = "Lim Superior"

DataGridView1.Rows(2).Cells(1).Value = lsx
DataGridView1.Rows(2).Cells(2).Value = lsy
DataGridView1.Rows(3).Cells(0).Value = "Cx Cy,Cz"

DataGridView1.Rows(3).Cells(3).Value = Cz
DataGridView1.Rows(4).Cells(0).Value = "Ex Ey Ez"

DataGridView1.Rows(5).Cells(0).Value = "Rot Ax Ay Az"

DataGridView1.Rows(5).Cells(1).Value = Gradosx
DataGridView1.Rows(5).Cells(2).Value = Gradosy
DataGridView1.Rows(5).Cells(3).Value = Gradosz
DataGridView1.Rows(6).Cells(0).Value = "Grosor pencil Modo"

DataGridView1.Rows(6).Cells(1).Value = GPencil
DataGridView1.Rows(6).Cells(2).Value = Indice
DataGridView1.Rows(7).Cells(0).Value = "Dx Dy vel"

DataGridView1.Rows(7).Cells(1).Value = dx
DataGridView1.Rows(7).Cells(2).Value = dy

Next
End Sub
End Sub
Private Sub btnGenerar_Click(sender As Object, e As EventArgs) Handles
btnGenerar.Click
Dim col As Integer
Dim x, y As Single
x = lix
y = f(x)
DataGridView2.Rows(col).Cells(0).Value = x
DataGridView2.Rows(col).Cells(1).Value = y
x = x + dx
Next
End Sub
nc = DataGridView1.Rows(0).Cells(1).Value
nf = DataGridView1.Rows(0).Cells(2).Value
lix = DataGridView1.Rows(1).Cells(1).Value
liy = DataGridView1.Rows(1).Cells(2).Value
lsx = DataGridView1.Rows(2).Cells(1).Value
lsy = DataGridView1.Rows(2).Cells(2).Value
Cx = DataGridView1.Rows(3).Cells(1).Value
Cy = DataGridView1.Rows(3).Cells(2).Value
Cz = DataGridView1.Rows(3).Cells(3).Value
Gradosx = DataGridView1.Rows(5).Cells(1).Value
Gradosy = DataGridView1.Rows(5).Cells(2).Value
Gradosz = DataGridView1.Rows(5).Cells(3).Value
GPencil = DataGridView1.Rows(6).Cells(1).Value
Indice = DataGridView1.Rows(6).Cells(2).Value
dx = (lsx - lix) / nc
dy = (lsy - liy) / nf
dx = DataGridView1.Rows(7).Cells(1).Value
dy = DataGridView1.Rows(7).Cells(2).Value
Next
GenerarGrabar(sender, e)
escalar(Ex, Ey, Ez)
rotar(Gradosx, Gradosy, Gradosz)
grafico3d()
End Sub
btnGraficar.Click
Pen.Width = GPencil
With DataGridView2
x1 = CSng(.Rows(col).Cells(0).Value)
y1 = CSng(.Rows(col).Cells(1).Value)
x2 = CSng(.Rows(col + 1).Cells(0).Value)
y2 = CSng(.Rows(col + 1).Cells(1).Value)
Grafico.DrawLine(Pen, Cx + x1 * Ex, Cy + y1 * Ey, Cx + x2 * Ex, Cy + y2 * Ey)
Next
End With
End Sub
BtnBorrar.Click
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles

btnCoordenadas.Click
Pen.Color = Color.Blue
Grafico.DrawLine(Pen, 0, Cy, PictureBox1.Width, Cy)
Grafico.DrawLine(Pen, Cx, 0, Cx, PictureBox1.Height)
End Sub
Sub grafico3d()
Dim Color1 As Integer
Single
As Single
Dim R As Single
Dim Pe As Single
Dim x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4 As Single
Dim px1, py1, px2, py2, px3, py3, px4, py4 As Single
Dim Puntos(3) As Point
x1 = MP1(fila, col).X
y1 = MP1(fila, col).Y
z1 = MP1(fila, col).Z
x2 = MP1(fila, col + 1).X
y2 = MP1(fila, col + 1).Y
z2 = MP1(fila, col + 1).Z
x3 = MP1(fila + 1, col + 1).X

y3 = MP1(fila + 1, col + 1).Y
z3 = MP1(fila + 1, col + 1).Z
x4 = MP1(fila + 1, col).X
y4 = MP1(fila + 1, col).Y
z4 = MP1(fila + 1, col).Z
'*******************
px1 = Cx + (x1 * D) / (D + z1)
py1 = Cy + (y1 * D) / (D + z1)
px2 = Cx + (x2 * D) / (D + z2)

py2 = Cy + (y2 * D) / (D + z2)
px3 = Cx + (x3 * D) / (D + z3)
py3 = Cy + (y3 * D) / (D + z3)
px4 = Cx + (x4 * D) / (D + z4)

py4 = Cy + (y4 * D) / (D + z4)
Puntos(0).X = px1
Puntos(0).Y = py1
Puntos(1).X = px2
Puntos(1).Y = py2
Puntos(2).X = px3
Puntos(2).Y = py3
Puntos(3).X = px4
Puntos(3).Y = py4
' ***************************
AX = x2 - x1
Ay = y2 - y1
Az = z2 - z1
Bx = x3 - x2
By = y3 - y2
Bz = z3 - z2
'PRODUCTO(CRUZ)
If R > 0 Then
Nx1 = NX / R
Else
Nx1 = 1000
End If
If R > 0 Then
Ny1 = Ny / R
Else
Ny1 = 1000
End If
If R > 0 Then
Nz1 = Nz / R
Else
Nz1 = 1000
End If
Pe = Nx1 * 0 + Ny1 * 0 + Nz1 * D
Grafico.DrawPolygon(Pen, Puntos)
If modo = 1 Then
If Nz1 <= 0 Then
Color1 = -Nz1 * 255
brocha.Color = Color.FromArgb(0, Color1, 0)
End If
End If
Next
Next
End Sub
Private Sub btnGrafica3D_Click(sender As Object, e As EventArgs) Handles
btnGrafica3D.Click
grafico3d()
End Sub
Private Sub GenerarGrabar(sender As Object, e As EventArgs) Handles
btnGenerarGrabar.Click
Dim x, y, z1 As Single
Pen.Width = GPencil
cont = 0
'generamos los puntos
y = liy
x = lix
z1 = f3d(x, y)
MP(fila, col).nro = cont
MP(fila, col).X = x
MP(fila, col).Y = y
MP(fila, col).Z = z1
x = x + dx
cont = cont + 1
Next
y = y + dy
Next
np = cont
archivo = New StreamWriter("E:\datos\Mp20x20.txt")
' grabamos los puntos de la matriz y mostramos
archivo.Write("{0}{1}", MP(fila, col).Z, Chr(9))
Next
archivo.WriteLine()
Next
archivo.Close()
Copiar(MP, MP1, nf, nc)
End Sub
Sub rotar(gradosx As Single, gradosy As Single, gradosz As Single)

Dim col As Integer = 0
Dim Ax, Ay, Az As Single
' rotacion x
Ax = gradosx * Math.PI / 180
x2 = x1
y2 = y1 * Math.Cos(Ax) - z1 * Math.Sin(Ax)
z2 = y1 * Math.Sin(Ax) + z1 * Math.Cos(Ax)
MP1(fila, col).X = x2
MP1(fila, col).Y = y2
MP1(fila, col).Z = z2
Next
Next
' rotacion y
Ay = gradosy * Math.PI / 180
' rotacion y
x2 = x1 * Math.Cos(Ay) + z1 * Math.Sin(Ay)
y2 = y1
z2 = -x1 * Math.Sin(Ay) + z1 * Math.Cos(Ay)
Next
Next
' rotacion z
Az = gradosz * Math.PI / 180
x2 = x1 * Math.Cos(Az) - y1 * Math.Sin(Az)
y2 = x1 * Math.Sin(Az) + y1 * Math.Cos(Az)
z2 = z1
Next
Next
End Sub
Private Sub btnVerDatos_Click(sender As Object, e As EventArgs) Handles
btnVerosDatos.Click
Form2.DataGridView1.ColumnCount = nc + 1
Form2.DataGridView1.RowCount = nf + 1
For col = 0 To nc
Form2.DataGridView1.Columns(col).Width = 70
Next
Form2.DataGridView1.Rows(fila).Cells(col).Value = MP1(fila, col).Z
Next
Next
Form2.Show()
End Sub
Private Sub TextBox1_KeyDown_1(sender As Object, e As KeyEventArgs) Handles
TextBox1.KeyDown
Case Keys.Left
Gradosx = Gradosx - 1
Case Keys.Right
Gradosx = Gradosx + 1
Case Keys.Up
Gradosy = Gradosy - 1
Case Keys.Down
Gradosy = Gradosy + 1
Case 90 'Z
Gradosz = Gradosz + 1
Case 87 'W
Gradosz = Gradosz - 1
End Select
TextBox1.Text = ""
End Sub
End Class
11.28 GENERACION DE MONTAÑAS CON AUTOMATAS CELULARES(corregir)

CODIGO DEL MODULO
Imports System.IO
Module Module1
Public X As Single
Public Y As Single
Public Z As Single
End Structure
Public Nvecinos1 As Integer = 3
Public altura As Single = 10
Public niter As Integer = 100
Public Vinicial As Single = 0
Public vargx As Single = 0
Public vargy As Single = 0
Public vargz As Single = 0
Public aumento As Single = 10
Public Gradosx As Single = 0
Public Gradosy As Single = 0
Public Gradosz As Single = 0
Public MP(maxfilas, maxcol) As Puntos
Public MP1(maxfilas, maxcol) As Puntos
Public Cz As Single = 0
Public dx As Single
Public dy As Single
Public Ey As Single = -20
Public GPencil As Integer = 1
Public Indice As Integer = 1
Public lix As Single = -5
Public liy As Single = -5
Public lsx As Single = 5
Public lsy As Single = 5
Public Pen As Pen
Public Sub Copiar(MP(,) As Puntos, ByRef MP1(,) As Puntos, nf As Integer, nc As
Integer)
MP1(fila, COL).X = MP(fila, COL).X
MP1(fila, COL).Y = MP(fila, COL).Y
MP1(fila, COL).Z = MP(fila, COL).Z
Next
Next
End Sub
Public Sub escalar(Ex As Single, ey As Single, ez As Single)
MP1(fila, COL).X = MP1(fila, COL).X * Ex
MP1(fila, COL).Y = MP1(fila, COL).Y * ey
MP1(fila, COL).Z = MP1(fila, COL).Z * ez
Next
Next
End Sub
Sub rotar(gradosx As Single, gradosy As Single, gradosz As Single)

Dim Ax, Ay, Az As Single
' rotacion x
Ax = gradosx * Math.PI / 180
x2 = x1
y2 = y1 * Math.Cos(Ax) - z1 * Math.Sin(Ax)
z2 = y1 * Math.Sin(Ax) + z1 * Math.Cos(Ax)
Next
Next
' rotacion y
Ay = gradosy * Math.PI / 180
' rotacion y
x2 = x1 * Math.Cos(Ay) + z1 * Math.Sin(Ay)
y2 = y1
z2 = -x1 * Math.Sin(Ay) + z1 * Math.Cos(Ay)
Next
Next
' rotacion z
Az = gradosz * Math.PI / 180
x2 = x1 * Math.Cos(Az) - y1 * Math.Sin(Az)
y2 = x1 * Math.Sin(Az) + y1 * Math.Cos(Az)
z2 = z1
Next
Next
End Sub
Sub Iniciar()
Dim x, y, z1 As Single
Pen.Width = GPencil
cont = 0
'generamos los puntos
y = liy
x = lix
REM z1 = f3d(x, y)
MP(fila, col).nro = cont
MP(fila, col).X = x
MP(fila, col).Y = y
MP(fila, col).Z = Vinicial
x = x + dx
cont = cont + 1
Next
y = y + dy
Next
np = cont
Copiar(MP, MP1, nf, nc)
End Sub
Sub grabar()
archivo = New StreamWriter("E:\datos\Mp20x20.txt")
' grabamos los puntos de la matriz y mostramos
archivo.Write("{0}{1}", MP1(fila, col).Z, Chr(9))
Next
archivo.WriteLine()
Next
archivo.Close()
End Sub
End Module
Public Class Form1

btnIniciar.Click
DataGridView1.Columns(1).HeaderText = "X (min)"
DataGridView1.Columns(2).HeaderText = "Y (Max)"
DataGridView1.Rows(0).Cells(0).Value = "nc, nf ,D"

DataGridView1.Rows(1).Cells(0).Value = "Lim Inferior"

DataGridView1.Rows(1).Cells(1).Value = lix
DataGridView1.Rows(1).Cells(2).Value = liy
DataGridView1.Rows(2).Cells(0).Value = "Lim Superior"

DataGridView1.Rows(2).Cells(1).Value = lsx
DataGridView1.Rows(2).Cells(2).Value = lsy
DataGridView1.Rows(3).Cells(0).Value = "Cx Cy,Cz"

DataGridView1.Rows(3).Cells(3).Value = Cz
DataGridView1.Rows(4).Cells(0).Value = "Ex Ey Ez"

DataGridView1.Rows(5).Cells(0).Value = "Rot Ax Ay Az"

DataGridView1.Rows(6).Cells(0).Value = "Grosor pencil Modo"

DataGridView1.Rows(6).Cells(1).Value = GPencil
DataGridView1.Rows(6).Cells(2).Value = Indice
DataGridView1.Rows(7).Cells(0).Value = "Dx Dy vel"

DataGridView1.Rows(8).Cells(0).Value = "Niter, Vinicial aumento"

DataGridView1.Rows(8).Cells(1).Value = niter
DataGridView1.Rows(8).Cells(2).Value = Vinicial
DataGridView1.Rows(8).Cells(3).Value = aumento
DataGridView1.Rows(9).Cells(0).Value = "Nvecinos"
DataGridView1.Rows(9).Cells(1).Value = Nvecinos1

Next
End Sub
GroupBox1.Visible = True
End Sub
lix = DataGridView1.Rows(1).Cells(1).Value
liy = DataGridView1.Rows(1).Cells(2).Value
lsx = DataGridView1.Rows(2).Cells(1).Value
lsy = DataGridView1.Rows(2).Cells(2).Value
Cz = DataGridView1.Rows(3).Cells(3).Value
Gradosx = DataGridView1.Rows(5).Cells(1).Value
Gradosy = DataGridView1.Rows(5).Cells(2).Value
Gradosz = DataGridView1.Rows(5).Cells(3).Value
GPencil = DataGridView1.Rows(6).Cells(1).Value
Indice = DataGridView1.Rows(6).Cells(2).Value
niter = DataGridView1.Rows(8).Cells(1).Value
Vinicial = DataGridView1.Rows(8).Cells(2).Value
aumento = DataGridView1.Rows(8).Cells(3).Value
Nvecinos1 = DataGridView1.Rows(9).Cells(1).Value
dx = DataGridView1.Rows(7).Cells(1).Value
dy = DataGridView1.Rows(7).Cells(2).Value
Iniciar()
escalar(Ex, Ey, Ez)
rotar(Gradosx, Gradosy, Gradosz)
grafico3d()
verdatos()
End Sub
BtnBorrar.Click
End Sub
Private Sub Coordenadas(sender As Object, e As EventArgs) Handles
Pen.Color = Color.Blue
Grafico.DrawLine(Pen, 0, Cy, PictureBox1.Width, Cy)
Grafico.DrawLine(Pen, Cx, 0, Cx, PictureBox1.Height)
End Sub
Sub grafico3d()
Dim Color1 As Integer
Single
As Single
Dim R As Single
Dim Pe As Single
Dim x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4 As Single
Dim px1, py1, px2, py2, px3, py3, px4, py4 As Single
Dim Puntos(3) As Point
x2 = MP1(fila, col + 1).X
y2 = MP1(fila, col + 1).Y
z2 = MP1(fila, col + 1).Z
x3 = MP1(fila + 1, col + 1).X

y3 = MP1(fila + 1, col + 1).Y
z3 = MP1(fila + 1, col + 1).Z
x4 = MP1(fila + 1, col).X
y4 = MP1(fila + 1, col).Y
z4 = MP1(fila + 1, col).Z
'*******************
px1 = Cx + (x1 * D) / (D + z1)
py1 = Cy + (y1 * D) / (D + z1)
px2 = Cx + (x2 * D) / (D + z2)

py2 = Cy + (y2 * D) / (D + z2)
px3 = Cx + (x3 * D) / (D + z3)
py3 = Cy + (y3 * D) / (D + z3)
px4 = Cx + (x4 * D) / (D + z4)

py4 = Cy + (y4 * D) / (D + z4)
Puntos(0).X = px1
Puntos(0).Y = py1
Puntos(1).X = px2
Puntos(1).Y = py2
Puntos(2).X = px3
Puntos(2).Y = py3
Puntos(3).X = px4
Puntos(3).Y = py4
' ***************************
AX = x2 - x1
Ay = y2 - y1
Az = z2 - z1
Bx = x3 - x2
By = y3 - y2
Bz = z3 - z2
'PRODUCTO(CRUZ)
If R > 0 Then
Nx1 = NX / R
Else
Nx1 = 1000
End If
If R > 0 Then
Ny1 = Ny / R
Else
Ny1 = 1000
End If
If R > 0 Then
Nz1 = Nz / R
Else
Nz1 = 1000
End If
Pe = Nx1 * 0 + Ny1 * 0 + Nz1 * D
Grafico.DrawPolygon(Pen, Puntos)
If modo = 1 Then
If Nz1 <= 0 Then
Color1 = -Nz1 * 255
brocha.Color = Color.FromArgb(0, Color1, 0)
End If
End If
Next
Next
End Sub
Sub verdatos()
DataGridView2.ColumnCount = nc + 1
For col = 0 To nc
DataGridView2.Columns(col).HeaderText = col
Next
Next
DataGridView2.Rows(fila).Cells(col).Value = MP1(fila, col).Z
Next
Next
End Sub
TextBox1.KeyDown
Dim gxa As Single = Gradosx
Dim gya As Single = Gradosy
Dim gza As Single = Gradosz
Case Keys.Left
Gradosx = Gradosx - 1
Case Keys.Right
Gradosx = Gradosx + 1
Case Keys.Up
Gradosy = Gradosy - 1
Case Keys.Down
Gradosy = Gradosy + 1
Case 90 'Z
Gradosz = Gradosz + 1
Case 87 'W
Gradosz = Gradosz - 1
End Select
vargx = Gradosx - gxa
vargy = Gradosy - gya
vargz = Gradosz - gza
rotar(vargx, vargy, vargz)
grafico3d()
TextBox1.Text = ""
End Sub
Function Contavecinos(rcol As Integer, rfila As Integer, valor As Single) As Integer
For fila = rfila - 1 To rfila + 1
For col = rcol - 1 To rcol + 1
If (MP1(fila, col).Z = valor) Then
valor = 1
Exit For
End If
If valor = 1 Then Exit For
Next
Next
Return valor
End Function
Private Sub btnAleatorio_Click(sender As Object, e As EventArgs) Handles
btnAleatorio.Click
Dim rfila, rcol As Integer
Dim Pvecinos As Single = 0
rfila = Nvecinos1 + Int(Rnd() * (nf - Nvecinos1))
rcol = Nvecinos1 + Int(Rnd() * (nc - Nvecinos1))
TextBox2.Text = rcol
TextBox3.Text = rfila
Dim valor1 As Single
MP1(rfila, rcol).Z = MP1(rfila, rcol).Z + aumento
valor1 = aumento / Nvecinos1
cont = 1
For k = Nvecinos1 - 1 To 0 Step -1
For fila = rfila - k To rfila + k
For col = rcol - k To rcol + k
MP1(fila, col).Z = MP1(fila, col).Z + cont * valor1
Next
Next
Next
verdatos()
grafico3d()
End Sub
Private Sub IniciarClick(sender As Object, e As EventArgs) Handles
BtnInicializar.Click
Dim rfila, rcol As Integer
rcol = TextBox2.Text
rfila = TextBox3.Text
MP1(rfila, rcol).Z = altura
verdatos()
End Sub
Private Sub btnProbar_Click(sender As Object, e As EventArgs) Handles
btnProbar.Click
Dim rfila, rcol As Integer, k As Integer
rcol = TextBox2.Text
rfila = TextBox3.Text
cont = 1
Next
Next
Next
verdatos()
grafico3d()
End Sub
Private Sub btnGrabar_Click(sender As Object, e As EventArgs) Handles
btnGrabar.Click
grabar()
End Sub
Private Sub btnAutomatico_Click_1(sender As Object, e As EventArgs) Handles

btnAutomatico.Click
Dim rfila, rcol, m As Integer
For m = 1 To niter
rfila = Nvecinos1 + Int(Rnd() * (nf - Nvecinos1 * 2))
rcol = Nvecinos1 + Int(Rnd() * (nc - Nvecinos1 * 2))
TextBox2.Text = rcol
TextBox3.Text = rfila

cont = 1
Next
Next
Next
Next
verdatos()
grafico3d()
End Sub
End Class
12.28 Prender y Apagar un Foco con Arduino

Se trata de gobernar el Arduino desde Visual Basic 2012.
Creamos dos botones, cuando pulsamos estos botones se apaga o enciende el

LED13 del Arduino.
En Visual Basic 2010, insertamos dos Botones y un SerialPort

- Cambia el puerto COM3 por el puerto que tengas en el Arduino (1, 2, 3 o 4)
Cuando pulsamos el Button1 se enciende el LED13
Cuando pulsamos el Button2 se apaga el LED13
Imports System.IO
Imports System.IO.Ports
Imports System.Threading
Public Class Form1
Shared _continue As Boolean
Shared _serialPort As SerialPort
SerialPort1.Close()
SerialPort1.PortName = "COM12" ' Cambia el Puerto
SerialPort1.BaudRate = 9600
SerialPort1.DataBits = 8
SerialPort1.Parity = Parity.None
SerialPort1.StopBits = StopBits.One
SerialPort1.Handshake = Handshake.None
SerialPort1.Encoding = System.Text.Encoding.Default
End Sub
Private Sub PrenderLed(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles BtnPrender.Click
SerialPort1.Open()
SerialPort1.Write("1")
SerialPort1.Close()
PicFoco.Image = PictureBox1.Image
End Sub
Private Sub ApagarLed(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles BtnApagar.Click
SerialPort1.Open()
SerialPort1.Write("0")
SerialPort1.Close()
PicFoco.Image = PictureBox2.Image
End Sub
End Class
Programa para el Arduino
int ledPin = 13;

void setup() {
Serial.begin(9600);
pinMode(ledPin, OUTPUT);
digitalWrite(ledPin, LOW);
}
void loop(){
while (Serial.available() == 0);
int val = Serial.read() - '0';
if (val == 1) {
Serial.println("LED on");
digitalWrite(ledPin, HIGH);
}
else if (val == 0)
{
Serial.println("LED OFF");
digitalWrite(ledPin, LOW);
}
else
{
//val = val;
}
Serial.println(val);
Serial.flush();
}
11.|11-30 PROCESAMIENTO DE IMAGNES EN VISUAL BASIC 2012

Indicaciones
1. Abra la imagen menor a 500x500 por ejmplo unsa.bmp
2. Dibujar . dibuja la imagen
3. Automatico . rota la imagen
Puede ver todos los efectos que se puede realizar con la imagen
Se puede aumentar y desminuir color
Para ver los cambios de color modifique los valores en

Aplique obtener valores y luego dibujar
Module Module1
Public Az As Single = 0 ' rotacion al rededor del eje z
Public dex As Single = 0.1
Public dey As Single = 0.1
Public drojo As Integer = 10
Public dverde As Integer = 10
Public dazul As Integer
Public tipo As Integer = 0 ' es tipo normal 1.
Public MBN(maxfilas, maxcol) As Byte
Const maxcol As Integer = 550
Const maxfilas As Integer = 400
Public Rojos(maxfilas, maxcol) As Integer
Public Verdes(maxfilas, maxcol) As Integer
Public Azules(maxfilas, maxcol) As Integer
Public imagen As Bitmap
Public nfilas As Integer = 7
Public projo As Single = 1
Public pverde As Single = 1
Public pazul As Single = 1
Public vrojo As Single
Public vverde As Single
Public vazul As Single
End Module

Imports System.IO
Public Class Form1
grafico = PictureBox1.CreateGraphics()
grafico2 = PictureBox2.CreateGraphics()
MnuIniciar_Click(sender, e)
End Sub
Sub procesar(MBN(,) As Byte, nf As Integer, nc As Integer)
Dim rojo, verde, azul, suma As Integer
brocha = New SolidBrush(Color.Aqua)
rojo = Rojos(fila, col)
verde = Verdes(fila, col)
azul = Azules(fila, col)
suma = (rojo + verde + azul) / 3
If suma < 127 Then
suma = 0
MBN(fila, col) = 0
Else
suma = 255
MBN(fila, col) = 1
End If
brocha.Color = Color.FromArgb(suma, suma, suma)
grafico2.FillRectangle(brocha, col * ex, fila * ey, ex, ey)
Next
Next
End Sub
Private Sub AbrirToolStripMenuItem_Click(sender As Object, e As EventArgs)
Handles MnuAbrir.Click
REM nombre = "E:\datos\unsa1.bmp"
imagen = New Bitmap(nombre)
REM grafico.DrawImage(New Bitmap(imagen), 0, 0)
PictureBox1.Load(nombre)
nf = imagen.Height
nc = imagen.Width
Me.Text = "ancho " & nc & " alto " & nf
Rojos(fila, col) = imagen.GetPixel(col, fila).R
Verdes(fila, col) = imagen.GetPixel(col, fila).G
Azules(fila, col) = imagen.GetPixel(col, fila).B
Next
Next
End Sub
Private Sub Salir(sender As Object, e As EventArgs) Handles
SalirToolStripMenuItem.Click
Me.Close()
End
End Sub
Private Sub MnuIniciar_Click(sender As Object, e As EventArgs) Handles
MnuIniciar.Click
DataGridView1.Columns(0).HeaderText = "Propiedad"
DataGridView1.Columns(1).HeaderText = "X (rojo)"
DataGridView1.Columns(2).HeaderText = "Y(verde)"
DataGridView1.Columns(3).HeaderText = "Z(Azul)"
For i = 0 To nfilas - 1
DataGridView1.Rows(i).HeaderCell.Value = i.ToString
Next
DataGridView1.Rows(0).Cells(0).Value = "Tamaño Velocidad"
DataGridView1.Rows(0).Cells(3).Value = velocidad
DataGridView1.Rows(1).Cells(0).Value = "Escala"
DataGridView1.Rows(1).Cells(1).Value = ex
DataGridView1.Rows(1).Cells(2).Value = ey
DataGridView1.Rows(2).Cells(0).Value = "%Color"
DataGridView1.Rows(2).Cells(1).Value = projo
DataGridView1.Rows(2).Cells(2).Value = pverde
DataGridView1.Rows(2).Cells(3).Value = pazul
DataGridView1.Rows(3).Cells(0).Value = "Var Color"
DataGridView1.Rows(3).Cells(1).Value = vrojo
DataGridView1.Rows(3).Cells(2).Value = vverde
DataGridView1.Rows(3).Cells(3).Value = vazul
DataGridView1.Rows(4).Cells(0).Value = "Incremento"
DataGridView1.Rows(4).Cells(1).Value = drojo
DataGridView1.Rows(4).Cells(2).Value = dverde
DataGridView1.Rows(4).Cells(3).Value = dazul
DataGridView1.Rows(5).Cells(0).Value = "CX y Cy"

DataGridView1.Rows(6).Cells(0).Value = "Rotac z"
DataGridView1.Rows(6).Cells(1).Value = Az
End Sub
Private Sub MnuObtenerValores_Click(sender As Object, e As EventArgs) Handles
MnuObtenerValores.Click
velocidad = DataGridView1.Rows(0).Cells(3).Value
ex = DataGridView1.Rows(1).Cells(1).Value
ey = DataGridView1.Rows(1).Cells(2).Value
projo = DataGridView1.Rows(2).Cells(1).Value
pverde = DataGridView1.Rows(2).Cells(2).Value
pazul = DataGridView1.Rows(2).Cells(3).Value
vrojo = DataGridView1.Rows(3).Cells(1).Value
vverde = DataGridView1.Rows(3).Cells(2).Value
vazul = DataGridView1.Rows(3).Cells(3).Value
drojo = DataGridView1.Rows(4).Cells(1).Value
dverde = DataGridView1.Rows(4).Cells(2).Value
dazul = DataGridView1.Rows(4).Cells(3).Value
Az = DataGridView1.Rows(6).Cells(1).Value
End Sub
Private Sub mnuBorrar_Click(sender As Object, e As EventArgs) Handles

mnuBorrar.Click
End Sub
Private Sub mnuInverso_Click(sender As Object, e As EventArgs) Handles
mnuInverso.Click
tipo = 3
Dibujar(tipo)
End Sub
Private Sub mnuEnfoque_Click(sender As Object, e As EventArgs) Handles
mnuEnfoque.Click
tipo = 1
Dibujar(tipo)
End Sub
Private Sub mnuDesenfoque_Click(sender As Object, e As EventArgs) Handles
mnuDesenfoque.Click
tipo = 2
Dibujar(tipo)
End Sub
Private Sub MnuBajoRelieve_Click(sender As Object, e As EventArgs) Handles
MnuBajoRelieve.Click
tipo = 5
Dibujar(tipo)
End Sub
Private Sub mnuGrabarBN_Click(sender As Object, e As EventArgs) Handles
mnuGrabarBN.Click
archivo = New StreamWriter("E:\datos\MBN" & nc & "x" & nf & ".txt")
archivo.Write("{0}{1}", MBN(fila, col), Chr(9))
Next
archivo.WriteLine()
Next
archivo.Close()
End Sub
Private Sub mnuDifusion_Click(sender As Object, e As EventArgs) Handles

mnuDifusion.Click
tipo = 6
Dibujar(tipo)
End Sub
Private Sub mnuAislamiento_Click(sender As Object, e As EventArgs) Handles
mnuAislamiento.Click
tipo = 4
Dibujar(tipo)
End Sub
Private Sub mnuBlancoYNegro_Click(sender As Object, e As EventArgs) Handles
mnuBlancoYNegro.Click
tipo = 8
Dibujar(tipo)
procesar(MBN, nf, nc)
End Sub
Private Sub mnuEscalaGrises_Click(sender As Object, e As EventArgs) Handles

mnuEscalaGrises.Click
tipo = 7
Dibujar(tipo)
End Sub
Private Sub MnuDeteccionBorde_Click(sender As Object, e As EventArgs) Handles
MnuDeteccionBorde.Click
Dim F(3, 3) As Integer
F(0, 0) = 0 : F(0, 1) = 0 : F(0, 2) = 0
F(1, 0) = 1 : F(1, 1) = -2 : F(1, 2) = 1
F(2, 0) = 0 : F(2, 1) = 0 : F(2, 2) = 0
Dim tfiltro As Integer = 3
Dim fila1, col1 As Integer
Dim rojo, verde, azul As Integer
rojo = 0
verde = 0
azul = 0
For fila1 = 0 To tfiltro - 1
For col1 = 0 To tfiltro - 1
rojo = rojo + Rojos(fila + 1 - fila1, col + 1 - col1) * F(fila1, col1)
verde = verde + Verdes(fila + 1 - fila1, col + 1 - col1) * F(fila1, col1)
azul = azul + Azules(fila + 1 - fila1, col + 1 - col1) * F(fila1, col1)
Next
Next
If rojo > 255 Then rojo = 255
If rojo < 0 Then rojo = 0
If verde > 255 Then verde = 255
If verde < 0 Then verde = 0
If azul > 255 Then azul = 255
If azul < 0 Then azul = 0
brocha.Color = Color.FromArgb(rojo, verde, azul)
grafico2.FillRectangle(brocha, col * ex, fila * ey, ex, ey)
Next
Next
End Sub
Sub DibujarNormal()
rojo = Rojos(fila, col) * projo
If (rojo + vrojo >= 0 And rojo + vrojo <= 255) Then
rojo = Rojos(fila, col) * projo + vrojo
Else
If (rojo + vrojo < 0) Then rojo = 0
If (rojo + vrojo > 255) Then rojo = 255
End If
verde = Verdes(fila, col) * pverde
If (verde + vverde >= 0 And verde + vverde <= 255) Then
verde = Verdes(fila, col) * pverde + vverde
Else
If (verde + vverde < 0) Then verde = 0
If (verde + vverde > 255) Then verde = 255
End If
azul = Azules(fila, col) * pverde
If (azul + vazul >= 0 And azul + vazul <= 255) Then
azul = Azules(fila, col) * pazul + vazul
Else
If (azul + vazul < 0) Then azul = 0
If (azul + vazul > 255) Then azul = 255
End If
grafico2.FillRectangle(brocha, Cx + col * ex, Cy + fila * ey, Math.Abs(ex),
Math.Abs(ey))
Next
Next
End Sub
Sub Dibujar(tipo As Integer)

Dim dx As Integer = 1
Dim dy As Integer = 1
Dim suma As Integer = 0
Select Case tipo
Case 1 '
rojo = Rojos(fila, col) + 0.5 * Rojos(fila, col) - Rojos(fila - dx, col - dy)
verde = Verdes(fila, col) + 0.5 * Verdes(fila, col) - Verdes(fila - dx, col - dy)
azul = Azules(fila, col) + 0.5 * Azules(fila, col) - Azules(fila - dx, col - dy)
If rojo > 255 Then rojo = 255
If rojo < 0 Then rojo = 0
If verde > 255 Then verde = 255

If verde < 0 Then verde = 0
If azul > 255 Then azul = 255
If azul < 0 Then azul = 0
Case 2 'desenfoque
rojo = 0
verde = 0
azul = 0
For fila1 = fila - 1 To fila + 1
For col1 = col - 1 To col + 1
rojo = rojo + Rojos(fila1, col1)
verde = verde + Verdes(fila1, col1)
azul = azul + Azules(fila1, col1)
Next
Next
rojo = rojo / 9
verde = verde / 9
azul = azul / 9
Case 3 ' inverso
rojo = 255 - Rojos(fila, col)
verde = 255 - Verdes(fila, col)
azul = 255 - Azules(fila, col)
Case 4 'ailamiento
If ((rojo < 128) Or (rojo > 255)) Then rojo = 255 - rojo
If ((verde < 128) Or (verde > 255)) Then verde = 255 - verde
If ((azul < 128) Or (azul > 255)) Then azul = 255 - azul
Case 5 ' bajo relieve
rojo = Math.Abs(Rojos(fila, col) - Rojos(fila + dx, col + dy) + 128)
verde = Math.Abs(Verdes(fila, col) - Verdes(fila + dx, col + dy) + 128)
azul = Math.Abs(Azules(fila, col) - Azules(fila + dx, col + dy) + 128)
If (rojo > 255) Then rojo = 255
If (verde > 255) Then verde = 255
If (azul > 255) Then azul = 255
Case 6 'difusion
Dim rx, ry As Integer
rx = Rnd() * 4 - 2
ry = Rnd() * 4 - 2
rojo = Rojos(fila + rx, col + ry)
verde = Verdes(fila + rx, col + ry)
azul = Azules(fila + rx, col + ry)
Case 7 ' gris
suma = (rojo + verde + azul) / 3
rojo = suma
verde = suma
azul = suma
End Select
grafico2.FillRectangle(brocha, Cx + col * ex, Cy + fila * ey, Math.Abs(ex),
Math.Abs(ey))
Next
Next
End Sub
Private Sub mnuDibujar_Click(sender As Object, e As EventArgs) Handles
mnuDibujar.Click
DibujarNormal()
End Sub
Private Sub BtnNormal_Click(sender As Object, e As EventArgs) Handles
BtnNormal.Click
tipo = 0
Dibujar(tipo)
End Sub
Private Sub txtVarColor_KeyDown(sender As Object, e As KeyEventArgs) Handles

txtVarColor.KeyDown
Select e.KeyCode
Case 88 'rojo
If vrojo < 255 Then
vrojo = vrojo + drojo
Else
vrojo = 255
End If
Case 65 'rojo
If vrojo > -255 Then
vrojo = vrojo - drojo
Else
vrojo = -255
End If
Case 89 'verde
If vverde < 255 Then
vverde = vverde + dverde
Else
vverde = 255
End If
Case 66 'verde
If vverde > -255 Then
vverde = vverde - dverde
Else
vverde = -255
End If
Case 90 'azul
If vazul < 255 Then
vazul = vazul + dazul
Else
vazul = 255
End If
Case 67 'azul
If vazul > -255 Then
vazul = vazul - dazul
Else
vazul = -255
End If
Case 87 'wbrillo
If vrojo < 255 Then
vrojo = vrojo + 1
Else
vrojo = 255
End If
If vverde < 255 Then
vverde = vverde + 1
Else
vverde = 255
End If
If vazul < 255 Then
vazul = vazul + 1
Else
vazul = 255
End If
Case 68 ' dbrillo
If vrojo > 0 Then
vrojo = vrojo - 1
Else
vrojo = 0
End If
If vverde > 0 Then
vverde = vverde - 1
Else
vverde = 0
End If
If vazul > 0 Then
vazul = vazul - 1
Else
vazul = 0
End If
End Select
DataGridView1.Rows(3).Cells(1).Value = vrojo
DataGridView1.Rows(3).Cells(2).Value = vverde
DataGridView1.Rows(3).Cells(3).Value = vazul
MnuObtenerValores_Click(sender, e)
txtVarColor.Text = ""
DibujarNormal()
End Sub
Private Sub txtEscala_KeyDown(sender As Object, e As KeyEventArgs) Handles
txtEscala.KeyDown
Case 88 'ex
If ex < 10 Then
ex = ex + dex
Else
dex = 10
End If
Case 65 'ex
If ex > -10 Then
ex = ex - dex
Else
ex = -10
End If
Case 89 'ey
If ey < 10 Then
ey = ey + dey
Else
ey = 10
End If
Case 66 'verde
If ey > -10 Then
ey = ey - dey
Else
ey = -10
End If
Case 87 'w incremento simultania
If ex < 10 Then
ex = ex + dex
Else
dex = 10
End If
If ey < 10 Then
ey = ey + dey
Else
ey = 10
End If
Case 68 'Dex
If ex > -10 Then
ex = ex - dex
Else
ex = -10
End If
If ey > -10 Then
ey = ey - dey
Else
ey = -10
End If
End Select
txtVarColor.Text = ""
DibujarNormal()
End Sub
Private Sub BtnAutomatico_Click(sender As Object, e As EventArgs) Handles
BtnAutomatico.Click
End Sub
BtnDetener.Click
End Sub
Private Sub mnuRotar_Click(sender As Object, e As EventArgs) Handles

mnuRotar.Click
Dim fila As Integer
Dim azr As Single
azr = Az * Math.PI / 180
x1 = col
y1 = fila
x2 = x1 * Math.Cos(azr) - y1 * Math.Sin(azr)
y2 = x1 * Math.Sin(azr) + y1 * Math.Cos(azr)
grafico2.FillRectangle(brocha, Cx + x2 * ex, Cy + y2 * ey, Math.Abs(ex),
Math.Abs(ey))
Next
Next
End Sub

If Az < 1000 Then
Az = Az + 1
DataGridView1.Rows(6).Cells(1).Value = Az
mnuRotar_Click(sender, e)
Else
Az = 0
End If
End Sub
End Class
11.34 TRANSFORMACIONES CON BITMAPS

'************* codigo del modulo

Module Module1
Const maxcols As Integer = 500
Const maxfilas As Integer = 500
Public rojos1(maxfilas, maxcols) As Byte
Public verdes1(maxfilas, maxcols) As Integer
Public azules1(maxfilas, maxcols) As Integer
Public rojos2(maxfilas, maxcols) As Integer
Public verdes2(maxfilas, maxcols) As Integer
Public azules2(maxfilas, maxcols) As Integer
Public paso As Single = 0.02
Public Ancho1 As Integer = 333 ' ancho de imagen original
Public Alto1 As Integer = 305 ' alto de imagen original
Public p1 As Single = 0
Public p2 As Single = 1 - p1
Public Nombre As String
Public Bitmap1 As Bitmap
Public rojo, verde, azul As Integer
End Module

Public Class Form1
Sub mezclar()
'Bitmap3 = New Bitmap("E:\FOTOSBMP\gato333x305.bmp")
For fila = 0 To Alto1 - 1
For col = 0 To Ancho1 - 1
rojo = rojos1(col, fila) * p1 + rojos2(col, fila) * p2
verde = verdes1(col, fila) * p1 + verdes2(col, fila) * p2
azul = azules1(col, fila) * p1 + azules2(col, fila) * p2
Color3 = Color.FromArgb(rojo, verde, azul)
Bitmap3.SetPixel(col, fila, Color3)
Next
Next
PictureBox3.Image = Bitmap3
End Sub
Private Sub Btmezclar_Click(sender As Object, e As EventArgs) Handles
Btmezclar.Click
mezclar()
End Sub
Private Sub btnGrafico1_Click(sender As Object, e As EventArgs) Handles
btnGrafico1.Click
Bitmap1 = New Bitmap("E:\FOTOSBMP\gato333x305.bmp")
Ancho1 = Bitmap1.Width
Alto1 = Bitmap1.Height
rojos1(col, fila) = Bitmap1.GetPixel(col, fila).R
verdes1(col, fila) = Bitmap1.GetPixel(col, fila).G
azules1(col, fila) = Bitmap1.GetPixel(col, fila).B
Next
Next
DataGridView1.Rows(1).Cells(1).Value = Ancho1
DataGridView1.Rows(1).Cells(2).Value = Alto1
grafico1.DrawImage(Bitmap1, 0, 0)
End Sub
Private Sub BtnGrafico2_Click(sender As Object, e As EventArgs) Handles

BtnGrafico2.Click
Bitmap2 = New Bitmap("E:\FOTOSBMP\perrita333X304.bmp")
rojos2(col, fila) = Bitmap2.GetPixel(col, fila).R
verdes2(col, fila) = Bitmap2.GetPixel(col, fila).G
azules2(col, fila) = Bitmap2.GetPixel(col, fila).B
Next
Next
grafico2.DrawImage(Bitmap2, 0, 0)
End Sub
BtnIniciar.Click
DataGridView1.Columns(1).HeaderText = "Valor 1"
DataGridView1.Columns(2).HeaderText = "Valor 2"
Next
DataGridView1.Rows(0).Cells(0).Value = "%p1 p2 "
DataGridView1.Rows(0).Cells(1).Value = p1
p2 = 1 - p1
DataGridView1.Rows(1).Cells(0).Value = "Ancho1 Alto1 "

DataGridView1.Rows(4).Cells(0).Value = "velocidad paso"
DataGridView1.Rows(4).Cells(1).Value = velocidad
DataGridView1.Rows(4).Cells(2).Value = paso
End Sub
PictureBox1.Width = Ancho1
PictureBox1.Height = Alto1
grafico1 = PictureBox1.CreateGraphics
Bitmap2 = New Bitmap("E:\FOTOSBMP\perrita333X304.bmp")
End Sub
Private Sub BtnValores_Click(sender As Object, e As EventArgs) Handles
BtnValores.Click
p1 = DataGridView1.Rows(0).Cells(1).Value
p2 = 1 - p1
Ancho1 = DataGridView1.Rows(1).Cells(1).Value
Alto1 = DataGridView1.Rows(1).Cells(2).Value
velocidad = DataGridView1.Rows(4).Cells(1).Value
paso = DataGridView1.Rows(4).Cells(2).Value
End Sub
Private Sub btnauto_Click(sender As Object, e As EventArgs) Handles btnauto.Click

End Sub

BtnDetener.Click
End Sub

If p1 < (1 - paso) Then
p1 = p1 + paso
Else
p1 = 0
End If
p2 = 1 - p1
' Btmezclar_Click(sender, e)
mezclar()
End Sub
End Class
11.34 JUEGO DE LA SERPIENTE O GUSANO(USO DE AUTOMATAS

CELULARES)
Mover un ser con las teclas direccionales y en forma automática
' ******** codigo del modulo

Module Module1
Public lapiz As Pen
Public x As Integer = 10
Public y As Integer = 5
Public ne, i As Integer
Public VX(maxcol) As Integer
Public VY(maxcol) As Integer
Public ancho As Integer
Public alto As Integer
End Module
' *** codigo del formulario

Public Class Form1
Function Encontrado(VX() As Integer, VY() As Integer, cx As Integer, cy As Integer,
ne As Integer)
Dim col As Integer
If cx = VX(col) And cy = VY(col) Then
valor = 1
Exit For
End If
Next
Return valor ' si es 1
End Function
Sub MostrarSer(s As String, VX() As Integer, VY() As Integer, nelem As Integer)

For col = 0 To nelem - 1
Select Case s(col)
Case "A" : brocha.Color = Drawing.Color.FromArgb(255, 0, 0) 'rojo
Case "B" : brocha.Color = Drawing.Color.FromArgb(0, 255, 0) ' verde
Case "C" : brocha.Color = Drawing.Color.FromArgb(0, 0, 255) ' "azul"
Case "D" : brocha.Color = Drawing.Color.FromArgb(255, 255, 0) ' "amarillo
Case "E" : brocha.Color = Drawing.Color.FromArgb(255, 0, 255) '"violeta
Case "F" : brocha.Color = Drawing.Color.FromArgb(0, 255, 255) '" celeste
Case "G" : brocha.Color = Drawing.Color.FromArgb(255, 255, 255) '" blanco
Case "H" : brocha.Color = Drawing.Color.FromArgb(150, 150, 150) ' gris
Case "I" : brocha.Color = Drawing.Color.FromArgb(200, 100, 50) 'ladrillo
End Select
grafico.FillRectangle(brocha, VX(col) * ex, VY(col) * ey, ex, ey)
Next
End Sub
Sub Listar(s As String, VX() As Integer, VY() As Integer, nelem As Integer)
Dim col As Integer
For col = 0 To nelem - 1
ListBox1.Items.Add(col & " X " & VX(col) & "Y " & VY(col) & " s " & s(col))
Next
End Sub

btnIniciar.Click
cadena = "ABCDEFGHI"
ne = Len(cadena)
For i = 0 To ne - 1
VX(i) = 10 - i
VY(i) = 5
Next
x2 = ancho / ex - 1
y2 = alto / ey - 1
MostrarSer(cadena, VX, VY, ne)
Listar(cadena, VX, VY, ne)
End Sub

lapiz = New Pen(Brushes.Red)
ancho = PictureBox1.Width
alto = PictureBox1.Height
End Sub
Private Sub TextBox1_KeyDown(sender As Object, e As KeyEventArgs) Handles

TextBox1.KeyDown
Dim control As Integer = 0
Case Keys.Down
If y < y2 And Encontrado(VX, VY, x, y + 1, ne) = 0 Then
y=y+1
control = 1
End If
Case Keys.Up
If y > y1 And Encontrado(VX, VY, x, y - 1, ne) = 0 Then
y=y-1
control = 1
End If
Case Keys.Right
If x < x2 And Encontrado(VX, VY, x + 1, y, ne) = 0 Then
x=x+1
control = 1
End If
Case Keys.Left
If x > x1 And Encontrado(VX, VY, x - 1, y, ne) = 0 Then
x=x-1
control = 1
End If
End Select
REM modificar el vector solo si es factible
If control = 1 Then
For i = ne - 1 To 1 Step -1
VX(i) = VX(i - 1)
VY(i) = VY(i - 1)
Next
VX(0) = x
VY(0) = y
End If
End Sub
Private Sub BtnAuto_Click(sender As Object, e As EventArgs) Handles BtnAuto.Click
End Sub

BtnDetener.Click
End Sub
Private Sub btnAleatorio_Click(sender As Object, e As EventArgs) Handles
btnAleatorio.Click
Dim control As Integer = 0
Dim nroA As Integer
Randomize()
nroA = Int(Rnd() * 4)
Select Case nroA
Case 0
If y < y2 And Encontrado(VX, VY, x, y + 1, ne) = 0 Then
y=y+1
control = 1
End If
Case 1
If y > y1 And Encontrado(VX, VY, x, y - 1, ne) = 0 Then
y=y-1
control = 1
End If
Case 2
If x < x2 And Encontrado(VX, VY, x + 1, y, ne) = 0 Then
x=x+1
control = 1
End If
Case 3
If x > x1 And Encontrado(VX, VY, x - 1, y, ne) = 0 Then
x=x-1
control = 1
End If
End Select
If Encontrado(VX, VY, x, y, ne) = 1 Then control = 0 ' si encuentra entonces no
modifica
REM modificar el vector solo si es factible
If control = 1 Then
For i = ne - 1 To 1 Step -1
VX(i) = VX(i - 1)
VY(i) = VY(i - 1)
Next
VX(0) = x
VY(0) = y
End If
End Sub
btnAleatorio_Click(sender, e)
End Sub
End Class
11.35 TRABAJO CON BITMAPS . la siguiente aplicación permite ampliar y reducir

una imagen y también navegar con las teclas direccionales y con el evento mouse
down
'*** codigo del modulo

Module Module1
Public Ancho2 As Integer = 200 ' ancho de imagen reducida
Public Alto2 As Integer = 200 ' alto de imagen reducidad
Public Ancho3 As Integer = 600 ' ancho de imagen agrandada
Public Alto3 As Integer = 600 ' alto de imagen agrandada
Public Cxf As Integer = 0
Public Cyf As Integer = 0
Public Anchof As Integer = 100
Public Altof As Integer = 100
Public Anchod2 As Integer = 50
Public Altod2 As Integer = 50
Public Anchod3 As Integer = 200
Public Altod3 As Integer = 200

Public Cx1 As Integer = 0
Public Cy1 As Integer = 0
Public ex2 As Single
Public ey2 As Single
Public ex3 As Single
Public ey3 As Single
Public myBitmap As Bitmap
Public Rectangle1 As Rectangle
Public sourceRectangle As Rectangle
Public destRectangle2 As Rectangle
Public destRectangle3 As Rectangle
End Module
Public Class Form1

BtnIniciar.Click
DataGridView1.Columns(1).HeaderText = "Valor X"
DataGridView1.Columns(2).HeaderText = "Valor Y"
Next
DataGridView1.Rows(0).Cells(0).Value = "Fuente Cx1,Cy1 "
DataGridView1.Rows(0).Cells(1).Value = Cxf
DataGridView1.Rows(0).Cells(2).Value = Cyf
DataGridView1.Rows(1).Cells(0).Value = "Fuente Ancho1 Alto1 "
DataGridView1.Rows(1).Cells(1).Value = Anchof
DataGridView1.Rows(1).Cells(2).Value = Altof
DataGridView1.Rows(2).Cells(0).Value = "Destino1 Cx2,Cy2 "

DataGridView1.Rows(2).Cells(1).Value = Cx2
DataGridView1.Rows(2).Cells(2).Value = Cy2
DataGridView1.Rows(3).Cells(0).Value = "Destino 2 Ancho2 Alto2 "
DataGridView1.Rows(3).Cells(1).Value = Anchod2
DataGridView1.Rows(3).Cells(2).Value = Altod2
DataGridView1.Rows(4).Cells(0).Value = "Destino3 Cx3,Cy3 "
DataGridView1.Rows(5).Cells(0).Value = "Destino 3 Ancho3 Alto3 "
End Sub
Private Sub btnModificarBitmap_Click(sender As Object, e As EventArgs) Handles
btnModificarBitmap.Click
Anchod2 = Anchof * ex2
Altod2 = Altof * ey2
sourceRectangle = New Rectangle(Cxf, Cyf, Anchof, Altof)
destRectangle2 = New Rectangle(0, 0, Ancho2, Alto2)
grafico1.DrawImage(myBitmap, 0, 0)
grafico2.DrawImage(myBitmap, destRectangle2, Rectangle1, GraphicsUnit.Pixel)
grafico3.DrawImage(myBitmap, destRectangle3, sourceRectangle,
GraphicsUnit.Pixel)
Cx2 = Cxf * ex2
Cy2 = Cyf * ey2
grafico1.DrawRectangle(Pens.Yellow, Cxf, Cyf, Anchof, Altof)
grafico2.DrawRectangle(Pens.Yellow, Cx2, Cy2, Anchod2, Altod2)
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles btnAbrir.Click

myBitmap = New Bitmap(nombre)
' myBitmap = New Bitmap("E:\FOTOSBMP\Partido200x200.bmp")
Ancho1 = myBitmap.Width
Alto1 = myBitmap.Height
ex2 = Ancho2 / Ancho1
ey2 = Alto2 / Alto1
ex3 = Ancho3 / Ancho1
ey3 = Alto3 / Alto1
Anchod2 = Anchof * ex2
Altod2 = Altof * ey2
sourceRectangle = New Rectangle(Cxf, Cyf, Anchof, Altof)
Rectangle1 = New Rectangle(0, 0, Ancho1, Alto1)
grafico1.DrawImage(myBitmap, 0, 0)
grafico2.DrawImage(myBitmap, destRectangle2, Rectangle1, GraphicsUnit.Pixel)
grafico3.DrawImage(myBitmap, destRectangle3, sourceRectangle,
GraphicsUnit.Pixel)
Cx2 = Cxf * ex2
Cy2 = Cyf * ey2
grafico1.DrawRectangle(Pens.Yellow, Cxf, Cyf, Anchof, Altof)
grafico2.DrawRectangle(Pens.Yellow, Cx2, Cy2, Anchod2, Altod2)
End Sub
Private Sub btnObtenerValores_Click(sender As Object, e As EventArgs) Handles
btnObtenerValores.Click
Cxf = DataGridView1.Rows(0).Cells(1).Value
Cyf = DataGridView1.Rows(0).Cells(2).Value
Anchof = DataGridView1.Rows(1).Cells(1).Value
Altof = DataGridView1.Rows(1).Cells(2).Value
Cx2 = DataGridView1.Rows(2).Cells(1).Value
Cy2 = DataGridView1.Rows(2).Cells(2).Value
Anchod2 = DataGridView1.Rows(3).Cells(1).Value
Altod2 = DataGridView1.Rows(3).Cells(2).Value
Cx3 = DataGridView1.Rows(4).Cells(1).Value
Cy3 = DataGridView1.Rows(4).Cells(2).Value
Anchod3 = DataGridView1.Rows(5).Cells(1).Value
Altod3 = DataGridView1.Rows(5).Cells(2).Value
End Sub

pincel = New Pen(Brushes.Azure, 2)
brocha = New SolidBrush(Color.AliceBlue)
End Sub
btnBorrar.Click
End Sub
Private Sub txtCxCyF_KeyDown(sender As Object, e As KeyEventArgs) Handles
txtCxCyF.KeyDown
Case Keys.Down
If (Cy2 + Altod2) < Alto2 Then Cy2 = Cy2 + 1
Case Keys.Up
If Cy2 > 0 Then Cy2 = Cy2 - 1
Case Keys.Right
If (Cx2 + Anchod2) < Ancho2 Then Cx2 = Cx2 + 1
Case Keys.Left
If Cx2 > 0 Then Cx2 = Cx2 - 1
End Select
Cxf = Cx2 / ex2
Cyf = Cy2 / ey2
btnModificarBitmap_Click(sender, e)
End Sub
Private Sub txtTamfuente_KeyDown(sender As Object, e As KeyEventArgs) Handles
txtTamfuente.KeyDown
Case Keys.Down
If (Cy2 + Altod2) < Alto2 Then Altod2 = Altod2 + 1
Case Keys.Up
If Altod2 > 0 Then Altod2 = Altod2 - 1
Case Keys.Right
If (Cx2 + Anchod2) < Ancho2 Then Anchod2 = Anchod2 + 1
Case Keys.Left
If Anchod2 > 0 Then Anchod2 = Anchod2 - 1
End Select
Anchof = Anchod2 / ex2
Altof = Altod2 / ey2
DataGridView1.Rows(1).Cells(1).Value = Anchof
DataGridView1.Rows(1).Cells(2).Value = Altof
End Sub

Cx2 = e.X
Cy2 = e.Y
Cxf = Cx2 / ex2
Cyf = Cy2 / ey2
End Sub
End Class
11.35 PROBLEMA DEL BARQUITO EN MODO VISUAL

El barquito pasa por detrás de la sombrilla y por encima de fondo
Option Explicit On
Option Strict On
Imports System.IO
Module module1
Public backColor As Color
Public MyBitmap1 As Bitmap
Public Ancho1 As Integer
Public Alto1 As Integer

Public Velocidad As Integer = 20
End Module
Public Class Form1

End Sub
Sub Dibujar(cx As Integer, cy As Integer)

nombre = "E:\fotosbmp\copiar\mar800x500.bmp"
MyBitmap1 = New Bitmap(nombre)
Ancho1 = MyBitmap1.Width
Alto1 = MyBitmap1.Height
Grafico1.DrawImage(MyBitmap1, 0, 0)
nombre = "E:\fotosbmp\copiar\barco454x160.bmp"
BackColor = MyBitmap2.GetPixel(5, 5)
MyBitmap2.MakeTransparent(BackColor)
Grafico1.DrawImage(MyBitmap2, cx, cy, Ancho2, Alto2)
nombre = "E:\fotosbmp\copiar\SOMBRILLA287X298.bmp"
BackColor = MyBitmap3.GetPixel(5, 5)
MyBitmap3.MakeTransparent(BackColor)
Grafico1.DrawImage(MyBitmap3, Cx2, Cy2, Ancho3, Alto3)
End Sub
Private Sub BTNDIBUJAR_Click(sender As Object, e As EventArgs) Handles
BTNDIBUJAR.Click
Dibujar(Cx, Cy)
End Sub
Private Sub BtnMover_Click(sender As Object, e As EventArgs) Handles
BtnMover.Click
'Grafico1.Clear(Color.Blue)
If Cx < Ancho1 Then
Cx = Cx + 1 ' necesitas una matriz sobrd otra
Else
Cx = 1
End If
Dibujar(Cx, Cy)
End Sub
Timer1.Interval = Velocidad
End Sub

BtnDetener.Click
End Sub
BtnMover_Click(sender, e)
End Sub
Private Sub txtMover_KeyDown(sender As Object, e As KeyEventArgs) Handles

txtMover.KeyDown
Select e.KeyCode
Case Keys.Down
If Cy < Alto1 Then Cy = Cy + 1
Case Keys.Up
If Cy > 1 Then
Cy = Cy - 1
End If
Case Keys.Right
If Cx < Ancho1 Then
Cx = Cx + 1
End If
Case Keys.Left
If Cx > 0 Then
Cx = Cx - 1
End If
End Select
Grafico1.DrawImage(MyBitmap1, 0, 0)
Dibujar(Cx, Cy)
End Sub
End Class
PROGRAMA DE RELLENADO CPN AUTÓMATAS CELULARES MODO CONSOLA
Imports System.IO
Module Module2
Public cont1 As Integer = 0
Public valor1, valor2 As Integer
Public lector As StreamReader
Public contador As Integer = 0
Public NombreArchivo = "E:\DATOS\PUNTOS80.TXT"
Public Maxfilas As Integer = 1000
Public X(Maxfilas) As Integer
Public Y(Maxfilas) As Integer
Public nelem As Integer = 120
Public XX(Maxfilas) As Integer
Public YY(Maxfilas) As Integer
Sub RellenarBorde(cont1 As Integer, X() As Integer, Y() As Integer, nelem As

Integer, px As Integer, py As Integer)
XX(contador) = px
YY(contador) = py
Console.SetCursorPosition(cx + px, cy + py)
Console.Write("{0}", 3)
valor1 = EsPosible(X, Y, nelem, px + 1, py)
valor2 = EsPosible(XX, YY, contador, px + 1, py)
If valor1 = 0 And valor2 = 0 Then
RellenarBorde(cont1 + 1, X, Y, nelem, px + 1, py)
End If
valor1 = EsPosible(X, Y, nelem, px, py - 1)

valor2 = EsPosible(XX, YY, contador, px, py - 1)
RellenarBorde(cont1, X, Y, nelem, px, py - 1)
End If
valor1 = EsPosible(X, Y, nelem, px - 1, py)
valor2 = EsPosible(XX, YY, contador, px - 1, py)
RellenarBorde(cont1, X, Y, nelem, px - 1, py)
End If
valor1 = EsPosible(X, Y, nelem, px, py + 1)
valor2 = EsPosible(XX, YY, contador, px, py + 1)
RellenarBorde(cont1, X, Y, nelem, px, py + 1)
End If
End Sub
Sub mostrarPuntos(X() As Integer, Y() As Integer, ne As Integer)

Dim fila As Integer
Console.WriteLine(" {0} {1} {2} ", fila, X(fila), Y(fila))
Next
End Sub
Sub VerPuntos(cx As Integer, cy As Integer, X() As Integer, Y() As Integer, ne As
Integer)
Dim fila As Integer
Console.SetCursorPosition(cx + X(fila) * ex, cy + Y(fila) * ey)
Console.Write("{0}", 2)
Next
End Sub
Sub RecuperarPuntos(NombreArchivo As String, X() As Integer, Y() As Integer,
ByRef nelem As Integer)
Dim pos As Integer
lector = New StreamReader(NombreArchivo)
contador = 0
cadena = lector.ReadLine
X(contador) = Val(subcadena)
subcadena = Mid(cadena, pos + 1, Len(cadena) - pos)
Y(contador) = Val(subcadena)
Loop
lector.Close()
nelem = contador - 1
Console.WriteLine("puntos recueprados {0}", nelem)
End Sub
Function EsPosible(X() As Integer, Y() As Integer, nelem As Integer, px As Integer,

py As Integer) As Integer
Dim fila As Integer
For fila = 0 To nelem - 1
If X(fila) = px And Y(fila) = py Then
valor = 1
Exit For
End If
Next
Return valor
End Function
End Module
CODIGO DEL MODULO
Module Module1
Sub Main()
RecuperarPuntos(NombreArchivo, X, Y, nelem)
Console.WriteLine(" puntos recuperados")
mostrarPuntos(X, Y, nelem)
Console.Clear()
VerPuntos(cx, cy, X, Y, nelem)
contador = 0
cont1 = 0
RellenarBorde(cont1, X, Y, nelem, 2, 2)
Console.SetCursorPosition(60, 24)
Console.Write("cont {0} ", contador)
Console.ReadLine()
End Sub
End Module
APLICACIÓN DE AUTOMATAS CELULARES
Este programa permite trabajar con bitmaps, rellena una figura , obtiene el borde ,
hace transformaciones de un objeto a otro ( modificar el programa para 3d
CODIGO DEL MODULO 2
Imports System.IO
Module Module2
Public relleno As Integer = 0
Public cont1 As Integer = 0
Public XX(4000) As Integer
Public YY(4000) As Integer
Public txmin As Integer = 0
Public txmax As Integer = 0
Public resn As Integer = 0
Public alfa1 As Single = 1
Public alfa2 As Single = 0
Public Azules(maxfilas, maxcol) As Integer
Public borde1 As Integer = 1
Public lector As StreamReader
Public escritor As StreamWriter
Public Color As Color
Public contador As Integer = 0
Public CX As Integer = 0 ' posicion de la figura
Public CY As Integer = 0 ' posicion de la figura
Public graficodestino As Graphics
Public graficofuente As Graphics
Public ne1 As Integer ' nro de elementos del vector1
Public ne2 As Integer ' nro de elementos del vector 2
Public ne3 As Integer ' dimension del vector conbinado
Public NombreArchivo As String
Public NombreBitmaps As String
Public Pazul As Bitmap
Public Pict1 As Bitmap
Public px As Integer = 10
Public px1 As Integer = 1
Public py As Integer ' centro de la figura
Public py1 As Integer = 1
Public relleno1 As Integer = 2
Public relleno4 As Integer = 4
Public signo As Integer = 1
Public sx As Integer = 0
Public sY As Integer = 0
Public Umbral As Integer = 10
Public varalfa As Single = 0.01
Public X(maximo) As Integer
Public X1(maximo) As Integer
Public Y(maximo) As Integer
Public Y1(maximo) As Integer
End Module
CODIGO DEL MODULO 1
Imports System.IO
Module Module1
Sub EncontrarSer(a(,) As Integer, nf As Integer, nc As Integer, ByRef px As Integer,
ByRef py As Integer, elem As Integer)
If a(fila, col) = elem Then
px = col
py = fila
Exit Sub
End If
Next col
Next fila
End Sub
Private Sub cmdGrabarVector_Click()
Dim fila As Integer
Form1.OpenFileDialog1.ShowDialog()
NombreArchivo = Form1.OpenFileDialog1.FileName
Dim escritor As StreamWriter
escritor = New StreamWriter(nombreArchivo)
For fila = 1 To nelem
escritor.WriteLine(" {0}{1}{2}{4} ", X(fila), vbTab, Y(fila), vbCrLf)
Next
escritor.Close()
End Sub
Function evaluar(X() As Integer, Y() As Integer, ne As Integer, _
px As Integer, py As Integer, camino As Integer, borde1 As Integer) As Integer
Dim valor1 As Integer, valor2 As Integer, valor3 As Integer, col As Integer
Dim suma As Integer
Dim fila1 As Integer, col1 As Integer
valor1 = 1
valor2 = 1
valor3 = 1
If px = 3 And py = 6 Then
px = 3
End If
If (X(col) = px And Y(col) = py) Then
valor1 = 0
Exit For
End If
Next
If Azules(py, px) <> camino Then valor2 = 0
suma = 0
For fila1 = py - 1 To py + 1
For col1 = px - 1 To px + 1
If Azules(fila1, col1) = borde1 Then
suma = suma + 1
End If
Next
Next
If suma < 1 Then valor3 = 0
evaluar = valor1 * valor2 * valor3
End Function
Sub RecuperarPuntos(NombreArchivo As String, X() As Integer, Y() As Integer,
ByRef nelem As Integer)
Dim pos As Integer
lector = New StreamReader(NombreArchivo)
contador = 0
X(contador) = Val(subcadena)
subcadena = Mid(cadena, pos + 1, Len(cadena) - pos)
Y(contador) = Val(subcadena)
Loop
lector.Close()
nelem = contador - 1
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByRef A(,) As Integer, ByVal
inicio = 1
A(fila, col) = CStr(CInt(CSng(Val(subcadena))))
inicio = pos + 1
Next
Next
srLector.Close()
End Sub
Function calcularborde() As Integer
Dim res As Integer
res = 0
Do
res = evaluar(X, Y, contador, px1 + 1, py1, camino, borde1) ' *** derecha
If res = 1 Then
px1 = px1 + 1
X(contador) = px1
Y(contador) = py1
Exit Do
End If
res = evaluar(X, Y, contador, px1, py1 + 1, camino, borde1) '**+ abajo
If res = 1 Then
py1 = py1 + 1
X(contador) = px1
Y(contador) = py1
Exit Do
End If
res = evaluar(X, Y, contador, px1 - 1, py1, camino, borde1) ' Izquierda
If res = 1 Then
px1 = px1 - 1
X(contador) = px1
Y(contador) = py1
Exit Do
End If
res = evaluar(X, Y, contador, px1, py1 - 1, camino, borde1) ' *** arriba
If res = 1 Then
py1 = py1 - 1
X(contador) = px1
Y(contador) = py1
Exit Do
res = 0
Exit Do
End If
Loop While res = 1
calcularborde = res
End Function
Sub GrabarMatriz(NombreArchivo As String, A(,) As Integer, nf As Integer, nc As
Integer)
escritor = New StreamWriter(NombreArchivo)
escritor.Write("{0}{1}", A(fila, col), vbTab)
Next col
escritor.WriteLine()
Next
escritor.Close()
End Sub
Sub Centroide(X() As Integer, Y() As Integer, nelem As Integer, ByRef sx As Integer,
ByRef sy As Integer)
Dim fila As Integer
sx = sx + X(fila)
sy = sy + Y(fila)
Next
sx = sx / nelem
sy = sy / nelem
End Sub
Function EsPosible(X() As Integer, Y() As Integer, nelem As Integer, px As Integer,
py As Integer) As Integer
Dim fila As Integer
If X(fila) = px And Y(fila) = py Then
valor = 1
Exit For
End If
Next
Return valor
End Function
End Module
Imports System.IO
Public Class Form1
Sub Iniciar()
DataGridView1.Columns(0).HeaderText = "Prop"
DataGridView1.Columns(1).HeaderText = "V1"
DataGridView1.Columns(2).HeaderText = "V2"
DataGridView1.Rows(0).Cells(0).Value = "Ancho/alto"
DataGridView1.Rows(1).Cells(0).Value = "alfa"
DataGridView1.Rows(1).Cells(1).Value = alfa1
DataGridView1.Rows(2).Cells(0).Value = "VarAlfa"
DataGridView1.Rows(2).Cells(1).Value = varalfa
DataGridView1.Rows(3).Cells(0).Value = "Npuntos"
DataGridView1.Rows(3).Cells(1).Value = ne1
DataGridView1.Rows(4).Cells(0).Value = "vel/relleno"
DataGridView1.Rows(4).Cells(2).Value = resn
DataGridView1.Rows(5).Cells(0).Value = "Coord Cx,Cy"

DataGridView1.Rows(5).Cells(1).Value = CX
DataGridView1.Rows(5).Cells(2).Value = CY
DataGridView1.Rows(6).Cells(0).Value = "tx min max"

DataGridView1.Rows(6).Cells(1).Value = txmin
DataGridView1.Rows(6).Cells(2).Value = txmax
End Sub
graficofuente = PicFuente.CreateGraphics
graficodestino = PicDestino.CreateGraphics
pincel = New Pen(Brushes.Red, 2)
brocha = New SolidBrush(Drawing.Color.Blue)
PicFuente.Width = ancho
PicFuente.Height = alto
PicDestino.Width = ancho * 4
PicDestino.Height = alto * 4
Iniciar()
End Sub
Sub RellenarMatriz(px As Integer, py As Integer, camino As Integer, relleno As
Integer)
Azules(py, px) = relleno
'cont = cont + 1
If Azules(py, px + 1) = camino Then
Call RellenarMatriz(px + 1, py, camino, relleno)
End If
If Azules(py + 1, px) = camino Then
Call RellenarMatriz(px, py + 1, camino, relleno)
End If
If Azules(py, px - 1) = camino Then
Call RellenarMatriz(px - 1, py, camino, relleno)
End If
If Azules(py - 1, px) = camino Then
Call RellenarMatriz(px, py - 1, camino, relleno)
End If
End Sub
Sub iniciarvector(X() As Integer, ne As Integer, valor As Integer)
Dim fila As Integer
X(fila) = valor
Next
End Sub
Sub RellenarBorde(contador As Integer, X() As Integer, Y() As Integer, nelem As
Integer, px As Integer, py As Integer)
graficodestino.FillRectangle(brocha, CX + px * ex, CY + py * ey, ex, ey)
XX(cont1) = px
YY(cont1) = py
cont1 = cont1 + 1
ListBox1.Items.Add("cont " & cont1 & " px = " & px & " py " & py)
'If (contador >= 200) Then
' ListarVector(XX, YY, cont1)
'Exit Sub
' End If
If EsPosible(X, Y, nelem, px + 1, py) = 0 And EsPosible(XX, YY, cont1, px + 1, py) = 0
Then
RellenarBorde(contador + 1, X, Y, nelem, px + 1, py)
End If
If EsPosible(X, Y, nelem, px, py - 1) = 0 And EsPosible(XX, YY, cont1, px, py - 1) =
0 Then
RellenarBorde(contador + 1, X, Y, nelem, px, py - 1)
End If
If EsPosible(X, Y, nelem, px - 1, py) = 0 And EsPosible(XX, YY, cont1, px - 1, py) = 0
Then
RellenarBorde(contador + 1, X, Y, nelem, px - 1, py)
End If
If EsPosible(X, Y, nelem, px, py + 1) = 0 And EsPosible(XX, YY, cont1, px, py + 1) =
0 Then
RellenarBorde(contador + 1, X, Y, nelem, px, py + 1)
End If
End Sub
Private Sub MnuBorde_Click(sender As Object, e As EventArgs) Handles
MnuBorde.Click
valor = 0
Do
valor = calcularborde()
If valor = 1 Then
ListBox1.Items.Add("X=" & px1 & "Y=" & py1)
ListBox1.Items.Add("CONT=" & contador)
' graficodestino.DrawRectangle(pincel, col * ex, fila * ey, ex, ey)
graficodestino.FillRectangle(brocha, CX + px1 * ex, CY + py1 * ey, ex, ey)
Else
X(contador) = px1
Y(contador) = py1
nelem = contador + 1
Exit Do
End If
Loop While valor = 1
End Sub
Private Sub MnuCentroide_Click(sender As Object, e As EventArgs) Handles
MnuCentroide.Click
Centroide(X, Y, nelem, sx, sY)
ListBox1.Items.Add("sx" & sx & "Sy " & sY)
brocha.Color = Color.FromArgb(255, 0, 0)
graficodestino.DrawRectangle(pincel, CX + sx * ex, CY + sY * ey, ex, ey)
graficodestino.FillRectangle(brocha, CX + sx * ex, CY + sY * ey, ex, ey)
End Sub
Private Sub GrabarMatrizClick(sender As Object, e As EventArgs) Handles
mnuGrabarMatriz.Click
SaveFileDialog1.ShowDialog()
NombreArchivo = SaveFileDialog1.FileName
' NombreArchivo = "E:\datos\matriz10X10A.TXT"
GrabarMatriz(NombreArchivo, Azules, nf, nc)
End Sub
Private Sub MnuPunto_Click(sender As Object, e As EventArgs) Handles
MnuPunto.Click
CX = DataGridView1.Rows(5).Cells(1).Value
CY = DataGridView1.Rows(5).Cells(2).Value
EncontrarSer(Azules, nf, nc, px, py, camino)
ListBox1.Items.Add("X=" & px & "Y=" & py)
ListBox1.Items.Add("CONT=" & contador)
contador = 0
px1 = px
py1 = py
sx = px
sY = py
X(contador) = px1
Y(contador) = py1
brocha.Color = Drawing.Color.Red
graficodestino.DrawRectangle(pincel, CX + px1 * ex, CY + py1 * ey, ex, ey)
graficodestino.FillRectangle(brocha, CY + px1 * ex, CY + py1 * ey, ex, ey)
contador = 1
End Sub
Private Sub MnuBorrar_Click(sender As Object, e As EventArgs) Handles
MnuBorrar.Click
graficodestino.Clear(Drawing.Color.Aqua)
End Sub
Private Sub MnuRellenar_Click(sender As Object, e As EventArgs) Handles
MnuRellenar.Click
RellenarMatriz(sx, sY, camino, relleno4)
MostrarMatriz(CX, CY)
End Sub
Sub MostrarMatriz(cx As Integer, cy As Integer)
Select Case Azules(fila, col)
Case 0
Case 1
Case 2
Case 3
Case 4
End Select
graficodestino.DrawRectangle(pincel, cx + col * ex, cy + fila * ey, ex, ey)
graficodestino.FillRectangle(brocha, cx + col * ex, cy + fila * ey, ex, ey)
Next
Next
End Sub
Private Sub MnuMostrar_Click(sender As Object, e As EventArgs) Handles
MnuMostrar.Click
Select Case Azules(fila, col)
Case 0
Case 1
Case 2
Case 3
Case 4
End Select
graficodestino.DrawRectangle(pincel, CX + col * ex, CY + fila * ey, ex, ey)
graficodestino.FillRectangle(brocha, CX + col * ex, CY + fila * ey, ex, ey)
Next
Next
End Sub
Private Sub MnuAbrirarchivo_Click(sender As Object, e As EventArgs) Handles
MnuAbrirMatriz.Click
' NombreArchivo = "e:\DATOS\MATRIZ10X10.TXT"
RecuperarMatriz(NombreArchivo, Azules, nf, nc)
End Sub
Private Sub MnuFigura1_Click(sender As Object, e As EventArgs) Handles
MnuFigura1.Click
' NombreArchivo = "E:\DATOS\FIGURA1.TXT"
RecuperarPuntos(NombreArchivo, X1, Y1, ne1)
End Sub
Private Sub MnuFigura2_Click(sender As Object, e As EventArgs) Handles
MnuFigura2.Click
'NombreArchivo = "E:\DATOS\FIGURA2.TXT"
RecuperarPuntos(NombreArchivo, X2, Y2, ne2)
End Sub
Private Sub mnuAbriFigura(sender As Object, e As EventArgs) Handles
mnuAbrir.Click
' abre la figura'
' NombreArchivo = "E:\DATOS\GATO100X100.BMP"
Pict1 = New Bitmap(NombreArchivo)
Pazul = New Bitmap(Pict1.Width, Pict1.Height)
PicFuente.Image = Pict1
nc = Pict1.Width
nf = Pict1.Height
'********** obtener
If Color.B > Umbral Then
Azules(fila, col) = 1
Else
Azules(fila, col) = 0
End If
Next col
Next
End Sub
Sub ListarVector(X() As Integer, Y() As Integer, ne As Integer)
Dim fila As Integer
ListBox1.Items.Add(fila & " X =" & X(fila) & "y=" & Y(fila))
Next fila
End Sub
Private Sub ListarVector(sender As Object, e As EventArgs) Handles
MnuListarVector.Click
ListarVector(X, Y, nelem)
End Sub
Private Sub GrabarVectorClick(sender As Object, e As EventArgs) Handles

MnuGrabarVector.Click
Dim escritor As StreamWriter
escritor = New StreamWriter(NombreArchivo)
Dim fila As Integer
escritor.WriteLine("{0}{1}{2}", X(fila), vbTab, Y(fila))
Next
escritor.Close()
End Sub
Sub BordeFigura(cx As Integer, cy As Integer, X() As Integer, Y() As Integer, nelem
As Integer)
brocha.Color = Drawing.Color.Red
Dim fila As Integer
graficodestino.DrawRectangle(pincel, cx + X(fila) * ex, cy + Y(fila) * ey, ex, ey)
graficodestino.FillRectangle(brocha, cx + X(fila) * ex, cy + Y(fila) * ey, ex, ey)
Next
End Sub
Private Sub MnuMostrarBorde_Click(sender As Object, e As EventArgs) Handles
MnuMostrarBorde.Click
BordeFigura(CX, CY, X, Y, nelem)
End Sub
Private Sub MnuMostrarF1_Click(sender As Object, e As EventArgs) Handles
MnuMostrarF1.Click
BordeFigura(CX, CY, X1, Y1, ne1)
End Sub
Private Sub MnuMostrarf2_Click(sender As Object, e As EventArgs) Handles
MnuMostrarf2.Click
End Sub
Private Sub MnuCombinado(sender As Object, e As EventArgs) Handles
MnuostrarCombinadoToolStripMenuItem.Click
MnuBorrar_Click(sender, e)
Dim fila As Integer
alfa1 = DataGridView1.Rows(1).Cells(1).Value
ne1 = DataGridView1.Rows(3).Cells(1).Value
ne2 = DataGridView1.Rows(3).Cells(2).Value
If ne1 > ne2 Then
For fila = ne2 To ne1
X2(fila) = X2(ne2 - 1)
Y2(fila) = Y2(ne2 - 1)
Next
ne3 = ne1
Else
For fila = ne1 To ne2
X1(fila) = X1(ne1 - 1)
Y1(fila) = Y1(ne1 - 1)
Next
ne3 = ne2
End If
For fila = 0 To ne3 - 1
X3(fila) = X1(fila) * alfa1 + X2(fila) * alfa2
Y3(fila) = Y1(fila) * alfa1 + Y2(fila) * alfa2
Next
X3(ne3) = X3(0)
Y3(ne3) = Y3(0)
ne3 = ne3 + 1
ListarVector(X3, Y3, ne3)
End Sub
Private Sub MnuTransformar_Click(sender As Object, e As EventArgs) Handles

MnuTransformar.Click
If (alfa1) <= 1 And alfa1 >= 0 Then
alfa1 = alfa1 + varalfa * signo
If CX < txmax Then
CX = CX + 1
Else
CX = txmin
End If
DataGridView1.Rows(5).Cells(1).Value = CX
Else
If alfa1 > 1 Then
alfa1 = 1
signo = signo * (-1)
End If
If alfa1 < 0 Then
alfa1 = 0
signo = signo * (-1)
End If
End If
alfa2 = 1 - alfa1
For fila = 0 To ne3 - 1
X3(fila) = X1(fila) * alfa1 + X2(fila) * alfa2
Y3(fila) = Y1(fila) * alfa1 + Y2(fila) * alfa2
Next
If relleno = 1 Then
Centroide(X3, Y3, ne3, sx, sY)
MnuRellenoFigura3_Click(sender, e)
End If
End Sub
Private Sub MnuDetener_Click(sender As Object, e As EventArgs) Handles

MnuDetener.Click
End Sub
MnuTransformar_Click(sender, e)
System.Threading.Thread.Sleep(vel) ' 1 segundo
Application.DoEvents()
End Sub
Private Sub mnuAutomatico_Click(sender As Object, e As EventArgs) Handles
mnuAutomatico.Click
txmin = DataGridView1.Rows(6).Cells(1).Value
txmax = DataGridView1.Rows(6).Cells(2).Value
End Sub
Private Sub mnuSalir_Click(sender As Object, e As EventArgs) Handles

mnuSalir.Click
Me.Close()
End Sub
Private Sub MnuObtner_Click(sender As Object, e As EventArgs) Handles
MnuObtener.Click
varalfa = DataGridView1.Rows(2).Cells(1).Value
ne1 = DataGridView1.Rows(3).Cells(1).Value = ne1
ne2 = DataGridView1.Rows(3).Cells(2).Value = ne2
vel = DataGridView1.Rows(4).Cells(1).Value = vel
txmin = DataGridView1.Rows(6).Cells(1).Value = txmin
txmax = DataGridView1.Rows(6).Cells(2).Value = txmax
End Sub
Private Sub MnuCentroideFigura3_Click(sender As Object, e As EventArgs)

Centroide(X3, Y3, nelem, sx, sY)
graficodestino.DrawRectangle(pincel, CX + sx * ex, CY + sY * ey, ex * 2, ey)
graficodestino.FillRectangle(brocha, CX + sx * ex, CY + sY * ey, ex * 2, ey)
End Sub
Private Sub MnuRellenoFig3_Click(sender As Object, e As EventArgs)
RellenarMatriz(sx, sY, camino, relleno4)
MostrarMatriz(CX, CY)
End Sub
Private Sub MnuCentroideFig3_Click(sender As Object, e As EventArgs) Handles
MnuCentroideFig3.Click
Centroide(X3, Y3, ne3, sx, sY)
graficodestino.DrawRectangle(pincel, CX + sx * ex, CY + sY * ey, ex, ey)
graficodestino.FillRectangle(brocha, CX + sx * ex, CY + sY * ey, ex, ey)
End Sub
Private Sub MnuRellenoFigura3_Click(sender As Object, e As EventArgs) Handles

MnuRellenoFigura3.Click
cont1 = 0
brocha.Color = Drawing.Color.Blue
contador = 0
RellenarBorde(contador, X3, Y3, ne3, sx, sY)
End Sub
Private Sub Rellenar_Click(sender As Object, e As EventArgs) Handles
Rellenar.Click
relleno = 1
End Sub
Private Sub NoRellenar_Click(sender As Object, e As EventArgs) Handles
NoRellenar.Click
relleno = 0
End Sub
End Class
DICCIONARIO TRADUCTOR
Imports System.IO
Module Module1
Public A(25000, 2) As String
Sub LeerArchivo(A(,) As String, ByRef nf As Integer)
Dim srLector As StreamReader = New StreamReader("e:\DATOS\DIC1.txt")
Dim Linea As String
Dim pos As Integer
pos = InStr(1, Linea, Chr(9))
A(cont, 0) = Mid(Linea, 1, pos - 1)
A(cont, 1) = Mid(Linea, pos + 1, Len(Linea))
cont = cont + 1
Loop
nf = cont
End Sub
End Module
CODIGO DEL MODULO FORM
Public Class Form1

Dim Oreg As ListViewItem
Dim nf As Integer
ListView1.View = View.Details
ListView1.FullRowSelect = True
ListView2.FullRowSelect = True
ListView1.Columns.Add("Nro ", 50)
ListView1.Columns.Add("Ingles", 120)
ListView1.Columns.Add("Castellano", 100)
LeerArchivo(A, nf)
TextBox2.Text = nf
For i = 0 To nf - 1
Oreg = New ListViewItem(i)
Oreg.SubItems.Add(A(i, 0))
Oreg.SubItems.Add(A(i, 1))
ListView1.Items.Add(Oreg)
Oreg = Nothing
Next
End Sub
Private Sub btnBuscar_Click(sender As Object, e As EventArgs) Handles

InglesC.Click
ListView2.Clear()
Dim i As Integer
Dim nombreABuscar As String
nombreABuscar = TextBox1.Text
nf = ListView1.Items.Count
Dim largo As Integer
For i = 0 To nf - 1
nombre = ListView1.Items(i).SubItems(1).Text
largo = InStr(nombre, nombreABuscar)
If largo > 0 Then
ListView1.Items(i).Selected = True
Oreg = New ListViewItem(ListView1.Items(i).SubItems(0).Text)
Oreg.SubItems.Add(nombre)
Oreg = Nothing
End If
Next
End Sub
Private Sub CastellanoI_Click(sender As Object, e As EventArgs) Handles

CastellanoI.Click
ListView2.Clear()
Dim i As Integer
Dim nombreABuscar As String
nombreABuscar = TextBox1.Text
nf = ListView1.Items.Count
For i = 0 To nf - 1
largo = InStr(nombre, nombreABuscar)
If largo > 0 Then
Oreg = New ListViewItem(ListView1.Items(i).SubItems(0).Text)
Oreg = Nothing
End If
Next
End Sub
End Class
DICCIONARIO TRADUCTOR EN MODO CONSOLA
Imports System.IO
Module Module1
Public A(25000, 2) As String
Sub LeerArchivo(A(,) As String, ByRef nf As Integer)
Dim srLector As StreamReader = New StreamReader("e:\DATOS\DIC1.txt")
Dim Linea As String
Dim pos As Integer
pos = InStr(1, Linea, Chr(9))
A(cont, 0) = Mid(Linea, 1, pos - 1)
A(cont, 1) = Mid(Linea, pos + 1, Len(Linea))
cont = cont + 1
Loop
nf = cont
End Sub
Sub BuscarInglesCastellano(A(,) As String, Ingles As String, nf As Integer)
Dim i As Integer
For i = 0 To nf - 1
largo = InStr(A(i, 0), Ingles)
If largo > 0 Then
Console.WriteLine(" {0}===> {1} ====>{2}", cont1, A(i, 0), A(i, 1))
cont1 = cont1 + 1
End If
Next
Console.WriteLine("Palabras encontradas{0}", cont1)
End Sub
Sub BuscarCastellanoIngles(A(,) As String, Castellano As String, nf As Integer)
Dim i As Integer
For i = 0 To nf - 1
largo = InStr(A(i, 1), Castellano)
If largo > 0 Then
Console.WriteLine(" {0}===> {1} ====>{2}", cont1, A(i, 1), A(i, 0))
cont1 = cont1 + 1
End If
Next
Console.WriteLine("Palabras encontradas{0}", cont1)
End Sub
CODIGO DEL MODULO PRINCIPAL
Sub Main()
LeerArchivo(A, nf)
Dim opcion As Integer
Dim Ingles, Castellano As String
Do
Console.WriteLine("1. Ingles castellano 2. Castellano Ingles 3.Salir ")
Console.Write("ingrese opcion ")
opcion = Console.ReadLine()
Select Case opcion
Case 1
Console.WriteLine("Ingrese palabra en Inglés ")
Ingles = Console.ReadLine
BuscarInglesCastellano(A, Ingles, nf)
Case 2
Console.WriteLine("Ingrese palabra en Castellano ")
Castellano = Console.ReadLine
BuscarCastellanoIngles(A, Castellano, nf)
End Select
Loop While opcion <> 3
End Sub
End Module
TRADUCTOR MODIFICADO ( usando cuadros de dialogo)
Diseñe el siguiente formulario
Imports System.IO
Public Class Form1
Const Maximo As Integer = 25000
Public A(Maximo) As String
Public B(Maximo) As String
Dim fuente As Font
Dim Color As Color
Dim camino As Path
Dim nterminos As Integer = 2
Dim Texto As String = ""
Private Sub InglesEspañol(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles btnInglesEspañol.Click
Texto = txtFuente.Text
For fila1 = 0 To nterminos - 1
nombre1 = A(fila1) ' INGLES
nombre2 = B(fila1) ' ESPAÑOL
Texto = Replace(Texto, nombre1, nombre2)
Next
txtDestino.Text = Texto
End Sub
Private Sub btnTerminos_Click(ByVal sender As System.Object, ByVal e As

System.EventArgs) Handles btnTerminos.Click
srLector = New StreamReader(OpenFileDialog1.FileName)
subcadena1 = Mid(cadena, 1, pos - 1)
A(cont) = " " & subcadena1 & " " ' español
subcadena2 = Mid(cadena, pos + 1, Len(cadena) - pos)
B(cont) = " " & subcadena2 & " "
cadena = srLector.ReadLine() ' ingles
cont += 1
Loop
'Me.Text = "terminos " & cont
srLector.Close()
nterminos = cont
For i = 0 To nterminos - 1
ListBox1.Items.Add(A(i))
ListBox2.Items.Add(B(i))
Next
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles BtnAbrir.Click
Dim Linea As String
srLector = New StreamReader(OpenFileDialog1.FileName)
Texto = ""
Texto = Texto & Linea & vbCrLf
Loop
txtFuente.Text = Texto
srLector.Close()
End Sub
Private Sub btnInglesEspañol_Click(sender As Object, e As EventArgs) Handles

btnEspañolIngles.Click
Texto = txtFuente.Text
For fila1 = 0 To nterminos - 1
nombre1 = A(fila1) 'INGLES
nombre2 = B(fila1) ' ESPAÑOL
Texto = Replace(Texto, nombre2, nombre1)
Next
txtDestino.Text = Texto
End Sub

btnGrabar.Click
Dim escritor As StreamWriter = New StreamWriter(SaveFileDialog1.FileName)
escritor.WriteLine("{0}", txtDestino.Text)
escritor.Close()
End Sub
Private Sub btnfuente_Click(sender As Object, e As EventArgs) Handles

btnfuente.Click
FontDialog1.ShowDialog()
fuente = FontDialog1.Font
txtFuente.Font = fuente
End Sub
Private Sub btnletra_Click(sender As Object, e As EventArgs) Handles btnletra.Click

COLOR = ColorDialog1.Color
txtFuente.ForeColor = COLOR
End Sub
Private Sub btnfondo_Click(sender As Object, e As EventArgs) Handles

btnfondo.Click
COLOR = ColorDialog1.Color
txtFuente.BackColor = COLOR
End Sub
Private Sub btndirectorio_Click(sender As Object, e As EventArgs) Handles

btndirectorio.Click
FolderBrowserDialog1.ShowDialog()
' camino = FolderBrowserDialog1.SelectedPath
End Sub
End Class
Tarea : modifique la aplicación parar traducir Código de Lenguaje C++ a Código de

Visual Basic
CUADRO CROMATICO
Public Class Form1
Dim Pen As Pen
Dim ancho As Integer = 255
Dim alto As Integer = 255
Dim color1 As Color
Private Sub btnCromatico_Click(sender As Object, e As EventArgs) Handles
btnCromatico.Click
brocha.Color = Color.FromArgb(fila, col, 0)
Grafico.FillRectangle(brocha, fila, col, 1, 1)
Next
Next
End Sub

End Sub
Private Sub BtnColordialog_Click(sender As Object, e As EventArgs) Handles

BtnColordialog.Click
color1 = ColorDialog1.Color
Panel1.BackColor = color1
End Sub

Dim cx, cy As Integer
cx = e.X
cy = e.Y
Label1.Text = "X= " & cx & " Y = " & cy
Panel1.BackColor = Color.FromArgb(cx, cy, 0)
End Sub
End Class
Tarea.- Elaborar Gama de colores o circulo cromático(use el triangulo para cad

color)( Estufiar el cuadro cromaico
REDES NEURONALES BACKPROPAGACION .
Problema 2
• El diagrama de la red multicapa se muestra en la figura 1. La red tiene 3 capas

una capa de entrada con una neurona, una capa oculta con dos neuronas y una
capa de salida con 1 neurona
• La función de transferencia en la primera capa es la función tangente Sigmoida
Hiperbólica (Ec. 1).
• Y la función de transferencia en la segunda capa (capa de salida ) es la función
lineal ( Ec. 3)
•
Los valores de entrada son
PUNTO X Y
0 -3.00 0.00
1 -2.00 5.00
2 -1.00 8.00
3 0.00 9.00
4 1.00 8.00
5 2.00 5.00
6 3.00 0.00
Alfa=0.1
1- Determine la función de salida obtenida para la entrada -3 ( explicar) (3 puntos)
2- Propague el error hacia atrás y calcule los nuevos pesos ( 3 puntos)
3- Elabore un programa en visual Basic modo ocnsola o formulario , o lenguaje c (
3 puntos)
EN PROGRAMACION VISUAL
Imports System.IO
Module Module1
Public Const limdatos As Integer = 10
Public nombreErrores As String = "e:\datos\errores.txt"

Public nombreEntrenamiento As String = "e:\datos\entrena.txt"
Public w1(limite) As Single ' matriz de pesos en la capa 1
Public x(limdatos) As Single ' entradas a la red
Public y(limdatos) As Single ' salidas deseadas de la red
Public ndatos As Integer = 7 ' nro de entradas y salidas
Public ne1 As Integer = 2 REM neuronas en la etapa 1
Public alfa As Single = 0.1
Public a1(limite) As Single ' salida de la capa 1
Public a2 As Single ' salida de la capa 2
Public b1(limite) As Single ' vector de segos capa 1
Public s1(limite) As Single ' vector de errores de capa 1
Public ya2(limdatos) As Single ' vector de salida obtenida
Public entrada As Single = -2
Public SalidaDeseada As Single = 1
Public sumacuadratica As Single
Public nveces As Integer = 58
Public errorsalida As Single
Public prono As Single = 3
Public Ventrena(1000) As Single ' graba la desinuci
Sub Iniciar()
w1(0) = 1
w1(1) = 2
w1(2) = 8
w2(0) = 5
w2(1) = 6
w2(2) = 10
b1(0) = 3
b1(1) = 4
b1(2) = 9
b2(0) = 7
b2(1) = 0
x(1) = -3 : y(1) = 0
x(2) = -2 : y(2) = 5
x(3) = -1 : y(3) = 8
x(4) = 0 : y(4) = 9
x(5) = 1 : y(5) = 8
x(6) = 2 : y(6) = 5
x(7) = 3 : y(7) = 0
alfa = 0.1
End Sub
Sub GrabarVector(A() As Single, nf As Integer, nombre As String)
Dim escritor As New StreamWriter(nombre)
Dim i As Integer
For i = 0 To nf - 1
escritor.WriteLine(" suma {0} {1}= {2}", i, vbTab, A(i))
Next
escritor.Close()
End Sub
Sub Mostrar(A() As Single, nf As Integer)
Dim i As Integer
For i = 0 To nf - 1
cadena = cadena + " " + A(i).ToString
Next
Form1.ListBox1.Items.Add(cadena)
End Sub
Sub sigmoidea(A() As Single, nf As Single)
Dim i As Integer
Dim valor As Single
For i = 0 To nf - 1
valor = (Math.Exp(A(i)) - Math.Exp(-A(i))) / (Math.Exp(A(i)) + Math.Exp(-A(i)))
A(i) = valor
Next
End Sub
Function Probar(entrada As Single, salida As Single) As Single
' funcion suma
For i = 0 To ne1 - 1
a1(i) = a1(i) + entrada * w1(i) + b1(i)
Next i
Form1.ListBox1.Items.Add(" la suma es ")
Mostrar(a1, ne1)
' calcular la funcion de salida
sigmoidea(a1, ne1)
Form1.ListBox1.Items.Add(" salida de capa 1 a1 ")
Mostrar(a1, ne1)
'salida de la red
a2 = 0
a2 = a2 + a1(i) * w2(i)
Next i
a2 = a2 + b2(0)
Form1.ListBox1.Items.Add(" salida de capa 2 " & a2)
Return a2
End Function
End Module
EVALUACION DE EXPRESIONES
'***CODIGO DEL MODULO 1
Module Module1
Public EvalRes As Boolean ' Resultado de la evaluacion
Public CadA, CadB, CadC, CadD, CadE, CadX As String
Public CadenaEcuacion As String
Public Cadena As String = "XXXX"
Public VSignos As String = "^*/"
Public CadSigno As String = ""
Public CadenaExpresion As String
Public CadNumeros As String = "0123456789.+-*/^() "
Public suma As Single
Public ck As Single = 0.279
' **************
Public x1 As Single = 1
Public Li As Single = -5
Public Ls As Single = 5
Public Dx As Single = 1
Public Ndiv As Integer = 10
Public A As Single = 0
Public B As Single = 0
Public C As Single = 1
Public vE As Single = 0
Public Umbral As Single = 2
Function PotMultiDivi(cadena As String, tipo As Integer) As String
Dim Signo1, signo2, signo3, cadsigno As String
Dim cad1, cad2, cad3 As String
Dim Cadena1, Cadena2, Cadena3 As String
Dim CadA, CadB As String
Dim pos1, pos2, pos3, posini As Integer
Dim R As Single
Dim fila As Integer
cadena = " " + cadena + " "
cadsigno = ""
Select Case tipo
Case 1 ' si son potencias
If cadena(fila) = "^" Then
cadsigno = cadena(fila)
pos2 = fila
Exit For
End If
Next
Case 2
'multiplicaciones y divisiones tienen igual prioridad
If cadena(fila) = "*" Or cadena(fila) = "/" Then
cadsigno = cadena(fila)
pos2 = fila
Exit For
End If
Next
End Select
' primero buscamos si son las potencias
CadA = Extrae(cadena, 0, pos2 - 1)
CadB = Extrae(cadena, pos2 + 1, Len(cadena) - 1)
' la cadena anterior
For fila = pos2 - 1 To 0 Step -1
If cadena(fila) = "+" Or cadena(fila) = "-" Or cadena(fila) = "*" Or cadena(fila) =
"/" Or cadena(fila) = "^" Then
pos1 = fila
Exit For
Else
cad1 = cadena(fila) + cad1
End If
Next
' busca hacia adelante
pos3 = pos2
' si el primer signo + o - entonces si cuenta 2o
If CadB(0) = "+" Or CadB(0) = "-" Then
posini = pos2 + 2
cad3 = CadB(0)
Else
cad3 = ""
posini = pos2 + 1
End If
pos3 = Len(cadena) - 1
For fila = posini To Len(cadena) - 1
' cadsigno = cadena(fila)
If cadena(fila) = "+" Or cadena(fila) = "-" Or _
cadena(fila) = "*" Or cadena(fila) = "/" Or cadena(fila) = "^" Or fila >
Len(cadena) - 1 Then
pos3 = fila
Exit For
Else
cad3 = cad3 + cadena(fila)
End If
Next
Select Case cadsigno
Case "^" : R = Val(cad1) ^ Val(cad3) 'tiene mayor prioridad
Case "*" : R = Val(cad1) * Val(cad3)
Case "/" : R = Val(cad1) / Val(cad3)
End Select
'reemplazamos el resultado de la multiplicacion
Cadena1 = Extrae(cadena, 0, pos1)
Cadena3 = Extrae(cadena, pos3, Len(cadena) - 1)
' juntamos la cadena
Cadena2 = Str(R)
' Console.WriteLine(" la cadena 1 es {0} ", Cadena1)
Signo1 = Cadena1(Len(Cadena1) - 1)
signo2 = Cadena2(0)
Select Case Signo1
Case "+"
Select Case signo2
Case "+" : signo3 = "+"
Case " " : signo3 = "+"
Case "-" : signo3 = "-"
End Select
Case "-"
Select Case signo2
Case "+" : signo3 = "-"
Case " " : signo3 = "-"
Case "-" : signo3 = "+"
End Select
Case "*"
signo3 = Signo1
Case "/"
signo3 = Signo1
End Select
Cadena1 = Extrae(Cadena1, 0, Len(Cadena1) - 2)
Cadena2 = Extrae(Cadena2, 1, Len(Cadena2) - 1)
cadena = Cadena1 + signo3 + Cadena2 + Cadena3
Return cadena
End Function
Function Reemplazar(cadena As String, cadbusca As String, cadrempla As String)

As String
Dim fila As Integer
Dim cadTemporal As String = ""
If cadena(fila) = cadbusca Then
cadTemporal = cadTemporal + cadrempla
Else
cadTemporal = cadTemporal + cadena(fila)
End If
Next
Return cadTemporal
End Function
Sub ImprimirCadena(cadena As String)
Dim fila As Integer
Console.WriteLine(" {0} {1} ", fila, cadena(fila))
Next
End Sub
Function Encontrado(SIGNO As String) As Boolean
Dim fila As Integer
Dim valor As Boolean = False
For fila = 0 To Len(CadNumeros) - 1
If CadNumeros(fila) = SIGNO Then
valor = True
Exit For
End If
Next
Return valor
End Function
Function contar(cadena As String, cadsigno As String) As Integer
Dim fila, cont As Integer
cont = 0
If cadena(fila) = cadsigno Then cont = cont + 1
Next
Return cont
End Function
Function Encontrar(cadena As String, cadsigno As String, Vinicial As Integer) As
String
For fila = Vinicial To Len(cadena) - 1
If cadena(fila) = cadsigno Then
pos = fila
Exit For
End If
Next
Return pos
End Function
Function Extrae(cadena As String, pos1 As Integer, pos2 As Integer) As String
Dim subcadena As String = ""
Dim fila As Integer
For fila = pos1 To pos2
subcadena = subcadena + cadena(fila)
Next
Return subcadena
End Function
Function EvaluacionCorrecta(cadena As String) As Boolean
Dim fila, pos1, pos2 As Integer
Dim valor1 As Boolean = True
Dim valor2 As Boolean = True
If Encontrado(cadena(fila)) = False Then
valor1 = False
Exit For
End If
Next
' lo parentesis que se abre debe cerrarse
Dim punto As Integer
punto = 0
While punto < Len(cadena) - 1
pos1 = Encontrar(cadena, "(", punto)
If pos1 > 0 Then ' se encuentra el parentesis
pos2 = Encontrar(cadena, ")", pos1)
If (pos2 > pos1) Then ' se encuentra despue de pos1
valor2 = True
punto = pos2 + 1
Else ' si pos2 esta antes de pos1 o no lo encuentre
valor2 = False
Exit While
End If
Else ' se no encuentra pos 1 no deberia encontrar el pos 2
pos2 = Encontrar(cadena, ")", punto)
If (pos2 > 0) Then
valor2 = False
Exit While
Else
valor2 = True
Exit While
End If
End If
' pos2 = Encontrar(cadena, ")", pos1)
If pos2 >= pos1 And pos2 >= 0 Then
Else
valor2 = False
Exit While
End If
End While
If valor1 * valor2 >= 1 Then
Return True
Else
Return False
End If
End Function
Function EliminarCar(cadena As String, car As String) As String
Dim fila As Integer
Dim Cadena1 As String = ""
If cadena(fila) <> car Then Cadena1 = Cadena1 + cadena(fila)
Next
Return Cadena1
End Function
Function Fractal(Li As Single, ByRef cadres As String) As Single
Dim x, y As Single
Dim fila As Integer
Dim cont As Integer
cadres = "Dentro"
x = Li
cont = 0
For fila = 1 To 255
y = Math.Pow(x, 2) - ck
' Console.WriteLine("fila {0} x {1} y {2}", fila, x, y)
cont = cont + 1
If Math.Abs(y) > Umbral Then
cadres = "FUERA"
Exit For
End If
x=y
Next
If cont > 24 Then
valor = y
Else
valor = cont
End If
Return valor
End Function
Function EvaluarExpresion(cadena As String) As Single
Dim R As Single
' quitamos los parentesis primero
cadena = CadLibre(cadena)
' Console.WriteLine(" la cadena resultante es {0} ", cadena)
' evaluamos la cadena
nelem = contar(cadena, "^")
cadena = PotMultiDivi(cadena, 1) ' es de tipo potencia
Next
' Console.WriteLine("cadena es {0} ", cadena)
nelem = 0
nelem = contar(cadena, "*")
nelem = nelem + contar(cadena, "/")
cadena = PotMultiDivi(cadena, 2) 'l multiplicaciones y divisiones
Next
' evaluamos la cadena sis parentesis
Console.WriteLine("cadena final {0} ", cadena)
cadena = " " + cadena + " "
R = Sumasrestas(cadena)
Return R
End Function
Function CadLibre(Cadena As String) As String
Dim Cadena1, Cadena2, cadena3 As String
Dim cpar As Integer
Dim R As Single
Dim fila, k, pos1, pos2 As Integer
cpar = contar(Cadena, "(")
For k = 0 To cpar - 1
' primero quitamos los parentesis
pos1 = Encontrar(Cadena, "(", 1)
pos2 = Encontrar(Cadena, ")", pos1 + 1)
subcadena = Extrae(Cadena, pos1 + 1, pos2 - 1)
' Console.WriteLine(" subcadena {0}", subcadena)
' evaluamos la cadena
nelem = contar(subcadena, "^")
subcadena = PotMultiDivi(subcadena, 1) ' es de tipo potencia
Next
' Console.WriteLine("cadena es {0} ", subcadena)
nelem = 0
nelem = contar(subcadena, "*")
nelem = nelem + contar(subcadena, "/")
subcadena = PotMultiDivi(subcadena, 2)
Next
Console.WriteLine("cadena final {0} ", subcadena)
subcadena = " " + subcadena + " "
R = Sumasrestas(subcadena)
Console.WriteLine(" la suma y resta es {0}", R)
' formando la nueva cadena
Cadena1 = Extrae(Cadena, 0, pos1 - 1)
Cadena2 = Str(R)
cadena3 = Extrae(Cadena, pos2 + 1, Len(Cadena) - 1)
Cadena = Cadena1 + Cadena2 + cadena3
Next
Return Cadena
End Function
Function Sumasrestas(cadena As String) As Single
Dim suma As Single
Dim signo1, signo2, subcadena As String
Dim psigno1, psigno2, possigno As Integer
Dim cont1, cont2, largo As Integer
largo = Len(cadena)
' buscar el primer signo si es mas o menos
psigno1 = Encontrar(cadena, "+", 0)
psigno2 = Encontrar(cadena, "-", 0)
If psigno1 < psigno2 Then
possigno = psigno1
Else
possigno = psigno2
End If
cont1 = possigno + 1
signo1 = cadena(possigno)
' sumas y restas
suma = 0
While (cont2 < largo)
signo2 = cadena(cont2)
If signo2 = "-" Or signo2 = "+" Or cont2 >= largo - 1 Then
subcadena = Extrae(cadena, cont1, cont2 - 1)
' Console.WriteLine("subcadena {0} ", subcadena)
Select Case signo1
Case "+" : suma = suma + Val(subcadena)
Case "-" : suma = suma - Val(subcadena)
End Select
signo1 = signo2
cont2 = cont2 + 1
cont1 = cont2
' Console.WriteLine("la suma es {0}", suma)
Else
cont2 = cont2 + 1
End If
End While
Return suma
End Function
End Module
' *** CODIGO DEL FORMULARIO
Public Class Form1
Dim pen As Pen
Sub ObtenerValores()
cx = DataGridView1.Rows(0).Cells(1).Value
cy = DataGridView1.Rows(1).Cells(1).Value
Li = DataGridView1.Rows(2).Cells(1).Value
Ls = DataGridView1.Rows(3).Cells(1).Value
Ndiv = DataGridView1.Rows(4).Cells(1).Value
Dx = DataGridView1.Rows(5).Cells(1).Value
A = DataGridView1.Rows(6).Cells(1).Value
B = DataGridView1.Rows(7).Cells(1).Value
C = DataGridView1.Rows(8).Cells(1).Value
vE = DataGridView1.Rows(10).Cells(1).Value
x1 = DataGridView1.Rows(11).Cells(1).Value
ex = DataGridView1.Rows(12).Cells(1).Value
ey = DataGridView1.Rows(13).Cells(1).Value
ck = DataGridView1.Rows(14).Cells(1).Value
End Sub
Function ObtenerEcuacion(CadExpresion As String, cadA As String, cadB As String, _
cadC As String, cadD As String, cadE As String, cadX As String)
CadExpresion = Reemplazar(CadExpresion, "A", cadA)
CadExpresion = Reemplazar(CadExpresion, "B", cadB)
CadExpresion = Reemplazar(CadExpresion, "C", cadC)
CadExpresion = Reemplazar(CadExpresion, "D", cadD)
CadExpresion = Reemplazar(CadExpresion, "E", cadE)
CadExpresion = Reemplazar(CadExpresion, "X", cadX)
Return CadExpresion
End Function
pen = New Pen(Brushes.Red, 2)
DataGridView1.Columns(0).HeaderText = "Prop"
DataGridView1.Columns(1).HeaderText = "Valor"
DataGridView1.Rows(0).Cells(0).Value = "Cx"
DataGridView1.Rows(0).Cells(1).Value = cx
DataGridView1.Rows(1).Cells(0).Value = "Cy"
DataGridView1.Rows(1).Cells(1).Value = cy
DataGridView1.Rows(2).Cells(0).Value = "Li"
DataGridView1.Rows(2).Cells(1).Value = Li
DataGridView1.Rows(3).Cells(0).Value = "Ls"
DataGridView1.Rows(3).Cells(1).Value = Ls
DataGridView1.Rows(4).Cells(0).Value = "Nd"
DataGridView1.Rows(4).Cells(1).Value = Ndiv
DataGridView1.Rows(5).Cells(0).Value = "Dx"
DataGridView1.Rows(5).Cells(1).Value = Dx
DataGridView1.Rows(6).Cells(0).Value = "A"
DataGridView1.Rows(6).Cells(1).Value = A
DataGridView1.Rows(7).Cells(0).Value = "B"
DataGridView1.Rows(7).Cells(1).Value = B
DataGridView1.Rows(8).Cells(0).Value = "C"
DataGridView1.Rows(8).Cells(1).Value = C
DataGridView1.Rows(9).Cells(0).Value = "D"
DataGridView1.Rows(10).Cells(0).Value = "E"
DataGridView1.Rows(10).Cells(1).Value = vE
DataGridView1.Rows(11).Cells(0).Value = "X"
DataGridView1.Rows(11).Cells(1).Value = x1
DataGridView1.Rows(12).Cells(0).Value = "EX"
DataGridView1.Rows(13).Cells(0).Value = "EY"
DataGridView1.Rows(14).Cells(0).Value = "CK"
DataGridView1.Rows(14).Cells(1).Value = ck
End Sub
Sub ObtenerCadenas()
CadenaEcuacion = txtEcuacion.Text
CadA = DataGridView1.Rows(6).Cells(1).Value
CadB = DataGridView1.Rows(7).Cells(1).Value
CadC = DataGridView1.Rows(8).Cells(1).Value
CadD = DataGridView1.Rows(9).Cells(1).Value
CadE = DataGridView1.Rows(10).Cells(1).Value
CadX = DataGridView1.Rows(11).Cells(1).Value
End Sub
Function Sumasrestas(cadena As String) As Single
Dim suma As Single
Dim signo1, signo2, subcadena As String
Dim psigno1, psigno2, possigno As Integer
Dim cont1, cont2, largo As Integer
largo = Len(cadena)
' buscar el primer signo si es mas o menos
psigno1 = Encontrar(cadena, "+", 0)
psigno2 = Encontrar(cadena, "-", 0)
If psigno1 < psigno2 Then
possigno = psigno1
Else
possigno = psigno2
End If
signo1 = cadena(possigno)
' sumas y restas
suma = 0
While (cont2 < largo)
signo2 = cadena(cont2)
If signo2 = "-" Or signo2 = "+" Or cont2 >= largo - 1 Then
subcadena = Extrae(cadena, cont1, cont2 - 1)
' Console.WriteLine("subcadena {0} ", subcadena)
Select Case signo1
Case "+" : suma = suma + Val(subcadena)
Case "-" : suma = suma - Val(subcadena)
End Select
signo1 = signo2
cont2 = cont2 + 1
cont1 = cont2
' Console.WriteLine("la suma es {0}", suma)
Else
cont2 = cont2 + 1
End If
End While
Return suma
End Function
Function Encontrado(SIGNO As String) As Boolean
Dim fila As Integer
Dim valor As Boolean = False
For fila = 0 To Len(CadNumeros) - 1
If CadNumeros(fila) = SIGNO Then
valor = True
Exit For
End If
Next
Return valor
End Function
Private Sub BtnVarTodo_Click(sender As Object, e As EventArgs) Handles

BtnVarTodo.Click
CadenaEcuacion = " " + CadenaEcuacion + " "
ObtenerValores()
ObtenerCadenas()
CadenaExpresion = ObtenerEcuacion(CadenaEcuacion, CadA, CadB, CadC,
CadD, CadE, CadX)
TxtExpresion.Text = CadenaExpresion
CadenaExpresion = " " + CadenaExpresion + " "
EvalRes = EvaluacionCorrecta(CadenaExpresion)
If EvalRes = True Then
Me.Text = "evalucion correcta"
Else
MsgBox("expresion incorrecta")
End If
CadenaExpresion = " +2+(+2-5)+4" ' prueba
txtResultado.Text = EvaluarExpresion(CadenaExpresion)
End Sub
Sub coordenadas(Cx As Integer, Cy As Integer)
Grafico.DrawLine(Pens.Blue, 0, Cy, Cx * 2, Cy)
Grafico.DrawLine(Pens.Blue, Cx, 0, Cx, Cy * 2)
End Sub
Private Sub btnGraficarX(sender As Object, e As EventArgs) Handles btnVarX.Click
Dim CadTemporal As String
Dim x1, y1, x2, y2, x, y As Single
ObtenerValores()
ObtenerCadenas()
CadX = "X"
CadD, CadE, CadX)
coordenadas(cx, cy)
Dx = (Ls - Li) / Ndiv
' mostramos los valores en textbox
ListBox1.Items.Add("valores de la funcion " & CadenaEcuacion)
x = Li
CadTemporal = Reemplazar(CadenaExpresion, "X", x)
CadTemporal = " " + CadTemporal + " "
' reemplaza x con el nuevo y luego calcula la expresion
y = EvaluarExpresion(CadTemporal)
x1 = cx + x * ex
y1 = cy + y * (ey * -1)
For x = Li + Dx To Ls Step Dx
CadTemporal = Reemplazar(CadenaExpresion, "X", x)
CadTemporal = " " + CadTemporal + " "
y = EvaluarExpresion(CadTemporal)
x2 = cx + x * ex
y2 = cy + y * (ey * -1)
x1 = x2
y1 = y2
'Grafico.FillRectangle(Brushes.Blue, x2, y2, ex, ey)
ListBox1.Items.Add(x & " " & y)
Next
End Sub
Private Sub btnVarXA_Click(sender As Object, e As EventArgs) Handles
btnVarXC.Click
Dim CadTemporal1, CadTemporal2 As String
Dim vc As Single
ObtenerValores()
ObtenerCadenas()
CadC = "C"
CadX = "X"
CadD, CadE, CadX)
coordenadas(cx, cy)
For vc = Li To Ls Step Dx
CadTemporal1 = Reemplazar(CadenaExpresion, "C", vc)
x = Li
CadTemporal2 = Reemplazar(CadTemporal1, "X", x)
CadTemporal2 = " " + CadTemporal2 + " "
y = EvaluarExpresion(CadTemporal2)
x1 = cx + x * ex
y1 = cy + y * (ey * -1)
x2 = cx + x * ex
y2 = cy + y * (ey * -1)
x1 = x2
y1 = y2
Next
Next
End Sub
Private Sub BtnXd_Click(sender As Object, e As EventArgs) Handles BtnXd.Click
Dim vd As Single
ObtenerValores()
ObtenerCadenas()
CadD = "D"
CadX = "X"
CadD, CadE, CadX)
coordenadas(cx, cy)
For vd = Li To Ls Step Dx
CadTemporal1 = Reemplazar(CadenaExpresion, "D", vd)
x = Li
x1 = cx + x * ex
y1 = cy + y * (ey * -1)
x2 = cx + x * ex
y2 = cy + y * (ey * -1)
x1 = x2
y1 = y2
Next
Next
End Sub
Private Sub BtnVarXE_Click(sender As Object, e As EventArgs) Handles
BtnVarXE.Click
Dim ve As Single
ObtenerValores()
ObtenerCadenas()
CadE = "E"
CadX = "X"
CadD, CadE, CadX)
coordenadas(cx, cy)
For ve = Li To Ls Step Dx
CadTemporal1 = Reemplazar(CadenaExpresion, "E", ve)
x = Li
x1 = cx + x * ex
y1 = cy + y * (ey * -1)
x2 = cx + x * ex
y2 = cy + y * (ey * -1)
x1 = x2
y1 = y2
Next
Next
End Sub
Private Sub BtnBorra_Click(sender As Object, e As EventArgs) Handles
BtnBorra.Click
End Sub
Private Sub btnCX_Click(sender As Object, e As EventArgs) Handles btnCX.Click
Dim vc As Single
ObtenerValores()
ObtenerCadenas()
CadC = "C"
CadX = "X"
CadD, CadE, CadX)
coordenadas(cx, cy)
CadTemporal1 = Reemplazar(CadenaExpresion, "X", x)
'BtnBorra_Click(sender, e)
System.Threading.Thread.Sleep(50) ' 1 segundo
vc = Li
CadTemporal2 = Reemplazar(CadTemporal1, "C", vc)
x1 = cx + vc * ex
y2 = cy + y * (ey * -1)
For vc = Li + Dx To Ls Step Dx
CadTemporal2 = Reemplazar(CadTemporal1, "C", vc)
x2 = cx + vc * ex
y2 = cy + y * (ey * -1)
x1 = x2
y1 = y2
Next
Next
End Sub
Private Sub BtnFractal_Click(sender As Object, e As EventArgs) Handles
BtnFractal.Click
Dim Resultado As Single
ObtenerValores()
ObtenerCadenas()
CadD, CadE, CadX)
For fila = Li To Ls Step Dx
cadena1 = ""
Resultado = Fractal(fila, cadena1)
' Console.WriteLine("cont {0} X {1} Y {2} {3} ", cont, fila, Resultado, cadena)
ListBox1.Items.Add(" cont " & cont & " fila " & fila & "res " & Resultado & " cad "
& cadena1)
cont = cont + 1
Grafico.FillRectangle(brocha, cx + fila * ex, cy + Resultado * ey * (-1), ex, ey)
Next
' Console.ReadLine()
End Sub
Private Sub btnEvaluar_Click(sender As Object, e As EventArgs) Handles

btnEvaluar.Click
CadenaExpresion = " " + CadenaEcuacion + " "
EvalRes = EvaluacionCorrecta(CadenaExpresion)
If EvalRes = True Then
Me.Text = "evalucion correcta"
Else
MsgBox("expresion incorrecta")
End If
txtResultado.Text = EvaluarExpresion(CadenaExpresion)
End Sub
End Class
PROPUESTAS DE TRABAJOS DE INVESTIGACION
Los trabajos tienen que ser en modo visual . se deben presentar en grupos de 3
1. Aplicación de fractales y recursividad ejemplo modelización de terrenos
2. Aplicación de autómatas celulares y computación universal. Juego de la vida en
2d y 3D
3. Aplicación del programa del buscador en optimización en modo grafico
4. Manejo del puerto USB
5. Programación de ADN manejo de secuencias cadenas
6. Programación genérica plantillas ( Templates)
7. Base de datos biológica
8. Aplicación 3d en opengl y visual estudio 2010, Simulación 3D
9. Aplicaciones Web Lenguaje HTML, Java, etc. y su importancia
10. Temas de inteligencia artificial como programación evolutiva , redes
neuronales,etc
11. Sistemas de información en Office Excel
12. My sql
13. Automatización industrial plc, sensores,
14. Aplicaciones de sistemas de información para optimización
15. Simulación 3d, ejemplo simio.etc
16. Programación en Windows. Uso de otros controles como por ejemplo el
Microsoft char
17. Programación genérica plantillas ( Templates)
18. Seguridad de base de datos en sqlserver
19. Otros temas relacionados al curso de sistemas de información
20. usando recursividad encuentre la posicion de cada objeto y cuantos
elementos tiene cada uno
EVALUACION DE EXPRESIONE
Module Module2
Public Signo As Integer
Function Evaluar(ByVal Txt As String) As String
Dim i As Integer, oNB As Integer, fNB As Integer
Dim P1 As Integer, P2 As Integer
Dim Buff As String
' Dim T As String
'Para los calculos es necesario un punto en lugar de la coma
Txt = Replace(Txt, ",", ".")
'Ver si hay (
For i = 1 To Len(Txt)
If Mid(Txt, i, 1) = "(" Then oNB = oNB + 1
Next i
'Si hay ( (abiertos), ver si concuerdan) (cerrados)
If oNB > 0 Then
For i = 1 To Len(Txt)
If Mid(Txt, i, 1) = ")" Then fNB = fNB + 1
Next i
Else
'No hay parentesis, Evalua directamente el calculo
Evaluar = EvaluaExpresion(Txt)
Exit Function
End If
If oNB <> fNB Then
'Los parentesis no concuerdan, mostrar mensaje de error de parentesis
Return "ERROR"
Exit Function
End If
While oNB > 0

'busca el ultimo parentesis abierto
P1 = InStrRev(Txt, "(")
'Busca el parentesis que cierra la expresion
P2 = InStr(Mid(Txt, P1 + 1), ")")
'Evalua la expresion que esta entre parentesis
Buff = EvaluaExpresion(Mid(Txt, P1 + 1, P2 - 1))
'Reemplazar la expresion con el resultado y eliminar los parentesis
Txt = Left(Txt, P1 - 1) & Buff & Mid(Txt, P1 + P2 + 1)
oNB = oNB - 1
End While
'no mas parentesis, evaluar la ultima expresion
Evaluar = EvaluaExpresion(Txt)
End Function
Function EvaluaExpresion(A As String) As String
Dim T As Integer, S As Integer
Dim B As String, i As Integer, C As Boolean
Dim c1 As Double, c2 As Double, Signe As Integer
Dim R As String, Fin As Boolean, z As Integer
'quitar los espacios

A = Replace(A, " ", "")
While Not Fin

For i = 1 To Len(A)
T = Asc(Mid(A, i, 1))
If T < 48 And T <> 46 Or i = Len(A) Then
If C Then 'evalua
If i = Len(A) Then
c2 = Val(Mid(A, S))
Else
c2 = Val(Mid(A, S, i - S))
End If
R = Str(CalculSimple(c1, c2, Signo))
If i = Len(A) Then
Fin = True
Else
A = Trim(R & Mid(A, i))
C = False
End If
Exit For
Else 'separa la 1ra cifra
c1 = Val(Left(A, i - 1))
Signe = T
S=i+1
C = True
End If
End If
Next i
End While
'reemplazar la expresión con el resultado
EvaluaExpresion = Trim(R)
End Function
Function CalculSimple(n1 As Double, n2 As Double, Signe As Integer) As Double
Select Case Signe
Case 43 ' +
CalculSimple = n1 + n2
Case 45 ' -
CalculSimple = n1 - n2
Case 42 ' *
CalculSimple = n1 * n2
Case 47 ' /
CalculSimple = n1 / n2
'Aquí, agregar otro calculo...
End Select
End Function
End Module
Module Module1
Sub TestCalcul()
Dim A As String
Dim Ret As String
A = "(((3*(12.223+ 15)) - 7)*21)/7"
Ret = Evaluar(A)
'Debug.Print Ret
'= 224.007
A = "((123.32/2.67)*6)+2127.34"
Ret = Evaluar(A)
'=2404.46359550562
'Debug.Print Ret
End Sub
Sub Main()
TestCalcul()
Console.ReadLine()
End Sub
End Module
Fractal
Module Module1
Dim Li, Ls, Dx As Single
Dim x, y As Single
Dim k As Single = 0.279
Dim umbral As Single = 2
Function Fractal(Li As Single, ByRef cadres As String) As Single
Dim fila As Integer
cadres = "Dentro"
x = Li
cont = 0
For fila = 1 To 25
y = Math.Pow(x, 2) - k
' Console.WriteLine("fila {0} x {1} y {2}", fila, x, y)
cont = cont + 1
If Math.Abs(y) > umbral Then
cadres = "FUERA"
Exit For
End If
x=y
Next
If cont > 24 Then
valor = y
Else
valor = cont
End If
Return valor
End Function
Sub Main()
Dim Resultado As Single
Li = -2
Ls = 2
Dx = 0.05
For fila = Li To Ls Step Dx
Resultado = Fractal(fila, cadena)
Console.WriteLine("cont {0} X {1} Y {2} {3} ", cont, fila, Resultado, cadena)
cont = cont + 1
Next
Console.ReadLine()
End Sub
End Module
Desarrollar un juego donde se mueve el fondo de la pantalla

Usar colores como las que indican en el cuadro
Nro Color Significado

0 negro camino limpio
1 punto amarillo pequeño cambia la matriz
2 naranja premio 10 puntos
3 Verde pared
4 rojo pierde e juego
5 azul pierde una vida
6 blanco Meta
11.19 VER UNA PARTE DE LA PANTALLA Modificar el programa para ver parte de
una pantalla(corregir)
'****** CODIGO DEL MODULO 1
Imports System.IO
Module Module1
Public Npremios As Integer = 10
Public Px As Integer = 10 ' posicion X del curso en la matrizal
Public Py As Integer = 10 ' posicon Y del cursor en la matriz
Public RxTem(10) As Integer ' variable para obtener temporal
Public RyTem(10) As Integer ' variable y para obtener temporal
Public RValor1(10) As Integer ' variable que almacena el valor
Public RValor2(10) As Integer ' variable que almacena el valor
Public RX(10) As Integer ' coordenadas Y del enemigo

Public RY(10) As Integer ' coordenadas Y del enemigo
Public nene As Integer = 5 ' numero de enemigos
Public generar As Integer = 0
Public CadRes1, CadRes2 As String
Public vidas As Integer = 7
Public puntos As Integer = 0
Public pasos As Integer = 0
Public nvidas As Integer = 3
Public mov As Integer = 0
Public A(nf, nc) As Integer
Public lapicero As Pen
Public AnchoFigura As Integer = 500
Public AltoFigura As Integer = 500
Public EX1 As Integer = 12
Public EY1 As Integer = 10
Public paso As Integer = 1
Public nfmuestra As Integer = 10
Public ncmuestra As Integer = 10
Public nf1 As Integer = 5
Public nc1 As Integer = 5
Public posx As Integer = cx + nf1
Public posy As Integer = cy + nc1
Public tpx As Integer = cx + nf1
Public tpy As Integer = cy + nc1
Public NombreArchivo As String = "E:\datos\matriz24x44.txt"
Sub MostrarMatriz(grafico As Graphics, ByVal Cx As Integer, ByVal Cy As Integer,
ByVal A(,) As Integer,
ByVal nf As Integer, ByVal nc As Integer, ex As Integer, ey As Integer)
Dim ancho1, alto1 As Integer
ancho1 = ex / 3
alto1 = ey / 3
Select Case A(Cy + fila, Cx + col)
Case 0
Case 1 : grafico.FillRectangle(Brushes.Yellow, col * ex + ancho1, fila * ey +
alto1, ancho1, alto1)
Case 2 : grafico.FillRectangle(Brushes.Orange, col * ex, fila * ey, ex, ey)
Case 3 : grafico.FillRectangle(Brushes.Green, col * ex, fila * ey, ex, ey)
Case 4 : grafico.FillRectangle(Brushes.Blue, col * ex, fila * ey, ex, ey)
Case 5 : grafico.FillRectangle(Brushes.Red, col * ex, fila * ey, ex, ey)
Case 6 : grafico.FillRectangle(Brushes.White, col * ex, fila * ey, ex, ey)
Case 7 : grafico.FillRectangle(Brushes.Yellow, col * ex, fila * ey, ex, ey)
End Select
grafico.DrawRectangle(Pens.Red, col * ex, fila * ey, ex, ey)
Next
Next
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByRef A(,) As Integer, ByRef

inicio = 1
inicio = pos + 1
Next
fila = fila + 1
Loop
nf = fila
srLector.Close()
End Sub
Function factible(X() As Integer, Y() As Integer, n As Integer, Nx As Integer, ny As
Integer) As Integer
Dim fila As Integer
Dim res As Integer = 1
For fila = 0 To n - 1
If Nx = X(fila) And ny = Y(fila) Then
res = 0
Exit For
End If
Next
Return res
End Function
Sub copiarVector(A() As Integer, B() As Integer, ne As Integer)
Dim fila As Integer
B(fila) = A(fila)
Next
End Sub
Sub premio()
Dim fila, rx1, ry1 As Integer
For fila = 0 To nene - 1
generar = 0
Do
rx1 = 2 + Int(Rnd() * (nc - 4))
ry1 = 2 + Int(Rnd() * (nf - 4))
If A(ry1, rx1) <= 1 Then
A(ry1, rx1) = 2
generar = 1
End If
Loop While generar = 0
Next
End Sub
End Module
' **** CODIGO DEL FORMULARIO

Public Class Form1
PictureBox1.Width = AnchoFigura
PictureBox1.Height = AltoFigura
Grafico.DrawRectangle(Pens.Red, cx, cy, ex, ey)
lapicero = New Pen(Color.FromArgb(255, 0, 0), 5)
MostrarMatriz(Grafico, cx, cy, A, nfmuestra, ncmuestra, ex, ey)
Grafico.FillRectangle(Brushes.Yellow, posx * ex, posy * ey, ex, ey)
MostrarMatriz(Grafico2, 0, 0, A, nf, nc, EX1, EY1)
TextBox1.Focus()
End Sub
Sub ImprimirElementoMatriz(grafico As Graphics, cx As Integer, cy As Integer, dx As
Integer, dy As Integer, ex As Integer, ey As Integer, valor As Integer)
Dim ancho1, alto1 As Integer
ancho1 = ex / 3
alto1 = ey / 3
Select Case valor
Case 0 : Grafico.FillRectangle(Brushes.Black, cx + dx * ex, cy + dy * ey, ex, ey)
Case 1 : Grafico.FillRectangle(Brushes.Yellow, cx + dx * ex + ancho1, cy + dy *
ey + alto1, ancho1, alto1)
Case 2 : Grafico.FillRectangle(Brushes.Orange, cx + dx * ex, cy + dy * ey, ex, ey)
Case 3 : Grafico.FillRectangle(Brushes.Green, cx + dx * ex, cy + dy * ey, ex, ey)
Case 4 : Grafico.FillRectangle(Brushes.Blue, cx + dx * ex, cy + dy * ey, ex, ey)
Case 5 : Grafico.FillRectangle(Brushes.Red, cx + dx * ex, cy + dy * ey, ex, ey)
Case 6 : Grafico.FillRectangle(Brushes.White, cx + dx * ex, cy + dy * ey, ex, ey)
Case 7 : Grafico.FillRectangle(Brushes.Yellow, cx + dx * ex, cy + dy * ey, ex, ey)
'amarillo grande
End Select
Grafico.DrawRectangle(Pens.Red, cx + dx * ex, cy + dy * ey, ex, ey)
End Sub
TextBox1.KeyDown
Dim tposx, tposy, valor As Integer
Dim Cantes, Ctemp, cDespues As String
cx = Px - nc1
cy = Py - nf1
Cantes = "py " & posy & "Px" & posx & "valor " & A(posy, posx)
tpx = Px
tpy = py
Case Keys.Left
If tpx > nc1 Then tpx = tpx - paso
Case Keys.Right
If tpx < nc - nc1 Then tpx = tpx + paso
Case Keys.Up
If tpy > nf1 Then tpy = tpy - paso
Case Keys.Down
If tpy < nf - nf1 Then tpy = tpy + paso
End Select
pasos = pasos + 1
valor = A(tpy, tpx)
Ctemp = " Temp py " & tpy & "Px" & tpx & "valor " & A(tpy, tpx)
' en el juego aumentar velocidad
Select Case A(tpy, tpx)
Case 0 ' camina limpia no retorna
Case 1 ' punto amariloo pequeño cuadro en la matriz no retorna gana puntos y
no retorna
' reemplaza a la matriz con 0
A(tpy, tpx) = 0
puntos = puntos + 1
Case 2 'naranja gana 10 puntos no retorna reemplaza a la matriz con cero
puntos = puntos + 10
A(tpy, tpx) = 0
Case 3 'verde no puede caminar retorna al anterior
tpx = Px
tpy = py
A(tpy, tpx) = 0
' Case 4 'Azul pierde una vida retrocede
' vidas = vidas - 1
Case 5 ' rojo pierde el juego
MsgBox(" Juego terminado ")
Case 6 'blanco llega a la meta
MsgBox("llego a la meta ")
End Select
If (tpx = RX(fila)) And (tpy = RY(fila)) Then vidas = vidas - 1
Next
Px = tpx
Py = tpy
cx = Px - nc1
cy = Py - nf1
cDespues = " Despues Temp posy " & Px & "Posx" & Py & "valor " & A(tposy,
tposx)
ListBox1.Items.Add(Cantes)
ListBox1.Items.Add(Ctemp)
ListBox1.Items.Add(cDespues)
If vidas > 0 Then
mov = mov + 1
ImprimirElementoMatriz(Grafico, cx, cy, RX(fila) - cx, RY(fila) - cy, ex, ey, 4)
ImprimirElementoMatriz(Grafico2, 0, 0, RX(fila), RY(fila), EX1, EY1, 4)
Next
ImprimirElementoMatriz(Grafico, cx, cy, posx, posy, ex, ey, 7)
ImprimirElementoMatriz(Grafico2, 0, 0, Px, Py, EX1, EY1, 7)
CadRes1 = "Mov " + Str(mov) + " Puntos " + Str(puntos) + " vidas " + Str(vidas)
Label1.Text = CadRes1
TextBox1.Focus()
Else
MsgBox("juego terminado")
End If
End Sub
Private Sub btnRecuperar_Click(sender As Object, e As EventArgs) Handles
btnRecuperar.Click
Dim fila, rx1, ry1 As Integer
Randomize()
generar = 0
Do
rx1 = 2 + Int(Rnd() * (nc - 4))
ry1 = 2 + Int(Rnd() * (nf - 4))
If A(ry1, rx1) <= 1 And factible(RX, RY, fila, rx1, ry1) = 1 Then
RX(fila) = rx1
RY(fila) = ry1
generar = 1
End If
Loop While generar = 0
Next
RValor2(fila) = A(RY(fila), RX(fila))
Next
copiarVector(RX, RxTem, nene)
copiarVector(RY, RyTem, nene)
copiarVector(RValor2, RValor1, nene)
posx = 5 ' nfmuestra/2
posy = 5
cx = 0
cy = 0
Px = cx + nc1
Py = cy + nf1
ImprimirElementoMatriz(Grafico, cx, cy, posx, posy, ex, ey, 7)
ImprimirElementoMatriz(Grafico2, cx, cy, RX(fila) - cx, RY(fila) - cy, EX1, EY1, 4)
Next
ImprimirElementoMatriz(Grafico2, 0, 0, Px, Py, EX1, EY1, 7)
CadRes1 = "Mov " + Str(mov) + " Puntos " + Str(puntos) + " vidas " + Str(vidas)
CadRes2 = "Cx " + Str(cx) + " Cy " + Str(cy) + "Px " + Str(Px) + "Py " + Str(Py)
txtMov.Text = CadRes2
premio()
TextBox1.Focus()
End Sub
Private Sub btnMostrar_Click(sender As Object, e As EventArgs) Handles
btnMostrar.Click
Grafico.FillRectangle(Brushes.Blue, posx * ex, posy * ey, ex, ey)
End Sub
btnMover.Click
End Sub
Sub MoverEnemigo()
Dim resultado As Integer = 0
Dim Ancho1, alto1 As Integer
Dim Nr As Integer
ancho1 = ex / 3
alto1 = ey / 3
' lo elimina y recupera el valor anterior
‘ ImprimirElementoMatriz(Grafico, cx, cy, RxTem(fila) - cx, RyTem(fila) - cy, ex, ey, 0)
' ImprimirElementoMatriz(Grafico2, 0, 0, RxTem(fila), RyTem(fila), EX1, EY1, 0)
ImprimirElementoMatriz(Grafico, cx, cy, RxTem(fila) - cx, RyTem(fila) - cy, ex,
ey, RValor1(fila))
ImprimirElementoMatriz(Grafico2, 0, 0, RxTem(fila), RyTem(fila), EX1, EY1,
RValor1(fila))
Next
resultado = 0
Do
Nr = 1 + Int(Rnd() * 4)
Select Case Nr
Case 1
If A(RY(fila), RX(fila) + 1) <> 3 And RX(fila) + 1 < nc - 2 Then
RX(fila) = RX(fila) + 1
RValor2(fila) = A(RY(fila), RX(fila) + 1)
resultado = 1
End If
Case 2
If A(RY(fila) - 1, RX(fila)) <> 3 And RY(fila) - 1 > 2 Then
RY(fila) = RY(fila) - 1
RValor2(fila) = A(RY(fila) - 1, RX(fila))
resultado = 1
End If
Case 3
If A(RY(fila), RX(fila) - 1) <> 3 And RX(fila) - 1 > 2 Then
RX(fila) = RX(fila) - 1
RValor2(fila) = A(RY(fila), RX(fila) - 1)
resultado = 1
End If
Case 4
If A(RY(fila) + 1, RX(fila)) <> 3 And RY(fila) + 1 < nf - 2 Then
RY(fila) = RY(fila) + 1
RValor2(fila) = A(RY(fila) + 1, RX(fila))
resultado = 1 '
End If
End Select
Loop While resultado = 0
Next
'' quitar vidas
If (RX(fila) = Px And RY(fila) = Py) Then
vidas = vidas - 1
CadRes1 = "Mov " + Str(mov) + " Puntos " + Str(puntos) + " vidas " +
Str(vidas)
If vidas <= 0 Then MsgBox("juego terminado ")
Exit Sub
End If
ImprimirElementoMatriz(Grafico2, 0, 0, RX(fila), RY(fila), EX1, EY1, 4)
Next
copiarVector(RX, RxTem, nene)
copiarVector(RY, RyTem, nene)
copiarVector(RValor2, RValor1, nene)
End Sub
MoverEnemigo()
End Sub

btnDetener.Click
End Sub
End Class
APLICACIÓN DE SIMULACION DE UN SENSOR
La siguieten aplicacion simula el movieminto de las lectruas leidas por un sensor y

muestra en un grafico los resultado , la aplicación permite leer datos y también grabar
CODIGO DEL MODULO
Imports System.IO
Module Module1
Sub SimularMatriz(ByRef A(,) As Single, ByVal nf As Integer, li As Integer, ls As

Integer)
Dim fila As Integer
Randomize()
A(fila, 0) = fila + 1
A(fila, 1) = li + Int(Rnd() * (ls - li))
Next
End Sub
Sub MostrarMatriz(A(,) As Single, nf As Integer, nc As Integer)
Next
Console.WriteLine()
Next
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByRef A(,) As Single, ByVal nf
inicio = 1
inicio = pos + 1
Next
Next
srLector.Close()
End Sub
Sub Grabar(ByVal nombrearchivo As String, ByRef A(,) As Single, ByVal nf As
Dim srEscritor As StreamWriter
srEscritor = New StreamWriter(nombrearchivo)
srEscritor.Write("{0} {1}", A(fila, col), vbTab)
Next
srEscritor.WriteLine()
Next
srEscritor.Close()
End Sub
End Module
Public Class Form1
Public alturamaxima As Integer = 20
Public maxcol As Integer = 2
Public maxfilas As Integer = 100
Public A(maxfilas, maxcol) As Single
Public NombreArchivo As String = "E:\datos\datos1.txt"
Public pen As Pen
Public pen1 As Pen
Public brochaletra As SolidBrush
Public li As Integer = 0
Public ls As Integer = 5
Sub MostrarMatriz(A(,) As Single, nf As Integer, nc As Integer)

cadena = ""
cadena = cadena + " " + CStr(A(fila, col))
Next
ListBox1.Items.Add(cadena)
Next
End Sub
Sub GraficaIntervalo(A(,) As Single, li As Integer, ls As Integer, nf As Integer)
Dim fila As Integer
'la grafica
For fila = li To ls
grafico.FillRectangle(brocha, cx + (fila - li) * ex, cy - A(fila, 1) * ey, ex, A(fila, 1) * ey)
grafico.DrawRectangle(pen, cx + (fila - li) * ex, cy - A(fila, 1) * ey, ex, A(fila, 1) * ey)
grafico.DrawString(CStr(fila), MiFuente, brochaletra, cx + (fila - li) * ex, cy)
Next
End Sub
BtnGraficar.Click
li = Val(txtLi.Text)
ls = Val(txtls.Text)
btnCoordenadas_Click(sender, e)
GraficaIntervalo(A, li, ls, nf)
End Sub
Private Sub BtnRecuperar_Click_1(sender As Object, e As EventArgs) Handles
BtnRecuperar.Click
nf = Val(txtNf.Text)
MostrarMatriz(A, nf, nc)
End Sub

brochaletra = New SolidBrush(Color.Blue)
End Sub
Private Sub btnCoordenadas_Click(sender As Object, e As EventArgs) Handles
Dim fila As Integer
grafico.DrawLine(pen, cx, cy, ancho, cy)
grafico.DrawLine(pen, cx, 0, cx, alto)
For fila = 0 To alturamaxima
grafico.DrawString(CStr(fila), MiFuente, brochaletra, cx - 30, cy - fila * ey - ey)
grafico.DrawLine(pen1, cx - 30, cy - fila * ey - ey, ancho, cy - fila * ey - ey)
Next
For fila = li To ls
grafico.DrawLine(pen1, cx + (fila - li) * ex, 0, cx + (fila - li) * ex, cy)
Next
End Sub

btnBorrar.Click
End Sub
Private Sub BtnDesIzquierda_Click(sender As Object, e As EventArgs) Handles

BtnDesIzquierda.Click
If ls < nf - 1 Then
li = li + 1
ls = ls + 1
txtLi.Text = li
txtls.Text = ls
End If
End Sub
Private Sub btnDespDerecha_Click(sender As Object, e As EventArgs) Handles
btnDespDerecha.Click
If li > 0 Then
li = li - 1
ls = ls - 1
txtLi.Text = li
txtls.Text = ls
End If
End Sub
Private Sub btnSimular_Click(sender As Object, e As EventArgs) Handles

btnSimular.Click
nf = Val(txtNf.Text)
li = Val(txtLi.Text)
ls = Val(txtls.Text)
SimularMatriz(A, nf, li, ls)
MostrarMatriz(A, nf, nc)
End Sub

btnMover.Click
End Sub
btnDetener.Click
End Sub

If ls < nf - 1 Then
li = li + 1
ls = ls + 1
txtLi.Text = li
txtls.Text = ls
Else
li = 0
ls = 10
End If
End Sub

btnGrabar.Click
Grabar(NombreArchivo, A, nf, nc)
End Sub
End Class
SOLUCION FINAL
' **** MODULO2

Module Module2
Sub Iniciar1()
Act(0) = "A"
Act(1) = "B"
Act(2) = "C"
Act(3) = "D"
Act(4) = "E"
Asig(0) = "BD"
Asig(1) = "CD"
Asig(2) = "E"
Asig(3) = "E"
'Asig(4) = " "
T(0) = 2
T(1) = 3
T(2) = 4
T(3) = 5
T(4) = 2
End Sub
Sub MostrarCadenas(Cadenas() As String, nf As Integer)
Dim fila As Integer
Console.WriteLine("{0}", Cadenas(fila))
Next
End Sub
Function Obtenercadenas2(cadenas() As String, cad1() As String, letra As String, ne

As Integer) As Integer
Dim fila As Integer
If letra = cadenas(fila)(0) Then
cad1(cont) = cadenas(fila)
cont = cont + 1
End If
Next
Return cont
End Function
Dim Cad2(10) As String
Function Obtenercadenas3(cadenas() As String, ByRef cad1() As String, letra As
String, ne As Integer, ini As Integer) As Integer
Dim fila As Integer
Dim cad2(10) As String
Dim letra1 As String
Dim nf1 As Integer
letra2 = (cadenas(fila)(0))
If letra = letra2 Then
cont = cont + 1
End If
Next
nf1 = cont
'' trasladra a cadena reemplazando la ultima letra con todas las combinaciones
de cad
cont = 0
For fila = 0 To ini - 1
letra1 = cad1(fila)
largo = Len(letra1)
letra4 = letra1(largo - 1)
' reemplaza con todos los posibles valores
For k = 0 To nf1 - 1
cad3(cont) = cad1(fila) + cad2(k)(1)
cont = cont + 1
Next
Else
cad3(cont) = cad1(fila)
cont = cont + 1
End If
Next
cad1 = cad3
Return cont
End Function
Function obtenerVectores(Mred(,) As String, Act() As String, X() As Integer, Y() As
Integer, nact As Integer) As Integer
Dim k, nf1, nc1 As Integer
Dim letra As String
Dim posletra As Boolean
For k = 0 To nact - 1
letra = Act(k)
posletra = EncontrarLetraMatriz(MR1, letra, ncad1, nper, nf1, nc1)
If posletra = True Then
X(cont) = nc1
Y(cont) = nf1
cont = cont + 1
End If
Next
Return cont
End Function
Sub ConvertirCadenasMatriz(Cadenas() As String, Matriz(,) As String, ncad As

Integer)
Dim cad As String
For fila = 0 To ncad - 1
cad = Cadenas(fila)
For col = 0 To Len(cad) - 1
Matriz(fila, col) = cad(col)
Next
Next
End Sub
Function EncontrarLetraMatriz(MR1(,) As String, letra As String, _
nf As Integer, nc As Integer, ByRef nfe As Integer, ByRef nce As
Integer) As Boolean
If letra = MR1(fila, col) Then
nfe = fila
nce = col
encontrado = True
Return encontrado
End If
Next
Next
Return encontrado
End Function
Sub Mostrar3VectoresC(V1() As String, V2() As String, V3() As Integer, ne As
Integer)
Dim fila As Integer
Console.WriteLine("{0}{1}{2} {3}{4}", V1(fila), vbTab, V2(fila), vbTab, V3(fila))
Next
End Sub
Sub Mostrar2VectoresC(V1() As Integer, V2() As Integer, ne As Integer)
Dim fila As Integer
Console.WriteLine("{0}{1}{2} ", V1(fila), vbTab, V2(fila))
Next
End Sub
Sub MostrarVectorC(V1() As String, ne As Integer)
Dim fila As Integer
Console.WriteLine("{0}", V1(fila))
Next
End Sub
Function EncontrarFila(Cad() As String, letra As String, ne As Integer, posini As
Integer) As Integer
Dim fila As Integer
For fila = posini To ne - 1
If Cad(fila)(0) = letra Then
pos = fila
Exit For
End If
Next
Return pos
End Function
Function EncontrarFilaCadena(Cadena As String, letra As String, ne As Integer) As
Integer
If Cadena(fila) = letra Then
pos = fila
Exit For
End If
Next
Return pos
End Function
Function EncontrarCadena(cadenas() As String, cad1 As String, nf As Integer) As

Integer
Dim fila, pos1 As Integer
Dim valor As Integer = -1
pos1 = InStr(cadenas(fila), cad1)
If pos1 >= 1 Then
valor = pos1 - 1
Exit For
End If
Next
Return valor
End Function
Function ObtenerCadenas(cadenas() As String, cadenas2() As String, ncad As
Integer) As Integer
Dim Posletra1, fila, posini As Integer
Dim cad1 As String
posini = 0
letra2 = cadenas(fila)(0)
cad1 = letra2
Do
Posletra1 = EncontrarFila(cadenas, letra2, ncad, fila)
If (Posletra1 >= 0) Then
letra2 = cadenas(Posletra1)(1)
cad1 = cad1 + letra2
End If
Loop While (Posletra1 >= 0)
cadenas2(cont) = cad1
cont = cont + 1
Next
Return cont
End Function
Function FormarCadenas(V1() As String, V2() As String, V3() As String, nf As
Integer) As Integer
Dim cont As Integer
CadTemporal = V2(fila)
For col = 0 To Len(CadTemporal) - 1
V3(cont) = V1(fila) + CadTemporal(col)
cont = cont + 1
Next
Next
Return cont
End Function
Sub IniciarCadena(cadena() As String, nf As Integer)
Dim col As Integer
For col = 0 To nf - 1
cadena(col) = "X"
Next
End Sub
Sub IniciarMatriz(Matriz(,) As String, nf As Integer, nc As Integer)
Matriz(fila, col) = "X"
Next
Next
End Sub
Sub MostrarMatriz(M(,) As String, nf As Integer, nc As Integer)
Console.Write("{0,2}", M(fila, col))
Next
Console.WriteLine()
Next
End Sub
Function MaxletrasColumnas(MP(,) As String, nf As Integer, nc As Integer)

Dim fila, col, suma As Integer
Dim maxlc As Integer = 0
suma = 0
If MP(fila, col) <> "X" Then
suma = suma + 1
End If
If suma > maxlc Then maxlc = suma
Next
Next
Return maxlc
End Function
Function EncontrarUltimaLetra(MP(,) As String, letra As String, nf As Integer, nc As
Integer) As Integer
Dim res As Integer = -1
For col = nc - 1 To 0 Step -1
If MP(fila, col) = letra Then
res = col
Return res
End If
Next
Next
Return res
End Function
Function ProgramaPriliminar(Act() As String, T() As Integer, Mred(,) As String, ByRef

MGantt(,) As String, _
ncad As Integer, nact As Integer, nper As Integer) As Integer
Dim fila, col, k, i As Integer
Dim letra As String
Dim mayor As Integer = 0
For k = 0 To ncad - 1
cont = 0
For col = 0 To nper - 1
letra = Mred(k, col)
For fila = 0 To nact - 1
If letra = Act(fila) Then
For i = 0 To T(fila) - 1
MGantt(fila, cont) = letra
cont = cont + 1
Next
End If
Next
If cont > mayor Then mayor = cont
Next
Next
Return mayor
End Function
Sub programaGantt(Act() As String, T() As Integer, MP(,) As String, ByRef MGantt(,)
As String, _
nact As Integer, nper As Integer)
Dim fila, col, ultimo As Integer
Dim letra As String
letra = Act(fila)
ultimo = EncontrarUltimaLetra(MP, letra, nact, nper)
' asignamos
For col = ultimo To ultimo - T(fila) + 1 Step -1
MGantt(fila, col) = letra
Next
Next
End Sub
End Module
' ************* MODULE 1

Module Module1
Public Act(maxfilas) As String
Public Asig(maxfilas) As String
Public brochaTexto As SolidBrush
Public Cadenas1(maxcol) As String ' cadena de secuencias origen destino
Public Const max As Integer = 5
Public MGantt(maxfilas, maxcol) As String
Public MP(maxfilas, maxcol) As String
Public MR1(maxfilas, maxcol) As String
'Public MRed(,) As String = {{"A", "B", "C", "E"}, {"A", "D", "E", "X"}}
Public nact As Integer = 5
Public ncad1 As Integer ' cantidad de cadenas iniciales
Public nper As Integer = 4
Public Nper1 As Integer = 15
Public Pen As Pen
Public Periodos(maxcol) As Integer
Public plantilla As String = "ABCDE"
Public redcol As Integer
Public T(maxfilas) As Integer
Public X(maxfilas) As Integer
Public Y(maxcol) As Integer
Public nvec As Integer
Public Nelem As Integer
Dim CAD1(10) As String
Sub Iniciar()
Dim letra As String
'Iniciar1()
IniciarMatriz(MR1, nact, Nper1)
IniciarMatriz(MP, nact, Nper1)
IniciarMatriz(MGantt, nact, Nper1)
MostrarMatriz(MR1, nact, Nper1)

Console.WriteLine("vectores iniciales cadenas 1")
Mostrar3VectoresC(Act, Asig, T, nact)
ncad1 = FormarCadenas(Act, Asig, Cadenas1, nact)
Console.WriteLine(" cadenas 1 todas las relaciones")
MostrarVectorC(Cadenas1, ncad1)
letra = "A"
Nelem = Obtenercadenas2(Cadenas1, CAD1, letra, ncad1)
Console.WriteLine(" las cadenas son {0} ", Nelem)
MostrarCadenas(CAD1, Nelem)
letra = Act(fila)
Nelem = Obtenercadenas3(Cadenas1, CAD1, letra, ncad1, Nelem)
Next
Console.WriteLine(" las cadenas finales {0} ", Nelem)
MostrarCadenas(CAD1, Nelem)
ConvertirCadenasMatriz(CAD1, MR1, ncad1)

Console.WriteLine(" matriz MR1")
MostrarMatriz(MR1, ncad1, nper)
nvec = obtenerVectores(MR1, Act, X, Y, nact)

Console.WriteLine("Nro de vectores {0} ", nvec)
Mostrar2VectoresC(X, Y, nvec)
Nper1 = ProgramaPriliminar(Act, T, MR1, MP, ncad1, nact, nper)

For col = 0 To Nper1 - 1
Periodos(col) = col
Next
MostrarMatriz(MP, nact, Nper1)
Console.WriteLine(" resultado final")
programaGantt(Act, T, MP, MGantt, nact, Nper1)
MostrarMatriz(MGantt, nact, Nper1)
Console.ReadLine()
End Sub
Sub Main()
Iniciar()
Console.ReadLine()
End Sub
End Module
' FORMULARIO
Public Class frmRuta

Sub Mostrar3VectoresF(V1() As String, V2() As String, V3() As Integer, ne As
Integer)
Dim fila As Integer
DataGridView1.Rows(fila).Cells(0).Value = V1(fila)
Next
End Sub
Sub Leer3VectoresF(V1() As String, V2() As String, V3() As Integer, ne As Integer)
Dim fila As Integer
V1(fila) = DataGridView1.Rows(fila).Cells(0).Value
Next
End Sub
Sub Mostrar4VectoresF(V1() As String, V2() As Integer, V3() As Integer, V4() As
Integer, nf As Integer)
Dim fila As Integer
Next
End Sub
Private Sub BtnResultado_Click(sender As Object, e As EventArgs) Handles

BtnResultado.Click
Iniciar()
Mostrar4VectoresF(Act, X, Y, Periodos, nact)
End Sub
Private Sub frmRuta_Load(sender As Object, e As EventArgs) Handles

MyBase.Load
DataGridView1.RowCount = nact
DataGridView1.Columns(0).HeaderText = "Act"
DataGridView1.Columns(1).HeaderText = "Sig"
DataGridView1.Columns(2).HeaderText = "Tiempog"
Iniciar1()
Mostrar3VectoresF(Act, Asig, T, nact)
DataGridView2.Columns(3).HeaderText = "PER"
End Sub
Sub Graficar(Act() As String, X() As Integer, Y() As Integer, ne As Integer)
Dim fila As Integer

Grafico.DrawEllipse(Pen, cx + X(fila) * ex, cy + Y(fila) * ey, CInt(ex / 2), CInt(ey /
2))
Grafico.DrawString(Act(fila), MiFuente, brochaTexto, cx + X(fila) * ex + ex / 16,
cy + Y(fila) * ey + ey / 16)
Next
End Sub
btnGraficar.Click
brochaTexto = New SolidBrush(Color.FromArgb(0, 0, 255))
Graficar(Act, X, Y, nact)
End Sub
Private Sub btnUnir_Click(sender As Object, e As EventArgs) Handles btnUnir.Click

BtnResultado_Click(sender, e)
btnGraficar_Click(sender, e)
Dim fila, nrofila As Integer
Dim letra1, letra2 As String
Dim x1, y1, x2, y2 As Integer
For fila = 0 To ncad1 - 1
letra1 = Cadenas1(fila)(0)
nrofila = EncontrarFilaCadena(plantilla, letra1, nact)
x1 = X(nrofila)
y1 = Y(nrofila)
x2 = X(nrofila)
y2 = Y(nrofila)
Grafico.DrawLine(Pen, cx + x1 * ex + CInt(ex / 2), cy + y1 * ey + CInt(ey / 4), cx
+ x2 * ex, cy + y2 * ey + CInt(ey / 4))
Next
End Sub
Sub MostrarMatriz(Matriz(,) As String, nf As Integer, nc As Integer)
Select Case Matriz(fila, col)
Case "A"
DataGridView3.Rows(fila).Cells(col).Style.BackColor =
Case "B"
Case "C"
Case "D"
Case "E"
Case "F"
Case "G"
Case "H"
End Select
DataGridView3.Rows(fila).Cells(col).Value = Matriz(fila, col)
Next
Next
End Sub
Private Sub btnGantt_Click(sender As Object, e As EventArgs) Handles
btnGantt.Click
btnUnir_Click(sender, e)
Dim col As Integer
DataGridView3.ColumnCount = Nper1
' poner titulos de la columnas
DataGridView3.Columns(0).HeaderText = "Act\Per"
DataGridView3.Columns(col).HeaderText = Periodos(col)
Next
DataGridView3.Rows(fila).HeaderCell.Value = Act(fila)
Next
End Sub
Private Sub DataGridView1_CellContentClick(sender As Object, e As

Windows.Forms.DataGridViewCellEventArgs) Handles DataGridView1.CellContentClick
End Sub
Private Sub btnLeer_Click(sender As Object, e As EventArgs) Handles btnLeer.Click

Leer3VectoresF(Act, Asig, T, nact)
End Sub
Private Sub btnMostrar_Click(sender As Object, e As EventArgs) Handles

btnMostrar.Click
Mostrar3VectoresF (Act,Asig ,T,nact)
End Sub
Private Sub btnBorrarGrafico_Click(sender As Object, e As EventArgs) Handles

btnBorrarGrafico.Click
End Sub

btnBorrar.Click
DataGridView3.Rows.Clear()
DataGridView3.Columns.Clear()
End Sub
End Class
' **** MODULO2

Module Module2
Sub Iniciar()
IniciarMatriz(MR1, nact, Nper1)

MostrarMatriz(MR1, nact, Nper1)
Console.WriteLine("vectores iniciales cadenas 1")

Mostrar2VectoresC(Act, Asig, nact)
ncad1 = FormarCadenas(Act, Asig, Cadenas1, nact)
Console.WriteLine(" cadenas 1 todas las relaciones")
MostrarVectorC(Cadenas1, ncad1)
ncad2 = ObtenerCadenas(Cadenas1, cadenas2, ncad1)
Console.WriteLine(" cadenas 2 todas los recorridos")
MostrarVectorC(cadenas2, ncad2)
' '' eliminar cadenas repitidas
ncad3 = EliminarCadenas(cadenas2, cadenas3, ncad2)
Console.WriteLine(" cadena 3 los que quedan")
MostrarVectorC(cadenas3, ncad3)
ConvertirCadenasMatriz(cadenas3, MR1, ncad3)

nvec = obtenerVectores(MR1, Act, X, Y, nact)
Console.WriteLine("Nro de vectores {0} ", nvec)
Mostrar3Vectoresc(Act, X, Y, nvec)
IniciarMatriz(MGantt, 10, 20)

MostrarMatriz(MR1, ncad, nper)
Nper1 = ProgramaPriliminar(Act, T, MR1, MP, ncad, nact, nper)
Periodos(col) = col
Next
MostrarMatriz(MP, nact, Nper1)
Console.WriteLine(" resultado final")
programaGantt(Act, T, MP, MGantt, nact, Nper1)
Console.ReadLine()
End Sub
Function obtenerVectores(Mred(,) As String, Act() As String, X() As Integer, Y() As
Integer, nact As Integer) As Integer
Dim k, nf1, nc1 As Integer
Dim letra As String
Dim posletra As Boolean
For k = 0 To nact - 1
letra = Act(k)
posletra = EncontrarLetraMatriz(MR1, letra, ncad3, nper, nf1, nc1)
If posletra = True Then
X(cont) = nc1
Y(cont) = nf1
cont = cont + 1
End If
Next
Return cont
End Function
Sub ConvertirCadenasMatriz(Cadenas() As String, Matriz(,) As String, ncad As

Integer)
Dim cad As String
cad = Cadenas(fila)
For col = 0 To Len(cad) - 1
Matriz(fila, col) = cad(col)
Next
Next
End Sub
Function EncontrarLetraMatriz(MR1(,) As String, letra As String, _
nf As Integer, nc As Integer, ByRef nfe As Integer, ByRef nce As
Integer) As Boolean
If letra = MR1(fila, col) Then
nfe = fila
nce = col
encontrado = True
Return encontrado
End If
Next
Next
Return encontrado
End Function
Sub Mostrar2VectoresC(V1() As String, V2() As String, ne As Integer)

Dim fila As Integer
Console.WriteLine("{0}{1}{2}", V1(fila), vbTab, V2(fila))
Next
End Sub
Sub Mostrar3Vectoresc(V1() As String, V2() As Integer, V3() As Integer, ne As
Integer)
Dim fila As Integer
Console.WriteLine("{0}{1}{2} {3}{4}", V1(fila), vbTab, V2(fila), vbTab, V3(fila))
Next
End Sub
Sub MostrarVectorC(V1() As String, ne As Integer)
Dim fila As Integer
Console.WriteLine("{0}", V1(fila))
Next
End Sub
Function EncontrarFila(Cad() As String, letra As String, ne As Integer, posini As
Integer) As Integer
Dim fila As Integer
For fila = posini To ne - 1
If Cad(fila)(0) = letra Then
pos = fila
Exit For
End If
Next
Return pos
End Function
Function EncontrarFilaCadena(Cadena As String, letra As String, ne As Integer) As
Integer
If Cadena(fila) = letra Then
pos = fila
Exit For
End If
Next
Return pos
End Function
Function EncontrarCadena(cadenas() As String, cad1 As String, nf As Integer) As

Integer
Dim fila, pos1 As Integer
Dim valor As Integer = -1
pos1 = InStr(cadenas(fila), cad1)
If pos1 >= 1 Then
valor = pos1 - 1
Exit For
End If
Next
Return valor
End Function
Function EliminarCadenas(cadenas1() As String, cadenas2() As String, ne As
Integer) As Integer
Dim fila As Integer
Dim pos1 As Integer = 0
pos1 = EncontrarCadena(cadenas1, cadenas1(fila), ncad2)
If pos1 <= 0 Then
cadenas2(cont) = cadenas1(fila)
cont = cont + 1
End If
Next
Return cont
End Function
Function ObtenerCadenas(cadenas() As String, cadenas2() As String, ncad As
Integer) As Integer
Dim Posletra1, fila, posini As Integer
Dim cad1 As String
posini = 0
letra2 = cadenas(fila)(0)
cad1 = letra2
Do
Posletra1 = EncontrarFila(cadenas, letra2, ncad, fila)
If (Posletra1 >= 0) Then
letra2 = cadenas(Posletra1)(1)
cad1 = cad1 + letra2
End If
Loop While (Posletra1 >= 0)
cadenas2(cont) = cad1
cont = cont + 1
Next
Return cont
End Function
Function FormarCadenas(V1() As String, V2() As String, V3() As String, nf As
Integer) As Integer
Dim cont As Integer
CadTemporal = V2(fila)
For col = 0 To Len(CadTemporal) - 1
V3(cont) = V1(fila) + CadTemporal(col)
cont = cont + 1
Next
Next
Return cont
End Function
Sub IniciarCadena(cadena() As String, nf As Integer)
Dim col As Integer
For col = 0 To nf - 1
cadena(col) = "X"
Next
End Sub
Sub IniciarMatriz(Matriz(,) As String, nf As Integer, nc As Integer)
Matriz(fila, col) = "X"
Next
Next
End Sub
Sub MostrarMatriz(M(,) As String, nf As Integer, nc As Integer)
Console.Write("{0,2}", M(fila, col))
Next
Console.WriteLine()
Next
End Sub
Function MaxletrasColumnas(MP(,) As String, nf As Integer, nc As Integer)

Dim fila, col, suma As Integer
Dim maxlc As Integer = 0
suma = 0
If MP(fila, col) <> "X" Then
suma = suma + 1
End If
If suma > maxlc Then maxlc = suma
Next
Next
Return maxlc
End Function
Function EncontrarUltimaLetra(MP(,) As String, letra As String, nf As Integer, nc As
Integer) As Integer
Dim res As Integer = -1
For col = nc - 1 To 0 Step -1
If MP(fila, col) = letra Then
res = col
Return res
End If
Next
Next
Return res
End Function
Function ProgramaPriliminar(Act() As String, T() As Integer, Mred(,) As String, ByRef

MGantt(,) As String, _
ncad As Integer, nact As Integer, nper As Integer) As Integer
Dim fila, col, k, i As Integer
Dim letra As String
Dim mayor As Integer = 0
For k = 0 To ncad - 1
cont = 0
For col = 0 To nper - 1
letra = Mred(k, col)
If letra = Act(fila) Then
For i = 0 To T(fila) - 1
MGantt(fila, cont) = letra
cont = cont + 1
Next
End If
Next
If cont > mayor Then mayor = cont
Next
Next
Return mayor
End Function
Sub programaGantt(Act() As String, T() As Integer, MP(,) As String, ByRef MGantt(,)
As String, _
nact As Integer, nper As Integer)
Dim fila, col, ultimo As Integer
Dim letra As String
letra = Act(fila)
ultimo = EncontrarUltimaLetra(MP, letra, nact, nper)
' asignamos
For col = ultimo To ultimo - T(fila) + 1 Step -1
MGantt(fila, col) = letra
Next
Next
End Sub
End Module
' ************* MODULE 1

Module Module1
Public Act() As String = {"A", "B", "C", "D", "E"}
Public Asig() As String = {"BD", "C", "E", "E", ""}
Public brochaTexto As SolidBrush
Public Cadenas1(10) As String ' cadena de secuencias origen destino
Public cadenas2(10) As String ' cadena de secuencias
Public cadenas3(10) As String ' cadena de seceucnias reducidas
Public Const max As Integer = 5
Public maxcol As Integer = 20
Public maxfilas As Integer = 10
Public MGantt(maxfilas, maxcol) As String
Public MP(10, 10) As String
Public MR1(maxfilas, maxcol) As String
'Public MRed(,) As String = {{"A", "B", "C", "E"}, {"A", "D", "E", "X"}}
Public nact As Integer = 5
Public ncad As Integer = 2
Public ncad1 As Integer ' cantidad de cadenas iniciales
Public ncad2 As Integer ' la cantidad de cadenas obtenidas
Public ncad3 As Integer ' cantidad de cadenas despues de eliminar
Public nper As Integer = 4
Public Nper1 As Integer = 15
Public Pen As Pen
Public Periodos(10) As Integer
Public plantilla As String = "ABCDE"
Public redcol As Integer
Public T() As Integer = {2, 3, 4, 5, 2}
Public X(10) As Integer
Public Y(10) As Integer
Public nvec As Integer
Sub Main()
Iniciar()
Console.ReadLine()
End Sub
End Module
' FORMULARIO
Public Class frmRuta

btnIniciar.Click
DataGridView1.Columns(1).HeaderText = "Sig"
End Sub
Sub MostrarVectoresF(V1() As String, V2() As String, ne As Integer)
Dim fila As Integer
Next
End Sub
Private Sub BtnMostrar_Click(sender As Object, e As EventArgs) Handles
BtnMostrar.Click
MostrarVectoresF(Act, Asig, nact)
End Sub
Sub Mostrar4VectoresF(V1() As String, V2() As Integer, V3() As Integer, V4() As
Integer, nf As Integer)
Dim fila As Integer
Next
End Sub
Private Sub BtnResultado_Click(sender As Object, e As EventArgs) Handles

BtnResultado.Click
Iniciar()
Mostrar4VectoresF(Act, X, Y, Periodos, nact)
End Sub
Private Sub frmRuta_Load(sender As Object, e As EventArgs) Handles

MyBase.Load
DataGridView2.Columns(3).HeaderText = "PER"
End Sub
Sub Graficar(Act() As String, X() As Integer, Y() As Integer, ne As Integer)
Dim fila As Integer

Grafico.DrawEllipse(Pen, cx + X(fila) * ex, cy + Y(fila) * ey, CInt(ex / 2), CInt(ey /
2))
Grafico.DrawString(Act(fila), MiFuente, brochaTexto, cx + X(fila) * ex + ex / 16,
cy + Y(fila) * ey + ey / 16)
Next
End Sub
btnGraficar.Click
brochaTexto = New SolidBrush(Color.FromArgb(0, 0, 255))
Graficar(Act, X, Y, nact)
End Sub
Private Sub btnUnir_Click(sender As Object, e As EventArgs) Handles btnUnir.Click

btnIniciar_Click(sender, e)
BtnMostrar_Click(sender, e)
BtnResultado_Click(sender, e)
btnGraficar_Click(sender, e)
Dim fila, nrofila As Integer
Dim letra1, letra2 As String
Dim x1, y1, x2, y2 As Integer
x1 = X(nrofila)
y1 = Y(nrofila)
x2 = X(nrofila)
y2 = Y(nrofila)
Grafico.DrawLine(Pen, cx + x1 * ex + CInt(ex / 2), cy + y1 * ey + CInt(ey / 4), cx
+ x2 * ex, cy + y2 * ey + CInt(ey / 4))
Next
End Sub
Sub MostrarMatriz(Matriz(,) As String, nf As Integer, nc As Integer)
DataGridView3.Rows(fila).Cells(col).Value = Matriz(fila, col)
Next
Next
End Sub
Private Sub btnGantt_Click(sender As Object, e As EventArgs) Handles
btnGantt.Click
btnUnir_Click(sender, e)
Dim col As Integer
DataGridView3.ColumnCount = Nper1
' poner titulos de la columnas
DataGridView3.Columns(0).HeaderText = "Act\Per"
DataGridView3.Columns(col).HeaderText = Periodos(col)
Next
DataGridView3.Rows(fila).HeaderCell.Value = Act(fila)
Next
End Sub

End Sub
End Class
Module Module2
Sub MostrarCadenas(Cadenas() As String, nf As Integer)
Dim fila As Integer
Console.WriteLine("{0}", Cadenas(fila))
Next
End Sub
Function cadenas2(cadenas() As String, cad1() As String, letra As String, ne As
Integer) As Integer
Dim fila As Integer
If letra = cadenas(fila)(0) Then
cont = cont + 1
End If
Next
Return cont
End Function
Dim Cad2(10) As String
Function cadenas3(cadenas() As String, ByRef cad1() As String, letra As String, ne
As Integer, ini As Integer) As Integer
Dim fila As Integer
Dim nf1 As Integer
letra2 = (cadenas(fila)(0))
cont = cont + 1
End If
Next
nf1 = cont
'' trasladra a cadena reemplazando la ultima letra con todas las combinaciones
de cad
cont = 0
For fila = 0 To ini - 1
letra1 = cad1(fila)
largo = Len(letra1)
letra4 = letra1(largo - 1)
' reemplaza con todos los posibles valores
For k = 0 To nf1 - 1
cad3(cont) = cad1(fila) + cad2(k)(1)
cont = cont + 1
Next
Else
cad3(cont) = cad1(fila)
cont = cont + 1
End If
Next
cad1 = cad3
Return cont
End Function
End Module
' FORMAR CADEENA DE PROGRMACIONAcomadar cadena corta a cadena grande

Module Module1
Dim cadenas() As String = {"AB", "AD", "BC", "BD", "CE", "DE"}
Dim act() = {"A", "B", "C", "D", "E"}
Dim nf As Integer = 6
Dim nac As Integer = 5
Dim CAD1(10) As String
Sub main()
Dim letra As String = "A"
Dim nelem As Integer
MostrarCadenas(cadenas, nf)
nelem = cadenas2(cadenas, CAD1, letra, nac)
For fila = 1 To nac - 2
Console.WriteLine(" las cadenas son {0} ", nelem)
MostrarCadenas(CAD1, nelem)
letra = act(fila)
nelem = cadenas3(cadenas, CAD1, letra, nf, nelem)
Next
Console.ReadLine()
End Sub
End Module
1. Diseñe un sistema experto para compra de insumos lácteos utilizando la

metodología CommonKADS.
Defina los sigueintes concetpos

Elementos de un autómata celular (2) grafique
Algoritmos genéticos
Los Algoritmos Genéticos (en adelante AG) son algoritmos de
búsqueda inspirados en procesos de selección natural, basados en la teoría
de la evolución de Darwin. Establecen una analogía entre el conjunto de
soluciones de un problema y el conjunto de individuos de una población
natural. Se aplican principalmente en problemas de optimización y se
comportan de un modo muy eficaz en problemas de superficie compleja,
con múltiples mínimos locales y grandes espacios de búsqueda.
Programación genética
John Koza, en 1992, adaptó los AG para la creación de programas de
computador, permitiendo que las técnicas de Computación Evolutiva se
utilizaran para construir grandes poblaciones de programas que evolucionan
y finalmente obtienen, de forma automática, un programa que constituye la
solución a un problema dado. Él mismo bautizó a esta nueva técnica como
“Genetic Programming” o “Programación Genética”.
Así, la Programación Genética (en adelante PG) surge como una
evolución de los AG tradicionales, manteniendo el mismo principio de
selección natural. Es una técnica de búsqueda en la que, a partir de un
conjunto inicial de programas (población), éstos se van combinando
sucesivamente, formando distintas generaciones para dar lugar a programas
mejores. Al igual que los AG, la PG también forma parte de las
denominadas técnicas de Computación Evolutiva.
ADN molecular
En esta técnica se utiliza el ADN de seres vivos para resolver
problemas computacionales.
Es una técnica masivamente paralela y muy prometedora, pero en la
actualidad el procesado de la información (probetas con piezas de ADN) es
realizado por el investigador y es muy laborioso y lento.
Artificial imnume systems

Estos sistemas están inspirados en el Sistema Inmune Natural. Son
sistemas masivamente paralelos. Permiten detectar situaciones no
habituales, proporcionar una memoria direccionable por contenido o
distinguir entre entradas típicas y anormales. Pueden utilizarse en problemas
de optimización y búsqueda.
Vida artificial
La Vida Artificial trata acerca de la creación de modelos
computacionales con comportamientos biológicos. Se emplean múltiples
agentes simples para conseguir un comportamiento complejo.
Ronald ofrece una de las definiciones más completa: “la Vida
Artificial es una disciplina experimental que consiste fundamentalmente en
la observación de los comportamientos de ejecución, aquellas interacciones
complejas generadas cuando las poblaciones de criaturas artificiales
hechas por el hombre están inmersas en entornos reales o simulados” [13].
En muchos casos se busca determinar los mecanismos de interacción
entre los individuos de una colectividad que hacen emerger
comportamientos adaptativos o inteligentes al nivel de toda la colectividad
de organismos.
Avances en Algoritmos Evolutivos

Jesús A. Hernández1, Julián Dorado2,
Marcos Gestal2
Predicción No Supervisada de Entornos

Cambiantes: Aplicación Práctica al
Problema de las Mareas Rojas
Florentino Fdez-Riverola
Depar
Búsqueda Aproximada de Patrones de

Puntos en 2D y 3D
Arno Formella
Departamento de Informática
Universidad de Vigo
Email: formella@ei.uvigo.es
1.
2. Algoritmos genéticos
Computación Evolutiva y Creatividad

Fernando Jorge Penousal1 y Mª Luisa Santos2
1 Instituto Superior de Ingeniería de Coimbra
3030 Coimbra, Portugal
Computación evolutiva
Creatividad asistida por ordenador
Operadores genéticos
Coloreando las imágenes
Creatividad Computacional
Nuevas Perspectivas en Informática

Médica y Bioinformática
Víctor Maojo1, Fernando Martín2 y José Manuel Vázquez3
Predicción Pesquera Utilizando

Algoritmos Basados en I.A.
José Manuel Cotos1, Alfonso Iglesias2,
Pedro Saco1 y Bernardino Arcay2
1Depto de Electrónica y Computación
Resultados del entrenamiento de redes

Backpropagation y RBF (Radial Basis Function)
El problema que vamos a analizar consiste en determinar
Redes Backpropagation
Un Modo Inteligente de Gestionar el

Conocimiento
Javier Andrade, Santiago Rodríguez y Sonia Suárez
Depto de Tecnologías de la Información y las Comunicaciones
Universidade da Coruña
Email: {jag, santi, ssuarez}@udc.es
Introducción
Con el fin de hacer
Técnicas de Inteligencia Artificial para

el Tratamiento de Datos Astronómicos
Alejandra Rodríguez1, Carlos Dafonte1, Bernardino Arcay1,
Iciar
Redes de neuronas artificiales
BIOINFORMÁTICA: Genética e
Informática
José Mª Barreiro, Juan Pazos1, Alfonso Rodríguez
Autómatas reproductores
La primera aportación de las ciencias
Autorreproducción
Butler en su novela utópica "Erewhon", palabra que, en inglés, es la
imagen especular de "nowhere" que significa en ninguna parte, plantea la
posibilidad de que las máquinas utilicen a los hombres como intermediarios
para construir nuevas máquinas. En el siglo pasado, hubo muchos casos de
331
Descifrado del genoma

El problema
Imports System.IO
Module Module2
Public w1(2) As Single ' matriz de pesos en la capa 1

Public w2(2) As Single ' matriz de pesos en la capa 2
Public x(6) As Single ' entradas a la red
Public y(6) As Single ' salidas deseadas de la red
Public a1(2) As Single ' salida de la capa 1
Public b1(2) As Single ' vector de segos capa 1
Public b2(2) As Single ' vector de segos capa 2
Public s1(2) As Single ' vector de errores de capa 1
Public ya2(6) As Single ' vector de salida obtenida
Sub Iniciar()
'w1(0) = -3
'w1(1) = -1
'w2(0) = -1
'w2(1) = -45
'b1(0) = 6
'b1(1) = 1
'b2(0) = 39
'w1(0) = -16.43
'w1(1) = -157.28
'w2(0) = 6.76
'w2(1) = -10.11
'b1(0) = 3.04
'b1(1) = 150.71
'b2(0) = 6.22
w1(0) = 0
w1(1) = 0
w2(0) = 0
w2(1) = 0
b1(0) = 0
b1(1) = 0
b2(0) = 0
x(0) = -3 : y(0) = 6
x(1) = -2 : y(1) = 3
x(2) = -1 : y(2) = 2
x(3) = 0 : y(3) = 3
x(4) = 1 : y(4) = 6
x(5) = 2 : y(5) = 11
End Sub

Dim i As Integer
For i = 0 To nf - 1
Next
escritor.Close()
End Sub
Dim i As Integer
For i = 0 To nf - 1
Console.WriteLine(" suma {0} = {1}", i, A(i))
Next
End Sub

Dim i As Integer
Dim valor As Single
For i = 0 To nf - 1
A(i) = valor
Next
End Sub
' funcion suma
Next i
Console.WriteLine(" la suma es ")
Mostrar(a1, ne1)
sigmoidea(a1, ne1)
Console.WriteLine("la funcion de la salida es a1 ")
Mostrar(a1, ne1)
'salida de la red
a2 = 0
a2 = a2 + a1(i) * w2(i)
Next i
a2 = a2 + b2(0)
Console.WriteLine("la salida de la capa 2 es {0} ", a2)
Return a2
End Function
End Module
Module Module1
Dim nombreEntrada As String = "e:\datos\errores1.txt"
Dim nombreSalida As String = "e:\datos\errores2.txt"
Sub Main()
Dim i, k As Integer
Iniciar()
Console.WriteLine("probando con los pesos iniciales")
sumacuadratica = 0
For k = 0 To ndatos - 1
entrada = x(k)
SalidaDeseada = y(k)
a2 = Probar(entrada, SalidaDeseada)
ya2(k) = a2
Next
Mostrar(ya2, ndatos)
GrabarVector(ya2, ndatos, nombreEntrada)
Do
sumacuadratica = 0
entrada = x(k)
' funcion suma
Next i
Console.WriteLine(" la suma es ")
Mostrar(a1, ne1)
sigmoidea(a1, ne1)
Console.WriteLine("la funcion de la salida es a1 ")
Mostrar(a1, ne1)
'salida de la red
a2 = 0
a2 = a2 + a1(i) * w2(i)
Next i
a2 = a2 + b2(0)
Console.WriteLine("la salida de la capa 2 es {0} ", a2)
errorsalida = SalidaDeseada - a2
Console.WriteLine("error de la salida es {0} ", errorsalida)
sumacuadratica = sumacuadratica + Math.Pow(errorsalida, 2)
Console.WriteLine("error de la capa de salida ")
Dim s2 As Single
s2 = -2 * (1) * errorsalida
Console.WriteLine("error de la capa de salida s2 {0} ", s2)
' error en la capa oculta
s1(0) = (1 - Math.Pow(a1(0), 2)) * w2(0) * s2
s1(1) = (1 - Math.Pow(a1(1), 2)) * w2(1) * s2
Console.WriteLine("error de la capa de salida 1 ")
Mostrar(s1, ne1)
'Calculo de nuevos pesos
w2(0) = w2(0) - alfa * a1(0) * s2
w2(1) = w2(1) - alfa * a1(1) * s2
Console.WriteLine("Nuevo pesos capa 2 ")
Mostrar(w2, ne1)
b2(0) = b2(0) - alfa * s2
Console.WriteLine("Nuevo b2 {0} ", b2(0))
Console.WriteLine("Nuevo pesos capa 1 ")
w1(0) = w1(0) - alfa * entrada * s1(0)
w1(1) = w1(1) - alfa * entrada * s1(1)
Mostrar(w1, ne1)
Console.WriteLine("Nuevo b en 1 ")
b1(0) = b1(0) - alfa * s1(0)
b1(1) = b1(1) - alfa * s1(1)
Mostrar(b1, ne1)
Next k
Console.WriteLine("Iteracion ={0}", cont)
Console.WriteLine("sumaerrorcuadratico {0} ", sumacuadratica)
cont = cont + 1
Loop Until sumacuadratica < 1 Or cont > 20

Console.WriteLine("sumaerrorcuadratico {0} ", sumacuadratica)
Console.WriteLine("probando con los pesos finales")
sumacuadratica = 0
entrada = x(k)
a2 = Probar(entrada, SalidaDeseada)
ya2(k) = a2
Next
Mostrar(ya2, ndatos)
GrabarVector(ya2, ndatos, nombreSalida)
Console.WriteLine("========RESULTADOS")
Console.WriteLine("pesos en la capa 1 ")
Mostrar(w1, ne1)
Console.WriteLine("sesgos en la capa 1 ")
Mostrar(b1, ne1)
Console.WriteLine("pesos en la capa 2 ")
Mostrar(w2, ne1)
Console.WriteLine("sesgos en la capa 2 ")
Mostrar(b2, ne1)
Console.ReadLine()
End Sub
End Module
EN PROGRAMACION VISUAL
Imports System.IO
Module Module1
Public Const limdatos As Integer = 10
Public nombreErrores As String = "e:\datos\errores.txt"

Public nombreEntrenamiento As String = "e:\datos\entrena.txt"
Public x(limdatos) As Single ' entradas a la red
Public y(limdatos) As Single ' salidas deseadas de la red
Public a1(limite) As Single ' salida de la capa 1
Public s1(limite) As Single ' vector de errores de capa 1
Public ya2(limdatos) As Single ' vector de salida obtenida
Public nveces As Integer = 58
Public prono As Single = 3
Public Ventrena(1000) As Single ' graba la desinuci
Sub Iniciar()
w1(0) = 1
w1(1) = 2
w1(2) = 8
w2(0) = 5
w2(1) = 6
w2(2) = 10
b1(0) = 3
b1(1) = 4
b1(2) = 9
b2(0) = 7
b2(1) = 0
x(1) = -3 : y(1) = 0
x(2) = -2 : y(2) = 5
x(3) = -1 : y(3) = 8
x(4) = 0 : y(4) = 9
x(5) = 1 : y(5) = 8
x(6) = 2 : y(6) = 5
x(7) = 3 : y(7) = 0
alfa = 0.1
End Sub
Dim i As Integer
For i = 0 To nf - 1
Next
escritor.Close()
End Sub
Dim i As Integer
For i = 0 To nf - 1
cadena = cadena + " " + A(i).ToString
Next
Form1.ListBox1.Items.Add(cadena)
End Sub
Dim i As Integer
Dim valor As Single
For i = 0 To nf - 1
A(i) = valor
Next
End Sub
' funcion suma
Next i
Form1.ListBox1.Items.Add(" la suma es ")
Mostrar(a1, ne1)
sigmoidea(a1, ne1)
Form1.ListBox1.Items.Add(" salida de capa 1 a1 ")
Mostrar(a1, ne1)
'salida de la red
a2 = 0
a2 = a2 + a1(i) * w2(i)
Next i
a2 = a2 + b2(0)
Form1.ListBox1.Items.Add(" salida de capa 2 " & a2)
Return a2
End Function
End Module
Problema 2
• El diagrama de la red multicapa se muestra en la figura 1. La red tiene 3 capas
una capa de entrada con una neurona, una capa oculta con dos neuronas y una
capa de salida con 1 neurona
• La función de transferencia en la primera capa es la función tangente Sigmoida
Hiperbólica (Ec. 1).
• Y la función de transferencia en la segunda capa (capa de salida ) es la función
lineal ( Ec. 3)
Los valores de entrada son
PUNTO X Y
0 -3.00 0.00
1 -2.00 5.00
2 -1.00 8.00
3 0.00 9.00
4 1.00 8.00
5 2.00 5.00
6 3.00 0.00
Alfa=0.1
4- Determine la función de salida obtenida para la entrada -3 ( explicar) (3
puntos)
5- Propague el error hacia atrás y calcule los nuevos pesos ( 3 puntos)
6- Elbore un programa en visual Basic modo ocnsola o formulario , o
lenguaje c ( 3 puntos)
Elabore un cuadro compartivo de modleo Modelos usados en sistemas Inteligentes
(minimo 10) ( 3 puntos)
elementos (
Nro. Modelo Descripción grafico) Obs
1 redes neuronales
2 Lógica difusa
3 sistemas expertos
4 algoritmos genéticos
5 autómatas celulares
6 Visón Artificial
7 Vida artificial
8 Robotica
9 Automatizacion
10 Busqueda
11 Adn
Imports System.IO
Module Module2
Public Objetos(maxfilas, maxcol) As String
Public Nfilas As Integer = 30
Public Ncol As Integer = 7
Public NfObjetos As Integer = 8
Public NcObjetos As Integer = 4
Public NombreArchivo As String = "e:\datos\plano5x8.txt"

Public NombreArchivoSalida As String = "e:\datos\plano5x8Salida.txt"
Public NombreArchivoObjetos As String = "e:\datos\Objetos.txt"
Public Color1 As Integer = 0 ' si es cero es color azul

Public AltoLetra As Integer = 12
Public Cadena As String
Function BuscarCadena(A(,) As String, nf As Integer, letra As String) As Integer

Dim fila, posletra As Integer
posletra = -1
If Trim(A(fila, 6)) = letra Then
posletra = fila
Exit For
End If
Next
Return posletra
End Function
Sub MostrarMatriz(ByVal A(,) As String, ByVal nf As Integer, ByVal nc As Integer)

Console.Write("{0} {1} ", A(fila, col), vbTab)
Next
Console.WriteLine()
Next
End Sub
Sub GrabarMatriz(NombreArchivo As String, ByVal A(,) As String, ByVal nf As

archivo = New StreamWriter(NombreArchivo)
archivo.Write("{0} {1} ", A(fila, col), vbTab)
Next
archivo.WriteLine()
Next
archivo.Close()
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByRef A(,) As String, ByVal nf
inicio = 1
inicio = pos + 1
Next
Next
srLector.Close()
End Sub
End Module
Module Module1
Dim cadena As String = "ABCEFG"
Sub main()
Dim fila, col, posletra As Integer
RecuperarMatriz(NombreArchivoObjetos, Objetos, NfObjetos, NcObjetos)
MostrarMatriz(Objetos, NfObjetos, NcObjetos)
RecuperarMatriz(NombreArchivo, A, Nfilas, Ncol) ' recupera la matriz A
' MostrarMatriz(A, Nfilas, Ncol)
' For fila = 0 To NfObjetos - 1
Dim sumaX, sumaY As Single
Dim npuntos As Integer
For fila = 0 To 0
sumaX = 0
sumaY = 0
npuntos = Len(cadena)
Console.WriteLine("datos de la fila {0} ={1}", fila, Objetos(fila, 2))
cadena = Objetos(fila, 2)
For col = 0 To npuntos - 1

' Console.WriteLine("{0}", cadena(col))
posletra = BuscarCadena(A, Nfilas, cadena(col))
Console.WriteLine("posletra {0}", posletra)
Console.WriteLine("datos de la fila {0}", posletra)
If posletra >= 0 Then
sumaX = sumaX + A(posletra, 1)
sumaY = sumaY + A(posletra, 2)
End If
Next
Console.WriteLine("suma x {0} ", sumaX / npuntos)
Console.WriteLine("suma Y {0} ", sumaY / npuntos)
Next
Console.ReadLine()
End Sub
End Module
Public Class Form1

Dim grafico As Graphics
Dim lapiz1 As Pen
Dim lapiz2 As Pen
Dim lapiz As Pen
Dim ex As Single = 40
Dim ey As Single = 40

Dim MiFuente As New Font("Verdana", AltoLetra, FontStyle.Bold)
Dim PosFila As Integer
Dim PosCol As Integer
Sub ProcesarFila(A(,) As String, nf As Integer, nc As Integer, FilaNro As Integer,
color1 As Integer)
Dim x1, y1, ancho, alto As Single
Dim tipo As String
Dim Nro As Integer
Nro = CInt(A(FilaNro, 0))

x1 = CSng(A(FilaNro, 1))
y1 = CSng(A(FilaNro, 2))
ancho = CSng(A(FilaNro, 3))
alto = CSng(A(FilaNro, 4))
Select Case color1
Case 0
lapiz = lapiz1
brocha = brocha1
Case 1
lapiz = lapiz2
brocha = brocha2
End Select
tipo = A(FilaNro, 5)
Select Case Trim(tipo)
Case "PARED"
grafico.FillRectangle(brocha, x1 * ex, y1 * ey, ancho * ex, alto * ey)
Case "V1"
grafico.DrawRectangle(lapiz, x1 * ex, y1 * ey, ancho * ex, alto * ey)
grafico.DrawRectangle(lapiz, x1 * ex, y1 * ey + alto * ey / 3, ancho * ex, alto *
ey / 4)
Case "V2"
grafico.DrawRectangle(lapiz, x1 * ex, y1 * ey, ancho * ex, alto * ey)
grafico.DrawRectangle(lapiz, x1 * ex + ancho * ex / 3, y1 * ey, ancho * ex / 4,
alto * ey)
End Select
End Sub
Private Sub Procesar1(sender As Object, e As EventArgs) Handles btnProcesar.Click
' For fila = 0 To maxfilas - 1
For fila = 0 To 27
ProcesarFila(A, Nfilas, Ncol, fila, Color1)
Next
End Sub

lapiz = New Pen(Brushes.Green, 1)
lapiz1 = New Pen(Brushes.Blue, 1)
lapiz2 = New Pen(Brushes.Red, 1)
brocha1 = New SolidBrush(Color.Blue)
brocha2 = New SolidBrush(Color.Red)
brocha3 = New SolidBrush(Color.Yellow)
End Sub
Sub MostrarCuadricula(A(,) As String, nf As Integer, nc As Integer)
DataGridView1.ColumnCount = nc
DataGridView1.Columns(3).HeaderText = "Ancho"
DataGridView1.Columns(4).HeaderText = "Alto"
DataGridView1.Columns(5).HeaderText = "Tipo"
DataGridView1.Columns(6).HeaderText = "Titulo"
Next
Next
Next
Next
' DataGridView1.Refresh()
End Sub
Sub ModificarMatrizdeCuadricula(A(,) As String, nf As Integer, nc As Integer)
A(fila, col) = DataGridView1.Rows(fila).Cells(col).Value
Next
Next
' DataGridView1.Refresh()
End Sub
Private Sub BtnAbrir_Click(sender As Object, e As EventArgs) Handles BtnAbrir.Click

RecuperarMatriz(NombreArchivo, A, Nfilas, Ncol)
MostrarCuadricula(A, Nfilas, Ncol)
End Sub
Private Sub btnModificar_Click(sender As Object, e As EventArgs) Handles

btnModificar.Click
ModificarMatrizdeCuadricula(A, Nfilas, Ncol)
ProcesarFila(A, Nfilas, Ncol, PosFila, Color1)
End Sub

Windows.Forms.DataGridViewCellEventArgs) Handles DataGridView1.CellClick
PosFila = DataGridView1.CurrentCell.RowIndex
PosCol = DataGridView1.CurrentCell.ColumnIndex
txtFila.Text = PosFila
txtCol.Text = PosCol
txtValor.Text = DataGridView1.Rows(PosFila).Cells(PosCol).Value
ListBox1.Items.Add("Nro= " & A(PosFila, 0))
ListBox1.Items.Add(" X = " & A(PosFila, 1))

ListBox1.Items.Add("Y = " & A(PosFila, 2))
ListBox1.Items.Add(" ANCHO = " & A(PosFila, 3))
ListBox1.Items.Add(" ALTO = " & A(PosFila, 4))
ListBox1.Items.Add(" TIPO = " & A(PosFila, 5))
ListBox1.Items.Add(" TITULO = " & A(PosFila, 5))
ProcesarFila(A, Nfilas, Ncol, PosFila, 1)

End Sub
BtnBorrar.Click
End Sub

btnGrabar.Click
GrabarMatriz(NombreArchivoSalida, A, Nfilas, Ncol)
End Sub
Private Sub DataGridView1_CellContentClick_1(sender As Object, e As
End Sub
Private Sub btnPonerTitulo_Click(sender As Object, e As EventArgs) Handles

btnPonerTitulo.Click
Dim Titulo As String
Dim fila As Integer
Dim x1, y1, ancho, alto As Single
For fila = 0 To 29
x1 = CSng(A(fila, 1))
y1 = CSng(A(fila, 2))
ancho = CSng(A(fila, 3))
alto = CSng(A(fila, 4))
Titulo = A(fila, 6)
grafico.DrawString(Titulo, MiFuente, brocha3, x1 * ex + ancho * ex / 2, y1 * ey +
alto * ey / 2 - AltoLetra)
Next
End Sub
Sub MostrarObjetos(Objetos(,) As String, nc As Integer, nroobjeto As Integer, ByRef
Px As Single, ByRef py As Single)
Dim Cadena1, letra As String
Dim col As Integer
Dim sumaX, sumaY, sAncho, sAlto As Single
Dim npuntos, posletra As Integer
Dim pancho, palto As Single
sumaX = 0
sumaY = 0
sAncho = 0
sAlto = 0
Cadena1 = Objetos(nroobjeto, 2)
npuntos = Len(Cadena1)
For col = 0 To npuntos - 1

letra = Cadena1(col)
posletra = BuscarCadena(A, Nfilas, letra)
If posletra >= 0 Then
sumaX = sumaX + A(posletra, 1)
sumaY = sumaY + A(posletra, 2)
sAncho = sAncho + A(posletra, 3)
sAlto = sAlto + A(posletra, 4)
End If
Next
pancho = sAncho / npuntos
palto = sAlto / npuntos
Px = sumaX / npuntos + pancho - pancho

py = sumaY / npuntos + palto - palto / 2
ListBox1.Items.Add("suma x " & Px)
ListBox1.Items.Add("suma Y " & py)
End Sub
Private Sub btnAbrirObjetos_Click(sender As Object, e As EventArgs) Handles
btnAbrirObjetos.Click
RecuperarMatriz(NombreArchivoObjetos, Objetos, NfObjetos, NcObjetos)
MostrarMatriz(Objetos, NfObjetos, NcObjetos)
DataGridView2.RowCount = NfObjetos + 1
DataGridView2.ColumnCount = NcObjetos
DataGridView2.Columns(1).HeaderText = "SIMBOLO"
DataGridView2.Columns(2).HeaderText = "COMPONENTES"
DataGridView2.Columns(3).HeaderText = "NOMBRE"
For col = 0 To NcObjetos - 1
Next
For fila = 0 To NfObjetos - 1
Next
For col = 0 To NcObjetos - 1
DataGridView2.Rows(fila).Cells(col).Value = Objetos(fila, col)
Next
Next
RecuperarMatriz(NombreArchivo, A, Nfilas, Ncol) ' recupera la matriz A
End Sub
Private Sub btnMostrarObjeto_Click(sender As Object, e As EventArgs) Handles
btnMostrarObjeto.Click
Dim titulo As String
Dim posfila1, poscol1 As Single

MostrarObjetos(Objetos, NcObjetos, fila, posfila1, poscol1)
titulo = Objetos(fila, 3)
grafico.DrawString(titulo, MiFuente, brocha3, posfila1 * ex, poscol1 * ey)
Next
End Sub
End Class
TRANSPARENCIAS
En la sigueinte aplicacion se puede puede mover el objeto trnsaparente.
Hacer modelos de trnsaparencia d evidreo
Public Class Form1

Public px As Integer = 100
Public py As Integer = 100
Public alfa As Integer = 120
Public rojo As Integer = 120
Public verde As Integer = 120
Public azul As Integer = 120
Public brocharoja As SolidBrush
Public brochaverde As SolidBrush
Public brochaazul As SolidBrush
Public Pict1 As Bitmap
brocha = New Drawing.SolidBrush(Drawing.Color.Blue)
brocharoja = New Drawing.SolidBrush(Drawing.Color.Red)
brochaverde = New Drawing.SolidBrush(Drawing.Color.Green)
brochaazul = New Drawing.SolidBrush(Drawing.Color.Blue)
End Sub

btnIniciar.Click
PictureBox1.Refresh()
alfa = txtAlfa.Text
rojo = txtRojo.Text
verde = txtVerde.Text
azul = txtAzul.Text
px = txtCx.Text
py = txtCy.Text
ancho = txtAncho.Text
alto = txtAlto.Text
brocha.Color = Color.FromArgb(alfa, rojo, verde, azul)
grafico.FillEllipse(brocha, px, py, ancho, alto)
End Sub
Private Sub HSalfa_Scroll(sender As Object, e As ScrollEventArgs) Handles

HSalfa.Scroll
txtAlfa.Text = HSalfa.Value
End Sub
Private Sub HSrojo_Scroll(sender As Object, e As ScrollEventArgs) Handles

HSrojo.Scroll
txtRojo.Text = HSrojo.Value
End Sub
Private Sub HSverde_Scroll(sender As Object, e As ScrollEventArgs) Handles

HSverde.Scroll
txtVerde.Text = HSverde.Value
End Sub
Private Sub HSAzul_Scroll(sender As Object, e As ScrollEventArgs) Handles

HSAzul.Scroll
txtAzul.Text = HSAzul.Value
End Sub
Private Sub HSCx_Scroll(sender As Object, e As ScrollEventArgs) Handles

HSCx.Scroll
txtCx.Text = HSCx.Value
End Sub
Private Sub HSCy_Scroll(sender As Object, e As ScrollEventArgs) Handles

HSCy.Scroll
txtCy.Text = HSCy.Value
End Sub
Private Sub HSAncho_Scroll(sender As Object, e As ScrollEventArgs) Handles
HSAncho.Scroll
txtAncho.Text = HSAncho.Value
End Sub
Private Sub HSAlto_Scroll(sender As Object, e As ScrollEventArgs) Handles

HSAlto.Scroll
txtAlto.Text = HSAlto.Value
End Sub
Private Sub txtMover_KeyDown(sender As Object, e As KeyEventArgs) Handles

txtMover.KeyDown
Case Keys.Left
If px > 0 Then px = px - 1
txtCx.Text = px
Case Keys.Right
If px < 555 Then px = px + 1
txtCx.Text = px
Case Keys.Up
If py > 0 Then py = py - 1
txtCy.Text = py
Case Keys.Down
If py < 555 Then py = py + 1
txtCy.Text = py
End Select
End Sub
Private Sub btPrueba_Click(sender As Object, e As EventArgs) Handles

btPrueba.Click
alfa = txtAlfa.Text
brocharoja.Color = Color.FromArgb(255, 255, 0, 0)
brochaverde.Color = Color.FromArgb(alfa, 0, 255, 0)
brochaazul.Color = Color.FromArgb(alfa / 2, 0, 0, 255)
grafico2.FillEllipse(brocharoja, 50, 50, 200, 150)
grafico2.FillEllipse(brochaverde, 150, 50, 200, 150)
grafico2.FillEllipse(brochaazul, 100, 100, 200, 150)
End Sub
End Class
Juego de la vida
'**************** modulo 2
Imports System.IO
Module Module2
Public A(maxfilas, maxcol) As Integer
Public B(maxfilas, maxcol) As Integer
Public Modelo(maxfilas, maxcol) As Integer
Public ng As Integer = 200
Sub VerPantalla(cx As Integer, cy As Integer, ByVal A(,) As Integer, ByVal nf As

Console.SetCursorPosition(cx + col, cy + fila)
If (A(fila, col) > 0) Then
Console.Write("*")
Else
Console.Write(" ")
End If
Next
Next
End Sub
Sub CopiarMatriz(ByVal A(,) As Integer, B(,) As Integer, ByVal ancho As Integer,
ByVal alto As Integer)
Next
Next
End Sub
Sub JuegoVida(ByVal A(,) As Integer, B(,) As Integer, ByVal nf As Integer, ByVal nc
As Integer)
Dim fila, col, vecinos, x1, y1, x2, y2, fila1, col1 As Integer
vecinos = 0
If fila > 0 Then
y1 = fila - 1
Else
y1 = fila
End If
If fila < nf - 2 Then
y2 = fila + 1
Else
y2 = fila
End If
If col > 0 Then
x1 = col - 1
Else
x1 = col
End If
If col < nc - 2 Then
x2 = col + 1
Else
x2 = col
End If
For fila1 = y1 To y2
For col1 = x1 To x2
If (fila1 = fila And col1 = col) Then Continue For
If A(fila1, col1) = 1 Then vecinos = vecinos + 1
Next
Next
Select Case vecinos
Case 0
B(fila, col) = 0
Case 1
B(fila, col) = 0
Case 2
Case 3
B(fila, col) = 1
Case Else
B(fila, col) = 0
End Select
Next
Next
'Console.Clear()
CopiarMatriz(B, A, nf, nc)
End Sub
Sub RecuperarMatriz(ByVal nombrearchivo As String, ByRef A(,) As Integer, ByVal nf As

inicio = 1
inicio = pos + 1
Next
Next
srLector.Close()
End Sub
End Module
'******************modulo 1
Module Module1
Sub Main()
Console.Write("juego de la vida de wonway")
Console.Write("Diseño escenarioen Excel y grabe archivo con bloque de notas ")
Console.Write("juego de la vida de wonway")
RecuperarMatriz("E:\datos\modelo40x20.txt", Modelo, nf, nc)
CopiarMatriz(Modelo, A, nc, nf)
VerPantalla(10, 4, A, nf, nc)
Console.ReadLine()
While (1)
'For i = 0 To ng
JuegoVida(A, B, nf, nc)
VerPantalla(10, 4, A, nf, nc)
'System.Threading.Thread.Sleep(10) ' 1 segundo
'Next
End While
Console.ReadLine()
End Sub
End Module
Public Class FrmVida
Public borrador As SolidBrush
Sub VerPantallaGrafica(cx As Integer, cy As Integer, ByVal A(,) As Integer, ByVal nf

As Integer, ByVal nc As Integer, _
ex As Single, ey As Single)
Select Case A(fila, col)
Case 0
grafico.FillRectangle(borrador, cx + col * ex, cy + fila * ey,
ex, ey)
Case 1
grafico.FillRectangle(brocha, cx + col * ex, cy + fila * ey, ex,
ey)
Case 2
grafico.FillRectangle(Brushes.Red, cx + col * ex, cy + fila * ey,
ex, ey)
Case 3
grafico.FillRectangle(Brushes.Green, cx + col * ex, cy + fila *
ey, ex, ey)
End Select
Next
Next
End Sub

BtnIniciar.Click
RecuperarMatriz("E:\datos\juego40x40.txt", Modelo, nf, nc)

CopiarMatriz(Modelo, A, nc, nf)
VerPantallaGrafica(cx, cy, A, nf, nc, ex, ey)
cont = 0
txtContGeneracion.Text = cont
End Sub
Private Sub FrmVida_Load(sender As Object, e As EventArgs) Handles MyBase.Load

grafico = PictureBox1.CreateGraphics()
brocha = New SolidBrush(Color.Yellow)
borrador = New SolidBrush(Color.Blue)
End Sub
Private Sub BtnJugar_Click(sender As Object, e As EventArgs) Handles BtnJugar.Click

JuegoVida(A, B, nf, nc)
VerPantallaGrafica(cx, cy, A, nf, nc, ex, ey)
cont = cont + 1
txtContGeneracion.Text = cont
End Sub

Timer1.Start()
End Sub

BtnDetener.Click
Timer1.Stop()
End Sub

BtnJugar_Click(sender, e)
End Sub
End Class

Lp11 Aplicaciones Windows Form

Cargado por

Información del documento

Derechos de autor

Formatos disponibles

Compartir este documento

Compartir o incrustar documentos

Opciones para compartir

¿Le pareció útil este documento?

¿Este contenido es inapropiado?

Copyright:

Formatos disponibles

Lp11 Aplicaciones Windows Form

Cargado por

Copyright:

Formatos disponibles

Lenguaje de programación 2015 \11 Aplicaciones Windows Forms \Ismael Véliz Vilca -745-

11 APLICACIONES EN WINDOWS FORM

11-30 PROCESAMIENTO DE IMAGNES EN VISUAL BASIC 2012 995

11.34 TRANSFORMACIONES CON BITMAPS 1031

11.1 EJEMPLO DE APLICACIÓN COMPLETA CON MENUS Y BARRA DE

1. TRABAJANDO CON INTERFACES DE MULTIPLES DOCUMENTOS

1. Crear un Aplicación Windows en Visual Basic .NET llamado FormularioMDI

Objeto Propiedad Valor

3. Seleccione el control MenuStrip1 y en la parte superior donde dice “Escriba aqui”,

Objeto Propiedad Valor

Aparece el siguiente cuadro

Hay podria cambiar los nombres

Objeto Propiedad Valor

Al final debe quedar así

5. Seleccione el control StatusStrip1 y Clic al botón de editar elementos luego añadir

Objeto Propiedad Valor

Objeto Propiedad Valor

9. Regresar al formulario frmEditor y en la ventana explorador de soluciones dar

CODIGO DEL FORMULARIO

Imports System.IO 'Usar Path

Private Sub AbrirDocumento(ByVal sender As System.Object, ByVal e As

Private Sub GuardarDocumento(ByVal sender As System.Object, ByVal e As

Private Sub CopiarTexto(ByVal sender As System.Object, ByVal e As

Private Sub CambiarColorFondo(ByVal sender As System.Object, ByVal e As

Private Sub AbrirWord(ByVal sender As System.Object, ByVal e As

Private Sub MostrarNombre(ByVal sender As Object, ByVal e As System.EventArgs)

Ejecute el programa . la aplicación debera quedar asi

Nota clic derecho en el menú strip y clic en insertar elementos estándar

Al presionar editar elementos aparece el cuadro

Que nos permite editar los elementos

FRACTAL De Wikipedia, la enciclopedia libre

En la naturaleza también aparece la geometría

Alfombra de Sierpinski De Wikipedia, la enciclopedia libre

Paso 1 Paso 2 Paso 3 Paso 4 Paso 5

Código en Visual Basic (Ver en la aplicación)

Triángulo de Sierpinski De Wikipedia, la enciclopedia libre

CREACION DE UNA MONTAÑA FRACTAL

Considerando los cuatros triangulos

Aleatorizando (modelizacion de terrenos )

ARBOLES CON RECURSIVIDAD

Copo de nieve de Koch

El copo de nieve de Koch, también llamado estrella de

Código en Visual Basic ( ver en la aplicacion)

CODIGO EN VISUAL BASIC

CODIGO DEL MODULO 1

CODIGO DEL FORMULARIO

Private Sub MnuArbolFractal_Click(sender As Object, e As EventArgs) Handles

CODIGO DEL FORMULARIO FRMALFOMBRA

Public Class FrmAlfombra

Sub CuadroRecursivo(ByVal Cx As Integer, ByVal Cy As Integer, ByVal Ancho As

Private Sub frmFractal_Paint(sender As Object, e As PaintEventArgs) Handles

Private Sub FrmAlfombra_Load(sender As Object, e As EventArgs) Handles

CODIGO DEL FORMULARIO FRMTRIANGULO

Public Class frmTriangulo

Private Sub frmTriangulo_Paint(sender As Object, e As PaintEventArgs) Handles

CODIGO DEL FORMULARIO MONTAÑA FRACTAL

Public Class frmMontaña

Private Sub frmMontaña_Paint(sender As Object, e As PaintEventArgs) Handles

Private Sub frmMontaña_Load(sender As Object, e As EventArgs) Handles

CODIGO DEL FORMULARIO FRMARBOL

Public Class FrmArbol

Sub Arbol(ByVal x As Single, ByVal y As Single, ByVal t As Single, ByVal teta As

Private Sub FrmArbol_Load(sender As Object, e As EventArgs) Handles

CODIGO DEL FORMULARIO COPODE NIEVE