(*
  File: Min.sml

  For doing aggregation of PEPA models
*)

structure Min =
(* structure Min :> Min = *)
struct

(*    type derivative = (string * string) * Pepa.Component *)
(*    type derivative = (string * Expressions.Aexp) * Pepa.Component *)
(*    type derivative = (string * bool) * Pepa.Component *)
(*    type derivatives = derivative list *)

   open Pepa

   exception noprefixorchoiceinle

   local
      fun le (VAR I, VAR I') = HashTable.unhash(I) <= HashTable.unhash(I')
	| le (VAR I, _) = true
	(* gcla - need this case *)
	| le (_, VAR I) = false
(*
(* no sequential components *)
| le (PREFIX ((a, r), P), PREFIX ((a', r'), P')) =
  a < a' orelse (a = a' andalso (r < r' orelse (r = r' andalso le (P, P'))))
| le (CHOICE (P, Q), CHOICE (P', Q')) = 
  le (P, P') orelse (P=P' andalso le (Q, Q'))
| le (CHOICE _, _) = true
  *)
	| le (COOP ([], L), COOP ([], L')) = le_st (L, L')
	| le (COOP ([], L), COOP (_,  L')) = true
	| le (COOP (_,  L), COOP ([], L')) = false
	| le (COOP (h1::t1, L), COOP (h2::t2, L')) =
	  le (h1, h2) orelse ((Pepa.pequals(h1,h2)) andalso le (COOP (t1, L), COOP (t2, L')))
	| le (COOP _, _) = true
	(* gcla - need this case *)
	| le (_, COOP _) = false

	| le (HIDING (P, L), HIDING (P', L')) = 
	  le (P, P') orelse ((Pepa.pequals(P,P')) andalso le_st (L, L'))
	| le (HIDING _, _) = true
	(* gcla - need this case *)
	| le (_, HIDING _) = false

	| le (PREFIX _, _) = raise noprefixorchoiceinle
	| le (_, PREFIX _) = raise noprefixorchoiceinle
	| le (CHOICE _, _) = raise noprefixorchoiceinle
	| le (_, CHOICE _) = raise noprefixorchoiceinle

	| le _ = true

      and le_st ([], []) = true
	| le_st ([], _) = true
	| le_st (_, []) = false
	| le_st (h1::t1, h2::t2) = HashTable.unhash(h1) < HashTable.unhash(h2)
	  orelse (h1 = h2 andalso le_st (t1, t2))
(*       and le_pair (((a : string, r : string), P), ((a', r'), P')) = *)
(* 	 a < a' orelse (a=a' andalso (r < r' orelse (r=r' andalso le (P, P')))) *)
(*       and le_pair (((a : string, r : string), n, P), ((a', r'), n', P')) = *)
(* 	 a < a' orelse (a=a' andalso (r < r' orelse (r=r' andalso le (P, P')))) *)
      and le_pair (((a : HashTable.hashedstring, r : Expressions.Aexp), n, P), ((a', r'), n', P')) =
	 (HashTable.unhash(a) < HashTable.unhash(a')) orelse (a=a' andalso ((Expressions.lessThan(r,r')) orelse ((Expressions.aequals(r,r')) andalso le (P, P'))))
(*       and le_pair (((a : HashTable.hashedstring, r : HashTable.hashedstring), n, P), ((a', r'), n', P')) = *)
(* 	 HashTable.unhash(a) < HashTable.unhash(a') orelse (a=a' andalso (HashTable.unhash(r) < HashTable.unhash(r') orelse (r=r' andalso le (P, P')))) *)
      fun sorta [] = []
	| sorta ((COOP (C, L)) :: t) = 
	  let val h = COOP (sorta C, L)
	  in insert (h, sorta t)
	  end
	| sorta (h::t) = insert (h, sorta t)
      and insert (x, []) = [x]
	| insert (x, h::t) =
	  if le (x, h) then x :: h :: t
	  else h :: insert (x, t)
      fun sort_sing (CONSTS (I, P, L)) = CONSTS (I, P, sort_sing L)
	| sort_sing A = hd (sorta [A])
      fun sortp [] = []
(* 	| sortp (h as (a, P) :: t) = *)
	| sortp (h as (a, n, P) :: t) =
(* 	  insert ((a, sort_sing P), sortp t) *)
	  insert ((a, n, sort_sing P), sortp t)
      and insert (x, []) = [x]
	| insert (x, h::t) =
	  if le_pair (x, h) then x :: h :: t
	  else h :: insert (x, t)
   in
      val sort_agent = sort_sing
      val sort_agents = sorta 
      val sort_pairs = sortp
   end
   

   local

      (* gcla *)
      fun stoc s =
	 case (Char.fromString s) of
	    NONE => Char.minChar
	  | SOME c => c

(* (m, ((a, r), n, P)) *)

      fun print_trio' n [] = ()
	| print_trio' n ((m, ((a, r), P)) :: t) =
	  (TextIO.output (TextIO.stdOut, (Int.toString n) ^ ".\t[" 
			  ^ (Int.toString m) ^ " times] --(" 
			  ^ a ^ ", " ^ (Expressions.toString (Expressions.simplify r)) ^ ")-->\n\t"
(* 			  ^ a ^ ", " ^ r ^ ")-->\n\t" *)
			  ^ Prettyprinter.print Prettyprinter.uncompressed
			  P ^ "\n");
	  print_trio' (n+1) t)
      local 
	 fun get_numeric_suffix acc [] = (0, "")
	   | get_numeric_suffix acc ("*" :: t) = (acc, implode (rev (map stoc t)))
	   | get_numeric_suffix acc (h::t) = 
	     if numeric h then 
		get_numeric_suffix (10 * acc + value h) t
	     else (0, "")
	 and numeric c = "0" <= c andalso c <= "9"
	 and value c = ord (stoc c) - ord (stoc "0")
	 fun getnum id = get_numeric_suffix 0 (map Char.toString (rev (explode id)))
      in
	 fun make_rate_product rate num =
	    Expressions.PROD(rate, Expressions.INTNUM num)
      end

      fun minimize_trio (m, ((a, r), n, P)) = ((a, make_rate_product r m), n,P)
(*       fun hackedequals (((a1,b1),c1,d1),((a2,b2),c2,d2)) = *)
(* 	 (a1=a2) andalso (Expressions.aequals(b1,b2)) andalso (c1=c2) andalso (Pepa.pequals(d1,d2)) *)

      fun hackedequals (((a1,b1),c1,d1),((a2,b2),c2,d2)) =
	 (a1=a2) andalso (Expressions.aequals(b1,b2)) andalso (c1=c2) andalso (Pepa.pequals(d1,d2))

   in
      type derivatives = ((HashTable.hashedstring * Expressions.Aexp) 
			  * int * Component) list;
      type derivatives' = ((HashTable.hashedstring * Expressions.Aexp)
			  * int * Component) list;
      fun mktrio n [] = []
	| mktrio n [x] = [(n, x)]
	| mktrio n (h1::h2::t) = 
	  (
(* 	   if (Pepa.pequals(h1,h2)) *)
	   if (hackedequals(h1,h2))
(* 	   if (true = true) *)
	      then (
		    mktrio (n+1) (h2::t))
	   else
	      let val p145 = h1
	      in
		 (n, h1) :: mktrio 1 (h2::t)
	      end)
      fun remove_idents (n, a, c) = (n, 1, c)

      val minimize : derivatives -> derivatives' = (map minimize_trio) o (mktrio 1) o (map remove_idents) o sort_pairs
(*       val print_trio : derivatives -> unit = (print_trio' 1) o (mktrio 1) *)
   end



   local
      local
	 fun sort []                     = []
	   | sort (h::t)                 = insert h (sort t)
	 and insert (x: HashTable.hashedstring) []       = [x]
	   | insert x (l as h::t)        = if (HashTable.unhash(x) < HashTable.unhash(h)) then x::l else 
	     if x = h then l else h :: insert x t
      in
	 fun fold (PREFIX ((a, r), P)) = (PREFIX ((a, r), P))
	   | fold (CHOICE (P, Q))      = (CHOICE (P, Q))
	   | fold (COOP ([], L))       =
	     ((* TextIO.output (TextIO.stdOut, "coop []\n"); *)
(* 	      TextIO.flushOut (TextIO.stdOut); *)
(* 	      TextIO.output (TextIO.stdOut, "testing sort L\n"); *)
(* 	      TextIO.flushOut (TextIO.stdOut); *)
(* 	      sort L; *)
(* 	      TextIO.output (TextIO.stdOut, "managed sort L\n"); *)
(* 	      TextIO.flushOut (TextIO.stdOut); *)
	      (COOP ([], sort L)))
	   | fold (COOP (h::t, L))     =
	     ((* TextIO.output (TextIO.stdOut, "coop list\n"); *)
	      let
		val git = fold (COOP (t, L))
		val (t', L') = case git of
		   COOP (t''', L''') => (t''', L''')
		 | _ => (TextIO.output (TextIO.stdOut, "not a coop back!\n");
			 TextIO.flushOut (TextIO.stdOut);
			 (t,L))
	      (* gcla - remove later *)
	      (* 		val COOP (t', L') = fold (COOP (t, L)) *)
	     in
		case h of
		   (COOP (t'', L'')) => 
		      ((* TextIO.output (TextIO.stdOut, "test set equal\n"); *)
(* 		       TextIO.flushOut (TextIO.stdOut); *)
(* 		       seteq (L, L''); *)
		       if seteq (L, L'') 
			 then COOP (map fold t'' @ t', L')
		      else COOP (fold h :: t', L'))
		 | _ => ((* TextIO.output (TextIO.stdOut, "not a coop\n"); *)
(* 			 TextIO.flushOut (TextIO.stdOut); *)
			 COOP (h :: t', L'))
	     end)
	   | fold (HIDING (P, L))      = (HIDING (fold P, sort L))
	   | fold (VAR I)              = 
	     ((* TextIO.output (TextIO.stdOut, "var\n"); *)
	      (VAR I))
	   (* gcla - remove later *)
(* 	   | fold (CONST (I, P))       = (CONST (I, fold P)) *)
	   | fold (CONSTS (I, P, L))   = 
	     ((* TextIO.output (TextIO.stdOut, "consts\n"); *)
(* 	      TextIO.flushOut (TextIO.stdOut); *)
	      let val x = fold L
	      in
		 ((* TextIO.output (TextIO.stdOut, "managed fold L\n"); *)
(* 		  TextIO.flushOut (TextIO.stdOut); *)
		  (CONSTS (I, P, x)))
	      end)
	 and seteq (s1, s2)            = subset (s1, s2) andalso subset (s2, s1)
	 and subset ([], _)            = true
	   | subset (h::t, s)          = let
		fun member (x, []) = false
		  | member (x, h::t) = x=h orelse member (x, t)
	     in
		member (h, t) andalso subset (t, s)
	     end
      end
   in
      fun fixpointfold A = 
	 let val A' = fold A 
(* 	    val _ = (TextIO.output (TextIO.stdOut, "folded once\n"); *)
(* 		     TextIO.flushOut (TextIO.stdOut)) *)
(* 	    val _ = (TextIO.output (TextIO.stdOut, "testing a = a'\n"); *)
(* 		     TextIO.flushOut (TextIO.stdOut)) *)
(* 	    val _ = A = A' *)
(* 	    val _ = (TextIO.output (TextIO.stdOut, "managed equal check\n"); *)
(* 		     TextIO.flushOut (TextIO.stdOut)) *)
	 in if (Pepa.pequals(A,A'))
	       then ((* TextIO.output (TextIO.stdOut, "a = a'\n"); *)
(* 		     TextIO.flushOut (TextIO.stdOut); *)
		     A)
	    else ((* TextIO.output (TextIO.stdOut, "folding again\n"); *)
(* 		  TextIO.flushOut (TextIO.stdOut); *)
		  fixpointfold A')
	 end
      val fixpointfold = sort_agent o fixpointfold o sort_agent
   end

end;

