(******************************************************************************
 ** BuildPls.sml
 ** sml
 ** 
 ** Umut A. Acar
 ** 
 ** Build a PLS (Piecewise-linear-system). 
 ******************************************************************************)

   (******************************************************************************
  ** We represent a PLS with a dag of polytopes.  The dag has two kinds
  ** of edges, boundary edges and internal edges.  A boundary edge (u,
  ** v) denotes that v is in the boundary of u, and an internal edge
  ** (u, v) denotes that v is an internal contraint of u (v lies
  ** inside the boundary of u).  We represent the dag with a
  ** dictionary that is indexed by the id of polytopes.  A dictionary
  ** entry contains a dictionary of boundary and internal edges.  We
  ** also store parent edges in the dictionary and some data.
  ** Each polytope is given a generated id. 
  ********************************************************************************)

functor BuildPls (structure Geometry: GEOMETRY
		  structure Vertex: VERTEX where type point = Geometry.Point.point
		  structure Id: ID) : PLS where Vertex = Vertex and
						PolytopeId = Id
=
struct  
  (* A point. *)
  structure Point = Geometry.Point
  structure Vertex = Vertex
  type vertex = Vertex.vertex
 
  structure PolytopeId = Id
  type polytopeId = PolytopeId.id

  (******************************************************************************
   ******************************************************************************
   ** Constants 
   ******************************************************************************
   ******************************************************************************)
  val DEBUG = false             (* ? Debugging mode. *)
  val VERBOSE = true            (* ? Verbose mode. *)

  (******************************************************************************
   ******************************************************************************
   ** Data structures 
   ******************************************************************************
   ******************************************************************************)
    
  (* IDKEY is the key for the ID type. *)
  structure IDKey = 
    struct
      type t = polytopeId
      val compare = Id.compare
    end

  (** The mapping from point ids to vertices. **)
  structure IdTable =  RedBlackTable (structure Index = IDKey)
  structure PolytopeIdTable = IdTable

  type PointDic = Vertex.vertex IdTable.table

  (** The dictionary for the labels, a mapping from labels to IDs. **)
  structure Label = 
    struct
      type t = string
      val compare = String.compare
    end
  (* A table. *)

  structure LabelTable = RedBlackTable (structure Index = Label)

  (* A polytope. *)
  type polytope = {label: string,                    (* The label. *) 
		   id: polytopeId,                   (* The id. *)
		   dim: int,                         (* The dimention. *)
		   boundary: unit IdTable.table,     (* Boundary constraints. *)
		   internal: unit IdTable.table,     (* Internal contsraints. *)
		   constrained: unit IdTable.table   (* Constrainted polytopes. *)
		   }

  (* The dag. *)
  type pls = polytopeId * polytope IdTable.table
  
  (** An edge represents either a boundary or an internal constraint. **)
  datatype EdgeType = Boundary | Internal

  (******************************************************************************
   ******************************************************************************
   ** Exceptions 
   ******************************************************************************
   ******************************************************************************)

   exception BadCode          (* Raise when found a bug in the code. *)
   exception BadInput         (* Raise when the input file format is not correct. *)
   exception UndefinedLabel   (* Raise when found an undefined label in the input. *)
   exception UnexpectedEndOfFile (* Raise when there is not enought data in the input. *)
   exception PolytopeNotFound (* Raise when a polytope is not found. *)
   exception NYI              (* Not yet implemented. *)


  (******************************************************************************
   ******************************************************************************
   ** Printing, type conversion, debugging. 
   ******************************************************************************
   ******************************************************************************)

   fun vPrint (str) = 
     if VERBOSE then 
       print (str)
     else
       ()

  fun dPrint (str) = 
    if (DEBUG) then 
      print (str)
    else
      ()

  fun realFromString (str) = 
    let 
      val _ = dPrint ("realFromString: input = " ^ str ^ "\n");
    in      
      case Real.fromString (str) of
	 NONE => raise BadInput
       | SOME (x) => x
    end

  fun intFromString (str) = 
    let 
      val _ = dPrint ("intFromString: input = " ^ str ^ "\n");
    in      
      case Int.fromString (str) of
	 NONE => raise BadInput
       | SOME (x) => x
    end
      


  (******************************************************************************
   ******************************************************************************
   ** Update operations
   ******************************************************************************
   ******************************************************************************)


   (******************************************************************************
    ** add: add a polytope.
    ** Input: a pls and the dimension of the new polytope. 
    ** Output: the pls and the id of the new polytope. 
    ******************************************************************************)
   fun add ((id,pls'):pls, d:int) = 
     let
       val i = Id.next(id)
      in
	((i, IdTable.insert ((i, {label = "!generated", 
				  id = i, 
				  dim = d, 
				  boundary = IdTable.empty, 
				  internal = IdTable.empty, 
				  constrained = IdTable.empty} : polytope), 
			      pls')), 
	 i)			 
     end
       
   (******************************************************************************
    ** remove: remove a polytope.
    ** Input: a pls and the id of the polytope to remove
    ** Output: the pls.
    ******************************************************************************)
   fun rem ((i,pls'), ptope) =
     let        
       val (pls', _) = IdTable.deleteReturn (ptope, pls')
     in
       (i,pls')
     end

   (******************************************************************************
    ** addConstrained:  add a constraining edge. 
    ** Input: a pls and the edge (u, v)
    ** Output: the pls.
    ******************************************************************************)   
   fun addConstrained ((i : polytopeId ,pls : polytope IdTable.table), 
		       u : polytopeId , v : polytopeId) = 
     let 
      (* Add the  boundary constraint, constraint. *)
       fun updateFun (NONE) = raise BadCode
	 | updateFun (SOME (value)) =
	 let 
	   val {label = l, id = id, dim = dim, boundary = b, 
		internal = i, constrained = c} = value
	   val c = IdTable.insert ((v, ()), c)
	 in 
	   SOME ({label = l, id = id, dim = dim, boundary = b, 
		  internal = i, constrained = c})
	 end
     in
       (i, (IdTable.update updateFun (u, pls)))
     end

   (******************************************************************************
    ** addBoundary:  add a boundary edge.
    ** Input: a pls and the edge (u, v)
    ** Output: the pls.
    ******************************************************************************)   
   fun addBoundary ((i,pls'):pls, u : polytopeId, v : polytopeId) = 
     let 
      (* Add the  boundary constraint, constraint. *)
      fun updateFun (NONE) = raise BadCode
        | updateFun (SOME (value)) =
	    let 
	      val {label = l, id = id, dim = dim, boundary = b, 
		   internal = i, constrained = c} = value
	      val b = IdTable.insert ((v, ()), b)
	    in 
	      SOME ({label = l, id = id, dim = dim, boundary = b, 
		     internal = i, constrained = c} : polytope)
	    end
      (* Create the edge from the constraint to the polytope. *)
      val (i,pls'):pls = addConstrained ((i,pls': polytope IdTable.table), 
					 v, u)      
     in
       (i, IdTable.update updateFun (u, pls'))
     end

   (******************************************************************************
    ** addInternal:  add an internal edge.
    ** Input: a pls and the edge (u, v)
    ** Output: the pls.
    ******************************************************************************)   
   fun addInternal ((i, pls): pls, u, v) = 
     let 
      (* Add the  boundary constraint, constraint. *)
       fun updateFun (NONE) = raise BadCode
	 | updateFun (SOME (value)) =
	 let 
	   val {label = l, id = id, dim = dim, boundary = b, 
		internal = i, constrained = c} = value
	   val i = IdTable.insert ((v, ()), i)
	 in 
	   SOME ({label = l, id = id, dim = dim, boundary = b, 
		  internal = i, constrained = c} : polytope)
	 end
       (* Create the edge from the constraint to the polytope. *)
       val (i,pls):pls = addConstrained ((i,pls), v, u)      
     in
       (i, (IdTable.update updateFun (u, pls)))
     end

  
  (******************************************************************************
   ******************************************************************************
   ** Operations with constraints
   ******************************************************************************
   ******************************************************************************)
 
  (* The second element of a tuple. *)
  fun project1 (a, b) = a

  (******************************************************************************
   ** boundary: the boundary of a polytope. 
   ** Input: a pls and the id of a polytope. 
   ** Output: The polytopes in the boundary. 
   ******************************************************************************)
  fun boundary ((i,pls): pls , ptope) = 
    let 
      val pRec : polytope = case IdTable.find (ptope, pls) of 
 	NONE => raise PolytopeNotFound
      | SOME (x) => x
		       
      val bTable = #boundary pRec
    in
      Sequence.fromList (List.map project1 (IdTable.toList (bTable)))
    end

  (******************************************************************************
   ** internal: the internal constraints of a polytope. 
   ** Input: a pls and the id of a polytope. 
   ** Output: The polytopes internal to the polytope. 
   ******************************************************************************) 
  fun internal ((i,pls): pls, ptope) = 
    let 
      val pRec = case IdTable.find (ptope, pls) of 
	           NONE => raise PolytopeNotFound
                 | SOME (x) => x
		       
      val iTable = #internal pRec
    in
      Sequence.fromList (List.map project1 (IdTable.toList (iTable)))
    end


  (******************************************************************************
   ** constrained: the polytopes that a polytope constrains.
   ** Input: a pls and the id of a polytope. 
   ** Output: The constrainted polytopes. 
   ******************************************************************************) 
  fun constrained ((i,pls): pls, ptope) = 
    let 
      val pRec = case IdTable.find (ptope, pls) of 
	           NONE => raise PolytopeNotFound
	         | SOME (x) => x
		       
      val cTable = #constrained pRec
    in
      Sequence.fromList (List.map project1 (IdTable.toList (cTable)))
    end



  (******************************************************************************
   ******************************************************************************
   ** Constructors
   ******************************************************************************
   ******************************************************************************)

  (******************************************************************************
   ** fromFile
   ******************************************************************************)
 
  (******************************************************************************
   ** Read points.  
   **
   ** Input:  The tokens, the number of points
   ** the dag, the dictionary, 
   ** the dimension.
   **
   ** Output: The tokens, the dag, the label dictionary.
   ******************************************************************************)

  fun readPoints (tokens, nPoints, (id, dag), points, lDic, dimension) = 
    if (nPoints = 0) then 
      (tokens, (id, dag), points, lDic)
    else
      let 
	(* The label for the current point. *)
	val lab = List.hd tokens
	val tokens = List.drop (tokens, 1)
	  
	(* The location of the current point. *)	
	val loc = List.map  realFromString (List.take (tokens, dimension))
	val tokens = List.drop (tokens, dimension)  

	(* Add the point label to the label dictionary. *)
	val id = Id.next(id)
	val lDic = LabelTable.insert ((lab, id) , lDic)  

	(* Add the point to point dictionary. *)
	val point = Point.fromSeq (Sequence.map Point.Number.fromReal (Sequence.fromList loc))
	val vertex = Vertex.new (point)
        val points = IdTable.insert ((id, vertex), points)
	  
	(* Add the point to the dag. *)	
	val dag = IdTable.insert ((id, {label = lab, id = id, dim = 0, 
				    boundary = IdTable.empty, 
				    internal = IdTable.empty, 
				    constrained = IdTable.empty} : polytope), dag)
	  
      in
	(* Recurse. *)
	readPoints (tokens, nPoints-1, (id, dag), points, lDic, dimension)
      end
  
  (******************************************************************************
   ** Process a list of internal or boundary contraints. 
   **
   ** Input: The edge type, The list of constraints, the dag, the label dictionary,
   ** the id of the polytope.      
   **
   ** Output: The dag, the label dictionary. 
   ******************************************************************************)

  fun addConstraints (edge, [], pls, lDic, ptope) = (pls, lDic)
    | addConstraints (edge, head::tail, pls, lDic, ptope) = 
    let

      (* The id of the constraint. *)
      val constraint = case LabelTable.find (head, lDic) of 
	                NONE => raise UndefinedLabel
                      | SOME (id) => id			 
	       
      (* Create the edge from the ptope to the constraint. *)      		     
      val pls = case edge of
		  Boundary => addBoundary (pls, ptope, constraint)
		| Internal => addInternal (pls, ptope, constraint)
	
      (* Create the edge from the constraint to the polytope. *)
      val pls = addConstrained (pls, constraint, ptope)
    in
      addConstraints (edge, tail, pls, lDic, ptope)
    end


  (******************************************************************************
   ** Read the description of polytopes with dimension >= 1 and 
   ** update the dag. 
   **
   ** Input: the dimension of polytopes, the token list, number of polytopes, 
   ** the dag, the label dictionary.
   **
   ** Output: the token list, the dag, the label dictionary.
   ******************************************************************************)

  fun readNDPolytopes (dim, [], nPolytopes, pls, lDic) = 		     
    let
      val _ = vPrint ("Done (" ^ Int.toString(dim) ^ "-D polytopes).\n") 
    in
      if nPolytopes = 0 then 
	([], pls, lDic)
      else 
	raise UnexpectedEndOfFile
	  end
		     
  |  readNDPolytopes (dim, tokens, nPolytopes, pls, lDic) = 
    if nPolytopes = 0 then 
      let
	val _ = vPrint ("Done (" ^ Int.toString(dim) ^ "-D polytopes).\n") 
	(* Read higher-dimensional polytopes. *)
	val nPolytopes = case tokens of 
	                   _::x::_ => intFromString (x)
		         | _ => raise BadInput
	val tokens = List.drop (tokens, 2)
	val dim = dim + 1
	val _ = vPrint ("Processing " ^ Int.toString (nPolytopes) ^ " "		
				      ^ Int.toString (dim) ^ "-D polytopes ...\n") 
      in
	readNDPolytopes (dim, tokens, nPolytopes, pls, lDic)
      end
    else
      let 
	(* The label for the current polytope. *)
	val lab = List.hd tokens
	val tokens = List.drop (tokens, 1)
	val _ = dPrint ("ReadNDPolytops: Processing polytope: " ^ lab ^ "\n")
	 
	val (id,dag) = pls

	(* Add the polytope label to the label dictionary. *)
	val id = Id.next (id)

	val lDic = LabelTable.insert ((lab, id), lDic)

	(* Add the point to the dag. *)	
	val dag = IdTable.insert ((id, {label = lab, id = id, dim = dim, 
				    boundary = IdTable.empty, 
				    internal = IdTable.empty, 
				    constrained = IdTable.empty
				    } : polytope), dag)

	val pls = (id,dag)

	(* The number of boundary constraints. *)
	val nBoundary = intFromString (List.hd tokens)
	val tokens = List.drop (tokens, 1)
        val _ = dPrint ("ReadNDPolytopes:" ^ lab ^ " has " ^ Int.toString (nBoundary)^ 
			" boundary constraints.\n")

	(* The number of internal constraints. *)
	val nInternal =  intFromString (List.hd tokens)
	val tokens = List.drop (tokens, 1)
        val _ = dPrint ("ReadNDPolytopes:" ^ lab ^ " has " ^ Int.toString (nInternal)^ 
			" internal constraints.\n")

	(* Process the boundary constraints. *)
	val constraints = List.take (tokens, nBoundary)
	val tokens = List.drop (tokens, nBoundary)
	val (pls, lDic) = addConstraints (Boundary, constraints, pls, lDic, id)
	val _ = dPrint ("ReadNDPolytopes: Boundary constraints added.\n")

	(* Process the internal constraints. *)
	val constraints = List.take (tokens, nInternal)
	val tokens = List.drop (tokens, nInternal)	 
	val (pls, lDic) = addConstraints (Internal, constraints, pls, lDic, id)	
	val _ = dPrint ("ReadNDPolytopes: Internal constraints added.\n")

      in
	readNDPolytopes (dim, tokens, nPolytopes-1, pls, lDic)
      end


  (******************************************************************************
   ** Build a Pls. 
   ** Input: Name of the file containing the PLS description. 
   ******************************************************************************)
  fun fromFile'(fName) = 
    let
      (* Open standard i/o library. *)
      open TextIO
	
      (* Open input file. *)
      val inFile = openIn (fName)       

      (* Read the input and divide it into tokens. *)
      val tokens = String.tokens Char.isSpace (TextIO.inputAll inFile)

      val id = Id.new ()

      (* The dimension *)
      val dimension = case tokens of 
	                DIMENSION::x::_ => intFromString (x)
		      | _ => raise BadInput
      val tokens = List.drop (tokens, 2)
      val _ = vPrint ("\nThe dimension is " ^ Int.toString (dimension) ^ ".\n")

      (* The number of points. *)	
      val nPoints = case tokens of 
	              POINTS::x::_ => intFromString (x)
		    | _ => raise BadInput
      val _ = vPrint ("Processing " ^ Int.toString (nPoints) ^ " input points ... \n")
      val tokens = List.drop (tokens, 2)

      val pls = (id, IdTable.empty)

      (* Read the points. *)
      val (tokens, pls, points, lDic) = 
        readPoints (tokens, nPoints, pls, IdTable.empty, 
		    LabelTable.empty, dimension)
      
      val _ = vPrint ("Done (Points).\n");
	
    in
      case tokens of 
	nil => (pls, points, lDic)
      | _ => 
	  let
	    (* Read higher-dimensional polytopes. *)
	    val nPolytopes = case tokens of 
	                       _::x::_ => intFromString (x)
                  	     | _ => raise BadInput
	    val tokens = List.drop (tokens, 2)
	    val _ = vPrint ("The number of 1-D polytopes is " ^ Int.toString (nPolytopes) ^ ".\n")	
	    val (_, pls, lDic) = readNDPolytopes (1, tokens, nPolytopes, pls, lDic) 
	  in
	    (pls, points, lDic)
	  end
    end

  fun fromFile (fname) =
      let
	  val (pls, points, lDic) = fromFile'(fname)
	  val (id, dag) = pls
      in
	  (pls, points, lDic)
      end

  (******************************************************************************
   ** polytopeDim: The dimension of a polytope. 
   ******************************************************************************)

  fun polytopeDim ({dim, ...}: polytope) = dim
  fun polytopeLabel ({label, ...}: polytope) = label

    
  (******************************************************************************
   ** plsTable
   ******************************************************************************)
  fun plsTable (pId, table) = table

  (******************************************************************************
   ** find: Find a polytope in a pls. 
   ******************************************************************************)
  fun find (pls, polytopeId) = 
    let
      val (_, pls') = pls
    in
      PolytopeIdTable.find (polytopeId, pls') 
    end

  (******************************************************************************
   ** printPolytope 
   ******************************************************************************)
  fun printPolytope ({label = label, id = id, dim = dim, ...}: polytope) = 
    print ("label = " ^ label ^ 
	   " id = " ^ Id.toString id ^ 
	   " dim = " ^ Int.toString dim ^ ".\n")
  
  (******************************************************************************
   ** printPls 
   ******************************************************************************)
  fun printPls (pls) = 
    let
      val (_, pls') = pls
	
      
      fun findPolytope polytopeId = 
	let
	in
	  case find (pls, polytopeId) of 
	    NONE => raise BadCode
	  | SOME x => x
	end

      fun printConsList (consList : polytopeId list) = 
	List.app (printPolytope o findPolytope) consList
		
      fun printPolytopeWCons (polytopeId) = 
	let 
	  val ptope = findPolytope (polytopeId)
	  val {label = label, id = id, dim = dim, 
	       internal = internal, boundary = boundary, 
	       constrained = constrained} = ptope
	    

	  fun project1 (x, y) = x
	    
	  (* Convert the constraint tables to list. *)
	  val iList = List.map project1 (PolytopeIdTable.toList internal)
	  val bList = List.map project1 (PolytopeIdTable.toList boundary)
	  val cList = List.map project1 (PolytopeIdTable.toList constrained)
	in   
	  (* Print the constraints. *)
	  (print ("\nBEGIN  polytope " ^ label ^ "\n");
	   printPolytope ptope;
	   print ("The internal constraints:\n");	   
	   printConsList iList;
	   print ("The boundary constraints:\n");	   
	   printConsList bList;
	   print ("The constrained polytopes:\n");	   
	   printConsList cList; 
	   print ("END polytope " ^ label ^ "\n"))
	end
      
      val plsList = List.map project1 (PolytopeIdTable.toList pls')
    in    
      List.app printPolytopeWCons plsList
    end
	  

			  
			  

	

end