Aprendiendo Standard ML

Diego Bravo Estrada

Historial de revisiones
Revisión 0.725 de Agosto 2015DBE
Validador lógico y programa interactivo de matrices
Revisión 0.64 de Agosto 2015DBE
Sección archivos Octave
Revisión 0.53 de Agosto 2015DBE
Sección de matrices
Revisión 0.428 de Julio 2015DBE
Operaciones con registros; mejoras en bibliografía
Revisión 0.325 de Julio 2015DBE
Mejoras diversas de estilo, rlwrap
Revisión 0.223 de Julio 2015DBE
Se agregan ejemplos basicos para la primera parte
Revisión 0.118 de Julio 2015DBE
Se inicia el documento

Tabla de contenidos

1. Introducción
2. Ejemplos de Sintaxis Básica
2.1. Recursividad
2.2. Call by Value
2.3. Textos Palíndromos
2.4. Patrones de Listas
2.5. Solución de ecuación cuadrática
2.6. Listas
2.7. Operaciones de Polinomios
2.8. Referencias para Programación Interactiva
3. Interacción con el usuario
3.1. Trimming condicional
3.2. Implementación del trimming
3.3. Una estructura de trimming
3.4. Un loop interactivo
4. Resolviendo triángulos
4.1. Funciones utilitarias
4.2. Completar ángulos
4.3. Soluciones no triviales
4.4. Soluciones y Rotaciones
4.5. Aplicación sistemática de métodos de solución
4.6. Verificación de resultados
5. Generador de números primos
5.1. Estructura de números primos
5.2. Aplicación principal
5.3. Implementación alterna
5.4. Test de performance
6. Operando con Registros
6.1. Totalizando el almacén
6.2. Leer y Escribir Registros
6.3. Categorías para los Productos
7. Validacion de argumentos en logica proposicional
7.1. Nota breve sobre los argumentos
7.2. Programa principal
7.3. Obtención de tokens
7.4. Obtención de expresiones lógicas
8. Operando con Matrices
8.1. Utilizando Arrays
8.2. Definiendo operadores
8.3. Una firma para matrices
8.4. Estructura Matrix
8.5. Interactuando con las matrices
8.6. Usando Archivos de Octave
Bibliografía

1. Introducción

Este tutorial ilustra algunos conceptos del lenguaje Standard ML (SML) a través de una serie de ejemplos que esperamos resulten interesantes.

Los ejemplos han sido probados con SML/NJ y Poly/ML en XUbuntu 14.04. La instalación es tan simple como:

sudo apt-get install smlnj

o también:

sudo apt-get install polyml

En lo que sigue asumiremos SML/NJ pero esto es indistinto.

Nota

Para repetir y corregir con facilidad el texto introducido en la línea de comandos, es recomendable el uso de rlwrap a fin de incorporar las facilidades de la librería readline (usar rlwrap sml o rlwrap poly.)

2. Ejemplos de Sintaxis Básica

2.1. Recursividad

Empezaremos con una típica función recursiva para obtener el factorial de un número natural:

(* fact1.sml *)
fun fact1 0 = 1
  | fact1 n = n * fact1 (n - 1);

Esto puede tipearse directamente en la línea de comand de sml/poly, pero asumiremos que lo hemos guardado en un archivo llamado fact1.sml. Lo ejecutamos desde el shell con sml así:

$ sml fact1.sml
Standard ML of New Jersey v110.76 [built: Tue Oct 22 14:04:11 2013]
[opening fact1.sml]
val fact1 = fn : int -> int
- fact1 4;
val it = 24 : int
- fact1(10);
val it = 3628800 : int
- fact1 15;

uncaught exception Overflow [overflow]
  raised at: <file fact1.sml>

Tras ejecutar el código, se inicia una sesión interactiva. Allí probamos a fact1(). Es evidente la recurrencia en la definición de esta función.

Nota

Es idéntico invocar fact1 4 que fact1(4). Las funciones reciben exactamente un argumento, el cual puede ser una tupla, para lo cual sí debe emplearse la sintaxis f (a,b). Usualmente no se agregan parántesis de no ser necesario.

Nota

fact 2 - 4 es igual que (fact 2) - 4, es decir, la función tiene más precedencia que otros operadores.

Nota

Otra manera de ejecutar el archivo fact1.sml desde la línea de comando de SML (no desde el shell) es mediante el comando SML use "fact1.sml";.

2.2. Call by Value

SML intenta evaluar las expresiones de manera recursiva siguiendo un patrón "call by value", lo que significa que para evaluar f(E) primero debe evaluarse E. Para nuestro caso, la evaluación de fact1 4 requiere estos pasos:

fact1(4)
4 * fact1(4 - 1)
4 * fact1(3)
4 * (3 * fact1(3 - 1))
4 * (3 * fact1(2))
4 * (3 * (2 * fact1(2 - 1)))
4 * (3 * (2 * fact1(1)))
4 * (3 * (2 * (1 * fact1(1 - 1))))
4 * (3 * (2 * (1 * fact1(0))))
4 * (3 * (2 * (1 * 1)))
4 * (3 * (2 * 1))
4 * (3 * 2)
4 * 6
24

Esta evaluación requiere de un almacenamiento temporal extenso, lo que es ineficiente para valores elevados. Es posible optimizar este proceso a costa de perder algo de claridad.

(* fact2.sml *)
fun fact2aux (a,0) = a
  | fact2aux (a,n) = fact2aux(a * n, n - 1);
fun fact2 n = fact2aux(1, n);

La secuencia de evaluación para fact2 4 es:

fact2aux (1, 4)
fact2aux (1 * 4, 4 - 1)
fact2aux (4, 3)
fact2aux (4 * 3, 3 - 1)
fact2aux (12, 2)
fact2aux (12 * 2, 2 - 1)
fact2aux (24, 1)
fact2aux (24 * 1, 1 - 1)
fact2aux (24, 0)
24

A esto se le conoce como evaluación "tail recursive".

Área de un círculo. 

(* circle1.sml: evaluacion de area de un circulo *)
fun power(x, 0) = 1.0
  | power(x, n) = x * power(x, n - 1);

fun area_circulo radio = Math.pi * power (radio,2);

Como se aprecia, debe pasarse un argumento real:

val area_circulo = fn : real -> real
- area_circulo 2.0;
val it = 12.5663706144 : real
- area_circulo 2;
stdIn:2.1-2.15 Error: operator and operand don't agree [literal]
  operator domain: real
  operand:         int
  in expression:
    area_circulo 2

Otros ejemplos básicos a continuación.

(* definir una funcion para calcular la hipotenusa de
 * un triangulo rectangulo *)
fun g12 (x, y) = Math.sqrt(x * x + y * y);

(* definir una funcion f(n) = 1 + 2 + 3 + ... + n
 * para n mayor o igual que cero *)
fun f13 0 = 0
  | f13 n = n + f13 (n - 1);

(* definir sum(m,n) = m + (m+1) + (m+2) + ... + (m+n) *)
fun sum14(m, 0) = m
  | sum14(m, n) = m + n + sum14(m, n - 1);

(* obtener numeros de fibonacci: F0=0, F1=1,
 * Fn = F[n-1] + F[n-2] *)
fun f15 0 = 0
  | f15 1 = 1
  | f15 n = f15 (n-1) + f15 (n-2);

2.3. Textos Palíndromos

Considérese las siguientes implementaciones de una función que reporta si un texto es o no palíndromo (string→bool.) La primera ilustra las funciones String.sub() (obtener un caracter de la cadena de texto), String.substring() (obtener una subcadena de texto) y size() (obtener la longitud de una cadena de texto.) Nótese que también se puede utilizar String.size() y substring(); esto ocurre por motivos históricos, siendo preferible emplear el prefijo correspondiente a la "estrcutura" correspondiente.

fun palindromo s =
    if size s <= 1 then true
    else if String.sub (s,0) = String.sub(s, size s - 1) then
        palindromo (String.substring(s, 1, size s - 2))
        else false;

La siguiente versión ilustra el uso de los operadores lógicos andalso y orelse (conjunción y disyunción lógica):

fun palindromo2 s =
  size s <= 1 orelse
    (
        String.sub (s,0) = String.sub(s, size s - 1)
    andalso
        palindromo2 (String.substring(s, 1, size s - 2))
    );

La última versión es más abreviada. Aprovecha la posibilidad de comparar listas de elementos (en este caso, listas de caracteres) y la posibilidad de invertir el orden de elementos de listas con rev():

fun pal3 s = String.explode(s) = rev(String.explode(s));

2.4. Patrones de Listas

Implementaremos dos funciones para contar cuántas ocurrencias de cierto caracter existen en un texto.

fun cntcaux (h::xs, ch) = if h = ch then 1 + cntcaux(xs,ch) else cntcaux(xs,ch)
  | cntcaux  (_, ch) = 0;
fun cntc(s,ch) = cntcaux(String.explode s, ch);

La función cntcaux recibe un par conteniendo una lista de caracteres y un caracter. En el primer patrón, la sintaxis h::xs significa que se trata de una lista cuyo primer elemento es h, y el resto es xs. Lo más importante es comprender que esto significa que el patrón requiere de listas con al menos un elemento (que se asignará a h.) De otro lado, el segundo patrón se invoca cuando se proporciona una lista vacía, y utiliza el underscore (_) como comodín.

En el ejemplo de uso, observar la (engorrosa) sintaxis para especificar un caracter (#"c"):

- cntc("Ratrunadora", #"a");
val it = 3 : int

Nota

Es muy probable que cntcaux() sólo sea utilizada en el contexto de cntc(); en tal sentido puede ser recomendable definirla como "local" a ésta. Una forma de lograrlo es mediante let como se verá más adelante.

2.5. Solución de ecuación cuadrática

exception Solve;

fun solve(a,b,c) =
  if b * b - 4.0 * a * c < 0.0 orelse Real.==(a, 0.0) then raise Solve
  else ((~b + Math.sqrt(b * b - 4.0 * a * c)) / (2.0 * a),
        (~b - Math.sqrt(b * b - 4.0 * a * c)) / (2.0 * a));

Ejemplo de ejecución:

- solve(1.0,~5.0,6.0);
val it = (3.0,2.0) : real * real
- solve(1.0,1.0,1.0);

uncaught exception Solve
  raised at: solve1.sml:4.66-4.71

El ejemplo muestra el uso de excepciones (en nuestro caso, la excepción definida como Solve.)

El cálculo del discriminante se realiza en tres oportunidades, lo cual es ineficiente. Podríamos calcularlo como una variable previa a la función, o mediante otra función auxiliar, pero más adecuado es obtenerlo como un valor "local" a la función de solución. Para esto empleamos let:

exception Solve;

fun solve(a,b,c) =
  let val d = b * b - 4.0 * a * c
  in if d < 0.0 orelse Real.==(a, 0.0) then raise Solve
  else ((~b + Math.sqrt d) / (2.0 * a),
        (~b - Math.sqrt d) / (2.0 * a))
  end;

La sintaxis es let dec in e end; las declaraciones dec no se propagan al entorno exterior, y sólo aplican en la evaluación de e.

La doble evaluación de ~b, la raíz del discriminante, y 2.0*a se puede optimizar con otra expresión let:

exception Solve;

fun solve(a,b,c) =
  let val d = b * b - 4.0 * a * c
  in if d < 0.0 orelse Real.==(a, 0.0) then raise Solve
  else
    let val menosb = ~b
        val raizd = Math.sqrt d
        val doblea = 2.0 * a
    in ((menosb + raizd) / doblea,
        (menosb - raizd) / doblea)
    end
  end;

2.6. Listas

Están compuestas de elementos del mismo tipo. El operador :: llamado "cons", permite agregar un elemento al inicio de una lista. Por ejemplo 2::[3,4] genera la lista [2,3,4]. Este operador asocia hacia la derecha, por tanto la expresión 2::3::4::[5] equivale a [2,3,4,5].

Los símbolos [] y nil denotan una lista vacía.

Diversos patrones de listas están disponibles:

val x::xs = [1,2,3];
val x1::x2::xs = [1.1, 2.2, 3.3, 4.4, 5.5];
val (y1,y2)::ys = [(1,[1]),(2,[2]),(3,[3])];

En el primer caso tenemos x=1 y xs=[2,3]. En el segundo x1=1.1, x2=2.2 y xs=[3.3,4.4,5.5]. Para el último tenemos y1=1, y2=[1], y ys=[(2,[2]),(3,[3])].

Nota

La función null permite conocer si una lista está vacía.

Rangos numéricos

Las siguientes funciones permiten obtener listas con rangos de enteros:

(* n, n-1, ... 1 *)
fun downto1 0 = []
  | downto1 n = n::downto1 (n-1);

(* i, i+1..., j *)
fun upto(i,j) = if i>j then [] else i::upto(i+1,j);

(* 1, 2... n *)
fun from1upto n = upto(1,n);

Más patrones de listas

Proponemos las siguientes funciones como ejemplos complementarios de patrones de lista:

(* computa la suma alternada: altsum[x1,x2,x3...] = x1 - x2 + x3 ... *)
fun altsum []           = 0
  | altsum [x1]         = x1
  | altsum (x1::x2::xs) = x1 - x2 + altsum(xs);

(* definir una funcion que elimine los elementos impares de una lista *)
fun rmodd [] = []
  | rmodd [x1] = []
  | rmodd (x1::x2::xs) = x2::rmodd(xs);

2.7. Operaciones de Polinomios

El siguiente ejemplo ilustra cómo se puede utilizar listas para modelar operaciones con polinomios. El comportamiento es el siguiente:

- val P = [1,2,1];
val P = [1,2,1] : int list
- val Q = [1,1];
val Q = [1,1] : int list
- poladd (P,Q);
val it = [2,3,1] : int list
- polprod (P,Q);
val it = [1,3,3,1] : int list
- polpow (Q,3);
val it = [1,3,3,1] : int list
- poltext (polpow(Q,3));
val it = "+1+3x^1+3x^2+1x^3" : string

Las funciones son las siguientes:

(* El polinomio a0 + a1.x + a2.x^2 + ... + an.x^n con
 * coeficientes enteros se representa por la lista
 * [a0,a1,...an]. Por ejemplo x^3+2 es [2,0,0,1].
 *)

(* multiplicacion de polinomio por constante *)
fun polbyconst([], cte) = []
  | polbyconst(x::xs : int list, cte : int) = (x*cte)::polbyconst(xs, cte);

(* multiplicar por "x" -> equivale a agregar un cero al inicio *)
fun polbyx(lst) = (0::lst);

(* sumar polinomios *)
local
  fun add([], mayor) = mayor
    | add(x::menor, y::mayor) = (x+y)::add(menor,mayor)
in
  fun poladd(p1, p2) = if (length p1) > (length p2) then add(p2,p1) else add(p1,p2)
end;

(* producto de polinomios. Considerar que 0.Q(x) = 0, y que:
 * (a0+a1.x+...).Q(x) = a0.Q(x) + x.((a1+a2.x+...).Q(x))
 *)
fun polprod([], p) = []
  | polprod(a0::rest, p) = poladd(polbyconst(p,a0),polbyx(polprod(rest,p)));

(* potencia de polinomio *)
fun polpow(p,0) = [1]
  | polpow(p,n) = polprod(p,polpow(p,n-1));

(* representacion textual del polinomio *)
local
  fun termtext(coef, deg) = if coef = 0 then ""
                            else if deg = 0
                                 then if coef < 0
                                      then Int.toString(coef)
                                      else "+" ^ Int.toString(coef)
                                 else if coef < 0
                                      then Int.toString(coef) ^ "x^" ^
                                           Int.toString(deg)
                                      else "+" ^ Int.toString(coef) ^ "x^" ^
                                           Int.toString(deg)
  fun polrun([x],deg) = termtext(x,deg)
    | polrun(x::xs, deg) = termtext(x, deg) ^ polrun(xs, deg + 1)
in
  fun poltext(x) = polrun(x, 0)
end;

2.8. Referencias para Programación Interactiva

Los valores en SML son inmutables; sin embargo, a fin de lograr un efecto equivalente a una variable (mutable), SML proporciona valores de tipo "referencia", los cuales son análogos a un "puntero" en otros lenguajes de programación.

Los valores de tipo referencia son conceptualmente una posición de memoria, la cual nunca cambia (pues los valores SML son inmutables); sin embargo, es posible modificar el contenido de la memoria apuntada. A continuación un ejemplo de creación de un valor de tipo referencia a entero:

val v = ref 5;

Para modificar la memoria apuntada por una referencia se utiliza el operador ":=" del siguiente modo:

v := 7

Y finalmente, cuando se requiere recuperar el valor en memoria se emplea el operador bang (!):

val k = !v

Cálculo del Máximo Común Divisor usando programación interactiva

El ejemplo a continuación ilustra el uso de while … do …; notar que una versión recursiva puede ser más simple, pero esta forma puede ser más veloz.

fun gcd(m,n) =
let
  val rm = ref m
  val rn = ref n
  val r = ref 0
in
  while
    !rn > 0
  do
    (
        r := !rm mod !rn ;
        rm := !rn ;
        rn := !r
     ) ; !rm
end;

Fibonacci interactivo

Notar el uso común de una referencia para almacenar un contador. Del mismo modo para acumuladores.

fun fib n =
let
  val s1 = ref 0
  val s2 = ref 1
  val cnt = ref n
  val t = ref 1
in
  while !cnt > 1
  do
  (
      t := !s1 + !s2;
      s1 := !s2;
      s2 := !t;
      cnt := !cnt - 1
  ); !t
end;

3. Interacción con el usuario

La estructura TextIO proporciona facilidades para interactuar con el exterior. En particular, TextIO.stdIn representa la "entrada estándar" del sistema operativo (normalmente el teclado.) La función TextIO.inputLine() permite leer una línea de texto de una fuente, por lo que se emplea la forma TextIO.inputLine(TextIO.stdIn). Dicha función normalmente retornaría una cadena de texto (tipo de dato string); sin embargo, es posible que el usuario cancele el ingreso del texto (o para el caso de un archivo de disco, se alcance el final de éste.)

Esta doble posibilidad es muy común en diversos escenarios, y la solución de SML consiste en retornar un valor de tipo option, el cual representa dos posibilidades: que realmente hay un valor de interés (en nuestro caso, el texto ingresado por el usuario), o que no hay ningún valor (por ejemplo, si se cancela el ingreso de texto.)

Nota

En C y Java se emplean los "valores especiales" NULL y null respectivamente para hacer referencia a la ausencia de texto ingresado u otra condición excepcional. Java SE 8 incluye una clase Optional con propósito similar.

La siguiente función getline() recibe un argumento prompt el cual es impreso en la pantalla (precedido de un salto de línea y sucedido por un espacio.) Luego se ejecuta el ingreso del texto, el cual genera un valor option que se constituye en el valor de retorno de la función getline().

fun getline prompt = (
        print ("\n" ^ prompt ^ " ");
        TextIO.inputLine(TextIO.stdIn)
        );

Cuando esta función se digita en el intérprete SML, éste retorna un mensaje tal como:

val getline = fn : string -> string option

Esto se lee así: "getline es un valor de tipo función (fn), la cual recibe un argumento de tipo string y retorna un valor de tipo string option". El string option es la posibilidad de que se retorne un string, o que no se retorne nada.

El argumento (prompt) debe ser de tipo string puesto que SML detecta que se utiliza en una conctatenación con otras cadenas de texto.

3.1. Trimming condicional

La siguiente versión incorpora una mejora que suele ser deseable: cuando el usuario ingresa texto, normalmente no se requiere el caracter de salto de línea final, ni espacios en los extremos del texto pues suelen ser accidentales. A tal fin hemos desarrollado una función de "trimming" para recortar el texto de estos caracteres indeseables; más adelante veremos dicha función; lo interesante en este punto es apreciar el uso de la sentencia "case":

case … of patrón1 ⇒ expresion1 | patron2 ⇒ expresion2 ….

En nuestro ejemplo, el valor option retornado tiene dos posibilidades: contiene un texto, o no contiene nada. Esto corresponde respectivamente a los "constructores" SOME y NONE, los cuales se utilizan como patrones en case. En el primer caso, SOME k indica a case que cuando se ha ingresado un texto (identificado a partir de este punto como "k"), deseamos que la expresión resultante sea SOME (Trimmer.trim(k)). En caso contrario, mantenemos el indicador de ausencia NONE:

fun getline prompt = (
        print ("\n" ^ prompt ^ " ");
        case (TextIO.inputLine(TextIO.stdIn)) of
             SOME k => SOME (Trimmer.trim(k))
           | NONE => NONE
        );

Algunas observaciones complementarias a este ejemplo: hemos visto cómo se puede definir funciones de un argumento con fun; estas funciones permiten evaluar expresiones separándolas con un signo ";" y encerradas entre paréntesis. Los paréntesis no son necesarios cuando se trata de una única expresión.

La expresión print … es una invocación a la función print() con un string como argumento (se puede apreciar cómo concatenar cadenas de texto con el símbolo de circunflejo.) La función print() es un ejemplo de expresión que retorna el valor unit que en ocasiones se explica como análogo al void de otros lenguajes de programación. Sin embargo, "unit" es un valor que puede asignarse y conformar otras estructuras, a diferencia de void que sólo opera como una indicación de ausencia de valor.

3.2. Implementación del trimming

A continuación una función ltrim() (left trim) que elimina espacios del principio de un string:

fun ltrim x = let
  fun xtrim (ch::xs) =
    if Char.isSpace ch
        then xtrim xs
        else ch::xs
    | xtrim _ = nil
in
  String.implode(xtrim(String.explode x))
end;

El cuerpo de la función está constituido por una expresión de forma let … in … end, la cual es muy útil y frecuente: entre let e in se introducen declaraciones diversas, las cuales son locales al cuerpo de la función (que va entre in y end.) En nuestro ejemplo, la única declaración local es la función xtrim(); esto significa que no será posible invocar a xtrim() desde otro punto exterior a ltrim(). Se puede afirmar que esto es una forma de encapsulación.

El cuerpo de ltrim() convierte el argumento x (cadena de texto) en una "lista de caracteres" (mediante String.explode); dicha lista es enviada a xtrim(). El resultado deberá ser una lista (posiblemente recordada en los caracteres no deseados), la cual se utiliza para construir un nuevo string mediante String.implode. Esto último se constituye en el valor retornado.

De otro lado, xtrim() es extremadamente interesante; en primer lugar, presenta la forma:

fun xtrim patron1 = expresion1
  | xtrim patron2 = expresion2

Lo que significa que xtrim() se evaluará como distintas expresiones en función de los argumentos proporcionados.

Tal como indicamos, el argumento es una "lista de caracteres", por lo que ambos patrones deben hacer referencia a ésta; sin embargo, en el primer patrón se utiliza la sintaxis ch::xs, que quiere decir literalmente: "una lista con su primer elemento identificado como ch, y el resto de la lista identificado como xs". En otras palabras, se trata de una lista con al menos un elemento (al menos un caracter para este ejemplo.)

El segundo patrón corresponde al caso de una lista vacía, lo cual se puede escribir mediante xtrim(nil), o como xtrim([]). Sin embargo, cuando no tenemos uso para un argumento, SML permite el uso del underscore (_) a modo de "comodín" para hacer referencia a cualquier valor.

Nota

El identificador nil corresponde a la "lista vacía", y es idéntico a []. No debe confundirse con la función null() que permite descubrir si una lista está vacía (es decir, si es nil.)

La expresión para xtrim() en su primer patrón es de tipo condicional (if … then … else …); ésta requiere de una expresión de condición (tipo bool) así como dos expresiones del mismo tipo que serán evaluadas en función del valor de verdad de la condición. La condición es Char.isSpace ch, que es una función auxiliar de la estructura Char que permite investigar si un caracter es de tipo espacio (esto incluye tabuladores y saltos de línea además del espacio en sí.) El objetivo es eliminar estos caracteres por lo que a continuación invocamos recursivamente a xtrim() pero con el resto de la lista: then xtrim(xs); este proceso se repetirá hasta hallar un caracter que no sea un espacio, en cuyo caso retornamos la lista recibida como argumento: else ch::xs.

Sin embargo, existe la posibilidad que todos los caracteres sean espacios, con lo que la última invocación recursiva se hará con una lista vacía, en cuyo caso se identificará el segundo patrón, el cual simplemente retorna nil (lista vacía.)

Así, xtrim() consigue retornar la lista de caracteres (posiblemente vacía) libre de espacios iniciales, con lo que ltrim() reconstruye un string para ser retornado.

Trim por la derecha

Esta no es la implementación más eficiente, pero permite ilustrar algunos puntos adicionales:

fun rtrim x = let
  fun reversar s =
    (String.implode o List.rev o String.explode) s
in
    reversar(ltrim(reversar x))
end;

Hemos basado rtrim() en función de ltrim(); es interesante el uso del operador "o" (composición de funciones) en la tercera línea. Esto equivale a:

    String.implode(List.rev(String.explode s))

Finalmente podemos definir un trim() total:

fun trim (x) = ltrim(rtrim x);

3.3. Una estructura de trimming

A fin de evitar la potencial colisión de nombres, es común definir "espacios de nombres" (namespaces.) Las estructuras de SML proporcionan -entre otras cosas- cierto nivel de aislamiento de los nombres. Podemos incluir nuestras funciones de trimming en una estructura:

(* strimmer.sml *)
structure Trimmer =
struct
fun ltrim x = let
  fun xtrim(ch::xs) =
    if Char.isSpace ch
        then xtrim xs
        else ch::xs
    | xtrim _ = nil
in
  String.implode(xtrim(String.explode x))
end;
fun rtrim x = let
  fun reversar s =
    (String.implode o List.rev o String.explode) s
in
    reversar(ltrim(reversar x))
end;
fun trim x = ltrim(rtrim x);
end

Con dicha estructura, la invocación se realiza tal como vimos en getline(), a saber, prefijando con el nombre de la estructura y separando con un punto el nombre de la función: Trimmer.trim(k).

3.4. Un loop interactivo

En lo que sigue, ilustramos una función que puede ser utilizada en muchos programas interactivos. SML es notablemente pobre en sentencias de control para bucles no recursivos, por lo que puede ser conveniente diseñar una función exclusivamente para este propósito. La sentencia SML para repetir sentencias es while … do …, que requiere de una condición y una expresión (o grupo de expresiones entre paréntesis como se vio al anteriormente.) Las expresiones entre paréntesis normalmente deberán afectar de algún modo a la condición a fin de que el bucle se mantenga en ejecución o termine.

En tal sentido, la condición con frecuencia requiere de datos "mutables" (cuyo valor puede variar) lo que se consigue con "refrencias". Las referencias corresponden a lo que en otros lenguajes se denomina "puntero", y direccionan a valores que pueden ser alterados a través del tiempo.

(* interact.sml *)
use "strimmer.sml";

structure Interact =
struct
fun getline prompt = (
        print ("\n" ^ prompt ^ " ");
        case (TextIO.inputLine(TextIO.stdIn)) of
             SOME k => SOME (Trimmer.trim(k))
           | NONE => NONE
        );
fun do_loop (prompt,extfun,arg,quitflag:string) =
  let
    val flag = ref true
  in
        while !flag
        do (
                case (getline prompt) of
                     SOME k => if k = quitflag then
                                   flag := false
                               else
                                   extfun(arg,k)
                   | NONE => flag := false
        )
  end;
end

La función do_loop() tiene la estructura let…in…end y declara una referencia de tipo bool conteniendo el valor inicial "true"; esta referencia se denomina flag y se utiliza como condición de repetición del bucle.

La condición del while es !flag; esto significa literalmente "extraer el valor al que apunta flag", que como vimos era inicialmente "true". La expresión del while es una decisión case que considera el caso SOME (usuario ingresó información) contrastándolo con un texto predeterminado para que el usuario indique la finalización del programa (quitflag), en cuyo caso el valor al que apunta flag se hace falso: flag := false. Nótese el operador := exclusivo para las referencias. Esto mismo ocurre cuando el usuario cancela el ingreso (caso NONE.)

Por el contrario, cuando hay texto y no es la orden de salida, se ejecuta la función extfun() con un argumento arbitrario (de uso optativo) arg, y el texto ingresado (k).

Nota

el argumento quitflag tiene indicado su tipo (quitflag:string.) Esto es opcional en la mayoría de casos (como el presente), pero puede proporcionar mayor claridad al usuario de la función.

Al ingresarse la función do_loop, SML responde con la siguiente interpretación de sus tipos:

val do_loop : string * ('a * string -> unit) * 'a * string -> unit

Los argumentos proporcionados a la función son 4: un texto de solicitud (prompt) de tipo string, una función (extfun), un argumento arbitrario (arg) y el texto que señala el fin del bucle (quitflag de tipo string.) Estrictamente, la función recibe un único argumento correspondiente a una tupla de 4 componentes.

Para el caso de quitflag SML ha recibido de nosotros la indicación de que es un string. Esto era innecesario puesto que su participación se da en la comparación con SOME k que es un string retornado por getline(): debido a esto, SML pudo haber deducido por sí mismo que su tipo era string.

Esta deducción del tipo es una de las ventajas principales de SML. En el caso de prompt el tipo no fue especificado, pero SML lo deduce correctamente puesto que se utiliza en la llamada a getline(), la cual recibe un string.

En el caso de arg, SML no encuentra elementos para deducir su tipo, por lo que asume que es de un tipo arbitrario ('a). Los valores 'a, 'b, etc. se utilizan para señalar tipos desconocidos.

El argumento más interesante es extfun() cuyo tipo es 'a * string → unit. Esta función recibe como argumentos dos elementos, uno de tipo 'a y un string. SML desconoce el tipo del primer argumento, pero sabe que es el mismo que el de arg (es decir 'a) debido a que hay una invocación a la función con dicho argumento: extfun(arg,k). Análogamente deduce el tipo del segundo argumento.

Más sutil aún resulta el tipo de retorno unit: al interior de do_loop() existe una expresión case la cual contiene un conjunto de expresiones que deben ser del mismo tipo (a fin de que la función do_loop() tenga un tipo único definido.) En ese sentido se aprecia que las expresiones de case son asignaciones a referencias y la invocación a extfun(). Las asignaciones a referencias retornan el elemento unit, por lo que SML deduce que extfun() también retorna dicho tipo.

4. Resolviendo triángulos

Esta será la primera aplicación "útil" de este documento. Tenemos un triángulo de lados a, b, c, y ángulos A, B, C respectivamente opuestos. Si el usuario proporciona algunos de estos valores, en ciertos casos es posible encontrar todos los otros (a esto se le denomina resolver el triángulo.)

Un ejemplo de una sesión con el programa se muestra a continuación:

Presione 'q' para salir, enter para resolver un triangulo
lado a? 10
lado b?
lado c?
angulo A? 45
angulo B?
angulo C?
Falta informacion para resolver el triangulo

Presione 'q' para salir, enter para resolver un triangulo
lado a? 10
lado b? 50
lado c? 20
angulo A?
angulo B?
angulo C?
Triangulo invalido

Presione 'q' para salir, enter para resolver un triangulo
lado a? 3
lado b? 4
lado c? 5
angulo A?
angulo B?
angulo C?
a=3.0 b=4.0 c=5.0 A=36.8698976458 B=53.1301023542 C=90.0

Utilizaremos una función a ser invocada desde do_loop() a solicitud del usuario. Esta función se encargará de consultar los valores de los lados y ángulos, así como de imprimir las soluciones. Como vimos, debe recibir dos argumentos (uno de tipo arbitrario y un string), y retornar unit. En nuestro caso, los argumentos no serán de utilidad:

fun main(arg, ans) =
let
  val questions = ["lado a?", "lado b?", "lado c?",
        "angulo A?", "angulo B?", "angulo C?"];
  val t = map (Real.fromString o valOf o Interact.getline) questions
in
  app print_triangle (print_empty(solve t)) handle BadTriangle =>
        print "Triangulo invalido\n"
end;

El valor questions corresponde a una lista de cadenas de texto. La función map aplica una función a todos los elementos de una lista, y con los resultados de dichas aplicaciones se construye una lista que es el valor retornado.

En tal sentido, "t" es una lista que contiene el resultado de aplicar la función Real.fromString o valOf o Interact.getline sobre las cadenas de texto de questions.

Esta función está construida como una composición de tres funciones. La primera en ser aplicada es Interact.getline(), la cual retorna un option string tal como vimos. Este resultado es proporcionado a valOf, la cual retorna el string de un elemento de forma SOME x. Es posible que el usuario cancele el ingreso de texto y se retorne NONE, con lo que valOf fallará y generará una excepción. Esto terminará el programa de modo no elegante, pero lo dejaremos así en esta versión.

Finalmente, el string es proporcionado a Real.fromString que retorna un option real, es decir, la posibilidad de que se haya ingresado un valor real o ningún valor. Convendremos en que el caso SOME n significa que el usuario ha ingresado un valor conocido del triángulo, y el caso NONE que no hay tal valor (para lo cual es suficiente que no ingrese ningún valor, lo que se considera una cadena de texto vacía la cual no se puede convertir a real.)

El objetivo principal de este programa es la resolución de triángulos; los triángulos a ser resueltos vienen dados por una lista de elementos option real que contiene los valores conocidos y desconocidos, y son siempre 6: los tres lados y los tres ángulos (en grados sexagesimales) que se les oponen respectivamente. La solución se inicia con la función solve() que recibe un triángulo, y retorna una lista conteniendo los tríangulos solución.

Los "triángulos solución" corresponden a una lista de elementos real (no option real pues todos los valores son conocidos), y dependiendo de los datos proporcionados, pueden ser:

  • ninguna solución al faltar información para resolver el triángulo
  • un triángulo solución
  • dos triángulos solución

Asimismo, solve() puede generar una excepción (que denominamos BadTriangle) cuando los valores del triángulo proporcionado resultan inconsistentes.

El resultado de solve() es proporcionado a print_empty(), que tiene como propósito imprimir un mensaje en el caso de no haber ninguna solución (lista vacía.) print_empty() retorna sin alteración el mismo valor que recibe (la lista de triángulos solución.)

La función app es similar a map: recibe una función que es aplicada sobre todos los elementos de una lista. La diferencia es que no se construye ninguna lista de resultado: sólo retorna unit. Así, app aplica print_triangle() sobre todos los triángulos resultado que retorna print_empty().

Como se indicó, solve() puede disparar una excepción BadTriangle, la cual es capturada de ser necesario (handle BadTriangle) y genera un mensaje informativo.

A continuación el código completo del archivo triangle.sml:

(* triangle.sml *)
use "interact.sml";
use "solvers.sml";

fun print_triangle t =
let
  val z = ListPair.zip (["a","b","c","A","B","C"],t)
in
  (
        app (fn (t,v) => print (t ^ "=" ^ Real.toString(v) ^ " ") ) z;
        print "\n"
  )
end

fun print_empty nil = (print "Falta informacion para resolver el triangulo\n"; nil)
  | print_empty ans = ans;

fun main(arg, ans) =
let
  val questions = ["lado a?", "lado b?", "lado c?",
        "angulo A?", "angulo B?", "angulo C?"];
  val t = map (Real.fromString o valOf o Interact.getline) questions
in
  app print_triangle (print_empty(solve t)) handle BadTriangle =>
        print "Triangulo invalido\n"
end;

val pr = "Presione 'q' para salir, enter para resolver un triangulo";
Interact.do_loop (pr, main, "none", "q");

Como se aprecia, se hace uso de "interact.sml" (que se explicó en la primera sección del documento) y de "solvers.sml" (que veremos luego.)

ListPair.zip recibe dos listas (del mismo tamaño) y genera una nueva lista conteniendo pares de la forma (a,b) donde a es un elemento de la primera lista y b de la segunda lista en la misma posición. Así, generamos parejas con la descripción del elemento del triángulo (tipo string), y el valor (tipo real) del elemento.

A cada pareja le aplicamos (app) una función que imprime la descripción, un símbolo de igualdad, y el valor (que requiere convertirse a string para su concatenación.) La función es anónima (sin nombre) para lo cual se usa la sintaxis fn … ⇒ …. Esto es totalmente equivalente a crear una función con nombre:

fun show(t,v) = print (t ^ "=" ^ Real.toString(v) ^ " ") ) z;
...
(
app show z;
print "\n"
)

4.1. Funciones utilitarias

Se declara la excepción BadTriangle así como un conjunto de funciones trigonométricas para operar con grados sexagesimales.

(* solvers.sml: funciones utilitarias *)
exception BadTriangle;

fun sin x = Math.sin (x*Math.pi/180.0);
fun cos x = Math.cos (x*Math.pi/180.0);
fun asin x = if x < ~1.0 orelse x > 1.0 then raise BadTriangle
  else Math.asin(x)*180.0/Math.pi;
fun acos x = if x < ~1.0 orelse x > 1.0 then raise BadTriangle
  else Math.acos(x)*180.0/Math.pi;

fun permutar (triangulo, posiciones) =
  map (fn pos => List.nth(triangulo, pos)) posiciones;

fun rotr triangulo = permutar (triangulo,[2,0,1,5,3,4]);
fun rotl triangulo = permutar (triangulo,[1,2,0,4,5,3]);
fun espejo triangulo = permutar (triangulo,[0,2,1,3,5,4]);

(* reemplazar los valores segun la posicion *)
fun replacer (triangulo : real option list, rep::xs) =
let
  val (pos,v) = rep;
  val rtriang = (
        case (List.nth(triangulo, pos)) of
             SOME _ => triangulo
           | NONE   => List.take(triangulo,pos) @
                        [SOME v] @
                        List.drop(triangulo,pos + 1)
        )
in
  replacer (rtriang, xs)
end
  | replacer (triangulo : real option list, nil) = triangulo;

La función permutar() recibe un triángulo en proceso de resolución (es decir, un option real list) y una lista de 6 enteros. El resultado es un nuevo triángulo donde las posiciones se han desplazado según lo indicado en la lista de enteros, para lo cual dicha lista se mapea al n-esimo elemento de la lista de valores del triángulo.

Con esto se implementa fácilmente las funciones rotr() (rotar a la derecha), rotl() (rotar a la izquierda) y espejo() (simetría respecto a un eje.)

De otro lado, la función replacer() se encarga de hacer reemplazos en los valores de un triángulo. Un criterio de este programa consiste en evitar la sobreescritura de los valores que el usuario ha ingresado, incluso si estos son recalculados por el programa. A tal efecto, la función replacer() recibe una lista de reemplazos denotados por pares (pos,v), pero sólo lo aplica cuando el valor es desconocido (NONE en el triángulo.) En tal caso, construye un nuevo triángulo extrayendo la primera parte de la lista (List.take(triangulo,pos)), concatenándola con SOME v, y con el resto de la lista (List.drop(triangulo,pos + 1).) Notar el uso del operador @ para concatenar listas.

Por claridad replacer() incluye el tipo real option list para el argumento triangulo, aunque no es imprescindible.

4.2. Completar ángulos

Los ángulos internos de un triángulo suman 180 grados. Esto permite deducir un ángulo si conocen los otros dos. La función completar_angulos() se encarga de dicha tarea:

(* solvers.sml: completar tercer angulo *)
fun find_C (triangulo : real option list) =
let
  val [_,_,_,SOME A, SOME B, NONE] = triangulo;
  val C = 180.0 - A - B
in
  List.take(triangulo,3)@[SOME A, SOME B, SOME C]
end;

fun completar_angulos (triangulo : real option list) =
  find_C(triangulo) handle Bind =>
        (rotr(find_C(rotl triangulo)) handle Bind =>
                (rotl(find_C(rotr triangulo)) handle Bind => triangulo
                )
        );

La función find_C() asume que se conocen los ángulos A y B, y que se desconoce C. Así, realiza la asignación con SOME A, SOME B y NONE; dicha asignación puede fallar si se desconoce A o B, y si ya se conoce a C, lo que genera una excepción Bind definida por SML. Asumiendo que no ocurre tal excepción se retorna un triángulo que conserva los tres lados, y que incluye los valores de los tres ángulos.

De otro lado, completar_angulos() intenta evaluar find_C(triangulo). Si esto funciona, entonces el triángulo con los ángulos completos será la respuesta. De lo contrario, se captura la excepción Bind y se procede a intentar find_C(rotl(triangulo)), es decir, el triángulo rotado a la izquierda, con la esperanza lograr el escenario del tercer ángulo desconocido y los otros dos conocidos. En caso de éxito, el triángulo con ángulos completos debe ser rotado en sentido inverso para no alterarlo, por lo que se emplea rotr(find_C(rotl(triangulo)). El último caso es una rotación en sentido opuesto: si nuevamente se captura Bind, entonces no estamos ante el escenario de cálculo por suma de ángulos, por lo que retornamos el triángulo inalterado con la esperanza de resolverlo por otro método.

Tener en cuenta que completar_angulos() no propaga la excepción Bind bajo ninguna circunstancia.

4.3. Soluciones no triviales

Las siguientes funciones implementan las soluciones de los triángulos según los casos conocidos. Este es el corazón del programa.

(* solvers.sml: soluciones no triviales *)

(* resolver caso en el que se conoce el lado a y los angulos B y C *)
fun solve_ala (triangulo: real option list) =
let
  val [SOME a, _, _,_, SOME B, SOME C] = triangulo;
  val A = 180.0 - B - C;
  val b = a * sin(B) / sin(A)
  and c = a * sin(C) / sin(A)
in
  [replacer(triangulo,[(3,A), (1,b), (2,c)])]
end;

(* resolver caso en el que se conoce el angulo A y los lados b y c *)
fun solve_lal (triangulo: real option list) =
let
  val [_, SOME b, SOME c,SOME A,_,_] = triangulo;
  val a = Math.sqrt(b*b+c*c-2.0*b*c*cos(A));
  val B = asin(b*sin(A)/a)
  and C = asin(c*sin(A)/a)
in
  [replacer(triangulo,[(0,a), (4,B), (5,C)])]
end;

(* resolver caso en el que se conoce el angulo A y los lados b y c *)
fun solve_lll (triangulo: real option list) =
let
  val [SOME a, SOME b, SOME c,_,_,_] = triangulo;
  val A = acos((b*b+c*c-a*a)/(2.0*b*c))
in
  solve_lal(replacer(triangulo,[(3,A)]))
end;

(* resolver cuando se conoce A, c y a *)
fun solve_all(triangulo: real option list) =
let
  val [SOME a,_,SOME c,SOME A,_,_] = triangulo;
  val C = asin(c*sin(A)/a);
  val B = 180.0 - A - C;
  val t1 = solve_ala(replacer(triangulo,[(4,B),(5,C)]))
  and tolerancia = 0.0001
in
  if C - A < tolerancia orelse abs(C-90.0) < tolerancia
  then t1
  else
    let
      val C' = 180.0 - C;
      val B' = 180.0 - A - C';
      val t2 = solve_ala(replacer(triangulo,[(4,B'),(5,C')]))
    in
      t1 @ t2
    end
end

Los triángulos se resuelven mediante las leyes del seno y coseno según corresponda. El caso "A-L-L" es el más interesante en la medida que dependiendo de los valores proporcionados, es posible que se genere una o dos soluciones (incluso ninguna si hay valores inconsistentes.) Por ejemplo, la figura muestra el angulo A=37 y el lado c=4, así como la base b. Como se aprecia, hay dos posiciones posibles para a=3 que resultan en dos soluciones (segmentos a1 y a2.)

Caso A-L-L

El arco-seno retorna un ángulo C agudo (la solución "a2" del gráfico), y su suplemento corresponde al ángulo (obtuso) de la solución "a1". Si C es menor o igual que A, entonces la línea "a1" resulta a la izquierda del segmento AB, lo que la invalida (con lo que sólo habria la solución única correspondiente a la línea "a2".)

Notar que cuando se encuentra C, es inmediato conocer B, y el triángulo se termina de resolver mediante el caso A-L-A (también se pudo utilizar L-A-L.)

Como se aprecia, todas estas funciones retornan una lista de triángulos solución conteniendo uno o dos elementos. Es muy importante recordar que estas funciones pueden propagar la excepción Bind cuando realizan la asignación de sus elementos.

4.4. Soluciones y Rotaciones

Salvo L-L-L, todos los métodos requieren ser aplicados para las distintas rotaciones del triángulo puesto que las funciones de solución asumen sólo una configuración para los valores conocidos y desconocidos.

A tal efecto, la función solve_perm() intenta aplicar una función de resolución solver() a las tres posibles configuraciones del triángulo: sin rotación, rotado a la derecha y rotado a la izquierda. En cada caso la función de resolución puede generar Bind, por lo que el efecto de solve_perm() puede ser la propagación de dicha excepción.

Considerando las rotaciones, para cada función de resolución hemos creado una función auxiliar con su mismo nombre y el sufijo "s". Por ejemplo, para solve_ala() se ha creado solve_alas(). Para mantener la simetría hemos creado un solve_llls() que obviamente no requiere de rotaciones.

El caso A-L-L tiene una sorpresa adicional: existe la posibilidad de que el triángulo tenga una configuración L-L-A, la cual tiene una solución idéntica pero que no será alcanzada mediante rotaciones puesto que se trata de una reflexión mediante un eje de simetría (espejo.)

En ese sentido definimos la función solve_llas() que invoca a solve_alls() con la reflexión del triángulo. A la(s) solución(es) las retorna a su configuración original con una nueva aplicación de espejo().

(* solvers.sml: soluciones y rotaciones *)

fun solve_llls triangulo =
  solve_lll triangulo;
fun solve_perm (triangulo, solver) =
  solver(triangulo) handle Bind =>
        (
        map rotl (solver(rotr triangulo)) handle Bind =>
                (map rotr (solver(rotl triangulo)))
        )
fun solve_alas (triangulo) = solve_perm (triangulo, solve_ala);
fun solve_lals (triangulo) = solve_perm (triangulo, solve_lal);
fun solve_alls (triangulo) = solve_perm (triangulo, solve_all);
fun solve_llas (triangulo) = map espejo (solve_alls(espejo triangulo));

4.5. Aplicación sistemática de métodos de solución

Las funciones solve_*s() son instaladas en la lista methods y aplicadas una tras otra por msolve() en la medida que generen la excepción Bind. Si se agotan los métodos de solución, significa que no es posible hacer más y retornamos una lista de soluciones vacía (nil.)

Nótese que antes de intentar los métodos de solución, intentamos completar los ángulos mediante la "suma 180".

(* solvers.sml: aplicacion de metodos de solucion *)

fun msolve (triangulo : real option list, method::xs) =
        (method triangulo handle Bind => msolve(triangulo,xs))
  | msolve (triangulo : real option list, nil) = nil;

fun main_solver (triangulo : real option list) =
let
  val methods = [solve_llls, solve_alas, solve_lals, solve_alls, solve_llas]
  and atriangulo = completar_angulos triangulo
in
  map (map valOf) (msolve (atriangulo, methods))
end;

Finalmente, a cada triángulo resultante, se le aplica la función map valOf, que a su vez aplica la función valOf a cada elemento (de tipo option real.) Con esto conseguimos listas de elementos de tipo real que son las respuestas deseadas.

4.6. Verificación de resultados

Hasta este punto si se proporciona un triángulo tal como a=b=c=1 y A=30 B=60 C=90 (obviamente incorrecto), el programa identificará la solución L-L-L, calculará los ángulos A, B, C, pero no los reemplazará puesto que esto ocultaría el defecto de la especificación.

Por el contrario, al completarse las soluciones, realizaremos algunas verificaciones para asegurarnos de la "calidad" del triángulo resuelto.

(* solvers.sml: verificacion de resultados *)

fun check_triangle_sides (rotador::rots, triangulo : real list) =
let
  val [a : real,b,c,_,_,_] = rotador triangulo
in
  if c > a + b orelse c < abs(a - b) then raise BadTriangle
  else check_triangle_sides (rots, triangulo)
end
  | check_triangle_sides (_, triangulo : real list) = triangulo;

fun check_triangle(triangulo : real list) =
let
  val [a,b,c,A,B,C] =
    check_triangle_sides ([fn x => x, rotr, rotl],
        triangulo);
  val sa = a/sin(A)
  and sb = b/sin(B)
  and sc = c/sin(C)
  and tolerancia = 0.0001
in
  if
        abs(A + B + C - 180.0) < tolerancia andalso
        abs(sa - sb) < tolerancia andalso
        abs(sa - sc) < tolerancia
  then triangulo
  else raise BadTriangle
end;

A tal efecto construimos la función check_triangle() la cual recibe los resultados de main_solver(); esto es, los triángulos como listas de reales y no listas de option real.

Con estos valores se realizan algunas validaciones típicas: los lados deben estar comprendidos entre la diferencia y la suma de los otros dos (check_triangle_sides()), la suma de los ángulos debe ser de 180 grados, y debe satisfacerse la ley de senos:

a/sin(A) = b/sin(B) = c/sin(C)

Apreciar que estamos empleando las mismas funciones de rotación que se emplearon para los triángulos no resueltos. Esto es posible debido a que no hemos especificado el tipo de los elementos de su primera lista argumento, lo que permite utilizar indistintamente elementos option real y real (o cualquier otro):

val rotr = fn : 'a list -> 'a list
val rotl = fn : 'a list -> 'a list

Otro punto interesante ocurre en check_triangle_sides() donde la asignación

val [a : real,b,c,_,_,_] = ...

especifica el tipo de dato real para el valor a. De no hacerlo, SML no tiene manera de conocer su tipo; sin embargo, dado que esta variable participa de operaciones aritméticas, asume incorrectamente que es un entero. El lector debe probar a eliminar la indicación de tipo real para apreciar el error generado en la invocación a check_triangle_sides():

Error: operator and operand don't agree [tycon mismatch]
  operator domain: (real list -> int list) list * real list
  operand:         (real list -> real list) list * real list

Una forma alternativa es declarar la función así:

fun check_triangle_sides (
        rotador::rots : (real list -> real list) list,
        triangulo : real list) = ...

Ahora podemos terminar el programa escribiendo la función inicial de solución del triángulo:

(* solvers.sml: funcion inicial *)

fun solve(triangulo : real option list) =
  map check_triangle (main_solver triangulo);

5. Generador de números primos

Nuestro siguiente programa será una aplicación que permita obtener (interactivamente) el n-esimo número primo.

A fin de hacer nuestro código reutilizable, definiremos una firma (signature) que deberá satisfacer nuestra estructura de números primos:

(* sig.sml *)
signature Primos =
sig
  type prcontext
  val get_nth : prcontext * int -> int
  val get_context : prcontext
  val print_context : prcontext -> unit
end

Esto significa que en el futuro dispondremos de una estructura que nos proporciona:

  • Un tipo de dato llamado prcontext que utilizaremos como "contenedor" de números primos
  • La función get_nth() para obtener el n-esimo número primo
  • El valor get_context que retorna un contenedor inicial de números primos
  • La función print_context() para imprimir el contenido del un contenedor de números primos

Nota

Esto es similar a una interfaz de Java. Las estructuras que satisfacen una firma equivalen a una clase que implementa una estructura. Al igual que en una interfaz Java, es posible agregar valores constantes. Nuestro ejemplo no lo demuestra, pero también es posible introducir nombres para nuevos tipos de datos (a ser definidos por las estructuras.)

Como es sabido, es sencillo determinar si un número es o no primo cuando se conocen todos los números primos anteriores a éste.

En tal sentido, hemos decidido conveniente mantener una lista de los números primos calculados, la cual puede crecer conforme se encuentren nuevos números primos; en otras palabras, requerimos una "lista mutable". Como sabemos, esto no existe en SML pero podemos conseguir el mismo efecto con una "referencia a una lista". Esto es precísamente lo que implementará nuestro contenedor de números primos.

5.1. Estructura de números primos

Definiremos una estructura Primosa que satisface la firma Primos. Dicha estructura implementa el tipo prcontext con una refrencia a lista de enteros (int list ref.)

La estructura define el valor get_context que sirve como contenedor inicial: dicho contenedor sólo contiene los primos 2 y 3. Es necesario que contenga al menos a "3" puesto que la búsqueda de más primos se realizará sobre todos los impares agregando dos cada vez (es decir, sobre 5, 7, 9, 11, etc.)

(* sprimosa.sml *)
use "sig.sml";

structure Primosa :> Primos =
struct
        type prcontext = int list ref;

        val get_context = ref [2, 3];

        fun check_next_primo(primos,n) =
          case (List.find (fn(x) => n mod x = 0) primos) of
               SOME _ => check_next_primo(primos, n + 2)
             | NONE => n;

        fun get_next_primo(primos) =
          check_next_primo(primos,List.last(primos) + 2);

        fun get_k_primos(primos,k) =
          if k <= 0 then primos
          else get_k_primos(
                primos @ [get_next_primo primos],
                k - 1);

        fun get_nth(ctx : prcontext, n) =
          let
            val cnt = length(!ctx)
          in
            if n < cnt then
              List.nth(!ctx, n)
            else
              let
                val newpr = get_k_primos(!ctx, 1 + n - cnt)
              in
                (ctx := newpr ; List.last(newpr))
              end
          end

        fun print_context(ctx : prcontext) =
          print (foldr
                        (fn(s1,s2) => s1 ^ " " ^ s2)
                        "\n"
                        (map (Int.toString) (!ctx))
          );
end

La función check_next_primo() utiliza List.find() para encontrar el primer elemento que satisface la función proporcionada; es decir, el primer primo que divide a n. Si dicho valor existe, reintentamos con "n+2"; cuando no existe tal valor, estamos ante un primo y se retorna. Nótese que la función anónima que se proporciona a List.find() utiliza su argumento x, pero también emplea el valor n disponible en dicho entorno. Este valor se "captura" hasta el momento en que la función se evalúa (invocada desde List.find().) A dicha captura se le conoce como "closure".

De otro lado, get_k_primos() retorna la lista de primos proporcionada (el contenedor de primos) incrementado en k nuevos primos.

Asimismo, get_nth() valida si es posible retornar el n-esimo primo a partir del contenedor; de lo contrario, lo extiende tanto como sea necesario. Observar aquí la asignación a la referencia: ctx := newpr.

Finalmente, print_context() imprime el contenedor de primos proporcionado. A fin de ilustrar la función foldr(), la hemos empleado para crear una cadena de texto a partir del contenedor de primos e imprimirla. Si la lista del tercer argumento contiene [e1,e2…] el resultado de foldr() contendrá e1 " " e2 … "\n".

5.2. Aplicación principal

Haremos uso de la estructura Interact que vimos anteriormente. A tal fin construimos una función llamada main la cual recibirá como argumentos el contenedor de primos y el texto ingresado por el usuario. Convendremos en que "s" es el comando de salida del bucle, y "l" imprimirá el contenedor de primos actual. Otros valores se asumen como la posición del primo que se desea obtener.

Nótese que a diferencia del programa de triángulos, aquí sí se ha hecho uso de los dos argumentos de la función invocada por do_loop().

(* app-primos.sml *)
use "sprimosa.sml";
use "interact.sml";
use "strimmer.sml";

fun main(context, line) =
  case line of
       "l" => Primosa.print_context context
     | _   => (case Int.fromString(line) of
                    SOME num =>
                       if num < 0 then
                           print "Valor invalido\n"
                       else
                           print (
                               Int.toString(Primosa.get_nth(context,num))
                           )
                   | NONE =>
                       print "Valor inadmisible\n"
               );

Interact.do_loop(
        "Hallar el k-esimo primo (l=lista s=salir) k? ",
        main,
        Primosa.get_context,
        "s");

Ejemplo de sesión. 

Hallar el k-esimo primo (l=lista s=salir) k?  5
13
Hallar el k-esimo primo (l=lista s=salir) k?  10
31
Hallar el k-esimo primo (l=lista s=salir) k?  3
7
Hallar el k-esimo primo (l=lista s=salir) k?  l
2 3 5 7 11 13 17 19 23 29 31

Hallar el k-esimo primo (l=lista s=salir) k?  s

5.3. Implementación alterna

Es sabido que para determinar si un número es primo, no hace falta analizar todos los primos anteriores: es suficiente con analizar todos los primos anteriores que no sobrepasan de la raíz cuadrada del número. Esto puede evitar una gran cantidad de pruebas y conducir a una implementación más eficiente, en especial para números grandes.

A tal efecto creamos la estructura PrimosSQ que es muy similar a la estructura Primosa, pero con la nueva función find_divisor() y una modificación de check_next_primo().

(* sprimos-sqrt.sml *)
use "sig.sml";

structure PrimosSQ :> Primos =
struct
        type prcontext = int list ref;

        val get_context = ref [2, 3];

        exception EndOfList;

        fun find_pred (n,sq) x =
          if x > sq then
            raise EndOfList
          else
            (n mod x = 0);

        fun check_next_primo(primos,n) =
        let
          val sq = Real.ceil( Math.sqrt(Real.fromInt n))
        in
          (case (List.find (find_pred (n,sq)) primos) of
               SOME _ => check_next_primo(primos, n + 2)
             | NONE => n) handle EndOfList => n
        end;

        fun get_next_primo(primos) =
          check_next_primo(primos,List.last(primos) + 2);

        fun get_k_primos(primos,k) =
          if k <= 0 then primos
          else get_k_primos(
                primos @ [get_next_primo primos],
                k - 1);

        fun get_nth(ctx : prcontext, n) =
          let
            val cnt = length(!ctx)
          in
            if n < cnt then
              List.nth(!ctx, n)
            else
              let
                val newpr = get_k_primos(!ctx, 1 + n - cnt)
              in
                (ctx := newpr ; List.last(newpr))
              end
          end

        fun print_context(ctx : prcontext) =
          print (foldr
                        (fn(s1,s2) => s1 ^ " " ^ s2)
                        "\n"
                        (map (Int.toString) (!ctx))
          );
end

Para utilizar esta estructura, debe modificarse la función main() a fin de invocar a PrimosSQ. El resultado es el mismo.

Esta implementación ilustra algunas funciones matemáticas a fin de obtener la raíz cuadrada. Pero lo más interesante radica en el uso de List.find(): a diferencia del caso anterior aquí deseamos interrumpir su proceso tan pronto como se alcance la raíz cuadrada del primo. No hay una forma sencilla de detener a List.find() salvo "encontrando" un elemento, pero esto no lo podemos hacer aquí dado que este camino ya se utiliza para señalar la existencia de un divisor y el caracter de no primo del número en análisis. A tal efecto hacemos que la función predicado lance una excepción para cortar el proceso, la cual es capturada, e interpretada como inexistencia de divisores.

Funciones Curry

Otro aspecto a considerar es la que la función List.find() requiere de una función que recibe un único argumento pero que al mismo tiempo tiene acceso a los valores previamente fijados n y sq. Esto se pudo implementar tal como en el caso anterior mediante una función anónima, cuyo "closure" incluyera a n y sq:

          case (List.find (fn(x) => ... ) primos) of

Sin embargo, esto resulta engorroso pues la función no es tan pequeña como en Primosa. Por este motivo hemos definido una función adicional find_pred() la cual debe ser equivalente; el problema es que dicha función no tiene forma de capturar n y sq desde su entorno de ejecución, por lo que necesitamos enviárselos como argumentos. Con este fin, hemos definido la función con la "forma Curry" (curried function): fun find_pred (n,sq) x que en realidad son dos funciones en una. Su tipo es: int * int → int → bool, lo que se debe leer como (int * int) → (int → bool); es decir, recibe un argumento de tipo (int * int) (los enteros n y sq) y como resultado proporciona una nueva función de tipo (int → bool). Esta nueva función recibe un entero (x) y retorna un bool; esto último es precísamente lo que requiere List.find().

5.4. Test de performance

A continuación crearemos una estructura que contenga una función run() la cual se encargará de medir el tiempo que toma evaluar el n-eximo primo. Para esto haremos uso de la estructura Time que permite obtener la hora actual (Time.now()) y convertirla a diversas resoluciones; en nuestro caso se ha traducido a milisegundos, lo cual genera valores de tipo IntInf: obtendremos uno al inicio del test y otro al final, a fin de calcular el tiempo transcurrido.

Lo resaltante del ejemplo es que la estructura de test será paramétrica; en SML a esto se le denomina functor:

use "sig.sml";
use "sprimosa.sml";
use "sprimos-sqrt.sml";

functor TestPrimos (P : Primos) =
struct
  fun run n = let
    val t1 = Time.toMilliseconds (Time.now());
    val ctx = P.get_context;
    val calculate = P.get_nth (ctx,n);
    val t2 = Time.toMilliseconds (Time.now());
    val dif = IntInf.toString (t2 - t1)
  in
    print ("tiempo ms = " ^ dif ^ " - primo = " ^ (Int.toString calculate)  ^ "\n")
  end
end;

(* primer test *)
structure StdTest = TestPrimos(Primosa);
StdTest.run 8000;

(* segundo test *)
structure SQTest = TestPrimos(PrimosSQ);
SQTest.run 8000;

Como se aprecia, TestPrimos es una estructura que depende del parámetro P, el cual satisface la firma Primos. Naturalmente, en su interior se pueden emplear los elementos de dicha firma mediante el identificador P.

Posteriormente, instanciamos estructuras reales mediante las llamadas al functor proporcionándole las estructuras concretas Primosa y PrimosSQ. Con las estructuras recién creadas podemos invocar a run() para evaluar las eficacia de las implementaciones de primos:

structure StdTest : sig val run : unit -> unit end
tiempo ms = 444 - primo = 81817
val it = () : unit
structure SQTest : sig val run : unit -> unit end
tiempo ms = 259 - primo = 81817
val it = () : unit

6. Operando con Registros

Los registros (records) corresponden a valores compuestos de un conjunto de constituyentes más simples. Por ejemplo, una dirección puede componerse de una ciudad, una calle o avenida y un número de solar o lote. En el lenguaje C esto corresponde a las variables de tipo "estructura" (que no tienen relación con las "struct" de SML); en Java corresponden a objetos conteniendo propiedades (pero no métodos.)

A diferencia de una lista o una tupla, los registros contienen datos de distinto tipo identificados por una palabra. En lo que sigue modelaremos un almacén de productos los cuales se componen de los siguientes campos:

  • Un código (int)
  • Una descripción (string)
  • El precio unitario (real)
  • El stock disponible (real)

6.1. Totalizando el almacén

La función que mostramos más abajo permite demostrar la sintaxis de definición de los valores de tipo "registro". El tipo corresponde al conjunto de identificadores y sus respectivos tipos de dato, todo lo cual se denota entre símbolos de llaves ({…}). Para los productos de nuestro ejemplo, el tipo corresponde a:

{cod:int, descripcion:string, precio:real, stock:real}

Nótese que las funciones que reciben valores de tipo registro requieren necesariamente de la especificación del tipo; en nuestro caso se proporciona una lista de registros por lo que el tipo del argumento es bastante engorroso:

(* productos1.sml - definir y calcular valor total de productos *)

fun total(p::xs :
  {cod:int, descripcion:string, precio:real, stock:real} list)
  = (#precio p) * (#stock p) + total xs
  | total(_) = 0.0;

val plist = [
        {cod=4414, descripcion="FRIJOL CANARIO", precio=4.50, stock= 15.0},
        {cod=4415, descripcion="MANZANA PACHACAMAC", precio=6.50, stock= 33.0},
        {cod=4416, descripcion="FIDEO CANUTO", precio=7.80, stock= 5.0}
        ];

total plist;

Observar la sintaxis #campo registro empleada para extraer el valor de un campo constituyente en un registro. Asimismo la expresión de la forma:

{ campo11 = valor1, campo2 = valor2, ... }

Es empleada para crear valores de tipo registro.

Identificadores de tipo

La sentencia type de SML permite dar un nombre conveniente a cualquier tipo de dato; esto resulta muy útil para los registros, como se aprecia en el siguiente ejemplo equivalente al anterior:

(* productos2.sml - definir y calcular valor total de productos *)

type producto = {cod:int, descripcion:string, precio:real, stock:real};

fun total(p::xs : producto list)
  = (#precio p) * (#stock p) + total xs
  | total(_) = 0.0;

val plist = [
        {cod=4414, descripcion="FRIJOL CANARIO", precio=4.50, stock= 15.0},
        {cod=4415, descripcion="MANZANA PACHACAMAC", precio=6.50, stock= 33.0},
        {cod=4416, descripcion="FIDEO CANUTO", precio=7.80, stock= 5.0}
        ];

total plist;

6.2. Leer y Escribir Registros

El ejemplo que mostramos a continuación consiste en un programa inspirado en un sistema de control de almacén. Utiliza el tipo producto que se vió en la sección anterior y que permitirá modelar un almacén como una lista de registros. A fin de elevar la encapsulación, definiremos una firma y una estructura para "ocultar" al registro producto:

La firma del producto es la siguiente:

(* sproducto.sml *)

signature SProducto =
sig
  type producto
  val get_codigo            : producto -> int
  val get_descripcion       : producto -> string
  val get_precio            : producto -> real
  val get_stock             : producto -> real
  val new_product           : int*string*real*real -> producto
  val parse_prod            : string   -> producto
  val toString              : producto -> string
end;

Este tipo de dato será "opaco" para el programa usuario, lo que significa que no podrá utilizar sus valores "directamente"; por el contrario, sólo podrá emplearlos mediante las operaciones proporcionadas por la estructura Producto que veremos a continuación. Por ejemplo, sabemos que los productos corresponden a registros conteniendo el campo descripcion; sin embargo, el programa no podrá generar la descripción mediante #descripcion, teniendo que recurrir a la función get_descripcion() de la estructura.

Esto corresponde a un mecanismo de encapsulación que permite modificar posteriormente la definición de los tipos de datos sin necesidad de actualizar los programas usuarios (mientras se conserve la firma.)

De igual modo necesitamos proporcionar una función como new_product() para crear un elemento producto, en vez de crear los registros directamente.

A continuación la estructura:

(* producto.sml *)

use "sproducto.sml";

structure Producto :> SProducto =
struct
  type producto = {cod:int, descripcion:string,
                   precio:real, stock:real};
  fun get_codigo (p:producto) = #cod p;
  fun get_descripcion (p:producto) = #descripcion p;
  fun get_precio (p:producto) = #precio p;
  fun get_stock (p:producto) = #stock p;
  fun new_product (c,d,p,s) = {cod=c,
                                descripcion=d,
                                precio=p,
                                stock=s};
  fun parse_prod line =
  let
    val line_nonl = if String.isSuffix "\n" line then
                           String.substring (line,0,size line - 1)
                    else line
    val [tok1,tok2,tok3,tok4] = String.fields
        (fn ch => ch = #",") line_nonl
  in
    {
    cod=valOf(Int.fromString tok1),
    descripcion=tok2,
    precio=valOf(Real.fromString tok3),
    stock=valOf(Real.fromString tok4)
    }
  end;
  fun toString (prod:producto) =
      (Int.toString (#cod prod)) ^ "," ^
      (#descripcion prod) ^ "," ^
      (Real.toString (#precio prod)) ^ "," ^
      (Real.toString (#stock prod));
end;

La función parse_prod() genera un producto a partir de un texto que contiene sus constituyentes separados por comas, lo cual será empleado a continuación. Obsérvese la interesante función String.fields() que genera una lista de strings a partir de una función que contrasta caracteres con lo que se defina como delimitador.

Archivo de Almacén

Utilizaremos un archivo de texto simple tal como el que se muestra a continuación para registrar nuestro almacén, el cual consiste de una lista de productos. En el disco se llamará db.txt:

4414,FRIJOL CANARIO,4.50,15.0
4415,MANZANA PACHACAMAC,6.50,33.0
4416,FIDEO CANUTO,7.80,5.0

Definiremos una estructura con operaciones para controlar nuestro almacén. Dichas operaciones se han reflejado en la siguiente firma:

(* prod_db_sig.sml *)

signature SProdDb =
sig
  type database
  exception NotFound
  val load_database         : string -> database
  val save_database         : string*database -> database
  val add_product           : database*(Producto.producto) -> database
  val search_by_description : database*string -> Producto.producto
  val show_all              : database -> unit
end;

Como se aprecia, la estructura permitirá cargar y grabar el almacén desde y hacia un archivo (load_database() y save_database().)

Crearemos algunas funciones de uso común las cuales deberá completar el lector. La búsqueda por descripción corresponde a encontrar una "subcadena de texto" dentro de la cadena de texto correspondiente a la descripción.

El programa que utilice esta estructura empleará un valor de tipo database el cual es en realidad una referencia a la lista de productos con lo que obtenemos el efecto de mutabilidad deseado. A continuación la estructura:

(* prod_db.sml *)

use "producto.sml";
use "prod_db_sig.sml";

structure ProdDb :> SProdDb =
struct
  type database = Producto.producto list ref;
  exception NotFound;
  fun load_database filename =
  let
    val io = TextIO.openIn filename
    val db = ref nil: database
    val do_read = ref true
  in
    while !do_read
    do (
        case (TextIO.inputLine io) of
             SOME line => db := (!db) @ [Producto.parse_prod line]
           | NONE => do_read := false
    ) ; TextIO.closeIn io ; db
  end;
  fun save_database (filename,db:database) =
  let
    val io = TextIO.openOut filename
    val plist = !db
    fun save_product (prod:Producto.producto) =
    let
      val pline = (Producto.toString prod) ^ "\n"
    in
      TextIO.output (io,pline)
    end
    fun xsave_database(p::xs) =
      (save_product p ; xsave_database xs)
      | xsave_database(nil) = ()
  in
    xsave_database(plist); TextIO.closeOut io; db
  end;
  fun add_product (db:database, p:(Producto.producto)) =
    (db := (!db) @ [p] ; db);
  fun strstr (haystack:string,needle:string) =
  let
    val ln = size needle
    val lh = size haystack
    fun strstr_st(h,n,start:int) =
      if start + ln > lh then false
      else if String.substring(h,start,ln) = n then true
           else strstr_st(h,n,start + 1)
  in
    strstr_st(haystack, needle, 0)
  end;
  fun search_by_description (db:database, desc:string) =
  let
    fun xsearch_by_desc(p::xs : Producto.producto list, d) =
        if strstr (Producto.get_descripcion p, d) then p
        else xsearch_by_desc(xs, d)
      | xsearch_by_desc(nil, d) = raise NotFound
  in
    xsearch_by_desc(!db, desc)
  end;
  fun show_all(pref : database) =
  let
    fun xshow_all(p::xs : Producto.producto list) =
    let val s = (Producto.toString p) ^ "\n"
    in ( print s ; xshow_all(xs) )
    end
    | xshow_all(_) = ()
  in
    xshow_all(!pref)
  end;
end;

Apreciar la función strstr() la cual es muy útil independientemente de este ejemplo.

A continuación el programa que hace uso de estas estructuras (antes de ejecutarlo, debe crearse el archivo db.txt con el contenido indicado anteriormente.) Obsérvese que hemos hecho uso extensivo de TextIO para las operaciones de disco.

También notar que el programa hace uso de la excepción ProdDb.NotFound. Esto es posible debido a que la excepción ha sido "exportada" en la firma SProdDb.

use "prod_db.sml";
use "interact.sml";

fun main((db,filename), line) =
let
  val ask_string = valOf o Interact.getline
  val ask_int = valOf o Int.fromString o valOf o Interact.getline
  val ask_real = valOf o Real.fromString o valOf o Interact.getline
in
    case line of
         "l" => ProdDb.show_all db
       | "a" => ignore (ProdDb.add_product
                        (db,Producto.new_product(
                                (ask_int "codigo?"),
                                (ask_string "descripcion?"),
                                (ask_real "precio?"),
                                (ask_real "stock?"))))
       | "g" => ignore (ProdDb.save_database (filename,db))
       | "b" => (
                let
                  val what = ask_string "Que desea buscar?"
                  val text = Producto.toString
                                (ProdDb.search_by_description (
                                        db,what))
                in
                  print text
                end
                handle ProdDb.NotFound =>
                  print "No se encontro producto"
                )
       | _ => print "Error en opcion solicitada\n"
end

val dbfile = "db.txt";
val db = ProdDb.load_database dbfile;
Interact.do_loop(
        "l=lista b=buscar a=agregar g=guardar s=salir >",
        main,
        (db,dbfile),
        "s");

El caso de la opción "b" es una expresión que se ha delimitado con paréntesis. De no hacerlo, el último caso (_⇒) sería interpretado por SML como un "handler" adicional para esta expresión (conjuntamente con ProdDb.NotFound.) Esto debido a que la sintaxis de captura de excepciones es:

handle ex1 => exp1 | ex2 => exp2 ...

Finalmente, observar que durante la ejecución del bucle principal (do_loop()) se requiere disponer de la referencia a la base de datos así como del nombre de archivo de disco; es por esto que el código de inicio que hace la invocación proporciona la tupla (db,dbfile) al bucle.

El lector debería mejorar este programa; por ejemplo, la función add_product() debe validar que el código no esté repetido; puede añadirse una funciones para actualizar, eliminar productos; también para incrementar y reducir el stock, así como fijar nuevos precios.

6.3. Categorías para los Productos

Es común que los productos de un almacén esten categorizados jerárquicamente. Esto configura un árbol de categorías donde los productos corresponden a las "hojas", y las categorías vienen a ser las "ramas".

ABARROTES
        --- FIDEOS
                --- cabello de angel
                --- fetuccini
        --- CONSERVAS
                --- filete de atun
                --- duraznos en almibar
BEBIDAS
        --- GASEOSAS
                --- inka coca
                --- crush
                --- 8up
        --- FRUTADOS
                --- pulpon
                --- fruticida
                --- mandarin

A fin de modelar este árbol de categorías y productos definiremos un nuevo tipo de dato. Dado que las categorías pueden contener múltiples niveles de subcategorías, es conveniente aprovechar la recursividad que proporciona SML para sus tipos. Nuestro tipo se denomina catprod y hace uso del tipo registro producto definido al inicio de esta sección.

El siguiente listado ilustra la sentencia datatype que permite crear nuevos tipos de datos, y demuestra la creación de algunos elementos del árbol mostrado arriba:

(* catprod.sml *)

type producto = {cod:int, descripcion:string, precio:real, stock:real};

datatype catprod =
        CATEGORIA of string * (catprod list ref)
        |
        PRODUCTO of producto;

val cabello = PRODUCTO({cod=312,
        descripcion="cabello de angel",
        precio=4.30, stock=12.0});
val fetuccini = PRODUCTO({cod=313,
        descripcion="fetuccini",
        precio=5.30, stock=10.0});
val filete = PRODUCTO({cod=314,
        descripcion="filete de atun",
        precio=4.30, stock=12.0});
val duraznos = PRODUCTO({cod=315,
        descripcion="duraznos en almibar",
        precio=5.30, stock=10.0});
val fideos = CATEGORIA("FIDEOS", ref [cabello, fetuccini]);
val conservas = CATEGORIA("CONSERVAS", ref [filete, duraznos]);
val abarrotes = CATEGORIA("ABARROTES", ref [fideos, conservas]);
val almacen = CATEGORIA("ALMACEN", ref [conservas, abarrotes]);

El tipo catprod puede contener o una rama (CATEGORIA), o una hoja (PRODUCTO.) Estos identificadores permiten crear valores de tipo catprod según se desee; debido a esto son denominados "constructores".

El constructor CATEGORIA requiere de un texto (el nombre de la categoría) así como de una referencia a una lista de elementos catprod, lo que permitirá posterioremente agregar ramas y hojas a la categoría.

El constructor PRODUCTO requiere de un producto tal como se vio anteriormente, y no permite contener otros elementos adicionales.

Notar que hemos creado un valor almacen que contiene todas las categorías, lo que equivale a contener el almacén en su totalidad.

A continuación mostramos una función que permite mostrar las categorías con sus contenidos de un modo ordenado con sangrado de 4 caracteres por nivel:

(* catprint.sml *)
use "catprod.sml";

fun catprint(cat) =
let
  fun spaces(0) = ()
    | spaces(n) = (print "    "; spaces(n-1))
  fun xcatprintlevel(s, level) =
    (
    spaces(level);
    print (s ^ "\n")
    )
  fun xcatprintlist(c::xs, level) =
    (xcatprint(c,level);xcatprintlist(xs,level))
    | xcatprintlist(_, level) = ()
  and
  xcatprint(cat,level) =
    case cat of
       CATEGORIA(name,lref) =>
         (
         xcatprintlevel("[" ^ name ^ "]", level);
         xcatprintlist(!lref, level + 1)
         )
     | PRODUCTO(p) =>
         xcatprintlevel(#descripcion p, level)
in
  xcatprint(cat,0)
end;

catprint(almacen);

Lo más importante aquí es observar el matching con case utilizando los constructores del tipo de dato.

Observar también que la función xcatprintlist() invoca a xcatprint(), y viceversa. Esto requiere crear estas funciones como una única expresión lo que se consigue utilizando el conector and; debe notarse que and es totalmente distinto al conector lógico andalso que significa conjunción.

Nota

Recalcamos, en SML el conector andalso equivale a lo que en C y Java se denota por &&.

La invocación catprint(almacen) genera esto:

[ALMACEN]
    [CONSERVAS]
        filete de atun
        duraznos en almibar
    [ABARROTES]
        [FIDEOS]
            cabello de angel
            fetuccini
        [CONSERVAS]
            filete de atun
            duraznos en almibar

Modificando el Árbol

La función add_cat() ilustra una manera en que se puede agregar una categoría al interior de otra. Nótese que el patrón case sólo incluye el caso CATEGORIA: en caso de que se proporcione un PRODUCTO, se generaría una excepción Match. Esta posibilidad normalmente es alertada por el compilador, siendo responsabilidad del programador su control y posible captura.

(* catbebidas.sml *)

use "catprint.sml";

fun add_cat(element, destination) =
  case destination of
       CATEGORIA(_,lr) => lr := !lr @ [element];

val gaseosas = CATEGORIA("GASEOSAS", ref nil);
val iq = PRODUCTO({cod=312,
        descripcion="iq",
        precio=3.0, stock=48.0});

val bebidas = CATEGORIA("BEBIDAS", ref [iq,gaseosas]);
add_cat(bebidas,almacen);
catprint(almacen);

La modificación es simple, y se basa en el mecanismo de "referencia a lista" que hemos visto en anteriores ejemplos.

Tras la ejecución del archivo, el resultado es:

[ALMACEN]
    [CONSERVAS]
        filete de atun
        duraznos en almibar
    [ABARROTES]
        [FIDEOS]
            cabello de angel
            fetuccini
        [CONSERVAS]
            filete de atun
            duraznos en almibar
    [BEBIDAS]
        iq
        [GASEOSAS]

Separar categorías de productos

El resultado anterior presenta la categoría "BEBIDAS" conteniendo al producto "iq" así como a la subcategoría "GASEOSAS". En ocasiones no es deseable tal combinación: puede ser preferible que una categoría contenga sólo categorías o sólo productos.

Esto se puede resolver redefiniendo el tipo de dato catprod para que refleje estas dos posibilidades: cada nodo contiene o una lista de más subcategorías posiblemente recursivas, o una lista de productos:

(* cat2.sml *)

type producto = {cod:int, descripcion:string, precio:real, stock:real};

datatype catprod =
        CATEGORIA of string * (catprod list ref)
        |
        PRODUCTOS of string * (producto list ref);

fun catprint(cat) =
let
  fun spaces(0) = ()
    | spaces(n) = (print "    "; spaces(n-1))
  fun xcatprintlevel(s, level) =
    ( spaces(level); print (s ^ "\n"))
  fun printprodlist(p::xs : producto list, level) =
    ( xcatprintlevel(#descripcion p, level);
    printprodlist(xs, level) )
    | printprodlist(_, level) = ()
  fun xcatprintlist(c::xs, level) =
    (xcatprint(c,level);xcatprintlist(xs,level))
    | xcatprintlist(_, level) = ()
  and
  xcatprint(cat,level) =
    case cat of
       CATEGORIA(name,lref) =>
         (
         xcatprintlevel("[" ^ name ^ "]", level);
         xcatprintlist(!lref, level + 1)
         )
     | PRODUCTOS(name,lref) =>
         (
         xcatprintlevel("[" ^ name ^ "]", level);
         printprodlist(!lref, level + 1)
         )
in
  xcatprint(cat,0)
end;

fun add_cat(element, destination) =
  case destination of
       CATEGORIA(_,lr) => lr := !lr @ [element];

fun add_prod(element, destination) =
  case destination of
       PRODUCTOS(_,lr) => lr := !lr @ [element];

val cabello = {cod=312,
        descripcion="cabello de angel",
        precio=4.30, stock=12.0};
val fetuccini = {cod=313,
        descripcion="fetuccini",
        precio=5.30, stock=10.0};
val filete = {cod=314,
        descripcion="filete de atun",
        precio=4.30, stock=12.0};
val duraznos = {cod=315,
        descripcion="duraznos en almibar",
        precio=5.30, stock=10.0};
val fideos = PRODUCTOS("FIDEOS", ref [cabello, fetuccini]);
val conservas = PRODUCTOS("CONSERVAS", ref [filete, duraznos]);
val abarrotes = CATEGORIA("ABARROTES", ref [fideos, conservas]);
val gaseosas = PRODUCTOS("GASEOSAS", ref nil);
val almacen = CATEGORIA("ALMACEN", ref [conservas, abarrotes]);

val bebidas = CATEGORIA("BEBIDAS", ref [gaseosas]);
add_cat(bebidas,almacen);

val iq = {cod=312,
        descripcion="iq",
        precio=3.0, stock=48.0};
add_prod(iq,bebidas) handle Match =>
        print "No se puede agregar a BEBIDAS\n";
add_prod(iq,gaseosas) handle Match =>
        print "No se puede agregar a GASEOSAS\n";

catprint(almacen);

Ahora a fin de agregar una categoría a otra debemos emplear add_cat() y para agregar un producto usaremos add_prod().

Notar que cuando se intenta agregar un producto a una categoría construida con CATEGORIA se genera la excepción Match. Esto se puede apreciar cuando se imprime el mensaje "No se puede agregar a BEBIDAS".

7. Validacion de argumentos en logica proposicional

Esta sección presenta un programa que permite validar argumentos de lógica proposicional. Por ejemplo, el conocido "modus tollens":

p -> q
!q
======
!p

O de forma más abreviada: p→q, !q |- !p.

7.1. Nota breve sobre los argumentos

Los argumentos consisten de un conjunto (posiblemente vacío) de fórmulas proposicionales que se asumen válidas (premisas), y una fórmula conclusión. Según la lógica clásica, los argumentos son válidos cuando no se puede encontrar ningún contraejemplo; es decir, cuando no se da el caso que todas las premisas son verdaderas mientras que la conclusión es falsa.

Si las proposiones son P1, P2, etc. y la conclusión es C, entonces otra forma de decir lo mismo consiste en afirmar que no existe una "valuación" (asignación de valores de verdad T/F a las proposiciones atómicas constituyentes) de modo tal que P1=T, P2=T, … al tiempo que C=F. Si & significa conjunción lógica, y ! es negación lógica, lo anterior equivale a afirmar que no existe valuación tal que (P1 & P2 &…& !C) = T.

El programa solicitará interactivamente una expresión de la forma P1,P2,… |-C, creará estructuras internas para las fórmulas, y las evaluará buscando un contraejemplo según lo anteriormente explicado. Por ejemplo:

VALIDACION DE ARGUMENTOS

El argumento debe tener la forma:

    p1, p2, ... |- c

donde 'pi' son las premisas (cero a mas), y 'c' es la conclusion;
por ejemplo: p->q, !q |- !p

Argumento?  p->q, q |- p
Se encontro contraejemplo con valuacion:
p=F q=T
...
Argumento?  p->q, !q |- !p
Argumento es valido

7.2. Programa principal

El programa principal va a continuación; éste incluye los archivos lexical.sml (análisis léxico) y nparser.sml (parser.)

(* validador.sml *)
exception Contraejemplo
exception UserAbort

datatype lexpr = L_ATOM of string | L_AND of (lexpr*lexpr)
               | L_OR of (lexpr*lexpr) | L_COND of (lexpr*lexpr)
               | L_NOT of lexpr | L_BICOND of (lexpr*lexpr) | BOTTOM;

use "lexical.sml";
use "nparser.sml";

fun trim x = let
  val l = String.explode x
  fun ltrim (ch::xs) = if Char.isSpace ch then xs else ch::xs
    | ltrim _ = nil
in
  String.implode(rev(ltrim(rev (ltrim l))))
end

fun getline prompt = (
        print ("\n" ^ prompt ^ " ");
        case (TextIO.inputLine(TextIO.stdIn)) of
             SOME k => trim(k)
           | NONE => raise UserAbort
        )

fun drop_last (x) = rev (List.drop(rev(x),1))

fun drop_rep (lst:string list) =
let
 fun draux(x::xs, cur) =
   if List.exists (fn t => t = x) cur
   then draux(xs,cur) else draux(xs, cur @ [x])
   | draux (nil,cur) = cur
in draux(lst,[]) end

fun extract_vars ath =
let
  fun maux (ath, tmap) =
  case ath of
       L_BICOND(x,y) => maux(y,maux(x,tmap))
     | L_COND(x,y) => maux(y,maux(x,tmap))
     | L_AND(x,y) => maux(y,maux(x,tmap))
     | L_OR(x,y) => maux(y,maux(x,tmap))
     | L_NOT(x) => maux(x,tmap)
     | BOTTOM => tmap
     | L_ATOM(x) => x::tmap
in
  maux(ath,[])
end

fun get_variables_formula ath =
let
  val tmap = extract_vars ath
in
  drop_rep tmap
end

(* obtener f1^f2...^c de la lista de formulas *)
fun conjugar (x::xs,c) =
  conjugar(xs, L_AND(x,c))
  | conjugar ([],c) = c

fun evaluar (f, vmap : (string * bool) list) =
let
  fun eval g =
    case g of
         L_BICOND (x,y) => (eval x = eval y)
       | L_COND (x,y) => ((not (eval x)) orelse (eval y))
       | L_AND (x,y) => eval x andalso eval y
       | L_OR (x,y) => eval x orelse eval y
       | L_NOT x => not (eval x)
       | BOTTOM => false
       | L_ATOM x => #2 (valOf(List.find (fn t => #1 t = x) vmap))
in
  eval f
end

fun xevaluar (f, vmap) =
let
  val r = evaluar (f,vmap)
in
  if r then
    (
    print "Se encontro contraejemplo con valuacion:\n";
    app (fn (n,v) =>
         if v then print (n ^ "=T ") else print (n ^ "=F "))
         vmap;
    raise Contraejemplo
    )
  else ()
end

fun combinaciones (v::xs, cur, f) = (
  combinaciones (xs, cur @ [(v,true)], f);
  combinaciones (xs, cur @ [(v,false)], f)
  )
  | combinaciones ([], cur, f) = xevaluar (f,cur)

fun validacion2 premisas =
let
  val conclusion = List.last premisas
  val nconclusion = L_NOT(conclusion)
  val rpremisas = drop_last premisas
  val ftotal = if null rpremisas then nconclusion
               else conjugar (rpremisas, nconclusion)
  val variables = get_variables_formula ftotal
in
  combinaciones (variables,[],ftotal);
  print "Argumento es valido\n"
end handle Contraejemplo => ()

fun validacion premisas =
  if length premisas = 0 then
    print "Se requiere al menos la conclusion\n"
  else
    validacion2 premisas

fun get_argumento () =
let
  val aline = (
    print ("VALIDACION DE ARGUMENTOS\n\n" ^
    "El argumento debe tener la forma:\n\n" ^
    "    p1, p2, ... |- c\n\n" ^
    "donde 'pi' son las premisas (cero a mas), y 'c' es la conclusion;\n" ^
    "por ejemplo: p->q, !q |- !p\n") ;
    getline "Argumento? " )
  val partes = String.fields (fn ch => ch = #"|") aline
  val p0 = trim(List.nth(partes,0))
  val prems = if p0 = "" then nil
              else String.fields (fn ch => ch = #",") p0
  val p1 = List.nth(partes,1)
  val conc = String.substring(p1, 1, size p1 - 1)
  val argtxt = prems @ [conc]
in
  validacion (map (fn t => Parser.parse (LogLexer.scan t)) argtxt) ;
  OS.Process.exit(0)
end ;

get_argumento();

Algunos puntos relevantes: el tipo de dato lexpr (expresión lógica) será utilizado para representar las fórmulas de lógica proposicional. Éstos valores tienen la capacidad de contener estructuras de la forma:

p, p&q, p|q, p->q, y p<->q

lo cual se utiliza para obtener el valor de verdad a partir de una "valuación"; a tal efecto, la función evaluar() permite obtener el valor de verdad de una fórmula, si se le proporciona una valuación en una lista tal como [("p",true),("q",false)].

La función combinaciones() es interesante como "motor" que genera las valuaciones T/F para todas las proposiciones involucradas en las fórmulas (las cuales se buscan previamente invocando a get_variables_formula(). Finalmente, get_argumento() se encarga de obtener y procesar (de modo bastante primitivo) el texto introducido por el usuario, convirtiéndolo en una lista de fórmulas de tipo lexpr mediante el "parser" y el "lexer".

7.3. Obtención de tokens

El "análisis lexicográfico" se implementa en el archivo lexical.sml mediante el functor Lexical. Como se indica, este código se ha tomado casi íntegramente de [PAULSON], adaptando la estructura LogKeyword a nuestras necesidades.

La función LogLexer.scan() recibe nuestras fórmulas como textos y retorna una lista de elementos de tipo LEXICAL.token (Id o Key) que corresponden a los elementos mínimos significativos (tokens) de las fórmulas: las proposiciones atómicas (tales como "p", "q", etc.) identificados con el constructor Id, y los símbolos con Key.

(* extraido de Paulson: ML for the working programmer 2ed *)
signature LEXICAL =
sig
  datatype token = Id of string | Key of string
  val scan : string -> token list
end;

signature KEYWORD =
sig
  val alphas : string list
  and symbols : string list
end;

structure LogKeyword : KEYWORD =
struct
  val alphas = nil
  val symbols = [ "(", ")", "|", "!", "&", "<->", "->", "#" ]
end;


functor Lexical (Keyword: KEYWORD) : LEXICAL =
struct
  datatype token = Id of string | Key of string
  fun member (x:string, l) = List.exists (fn y => x=y) l
  fun alphaTok a =
    if member(a, Keyword.alphas) then Key(a) else Id(a)
  fun symbolic (sy,ss) =
    case Substring.getc ss of
         NONE => (Key sy, ss)
       | SOME (c,ss1) =>
           if member(sy, Keyword.symbols)
           orelse not (Char.isPunct c)
           then (Key sy, ss)
           else symbolic (sy ^ String.str c, ss1);
  fun scanning (toks, ss) =
    case Substring.getc ss of
         NONE => rev toks
       | SOME (c,ss1) =>
           if Char.isAlphaNum c
           then
             let
               val (id,ss2) = Substring.splitl Char.isAlphaNum ss
               val tok = alphaTok (Substring.string id)
             in scanning (tok::toks, ss2)
             end
           else if Char.isPunct c
                then
                  let val (tok,ss2) = symbolic (String.str c, ss1)
                  in scanning (tok::toks, ss2)
                  end
                else
                  scanning(toks, Substring.dropl(not o Char.isGraph) ss);
  fun scan a = scanning([], Substring.full a)
end

structure LogLexer = Lexical(LogKeyword);

7.4. Obtención de expresiones lógicas

El archivo nparser.sml contiene una estructura encargada de obtener un lexpr a partir de una lista de tokens de nuestro lenguaje de lógica proposicional. Nuestro lenguaje soporta expresiones de longitud y anidamiento arbitrario (por ejemplo, (!p & (q → (!p) | r)).)

Tokens simples y compuestos

Los paréntesis fuerzan un orden de evaluación de las sub-expresiones contenidas en las fórmulas. A fin de posibilitar un análisis "top-down" de nuestras fórmulas (listas de tokens) introduciremos un nuevo tipo de dato "ctoken" que permite postergar la evaluación de expresiones entre paréntesis. Los tokens fuera de paréntesis se consideran "simples", mientras que los que los paréntesis corresponden a los compuestos. Por ejemplo:

TOKENS:    p      &      q       ->     (p  |  r)

           |      |      |       |         |
           v      v      v       v         v

CTOKENS: sim[p] sim[&] sim[q] sim[->]  comp[p,|,r]

Con este paso previo, se procede a identificar los operadores lógicos que constitueyen las fórmulas, empezando desde los que tienen menos precedencia. Siguiendo el ejemplo anterior, la condicional tiene la menor precedencia, con lo que la fórmula se convierte en una lexpr de constructor L_COND(F1,F2):

TOKENS:    p      &      q       ->     (p  |  r)

           |      |      |       |         |
           v      v      v       v         v

CTOKENS: sim[p] sim[&] sim[q] sim[->]  comp[p,|,r]

           |      |      |       |         |
           v      v      v       v         v

L_COND(  sim[p] sim[&] sim[q]    ,     comp[p,|,r] )

Cada componente se procesa a continuación. El primer componente se convierte en una lexpr de constructor L_AND; en el segundo caso, el proceso se reinicia desde el principio.

TOKENS:    p      &      q       ->     (p  |  r)

           |      |      |       |         |
           v      v      v       v         v

CTOKENS: sim[p] sim[&] sim[q] sim[->]  comp[p,|,r]

           |      |      |       |         |
           v      v      v       v         v

L_COND(  sim[p] sim[&] sim[q]    ,     comp[p,|,r] )

                 |                         |
                 v                         v

L_COND( L_AND(sim[p],sim[q])     ,  sim[p] sim[|] sim[r]  )

De otro lado, notar el uso del tipo orient para señalar la asociatividad de los operadores lógicos. Por ejemplo, las condicionales convencionalmente se asocian hacia la derecha:

p -> q -> r = p -> (q -> r)

El parsing se implementa en la estructura Parser:

(* nparser.sml  *)

exception ParseError of string

structure Parser =
struct
datatype ctoken = TokenSimple of LogLexer.token
                | TokenCompuesto of (LogLexer.token list)

datatype orient = LEFT | RIGHT

fun get_tokens_inpar (x::xs) =
let
  fun get_aux (s::sr, inpar, level) =
    (case s of
         LogLexer.Key "(" => get_aux (sr, inpar@[s], level + 1)
       | LogLexer.Key ")" =>
           if level = 1 then (inpar,sr)
           else get_aux (sr, inpar@[s], level - 1)
       | _ => get_aux(sr, inpar@[s], level)
    )
    | get_aux (nil, inpar, level) = raise ParseError "Error matching ()"
in
  get_aux(xs, nil, 1)
end
  | get_tokens_inpar [] = raise ParseError "Expresion vacia para analisis ()"

fun get_ctokens_aux (x::xs : LogLexer.token list, ctokens : ctoken list) =
  (case x of
       LogLexer.Key "(" =>
         let
           val (v1,v2) = get_tokens_inpar(x::xs)
         in
           get_ctokens_aux (v2, ctokens @ [TokenCompuesto v1])
         end
     | LogLexer.Key ")" => raise ParseError "Exceso de r-par"
     | _ => get_ctokens_aux (xs, ctokens @ [TokenSimple x])
  )
  | get_ctokens_aux (_, ctokens) = ctokens

fun get_ctokens (tokens:LogLexer.token list) : ctoken list =
  get_ctokens_aux (tokens, [])

fun find_symbol (ctokens, s) =
let
  fun fs (ct::xs,pos) =
    (case ct of
         TokenSimple (LogLexer.Key sym) =>
           if sym = s then SOME pos
           else fs (xs, pos + 1)
       | _ => fs (xs, pos + 1)
    )
    | fs (_, pos) = NONE
in
  fs (ctokens,0)
end

fun xpair_by_symbols (ctokens, s::xs) =
let val pos = find_symbol (ctokens,s) in
  case pos of
       NONE => xpair_by_symbols (ctokens, xs)
     | SOME n =>
         SOME (List.take (ctokens, n), s,
               List.drop (ctokens,1 + n))
end
  | xpair_by_symbols (ctokens, _) = NONE

fun pair_by_symbols (ctokens, slist : string list, dir : orient) =
let val pbs = if dir = LEFT
              then xpair_by_symbols (rev ctokens, slist)
              else xpair_by_symbols (ctokens, slist) in
  case pbs of
       NONE => NONE
     | SOME (c1,s,c2) => if dir = LEFT
                         then SOME(rev c2,s,rev c1)
                         else pbs
end

fun parse_not (ctok :: xs) =
  (case ctok of
       TokenSimple (LogLexer.Key "!") => L_NOT(parse_c(xs))
     | _ => raise ParseError "Expresion invalida imposible de procesar"
  )
  | parse_not [] = raise ParseError "Lista de ctokens vacia en parse_not"
and parse_and_or ctoks =
let val track_ao = pair_by_symbols (ctoks, ["&","|"], LEFT) in
  case track_ao of
       NONE => parse_not (ctoks)
     | SOME (c1,"&",c2) => L_AND(parse_c(c1),parse_c(c2))
     | SOME (c1,"|",c2) => L_OR(parse_c(c1),parse_c(c2))
     | SOME (_,s,_) => raise ParseError ("track_ao simbolo '" ^ s ^ "'")
end
and parse_cond ctoks =
let val track_cond = pair_by_symbols (ctoks, ["->"], RIGHT) in
  case track_cond of
       NONE => parse_and_or (ctoks)
     | SOME (c1,_,c2) => L_COND(parse_c(c1),parse_c(c2))
end
and parse_bicond ctoks =
let val track_bicond = pair_by_symbols (ctoks, ["<->"], LEFT) in
  case track_bicond of
       NONE => parse_cond (ctoks)
     | SOME (c1,_,c2) => L_BICOND(parse_c(c1),parse_c(c2))
end
and parse (tokens: LogLexer.token list) = parse_c(get_ctokens tokens)
and parse_c (ltc : ctoken list) =
let val l_ltc = length ltc in
  if l_ltc = 0 then raise ParseError "Lista de ctokens vacia en parse_c"
  else if l_ltc > 1 then parse_bicond ltc
       else (* l_ltc = 1 *)
         let val [ctok] = ltc in
           case ctok of
                TokenSimple ts =>
                  (
                  case ts of
                       LogLexer.Id i => L_ATOM i
                     | LogLexer.Key "#" => BOTTOM
                     | LogLexer.Key k => raise ParseError
                        ("Token simple invalido '" ^ k ^ "'")
                  )
              | TokenCompuesto tlst => parse tlst
         end
end
end

8. Operando con Matrices

En esta sección implementaremos una librería con funciones para realizar cálculos con matrices.

8.1. Utilizando Arrays

SML Proporciona el tipo array que permite crear conjuntos de elementos de longitud fija, indexados por su posición. Éstos pueden ser actualizados.

La estructura Array proporciona funciones para realizar operaciones sobre arrays. Para crear un array de longitud "n" (entero) conteniendo elementos repetidos "v" usaremos Array.array(n,v). La funcion Array.app() es similar a List.app() que permite aplicar una funcion sobre todos los elementos. Sin embargo, las listas no poseen un equivalente a Array.update().

(* matrix1.sml *)

fun show arr = ignore (
  print "[ ";
  Array.app
        (fn x => print ((Real.toString x) ^ " "))
        arr;
  print "]\n");

val a1 = Array.array(4, 0.0);
Array.update (a1, 1, 17.0);
Array.update (a1, 2, 512.1024);
print "Mostrando array a1:\n";
show a1;

El resultado es:

[ 0.0 17.0 512.1024 0.0 ]

8.2. Definiendo operadores

Un operador "infijo" (infix) es una función que se invoca escribiéndolo entre sus dos argumentos. Los ejemplos clásicos de la aritmética son los operadores de adición, sustracción, multiplicación, etc.

SML permite definir operadores adicionales mediante infix, los cuales deben acompañarse de una función que implementa su operación. El siguiente ejemplo ilustra un operador que se puede utilizar para actualizar el valor de un array con la sintaxis conveniente (array,posicion) ← valor:

- infix 0 <- ;
infix <-
- fun ((a,i) <- v) = (Array.update(a, i, v:real) ; a);
val <- = fn : (real array * int) * real -> real array
- val k = Array.array(8, 0.0);
val k = [|0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0|] : real array
- (k,2) <- 5.0;
val it = [|0.0,0.0,5.0,0.0,0.0,0.0,0.0,0.0|] : real array
- (k,5) <- 88.88;
val it = [|0.0,0.0,5.0,0.0,0.0,88.88,0.0,0.0|] : real array

Notar el número cero tras infix el cual representa la prioridad del operador (cero es la mínima, nueve es la máxima.) Esto es útil cuando para determinar el orden de evaluación cuando los operadores se combinan.

8.3. Una firma para matrices

La siguiente firma muestra un conjunto de operaciones que son útiles para operar con matrices.

(* matrix2_sig.sml *)

signature Matrix =
sig
  type t
  (* crear matriz a partir de una lista de listas *)
  val fromList: real list list -> t
  (* comparar dos matrices *)
  val ==      : t*t -> bool
  (* cuantas filas tiene una matriz *)
  val rows    : t -> int
  (* cuantas columnas tiene una matriz *)
  val columns : t -> int
  (* crear una matriz de 1x1 conteniendo el valor *)
  val single  : real -> t
  (* crear una matriz de m*n conteniendo ceros *)
  val zeros   : int*int -> t
  (* crear una matriz de m*n conteniendo unos *)
  val ones    : int*int -> t
  (* crear una matriz identidad de n*n *)
  val eye     : int -> t
  (* ejecutar una funcion para cada elemento
  * de la matriz, fila a fila y dentro de
  * cada fila, de izquierda a derecha *)
  val app     : (int*int*real -> unit) -> t -> unit
  (* actualizar una matriz con los valores retornados por
  * la funcion proporcionada, la cual recibe las
  * coordenadas. Si se proporciona NONE, no hay
  * actualizacion *)
  val fupdate : (int*int -> real option) -> t -> unit
  (* actualizar una celda *)
  val update  : t*int*int*real -> unit
  (* obtener el valor de una celda *)
  val get     : t*int*int -> real
  (* obtener el valor de la posicion (0,0) *)
  val first   : t -> real
  (* obtener el elemento con maximo valor y
  * su posicion *)
  val max     : t -> real*int*int
  (* obtener el elemento con minimo valor y
  * su posicion *)
  val min     : t -> real*int*int
  (* obtener una matriz cuyos elementos
  * son el valor absoluto de los originales *)
  val abs     : t -> t
  (* obtener una matriz cuyos elementos son
  * el producto de los originales por un factor *)
  val smul    : t*real -> t
  (* obtener una copia de la matriz *)
  val clone   : t -> t
  (* obtener la matriz transpuesta de una matriz *)
  val transp  : t -> t
  (* obtener la suma de dos matrices *)
  val add     : t*t -> t
  (* obtener el producto de dos matrices *)
  val prod    : t*t -> t
  (* mostrar el contenido de una matriz *)
  val show    : t -> unit
  (* extraer una submatriz a partir de las posiciones
  * proporcionadas: fila inicial, fila final, columna inicial,
  * columna final. NONE corresponde a una posicion extrema
  * de la matriz *)
  val extract : t*int option*int option*int option*int option -> t
  (* obtener una matriz de elementos en un rango linealmente
  * espaciados proporcionando el extremo inicial, final, y
  * la cantidad de estos *)
  val linspace: real*real*int -> t
  (* obtener una matriz conteniendo la union horizontal
  * de dos matrices *)
  val hjoin   : t*t -> t
  (* obtener una matriz conteniendo la union vertical
  * de dos matrices *)
  val vjoin   : t*t -> t
  (* obtener una matriz a partir de las filas
  * de otra matriz, las cuales se especifican en
  * una lista *)
  val fromRows: t*int list -> t
  (* obtener una matriz a partir de las columnas
  * de otra matriz, las cuales se especifican en
  * una lista *)
  val fromCols: t*int list -> t
  (* obtener una matriz fila de una matriz *)
  val getRow  : t*int -> t
  (* obtener una matriz columna de una matriz *)
  val getCol  : t*int -> t
  (* obtener la matriz que queda tras eliminar
  * un conjunto de filas especificadas en una
  * lista *)
  val dropRows: t*int list -> t
  (* obtener la matriz que queda tras eliminar
  * un conjunto de columnas especificadas en una
  * lista *)
  val dropCols: t*int list -> t
  (* obtener la matriz que resulta de eliminar
  * una fila *)
  val dropRow : t*int -> t
  (* obtener la matriz que resulta de eliminar
  * una columna *)
  val dropCol : t*int -> t
  (* reemplazar una fila en cierta posicion con
  * el contenido de una matriz fila *)
  val repRow  : t*int*t -> t
  (* reemplazar una columna en cierta posicion con
  * el contenido de una matriz columna *)
  val repCol  : t*int*t -> t
  (* resolver un sistema de ecuaciones AX=B representado
  * por una matriz cuadrada de coeficientes y
  * una matriz columna *)
  val solve   : t*t -> t
  (* obtener el determinante de una matriz cuadrada *)
  val det     : t -> real
end

8.4. Estructura Matrix

Definiendo el tipo de dato

Las matrices serán implementadas mediatne el tipo Array; sin embargo, deseamos soportar matrices rectangulares las cuales tienen "m" filas y "n" columnas; sus elementos se almacenarán en un Array de longitud m*n.

Nuestro tipo de dato para representar matrices debe contener toda la información de la matriz: los elementos y sus dimensiones. Para esto usaremos una tupla (elementos:array, filas:int, columnas:int).

(* matrix2.sml: tipo basado en Array *)

use "matrix2_sig.sml";

structure Matrix :> Matrix =
struct
  infix 1 >>
  type t = real array * int * int

  val format_width = 6

  fun rows (_,m,_) = m
  fun columns (_,_,n) = n

Creación de Matrices

La mayoría de funciones son evidentes; dup() aprovecha la funcion Array.copy que emplea un record para comunicar sus parámetros. Notar el uso de #1 dup para obtener el array incorporado en la matriz.

(* matrix2.sml: crear nuevas matrices *)

  fun single s = (Array.array(1, s), 1, 1)
  fun zeros(m, n) =
    if m < 1 orelse n < 1 then raise Subscript
    else (Array.array(m*n, 0.0), m, n)
  fun ones(m, n) =
    if m < 1 orelse n < 1 then raise Subscript
    else (Array.array(m*n, 1.0), m, n)
  fun clone(arr,m,n) =
  let val dup = zeros(m,n) in
    Array.copy({src=arr,dst=(#1 dup),di=0}); dup
  end

Leer y Actualizar elementos

A partir de un par (fila,columna) se puede obtener el índice en el Array interno con la fórmula fila*n + columna asociada al operador >>; si el resultado está fuera del rango [0,m*n> la estructura Array genera la excepción excepción Subscript. Lamentablemente es posible encontrar valores de (fila,columna) que están fuera de las dimensiones [0,m> y [0,n> pero que generan un valor aceptable en la fórmula de índice; a tal efecto hemos creado la función check() que hace las verificaciones necesarias.

Esta función es empleada por get() para obtener un elemento; sin embargo, cuando estamos seguros de estar dentro del rango, la invocación a check() es redundante por lo que preferiremos el operador >>.

La función más interesante es fupdate(), la cual proporciona un mecanismo muy flexible para modificar los valores de una matriz. La función proporcionada se encarga de entregar un valor (real) para introducir en la matriz; sin embargo, no siempre se requiere actualizar todos los valores de una vez, por lo que optamos por retornar SOME n cuando se desea actualizar, y NONE en caso contrario.

Esta función a su vez emplea app(), la cual también recibe una función auxiliar que es invocada fila a fila de manera ordenada, y al interior de cada fila se invoca columna a columna también de manera ordenada, lo que puede ser útil en ciertos casos.

(* matrix2.sml: leer y actualizar elementos *)

  fun ((arr,m,n):t) >> (row,col) = Array.sub(arr, row * n + col)
  fun check(f as (arr,m,n): t, row, col) =
    if row < 0 orelse row >= m orelse col < 0 orelse col >= n
    then raise Subscript else f
  fun get(f as (arr, m, n) : t, row, col) =
    check (f, row, col) >> (row, col)
  fun first (arr, m, n) = Array.sub (arr, 0)
  fun app f (arr,m,n) =
  let
    fun app_col (row,col) =
    let
      val v = Array.sub(arr, row * n + col)
    in
      f (row,col,v) ;
      if col = n - 1 then ()
      else app_col (row, col + 1)
    end
    fun app_row r = (
      app_col (r, 0);
      if r = m - 1 then () else app_row(r + 1)
      )
  in
    app_row 0
  end
  fun fupdate f (mat as (arr,_,n)) =
    app (fn (row,col,_) =>
        case (f (row,col)) of
          SOME v => Array.update(arr, n * row + col, v)
        | NONE => ()
    ) mat
  fun update(f, row, col, v) =
  let val (arr, m, n) = check (f, row, col)
  in
    Array.update(arr, row * n + col, v)
  end

A fin de ilustrar los operadores infijos se ha introducido >> para extraer un elemento. Tener en cuenta que su uso está restringido al interior de la estructura, lo que puede considerarse una limitación de SML.

Aplicando update funcional

Las siguientes funciones ilustran la utilidad y flexibilidad de fupdate(). La única desventaja que presenta es cierta ineficiencia al tener que recorrer toda la matriz cuando no siempre es necesario actualizar todos los elementos.

(* matrix2.sml: creacion mediante fupdate *)

  fun linspace(start, destination, elements) =
  let
    val ans = zeros(1, elements)
    val inter = (destination - start) / (Real.fromInt (elements - 1))
  in
    fupdate (
      fn (_,c) => SOME(start + (Real.fromInt c) * inter)
    ) ans ; ans
  end
  fun fromList (x::xs) =
  let
    val m = 1 + length xs
    val n = length x
    val ans = zeros(m,n)
  in
    if n = 0 then raise Subscript
    else
      (
      fupdate (
        fn (r,c) => SOME(
          List.nth(List.nth(x::xs, r),c))
      ) ans ; ans
      )
  end
  fun eye n =
  let val ans = zeros (n, n) in
    fupdate
      (fn (x,y) => if x = y then SOME 1.0 else NONE) ans ;
    ans
  end

Mostrar la matriz

El código mostrado a continuación ilustra cómo mostrar la matriz de una forma conveniente. Hemos roto la convención de SML para los números negativos prefijándolos con un guión (-) como en la mayoría de lenguajes de programación.

(* matrix2.sml: mostrar elementos *)

  fun show(f as (arr,m,n):t) =
  let
    fun pad(s,n) =
    let
      fun xpad(ls,n) = if length ls >= n
        then ls
        else xpad(#" " :: ls, n)
    in
      String.implode(xpad(String.explode(s), n))
    end
    fun real_pad(r,n) =
      if r >= 0.0 then (pad (Real.toString r, n)) ^ " "
      else (pad ("-" ^ Real.toString (~r), n)) ^ " "
  in
    app (fn (r,c,v) =>
        let
          val prn = real_pad (v, format_width)
        in
          if c = n - 1 then print (prn ^ "\n")
          else print (prn ^ " ")
        end
    ) f
  end

Quizá lo más interesante radica en el uso de app() para mostrar la matriz, aprovechando el orden de invocación que coincide con la forma como normalmente se imprime.

Operaciones comunes

Las operaciones más comunes que se realizan con matrices van a continuación.

(* matrix2.sml: transpuesta, suma, producto *)

  fun transp(q as (arr,m,n)) =
  let val ans = zeros(n,m) in
    fupdate (
      fn (r,c) => SOME (q >> (c,r))
    ) ans ; ans
  end
  fun smul(f, v) =
  let val ans = clone f in
    fupdate (
      fn (r,c) => SOME (v * (ans >> (r, c)))
    ) ans ; ans
  end
  fun add (mat1 as (arr1, m1, n1), mat2 as (arr2, m2, n2)) =
    if m1 <> m2 orelse n1 <> n2 then raise Subscript
    else let val ans = zeros(m1, n1) in
           fupdate (
             fn (r,c) => SOME ((mat1 >> (r,c)) + (mat2 >> (r,c)))
           ) ans ; ans
         end
  fun prod (mat1 as (arr1, m1, n1), mat2 as (arr2, m2, n2)) =
  let
    fun pint(mat1 as (_, _, common): t, mat2: t, row, col) =
    let fun xpint pos =
        if pos = common then 0.0
        else (xpint (pos + 1)) +
          (mat1 >> (row,pos)) * (mat2 >> (pos,col))
    in
      xpint 0
    end
  in
    if n1 <> m2 then raise Subscript
    else
      let val ans = zeros(m1,n2) in
        fupdate (
          fn (r,c) => SOME (pint(mat1, mat2, r, c))
        ) ans ; ans
      end
  end
  fun max f =
  let
    val maxpos = ref (0,0)
    val maxval = ref (first f)
  in
    app ( fn (r,c,v:real) =>
        if v > !maxval then (maxval := v ; maxpos := (r,c) )
        else () ) f ;
    (!maxval, #1 (!maxpos), #2 (!maxpos))
  end
  fun min f =
  let
    val minpos = ref (0,0)
    val minval = ref (first f)
  in
    app ( fn (r,c,v:real) =>
        if v < !minval then (minval := v ; minpos := (r,c) )
        else () ) f ;
    (!minval, #1 (!minpos), #2 (!minpos))
  end
  fun abs f = let val ans = clone(f) in
    fupdate (
      fn (r,c) => SOME (Real.abs(f >> (r,c)))
    ) f ; ans
  end
  fun op==(mat1 as (_,m1,n1),mat2 as (_,m2,n2)) = let
    val allequal = ref true
    fun testelem () = (
      app (
        fn (r,c,v) => if Real.==(v, mat2 >> (r,c))
                     then ()
                     else allequal := false
        )
      mat1 ; !allequal
      )
  in
    m1 = m2 andalso n1 = n2 andalso testelem ()
  end

Extracción y Unión de submatrices

Este grupo corresponde a funciones utilitarias que no tienen mayor complejidad.

(* matrix2.sml: extraer y unir submatrices *)

  fun extract (f as (_ ,m ,n),
    start_row, end_row, start_col, end_col) =
  let
    val rs = getOpt (start_row, 0)
    val re = getOpt (end_row, m - 1)
    val cs = getOpt (start_col, 0)
    val ce = getOpt (end_col, n - 1)
    val ck = check(check(f, rs, cs), re, ce)
    val ans = zeros(1 + re - rs, 1 + ce - cs) in
           fupdate (
             fn (r,c) => SOME (f >> (rs + r, cs + c))
           ) ans ; ans
  end
  fun getRow (f,n) = extract(f, SOME n, SOME n, NONE, NONE)
  fun getCol (f,n) = extract(f, NONE, NONE, SOME n, SOME n)
  fun hjoin (mat1 as (_,m1,n1), mat2 as (_,m2,n2)) =
    if m1 <> m2 then raise Subscript
    else
      let val ans = zeros(m1, n1 + n2) in
        fupdate (
          fn (r,c) => SOME(if c < n1
                      then (mat1 >> (r,c))
                      else (mat2 >> (r,c - n1)))
        ) ans ; ans
      end
  fun vjoin (mat1 as (_,m1,n1), mat2 as (_,m2,n2)) =
    if n1 <> n2 then raise Subscript
    else
      let val ans = zeros(m1 + m2, n1) in
        fupdate (
          fn (r,c) => SOME(if r < m1
                      then (mat1 >> (r,c))
                      else (mat2 >> (r - m1,c)))
        ) ans ; ans
      end
  fun fromRows (f as (_, m, n), lst) =
  let val ans = zeros(length lst, n) in
    fupdate (
      fn (r,c) => SOME (get(f,List.nth (lst,r),c))
    ) ans ; ans
  end
  fun fromCols (f as (_, m, n), lst) =
  let val ans = zeros(m,length lst) in
    fupdate (
      fn (r,c) => SOME (get(f,r,List.nth (lst,c)))
    ) ans ; ans
  end
  fun subtract(rangeExtreme, lst) =
  let
    fun xsubtract(cur, ~1) = cur
      | xsubtract(cur, n) =
         if (List.exists (fn x => x = n) lst)
         then xsubtract(cur, n - 1)
         else xsubtract(n::cur, n - 1)
  in
    xsubtract(nil, rangeExtreme - 1)
  end
  fun dropRows (f, rowlist) =
    fromRows(f, subtract(rows f, rowlist))
  fun dropCols (f, collist) =
    fromCols(f, subtract(columns f, collist))
  fun dropRow (f, rowpos) = dropRows (f, [rowpos])
  fun dropCol (f, colpos) = dropCols (f, [colpos])
  fun repRow(f, pos, newrow) = let
    val ans = clone(f)
  in
    app (fn (r,c,newval) => update(ans, pos, c, newval))
        newrow ; ans
  end
  fun repCol(f, pos, newcol) = let
    val ans = clone(f)
  in
    app (fn (r,c,newval) => update(ans, r, pos, newval))
        newcol ; ans
  end

Resolución de ecuaciones lineales y determinantes

Aplicando el método de eliminación gausiana mediante la función solve().

(* matrix2.sml: resolucion de sistemas de ecuaciones *)

  fun gaussianelim f = if rows f = 1 then (1.0,[f]) else
  let
    fun getpivotrow f =
    let
      val (v,pivotpos,_) = max(abs(getCol(f, 0)))
    in
      if Real.==(v, 0.0) then raise Div
      else (pivotpos, getRow(f, pivotpos))
    end
    fun elimrow (f, pivotrow, toElim) =
      if toElim = rows f then f
      else
        let
          val factor = ~((f >> (toElim,0)) / first pivotrow)
          val toAdd = smul (pivotrow, factor)
          val newRow = add(toAdd, getRow(f, toElim))
          val added = repRow (f, toElim, newRow)
        in
          elimrow (added, pivotrow, toElim + 1)
        end
    val (pivot_pos,pivot_row) = getpivotrow f
    val wopivotrow = dropRow (f,pivot_pos)
    val (sgn,nextrows) = gaussianelim (
      dropCol(elimrow(wopivotrow, pivot_row, 0), 0))
    val newsgn = if pivot_pos mod 2 = 1 then ~sgn else sgn
  in
    (newsgn,pivot_row::nextrows)
  end
  fun solve_gauss nil = single ~1.0
    | solve_gauss (p::rest) =
    let
      val sols = solve_gauss rest
      val prest = dropCol (p, 0)
      val pesc = prod (sols, transp prest)
      val newsol = ~(first pesc / first p)
    in
      hjoin (single newsol, sols)
    end
  fun solve (A,B) =
  let
    val both = hjoin (A,B)
    val (_,ge) = gaussianelim both
    val solutions = solve_gauss ge
    val last_col = columns solutions - 2
  in
    transp(extract
      (solutions,
        NONE, NONE, NONE, SOME last_col))
  end
  fun det f =
  let
    val (sgn,ge) = gaussianelim f handle Div => (0.0, nil)
    fun prod1st nil = 0.0
      | prod1st [x] = first x
      | prod1st (x::xs) = first x * prod1st xs
  in
    sgn * prod1st ge
  end
end

El siguiente ejemplo muestra la solución del un sistema de ecuaciones (los valores se han tomado de un ejemplo de [PAULSON].)

La función gaussianelim() se encarga de transformar una matriz a su "forma triangular", devolviendo una lista de matrices fila de longitud decreciente. Como se sabe, las matrices triangulares permiten obtener el determinante con facilidad (multiplicando los valores de la diagnonal) lo que motiva a mantener esta función independiente (externa) a solve(). Recordando que la "eliminación gausiana" requiere en cada paso encontrar una "fila pivot" la cual efectivamente pasa a ser la primera fila, debe tenerse en cuenta que esto puede alterar el signo del determinante a ser calculado. Es por este motivo que gaussianelim() también retorna un factor de signo para el determinante (1 o -1) que se invierte en cada iteración si la fila pivot tiene posición par (es decir, si pivot_pos es impar.)

val A = [[ 0.0,1.0,2.0,7.0],
         [~4.0,0.0,3.0,~5.0],
         [4.0,~1.0,~2.0,~3.0],
         [~2.0,1.0,2.0,8.0]];
- val B = [[7.0,~2.0,9.0,2.0]];
- val AT = Matrix.fromList A;
val AT = - : Matrix.t
- val BT = Matrix.transp (Matrix.fromList B);
val BT = - : Matrix.t
- Matrix.show(Matrix.solve(AT,BT));
   3.0   -10.0     5.0     1.0

8.5. Interactuando con las matrices

Inspirados en Octave, deseamos proporcionar una interfaz interactiva para nuestra librería de matrices. La siguiente sesión ilustra esta interfaz:

IMATRIX> a=[1,2;6,19]
   1.0     2.0
   6.0    19.0
IMATRIX> b=[5,3]
   5.0     3.0
IMATRIX> bt=b'
   5.0
   3.0
IMATRIX> x=a\bt
12.7142857143
-3.85714285714
IMATRIX> det(a)
7.0
IMATRIX> a*x-bt
   0.0
   0.0
IMATRIX> (a*x-bt)'
   0.0     0.0
IMATRIX> eye(4)
   1.0     0.0     0.0     0.0
   0.0     1.0     0.0     0.0
   0.0     0.0     1.0     0.0
   0.0     0.0     0.0     1.0

Comparemos con lo que se obtiene en Octave:

octave:1> a=[1,2;6,19]
a =

    1    2
    6   19

octave:2> b=[5,3]
b =

   5   3

octave:3> bt=b'
bt =

   5
   3

octave:4> x=a\bt
x =

   12.7143
   -3.8571

octave:5> det(a)
ans =  7.0000
octave:6> a*x-bt
ans =

   0
   0

octave:7> (a*x-bt)'
ans =

   0   0

octave:8> eye(4)
ans =

Diagonal Matrix

   1   0   0   0
   0   1   0   0
   0   0   1   0
   0   0   0   1

Utilizando las ideas de análisis léxico y parsing del programa de validador lógico procedemos a implementar esta aplicación.

Analizador léxico

El analizador es similar al que vimos anteriormente y que proviene de [PAULSON]. La novedad principal es que hemos introducido el punto (.) como parte de un identificador, lo que nos permite capturar números negativos.

Char.isAlphaNum x orelse x = #"."

Notar el uso del backlash (\) que significa "resolución de AX=B", lo que se implementará por eliminación gausiana.

(* extraido de Paulson: ML for the working programmer 2ed *)
signature LEXICAL =
sig
  datatype token = Id of string | Key of string
  val scan : string -> token list
end;

signature KEYWORD =
sig
  val alphas : string list
  and symbols : string list
end;

structure LogKeyword : KEYWORD =
struct
  val alphas = nil
  val symbols = [ "(", ")", "+", "-", "*", ",", ";", "[", "]", "=", "\\" ]
end;


functor Lexical (Keyword: KEYWORD) : LEXICAL =
struct
  datatype token = Id of string | Key of string
  fun member (x:string, l) = List.exists (fn y => x=y) l
  fun alphaTok a =
    if member(a, Keyword.alphas) then Key(a) else Id(a)
  fun symbolic (sy,ss) =
    case Substring.getc ss of
         NONE => (Key sy, ss)
       | SOME (c,ss1) =>
           if member(sy, Keyword.symbols)
           orelse not (Char.isPunct c)
           then (Key sy, ss)
           else symbolic (sy ^ String.str c, ss1);
  fun scanning (toks, ss) =
    case Substring.getc ss of
         NONE => rev toks
       | SOME (c,ss1) =>
           if Char.isAlphaNum c orelse c = #"."
           then
             let
               val (id,ss2) = Substring.splitl
                              (fn x => Char.isAlphaNum x orelse x = #".")
                              ss
               val tok = alphaTok (Substring.string id)
             in scanning (tok::toks, ss2)
             end
           else if Char.isPunct c
                then
                  let val (tok,ss2) = symbolic (String.str c, ss1)
                  in scanning (tok::toks, ss2)
                  end
                else
                  scanning(toks, Substring.dropl(not o Char.isGraph) ss);
  fun scan a = scanning([], Substring.full a)
end

structure LogLexer = Lexical(LogKeyword);

Programa principal

Lo principal de este programa es el parser (pues las operaciones matriciales se derivan a la estructura Matrix.) Notar que hemos definido un tipo de dato assignments que contendrá las "variables" creadas durante la sesión mediante una lista de elementos (nombre-variable,matriz).

(* imatrix.sml: interfaz interactiva para matrices *)

use "matrix2.sml";
use "imatrix-lex.sml";

exception UserAbort
exception Syntax of string

datatype ctoken = TSimple of LogLexer.token
                | TParentesis of (LogLexer.token list)
                | TCorchetes of (LogLexer.token list)

type mt = Matrix.t

type assignment = string*mt

type assignments = assignment list ref

A contnuación un grupo de funciones utilitarias:

(* imatrix.sml: funciones utilitarias *)

fun trim x = let
    val l = String.explode x
      fun ltrim (ch::xs) = if Char.isSpace ch then xs else ch::xs
        | ltrim _ = nil
in
    String.implode(rev(ltrim(rev (ltrim l))))
end

fun getline prompt = (
  print (prompt ^ " ");
  case (TextIO.inputLine(TextIO.stdIn)) of
      SOME k => trim(k)
    | NONE => raise UserAbort )

(* obtener el valor de una variable *)
fun get_from_am (atom:string, am:assignments):mt =
let val found = List.find (fn x=> atom = (#1 x)) (!am)
in
  case found of
       NONE => raise Syntax ("Bad identifier '" ^ atom ^ "'")
     | SOME n => #2 n
end

(* obtener tokens entre parentesis o entre corchetes *)
fun get_tokens_inpar (x::xs) =
let
  fun get_aux (s::sr, inpar, level) =
    (case s of
         LogLexer.Key "(" => get_aux (sr, inpar@[s], level + 1)
       | LogLexer.Key "[" => get_aux (sr, inpar@[s], level + 1)
       | LogLexer.Key ")" =>
           if level = 1 then (inpar,sr)
           else get_aux (sr, inpar@[s], level - 1)
       | LogLexer.Key "]" =>
           if level = 1 then (inpar,sr)
           else get_aux (sr, inpar@[s], level - 1)
       | _ => get_aux(sr, inpar@[s], level)
    )
    | get_aux (nil, inpar, level) = raise Syntax "Error de matching () o []"
in
  get_aux(xs, nil, 1)
end
  | get_tokens_inpar [] = raise Syntax "Expresion vacia para analisis ()"

(* obtener ctokens a partir de tokens *)
fun get_ctokens (tokens:LogLexer.token list) : ctoken list =
let
  fun get_ctokens_aux (x::xs : LogLexer.token list, ctokens : ctoken list) =
    (case x of
       LogLexer.Key "(" =>
         let
           val (v1,v2) = get_tokens_inpar(x::xs)
         in
           get_ctokens_aux (v2, ctokens @ [TParentesis v1])
         end
     | LogLexer.Key "[" =>
         let
           val (v1,v2) = get_tokens_inpar(x::xs)
         in
           get_ctokens_aux (v2, ctokens @ [TCorchetes v1])
         end
     | LogLexer.Key ")" => raise Syntax "Exceso de r-parentesis"
     | LogLexer.Key "]" => raise Syntax "Exceso de r-corchetes"
     | _ => get_ctokens_aux (xs, ctokens @ [TSimple x])
    )
    | get_ctokens_aux (_, ctokens) = ctokens
in
  get_ctokens_aux (tokens, [])
end

(* consultar si el ctoken de posicion pos es el simbolo sym *)
fun isSymbol (ctokens, sym, pos) =
  if length ctokens <= pos then false
  else case List.nth(ctokens,pos) of
            TSimple ts => (
              case ts of
                   LogLexer.Key k => k = sym
                 | _ => false
            )
          | _ => false

(* obtener identificador de un ctoken *)
fun getId ctoken =
  case ctoken of
      TSimple ts => (
        case ts of
           LogLexer.Id k => k
         | _ => raise Syntax "Se obtuvo simbolo donde se requeria identificador"
      )
    | _ => raise Syntax "Se obtuvo expresion donde se requeria identificador"

(* buscar posicion de un simbolo en una lista de ctokens *)
fun find_symbol (ctokens, s) =
let
  fun fs (ct::xs,pos) =
    (case ct of
         TSimple (LogLexer.Key sym) =>
           if sym = s then SOME pos
           else fs (xs, pos + 1)
       | _ => fs (xs, pos + 1)
    )
    | fs (_, pos) = NONE
in
  fs (ctokens,0)
end

fun xpair_by_symbols (ctokens, s::xs) =
let val pos = find_symbol (ctokens,s) in
  case pos of
       NONE => xpair_by_symbols (ctokens, xs)
     | SOME n =>
         SOME (List.take (ctokens, n), s,
               List.drop (ctokens,1 + n))
end
  | xpair_by_symbols (ctokens, _) = NONE

(* desde [a,b,%,c,d,...] genera[[a,b],[c,d]...]]
 * si % es el delimitador *)
fun sublist (src,fdelim) =
let
  fun sublistaux (result,src::xs,fdelim) =
    if fdelim src then
      sublistaux(nil::result,xs,fdelim)
    else
      if null result then
        sublistaux ([[src]],xs,fdelim)
      else
        let
          val r1::rest = result
        in
          sublistaux((r1@[src])::rest,xs,fdelim)
        end
    | sublistaux (result,[],_) = result
in
  rev(sublistaux([],src,fdelim))
end

(* dividir una lista en sublistas de hasta n elementos *)
fun divide (src,n) =
let
  fun daux (result,src::xs) =
      if null result then
        daux ([[src]],xs)
      else
        let
          val r1::rest = result
        in
          if length r1 = n then
            daux([src]::r1::rest,xs)
          else
            daux((r1@[src])::rest,xs)
        end
    | daux (result,[]) = result
in
  rev(daux([],src))
end

(* obtener argumento convertido a entero, real y matriz *)
fun iarg (argvals, pos):int =
let val v = List.nth(argvals,pos) in
     Real.floor (Matrix.first v)
end

fun rarg (argvals, pos):real =
let val v = List.nth(argvals,pos) in
     Matrix.first v
end

fun marg (argvals, pos):mt = List.nth(argvals,pos)

Luego el parser, el cual a diferencia del programa de lógica, no construye una estructura sino que intenta evaluar directamente el resultado a una matriz. Hemos incluido algunas de las funciones proporcionadas por la librería de matrices, pero otras pueden ser agregadas con relativa facilidad.

(* imatrix.sml: parsing y evaluacion *)

fun eval (tokens: LogLexer.token list, am:assignments): (mt list*int) =
let
  val ctokens = get_ctokens tokens
in
  eval_clist (ctokens,am)
end
and eval_clist (ctokens: ctoken list,am:assignments): (mt list * int) =
let
  val faux = fn (ct,sym:string list) => case ct of
                        TSimple ts => (
                          case ts of
                               LogLexer.Key k =>
                                 List.exists (fn x => x = k) sym
                             | _ => false
                        )
                       | _ => false
  val subs = sublist(ctokens,fn ct => faux(ct,[",",";"]))
  val subs_semi = sublist(ctokens,fn ct => faux(ct,[";"]))
  val row_w = (length subs) div (length subs_semi)
in
  (map (fn x=>eval_c(x,am)) subs, row_w)
end
and eval_c (ctokens: ctoken list,am:assignments): mt =
let val lc = length ctokens in
  if lc = 0 then raise Syntax "Expresion vacia invalida"
  else if lc > 1 then eval_assign (ctokens,am)
       else let val [ctok] = ctokens in
              case ctok of
                   TSimple ts =>
                   (
                   case ts of
                        LogLexer.Id i => get_atom_val (i,am)
                      | LogLexer.Key k => raise Syntax
                          ("Simbolo en lugar incorrecto '" ^ k ^ "'")
                   )
                 | TParentesis tlst => let
                       val lres = #1 (eval (tlst,am)) in
                       if length lres <> 1 then
                         raise Syntax "Se requiere un argumento"
                       else hd lres end
                 | TCorchetes tlst => let
                       val (lres,row_w) = eval (tlst,am)
                                       in
                       if length lres = 0 then
                         raise Syntax "Se requiere valores entre [...]"
                       else Matrix.fromList(divide(map (Matrix.first)
                            lres,row_w)) end
            end
end
and string2real s =
  if String.sub(s,0) = #"-" then
    Real.fromString (String.substring(s, 1, size s - 1))
  else
    Real.fromString s
and get_atom_val (atom:string,am:assignments):mt =
  if Char.isAlpha (String.sub(atom,0)) then get_from_am (atom,am)
  else let val rval = string2real atom
       in
         case rval of
              NONE => raise Syntax "Expresion numerica invalida"
            | SOME rval' => Matrix.fromList [[rval']]
       end
and eval_assign (ctokens,am) =
  if length ctokens >= 3 andalso isSymbol(ctokens,"=",1) then
    let
      val as_val = eval_c(List.drop(ctokens,2),am)
      val apair = (getId(List.nth(ctokens,0)),as_val)
    in
      am := (apair :: (!am)) ; as_val
    end
  else
    eval_sum (ctokens,am)
and eval_sum (ctokens,am) =
let val track_sum = pair_by_symbols(ctokens,["+","-"],am) in
  case track_sum of
       NONE => eval_mul (ctokens,am)
     | SOME (c1,"+",c2) => Matrix.add(c1,c2)
     | SOME (c1,"-",c2) =>
         Matrix.add(c1,Matrix.smul(c2,~1.0))
end
and eval_mul (ctokens,am) =
let val track_mul = pair_by_symbols(ctokens,["*"],am) in
  case track_mul of
       NONE => eval_mldivide (ctokens,am)
     | SOME (c1,_,c2) => Matrix.prod(c1,c2)
end
and eval_mldivide(ctokens,am) =
let val track_ml = pair_by_symbols(ctokens,["\\"],am) in
  case track_ml of
       NONE => eval_transp (ctokens,am)
     | SOME (c1,_,c2) => Matrix.solve(c1,c2)
end
and eval_transp(ctokens,am) =
  if isSymbol (ctokens,"'",length ctokens - 1) then
    let
      val rest = rev(List.drop(rev ctokens,1))
      val tran = eval_c(rest,am)
    in
      Matrix.transp tran
    end
  else eval_neg (ctokens,am)
and eval_neg(ctokens,am) =
  if isSymbol (ctokens,"-",0) then
    let
      val rest = List.drop(ctokens,1)
      val tran = eval_c(rest,am)
    in
      Matrix.smul(tran,~1.0)
    end
  else eval_fun (ctokens,am)
and eval_fun (ctokens,am) =
  if length ctokens <> 2 then
    raise Syntax "Error de Sintaxis"
  else
    let
      val [idfun,TParentesis tlst] = ctokens
      val fname = getId idfun
      val argvals = #1 (eval(tlst,am))
      (* FIXME crear funcion check_fun_nparams(fname,nparams) *)
    in
      case fname of
           "eye" => let val n = iarg(argvals,0) in
             if n < 1 then raise Syntax "eye() requiere entero positivo"
             else Matrix.eye(n) end
         | "zeros" => let val n1 = iarg(argvals,0)
                          val n2 = iarg(argvals,1) in
             if n1 < 1 orelse n2 < 1 then
               raise Syntax "zeros() requiere enteros positivos"
             else Matrix.zeros(n1,n2) end
         | "ones" => let val n1 = iarg(argvals,0)
                          val n2 = iarg(argvals,1) in
             if n1 < 1 orelse n2 < 1 then
               raise Syntax "ones() requiere enteros positivos"
             else Matrix.ones(n1,n2) end
         | "rows" => let val m = marg(argvals,0) in
             Matrix.fromList [[Real.fromInt (Matrix.rows m)]] end
         | "columns" => let val m = marg(argvals,0) in
             Matrix.fromList [[Real.fromInt (Matrix.columns m)]] end
         | "det" => let val m = marg(argvals,0) in
             Matrix.fromList [[Matrix.det m]] end
         | _ => raise Syntax "Funcion desconocida"
    end handle Bind => raise Syntax "Argumentos deben ir entre parentesis"
and pair_by_symbols (ctokens, slist : string list, am) =
let val pbs = xpair_by_symbols (rev ctokens, slist)
in
  case pbs of
       NONE => NONE
     | SOME (c1,s,c2) => if null c1 orelse null c2 then NONE
                         else SOME(eval_c(rev c2,am),s,eval_c(rev c1,am))
end

Un desarrollo interesante corresponde a la capacidad de definir nuevas funciones, pero no lo implementaremos aquí.

Finalmente, el loop principal donde se inicia el programa:

(* imatrix.sml: loop interactivo *)
fun main(am:assignments) =
let
  val line = trim(getline "IMATRIX>")
in
  if line = "quit" then ()
  else
    if line = "" then main(am)
    else (
         let
           val tokens = LogLexer.scan line
           val exps = #1(eval (tokens,am))
         in
           app (fn e=> Matrix.show e) exps
         end handle Syntax msg => print (msg ^ "\n")
                           | _ => print "Excepcion desconocida\n" ;
         main(am)
         )
end;

main(ref []);

8.6. Usando Archivos de Octave

En esta sección desarrollaremos una estructura con funciones para leer y escribir archivos de texto plano en el formato usado por Octave. A continuación un ejemplo de estos archivos:

# Created by Octave 3.8.1, Mon Aug 03 20:31:19 2015 PET <diego@host>
# name: y
# type: matrix
# rows: 4
# columns: 4
 2.149571848872152 8.744583592805938 2.419236220032078 2.881176465356625
 2.850172431481099 2.06485186349021 7.457562298652526 3.595634116704513
 3.553630476144513 7.844005549116849 8.479609554490658 6.060585590336842
 1.311409291031572 8.504476077439353 6.66286902876988 2.559602034068301

# name: t
# type: matrix
# rows: 4
# columns: 4
 1 -1 1 -1
 -1 -1 1 -1
 -1 1 -1 1
 1 -1 1 -1

Estructura SML

El formato del archivo es bastante evidente. Debe tenerse cuidado con el uso del signo dash (-) para los negativos.

Lo más interesante corresponde a la carga (load()) donde se debe apreciar el uso de la referencia state que mantiene un estado de tipo readstate; dicho estado permite al bucle de lectura determinar el tipo de texto que se espera leer a continuación.

Asimismo get_by_name() permite obtener una matriz por su nombre.

use "matrix2.sml";

structure MatrixOctave =
struct
  datatype readstate = WAIT_NAME |
    WAIT_MATRIX | WAIT_ROWS | WAIT_COLS | WAIT_DATA of int
  val transf = String.translate (fn ch => if ch = #"-" then "~" else str(ch));
  val transt = String.translate (fn ch => if ch = #"~" then "-" else str(ch));
  fun load (filename) : (string*Matrix.t) list =
  let
    val io = TextIO.openIn filename
    val ans = ref nil
    val do_read = ref true
    val state = ref WAIT_NAME
    val cur_name = ref "none"
    val cur_rows = ref 0
    val cur_mat = ref (Matrix.single 1.0)
    fun update_row (row, mat, txt) =
    let
      val toks = String.tokens Char.isSpace txt
      val rlist = map (valOf o Real.fromString o transf) toks
      val rmat = Matrix.fromList [rlist] (* una fila *)
      val rowpos = Matrix.rows (!cur_mat) - row
    in
      cur_mat := Matrix.repRow (!cur_mat, rowpos, rmat)
    end
    fun extrim(s:string, start:int) =
    let
      val rlst = rev (String.explode (String.extract (s, start, NONE)))
      fun cutter nil = nil
        | cutter (ch::xs) =
            if Char.isSpace ch then cutter xs
            else ch::xs
    in
      String.implode (rev (cutter rlst))
    end
    fun process line =
      case !state of
           WAIT_NAME =>
             if String.isPrefix "# name: " line
             then (cur_name := extrim (line, 8) ;
                   state := WAIT_MATRIX)
             else ()
         | WAIT_MATRIX =>
             if String.isPrefix "# type: matrix" line
             then state := WAIT_ROWS
             else ()
         | WAIT_ROWS =>
             if String.isPrefix "# rows: " line
             then (cur_rows := valOf (Int.fromString (extrim (line, 8))) ;
                   state := WAIT_COLS)
             else ()
         | WAIT_COLS =>
             if String.isPrefix "# columns: " line
             then
               let
                 val ncols = valOf(Int.fromString (extrim (line, 11)))
               in
                 (
                 cur_mat := Matrix.zeros(!cur_rows, ncols) ;
                 state := WAIT_DATA(ncols)
                 )
               end
             else ()
         | WAIT_DATA n =>
             (
               update_row (n, !cur_mat, line) ;
               if n > 1 then state := WAIT_DATA (n - 1)
               else (
                    ans := (!ans) @ [(!cur_name, !cur_mat)] ;
                    state := WAIT_NAME
                    )
             )
  in
    while !do_read
      do (
        case (TextIO.inputLine io) of
             SOME line => process line
           | NONE => do_read := false
      ) ; TextIO.closeIn io ; !ans
  end

  fun get_by_name (nil, _) = raise Subscript
    | get_by_name ((n,mat)::xs, name) =
        if n = name then mat
        else get_by_name(xs, name)

  fun save (filename, matlist) =
  let
    val io = TextIO.openOut filename
    fun save_header(name,mat) =
    let
      val prows = Int.toString (Matrix.rows mat)
      val pcols = Int.toString (Matrix.columns mat)
    in
      TextIO.output (io,"# name: " ^ name ^ "\n");
      TextIO.output (io,"# type: matrix\n");
      TextIO.output (io,"# rows: " ^ prows ^ "\n");
      TextIO.output (io,"# columns: " ^ pcols ^ "\n")
    end

    fun save_rows mat = Matrix.fupdate (
        fn (r,c) => let
                      val vs = transt(Real.toString(
                                 Matrix.get(mat,r,c)))
                      val toPrint = " " ^ vs;
                    in
                      if c = Matrix.columns mat - 1
                      then TextIO.output (io, toPrint ^ "\n")
                      else TextIO.output (io, toPrint)
                      ; NONE
                    end
      ) mat
    fun xsave((name,mat)::xs) = (
      save_header (name,mat);
      save_rows mat;
      xsave xs
      )
      | xsave(nil) = ()
  in
    TextIO.output (io, "# Created by MatrixOctave\n");
    xsave(matlist);
    TextIO.closeOut io
  end

end

A continuación un ejemplo de operación:

$ octave
GNU Octave, version 3.8.1
Copyright (C) 2014 John W. Eaton and others.
[...]
octave:1> m1 = (rand(6) - 0.5) * 50
m1 =

   11.3766   -2.8605   11.5256  -12.3394   -2.0533   17.5782
   -2.8420   -9.7033  -11.3983   -9.9446  -16.8160   -6.5252
    5.4047    7.0326  -20.3298   -2.7136   -4.7485  -21.2084
  -17.6776   -1.9356  -10.8609  -22.3254    1.2494   14.9223
   -2.6842    3.6444   13.3589   -6.6871   10.8126  -12.9107
  -16.5650   -8.4934  -23.5436  -19.6046   22.6706   -5.8875

octave:2> m2 = (rand(6) - 0.5) * 30
m2 =

   13.94065    7.70766   -1.15770   -1.39688   -7.10200   11.61498
   -9.15929    5.87039   -4.06025  -12.65760    0.22203   -6.45560
    4.90814    2.40369    3.78310   -0.73032   -7.21622   -1.23769
    7.53967    5.03683   -4.15009    0.93911   -8.30512   14.54988
   -8.74928    0.75895  -10.08109  -12.55593  -13.99280   10.16405
   14.13159   -4.06752    9.62969    5.58549  -12.78044    7.09903

octave:3> det(m1 * m2)
ans =    8.5064e+13
octave:4> save "to-sml.oct" m1 m2
octave:5> exit

Hemos guardado las matrices "m1" y "m2" en el archivo to-sml.oct. Ahora ejecutamos SML:

- val fromOctave = MatrixOctave.load "to-sml.oct";
val fromOctave = [("m1",-),("m2",-)] : (string * Matrix.t) list
- val m1 = MatrixOctave.get_by_name (fromOctave, "m1");
val m1 = - : Matrix.t
- val m2 = MatrixOctave.get_by_name (fromOctave, "m2");
val m2 = - : Matrix.t
- Matrix.det(Matrix.prod(m1,m2));
val it = 8.50635810232E13 : real
- val m3 = Matrix.add(m1,m2);
val m3 = - : Matrix.t
- Matrix.det m3;
val it = ~294543795.741 : real
- val toOctave = ("m3",m3)::fromOctave;
val toOctave = [("m3",-),("m1",-),("m2",-)] : (string * Matrix.t) list
- MatrixOctave.save ("to-octave.oct",toOctave);
val it = () : unit

Se han cargado las matrices "m1" y "m2" y luego se han vuelto a grabar junto con la matriz "m3" en el archivo to-octave.oct. Ahora volvemos a Octave:

$ octave
GNU Octave, version 3.8.1
Copyright (C) 2014 John W. Eaton and others.
[...]
octave:1> load "to-octave.oct"
octave:2> det(m3)
ans =   -2.9454e+08

Esta capacidad de lectura/escritura puede ser agregada a la interfaz interactiva a fin de enriquecerla.

Bibliografía

El libro de Paulson es un clásico que va mucho más allá del lenguaje SML; discute diversas estructuras de datos, cálculo lambda y técnicas de prueba automática.

Libros Consultados

[PAULSON] Paulson, L. C. "ML for the working programmer" 2ed. Cambridge University Press. 1996.

[HANSEN] Hansen & Rischel "Introduction to Programming using SML". Addison-Wesley. 1999.

En la Web

[HARPER] Harper, Robert "Programming in Standard ML" http://www.cs.cmu.edu/~rwh/introsml/

[TOFTE] Tofte, Mads "Tips for Computer Scientists on Standard ML" https://www.itu.dk/people/tofte/publ/tips.pdf

[SMLFAM] Standard ML Family GitHub Project http://sml-family.org/