(* $Id: rational.ml,v 1.21 2000/06/26 12:44:48 freek Exp $ *)

open Std
open Pp
open Printer
open Term
open Names
open Termenv
open Tacmach
open Trad
open Reduction
open Tactics
open Proof_trees
open Environ
open Constants
open Constrtypes

let constant sp id = 
  Machops.global_reference (gLOB (initial_sign ())) (path_of_string sp) 
    (id_of_string id)


type xexpr =
    X_var of int
  | X_int of int
  | X_plus of xexpr * xexpr
  | X_mult of xexpr * xexpr
  | X_div of xexpr * xexpr * constr
  | X_zero
  | X_one
  | X_nat of int
  | X_inv of xexpr
  | X_minus of xexpr * xexpr
  | X_power of xexpr * int


let frational verbose g a =

  let cs_eq = constant "#CSetoids#cs_eq.cci" "cs_eq"
  and xexpr_var = constant "#Reflection#xexpr.cci" "xexpr_var"
  and xexpr_int = constant "#Reflection#xexpr.cci" "xexpr_int"
  and xexpr_plus = constant "#Reflection#xexpr.cci" "xexpr_plus"
  and xexpr_mult = constant "#Reflection#xexpr.cci" "xexpr_mult"
  and xexpr_div = constant "#Reflection#xexpr.cci" "xexpr_div"
  and xexpr_zero = constant "#Reflection#xexpr.cci" "xexpr_zero"
  and xexpr_one = constant "#Reflection#xexpr.cci" "xexpr_one"
  and xexpr_nat = constant "#Reflection#xexpr.cci" "xexpr_nat"
  and xexpr_inv = constant "#Reflection#xexpr.cci" "xexpr_inv"
  and xexpr_minus = constant "#Reflection#xexpr.cci" "xexpr_minus"
  and xexpr_power = constant "#Reflection#xexpr.cci" "xexpr_power"
  and nat_nat = constant "#Datatypes#nat.cci" "nat"
  and nat_O = constant "#Datatypes#nat.cci" "O"
  and nat_S = constant "#Datatypes#nat.cci" "S"
  and csf_fun = constant "#CSetoids#csf_fun.cci" "csf_fun"
  and csbf_fun = constant "#CSetoids#csbf_fun.cci" "csbf_fun"
  and csg_unit = constant "#CSemiGroups#csg_unit.cci" "csg_unit"
  and cr_one = constant "#CRings#cr_one.cci" "cr_one"
  and nring = constant "#CRings#nring.cci" "nring"
  and zring = constant "#CRings#zring.cci" "zring"
  and csg_op = constant "#CSemiGroups#csg_op.cci" "csg_op"
  and cg_inv = constant "#CGroups#cg_inv.cci" "cg_inv"
  and cg_minus = constant "#CGroups#cg_minus.cci" "cg_minus"
  and cr_mult = constant "#CRings#cr_mult.cci" "cr_mult"
  and cf_div = constant "#CFields#cf_div.cci" "cf_div"
  and nzpro = constant "#CRings#nzpro.cci" "nzpro"
  and nexp_op = constant "#CRings#nexp_op.cci" "nexp_op"
  and xforget = constant "#Reflection#xforget.cci" "xforget"
  and expr_minus = constant "#Reflection#expr_minus.cci" "expr_minus"
  and tactic_lemma = constant "#Refl_corr#Tactic_lemma.cci"
		       "Tactic_lemma"
  and true_I = constant "#Logic#True.cci" "I"
  and norm = constant "#Refl_corr#Norm.cci" "Norm"
  and pos_xI = constant "#fast_integer#positive.cci" "xI"
  and pos_xO = constant "#fast_integer#positive.cci" "xO"
  and pos_xH = constant "#fast_integer#positive.cci" "xH"
  and int_ZERO = constant "#fast_integer#Z.cci" "ZERO"
  and int_POS = constant "#fast_integer#Z.cci" "POS"
  and int_NEG = constant "#fast_integer#Z.cci" "NEG"

  and csg_crr = constant "#CSemiGroups#csg_crr.cci" "csg_crr"
  and cm_crr = constant "#CMonoids#cm_crr.cci" "cm_crr"
  and cg_crr = constant "#CGroups#cg_crr.cci" "cg_crr"
  and cr_crr = constant "#CRings#cr_crr.cci" "cr_crr"
  and cf_crr = constant "#CFields#cf_crr.cci" "cf_crr" in
    
  let rec evalnat n =
    if eq_constr n nat_O then 0
    else if isAppL n & eq_constr (hd_app n) nat_S then
      let a = args_app n in
	if Array.length a > 0 then (evalnat a.(0)) + 1
	else raise (Failure "evalnat")
    else raise (Failure "evalnat") in

  let rec evalpos n =
    if eq_constr n pos_xH then 1
    else if isAppL n then
      let f = hd_app n
      and a = args_app n in
	if Array.length a > 0 then
	  if eq_constr f pos_xI then 2 * (evalpos a.(0)) + 1
	  else if eq_constr f pos_xO then 2 * (evalpos a.(0))
	  else raise (Failure "evalint")
	else raise (Failure "evalint")
    else raise (Failure "evalint") in

  let rec evalint n =
    if eq_constr n int_ZERO then 0
    else if isAppL n then
      let f = hd_app n
      and a = args_app n in
	if Array.length a > 0 then
	  if eq_constr f int_POS then evalpos a.(0)
	  else if eq_constr f int_NEG then -(evalpos a.(0))
	  else raise (Failure "evalint")
	else raise (Failure "evalint")
    else raise (Failure "evalint") in
    
  let rec envindex : constr * constr list -> int * constr list =
    function (x,e) ->
      match e with
	  [] -> (0,[x])
	| y::f ->
	    if eq_constr x y then (0, e) else
	      let (i,g) = envindex (x,f) in
		(i + 1, y::g) in
    
  let whd_nzpro c =
    if isAppL c & eq_constr (hd_app c) nzpro then c else
      let sp = path_of_string "#CRings#nzpro.cci" in
      let (_,cb) = const_of_path sp in
      let old_cONSTOPAQUE = cb.cONSTOPAQUE in
	cb.cONSTOPAQUE <- true;
	let d = pf_whd_betadeltaiota g c in
	  cb.cONSTOPAQUE <- old_cONSTOPAQUE;
	  d in
    
  let lift_var : constr * constr list -> xexpr * constr list =
    function (x,e) -> let (i,f) = envindex (x,e) in (X_var i, f) in

  let rec lift : constr * constr list -> xexpr * constr list =
    function (x,e) ->
      if isAppL x then
	let f = hd_app x
	and a = args_app x in
	  if eq_constr f csg_unit then (X_zero, e)
	  else if eq_constr f cr_one then (X_one, e)
	  else if eq_constr f nring & Array.length a > 1 then
	    try (X_nat(evalnat a.(1)), e)
	    with Failure "evalnat" -> lift_var (x,e)
	  else if eq_constr f zring & Array.length a > 1 then
	    try (X_int(evalint a.(1)), e)
	    with Failure "evalint" -> lift_var (x,e)
	  else if eq_constr f csbf_fun then
	    if Array.length a > 5
	    then let g = hd_app a.(3) in
                 if eq_constr g csg_op
		 then
		   let (t1,e1) = lift (a.(4),e) in
		   let (t2,e2) = lift (a.(5),e1) in
		   (X_plus(t1,t2), e2)
		 else if eq_constr g cr_mult
	              then
		        let (t1,e1) = lift (a.(4),e) in
		        let (t2,e2) = lift (a.(5),e1) in
			(X_mult(t1,t2), e2)
		      else lift_var (x,e)
            else lift_var (x,e)
	  else if eq_constr f csf_fun then
	    if Array.length a > 3 & isAppL a.(2) then
	      let g = hd_app a.(2) in
	      let b = args_app a.(2) in
		if eq_constr g cg_inv then
		  let (t1,e1) = lift (a.(3),e) in
		    (X_inv(t1), e1)
		else if eq_constr g nexp_op & Array.length b > 1 then
		  try
		    let n = evalnat b.(1) in
		    let (t1,e1) = lift (a.(3),e) in
		      (X_power(t1,n), e1)
		  with Failure "evalnat" -> lift_var (x,e)
		else lift_var (x,e)
	    else lift_var (x,e)
	  else if eq_constr f cg_minus then
	    if Array.length a > 2 then
	      let (t1,e1) = lift (a.(1),e) in
	      let (t2,e2) = lift (a.(2),e1) in
		(X_minus(t1,t2), e2)
	    else lift_var (x,e)
	  else if eq_constr f cf_div then
	    if Array.length a > 2 then
	      let a2 = whd_nzpro a.(2) in
		if isAppL a2 & eq_constr (hd_app a2) nzpro
		then
		  let b = args_app a2 in
		    if Array.length b > 2 then
		      let (t1,e1) = lift (a.(1),e) in
		      let (t2,e2) = lift (b.(1),e1) in
			(X_div(t1,t2,b.(2)), e2)
		    else lift_var (x,e)
		else lift_var (x,e)
	    else lift_var (x,e)
	  else if isAppL f then
	    lift ((collapse_appl x), e)
	  else lift_var (x,e)
      else lift_var (x,e) in

  let rec natconstr i =
    if i > 0 then mkAppL [| nat_S; natconstr (i - 1) |] else nat_O in

  let rec posconstr k =
    if k == 1 then pos_xH else
      let l = k mod 2 in
	mkAppL [| if l == 0 then pos_xO else pos_xI; posconstr (k / 2) |] in

  let rec intconstr k =
    if k == 0 then int_ZERO else
    if k > 0 then mkAppL [| int_POS; posconstr k |] else
      mkAppL [| int_NEG; posconstr (- k) |] in
    
  let rec xexprconstr t rho =
    match t with
	X_var i -> mkAppL [| xexpr_var; mkExistential; rho; natconstr i |]
      | X_int i -> mkAppL [| xexpr_int; mkExistential; rho; intconstr i |]
      | X_plus (t1,t2) ->
	  mkAppL [| xexpr_plus; mkExistential; rho;
		    mkExistential; mkExistential;
		    xexprconstr t1 rho; xexprconstr t2 rho |]
      | X_mult (t1,t2) ->
	  mkAppL [| xexpr_mult; mkExistential; rho;
		    mkExistential; mkExistential;
		    xexprconstr t1 rho; xexprconstr t2 rho |]
      | X_div (t1,t2,nz) ->
	  mkAppL [| xexpr_div; mkExistential; rho;
		    mkExistential; mkExistential;
		    xexprconstr t1 rho; xexprconstr t2 rho; nz |]
      | X_zero ->
	  mkAppL [| xexpr_zero; mkExistential; rho |]
      | X_one ->
	  mkAppL [| xexpr_one; mkExistential; rho |]
      | X_nat i ->
	  mkAppL [| xexpr_nat; mkExistential; rho; natconstr i |]
      | X_inv (t1) ->
	  mkAppL [| xexpr_inv; mkExistential; rho;
		    mkExistential;
		    xexprconstr t1 rho; |]
      | X_minus (t1,t2) ->
	  mkAppL [| xexpr_minus; mkExistential; rho;
		    mkExistential; mkExistential;
		    xexprconstr t1 rho; xexprconstr t2 rho |]
      | X_power (t1,n) ->
	  mkAppL [| xexpr_power; mkExistential; rho;
		    mkExistential;
		    xexprconstr t1 rho; natconstr n |] in
    
  let rec valconstr e ta =
    match e with
	[] -> mkLambda Anonymous nat_nat
	    (mkCast (mkAppL [| csg_unit; mkExistential |]) ta)
      | [c] -> mkLambda Anonymous nat_nat c
      | c::f -> mkLambda (Name (id_of_string "n")) nat_nat
	    (mkMutCase (Some (path_of_string "#Datatypes#nat.cci", 0))
	       ta (mkRel 1) [ c; valconstr f ta ]) in
    
  let solve_isevars g t =
    ise_resolve1 false (project g) (gLOB (pf_hyps g)) t in

  let rec printval i e =
    match e with
	[] -> ()
      | c::f ->
	  mSGNL [< 'sTR "("; 'iNT i; 'sTR ") -> "; prterm c >];
	  printval (i + 1) f in

  let report g f a xleft xright =
    (let left =
       nf_betadeltaiota (project g)
	 (solve_isevars g
	    (mkAppL
	       [| xforget;
		  mkExistential; mkExistential; mkExistential;
		  xleft |]))
     and right =
       nf_betadeltaiota (project g)
	 (solve_isevars g
	    (mkAppL
	       [| xforget;
		  mkExistential; mkExistential; mkExistential;
		  xright |])) in
     let nleft = (cbv_betadeltaiota (project g)
		    (mkAppL [| norm; left |]))
     and nright = (cbv_betadeltaiota (project g)
		     (mkAppL [| norm; right |])) in
     let difference =
       (cbv_betadeltaiota (project g)
	  (mkAppL [| norm;
		     (mkAppL [| expr_minus; left; right |]) |])) in
       mSGNL [< >]; printval 0 f; mSGNL [< >];
       mSGNL [< prterm a.(1) >];
       mSGNL [< prterm left >];
       mSGNL [< prterm nleft; 'fNL >];
       mSGNL [< prterm a.(2) >];
       mSGNL [< prterm right >];
       mSGNL [< prterm nright; 'fNL >];
       mSGNL [< prterm difference; 'fNL >] )
  in
    
  let cfield ta =
    if isAppL ta & eq_constr (hd_app ta) csg_crr then
      let ta1 = (args_app ta).(0) in
	if isAppL ta1 & eq_constr (hd_app ta1) cm_crr then
	  let ta2 = (args_app ta1).(0) in
	    if isAppL ta2 & eq_constr (hd_app ta2) cg_crr then
	      let ta3 = (args_app ta2).(0) in
		if isAppL ta3 & eq_constr (hd_app ta3) cr_crr then
		  let ta4 = (args_app ta3).(0) in
		    if isAppL ta4 & eq_constr (hd_app ta4) cf_crr then
		      (args_app ta4).(0)
		    else raise (Failure "cfield")
		else raise (Failure "cfield")
	    else raise (Failure "cfield")
	else raise (Failure "cfield")
    else raise (Failure "cfield")
  in

  let cfield_check = cfield a.(0) in

  let ta = pf_type_of g a.(1) in
  let fleft = a.(1) and fright = a.(2) in
  let (l,e) = lift (fleft,[]) in
  let (r,f) = lift (fright,e) in
  let rho = solve_isevars g (valconstr f ta) in
  let xleft = solve_isevars g (xexprconstr l rho)
  and xright = solve_isevars g (xexprconstr r rho) in
    if verbose then
      report g f a xleft xright;
    let term =
      mkAppL [| mkAppL [| tactic_lemma; mkExistential; rho;
			  fleft; fright; xleft |]; xright; true_I |]
    in
      if verbose then mSGNL [< 'sTR "begin type check" >];
      let proof =
	try solve_isevars g term
	with _ ->
	  (* if not verbose then report g f a xleft xright; *)
	  error "cannot establish equality"
      in
	if verbose then mSGNL [< 'sTR "end type check" >];
	let result = exact proof g in
	  if verbose then mSGNL [< 'sTR "end Rational" >];
	  result


let rrational verbose g a =

  let cs_eq = constant "#CSetoids#cs_eq.cci" "cs_eq"
  and xexpr_var = constant "#RReflection#Rxexpr.cci" "Rxexpr_var"
  and xexpr_int = constant "#RReflection#Rxexpr.cci" "Rxexpr_int"
  and xexpr_plus = constant "#RReflection#Rxexpr.cci" "Rxexpr_plus"
  and xexpr_mult = constant "#RReflection#Rxexpr.cci" "Rxexpr_mult"
  and xexpr_zero = constant "#RReflection#Rxexpr.cci" "Rxexpr_zero"
  and xexpr_one = constant "#RReflection#Rxexpr.cci" "Rxexpr_one"
  and xexpr_nat = constant "#RReflection#Rxexpr.cci" "Rxexpr_nat"
  and xexpr_inv = constant "#RReflection#Rxexpr.cci" "Rxexpr_inv"
  and xexpr_minus = constant "#RReflection#Rxexpr.cci" "Rxexpr_minus"
  and xexpr_power = constant "#RReflection#Rxexpr.cci" "Rxexpr_power"
  and nat_nat = constant "#Datatypes#nat.cci" "nat"
  and nat_O = constant "#Datatypes#nat.cci" "O"
  and nat_S = constant "#Datatypes#nat.cci" "S"
  and csf_fun = constant "#CSetoids#csf_fun.cci" "csf_fun"
  and csbf_fun = constant "#CSetoids#csbf_fun.cci" "csbf_fun"
  and csg_unit = constant "#CSemiGroups#csg_unit.cci" "csg_unit"
  and cr_one = constant "#CRings#cr_one.cci" "cr_one"
  and nring = constant "#CRings#nring.cci" "nring"
  and zring = constant "#CRings#zring.cci" "zring"
  and csg_op = constant "#CSemiGroups#csg_op.cci" "csg_op"
  and cg_inv = constant "#CGroups#cg_inv.cci" "cg_inv"
  and cg_minus = constant "#CGroups#cg_minus.cci" "cg_minus"
  and cr_mult = constant "#CRings#cr_mult.cci" "cr_mult"
  and nzpro = constant "#CRings#nzpro.cci" "nzpro"
  and nexp_op = constant "#CRings#nexp_op.cci" "nexp_op"
  and xforget = constant "#RReflection#Rxforget.cci" "Rxforget"
  and expr_minus = constant "#RReflection#Rexpr_minus.cci" "Rexpr_minus"
  and tactic_lemma = constant "#RRefl_corr#RTactic_lemma.cci"
		       "RTactic_lemma"
  and true_I = constant "#Logic#True.cci" "I"
  and norm = constant "#RRefl_corr#RNorm.cci" "RNorm"
  and pos_xI = constant "#fast_integer#positive.cci" "xI"
  and pos_xO = constant "#fast_integer#positive.cci" "xO"
  and pos_xH = constant "#fast_integer#positive.cci" "xH"
  and int_ZERO = constant "#fast_integer#Z.cci" "ZERO"
  and int_POS = constant "#fast_integer#Z.cci" "POS"
  and int_NEG = constant "#fast_integer#Z.cci" "NEG" in
    
  let rec evalnat n =
    if eq_constr n nat_O then 0
    else if isAppL n & eq_constr (hd_app n) nat_S then
      let a = args_app n in
	if Array.length a > 0 then (evalnat a.(0)) + 1
	else raise (Failure "evalnat")
    else raise (Failure "evalnat") in

  let rec evalpos n =
    if eq_constr n pos_xH then 1
    else if isAppL n then
      let f = hd_app n
      and a = args_app n in
	if Array.length a > 0 then
	  if eq_constr f pos_xI then 2 * (evalpos a.(0)) + 1
	  else if eq_constr f pos_xO then 2 * (evalpos a.(0))
	  else raise (Failure "evalint")
	else raise (Failure "evalint")
    else raise (Failure "evalint") in

  let rec evalint n =
    if eq_constr n int_ZERO then 0
    else if isAppL n then
      let f = hd_app n
      and a = args_app n in
	if Array.length a > 0 then
	  if eq_constr f int_POS then evalpos a.(0)
	  else if eq_constr f int_NEG then -(evalpos a.(0))
	  else raise (Failure "evalint")
	else raise (Failure "evalint")
    else raise (Failure "evalint") in
    
  let rec envindex : constr * constr list -> int * constr list =
    function (x,e) ->
      match e with
	  [] -> (0,[x])
	| y::f ->
	    if eq_constr x y then (0, e) else
	      let (i,g) = envindex (x,f) in
		(i + 1, y::g) in
    
  let whd_nzpro c =
    if isAppL c & eq_constr (hd_app c) nzpro then c else
      let sp = path_of_string "#CRings#nzpro.cci" in
      let (_,cb) = const_of_path sp in
      let old_cONSTOPAQUE = cb.cONSTOPAQUE in
	cb.cONSTOPAQUE <- true;
	let d = pf_whd_betadeltaiota g c in
	  cb.cONSTOPAQUE <- old_cONSTOPAQUE;
	  d in
    
  let lift_var : constr * constr list -> xexpr * constr list =
    function (x,e) -> let (i,f) = envindex (x,e) in (X_var i, f) in

  let rec lift : constr * constr list -> xexpr * constr list =
    function (x,e) ->
      if isAppL x then
	let f = hd_app x
	and a = args_app x in
	  if eq_constr f csg_unit then (X_zero, e)
	  else if eq_constr f cr_one then (X_one, e)
	  else if eq_constr f nring & Array.length a > 1 then
	    try (X_nat(evalnat a.(1)), e)
	    with Failure "evalnat" -> lift_var (x,e)
	  else if eq_constr f zring & Array.length a > 1 then
	    try (X_int(evalint a.(1)), e)
	    with Failure "evalint" -> lift_var (x,e)
	  else if eq_constr f csbf_fun then
	    if Array.length a > 5
	    then let g = hd_app a.(3) in
                 if eq_constr g csg_op
		 then
		   let (t1,e1) = lift (a.(4),e) in
		   let (t2,e2) = lift (a.(5),e1) in
		   (X_plus(t1,t2), e2)
		 else if eq_constr g cr_mult
	              then
		        let (t1,e1) = lift (a.(4),e) in
		        let (t2,e2) = lift (a.(5),e1) in
			(X_mult(t1,t2), e2)
		      else lift_var (x,e)
            else lift_var (x,e)
	  else if eq_constr f csf_fun then
	    if Array.length a > 3 & isAppL a.(2) then
	      let g = hd_app a.(2) in
	      let b = args_app a.(2) in
		if eq_constr g cg_inv then
		  let (t1,e1) = lift (a.(3),e) in
		    (X_inv(t1), e1)
		else if eq_constr g nexp_op & Array.length b > 1 then
		  try
		    let n = evalnat b.(1) in
		    let (t1,e1) = lift (a.(3),e) in
		      (X_power(t1,n), e1)
		  with Failure "evalnat" -> lift_var (x,e)
		else lift_var (x,e)
	    else lift_var (x,e)
	  else if eq_constr f cg_minus then
	    if Array.length a > 2 then
	      let (t1,e1) = lift (a.(1),e) in
	      let (t2,e2) = lift (a.(2),e1) in
		(X_minus(t1,t2), e2)
	    else lift_var (x,e)
	  else if isAppL f then
	    lift ((collapse_appl x), e)
	  else lift_var (x,e)
      else lift_var (x,e) in

  let rec natconstr i =
    if i > 0 then mkAppL [| nat_S; natconstr (i - 1) |] else nat_O in

  let rec posconstr k =
    if k == 1 then pos_xH else
      let l = k mod 2 in
	mkAppL [| if l == 0 then pos_xO else pos_xI; posconstr (k / 2) |] in

  let rec intconstr k =
    if k == 0 then int_ZERO else
    if k > 0 then mkAppL [| int_POS; posconstr k |] else
      mkAppL [| int_NEG; posconstr (- k) |] in
    
  let rec xexprconstr t rho =
    match t with
	X_var i -> mkAppL [| xexpr_var; mkExistential; rho; natconstr i |]
      | X_int i -> mkAppL [| xexpr_int; mkExistential; rho; intconstr i |]
      | X_plus (t1,t2) ->
	  mkAppL [| xexpr_plus; mkExistential; rho;
		    mkExistential; mkExistential;
		    xexprconstr t1 rho; xexprconstr t2 rho |]
      | X_mult (t1,t2) ->
	  mkAppL [| xexpr_mult; mkExistential; rho;
		    mkExistential; mkExistential;
		    xexprconstr t1 rho; xexprconstr t2 rho |]
      | X_div (t1,t2,nz) -> raise (Failure "xexprconstr")
      | X_zero ->
	  mkAppL [| xexpr_zero; mkExistential; rho |]
      | X_one ->
	  mkAppL [| xexpr_one; mkExistential; rho |]
      | X_nat i ->
	  mkAppL [| xexpr_nat; mkExistential; rho; natconstr i |]
      | X_inv (t1) ->
	  mkAppL [| xexpr_inv; mkExistential; rho;
		    mkExistential;
		    xexprconstr t1 rho; |]
      | X_minus (t1,t2) ->
	  mkAppL [| xexpr_minus; mkExistential; rho;
		    mkExistential; mkExistential;
		    xexprconstr t1 rho; xexprconstr t2 rho |]
      | X_power (t1,n) ->
	  mkAppL [| xexpr_power; mkExistential; rho;
		    mkExistential;
		    xexprconstr t1 rho; natconstr n |] in
    
  let rec valconstr e ta =
    match e with
	[] -> mkLambda Anonymous nat_nat
	    (mkCast (mkAppL [| csg_unit; mkExistential |]) ta)
      | [c] -> mkLambda Anonymous nat_nat c
      | c::f -> mkLambda (Name (id_of_string "n")) nat_nat
	    (mkMutCase (Some (path_of_string "#Datatypes#nat.cci", 0))
	       ta (mkRel 1) [ c; valconstr f ta ]) in
    
  let solve_isevars g t =
    ise_resolve1 false (project g) (gLOB (pf_hyps g)) t in

  let rec printval i e =
    match e with
	[] -> ()
      | c::f ->
	  mSGNL [< 'sTR "("; 'iNT i; 'sTR ") -> "; prterm c >];
	  printval (i + 1) f in

  let report g f a xleft xright =
    (let left =
       nf_betadeltaiota (project g)
	 (solve_isevars g
	    (mkAppL
	       [| xforget;
		  mkExistential; mkExistential; mkExistential;
		  xleft |]))
     and right =
       nf_betadeltaiota (project g)
	 (solve_isevars g
	    (mkAppL
	       [| xforget;
		  mkExistential; mkExistential; mkExistential;
		  xright |])) in
     let nleft = (cbv_betadeltaiota (project g)
		    (mkAppL [| norm; left |]))
     and nright = (cbv_betadeltaiota (project g)
		     (mkAppL [| norm; right |])) in
     let difference =
       (cbv_betadeltaiota (project g)
	  (mkAppL [| norm;
		     (mkAppL [| expr_minus; left; right |]) |])) in
       mSGNL [< >]; printval 0 f; mSGNL [< >];
       mSGNL [< prterm a.(1) >];
       mSGNL [< prterm left >];
       mSGNL [< prterm nleft; 'fNL >];
       mSGNL [< prterm a.(2) >];
       mSGNL [< prterm right >];
       mSGNL [< prterm nright; 'fNL >];
       mSGNL [< prterm difference; 'fNL >] )
  in

  let ta = pf_type_of g a.(1) in
  let fleft = a.(1) and fright = a.(2) in
  let (l,e) = lift (fleft,[]) in
  let (r,f) = lift (fright,e) in
  let rho = solve_isevars g (valconstr f ta) in
  let xleft =
    try solve_isevars g (xexprconstr l rho)
    with _ -> error "not an equation over a CRing"
  and xright = solve_isevars g (xexprconstr r rho) in
    if verbose then
      report g f a xleft xright;
    let term =
      mkAppL [| mkAppL [| tactic_lemma; mkExistential; rho;
			  fleft; fright; xleft |]; xright; true_I |]
    in
      if verbose then mSGNL [< 'sTR "begin type check" >];
      let proof =
	try solve_isevars g term
	with _ ->
	  (* if not verbose then report g f a xleft xright; *)
	  error "cannot establish equality"
      in
	if verbose then mSGNL [< 'sTR "end type check" >];
	let result = exact proof g in
	  if verbose then mSGNL [< 'sTR "end Rational" >];
	  result
      
	    
let rational verbose g =

  let cs_eq = constant "#CSetoids#cs_eq.cci" "cs_eq" in

  let c = strip_outer_cast (pf_concl g) in
    if isAppL c & eq_constr (hd_app c) cs_eq then
      let a = args_app c in
	if Array.length a > 2 then
	  try frational verbose g a
	  with _ -> rrational verbose g a
	else error "not an [=] equation"
    else error "not an [=] equation"
      
let rational1 verbose =
  if verbose then mSGNL [< 'sTR "begin Rational" >];
  rational verbose
      
let _ =
  add_tactic "Rational"
    (function _ -> rational1 false);
  add_tactic "RationalV"
    (function _ -> rational1 true)


