(********************************************************************)
(*                                                                  *)
(*              Delegating quasi-interpretations to Maple           *)
(*                                                                  *)
(*                          Jean-Yves Moyen                         *)
(*                              Mai 2001                            *)
(*                                                                  *)
(********************************************************************)

open Langage

let mupad = "mupad"
let mupad_input = "interp"
let mupad_options = Printf.sprintf "-S %s" mupad_input
		      
let mupad_output = "to_check"

let muprint fd s=
  Printf.sprintf "fprint(Unquoted,%s,%s)" fd s

let clean varl=
(List.fold_right (^)
   (List.map (fun x->Printf.sprintf "delete %s;\n" x) varl) "unassume();\n")

(*let assume_pos varl=
(List.fold_right (^) 
   (List.map (fun x->Printf.sprintf "assume(%s>=1);\n" x) varl) "")*)

let assume_pos=
  "assume(Type::Integer):assume(Global >=1, _and);\n"

let rec printl sep f =
  function
      [] -> ""
    | [a] -> (f a)
    | a::r -> Printf.sprintf "%s%s%s" (f a) sep (printl sep f r)

let rec big l=
  match l with
      [] -> ""
    | [a] -> ""
    | [a;b] -> Printf.sprintf "assume(%s>=%s,_and);" a b
    | a::b::r -> Printf.sprintf "assume(%s>=%s,_and);\n%s" a b (big (b::r))

let assume_max l=
  Printf.sprintf "%s%s\n" assume_pos (big l)

let mupad_action fd varl poly= (*do this to each polynome*)
  Printf.sprintf "%s%stoto:=%s;\ntiti:=simplify(toto);\nsig:=sign(titi+0.1);\nif sig=-1 then %s elif sig=0 or sig=1 then %s else %s end_if;\n\n"
    (clean varl) assume_pos poly
    (muprint fd "false") (muprint fd "true") (muprint fd "titi") 

let mupad_max fd poly varl =
  Printf.sprintf "%s%stoto:=%s;\ntiti:=simplify(toto);\nsig:=sign(titi+0.1);\nif sig=-1 then %s elif sig=0 or sig=1 then %s else %s end_if;\n\n" 
    (clean varl) (assume_max varl) poly
    (muprint fd "false") (muprint fd "true") (muprint fd "titi") 

let print_input strl=
  let oc=open_out mupad_input in
  let rec go=
    function
	[] -> ()
      | (v,s)::l -> 
	  output_string oc (mupad_action "fd" v s);
	  go l in 
    begin
      output_string oc
	(Printf.sprintf "fd:=fopen(Text,\"%s\",Write);\n\n" mupad_output);
      go strl;
      output_string oc "fclose(fd);\n quit;";
      close_out oc
    end

let cons a l = a::l

let do_perm varl=
  let v=List.hd varl and l=List.tl varl in
  let rec go hd=
    function
	[] -> [[]]
      | [a] -> [[a]]
      | w::b::r when hd=w -> 
	  let permr=go b (r@[b]) in
	    List.map (cons w) permr
      | w::b::r ->
	  let permr=go b (r@[b]) in
	    (List.map (cons w) permr)@(go hd (b::r@[w]))
  in go v (l@[v])


let print_max varl pol=
  let oc=open_out mupad_input and perml=do_perm varl 
  in
    begin
      output_string oc 
	(Printf.sprintf "fd:=fopen(Text,\"%s\",Write);\n\n" mupad_output);
      List.iter (output_string oc) (List.map (mupad_max "fd" pol) perml);
      output_string oc "fclose(fd);\n quit;";
      close_out oc
    end

module OrderedStr=
struct
  type t = string
  let compare = compare
end

module StrSet=Set.Make(OrderedStr)

let rec get_vars p=
  let rec go =
    function
	VarP x-> StrSet.add (Printf.sprintf "x%i" x) StrSet.empty
      | Int _ | True | False -> StrSet.empty
      | Sum(p1,p2) -> StrSet.union (go p1) (go p2)
      | Dif(p1,p2) -> StrSet.union (go p1) (go p2)
      | Prod(p1,p2) -> StrSet.union (go p1) (go p2)
      | Max(p1,p2) -> StrSet.union (go p1) (go p2)
      | Power(p,i) -> go p
  in StrSet.elements (go p) 

exception Found of int * int

let is_max_vars=
  let rec go b=
    function
	VarP _ -> b
      | Int _ | True | False -> false
      | Sum(p1,p2) | Prod(p1,p2) | Dif(p1,p2) -> (go b p1) || (go b p2)
      | Power(p,i) -> go b p
      | Max(p1,p2) -> (go true p1) || (go true p2)
  in go false

let rec chk_max p=
  let varl=get_vars p in
  let varm=is_max_vars p
  in
    if varm
    then
	  begin
	    print_max varl (pol_to_string p);
	    ignore (Sys.command (mupad^" "^mupad_options));
	    let ic=open_in mupad_output in
	    let res=Parser.polyl Lexer.token (Lexing.from_channel ic) in
	      begin
		close_in ic;
		if List.for_all ((=)True) res (*List.map chk_max res*)
		then True
		else p
	      end
	  end
    else p

let rule_to_string prg eq =
  let p1,p2 = rule_to_pol prg eq in 
  let q=Dif(p1,p2) in
    (get_vars q),(pol_to_string q)


let check_qi prg=
  print_input (List.map (rule_to_string prg) prg.rules);
  ignore (Sys.command (mupad^" "^mupad_options));
  (*  Sys.remove mupad_input;*)
  let ic=open_in mupad_output in
  let res=Parser.polyl Lexer.token (Lexing.from_channel ic) in
    begin
      close_in ic;
      (*      Sys.remove mupad_output;*)
      List.map chk_max res
    end



