Aprendiendo Standard ML

(* 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);

(* 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);

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

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

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

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

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

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

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

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

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

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

total plist;

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

(* prod_db_sig.sml *)

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

(* prod_db.sml *)

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

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

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

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

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

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

(* catbebidas.sml *)

use "catprint.sml";

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

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

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

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

(* cat2.sml *)

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

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

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

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

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

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

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

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

catprint(almacen);

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

           |      |      |       |         |
           v      v      v       v         v

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

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

           |      |      |       |         |
           v      v      v       v         v

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

           |      |      |       |         |
           v      v      v       v         v

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

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

           |      |      |       |         |
           v      v      v       v         v

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

           |      |      |       |         |
           v      v      v       v         v

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

                 |                         |
                 v                         v

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

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

(* nparser.sml  *)

exception ParseError of string

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

datatype orient = LEFT | RIGHT

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

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

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

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

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

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

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

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

use "matrix2_sig.sml";

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

  val format_width = 6
  
  fun rows (_,m,_) = m
  fun columns (_,_,n) = n

(* matrix2.sml: crear nuevas matrices *)

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

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

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

(* matrix2.sml: creacion mediante fupdate *)

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

(* matrix2.sml: mostrar elementos *)

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

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

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

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

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

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

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

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

Char.isAlphaNum x orelse x = #"."

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

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

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


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

structure LogLexer = Lexical(LogKeyword);

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

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

exception UserAbort
exception Syntax of string

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

type mt = Matrix.t

type assignment = string*mt

type assignments = assignment list ref

(* imatrix.sml: funciones utilitarias *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(* imatrix.sml: parsing y evaluacion *)

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

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

main(ref []);

use "matrix2.sml";

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

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

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

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

end

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

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

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

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

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

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

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