Source: https://americati.com/doc/smlsample/smlsample.html
Timestamp: 2020-01-29 21:20:11+00:00

Document:
Aprendiendo Standard ML
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 polyml
En lo que sigue asumiremos SML/NJ pero esto es indistinto.
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.)
Ejemplos de Sintaxis Básica
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
[opening fact1.sml]
val fact1 = fn : int -> int
- fact1 4;
- fact1(10);
- fact1 15;
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.
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.
fact 2 - 4 es igual que (fact 2) - 4, es decir, la función tiene más precedencia que otros operadores.
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";.
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))))
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)
A esto se le conoce como evaluación "tail recursive".
(* 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
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);
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))
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)
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));
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");
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.
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));
- 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:
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))
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:
let val menosb = ~b
val raizd = Math.sqrt d
val doblea = 2.0 * a
in ((menosb + raizd) / doblea,
(menosb - raizd) / doblea)
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])].
La función null permite conocer si una lista está vacía.
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);
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);
- polprod (P,Q);
val it = [1,3,3,1] : int list
- polpow (Q,3);
- poltext (polpow(Q,3));
val it = "+1+3x^1+3x^2+1x^3" : string
(* 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 *)
fun add([], mayor) = mayor
| add(x::menor, y::mayor) = (x+y)::add(menor,mayor)
fun poladd(p1, p2) = if (length p1) > (length p2) then add(p2,p1) else add(p1,p2)
(* 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 *)
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^" ^
fun polrun([x],deg) = termtext(x,deg)
| polrun(x::xs, deg) = termtext(x, deg) ^ polrun(xs, deg + 1)
fun poltext(x) = polrun(x, 0)
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) =
val rm = ref m
val rn = ref n
!rn > 0
r := !rm mod !rn ;
rm := !rn ;
rn := !r
) ; !rm
Fibonacci interactivo
Notar el uso común de una referencia para almacenar un contador. Del mismo modo para acumuladores.
val s1 = ref 0
val s2 = ref 1
val cnt = ref n
val t = ref 1
while !cnt > 1
t := !s1 + !s2;
s1 := !s2;
s2 := !t;
cnt := !cnt - 1
); !t
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.)
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.
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:
case (TextIO.inputLine(TextIO.stdIn)) of
SOME k => SOME (Trimmer.trim(k))
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.
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
String.implode(xtrim(String.explode x))
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.
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
reversar(ltrim(reversar x))
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);
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 =
fun xtrim(ch::xs) =
fun trim x = ltrim(rtrim x);
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).
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 =
fun do_loop (prompt,extfun,arg,quitflag:string) =
val flag = ref true
while !flag
case (getline prompt) of
SOME k => if k = quitflag then
extfun(arg,k)
| NONE => flag := false
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).
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.
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 c?
angulo A? 45
angulo B?
angulo C?
Falta informacion para resolver el triangulo
lado b? 50
lado c? 20
angulo A?
Triangulo invalido
lado a? 3
lado b? 4
lado c? 5
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) =
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
app print_triangle (print_empty(solve t)) handle BadTriangle =>
print "Triangulo invalido\n"
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 =
val z = ListPair.zip (["a","b","c","A","B","C"],t)
app (fn (t,v) => print (t ^ "=" ^ Real.toString(v) ^ " ") ) z;
fun print_empty nil = (print "Falta informacion para resolver el triangulo\n"; nil)
| print_empty ans = ans;
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;
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) =
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)
replacer (rtriang, xs)
| 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.
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) =
val [_,_,_,SOME A, SOME B, NONE] = triangulo;
val C = 180.0 - A - B
List.take(triangulo,3)@[SOME A, SOME B, SOME C]
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.
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) =
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)
[replacer(triangulo,[(3,A), (1,b), (2,c)])]
(* resolver caso en el que se conoce el angulo A y los lados b y c *)
fun solve_lal (triangulo: real option list) =
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)
[replacer(triangulo,[(0,a), (4,B), (5,C)])]
fun solve_lll (triangulo: real option list) =
val [SOME a, SOME b, SOME c,_,_,_] = triangulo;
val A = acos((b*b+c*c-a*a)/(2.0*b*c))
solve_lal(replacer(triangulo,[(3,A)]))
(* resolver cuando se conoce A, c y a *)
fun solve_all(triangulo: real option list) =
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
if C - A < tolerancia orelse abs(C-90.0) < tolerancia
val C' = 180.0 - C;
val B' = 180.0 - A - C';
val t2 = solve_ala(replacer(triangulo,[(4,B'),(5,C')]))
t1 @ t2
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.)
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.
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));
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) =
val methods = [solve_llls, solve_alas, solve_lals, solve_alls, solve_llas]
and atriangulo = completar_angulos triangulo
map (map valOf) (msolve (atriangulo, methods))
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.
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) =
val [a : real,b,c,_,_,_] = rotador triangulo
if c > a + b orelse c < abs(a - b) then raise BadTriangle
else check_triangle_sides (rots, triangulo)
| check_triangle_sides (_, triangulo : real list) = triangulo;
fun check_triangle(triangulo : real list) =
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)
abs(A + B + C - 180.0) < tolerancia andalso
abs(sa - sb) < tolerancia andalso
abs(sa - sc) < tolerancia
then triangulo
else raise BadTriangle
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:
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():
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);
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 =
type prcontext
val get_nth : prcontext * int -> int
val get_context : prcontext
val print_context : prcontext -> unit
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
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.
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 =
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) =
val cnt = length(!ctx)
if n < cnt then
List.nth(!ctx, n)
val newpr = get_k_primos(!ctx, 1 + n - cnt)
(ctx := newpr ; List.last(newpr))
fun print_context(ctx : prcontext) =
print (foldr
(fn(s1,s2) => s1 ^ " " ^ s2)
(map (Int.toString) (!ctx))
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".
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";
fun main(context, line) =
"l" => Primosa.print_context context
| _   => (case Int.fromString(line) of
SOME num =>
print "Valor invalido\n"
Int.toString(Primosa.get_nth(context,num))
print "Valor inadmisible\n"
Interact.do_loop(
"Hallar el k-esimo primo (l=lista s=salir) k? ",
Primosa.get_context,
Hallar el k-esimo primo (l=lista s=salir) k?  5
Hallar el k-esimo primo (l=lista s=salir) k?  10
Hallar el k-esimo primo (l=lista s=salir) k?  3
Hallar el k-esimo primo (l=lista s=salir) k?  l
Hallar el k-esimo primo (l=lista s=salir) k?  s
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 *)
structure PrimosSQ :> Primos =
exception EndOfList;
fun find_pred (n,sq) x =
if x > sq then
raise EndOfList
(n mod x = 0);
val sq = Real.ceil( Math.sqrt(Real.fromInt n))
(case (List.find (find_pred (n,sq)) primos) of
| NONE => n) handle EndOfList => n
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().
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 "sprimos-sqrt.sml";
functor TestPrimos (P : Primos) =
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)
print ("tiempo ms = " ^ dif ^ " - primo = " ^ (Int.toString calculate)  ^ "\n")
(* 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
structure SQTest : sig val run : unit -> unit end
tiempo ms = 259 - primo = 81817
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)
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.
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)
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 =
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
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 =
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 =
val line_nonl = if String.isSuffix "\n" line then
String.substring (line,0,size line - 1)
val [tok1,tok2,tok3,tok4] = String.fields
(fn ch => ch = #",") line_nonl
cod=valOf(Int.fromString tok1),
descripcion=tok2,
precio=valOf(Real.fromString tok3),
stock=valOf(Real.fromString tok4)
fun toString (prod:producto) =
(Int.toString (#cod prod)) ^ "," ^
(#descripcion prod) ^ "," ^
(Real.toString (#precio prod)) ^ "," ^
(Real.toString (#stock prod));
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 =
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
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 =
type database = Producto.producto list ref;
exception NotFound;
fun load_database filename =
val io = TextIO.openIn filename
val db = ref nil: database
val do_read = ref true
while !do_read
case (TextIO.inputLine io) of
SOME line => db := (!db) @ [Producto.parse_prod line]
| NONE => do_read := false
) ; TextIO.closeIn io ; db
fun save_database (filename,db:database) =
val io = TextIO.openOut filename
val plist = !db
fun save_product (prod:Producto.producto) =
val pline = (Producto.toString prod) ^ "\n"
TextIO.output (io,pline)
fun xsave_database(p::xs) =
(save_product p ; xsave_database xs)
| xsave_database(nil) = ()
xsave_database(plist); TextIO.closeOut io; db
fun add_product (db:database, p:(Producto.producto)) =
(db := (!db) @ [p] ; db);
fun strstr (haystack:string,needle:string) =
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)
strstr_st(haystack, needle, 0)
fun search_by_description (db:database, desc:string) =
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
xsearch_by_desc(!db, desc)
fun show_all(pref : database) =
fun xshow_all(p::xs : Producto.producto list) =
let val s = (Producto.toString p) ^ "\n"
in ( print s ; xshow_all(xs) )
| xshow_all(_) = ()
xshow_all(!pref)
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";
fun main((db,filename), line) =
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
"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" => (
val what = ask_string "Que desea buscar?"
val text = Producto.toString
(ProdDb.search_by_description (
db,what))
handle ProdDb.NotFound =>
print "No se encontro producto"
| _ => print "Error en opcion solicitada\n"
val dbfile = "db.txt";
val db = ProdDb.load_database dbfile;
"l=lista b=buscar a=agregar g=guardar s=salir >",
(db,dbfile),
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.
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".
--- FIDEOS
--- cabello de angel
--- fetuccini
--- CONSERVAS
--- filete de atun
--- duraznos en almibar
--- GASEOSAS
--- inka coca
--- 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 *)
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",
val duraznos = PRODUCTO({cod=315,
descripcion="duraznos en almibar",
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) =
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) = ()
xcatprint(cat,level) =
case cat of
CATEGORIA(name,lref) =>
xcatprintlevel("[" ^ name ^ "]", level);
xcatprintlist(!lref, level + 1)
| PRODUCTO(p) =>
xcatprintlevel(#descripcion p, level)
xcatprint(cat,0)
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.
Recalcamos, en SML el conector andalso equivale a lo que en C y Java se denota por &&.
La invocación catprint(almacen) genera esto:
[CONSERVAS]
[ABARROTES]
[FIDEOS]
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) =
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);
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:
[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 *)
PRODUCTOS of string * (producto list ref);
( spaces(level); print (s ^ "\n"))
fun printprodlist(p::xs : producto list, level) =
( xcatprintlevel(#descripcion p, level);
printprodlist(xs, level) )
| printprodlist(_, level) = ()
| PRODUCTOS(name,lref) =>
printprodlist(!lref, level + 1)
fun add_prod(element, destination) =
PRODUCTOS(_,lr) => lr := !lr @ [element];
val cabello = {cod=312,
precio=4.30, stock=12.0};
val fetuccini = {cod=313,
precio=5.30, stock=10.0};
val filete = {cod=314,
val duraznos = {cod=315,
val fideos = PRODUCTOS("FIDEOS", ref [cabello, fetuccini]);
val conservas = PRODUCTOS("CONSERVAS", ref [filete, duraznos]);
val gaseosas = PRODUCTOS("GASEOSAS", ref nil);
val bebidas = CATEGORIA("BEBIDAS", ref [gaseosas]);
val iq = {cod=312,
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";
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".
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":
O de forma más abreviada: p->q, !q |- !p.
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:
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
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
String.implode(rev(ltrim(rev (ltrim l))))
SOME k => trim(k)
| NONE => raise UserAbort
fun drop_last (x) = rev (List.drop(rev(x),1))
fun drop_rep (lst:string list) =
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 =
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
maux(ath,[])
fun get_variables_formula ath =
val tmap = extract_vars ath
drop_rep tmap
(* 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) =
fun eval g =
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))
fun xevaluar (f, vmap) =
val r = evaluar (f,vmap)
print "Se encontro contraejemplo con valuacion:\n";
app (fn (n,v) =>
if v then print (n ^ "=T ") else print (n ^ "=F "))
vmap;
raise Contraejemplo
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 =
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
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"
validacion2 premisas
fun get_argumento () =
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]
validacion (map (fn t => Parser.parse (LogLexer.scan t)) argtxt) ;
OS.Process.exit(0)
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".
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 =
datatype token = Id of string | Key of string
val scan : string -> token list
signature KEYWORD =
val alphas : string list
and symbols : string list
structure LogKeyword : KEYWORD =
val alphas = nil
val symbols = [ "(", ")", "|", "!", "&", "<->", "->", "#" ]
functor Lexical (Keyword: KEYWORD) : LEXICAL =
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) =
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) =
NONE => rev toks
if Char.isAlphaNum c
val (id,ss2) = Substring.splitl Char.isAlphaNum ss
val tok = alphaTok (Substring.string id)
in scanning (tok::toks, ss2)
else if Char.isPunct c
let val (tok,ss2) = symbolic (String.str c, ss1)
scanning(toks, Substring.dropl(not o Char.isGraph) ss);
fun scan a = scanning([], Substring.full a)
structure LogLexer = Lexical(LogKeyword);
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):
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.
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  *)
structure Parser =
datatype ctoken = TokenSimple of LogLexer.token
| TokenCompuesto of (LogLexer.token list)
datatype orient = LEFT | RIGHT
fun get_tokens_inpar (x::xs) =
fun get_aux (s::sr, inpar, level) =
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 ()"
get_aux(xs, nil, 1)
| get_tokens_inpar [] = raise ParseError "Expresion vacia para analisis ()"
fun get_ctokens_aux (x::xs : LogLexer.token list, ctokens : ctoken list) =
LogLexer.Key "(" =>
val (v1,v2) = get_tokens_inpar(x::xs)
get_ctokens_aux (v2, ctokens @ [TokenCompuesto v1])
| 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) =
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
fs (ctokens,0)
fun xpair_by_symbols (ctokens, s::xs) =
let val pos = find_symbol (ctokens,s) in
NONE => xpair_by_symbols (ctokens, xs)
SOME (List.take (ctokens, n), s,
List.drop (ctokens,1 + n))
| 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
| SOME (c1,s,c2) => if dir = LEFT
then SOME(rev c2,s,rev c1)
else pbs
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 ^ "'")
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))
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))
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 =>
LogLexer.Id i => L_ATOM i
| LogLexer.Key "#" => BOTTOM
| LogLexer.Key k => raise ParseError
("Token simple invalido '" ^ k ^ "'")
| TokenCompuesto tlst => parse tlst
En esta sección implementaremos una librería con funciones para realizar cálculos con matrices.
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 (
(fn x => print ((Real.toString x) ^ " "))
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;
[ 0.0 17.0 512.1024 0.0 ]
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.
Una firma para matrices
La siguiente firma muestra un conjunto de operaciones que son útiles para operar con matrices.
(* matrix2_sig.sml *)
signature Matrix =
(* 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
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
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
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
* un conjunto de columnas especificadas en una
val dropCols: t*int list -> t
(* obtener la matriz que resulta de eliminar
* una fila *)
val dropRow : t*int -> t
* 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
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 =
infix 1 >>
type t = real array * int * int
val format_width = 6
fun rows (_,m,_) = m
fun columns (_,_,n) = n
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) =
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
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) =
fun app_col (row,col) =
val v = Array.sub(arr, row * n + col)
f (row,col,v) ;
if col = n - 1 then ()
else app_col (row, col + 1)
fun app_row r = (
app_col (r, 0);
if r = m - 1 then () else app_row(r + 1)
app_row 0
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)
fun update(f, row, col, v) =
let val (arr, m, n) = check (f, row, col)
Array.update(arr, row * n + col, v)
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) =
val ans = zeros(1, elements)
val inter = (destination - start) / (Real.fromInt (elements - 1))
fupdate (
fn (_,c) => SOME(start + (Real.fromInt c) * inter)
) ans ; ans
fun fromList (x::xs) =
val m = 1 + length xs
val ans = zeros(m,n)
if n = 0 then raise Subscript
fn (r,c) => SOME(
List.nth(List.nth(x::xs, r),c))
fun eye n =
let val ans = zeros (n, n) in
(fn (x,y) => if x = y then SOME 1.0 else NONE) ans ;
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) =
fun pad(s,n) =
fun xpad(ls,n) = if length ls >= n
else xpad(#" " :: ls, n)
String.implode(xpad(String.explode(s), n))
fun real_pad(r,n) =
if r >= 0.0 then (pad (Real.toString r, n)) ^ " "
else (pad ("-" ^ Real.toString (~r), n)) ^ " "
app (fn (r,c,v) =>
val prn = real_pad (v, format_width)
if c = n - 1 then print (prn ^ "\n")
else print (prn ^ " ")
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.
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
fn (r,c) => SOME (q >> (c,r))
fun smul(f, v) =
let val ans = clone f in
fn (r,c) => SOME (v * (ans >> (r, c)))
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
fn (r,c) => SOME ((mat1 >> (r,c)) + (mat2 >> (r,c)))
fun prod (mat1 as (arr1, m1, n1), mat2 as (arr2, m2, n2)) =
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))
xpint 0
if n1 <> m2 then raise Subscript
let val ans = zeros(m1,n2) in
fn (r,c) => SOME (pint(mat1, mat2, r, c))
fun max f =
val maxpos = ref (0,0)
val maxval = ref (first f)
app ( fn (r,c,v:real) =>
if v > !maxval then (maxval := v ; maxpos := (r,c) )
else () ) f ;
(!maxval, #1 (!maxpos), #2 (!maxpos))
fun min f =
val minpos = ref (0,0)
val minval = ref (first f)
if v < !minval then (minval := v ; minpos := (r,c) )
(!minval, #1 (!minpos), #2 (!minpos))
fun abs f = let val ans = clone(f) in
fn (r,c) => SOME (Real.abs(f >> (r,c)))
) f ; ans
fun op==(mat1 as (_,m1,n1),mat2 as (_,m2,n2)) = let
val allequal = ref true
fun testelem () = (
fn (r,c,v) => if Real.==(v, mat2 >> (r,c))
else allequal := false
mat1 ; !allequal
m1 = m2 andalso n1 = n2 andalso testelem ()
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) =
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
fn (r,c) => SOME (f >> (rs + r, cs + c))
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
let val ans = zeros(m1, n1 + n2) in
fn (r,c) => SOME(if c < n1
then (mat1 >> (r,c))
else (mat2 >> (r,c - n1)))
fun vjoin (mat1 as (_,m1,n1), mat2 as (_,m2,n2)) =
if n1 <> n2 then raise Subscript
let val ans = zeros(m1 + m2, n1) in
fn (r,c) => SOME(if r < m1
else (mat2 >> (r - m1,c)))
fun fromRows (f as (_, m, n), lst) =
let val ans = zeros(length lst, n) in
fn (r,c) => SOME (get(f,List.nth (lst,r),c))
fun fromCols (f as (_, m, n), lst) =
let val ans = zeros(m,length lst) in
fn (r,c) => SOME (get(f,r,List.nth (lst,c)))
fun subtract(rangeExtreme, lst) =
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)
xsubtract(nil, rangeExtreme - 1)
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)
app (fn (r,c,newval) => update(ans, pos, c, newval))
newrow ; ans
fun repCol(f, pos, newcol) = let
app (fn (r,c,newval) => update(ans, r, pos, newval))
newcol ; ans
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
fun getpivotrow f =
val (v,pivotpos,_) = max(abs(getCol(f, 0)))
if Real.==(v, 0.0) then raise Div
else (pivotpos, getRow(f, pivotpos))
fun elimrow (f, pivotrow, toElim) =
if toElim = rows f then f
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)
elimrow (added, pivotrow, toElim + 1)
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
(newsgn,pivot_row::nextrows)
fun solve_gauss nil = single ~1.0
| solve_gauss (p::rest) =
val sols = solve_gauss rest
val prest = dropCol (p, 0)
val pesc = prod (sols, transp prest)
val newsol = ~(first pesc / first p)
hjoin (single newsol, sols)
fun solve (A,B) =
val both = hjoin (A,B)
val (_,ge) = gaussianelim both
val solutions = solve_gauss ge
val last_col = columns solutions - 2
transp(extract
(solutions,
NONE, NONE, NONE, SOME last_col))
fun det f =
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
sgn * prod1st ge
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
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]
6.0    19.0
IMATRIX> b=[5,3]
5.0     3.0
IMATRIX> bt=b'
IMATRIX> x=a\bt
12.7142857143
-3.85714285714
IMATRIX> det(a)
IMATRIX> a*x-bt
IMATRIX> (a*x-bt)'
IMATRIX> eye(4)
0.0     0.0     0.0     1.0
Comparemos con lo que se obtiene en Octave:
octave:1> a=[1,2;6,19]
octave:2> b=[5,3]
octave:3> bt=b'
octave:4> x=a\bt
octave:5> det(a)
ans =  7.0000
octave:6> a*x-bt
octave:7> (a*x-bt)'
octave:8> eye(4)
Utilizando las ideas de análisis léxico y parsing del programa de validador lógico procedemos a implementar esta aplicación.
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.
val symbols = [ "(", ")", "+", "-", "*", ",", ";", "[", "]", "=", "\\" ]
if Char.isAlphaNum c orelse c = #"."
val (id,ss2) = Substring.splitl
(fn x => Char.isAlphaNum x orelse x = #".")
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 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 *)
print (prompt ^ " ");
| 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)
NONE => raise Syntax ("Bad identifier '" ^ atom ^ "'")
| SOME n => #2 n
(* obtener tokens entre parentesis o entre corchetes *)
| LogLexer.Key "[" => get_aux (sr, inpar@[s], level + 1)
| LogLexer.Key "]" =>
| get_aux (nil, inpar, level) = raise Syntax "Error de matching () o []"
| get_tokens_inpar [] = raise Syntax "Expresion vacia para analisis ()"
(* obtener ctokens a partir de tokens *)
get_ctokens_aux (v2, ctokens @ [TParentesis v1])
| LogLexer.Key "[" =>
get_ctokens_aux (v2, ctokens @ [TCorchetes v1])
| LogLexer.Key ")" => raise Syntax "Exceso de r-parentesis"
| LogLexer.Key "]" => raise Syntax "Exceso de r-corchetes"
| _ => get_ctokens_aux (xs, ctokens @ [TSimple x])
(* 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 => (
LogLexer.Key k => k = sym
(* obtener identificador de un ctoken *)
fun getId ctoken =
case ctoken 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 *)
TSimple (LogLexer.Key sym) =>
(* desde [a,b,%,c,d,...] genera[[a,b],[c,d]...]]
* si % es el delimitador *)
fun sublist (src,fdelim) =
fun sublistaux (result,src::xs,fdelim) =
if fdelim src then
sublistaux(nil::result,xs,fdelim)
if null result then
sublistaux ([[src]],xs,fdelim)
val r1::rest = result
sublistaux((r1@[src])::rest,xs,fdelim)
| sublistaux (result,[],_) = result
rev(sublistaux([],src,fdelim))
(* dividir una lista en sublistas de hasta n elementos *)
fun divide (src,n) =
fun daux (result,src::xs) =
daux ([[src]],xs)
if length r1 = n then
daux([src]::r1::rest,xs)
daux((r1@[src])::rest,xs)
| daux (result,[]) = result
rev(daux([],src))
(* 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)
fun rarg (argvals, pos):real =
Matrix.first v
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) =
val ctokens = get_ctokens tokens
eval_clist (ctokens,am)
and eval_clist (ctokens: ctoken list,am:assignments): (mt list * int) =
val faux = fn (ct,sym:string list) => case ct of
LogLexer.Key k =>
List.exists (fn x => x = k) sym
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)
(map (fn x=>eval_c(x,am)) subs, row_w)
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
TSimple ts =>
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)
if length lres = 0 then
raise Syntax "Se requiere valores entre [...]"
else Matrix.fromList(divide(map (Matrix.first)
lres,row_w)) end
and string2real s =
if String.sub(s,0) = #"-" then
Real.fromString (String.substring(s, 1, size s - 1))
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
case rval of
NONE => raise Syntax "Expresion numerica invalida"
| SOME rval' => Matrix.fromList [[rval']]
and eval_assign (ctokens,am) =
if length ctokens >= 3 andalso isSymbol(ctokens,"=",1) then
val as_val = eval_c(List.drop(ctokens,2),am)
val apair = (getId(List.nth(ctokens,0)),as_val)
am := (apair :: (!am)) ; as_val
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))
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)
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)
and eval_transp(ctokens,am) =
if isSymbol (ctokens,"'",length ctokens - 1) then
val rest = rev(List.drop(rev ctokens,1))
val tran = eval_c(rest,am)
Matrix.transp tran
else eval_neg (ctokens,am)
and eval_neg(ctokens,am) =
if isSymbol (ctokens,"-",0) then
val rest = List.drop(ctokens,1)
Matrix.smul(tran,~1.0)
else eval_fun (ctokens,am)
and eval_fun (ctokens,am) =
if length ctokens <> 2 then
raise Syntax "Error de Sintaxis"
val [idfun,TParentesis tlst] = ctokens
val fname = getId idfun
val argvals = #1 (eval(tlst,am))
(* FIXME crear funcion check_fun_nparams(fname,nparams) *)
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)
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)
| 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))
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) =
val line = trim(getline "IMATRIX>")
if line = "quit" then ()
if line = "" then main(am)
val tokens = LogLexer.scan line
val exps = #1(eval (tokens,am))
app (fn e=> Matrix.show e) exps
end handle Syntax msg => print (msg ^ "\n")
| _ => print "Excepcion desconocida\n" ;
main(am)
main(ref []);
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
# 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
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.
structure MatrixOctave =
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 =
val ans = ref nil
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) =
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
cur_mat := Matrix.repRow (!cur_mat, rowpos, rmat)
fun extrim(s:string, start:int) =
val rlst = rev (String.explode (String.extract (s, start, NONE)))
fun cutter nil = nil
| cutter (ch::xs) =
if Char.isSpace ch then cutter xs
String.implode (rev (cutter rlst))
fun process line =
case !state of
WAIT_NAME =>
if String.isPrefix "# name: " line
then (cur_name := extrim (line, 8) ;
state := WAIT_MATRIX)
| WAIT_MATRIX =>
if String.isPrefix "# type: matrix" line
then state := WAIT_ROWS
| WAIT_ROWS =>
if String.isPrefix "# rows: " line
then (cur_rows := valOf (Int.fromString (extrim (line, 8))) ;
state := WAIT_COLS)
| WAIT_COLS =>
if String.isPrefix "# columns: " line
val ncols = valOf(Int.fromString (extrim (line, 11)))
cur_mat := Matrix.zeros(!cur_rows, ncols) ;
state := WAIT_DATA(ncols)
| WAIT_DATA n =>
update_row (n, !cur_mat, line) ;
if n > 1 then state := WAIT_DATA (n - 1)
ans := (!ans) @ [(!cur_name, !cur_mat)] ;
state := WAIT_NAME
SOME line => process line
) ; TextIO.closeIn io ; !ans
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) =
fun save_header(name,mat) =
val prows = Int.toString (Matrix.rows mat)
val pcols = Int.toString (Matrix.columns mat)
TextIO.output (io,"# name: " ^ name ^ "\n");
TextIO.output (io,"# type: matrix\n");
TextIO.output (io,"# rows: " ^ prows ^ "\n");
TextIO.output (io,"# columns: " ^ pcols ^ "\n")
fun save_rows mat = Matrix.fupdate (
fn (r,c) => let
val vs = transt(Real.toString(
Matrix.get(mat,r,c)))
val toPrint = " " ^ vs;
if c = Matrix.columns mat - 1
then TextIO.output (io, toPrint ^ "\n")
else TextIO.output (io, toPrint)
fun xsave((name,mat)::xs) = (
save_header (name,mat);
save_rows mat;
xsave xs
| xsave(nil) = ()
TextIO.output (io, "# Created by MatrixOctave\n");
xsave(matlist);
TextIO.closeOut io
A continuación un ejemplo de operación:
octave:1> m1 = (rand(6) - 0.5) * 50
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
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
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);
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: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.
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.
[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/
Last updated 2019-12-24 12:35:40 -0500

References: resolución 
 resolución 
 resolución 
 resolución 
 resolución 

Resolución