src/HOL/Matrix/cplex/Cplex_tools.ML

Symtab.foldl replaced by Symtab.fold

(*  Title:      HOL/Matrix/cplex/Cplex_tools.ML
    ID:         $Id$
    Author:     Steven Obua
*)

signature CPLEX =
sig
    
    datatype cplexTerm = cplexVar of string | cplexNum of string | cplexInf 
                       | cplexNeg of cplexTerm 
                       | cplexProd of cplexTerm * cplexTerm 
                       | cplexSum of (cplexTerm list) 
    
    datatype cplexComp = cplexLe | cplexLeq | cplexEq | cplexGe | cplexGeq 
								  
    datatype cplexGoal = cplexMinimize of cplexTerm 
		       | cplexMaximize of cplexTerm
					  
    datatype cplexConstr = cplexConstr of cplexComp * 
					  (cplexTerm * cplexTerm)
					  
    datatype cplexBounds = cplexBounds of cplexTerm * cplexComp * cplexTerm 
					  * cplexComp * cplexTerm
			 | cplexBound of cplexTerm * cplexComp * cplexTerm
					 
    datatype cplexProg = cplexProg of string 
				      * cplexGoal 
				      * ((string option * cplexConstr) 
					     list) 
				      * cplexBounds list
				      
    datatype cplexResult = Unbounded 
			 | Infeasible 
			 | Undefined
			 | Optimal of string * 
				      (((* name *) string * 
					(* value *) string) list)

    datatype cplexSolver = SOLVER_DEFAULT | SOLVER_CPLEX | SOLVER_GLPK
						     
    exception Load_cplexFile of string
    exception Load_cplexResult of string
    exception Save_cplexFile of string
    exception Execute of string

    val load_cplexFile : string -> cplexProg

    val save_cplexFile : string -> cplexProg -> unit 

    val elim_nonfree_bounds : cplexProg -> cplexProg

    val relax_strict_ineqs : cplexProg -> cplexProg

    val is_normed_cplexProg : cplexProg -> bool

    val get_solver : unit -> cplexSolver
    val set_solver : cplexSolver -> unit
    val solve : cplexProg -> cplexResult
end;

structure Cplex  : CPLEX =
struct

datatype cplexSolver = SOLVER_DEFAULT | SOLVER_CPLEX | SOLVER_GLPK

val cplexsolver = ref SOLVER_DEFAULT;
fun get_solver () = !cplexsolver;
fun set_solver s = (cplexsolver := s);

exception Load_cplexFile of string;
exception Load_cplexResult of string;
exception Save_cplexFile of string;
	  
datatype cplexTerm = cplexVar of string 
		   | cplexNum of string 
		   | cplexInf 
                   | cplexNeg of cplexTerm 
                   | cplexProd of cplexTerm * cplexTerm 
                   | cplexSum of (cplexTerm list) 
datatype cplexComp = cplexLe | cplexLeq | cplexEq | cplexGe | cplexGeq 
datatype cplexGoal = cplexMinimize of cplexTerm | cplexMaximize of cplexTerm
datatype cplexConstr = cplexConstr of cplexComp * (cplexTerm * cplexTerm)
datatype cplexBounds = cplexBounds of cplexTerm * cplexComp * cplexTerm 
				      * cplexComp * cplexTerm
                     | cplexBound of cplexTerm * cplexComp * cplexTerm 
datatype cplexProg = cplexProg of string 
				  * cplexGoal 
				  * ((string option * cplexConstr) list) 
				  * cplexBounds list
				  
fun rev_cmp cplexLe = cplexGe
  | rev_cmp cplexLeq = cplexGeq
  | rev_cmp cplexGe = cplexLe
  | rev_cmp cplexGeq = cplexLeq
  | rev_cmp cplexEq = cplexEq

fun the NONE = raise (Load_cplexFile "SOME expected")
  | the (SOME x) = x; 
    
fun modulo_signed is_something (cplexNeg u) = is_something u
  | modulo_signed is_something u = is_something u

fun is_Num (cplexNum _) = true
  | is_Num _ = false

fun is_Inf cplexInf = true
  | is_Inf _ = false

fun is_Var (cplexVar _) = true
  | is_Var _ = false

fun is_Neg (cplexNeg x ) = true
  | is_Neg _ = false

fun is_normed_Prod (cplexProd (t1, t2)) = 
    (is_Num t1) andalso (is_Var t2)
  | is_normed_Prod x = is_Var x

fun is_normed_Sum (cplexSum ts) = 
    (ts <> []) andalso forall (modulo_signed is_normed_Prod) ts
  | is_normed_Sum x = modulo_signed is_normed_Prod x

fun is_normed_Constr (cplexConstr (c, (t1, t2))) = 
    (is_normed_Sum t1) andalso (modulo_signed is_Num t2)

fun is_Num_or_Inf x = is_Inf x orelse is_Num x

fun is_normed_Bounds (cplexBounds (t1, c1, t2, c2, t3)) =
    (c1 = cplexLe orelse c1 = cplexLeq) andalso 
    (c2 = cplexLe orelse c2 = cplexLeq) andalso
    is_Var t2 andalso
    modulo_signed is_Num_or_Inf t1 andalso
    modulo_signed is_Num_or_Inf t3
  | is_normed_Bounds (cplexBound (t1, c, t2)) =
    (is_Var t1 andalso (modulo_signed is_Num_or_Inf t2)) 
    orelse
    (c <> cplexEq andalso 
     is_Var t2 andalso (modulo_signed is_Num_or_Inf t1))
	             		
fun term_of_goal (cplexMinimize x) = x
  | term_of_goal (cplexMaximize x) = x

fun is_normed_cplexProg (cplexProg (name, goal, constraints, bounds)) = 
    is_normed_Sum (term_of_goal goal) andalso
    forall (fn (_,x) => is_normed_Constr x) constraints andalso
    forall is_normed_Bounds bounds

fun is_NL s = s = "\n"

fun is_blank s = forall (fn c => c <> #"\n" andalso Char.isSpace c) (String.explode s)
		 
fun is_num a = 
    let 
	val b = String.explode a 
	fun num4 cs = forall Char.isDigit cs		      
	fun num3 [] = true
	  | num3 (ds as (c::cs)) = 
	    if c = #"+" orelse c = #"-" then
		num4 cs
	    else 
		num4 ds		    
	fun num2 [] = true
	  | num2 (c::cs) =
	    if c = #"e" orelse c = #"E" then num3 cs
	    else (Char.isDigit c) andalso num2 cs			 
	fun num1 [] = true
	  | num1 (c::cs) = 
	    if c = #"." then num2 cs 
	    else if c = #"e" orelse c = #"E" then num3 cs 
	    else (Char.isDigit c) andalso num1 cs
	fun num [] = true
	  | num (c::cs) = 
	    if c = #"." then num2 cs 
	    else (Char.isDigit c) andalso num1 cs
    in
	num b
    end  

fun is_delimiter s = s = "+" orelse s = "-" orelse s = ":"
		    
fun is_cmp s = s = "<" orelse s = ">" orelse s = "<=" 
		     orelse s = ">=" orelse s = "="

fun is_symbol a = 
    let
	val symbol_char = String.explode "!\"#$%&()/,.;?@_`'{}|~"
	fun is_symbol_char c = Char.isAlphaNum c orelse 
			       exists (fn d => d=c) symbol_char
	fun is_symbol_start c = is_symbol_char c andalso 
				not (Char.isDigit c) andalso 
				not (c= #".")
	val b = String.explode a
    in
	b <> [] andalso is_symbol_start (hd b) andalso 
	forall is_symbol_char b
    end

fun to_upper s = String.implode (map Char.toUpper (String.explode s))

fun keyword x = 
    let 	
	val a = to_upper x 
    in
	if a = "BOUNDS" orelse a = "BOUND" then
	    SOME "BOUNDS"
	else if a = "MINIMIZE" orelse a = "MINIMUM" orelse a = "MIN" then
	    SOME "MINIMIZE"
	else if a = "MAXIMIZE" orelse a = "MAXIMUM" orelse a = "MAX" then
	    SOME "MAXIMIZE"
	else if a = "ST" orelse a = "S.T." orelse a = "ST." then
	    SOME "ST"
	else if a = "FREE" orelse a = "END" then
	    SOME a
	else if a = "GENERAL" orelse a = "GENERALS" orelse a = "GEN" then
	    SOME "GENERAL"
	else if a = "INTEGER" orelse a = "INTEGERS" orelse a = "INT" then
	    SOME "INTEGER"
	else if a = "BINARY" orelse a = "BINARIES" orelse a = "BIN" then
	    SOME "BINARY"
	else if a = "INF" orelse a = "INFINITY" then
	    SOME "INF"
	else								   
	    NONE
    end
	        
val TOKEN_ERROR = ~1
val TOKEN_BLANK = 0
val TOKEN_NUM = 1
val TOKEN_DELIMITER = 2
val TOKEN_SYMBOL = 3
val TOKEN_LABEL = 4
val TOKEN_CMP = 5
val TOKEN_KEYWORD = 6
val TOKEN_NL = 7
		      
(* tokenize takes a list of chars as argument and returns a list of
   int * string pairs, each string representing a "cplex token", 
   and each int being one of TOKEN_NUM, TOKEN_DELIMITER, TOKEN_CMP
   or TOKEN_SYMBOL *)
fun tokenize s = 
    let
	val flist = [(is_NL, TOKEN_NL), 
		     (is_blank, TOKEN_BLANK), 
		     (is_num, TOKEN_NUM),  
                     (is_delimiter, TOKEN_DELIMITER), 
		     (is_cmp, TOKEN_CMP), 
		     (is_symbol, TOKEN_SYMBOL)]  
	fun match_helper [] s = (fn x => false, TOKEN_ERROR)
	  | match_helper (f::fs) s = 
	    if ((fst f) s) then f else match_helper fs s   
	fun match s = match_helper flist s
	fun tok s = 
	    if s = "" then [] else       
	    let 
		val h = String.substring (s,0,1) 
		val (f, j) = match h
		fun len i = 
		    if size s = i then i 
		    else if f (String.substring (s,0,i+1)) then 
			len (i+1) 
		    else i 
	    in
		if j < 0 then 
		    (if h = "\\" then [] 
		     else raise (Load_cplexFile ("token expected, found: "
						 ^s)))
		else 
		    let 
			val l = len 1 
			val u = String.substring (s,0,l)
			val v = String.extract (s,l,NONE)
		    in
			if j = 0 then tok v else (j, u) :: tok v
		    end
	    end                
    in
	tok s     
    end

exception Tokenize of string;

fun tokenize_general flist s = 
    let
	fun match_helper [] s = raise (Tokenize s)
	  | match_helper (f::fs) s = 
	    if ((fst f) s) then f else match_helper fs s   
	fun match s = match_helper flist s
	fun tok s = 
	    if s = "" then [] else       
	    let 
		val h = String.substring (s,0,1) 
		val (f, j) = match h
		fun len i = 
		    if size s = i then i 
		    else if f (String.substring (s,0,i+1)) then 
			len (i+1) 
		    else i 
		val l = len 1
	    in
		(j, String.substring (s,0,l)) :: tok (String.extract (s,l,NONE))
	    end
    in
	tok s     
    end

fun load_cplexFile name = 
    let 
	val f = TextIO.openIn name  
        val ignore_NL = ref true  
	val rest = ref []

	fun is_symbol s c = (fst c) = TOKEN_SYMBOL andalso (to_upper (snd c)) = s 
		   
	fun readToken_helper () =
	    if length (!rest) > 0 then  
		let val u = hd (!rest) in 
		    (
		     rest := tl (!rest); 
		     SOME u
		    ) 
		end
	    else 
		let val s = TextIO.inputLine f in
		    if s = "" then NONE else
		    let val t = tokenize s in
			if (length t >= 2 andalso 
			    snd(hd (tl t)) = ":") 
			then 
			    rest := (TOKEN_LABEL, snd (hd t)) :: (tl (tl t))
			else if (length t >= 2) andalso is_symbol "SUBJECT" (hd (t)) 
				andalso is_symbol "TO" (hd (tl t)) 
			then
			    rest := (TOKEN_SYMBOL, "ST") :: (tl (tl t))
			else
			    rest := t;
			readToken_helper ()  
		    end
		end           
	
	fun readToken_helper2 () = 
		let val c = readToken_helper () in
		    if c = NONE then NONE
                    else if !ignore_NL andalso fst (the c) = TOKEN_NL then
			readToken_helper2 ()
		    else if fst (the c) = TOKEN_SYMBOL 
			    andalso keyword (snd (the c)) <> NONE
		    then SOME (TOKEN_KEYWORD, the (keyword (snd (the c))))
		    else c
		end
		
	fun readToken () = readToken_helper2 ()
	    			   
	fun pushToken a = rest := (a::(!rest))
	    
	fun is_value token = 
	    fst token = TOKEN_NUM orelse (fst token = TOKEN_KEYWORD 
					  andalso snd token = "INF")	

        fun get_value token = 
	    if fst token = TOKEN_NUM then
		cplexNum (snd token)
	    else if fst token = TOKEN_KEYWORD andalso snd token = "INF" 
	    then
		cplexInf
	    else
		raise (Load_cplexFile "num expected")
					    
	fun readTerm_Product only_num = 
	    let val c = readToken () in
		if c = NONE then NONE
		else if fst (the c) = TOKEN_SYMBOL 
		then (
		    if only_num then (pushToken (the c); NONE) 
		    else SOME (cplexVar (snd (the c)))
		    ) 
		else if only_num andalso is_value (the c) then
		    SOME (get_value (the c))
		else if is_value (the c) then  
		    let val t1 = get_value (the c) 
			val d = readToken () 
		    in
			if d = NONE then SOME t1 
			else if fst (the d) = TOKEN_SYMBOL then 
			    SOME (cplexProd (t1, cplexVar (snd (the d))))
			else
			    (pushToken (the d); SOME t1)
		    end
		else (pushToken (the c); NONE)
	    end
	    
	fun readTerm_Signed only_signed only_num = 
	    let
		val c = readToken ()
	    in
		if c = NONE then NONE 
		else 
		    let val d = the c in 
			if d = (TOKEN_DELIMITER, "+") then 
			    readTerm_Product only_num
			 else if d = (TOKEN_DELIMITER, "-") then 
			     SOME (cplexNeg (the (readTerm_Product 
						      only_num)))
			 else (pushToken d; 
			       if only_signed then NONE 
			       else readTerm_Product only_num)
		    end
	    end
    
	fun readTerm_Sum first_signed = 
	    let val c = readTerm_Signed first_signed false in
		if c = NONE then [] else (the c)::(readTerm_Sum true)
	    end
	    
	fun readTerm () = 
	    let val c = readTerm_Sum false in
		if c = [] then NONE 
		else if tl c = [] then SOME (hd c)
		else SOME (cplexSum c) 
	    end
	    
	fun readLabeledTerm () = 
	    let val c = readToken () in
		if c = NONE then (NONE, NONE) 
		else if fst (the c) = TOKEN_LABEL then 
		    let val t = readTerm () in
			if t = NONE then 
			    raise (Load_cplexFile ("term after label "^
						   (snd (the c))^
						   " expected"))
			else (SOME (snd (the c)), t)
		    end
		else (pushToken (the c); (NONE, readTerm ()))
	    end
            
	fun readGoal () = 
	    let 
		val g = readToken ()
	    in
    		if g = SOME (TOKEN_KEYWORD, "MAXIMIZE") then 
		    cplexMaximize (the (snd (readLabeledTerm ()))) 
		else if g = SOME (TOKEN_KEYWORD, "MINIMIZE") then 
		    cplexMinimize (the (snd (readLabeledTerm ())))
		else raise (Load_cplexFile "MAXIMIZE or MINIMIZE expected")
	    end
	    
	fun str2cmp b = 
	    (case b of 
		 "<" => cplexLe 
	       | "<=" => cplexLeq 
	       | ">" => cplexGe 
	       | ">=" => cplexGeq 
               | "=" => cplexEq
	       | _ => raise (Load_cplexFile (b^" is no TOKEN_CMP")))
			    
	fun readConstraint () = 
            let 
		val t = readLabeledTerm () 
		fun make_constraint b t1 t2 =
                    cplexConstr 
			(str2cmp b,
			 (t1, t2))		
	    in
		if snd t = NONE then NONE
		else 
		    let val c = readToken () in
			if c = NONE orelse fst (the c) <> TOKEN_CMP 
			then raise (Load_cplexFile "TOKEN_CMP expected")
			else 
			    let val n = readTerm_Signed false true in
				if n = NONE then 
				    raise (Load_cplexFile "num expected")
				else
				    SOME (fst t,
					  make_constraint (snd (the c)) 
							  (the (snd t)) 
							  (the n))
			    end
		    end            
	    end
        
        fun readST () = 
	    let 
		fun readbody () = 
		    let val t = readConstraint () in
			if t = NONE then []
			else if (is_normed_Constr (snd (the t))) then
			    (the t)::(readbody ())
			else if (fst (the t) <> NONE) then 
			    raise (Load_cplexFile 
				       ("constraint '"^(the (fst (the t)))^ 
					"'is not normed"))
			else
			    raise (Load_cplexFile 
				       "constraint is not normed")
		    end
	    in    		
		if readToken () = SOME (TOKEN_KEYWORD, "ST") 
		then 
		    readbody ()
		else 
		    raise (Load_cplexFile "ST expected")
	    end
	    
	fun readCmp () = 
	    let val c = readToken () in
		if c = NONE then NONE
		else if fst (the c) = TOKEN_CMP then 
		    SOME (str2cmp (snd (the c)))
		else (pushToken (the c); NONE)
	    end
	    
	fun skip_NL () =
	    let val c = readToken () in
		if c <> NONE andalso fst (the c) = TOKEN_NL then
		    skip_NL ()
		else
		    (pushToken (the c); ())
	    end

	fun is_var (cplexVar _) = true
	  | is_var _ = false
	    
	fun make_bounds c t1 t2 = 
	    cplexBound (t1, c, t2)

	fun readBound () = 	    
	    let 		
		val _ = skip_NL ()
		val t1 = readTerm ()
	    in
		if t1 = NONE then NONE 
		else 
		    let 
			val c1 = readCmp () 
		    in
			if c1 = NONE then
			    let 
				val c = readToken () 
			    in
				if c = SOME (TOKEN_KEYWORD, "FREE") then
				    SOME (
				    cplexBounds (cplexNeg cplexInf,
						 cplexLeq,
						 the t1,
						 cplexLeq,
						 cplexInf))
				else
				    raise (Load_cplexFile "FREE expected")
			    end
			else
			    let 
				val t2 = readTerm () 
			    in
				if t2 = NONE then
				    raise (Load_cplexFile "term expected")
				else
				    let val c2 = readCmp () in
					if c2 = NONE then
					    SOME (make_bounds (the c1) 
							      (the t1)
							      (the t2))
					else
					    SOME (
					    cplexBounds (the t1,
							 the c1,
							 the t2,
							 the c2,
							 the (readTerm())))
				    end
			    end
		    end
	    end
	    
	fun readBounds () =
	    let 
		fun makestring b = "?"
		fun readbody () = 
		    let 
			val b = readBound ()
		    in
			if b = NONE then []
			else if (is_normed_Bounds (the b)) then
			    (the b)::(readbody())
			else (
			    raise (Load_cplexFile 
				       ("bounds are not normed in: "^
					(makestring (the b)))))
		    end
	    in
		if readToken () = SOME (TOKEN_KEYWORD, "BOUNDS") then 
		    readbody ()
		else raise (Load_cplexFile "BOUNDS expected")
	    end

        fun readEnd () = 
	    if readToken () = SOME (TOKEN_KEYWORD, "END") then ()
	    else raise (Load_cplexFile "END expected")
		    
	val result_Goal = readGoal ()  
	val result_ST = readST ()  
	val _ =	ignore_NL := false 
        val result_Bounds = readBounds ()
        val _ = ignore_NL := true
        val _ = readEnd ()
	val _ = TextIO.closeIn f
    in
	cplexProg (name, result_Goal, result_ST, result_Bounds)
    end

fun save_cplexFile filename (cplexProg (name, goal, constraints, bounds)) =
    let
	val f = TextIO.openOut filename
	
	fun basic_write s = TextIO.output(f, s)

	val linebuf = ref ""
	fun buf_flushline s = 
	    (basic_write (!linebuf); 
	     basic_write "\n";
	     linebuf := s)
	fun buf_add s = linebuf := (!linebuf) ^ s

	fun write s = 
	    if (String.size s) + (String.size (!linebuf)) >= 250 then 
		buf_flushline ("    "^s)
	    else 
		buf_add s

        fun writeln s = (buf_add s; buf_flushline "")
        
	fun write_term (cplexVar x) = write x
	  | write_term (cplexNum x) = write x
	  | write_term cplexInf = write "inf"
	  | write_term (cplexProd (cplexNum "1", b)) = write_term b
	  | write_term (cplexProd (a, b)) = 
	    (write_term a; write " "; write_term b)
          | write_term (cplexNeg x) = (write " - "; write_term x)
          | write_term (cplexSum ts) = write_terms ts
	and write_terms [] = ()
	  | write_terms (t::ts) = 
	    (if (not (is_Neg t)) then write " + " else (); 
	     write_term t; write_terms ts)

	fun write_goal (cplexMaximize term) = 
	    (writeln "MAXIMIZE"; write_term term; writeln "")
	  | write_goal (cplexMinimize term) = 
	    (writeln "MINIMIZE"; write_term term; writeln "")

	fun write_cmp cplexLe = write "<"
	  | write_cmp cplexLeq = write "<="
	  | write_cmp cplexEq = write "="
	  | write_cmp cplexGe = write ">"
	  | write_cmp cplexGeq = write ">="
        
	fun write_constr (cplexConstr (cmp, (a,b))) = 
	    (write_term a;
	     write " ";
	     write_cmp cmp;
	     write " ";
	     write_term b)
        
	fun write_constraints [] = ()
	  | write_constraints (c::cs) = 
	    (if (fst c <> NONE) 
	     then 
		 (write (the (fst c)); write ": ") 
	     else 
		 ();
	     write_constr (snd c);
	     writeln "";
	     write_constraints cs)

	fun write_bounds [] = ()
	  | write_bounds ((cplexBounds (t1,c1,t2,c2,t3))::bs) =
	    ((if t1 = cplexNeg cplexInf andalso t3 = cplexInf
		 andalso (c1 = cplexLeq orelse c1 = cplexLe) 
		 andalso (c2 = cplexLeq orelse c2 = cplexLe) 
	      then
		  (write_term t2; write " free")
	      else		 		 
		  (write_term t1; write " "; write_cmp c1; write " ";
		   write_term t2; write " "; write_cmp c2; write " ";
		   write_term t3)
	     ); writeln ""; write_bounds bs)
	  | write_bounds ((cplexBound (t1, c, t2)) :: bs) = 
	    (write_term t1; write " "; 
	     write_cmp c; write " ";
	     write_term t2; writeln ""; write_bounds bs)
	     
	val _ = write_goal goal
        val _ = (writeln ""; writeln "ST")
	val _ = write_constraints constraints
        val _ = (writeln ""; writeln "BOUNDS")
	val _ = write_bounds bounds
        val _ = (writeln ""; writeln "END") 
        val _ = TextIO.closeOut f
    in
	()
    end

fun norm_Constr (constr as cplexConstr (c, (t1, t2))) = 
    if not (modulo_signed is_Num t2) andalso  
       modulo_signed is_Num t1 
    then
	[cplexConstr (rev_cmp c, (t2, t1))]
    else if (c = cplexLe orelse c = cplexLeq) andalso
	    (t1 = (cplexNeg cplexInf) orelse t2 = cplexInf)	    
    then 
	[]
    else if (c = cplexGe orelse c = cplexGeq) andalso
	    (t1 = cplexInf orelse t2 = cplexNeg cplexInf)
    then
	[]
    else
	[constr]

fun bound2constr (cplexBounds (t1,c1,t2,c2,t3)) =
    (norm_Constr(cplexConstr (c1, (t1, t2))))
    @ (norm_Constr(cplexConstr (c2, (t2, t3))))
  | bound2constr (cplexBound (t1, cplexEq, t2)) =
    (norm_Constr(cplexConstr (cplexLeq, (t1, t2))))
    @ (norm_Constr(cplexConstr (cplexLeq, (t2, t1))))
  | bound2constr (cplexBound (t1, c1, t2)) = 
    norm_Constr(cplexConstr (c1, (t1,t2)))

val emptyset = Symtab.empty

fun singleton v = Symtab.update (v, ()) emptyset

fun merge a b = Symtab.merge (op =) (a, b)

fun mergemap f ts = fold (fn x => fn table => merge table (f x)) ts Symtab.empty

fun diff a b = Symtab.fold (fn (k, v) => fn a => 
			 (Symtab.delete k a) handle UNDEF => a) 
		     b a
		    
fun collect_vars (cplexVar v) = singleton v
  | collect_vars (cplexNeg t) = collect_vars t
  | collect_vars (cplexProd (t1, t2)) = 
    merge (collect_vars t1) (collect_vars t2)
  | collect_vars (cplexSum ts) = mergemap collect_vars ts
  | collect_vars _ = emptyset

(* Eliminates all nonfree bounds from the linear program and produces an
   equivalent program with only free bounds 
   IF for the input program P holds: is_normed_cplexProg P *)
fun elim_nonfree_bounds (cplexProg (name, goal, constraints, bounds)) =
    let
	fun collect_constr_vars (_, cplexConstr (c, (t1,_))) =
	    (collect_vars t1)   
	
	val cvars = merge (collect_vars (term_of_goal goal)) 
			  (mergemap collect_constr_vars constraints)         
		    
	fun collect_lower_bounded_vars 
	    (cplexBounds (t1, c1, cplexVar v, c2, t3)) =
	    singleton v
	  |  collect_lower_bounded_vars 
		 (cplexBound (_, cplexLe, cplexVar v)) =
	     singleton v
	  |  collect_lower_bounded_vars 
		 (cplexBound (_, cplexLeq, cplexVar v)) = 
	     singleton v
	  |  collect_lower_bounded_vars 
		 (cplexBound (cplexVar v, cplexGe,_)) = 
	     singleton v
	  |  collect_lower_bounded_vars 
		 (cplexBound (cplexVar v, cplexGeq, _)) = 
	     singleton v
	  | collect_lower_bounded_vars
	    (cplexBound (cplexVar v, cplexEq, _)) = 
	    singleton v
	  |  collect_lower_bounded_vars _ = emptyset
	
	val lvars = mergemap collect_lower_bounded_vars bounds        
	val positive_vars = diff cvars lvars			   
	val zero = cplexNum "0"
	
	fun make_pos_constr v = 
	    (NONE, cplexConstr (cplexGeq, ((cplexVar v), zero)))
	
	fun make_free_bound v = 
	    cplexBounds (cplexNeg cplexInf, cplexLeq, 
			 cplexVar v, cplexLeq,
			 cplexInf)
	
	val pos_constrs = rev (Symtab.fold
			      (fn (k, v) => cons (make_pos_constr k))
			      positive_vars [])
        val bound_constrs = map (pair NONE)
				(maps bound2constr bounds)
	val constraints' = constraints @ pos_constrs @ bound_constrs
	val bounds' = rev (Symtab.fold (fn (v, _) => cons (make_free_bound v)) cvars []);
    in
	cplexProg (name, goal, constraints', bounds')
    end

fun relax_strict_ineqs (cplexProg (name, goals, constrs, bounds)) = 
    let
	fun relax cplexLe = cplexLeq
	  | relax cplexGe = cplexGeq
	  | relax x = x
	
	fun relax_constr (n, cplexConstr(c, (t1, t2))) = 
	    (n, cplexConstr(relax c, (t1, t2)))
	    
	fun relax_bounds (cplexBounds (t1, c1, t2, c2, t3)) = 
	    cplexBounds (t1, relax c1, t2, relax c2, t3)
	  | relax_bounds (cplexBound (t1, c, t2)) = 
	    cplexBound (t1, relax c, t2)
    in
	cplexProg (name, 
		   goals, 
		   map relax_constr constrs, 
		   map relax_bounds bounds)
    end

datatype cplexResult = Unbounded 
		     | Infeasible 
		     | Undefined
		     | Optimal of string * ((string * string) list)

fun is_separator x = forall (fn c => c = #"-") (String.explode x)

fun is_sign x = (x = "+" orelse x = "-")

fun is_colon x = (x = ":")

fun is_resultsymbol a = 
    let
	val symbol_char = String.explode "!\"#$%&()/,.;?@_`'{}|~-"
	fun is_symbol_char c = Char.isAlphaNum c orelse 
			       exists (fn d => d=c) symbol_char
	fun is_symbol_start c = is_symbol_char c andalso 
				not (Char.isDigit c) andalso 
				not (c= #".") andalso
				not (c= #"-")
	val b = String.explode a
    in
	b <> [] andalso is_symbol_start (hd b) andalso 
	forall is_symbol_char b
    end

val TOKEN_SIGN = 100
val TOKEN_COLON = 101
val TOKEN_SEPARATOR = 102

fun load_glpkResult name = 
    let
	val flist = [(is_NL, TOKEN_NL), 
		     (is_blank, TOKEN_BLANK),
		     (is_num, TOKEN_NUM),
		     (is_sign, TOKEN_SIGN),
                     (is_colon, TOKEN_COLON),
		     (is_cmp, TOKEN_CMP),
		     (is_resultsymbol, TOKEN_SYMBOL),
		     (is_separator, TOKEN_SEPARATOR)]

	val tokenize = tokenize_general flist

	val f = TextIO.openIn name  

	val rest = ref []
		   
	fun readToken_helper () =
	    if length (!rest) > 0 then  
		let val u = hd (!rest) in 
		    (
		     rest := tl (!rest); 
		     SOME u
		    ) 
		end
	    else 
		let val s = TextIO.inputLine f in
		    if s = "" then NONE else (rest := tokenize s; readToken_helper())					     
		end           
		
	fun is_tt tok ty = (tok <> NONE andalso (fst (the tok)) = ty)

	fun pushToken a = if a = NONE then () else (rest := ((the a)::(!rest)))
	
	fun readToken () =
	    let val t = readToken_helper () in
		if is_tt t TOKEN_BLANK then 
		    readToken ()
		else if is_tt t TOKEN_NL then 
		    let val t2 = readToken_helper () in
			if is_tt t2 TOKEN_SIGN then 
			    (pushToken (SOME (TOKEN_SEPARATOR, "-")); t)
			else 
			    (pushToken t2; t)
		    end
		else if is_tt t TOKEN_SIGN then
		    let val t2 = readToken_helper () in
			if is_tt t2 TOKEN_NUM then
			    (SOME (TOKEN_NUM, (snd (the t))^(snd (the t2))))
			else
			    (pushToken t2; t)
		    end
		else
		    t
	    end	    		

        fun readRestOfLine P = 
	    let 
		val t = readToken ()
	    in
		if is_tt t TOKEN_NL orelse t = NONE 
		then P
		else readRestOfLine P
	    end			
							 
	fun readHeader () = 
	    let
		fun readStatus () = readRestOfLine ("STATUS", snd (the (readToken ())))
		fun readObjective () = readRestOfLine ("OBJECTIVE", snd (the (readToken (); readToken (); readToken ())))
		val t1 = readToken ()
		val t2 = readToken ()
	    in
		if is_tt t1 TOKEN_SYMBOL andalso is_tt t2 TOKEN_COLON 
		then
		    case to_upper (snd (the t1)) of
			"STATUS" => (readStatus ())::(readHeader ())
		      | "OBJECTIVE" => (readObjective())::(readHeader ())
		      | _ => (readRestOfLine (); readHeader ())
		else
		    (pushToken t2; pushToken t1; [])
	    end

	fun skip_until_sep () = 
	    let val x = readToken () in
		if is_tt x TOKEN_SEPARATOR then
		    readRestOfLine ()
		else 
		    skip_until_sep ()
	    end

	fun load_value () =
	    let 
		val t1 = readToken ()
		val t2 = readToken ()
	    in
		if is_tt t1 TOKEN_NUM andalso is_tt t2 TOKEN_SYMBOL then
		    let 
			val t = readToken ()
			val state = if is_tt t TOKEN_NL then readToken () else t
			val _ = if is_tt state TOKEN_SYMBOL then () else raise (Load_cplexResult "state expected")
			val k = readToken ()
		    in
			if is_tt k TOKEN_NUM then
			    readRestOfLine (SOME (snd (the t2), snd (the k)))
			else
			    raise (Load_cplexResult "number expected")
		    end				
		else
		    (pushToken t2; pushToken t1; NONE)
	    end

	fun load_values () = 
	    let val v = load_value () in
		if v = NONE then [] else (the v)::(load_values ())
	    end
	
	val header = readHeader () 

	val result = 
	    case AList.lookup (op =) header "STATUS" of
		SOME "INFEASIBLE" => Infeasible
	      | SOME "UNBOUNDED" => Unbounded
	      | SOME "OPTIMAL" => Optimal (the (AList.lookup (op =) header "OBJECTIVE"), 
					   (skip_until_sep (); 
					    skip_until_sep ();
					    load_values ()))
	      | _ => Undefined

	val _ = TextIO.closeIn f
    in
	result
    end
    handle (Tokenize s) => raise (Load_cplexResult ("Tokenize: "^s))
	 | Option => raise (Load_cplexResult "Option")
	 | x => raise x

fun load_cplexResult name = 
    let
	val flist = [(is_NL, TOKEN_NL), 
		     (is_blank, TOKEN_BLANK),
		     (is_num, TOKEN_NUM),
		     (is_sign, TOKEN_SIGN),
                     (is_colon, TOKEN_COLON),
		     (is_cmp, TOKEN_CMP),
		     (is_resultsymbol, TOKEN_SYMBOL)]

	val tokenize = tokenize_general flist

	val f = TextIO.openIn name  

	val rest = ref []
		   
	fun readToken_helper () =
	    if length (!rest) > 0 then  
		let val u = hd (!rest) in 
		    (
		     rest := tl (!rest); 
		     SOME u
		    ) 
		end
	    else 
		let 
		    val s = TextIO.inputLine f 
		in		    
		    if s = "" then NONE else (rest := tokenize s; readToken_helper())					     
		end           
		
	fun is_tt tok ty = (tok <> NONE andalso (fst (the tok)) = ty)

	fun pushToken a = if a = NONE then () else (rest := ((the a)::(!rest)))
	
	fun readToken () =
	    let val t = readToken_helper () in
		if is_tt t TOKEN_BLANK then 
		    readToken ()
		else if is_tt t TOKEN_SIGN then
		    let val t2 = readToken_helper () in
			if is_tt t2 TOKEN_NUM then
			    (SOME (TOKEN_NUM, (snd (the t))^(snd (the t2))))
			else
			    (pushToken t2; t)
		    end
		else
		    t
	    end	    		

        fun readRestOfLine P = 
	    let 
		val t = readToken ()
	    in
		if is_tt t TOKEN_NL orelse t = NONE 
		then P
		else readRestOfLine P
	    end			

	fun readHeader () = 
	    let
		fun readStatus () = readRestOfLine ("STATUS", snd (the (readToken ())))
		fun readObjective () = 
		    let
			val t = readToken ()
		    in
			if is_tt t TOKEN_SYMBOL andalso to_upper (snd (the t)) = "VALUE" then 
			    readRestOfLine ("OBJECTIVE", snd (the (readToken())))
			else
			    readRestOfLine ("OBJECTIVE_NAME", snd (the t))
		    end
		  
		val t = readToken ()
	    in
		if is_tt t TOKEN_SYMBOL then
		    case to_upper (snd (the t)) of 
			"STATUS" => (readStatus ())::(readHeader ())
		      | "OBJECTIVE" => (readObjective ())::(readHeader ())
		      | "SECTION" => (pushToken t; [])
		      | _ => (readRestOfLine (); readHeader ())
		else
		    (readRestOfLine (); readHeader ())
	    end

	fun skip_nls () = 
	    let val x = readToken () in
		if is_tt x TOKEN_NL then 
		    skip_nls () 
		else 
		    (pushToken x; ())
	    end

	fun skip_paragraph () = 
	    if is_tt (readToken ()) TOKEN_NL then
		(if is_tt (readToken ()) TOKEN_NL then
		     skip_nls ()
		 else
		     skip_paragraph ())
	    else			
		skip_paragraph ()	

	fun load_value () =
	    let 
		val t1 = readToken ()
		val t1 = if is_tt t1 TOKEN_SYMBOL andalso snd (the t1) = "A" then readToken () else t1
	    in
		if is_tt t1 TOKEN_NUM then
		    let 
			val name = readToken ()
			val status = readToken ()
			val value = readToken ()
		    in
			if is_tt name TOKEN_SYMBOL andalso
			   is_tt status TOKEN_SYMBOL andalso
			   is_tt value TOKEN_NUM 
			then
			    readRestOfLine (SOME (snd (the name), snd (the value)))
			else
			    raise (Load_cplexResult "column line expected")
		    end
		else 
		    (pushToken t1; NONE)
	    end

	fun load_values () = 
	    let val v = load_value () in
		if v = NONE then [] else (the v)::(load_values ())
	    end
	
	val header = readHeader ()

	val result = 
	    case AList.lookup (op =) header "STATUS" of
		SOME "INFEASIBLE" => Infeasible
	      | SOME "NONOPTIMAL" => Unbounded
	      | SOME "OPTIMAL" => Optimal (the (AList.lookup (op =) header "OBJECTIVE"), 
					   (skip_paragraph (); 
					    skip_paragraph (); 
					    skip_paragraph (); 
					    skip_paragraph (); 
					    skip_paragraph ();
					    load_values ()))
	      | _ => Undefined

	val _ = TextIO.closeIn f
    in
	result
    end
    handle (Tokenize s) => raise (Load_cplexResult ("Tokenize: "^s))
	 | Option => raise (Load_cplexResult "Option")
	 | x => raise x

exception Execute of string;

fun tmp_file s = Path.pack (Path.expand (File.tmp_path (Path.make [s])));
fun wrap s = "\""^s^"\"";

fun solve_glpk prog =
    let 
	val name = LargeInt.toString (Time.toMicroseconds (Time.now ()))	
	val lpname = tmp_file (name^".lp")
	val resultname = tmp_file (name^".txt")
	val _ = save_cplexFile lpname prog		
	val cplex_path = getenv "GLPK_PATH"
	val cplex = if cplex_path = "" then "glpsol" else cplex_path
	val command = (wrap cplex)^" --lpt "^(wrap lpname)^" --output "^(wrap resultname)
	val answer = execute command
    in
	let
	    val result = load_glpkResult resultname
	    val _ = OS.FileSys.remove lpname
	    val _ = OS.FileSys.remove resultname
	in
	    result
	end 
	handle (Load_cplexResult s) => raise (Execute ("Load_cplexResult: "^s^"\nExecute: "^answer))
	     | _ => raise (Execute answer)
    end		     
    
fun solve_cplex prog =
    let 
	fun write_script s lp r =
	    let
		val f = TextIO.openOut s
		val _ = TextIO.output (f, "read\n"^lp^"\noptimize\nwrite\n"^r^"\nquit")
		val _ = TextIO.closeOut f
	    in 
		() 
	    end 
	    
	val name = LargeInt.toString (Time.toMicroseconds (Time.now ()))	
	val lpname = tmp_file (name^".lp")
	val resultname = tmp_file (name^".txt")
	val scriptname = tmp_file (name^".script")
	val _ = save_cplexFile lpname prog		
	val cplex_path = getenv "CPLEX_PATH"
	val cplex = if cplex_path = "" then "cplex" else cplex_path
	val _ = write_script scriptname lpname resultname
	val command = (wrap cplex)^" < "^(wrap scriptname)^" > /dev/null"
	val answer = "return code "^(Int.toString (system command))
    in
	let
	    val result = load_cplexResult resultname
	    val _ = OS.FileSys.remove lpname
	    val _ = OS.FileSys.remove resultname
	    val _ = OS.FileSys.remove scriptname
	in
	    result
	end 
    end

fun solve prog = 
    case get_solver () of
      SOLVER_DEFAULT => 
        (case getenv "LP_SOLVER" of
	   "CPLEX" => solve_cplex prog
         | "GLPK" => solve_glpk prog
         | _ => raise (Execute ("LP_SOLVER must be set to CPLEX or to GLPK")))
    | SOLVER_CPLEX => solve_cplex prog
    | SOLVER_GLPK => solve_glpk prog
		   
end;

(*
val demofile = "/home/obua/flyspeck/kepler/LP/cplexPent2.lp45"
val demoout = "/home/obua/flyspeck/kepler/LP/test.out"
val demoresult = "/home/obua/flyspeck/kepler/LP/try/test2.sol"
	   
fun loadcplex () = Cplex.relax_strict_ineqs 
		   (Cplex.load_cplexFile demofile)

fun writecplex lp = Cplex.save_cplexFile demoout lp

fun test () = 
    let
	val lp = loadcplex ()
	val lp2 = Cplex.elim_nonfree_bounds lp
    in
	writecplex lp2
    end

fun loadresult () = Cplex.load_cplexResult demoresult;
*)

(*val prog = Cplex.load_cplexFile "/home/obua/tmp/pent/graph_0.lpt";
val _ = Cplex.solve prog;*)