(* This file demonstrates the implementation techniques behind Algebra        *)
(* Tactics by applying them to `zmodType`s (additive Abelian groups).         *)
(* This example is also described in the following paper:                     *)
(* Kazuhiko Sakaguchi. Reflexive tactics for algebra, revisited.              *)

From elpi Require Export elpi.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat choice seq.
From mathcomp Require Import fintype finfun bigop order ssralg ssrnum ssrint.
From mathcomp Require Import rat zify.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory.

Local Open Scope ring_scope.

Notation zeroz := (Posz 0).
Notation addz := intZmod.addz.
Notation oppz := intZmod.oppz.

(******************************************************************************)
(* Section 2.1                                                                *)
(******************************************************************************)

Module Section_2_1.

Structure eqType := { eq_sort : Type; eq_op : eq_sort -> eq_sort -> bool }.

Definition nat_eqType : eqType := {| eq_sort := nat; eq_op := eqn |}.

Fail Check eq_op 0%N 1%N.

Canonical nat_eqType.

Check eq_op 0%N 1%N.

Definition prod_eqType (T1 T2 : eqType) :=
  {| eq_sort := eq_sort T1 * eq_sort T2;
     eq_op := fun x y => eq_op x.1 y.1 && eq_op x.2 y.2 |}.

Fail Check eq_op (0, 0)%N (0, 1)%N.

Canonical prod_eqType.

Check eq_op (0, 0)%N (0, 1)%N.

Coercion eq_sort : eqType >-> Sortclass.

End Section_2_1.

(******************************************************************************)
(* Normalizing Z-module expressions to formal sums by reflection              *)
(******************************************************************************)

Inductive AGExpr : Type :=
  | AGX : nat -> AGExpr
  | AGO : AGExpr
  | AGOpp : AGExpr -> AGExpr
  | AGAdd : AGExpr -> AGExpr -> AGExpr.

Section AGeval.

Variables (V : Type) (zero : V) (opp : V -> V) (add : V -> V -> V).

Definition mulz (x : V) (n : int) :=
  match n with
    | Posz n => iterop n add x zero
    | Negz n => opp (iterop n.+1 add x zero)
  end.

Fixpoint AGeval (varmap : seq V) (e : AGExpr) : V :=
  match e with
    | AGX j => nth zero varmap j
    | AGO => zero
    | AGOpp e1 => opp (AGeval varmap e1)
    | AGAdd e1 e2 => add (AGeval varmap e1) (AGeval varmap e2)
  end.

Fixpoint AGnorm (e : AGExpr) : seq int :=
  match e with
    | AGX j => ncons j 0 [:: 1]
    | AGO => [::]
    | AGOpp e1 => map -%R (AGnorm e1)
    | AGAdd e1 e2 =>
      (fix add_rec (xs ys : seq int) : seq int :=
         match xs, ys with
           | [::], s | s, [::] => s
           | x :: xs, y :: ys => (x + y) :: add_rec xs ys
         end) (AGnorm e1) (AGnorm e2)
  end.

Definition AGsubst (varmap : seq V) (e : seq int) : V :=
  foldr (fun p n => add (mulz p.1 p.2) n) zero (zip varmap e).

End AGeval.

Lemma AG_norm_subst (V : zmodType) (varmap : seq V) (e : AGExpr) :
  AGsubst 0 -%R +%R varmap (AGnorm e) = AGeval 0 -%R +%R varmap e.
Proof.
rewrite /AGsubst -[mulz _ _ _]/*~%R.
elim: e => /= [j||e1 <-|e1 <- e2 <-].
- elim: j varmap => [|j IHj] [|x varmap] //=.
    by case: varmap => [|? ?]; rewrite /AGsubst /= mulr1z addr0.
  by rewrite /AGsubst /= mulr0z add0r; exact: IHj.
- by case: varmap.
- by elim: (AGnorm e1) varmap => [|x xs IHxs] [|v varmap];
  rewrite /AGsubst /= ?oppr0 // opprD -IHxs raddfN.
- move: (AGnorm e1) (AGnorm e2) varmap.
  elim=> [|x xs IHxs] [|y ys] [|v varmap];
    rewrite /AGsubst /= ?(add0r, addr0) //.
  by rewrite addrACA -IHxs raddfD.
Qed.

Lemma AG_correct (V : zmodType) (varmap : seq V) (e1 e2 : AGExpr) :
  all (fun i => i == 0) (AGnorm (AGAdd e1 (AGOpp e2))) = true ->
  AGeval 0 -%R +%R varmap e1 = AGeval 0 -%R +%R varmap e2.
Proof.
rewrite -!AG_norm_subst /AGsubst -[mulz _ _ _]/*~%R /=.
move: (AGnorm e1) (AGnorm e2) varmap.
elim=> [|x xs IH] [|y ys] [|v varmap] //=.
- rewrite oppr_eq0 => /andP[/eqP ->] /=; rewrite mulr0z add0r.
  elim: ys varmap => [|{}y ys IH] [|{}v varmap] //=.
  by rewrite oppr_eq0 => /andP[/eqP -> /IH <-]; rewrite mulr0z add0r.
- move=> /andP[/eqP ->] /=; rewrite mulr0z add0r.
  elim: xs varmap {IH} => [|{}x xs IH] [|{}v varmap] //=.
  by move=> /andP[/eqP -> /IH ->]; rewrite mulr0z add0r.
- by rewrite subr_eq0 => /andP[/eqP -> /IH] ->.
Qed.

Lemma int_norm_subst (varmap : seq int) (e : AGExpr) :
  AGsubst zeroz oppz addz varmap (AGnorm e) =
  AGeval zeroz oppz addz varmap e.
Proof. exact: AG_norm_subst. Qed.

Lemma int_correct (varmap : seq int) (e1 e2 : AGExpr) :
  all (fun i => i == zeroz) (AGnorm (AGAdd e1 (AGOpp e2))) = true ->
  AGeval zeroz oppz addz varmap e1 = AGeval zeroz oppz addz varmap e2.
Proof. exact: AG_correct. Qed.

(******************************************************************************)
(* Section 2.3 and 2.4                                                        *)
(******************************************************************************)

Ltac int_zmodule_reflection VarMap ZE1 ZE2 :=
  apply: (@int_correct VarMap ZE1 ZE2); [vm_compute; reflexivity].

Elpi Tactic int_zmodule.
Elpi Accumulate lp:{{

pred list-constant o:term, o:list term, o:term.
list-constant T [] {{ @nil lp:T }} :- !.
list-constant T [X|XS] {{ @cons lp:T lp:X lp:XS' }} :- list-constant T XS XS'.

% [quote In Out VarMap]
pred quote i:term, o:term, o:list term.
quote {{ zeroz }} {{ AGO }} _ :- !.
quote {{ oppz lp:In1 }} {{ AGOpp lp:Out1 }} VarMap :- !,
  quote In1 Out1 VarMap.
quote {{ addz lp:In1 lp:In2 }} {{ AGAdd lp:Out1 lp:Out2 }} VarMap :- !,
  quote In1 Out1 VarMap, quote In2 Out2 VarMap.
quote In {{ AGX lp:N }} VarMap :- !, mem VarMap In N.

pred mem o:list term, o:term, o:term.
mem [X|_] X {{ O }} :- !.
mem [_|XS] X {{ S lp:N }} :- !, mem XS X N.

pred close o:list term.
close [] :- !.
close [_|XS] :- close XS.

pred zmod-reflection i:term, i:term, i:term, i:goal, o:list sealed-goal.
zmod-reflection VarMap ZE1 ZE2 G GS :-
  coq.ltac.call "int_zmodule_reflection" [trm VarMap, trm ZE1, trm ZE2] G GS.
zmod-reflection VarMap ZE1 ZE2 _ _ :-
  coq.ltac.fail 0 "Not a valid Z-module equation" VarMap ZE1 ZE2.

pred solve i:goal, o:list sealed-goal.
solve (goal _ _ {{ @eq int lp:T1 lp:T2 }} _ _ as G) GS :-
  quote T1 ZE1 VarMap, !,
  quote T2 ZE2 VarMap, !,
  close VarMap, !,
  list-constant {{ int }} VarMap VarMap', !,
  zmod-reflection VarMap' ZE1 ZE2 G GS.
solve G _ :- coq.ltac.fail 0 "The goal is not an integer equation" G.

}}.
Elpi Typecheck.

Section Examples.

Local Open Scope int_scope.

Local Notation "0" := (Posz O) : int_scope.
Local Notation "- x" := (oppz x%Z) : int_scope.
Local Notation "x + y" := (addz x%Z y%Z) : int_scope.

Goal forall (x y : int), (x + (- y)) + x = (- y) + (x + x).
Proof.
move=> x y.
exact:
(let e1 := AGAdd (AGAdd (AGX 0) (AGOpp (AGX 1))) (AGX 0) in
 let e2 := AGAdd (AGOpp (AGX 1)) (AGAdd (AGX 0) (AGX 0)) in
 @int_correct [:: x; y] e1 e2 erefl).
Restart.
move=> x y.
elpi int_zmodule.
Qed.

End Examples.

(******************************************************************************)
(* Section 3.1                                                                *)
(******************************************************************************)

Ltac poly_zmodule_reflection V VarMap ZE1 ZE2 :=
  apply: (@AG_correct V VarMap ZE1 ZE2); [vm_compute; reflexivity].

Elpi Tactic fail_zmodule.
Elpi Accumulate lp:{{

pred list-constant o:term, o:list term, o:term.
list-constant T [] {{ @nil lp:T }} :- !.
list-constant T [X|XS] {{ @cons lp:T lp:X lp:XS' }} :- list-constant T XS XS'.

% [quote V In Out VarMap]
pred quote i:term, i:term, o:term, o:list term.
quote V {{ @GRing.zero lp:V }} {{ AGO }} _ :- !.
quote V {{ @GRing.opp lp:V lp:In1 }} {{ AGOpp lp:Out1 }} VarMap :- !,
  quote V In1 Out1 VarMap.
quote V {{ @GRing.add lp:V lp:In1 lp:In2 }} {{ AGAdd lp:Out1 lp:Out2 }} VarMap :- !,
  quote V In1 Out1 VarMap, quote V In2 Out2 VarMap.
quote _ In {{ AGX lp:N }} VarMap :- !, mem VarMap In N.

pred mem o:list term, o:term, o:term.
mem [X|_] X {{ O }} :- !.
mem [_|XS] X {{ S lp:N }} :- !, mem XS X N.

pred close o:list term.
close [] :- !.
close [_|XS] :- close XS.

pred zmod-reflection i:term, i:term, i:term, i:term, i:goal, o:list sealed-goal.
zmod-reflection V VarMap ZE1 ZE2 G GS :-
  coq.ltac.call "poly_zmodule_reflection"
    [trm V, trm VarMap, trm ZE1, trm ZE2] G GS.
zmod-reflection _ _ _ _ _ _ :-
  coq.ltac.fail 0 "Not a valid Z-module equation".

pred solve i:goal, o:list sealed-goal.
solve (goal _ _ {{ @eq lp:Ty lp:T1 lp:T2 }} _ [trm V] as G) GS :-
  @ltacfail! 0 => std.assert-ok!
    (coq.unify-eq {{ GRing.Zmodule.sort lp:V }} Ty)
    "The goal is not an equation of the given Z-module", !,
  quote V T1 ZE1 VarMap, !,
  quote V T2 ZE2 VarMap, !,
  close VarMap, !,
  list-constant Ty VarMap VarMap', !,
  zmod-reflection V VarMap' ZE1 ZE2 G GS.
solve G _ :- coq.ltac.fail 0 "The goal is not an equation" G.

}}.
Elpi Typecheck.

Goal forall x y : [zmodType of int * int], x + y + x = y + x + x.
Proof.
move=> x y.
elpi fail_zmodule ([zmodType of int * int]).
Qed.

Goal forall x : int, x + 1 = 1 + x.
Proof.
Fail elpi fail_zmodule (int_ZmodType).
Abort.

(******************************************************************************)
(* Section 3.2                                                                *)
(******************************************************************************)

Elpi Tactic poly_zmodule.
Elpi Accumulate lp:{{

pred list-constant o:term, o:list term, o:term.
list-constant T [] {{ @nil lp:T }} :- !.
list-constant T [X|XS] {{ @cons lp:T lp:X lp:XS' }} :- list-constant T XS XS'.

% [quote V In Out VarMap]
pred quote i:term, i:term, o:term, o:list term.
quote V {{ @GRing.zero lp:V' }} {{ AGO }} _ :- coq.unify-eq V V' ok, !.
quote V {{ @GRing.opp lp:V' lp:In1 }} {{ AGOpp lp:Out1 }} VarMap :-
  coq.unify-eq V V' ok, !, quote V In1 Out1 VarMap.
quote V {{ @GRing.add lp:V' lp:In1 lp:In2 }} {{ AGAdd lp:Out1 lp:Out2 }} VarMap :-
  coq.unify-eq V V' ok, !, quote V In1 Out1 VarMap, quote V In2 Out2 VarMap.
quote _ In {{ AGX lp:N }} VarMap :- !, mem VarMap In N.

pred mem o:list term, o:term, o:term.
mem [X|_] X {{ O }} :- !.
mem [_|XS] X {{ S lp:N }} :- !, mem XS X N.

pred close o:list term.
close [] :- !.
close [_|XS] :- close XS.

pred zmod-reflection i:term, i:term, i:term, i:term, i:goal, o:list sealed-goal.
zmod-reflection V VarMap ZE1 ZE2 G GS :-
  coq.ltac.call "poly_zmodule_reflection"
    [trm V, trm VarMap, trm ZE1, trm ZE2] G GS.
zmod-reflection _ _ _ _ _ _ :-
  coq.ltac.fail 0 "Not a valid Z-module equation".

pred solve i:goal, o:list sealed-goal.
solve (goal _ _ {{ @eq lp:Ty lp:T1 lp:T2 }} _ _ as G) GS :-
  @ltacfail! 0 => std.assert-ok!
    (coq.unify-eq {{ GRing.Zmodule.sort lp:V }} Ty)
    "Cannot find a declared Z-module", !,
  quote V T1 ZE1 VarMap, !,
  quote V T2 ZE2 VarMap, !,
  close VarMap, !,
  list-constant Ty VarMap VarMap', !,
  zmod-reflection V VarMap' ZE1 ZE2 G GS.
solve G _ :- coq.ltac.fail 0 "The goal is not a Z-module equation" G.

}}.
Elpi Typecheck.

Goal forall (x y : int * int), x + y + x = y + x + x.
Proof.
move=> x y.
elpi poly_zmodule.
Qed.

Goal forall x : int, x + 1 = 1 + x.
Proof.
move=> x.
elpi poly_zmodule.
Qed.

(******************************************************************************)
(* Section 4                                                                  *)
(******************************************************************************)

Module Type ZmodSubSig.
Parameter subr : forall U : zmodType, U -> U -> U.
Axiom subrE : subr = (fun _ x y => x + - y).
End ZmodSubSig.

Module Import ZmodSub : ZmodSubSig.
Definition subr (U : zmodType) (x y : U) := x - y.
Definition subrE := erefl subr.
End ZmodSub.

Implicit Types (U V : zmodType).

Inductive MExpr : zmodType -> Type :=
  | MX V : V -> MExpr V
  | MO V : MExpr V
  | MOpp V : MExpr V -> MExpr V
  | MAdd V : MExpr V -> MExpr V -> MExpr V
  | MSub V : MExpr V -> MExpr V -> MExpr V
  | MMorph U V : {additive U -> V} -> MExpr U -> MExpr V.

Fixpoint Meval V (e : MExpr V) : V :=
  match e with
    | MX _ x => x
    | MO _ => 0
    | MOpp _ e1 => - Meval e1
    | MAdd _ e1 e2 => Meval e1 + Meval e2
    | MSub _ e1 e2 => subr (Meval e1) (Meval e2)
    | MMorph _ _ f e1 => f (Meval e1)
  end.

Fixpoint Mnorm U V (f : {additive U -> V}) (e : MExpr U) : V :=
  match e in MExpr U return {additive U -> V} -> V with
    | MX _ x => fun f => f x
    | MO _ => fun _ => 0
    | MOpp _ e1 => fun f => - Mnorm f e1
    | MAdd _ e1 e2 => fun f => Mnorm f e1 + Mnorm f e2
    | MSub _ e1 e2 => fun f => Mnorm f e1 + (- Mnorm f e2)
    | MMorph _ _ g e1 => fun f => Mnorm [additive of f \o g] e1
  end f.

Lemma M_correct_rec U V (f : {additive U -> V}) (e : MExpr U) :
  f (Meval e) = Mnorm f e.
Proof.
elim: e V f => //= {U}.
- by move=> U V f; rewrite raddf0.
- by move=> U e1 IHe1 V f; rewrite raddfN IHe1.
- by move=> U e1 IHe1 e2 IHe2 V f; rewrite raddfD IHe1 IHe2.
- by move=> U e1 IHe1 e2 IHe2 V f; rewrite subrE raddfB IHe1 IHe2.
- by move=> U U' g e1 IHe1 V f; rewrite -IHe1.
Qed.

Lemma M_correct V (e : MExpr V) : Meval e = Mnorm [additive of idfun] e.
Proof. exact: M_correct_rec [additive of idfun] _. Qed.

Ltac morph_zmodule_reflection V VarMap ME1 ME2 ZE1 ZE2 :=
  rewrite [LHS](@M_correct V ME1) [RHS](@M_correct V ME2);
  apply: (@AG_correct V VarMap ZE1 ZE2);
  [vm_compute; reflexivity].

Elpi Tactic morph_zmodule.
Elpi Accumulate lp:{{

pred list-constant o:term, o:list term, o:term.
list-constant T [] {{ @nil lp:T }} :- !.
list-constant T [X|XS] {{ @cons lp:T lp:X lp:XS' }} :- list-constant T XS XS'.

% [quote V F In OutM Out VarMap]
pred quote i:term, i:(term -> term), i:term, o:term, o:term, o:list term.
quote V _ {{ @GRing.zero lp:V' }} {{ MO lp:V }} {{ AGO }} _ :-
  coq.unify-eq V V' ok, !.
quote V F {{ @GRing.opp lp:V' lp:In1 }}
      {{ @MOpp lp:V lp:OutM1 }} {{ AGOpp lp:Out1 }} VarMap :-
  coq.unify-eq V V' ok, !, quote V F In1 OutM1 Out1 VarMap.
quote V F {{ @GRing.add lp:V' lp:In1 lp:In2 }}
      {{ @MAdd lp:V lp:OutM1 lp:OutM2 }} {{ AGAdd lp:Out1 lp:Out2 }} VarMap :-
  coq.unify-eq V V' ok, !,
  quote V F In1 OutM1 Out1 VarMap, quote V F In2 OutM2 Out2 VarMap.
quote V F {{ @subr lp:V' lp:In1 lp:In2 }}
      {{ @MSub lp:V lp:OutM1 lp:OutM2 }} {{ AGAdd lp:Out1 (AGOpp lp:Out2) }}
      VarMap :-
  coq.unify-eq V V' ok, !,
  quote V F In1 OutM1 Out1 VarMap, quote V F In2 OutM2 Out2 VarMap.
quote V F In {{ @MMorph lp:U lp:V lp:G lp:OutM }} Out VarMap :-
  coq.unify-eq {{ @GRing.Additive.apply lp:U lp:V lp:Ph lp:G lp:In1 }} In ok, !,
  quote U (x\ F {{ @GRing.Additive.apply lp:U lp:V lp:Ph lp:G lp:x }})
        In1 OutM Out VarMap.
quote V F In {{ @MX lp:V lp:In }} {{ AGX lp:N }} VarMap :- !,
  mem VarMap (F In) N.

pred mem o:list term, o:term, o:term.
mem [X|_] X {{ O }} :- !.
mem [_|XS] X {{ S lp:N }} :- !, mem XS X N.

pred close o:list term.
close [] :- !.
close [_|XS] :- close XS.

pred zmod-reflection i:term, i:term, i:term, i:term, i:term, i:term,
                     i:goal, o:list sealed-goal.
zmod-reflection V VarMap ZM1 ZM2 ZE1 ZE2 G GS :-
  coq.ltac.call "morph_zmodule_reflection"
    [trm V, trm VarMap, trm ZM1, trm ZM2, trm ZE1, trm ZE2] G GS.
zmod-reflection _ _ _ _ _ _ _ _ :-
  coq.ltac.fail 0 "Not a valid Z-module equation".

pred solve i:goal, o:list sealed-goal.
solve (goal _ _ {{ @eq lp:Ty lp:T1 lp:T2 }} _ _ as G) GS :-
  @ltacfail! 0 => std.assert-ok!
    (coq.unify-eq {{ GRing.Zmodule.sort lp:V }} Ty)
    "Cannot find a declared zmodType", !,
  quote V (x\ x) T1 ZM1 ZE1 VarMap, !,
  quote V (x\ x) T2 ZM2 ZE2 VarMap, !,
  close VarMap, !,
  list-constant Ty VarMap VarMap', !,
  zmod-reflection V VarMap' ZM1 ZM2 ZE1 ZE2 G GS.
solve G _ :- coq.ltac.fail 0 "The goal is not a Z-module equation" G.

}}.
Elpi Typecheck.

Goal forall (x y : int), (x + y)%:~R + x%:~R = (y + x + x)%:~R :> rat.
Proof.
move=> x y.
elpi morph_zmodule.
Qed.

Goal forall (x y : int), (- subr x y)%:~R = y%:~R - x%:~R :> rat.
Proof.
move=> x y.
elpi morph_zmodule.
Qed.

(******************************************************************************)
(* Section 5.2                                                                *)
(******************************************************************************)

Section ZifyRing.

Variable R : ringType.

Structure zifyRing :=
  ZifyRing { rval : R; zval : int; zifyRingE : rval = zval%:~R }.

Canonical zify_zero := @ZifyRing 0 0 (erefl : 0 = 0%:~R).
Canonical zify_one  := @ZifyRing 1 1 (erefl : 1 = 1%:~R).

Lemma zify_opp_subproof e1 : - rval e1 = (- zval e1)%:~R.
Proof. by rewrite zifyRingE mulrNz. Qed.

Canonical zify_opp e1 :=
  @ZifyRing (- rval e1) (- zval e1) (zify_opp_subproof e1).

Lemma zify_add_subproof e1 e2 : rval e1 + rval e2 = (zval e1 + zval e2)%:~R.
Proof. by rewrite 2!zifyRingE intrD. Qed.

Canonical zify_add e1 e2 :=
  @ZifyRing (rval e1 + rval e2) (zval e1 + zval e2) (zify_add_subproof e1 e2).

Lemma zify_mulrz_subproof e1 n : rval e1 *~ n = (zval e1 *~ n)%:~R.
Proof. by rewrite zifyRingE -mulrzA -mulrzz. Qed.

Canonical zify_mulrn e1 n :=
  @ZifyRing (rval e1 *+ n) (zval e1 *+ n) (zify_mulrz_subproof e1 n).

Canonical zify_mulrz e1 n :=
  @ZifyRing (rval e1 *~ n) (zval e1 *~ n) (zify_mulrz_subproof e1 n).

Lemma zify_mul_subproof e1 e2 : rval e1 * rval e2 = (zval e1 * zval e2)%:~R.
Proof. by rewrite 2!zifyRingE intrM. Qed.

Canonical zify_mul e1 e2 :=
  @ZifyRing (rval e1 * rval e2) (zval e1 * zval e2) (zify_mul_subproof e1 e2).

Goal False.
Proof.
move: (0%N) => n.
evar (e : zifyRing).
unify (rval ?e) (1 + n%:~R *+ 2 : R).
Abort.

End ZifyRing.

Lemma zify_eqb (R : numDomainType) (e1 e2 : zifyRing R) :
  (rval e1 == rval e2) = (zval e1 == zval e2).
Proof. by rewrite 2!zifyRingE eqr_int. Qed.

Goal forall n : int, n%:~R *+ 2 + 1 != 0 :> rat.
Proof. move=> n; rewrite zify_eqb /=; lia. Qed.


Require Import Coq.Setoids.Setoid.
Require Import Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.Tactics.DestructHead.

Local Ltac t :=
  repeat first [ progress destruct_head'_ex
               | progress destruct_head'_and
               | progress intros
               | progress subst
               | assumption
               | progress repeat esplit ].

Lemma ex_and_eq_l_iff {A P x}
  : (exists y : A, y = x /\ P y) <-> P x.
Proof. t. Qed.

Lemma ex_and_eq_r_iff {A P x}
  : (exists y : A, x = y /\ P y) <-> P x.
Proof. t. Qed.

Lemma ex_eq_and_l_iff {A P x}
  : (exists y : A, P y /\ y = x) <-> P x.
Proof. t. Qed.

Lemma ex_eq_and_r_iff {A P x}
  : (exists y : A, P y /\ x = y) <-> P x.
Proof. t. Qed.

Ltac ex_eq_and_step :=
  let rew lem := (rewrite lem || setoid_rewrite lem) in
  let rew_in lem H := (rewrite lem in H || setoid_rewrite lem in H) in
  match goal with
  | [ |- context[exists y, _ = y /\ _] ]
    => rew (@ex_and_eq_r_iff)
  | [ |- context[exists y, y = _ /\ _] ]
    => rew (@ex_and_eq_l_iff)
  | [ |- context[exists y, _ /\ _ = y] ]
    => rew (@ex_eq_and_r_iff)
  | [ |- context[exists y, _ /\ y = _] ]
    => rew (@ex_eq_and_l_iff)
  | [ H : context[exists y, _ = y /\ _] |- _ ]
    => rew_in (@ex_and_eq_r_iff) H
  | [ H : context[exists y, y = _ /\ _] |- _ ]
    => rew_in (@ex_and_eq_l_iff) H
  | [ H : context[exists y, _ /\ _ = y] |- _ ]
    => rew_in (@ex_eq_and_r_iff) H
  | [ H : context[exists y, _ /\ y = _] |- _ ]
    => rew_in (@ex_eq_and_l_iff) H
  end.

Ltac ex_eq_and := repeat ex_eq_and_step.


Require Import Tactical.Propositional.

Module DeexTests.

  Theorem chooses_name :
    (exists (foo:unit), foo=foo) ->
    True.
  Proof.
    intros.
    deex.
    destruct foo.
    trivial.
  Qed.

  Theorem chooses_fresh_name :
    forall (foo:bool),
      (exists (foo:unit), foo=foo) -> True.
  Proof.
    intros.
    deex.
    (* fresh name for exists witness *)
    destruct foo0.
    trivial.
  Qed.

End DeexTests.


Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Contextual Implicit.

From Coq Require Import
     Relation_Definitions
     RelationClasses
.

Require Import GHC.Base.
Require Import Fix.
Require Import Tactics.Tactics.

Require Import ClassesOfFunctors.FunctorPlus.
Require Import Adverb.Composable.Nondeterministically.

Section EqFplusLaws.

Variable D : (Set -> Set) -> Set -> Set.
Context `{ReifiedPlus -≪ D} `{Functor1 D}.
Context `{Functor (Fix1 D)}.

Variant EqFplusLaws
        (Kr : forall (A : Set), relation (Fix1 D A))
        {A : Set} : relation (Fix1 D A) :=
| EqFplusComm : forall (a b : Fix1 D A),
    EqFplusLaws Kr (fplus a b) (fplus b a)
| EqFplusAssoc : forall (a b c : Fix1 D A),
    EqFplusLaws Kr (fplus (fplus a b) c) (fplus a (fplus b c)).

Global Instance FunctorRel__EqNondeterministically
  : FunctorRel (F:=Fix1 D) (@EqFplusLaws).
constructor. intros. destruct H3; constructor; assumption.
Qed.

End EqFplusLaws.

Section EqFplusLaws_SmartConstructors.

Variable D : (Set -> Set) -> Set -> Set.
Context `{ReifiedPlus -≪ D} `{Functor1 D}.
Context `{Functor (Fix1 D)}.

Variable R : (forall (A : Set), relation (Fix1 D A)) ->
             forall (A : Set), relation (Fix1 D A).

Context `{FunctorRel _ R} `{@EqFplusLaws _ _ _ _  -⋘ R}.

Lemma eqFplusComm : forall {A : Set} (a b : Fix1 D A),
    FixRel R _ (fplus a b) (fplus b a).
Proof. eqConstruct. Qed.

Lemma eqFplusAssoc : forall {A : Set} (a b c : Fix1 D A),
    FixRel R _ (fplus (fplus a b) c) (fplus a (fplus b c)).
Proof. eqConstruct. Qed.

End EqFplusLaws_SmartConstructors.


Require Import CPidgin.Control.Monad.
Require Import CPidgin.Data.Maybe.

Module MaybeMonadLaws.

Import Maybe.Maybe.
Import Monad.

(* Monad Law 1: Left Identity. *)
Lemma MaybeMonadLeftIdentity:
    forall (A B : Type) (x : A) (f : A -> Maybe B),
        mret x >>= f
            = f x.
Proof.
    intros.
    unfold mret.
    unfold bind.
    unfold maybeMonad.
    trivial.
Qed.

(* Monad Law 2: Right Identity. *)
Lemma MaybeMonadRightIdentity:
    forall (A : Type) (m : Maybe A),
        m >>= mret
            = m.
Proof.
    intros.
    unfold mret.
    unfold bind.
    unfold maybeMonad.
    destruct m.
    trivial.
    trivial.
Qed.

(* Monad Law 3: Associativity. *)
Lemma MaybeMonadAssociativity:
    forall (A B C : Type) (m : Maybe A) (f : A -> Maybe B) (g : B -> Maybe C),
        (m >>= f) >>= g =
            m >>= (fun x => (f x >>= g)).
Proof.
    intros.
    unfold bind.
    unfold maybeMonad.
    destruct m.
    trivial.
    trivial.
Qed.

End MaybeMonadLaws.


Require Import ct12 ct13.

From Hammer Require Import Hammer.

Lemma HdRel_merge_snd_cons : forall (a a0 : nat) (l1 l2 : list nat),
  sorted (a :: l1) -> sorted (a0 :: l2) -> a <= a0
  -> HdRel le a (merge l1 (a0 :: l2)).
Proof. try hammer. Defined.

Lemma sorted_merge_cons : forall (a a0 : nat) (l1 l2 : list nat),
  (sorted (a :: l1) -> sorted l2 -> sorted (merge (a :: l1) l2))
 -> sorted (a :: l1) -> sorted (a0 :: l2)
  -> sorted (merge (a :: l1) l2).
Proof. try hammer. Defined.

Lemma HdRel_merge_fst_cons : forall (a a0 : nat) (l1 l2 : list nat),
  (sorted (a :: l1) -> sorted l2 -> sorted (merge (a :: l1) l2))
  -> sorted (a :: l1) -> sorted (a0 :: l2) -> a0 < a
  -> HdRel le a0 (merge (a :: l1) l2).
Proof. try hammer. Defined.

Lemma permutation_merge_concat : forall (l1 l2 : list nat),
  permutation (merge l1 l2) (l1 ++ l2).
Proof. (* try hammer. *) Abort.

Lemma permutation_split : forall (l : list nat),
  permutation (fst (split nat l) ++ snd (split nat l)) l.
Proof. (* try hammer. *) Abort.


(** * Theorems about string-like types *)
Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms Coq.Program.Basics.
Require Import Coq.Arith.Lt.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Le.
Require Import Fiat.Parsers.StringLike.Core Fiat.Common.Le Fiat.Common.UIP.

Local Open Scope list_scope.

Set Implicit Arguments.

Section String.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  Definition bool_eq_refl {x : String} : x =s x.
  Proof.
    reflexivity.
  Defined.

  Definition bool_eq_sym {x y : String} : ((x =s y) = (y =s x) :> bool)%string_like.
  Proof.
    case_eq (y =s x)%string_like; intro H';
    [
    | case_eq (x =s y)%string_like; intro H'' ].
    { apply (symmetry (R := (fun x y => x =s y))) in H'; assumption. }
    { apply (symmetry (R := (fun x y => x =s y))) in H''; hnf in H''.
      etransitivity; [ exact (eq_sym H'') | exact H' ]. }
    { reflexivity. }
  Defined.

  Definition bool_eq_trans {x y z : String} : (x =s y) -> (y =s z) -> (x =s z).
  Proof.
    apply (transitivity (R := (fun x y => x =s y))).
  Defined.

  Global Instance str_le_Proper_iff : Proper (beq ==> beq ==> iff) str_le | 1000.
  Proof.
    repeat match goal with
             | _ => intro
             | _ => split
             | [ H : _ ≤s _ |- _ ] => destruct H
             | _ => left; assumption
             | _ => right; assumption
             | _ => right; symmetry; assumption
             | [ H : ?x =s _ |- _ ] => rewrite H in *; clear x H
             | [ H : _ =s ?x |- _ ] => rewrite <- H in *; clear x H
           end.
  Qed.

  Global Instance str_le_Proper : Proper (beq ==> beq ==> impl) str_le.
  Proof.
    intros x y H' x' y' H'' H'''.
    apply (@str_le_Proper_iff x y H' x' y' H''); assumption.
  Qed.

  Global Instance str_le_Proper' : Proper (beq ==> beq ==> Basics.flip impl) str_le.
  Proof.
    intros x y H' x' y' H'' H'''.
    apply (@str_le_Proper_iff _ _ H' _ _ H''); assumption.
  Qed.

  Global Instance str_le_refl : Reflexive str_le.
  Proof.
    repeat intro; right; reflexivity.
  Qed.

  Global Instance str_le_antisym : @Antisymmetric _ beq _ str_le.
  Proof.
    intros ? ? [H'|H']; repeat subst; intros [H1|H1]; repeat subst; try reflexivity;
    solve [ reflexivity
          | exfalso; omega
          | assumption
          | symmetry; assumption ].
  Qed.

  Global Instance str_le_trans : Transitive str_le.
  Proof.
    intros ? ? ? [H'|H']; repeat subst; intros [H1|H1]; repeat subst;
    try (rewrite H1 in *; clear H1);
    try (rewrite H' in *; clear H');
    first [ reflexivity
          | left; assumption
          | left; etransitivity; eassumption ].
  Qed.

  Local Open Scope string_like_scope.

  Global Instance str_le_length_le_Proper : Proper (str_le ==> le) length.
  Proof.
    intros x y [H'|H']; auto with arith.
    rewrite H'; reflexivity.
  Qed.

  Global Instance str_le_length_le_Proper' : Proper (Basics.flip str_le ==> Basics.flip le) length.
  Proof.
    intros x y [H'|H']; unfold Basics.flip in *; auto with arith.
    rewrite H'; reflexivity.
  Qed.

  Lemma str_le_take {str n}
  : take n str ≤s str.
  Proof.
    destruct (le_gt_dec (length str) n).
    { right; apply take_long; assumption. }
    { left; rewrite take_short_length; omega. }
  Qed.

  Lemma str_le_drop {str n}
  : drop n str ≤s str.
  Proof.
    destruct n.
    { rewrite drop_0; reflexivity. }
    { hnf; rewrite drop_length.
      case_eq (length str); intro H'.
      { right; apply bool_eq_empty.
        { rewrite drop_length, H'; reflexivity. }
        { assumption. } }
      { intro; left; omega. } }
  Qed.

  Lemma take_length {str n}
  : length (take n str) = min n (length str).
  Proof.
    destruct (le_ge_dec (length str) n).
    { rewrite take_long by assumption.
      rewrite Min.min_r by assumption.
      reflexivity. }
    { rewrite take_short_length by assumption.
      rewrite Min.min_l by assumption.
      reflexivity. }
  Qed.

  Lemma length_le_trans
        {a b c : String} (H0' : length a < length b) (H1' : b ≤s c)
  : length a < length c.
  Proof.
    destruct H1'; setoid_subst.
    { etransitivity; eassumption. }
    { assumption. }
  Qed.

  Lemma strle_to_sumbool
        (s1 s2 : String) (f : String -> nat)
        (H' : f s1 < f s2 \/ s1 =s s2)
  : {f s1 < f s2} + {s1 =s s2}.
  Proof.
    unfold beq in *.
    case_eq (s1 =s s2).
    { intro H''; right; reflexivity. }
    { intro H''; left.
      destruct H' as [H' | H']; trivial.
      hnf in *.
      abstract congruence. }
  Defined.

  Section strle_choose.
    Context (s1 s2 : String) (f : String -> nat)
            (f_Proper : Proper (beq ==> eq) f)
            (H0' : f s1 < f s2 \/ s1 =s s2).

    Definition strle_left (H' : f s1 < f s2)
    : H0' = or_introl H'.
    Proof.
      destruct H0' as [H''|H'']; try clear H0'; [ apply f_equal | exfalso ].
      { apply le_proof_irrelevance. }
      { setoid_subst s1.
        eapply lt_irrefl; eassumption. }
    Qed.

    Definition strle_right (H' : s1 =s s2)
    : H0' = or_intror H'.
    Proof.
      destruct H0' as [H''|H'']; try clear H0'; [ exfalso | apply f_equal ].
      { setoid_subst s1; eapply lt_irrefl; eassumption. }
      { apply dec_eq_uip.
        decide equality. }
    Qed.
  End strle_choose.

  Lemma str_seq_lt_false
        {a b : String}
        (H0' : length a < length b)
        (H' : a =s b)
  : False.
  Proof.
    rewrite H' in H0'.
    eapply lt_irrefl; eassumption.
  Qed.

  Lemma singleton_exists_unique : forall s, length s = 1 -> exists !ch, s ~= [ ch ].
  Proof.
    intros s H'.
    destruct (singleton_exists s H') as [ch H''].
    exists ch.
    split; [ apply H'' | ].
    intro; apply singleton_unique; assumption.
  Qed.

  Lemma singleton_take {str ch} (H' : str ~= [ ch ]) n
  : take (S n) str =s str.
  Proof.
    eapply bool_eq_char; try eassumption.
    rewrite take_long; try assumption.
    apply length_singleton in H'; omega.
  Qed.

  Lemma drop_empty {str n} (H' : length str = 0) : drop n str =s str.
  Proof.
    apply bool_eq_empty; rewrite ?drop_length, ?take_length; omega.
  Qed.

  Lemma take_empty {str n} (H' : length str = 0) : take n str =s str.
  Proof.
    apply bool_eq_empty; rewrite ?drop_length, ?take_length; trivial.
    apply Min.min_case_strong; omega.
  Qed.

  Definition get_first_char_nonempty' str (H' : length str <> 0) : Char.
  Proof.
    let ret := constr:(get 0 str) in
    refine (match get 0 str as ch return ret = ch -> Char with
              | Some ch => fun _ => ch
              | None => fun H'' => match _ : False with end
            end eq_refl).
    abstract (
        pose proof (singleton_exists (take 1 str)) as H''';
        rewrite take_length in H'''; destruct (length str); try omega;
        specialize (H''' eq_refl);
        destruct H''' as [ch H'''];
        apply get_0 in H'''; congruence
      ).
  Defined.

  Definition get_first_char_nonempty str n (H' : length str = S n) : Char.
  Proof.
    apply (get_first_char_nonempty' str);
    generalize dependent (length str); clear; intros; abstract omega.
  Defined.

  Lemma no_first_char_empty str (H' : get 0 str = None) : length str = 0.
  Proof.
    case_eq (length (take 1 str)); rewrite take_length.
    { destruct (length str); simpl; intros; omega. }
    { intros ? H''.
      pose proof (singleton_exists (take 1 str)) as H'''.
      rewrite take_length in H'''.
      destruct (length str); try omega; simpl in *.
      specialize (H''' eq_refl).
      destruct H''' as [ch H'''].
      apply get_0 in H'''.
      congruence. }
  Qed.

  Lemma has_first_char_nonempty str (H' : length str = 0) : get 0 str = None.
  Proof.
    case_eq (get 0 str); try reflexivity.
    intros ch H''.
    exfalso.
    apply get_0, length_singleton in H''.
    rewrite take_length, H' in H''.
    simpl in *; omega.
  Qed.

  Global Instance get_Proper {n}
  : Proper (beq ==> eq) (get n).
  Proof.
    induction n.
    { intros x y H'.
      case_eq (get 0 x).
      { intros ch H''.
        apply get_0 in H''.
        rewrite H' in H''.
        rewrite (proj1 (get_0 _ _) H'').
        reflexivity. }
      { intros H'''.
        case_eq (get 0 y).
        { intros ch' H''.
          apply get_0 in H''.
          rewrite <- H' in H''.
          rewrite (proj1 (get_0 _ _) H'') in H'''.
          congruence. }
        { reflexivity. } } }
    { intros x y H'.
      rewrite !get_S.
      apply IHn.
      rewrite H'; reflexivity. }
  Qed.

  Lemma get_drop {n str} : get n str = get 0 (drop n str).
  Proof.
    revert str; induction n; intros.
    { rewrite drop_0; reflexivity. }
    { rewrite !get_S, IHn.
      rewrite drop_drop.
      repeat (f_equal; []).
      omega. }
  Qed.

  Lemma get_drop' {n m str} : get m (drop n str) = get (m + n) str.
  Proof.
    revert str n; induction m; intros.
    { rewrite <- get_drop; reflexivity. }
    { rewrite !get_S, !drop_drop, IHm.
      repeat (f_equal; []).
      omega. }
  Qed.

  Lemma fold'_nil
        {A} (f : Char -> A -> A) (init : A) (str : String)
  : fold' f init str 0 = init.
  Proof.
    reflexivity.
  Qed.

  Lemma fold'_cons
        {A} (f : Char -> A -> A) (init : A) (str : String) len
  : fold' f init str (S len)
    = match get (length str - S len) str with
        | Some ch => f ch (fold' f init str len)
        | None => init
      end.
  Proof.
    reflexivity.
  Qed.

  Global Instance fold'_Proper
         {A} (f : Char -> A -> A) (init : A)
  : Proper (beq ==> eq ==> eq) (fold' f init).
  Proof.
    intros ?? H' ? x ?; subst.
    induction x.
    { rewrite !fold'_nil; reflexivity. }
    { rewrite !fold'_cons.
      repeat match goal with
               | _ => reflexivity
               | _ => rewrite IHx
               | _ => rewrite H' at 1
               | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
             end. }
  Qed.

  Lemma fold'_drop
        {A} (f : Char -> A -> A) (init : A) (str : String) len m
        (H' : m + len <= length str)
  : fold' f init str len = fold' f init (drop m str) len.
  Proof.
    revert str m H'.
    induction len; simpl.
    { intros; reflexivity. }
    { intros.
      rewrite !(@get_drop (length _ - _)).
      rewrite drop_length, drop_drop.
      rewrite <- Nat.sub_add_distr, (plus_comm m), Nat.sub_add_distr, Nat.sub_add by omega.
      match goal with
        | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
      end.
      { rewrite <- IHlen by omega; reflexivity. }
      { reflexivity. } }
  Qed.

  Definition fold_nil
             {A} (f : Char -> A -> A) (init : A) (str : String)
             (H' : length str = 0)
  : fold f init str = init.
  Proof.
    unfold fold; rewrite H'; apply fold'_nil.
  Qed.

  Lemma fold_recr
        {A} (f : Char -> A -> A) (init : A) (str : String)
  : fold f init str
    = match get 0 str with
        | Some ch => f ch (fold f init (drop 1 str))
        | None => init
      end.
  Proof.
    case_eq (get 0 str).
    { intros ch H'.
      unfold fold.
      case_eq (length str).
      { intro H''.
        apply has_first_char_nonempty in H''.
        congruence. }
      { intros ? H''.
        rewrite fold'_cons.
        rewrite !H'', minus_diag, H'.
        rewrite drop_length, H''; simpl.
        rewrite <- minus_n_O.
        apply f_equal.
        rewrite <- fold'_drop by omega; reflexivity. } }
    { intro H'.
      apply fold_nil, no_first_char_empty; assumption. }
  Qed.

  Global Instance fold_Proper
         {A} (f : Char -> A -> A) (init : A)
  : Proper (beq ==> eq) (fold f init).
  Proof.
    repeat intro; apply fold'_Proper; trivial.
    setoid_subst_rel beq; reflexivity.
  Qed.

  Lemma fold_lookahead'_nil
        {A} (f : Char -> option Char -> A -> A) (init : A) (str : String)
  : fold_lookahead' f init str 0 = init.
  Proof.
    reflexivity.
  Qed.

  Lemma fold_lookahead'_cons
        {A} (f : Char -> option Char -> A -> A) (init : A) (str : String) len
  : fold_lookahead' f init str (S len)
    = match get (length str - S len) str with
        | Some ch => f ch (get (length str - len) str) (fold_lookahead' f init str len)
        | None => init
      end.
  Proof.
    reflexivity.
  Qed.

  Global Instance fold_lookahead'_Proper
         {A} (f : Char -> option Char -> A -> A) (init : A)
  : Proper (beq ==> eq ==> eq) (fold_lookahead' f init).
  Proof.
    intros ?? H' ? x ?; subst.
    induction x.
    { rewrite !fold_lookahead'_nil; reflexivity. }
    { rewrite !fold_lookahead'_cons.
      repeat match goal with
               | _ => reflexivity
               | _ => rewrite IHx
               | _ => rewrite H' at 1
               | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
             end. }
  Qed.

  Lemma fold_lookahead'_drop
        {A} (f : Char -> option Char -> A -> A) (init : A) (str : String) len m
        (H' : m + len <= length str)
  : fold_lookahead' f init str len = fold_lookahead' f init (drop m str) len.
  Proof.
    revert str m H'.
    induction len; simpl.
    { intros; reflexivity. }
    { intros.
      rewrite !(@get_drop (length _ - _)).
      rewrite drop_length, drop_drop.
      rewrite <- Nat.sub_add_distr, (plus_comm m), Nat.sub_add_distr, Nat.sub_add by omega.
      match goal with
        | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
      end.
      { rewrite drop_drop;
        rewrite <- Nat.sub_add_distr, (plus_comm m), Nat.sub_add_distr, Nat.sub_add by omega;
        rewrite <- IHlen by omega; reflexivity. }
      { reflexivity. } }
  Qed.

  Definition fold_lookahead_nil
             {A} (f : Char -> option Char -> A -> A) (init : A) (str : String)
             (H' : length str = 0)
  : fold_lookahead f init str = init.
  Proof.
    unfold fold_lookahead; rewrite H'; apply fold_lookahead'_nil.
  Qed.

  Lemma fold_lookahead_recr
        {A} (f : Char -> option Char -> A -> A) (init : A) (str : String)
  : fold_lookahead f init str
    = match get 0 str with
        | Some ch => f ch (get 1 str) (fold_lookahead f init (drop 1 str))
        | None => init
      end.
  Proof.
    case_eq (get 0 str).
    { intros ch H'.
      unfold fold_lookahead.
      case_eq (length str).
      { intro H''.
        apply has_first_char_nonempty in H''.
        congruence. }
      { intros n H''.
        rewrite fold_lookahead'_cons.
        rewrite !H'', minus_diag, H'.
        replace (S n - n) with 1 by omega.
        rewrite drop_length, H''; simpl.
        rewrite <- minus_n_O.
        apply f_equal.
        rewrite <- fold_lookahead'_drop by omega; reflexivity. } }
    { intro H'.
      apply fold_lookahead_nil, no_first_char_empty; assumption. }
  Qed.

  Global Instance fold_lookahead_Proper
         {A} (f : Char -> option Char -> A -> A) (init : A)
  : Proper (beq ==> eq) (fold_lookahead f init).
  Proof.
    repeat intro; apply fold_lookahead'_Proper; trivial.
    setoid_subst_rel beq; reflexivity.
  Qed.

  Lemma add_take_1_singleton (str : String) ch (H : str ~= [ ch ])
  : take 1 str ~= [ ch ].
  Proof.
    rewrite take_long; [ assumption | ].
    apply length_singleton in H; rewrite H; reflexivity.
  Qed.

  Lemma take_n_1_singleton (str : String) n ch (H : take n str ~= [ ch ])
  : take 1 str ~= [ ch ].
  Proof.
    apply add_take_1_singleton in H.
    rewrite (take_take str 1 n) in H.
    destruct n; simpl min in H.
    { apply length_singleton in H; rewrite take_length in H.
      simpl in H; congruence. }
    { exact H. }
  Qed.

  Lemma get_take_lt (str : String) n m (Hle : n < m)
  : get n (take m str) = get n str.
  Proof.
    repeat match goal with
             | _ => progress simpl in *
             | _ => congruence
             | _ => omega
             | _ => progress rewrite ?drop_take
             | [ |- context[get ?n _] ] => not constr_eq n 0; rewrite !(get_drop (n := n))
             | [ |- context[get 0 ?str] ] => destruct (get 0 str) eqn:?
             | [ H : get 0 _ = Some _ |- _ ] => apply get_0 in H
             | [ H : get 0 _ = None |- _ ] => apply no_first_char_empty in H
             | [ H : _ |- _ ] => progress rewrite ?take_take, ?take_length in H
             | [ H : is_true (take ?n _ ~= [ _ ]) |- _ ] => progress apply take_n_1_singleton in H
             | [ |- Some _ = Some _ ] => apply f_equal
             | _ => eapply singleton_unique; eassumption
             | [ H : length ?str = 0, H' : is_true (take _ ?str ~= [ _ ]) |- _ ]
               => apply length_singleton in H'
             | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : context[min _ _] |- _ ] => revert H; apply Min.min_case_strong; intros
           end.
  Qed.

  Lemma take_min_length (str : String) n
  : take n str =s take (min (length str) n) str.
  Proof.
    apply Min.min_case_strong; [ | reflexivity ].
    intro H.
    rewrite !take_long by (assumption || reflexivity).
    reflexivity.
  Qed.

  Lemma drop_min_length (str : String) n
  : drop n str =s drop (min (length str) n) str.
  Proof.
    apply Min.min_case_strong; [ | reflexivity ].
    intro H.
    apply bool_eq_empty; rewrite drop_length; omega.
  Qed.

  Lemma not_is_char_options str ch
  : (is_char str ch = false) <-> (length str <> 1 \/ get 0 str <> Some ch).
  Proof.
    destruct (is_char str ch) eqn:H;
    (split; intro H'; try solve [ inversion H' | exact eq_refl ]).
    { pose proof H as H0.
      apply add_take_1_singleton, get_0 in H.
      apply length_singleton in H0.
      rewrite H, H0 in H'.
      destruct H'; congruence. }
    { destruct (Nat.eq_dec (length str) 1); [ right | left; assumption ].
      intro H''.
      apply get_0 in H''.
      rewrite take_long in H'' by omega.
      congruence. }
  Qed.

  Lemma is_char_parts str ch
  : (is_true (is_char str ch)) <-> (length str = 1 /\ get 0 str = Some ch).
  Proof.
    destruct (is_char str ch) eqn:H;
    (split; intro H'; try solve [ inversion H' | reflexivity ]).
    { split.
      { apply length_singleton in H; assumption. }
      { apply get_0, add_take_1_singleton, H. } }
    { apply not_is_char_options in H; tauto. }
  Qed.

  Local Ltac induction_to_string str IHlen :=
    let H := fresh "H" in
    let len := fresh "len" in
    unfold fold;
      generalize dependent str; intro str;
      remember (length str) as len eqn:H;
      revert str H;
      induction len as [|len IHlen]; simpl; intros;
      [
      | specialize (IHlen (drop 1 str));
        rewrite drop_length in IHlen;
        specialize_by omega;
        try rewrite <- !H, !minus_diag;
        try rewrite <- fold'_drop in IHlen by omega ].

  Lemma to_string_length str
  : List.length (to_string str) = length str.
  Proof.
    induction_to_string str IHlen; trivial.
    destruct (get 0 str) eqn:H'; simpl; [ rewrite IHlen; reflexivity | ].
    apply no_first_char_empty in H'; omega.
  Qed.

  Local Ltac take_drop_to_string_t0 :=
    repeat match goal with
             | _ => progress specialize_by omega
             | _ => reflexivity
             | _ => omega
             | _ => progress subst
             | [ H : context[S _ - S _] |- _ ] => rewrite Nat.sub_succ in H
             | [ H : context[S ?x - ?x] |- _ ] => replace (S x - x) with 1 in H by omega
             | [ H : cons _ _ = cons _ _ |- _ ] => inversion H; clear H
             | _ => discriminate
             | [ H : context[_ + 1] |- _ ] => rewrite Nat.add_1_r in H
             | [ |- context[match get 0 ?s with _ => _ end] ] => destruct (get 0 s) eqn:?
             | [ H : get 0 ?str = None |- _ ] => apply no_first_char_empty in H
             | [ H : _ = ?x |- _ = ?x ] => rewrite <- H; clear H
             | [ H : ?x = _ |- ?x = _ ] => rewrite H; clear H
             | [ H : context[length (drop _ _)] |- _ ] => rewrite drop_length in H
             | [ |- context[length (drop _ _)] ] => rewrite drop_length
             | [ H : context[length (take _ _)] |- _ ] => rewrite take_length in H
             | [ |- context[length (take _ _)] ] => rewrite take_length
             | [ |- context[_ - 0] ] => rewrite Nat.sub_0_r
             | [ H : context[_ - 0] |- _ ] => rewrite Nat.sub_0_r in H
             | [ |- context[fold' _ _ (drop _ _) _] ] => rewrite <- fold'_drop by (rewrite ?take_length; try apply Min.min_case_strong; omega)
             | [ H : context[fold' _ _ (drop _ _) _] |- _ ] => rewrite <- fold'_drop in H by omega
             | [ H : ?x = ?y |- context[?x - ?y] ] => replace (x - y) with 0 by omega
             | [ H : ?y = ?x |- context[?x - ?y] ] => replace (x - y) with 0 by omega
             | [ |- cons _ _ = cons _ _ ] => apply f_equal2
             | [ H : context[get _ (drop 0 ?str)] |- _ ] => rewrite (drop_0 str) in H
             | [ H : ?x = Some ?c, H' : ?y = Some ?c' |- _ ]
               => not constr_eq c c'; is_var c; is_var c';
                  assert (c = c') by congruence; subst
             | _ => progress simpl in *
             | [ |- context[fold' _ _ (drop _ (drop _ _)) _] ] => rewrite drop_drop
             | [ |- context[?x + 1] ] => rewrite Nat.add_1_r
             | [ H : S _ = ?x |- context[match ?x with _ => _ end] ] => rewrite <- H
             | [ H : S _ = ?x, H' : context[match ?x with _ => _ end] |- _ ] => rewrite <- H in H'
             | [ H : context[?x - ?x] |- _ ] => rewrite minus_diag in H
             | [ |- context[?x - ?x] ] => rewrite minus_diag
             | [ H : context[get _ (take _ _)] |- _ ] => rewrite get_take_lt in H by omega
             | [ H : context[min (pred ?x) ?x] |- _ ] => rewrite (Min.min_l (pred x) x) in H by omega
             | [ |- context[take _ (drop _ _)] ] => rewrite take_drop
             | [ |- context[min ?x ?y] ] => rewrite (Min.min_l x y) by omega
             | [ |- context[get _ (drop 0 ?s)] ] => rewrite (drop_0 s)
             | [ |- context[get _ (drop _ (drop _ _))] ] => rewrite drop_drop
             | [ H : S ?x = ?y, H' : S ?z = ?y |- _ ]
               => is_var x; not constr_eq x z; assert (x = z) by omega; subst
             | [ H : S ?x = ?y, H' : ?y = S ?z |- _ ]
               => is_var x; not constr_eq x z; assert (x = z) by omega; subst
             | [ H : get ?n ?s = None |- _ ] => not constr_eq n 0; rewrite get_drop in H
           end.

  Local Ltac take_drop_to_string_t s n :=
    unfold fold; rewrite ?drop_length, ?take_length;
    revert n;
    let IHlen := fresh "IHlen" in
    induction_to_string s IHlen;
      destruct n as [|n];
      try specialize (IHlen n);
      take_drop_to_string_t0.

  Lemma drop_to_string s n
  : List.drop n (to_string s) = to_string (drop n s).
  Proof.
    take_drop_to_string_t s n.
  Qed.

  Lemma take_to_string s n
  : List.take n (to_string s) = to_string (take n s).
  Proof.
    destruct (le_lt_dec (length s) n) as [H|H].
    { rewrite take_long by assumption.
      rewrite take_all by (rewrite to_string_length; assumption).
      reflexivity. }
    { revert H.
      take_drop_to_string_t s n. }
  Qed.

  Lemma nth_to_string s n
  : List.nth_error (to_string s) n = get n s.
  Proof.
    rewrite get_drop.
    symmetry.
    take_drop_to_string_t s n;
      try solve [ apply has_first_char_nonempty; rewrite ?drop_length; omega ].
  Qed.

  Lemma beq_to_string {s s'}
  : to_string s = to_string s' <-> s =s s'.
  Proof.
    split.
    { intro H; apply bool_eq_from_get; intro n.
      rewrite <- !nth_to_string, H; reflexivity. }
    { intro; setoid_subst_rel beq.
      reflexivity. }
  Qed.

  Lemma is_char_to_string s ch
  : is_char s ch <-> to_string s = (ch::nil)%list.
  Proof.
    induction_to_string s IHlen.
    { split; intro H'; exfalso; try congruence.
      apply length_singleton in H'; omega. }
    { clear IHlen.
      take_drop_to_string_t0.
      split; intro H'.
      { pose proof (add_take_1_singleton _ _ H') as H''.
        apply length_singleton in H'.
        apply get_0 in H''.
        take_drop_to_string_t0. }
      { take_drop_to_string_t0.
        rewrite <- take_long by reflexivity.
        match goal with
          | [ H : S ?len = length ?s |- _ ] => is_var len; destruct len; rewrite <- H
        end.
        { apply get_0; assumption. }
        { take_drop_to_string_t0.
          match goal with
            | [ H : context[match get ?n ?s with _ => _ end] |- _ ] => destruct (get n s) eqn:?
          end;
          take_drop_to_string_t0. } } }
  Qed.

  Section substring.
    Local Ltac substring_t' :=
      idtac;
      match goal with
        | [ |- beq _ _ ] => reflexivity
        | [ |- _ = _ ] => reflexivity
        | _ => assumption
        | [ H : length ?s = 0 |- beq _ ?s ] => apply bool_eq_empty
        | [ H : length ?s = 0 |- beq ?s _ ] => apply bool_eq_empty
        | _ => progress rewrite ?drop_0, ?take_long, ?take_length, ?drop_length by trivial
        | _ => progress rewrite <- ?Nat.sub_min_distr_r, ?Nat.add_sub by trivial
        | _ => rewrite !take_long by (rewrite drop_length; omega)
        | [ |- context[min ?x ?y] ]
          => match goal with
               | [ |- context[min y x] ]
                 => rewrite (Min.min_comm x y)
             end
        | _ => repeat apply Min.min_case_strong; omega
      end.

    Local Ltac substring_t := repeat substring_t'.

    Lemma substring_correct3 {s : String} m (H : length s <= m)
    : substring 0 m s =s s.
    Proof. substring_t. Qed.

    Lemma substring_correct3' {s : String}
    : substring 0 (length s) s =s s.
    Proof. substring_t. Qed.

    Lemma substring_length {s n m}
    : length (substring n m s) = (min (length s) (m + n)) - n.
    Proof. substring_t. Qed.

    Lemma substring_correct0_length {s : String} {n}
    : length (substring n 0 s) = 0.
    Proof. substring_t. Qed.

    Lemma substring_correct0 {s s' : String} {n} (H : length s' = 0)
    : substring n 0 s =s s'.
    Proof. substring_t. Qed.

    Lemma substring_correct0'_length {s : String} {n m} (H : length s <= n)
    : length (substring n m s) = 0.
    Proof. substring_t. Qed.

    Lemma substring_correct0' {s s' : String} {n m} (H : length s <= n) (H' : length s' = 0)
    : substring n m s =s s'.
    Proof. substring_t. Qed.

    Lemma substring_correct4 {s : String} {n m m'}
          (H : length s <= n + m) (H' : length s <= n + m')
    : substring n m s =s substring n m' s.
    Proof. substring_t. Qed.

    Lemma substring_substring {s n m n' m'}
    : substring n m (substring n' m' s) =s substring (n + n') (min m (m' - n)) s.
    Proof.
      rewrite !drop_take, !take_take, !drop_drop; reflexivity.
    Qed.

    Lemma substring_min {x x' y y' z str} (H : substring x y str =s substring x' y' str)
    : substring x (min y z) str =s substring x' (min y' z) str.
    Proof.
      pose proof (fun y x => @substring_substring str 0 z x y) as H'; simpl in *.
      setoid_rewrite Nat.sub_0_r in H'.
      setoid_rewrite Min.min_comm in H'.
      rewrite <- !H', H; reflexivity.
    Qed.

    Lemma substring_min_length str x y
    : substring x (min y (length str)) str =s substring x y str.
    Proof.
      apply Min.min_case_strong; try reflexivity.
      intro H.
      apply substring_correct4; omega.
    Qed.

    Lemma substring_length_no_min {offset len s} (Hshort : len = 0 \/ offset + len <= length s)
    : length (substring offset len s) = len.
    Proof.
      rewrite substring_length; destruct Hshort as [Hshort|Hshort];
      try rewrite Min.min_r by (clear -Hshort; omega);
      subst; simpl;
      rewrite <- ?NPeano.Nat.sub_min_distr_r, ?NPeano.Nat.add_sub, ?minus_diag, ?Min.min_0_r;
      reflexivity.
    Qed.
  End substring.

  Lemma char_at_matches_is_char_no_ex offset len str P
        (Hlen : offset + len <= length str)
  : (EqNat.beq_nat len 1 && char_at_matches offset str P)%bool = true
    <-> match get offset str with
          | Some ch => (P ch /\ substring offset len str ~= [ch])%string_like
          | None => False
        end.
  Proof.
    destruct (get offset str) as [ch|] eqn:Heq.
    { split; intro H.
      { apply Bool.andb_true_iff in H.
        destruct H as [H0 H1].
        apply EqNat.beq_nat_true in H0; subst.
        erewrite char_at_matches_correct in H1 by eassumption.
        split; try assumption.
        rewrite get_drop in Heq.
        generalize dependent (drop offset str); clear Hlen offset str; intro str.
        intro H.
        apply get_0; assumption. }
      { destruct H as [H0 H1].
        erewrite char_at_matches_correct by eassumption.
        apply Bool.andb_true_iff; split; [ | eassumption ].
        apply length_singleton in H1.
        rewrite substring_length, <- Nat.sub_min_distr_r, Nat.add_sub in H1.
        apply EqNat.beq_nat_true_iff.
        revert H1.
        apply Min.min_case_strong; intros; omega. } }
    { split; [ intro H | intros [] ].
      rewrite get_drop in Heq.
      apply no_first_char_empty in Heq.
      rewrite drop_length in Heq.
      apply Bool.andb_true_iff in H.
      destruct H as [H0 H1].
      apply EqNat.beq_nat_true in H0; subst.
      omega. }
  Qed.

  Lemma char_at_matches_is_char offset len str P
        (Hlen : offset + len <= length str)
  : (EqNat.beq_nat len 1 && char_at_matches offset str P)%bool = true
    <-> (exists ch, P ch /\ substring offset len str ~= [ch])%string_like.
  Proof.
    rewrite char_at_matches_is_char_no_ex by assumption.
    destruct (get offset str) as [ch|] eqn:Heq.
    { split; intro H; [ exists ch; assumption | ].
      destruct H as [ch' H].
      assert (ch = ch');
        [
        | subst; assumption ].
      destruct H as [H0 H1].
      apply take_n_1_singleton in H1.
      apply get_0 in H1.
      rewrite get_drop in Heq.
      congruence. }
    { split; [ intros [] | intros [ch [H0 H1]] ].
      rewrite get_drop in Heq.
      apply no_first_char_empty in Heq.
      rewrite drop_length in Heq.
      apply length_singleton in H1.
      assert (len = 0) by omega; subst.
      rewrite substring_length, <- Nat.sub_min_distr_r, Nat.add_sub, Min.min_0_r in H1.
      omega. }
  Qed.
End String.

Section Iso.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSI : StringIso Char}
          {HSLP : StringLikeProperties Char} {HSIP : StringIsoProperties Char}.

  Lemma length_of_string_nil
  : length (of_string nil) = 0.
  Proof.
    apply no_first_char_empty.
    rewrite get_of_string; reflexivity.
  Qed.

  Lemma drop_of_string (n : nat) str
  : drop n (of_string str) =s of_string (List.drop n str).
  Proof.
    apply bool_eq_from_get.
    intro n'; rewrite get_drop', !get_of_string, nth_error_drop.
    reflexivity.
  Qed.

  Lemma take_of_string (n : nat) str
  : take n (of_string str) =s of_string (List.take n str).
  Proof.
    revert str; induction n; intros; simpl.
    { apply bool_eq_empty; rewrite ?take_length, ?drop_length; trivial.
      apply length_of_string_nil. }
    { apply bool_eq_from_get.
      intros_destruct.
      { destruct str as [|ch str]; simpl;
        repeat match goal with
                 | _ => progress simpl
                 | _ => reflexivity
                 | _ => progress rewrite ?get_take_lt, ?get_of_string, ?take_length, ?length_of_string_nil
                       by (reflexivity || omega)
               end. }
      { intro n'; rewrite !get_S.
        rewrite drop_take, !drop_of_string; simpl.
        rewrite NPeano.Nat.sub_0_r.
        destruct str; simpl;
        rewrite !IHn; simpl; trivial.
        destruct n; reflexivity. } }
  Qed.

  Lemma of_string_length str
  : length (of_string str) = List.length str.
  Proof.
    induction str as [|ch str IHstr].
    { apply no_first_char_empty.
      rewrite get_of_string; reflexivity. }
    { simpl; rewrite <- IHstr; clear IHstr.
      assert (H : of_string str =s drop 1 (of_string (ch :: str))) by (rewrite drop_of_string; reflexivity).
      rewrite H, drop_length.
      destruct (length (of_string (ch::str))) eqn:H'.
      { apply has_first_char_nonempty in H'.
        rewrite get_of_string in H'; simpl in H'.
        inversion H'. }
      { omega. } }
  Qed.

  Lemma is_char_of_string str ch
  : is_true (is_char (of_string str) ch) <-> str = (ch::nil).
  Proof.
    split; intro H;
    [ pose proof (length_singleton _ _ H) as H';
      rewrite of_string_length in H'
    | ];
    (destruct str as [|ch' [|ch'' str]];
     simpl in *; try discriminate);
    change (ch' :: nil) with (List.take 1 (ch'::nil)) in *;
    repeat match goal with
             | [ H : _ |- _ ] => progress rewrite <- ?take_of_string, ?get_of_string in H
             | _ => progress rewrite <- ?take_of_string, ?get_of_string
             | _ => progress simpl in *
             | [ H : is_true (is_char _ _) |- _ ] => apply get_0 in H
             | [ |- is_true (is_char _ _) ] => apply get_0
             | _ => progress unfold value in *
             | [ H : Some _ = Some _ |- _ ] => inversion_clear H
             | [ H : _::_ = _::_ |- _ ] => inversion_clear H
             | _ => reflexivity
           end.
  Qed.

  Lemma substring_of_string {n m str}
  : substring n m (of_string str) =s of_string (List.take m (List.drop n str)).
  Proof.
    rewrite <- take_of_string, <- drop_of_string; reflexivity.
  Qed.

  Lemma to_of_string str
  : to_string (of_string str) = str.
  Proof.
    induction str.
    { unfold fold, fold'.
      rewrite of_string_length; simpl.
      reflexivity. }
    { rewrite fold_recr.
      rewrite get_of_string; simpl.
      rewrite drop_of_string; simpl.
      rewrite IHstr.
      reflexivity. }
  Qed.

  Lemma of_to_string str
  : of_string (to_string str) =s str.
  Proof.
    remember (length str) as n eqn:H.
    revert str H; induction n; intros.
    { unfold fold.
      apply bool_eq_empty; rewrite <- H, ?of_string_length; reflexivity. }
    { rewrite fold_recr.
      apply bool_eq_from_get.
      intros [|n'].
      { destruct (get 0 str) eqn:H'.
        { rewrite get_of_string; reflexivity. }
        { apply no_first_char_empty in H'; congruence. } }
      { rewrite !get_S.
        rewrite <- (IHn (drop 1 str)) by (rewrite drop_length; omega).
        rewrite drop_of_string.
        destruct (get 0 str) eqn:H'; simpl.
        { reflexivity. }
        { apply no_first_char_empty in H'; congruence. } } }
  Qed.

  Lemma beq_of_string {s s'}
  : of_string s =s of_string s' <-> s = s'.
  Proof.
    rewrite <- beq_to_string, !to_of_string.
    reflexivity.
  Qed.
End Iso.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import OrderedRing.
Require Import RingMicromega.
Require Import Refl.
Require Import Raxioms RIneq Rpow_def DiscrR.
Require Import QArith.
Require Import Qfield.
Require Import Qreals.

Require Setoid.
(*Declare ML Module "micromega_plugin".*)

Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R).
Proof.
  constructor.
  exact Rplus_0_l.
  exact Rplus_comm.
  intros. rewrite Rplus_assoc. auto.
  exact Rmult_1_l.
  exact Rmult_comm.
  intros ; rewrite Rmult_assoc ; auto.
  intros. rewrite Rmult_comm. rewrite Rmult_plus_distr_l.
   rewrite (Rmult_comm z).    rewrite (Rmult_comm z). auto.
  reflexivity.
  exact Rplus_opp_r.
Qed.

Open Scope R_scope.

Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R)  Rle Rlt.
Proof.
  constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)).
  constructor.
  constructor.
  unfold RelationClasses.Symmetric. auto.
  unfold RelationClasses.Transitive. intros. subst. reflexivity.
  apply Rsrt.
  eapply Rle_trans ; eauto.
  apply (Rlt_irrefl m) ; auto.
  apply Rnot_le_lt. auto with real.
  destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto.
  now apply Rmult_lt_0_compat.
Qed.

Notation IQR := Q2R (only parsing).

Lemma Rinv_1 : forall x, x * / 1 = x.
Proof.
  intro.
  rewrite Rinv_1.
  apply Rmult_1_r.
Qed.

Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y.
Proof.
  intros.
  now apply Qeq_eqR, Qeq_bool_eq.
Qed.

Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y.
Proof.
  intros.
  apply Qeq_bool_neq in H.
  contradict H.
  now apply eqR_Qeq.
Qed.

Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y.
Proof.
  intros.
  now apply Qle_Rle, Qle_bool_imp_le.
Qed.

Lemma IQR_0 : IQR 0 = 0.
Proof.
  apply Rmult_0_l.
Qed.

Lemma IQR_1 : IQR 1 = 1.
Proof.
  compute. apply Rinv_1.
Qed.

Lemma IQR_inv_ext : forall x,
  IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x).
Proof.
  intros.
  case_eq (Qeq_bool x 0).
  intros.
  apply Qeq_bool_eq in H.
  destruct x ; simpl.
  unfold Qeq in H.
  simpl in H.
  rewrite Zmult_1_r in H.
  rewrite H.
  apply Rmult_0_l.
  intros.
  now apply Q2R_inv, Qeq_bool_neq.
Qed.

Notation to_nat := N.to_nat.

Lemma QSORaddon :
  @SORaddon R
  R0 R1 Rplus Rmult Rminus Ropp  (@eq R)  Rle (* ring elements *)
  Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *)
  Qeq_bool Qle_bool
  IQR nat to_nat pow.
Proof.
  constructor.
  constructor ; intros ; try reflexivity.
  apply IQR_0.
  apply IQR_1.
  apply Q2R_plus.
  apply Q2R_minus.
  apply Q2R_mult.
  apply Q2R_opp.
  apply Qeq_true ; auto.
  apply R_power_theory.
  apply Qeq_false.
  apply Qle_true.
Qed.

(* Syntactic ring coefficients.
   For computing, we use Q. *)
Inductive Rcst :=
| C0
| C1
| CQ (r : Q)
| CZ (r : Z)
| CPlus (r1 r2 : Rcst)
| CMinus (r1  r2 : Rcst)
| CMult (r1 r2 : Rcst)
| CInv  (r : Rcst)
| COpp  (r : Rcst).

Fixpoint Q_of_Rcst (r : Rcst) : Q :=
  match r with
    | C0 => 0 # 1
    | C1 => 1 # 1
    | CZ z => z # 1
    | CQ q => q
    | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2)
    | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2)
    | CMult r1 r2  => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2)
    | CInv r        => Qinv (Q_of_Rcst r)
    | COpp r       => Qopp (Q_of_Rcst r)
  end.

Fixpoint R_of_Rcst (r : Rcst) : R :=
  match r with
    | C0 => R0
    | C1 => R1
    | CZ z => IZR z
    | CQ q => IQR q
    | CPlus r1 r2  => (R_of_Rcst r1) + (R_of_Rcst r2)
    | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2)
    | CMult r1 r2  => (R_of_Rcst r1) * (R_of_Rcst r2)
    | CInv r       =>
      if Qeq_bool (Q_of_Rcst r) (0 # 1)
        then R0
        else Rinv (R_of_Rcst r)
      | COpp r       => - (R_of_Rcst r)
  end.

Lemma Q_of_RcstR : forall c, IQR (Q_of_Rcst c) = R_of_Rcst c.
Proof.
    induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2).
    apply IQR_0.
    apply IQR_1.
    reflexivity.
    unfold IQR. simpl. rewrite Rinv_1. reflexivity.
    apply Q2R_plus.
    apply Q2R_minus.
    apply Q2R_mult.
    rewrite <- IHc.
    apply IQR_inv_ext.
    rewrite <- IHc.
    apply Q2R_opp.
  Qed.

Require Import EnvRing.

Definition INZ (n:N) : R :=
  match n with
    | N0 => IZR 0%Z
    | Npos p => IZR (Zpos p)
  end.

Definition Reval_expr := eval_pexpr  Rplus Rmult Rminus Ropp R_of_Rcst N.to_nat pow.

Definition Reval_op2 (o:Op2) : R -> R -> Prop :=
    match o with
      | OpEq =>  @eq R
      | OpNEq => fun x y  => ~ x = y
      | OpLe => Rle
      | OpGe => Rge
      | OpLt => Rlt
      | OpGt => Rgt
    end.

Definition Reval_formula (e: PolEnv R) (ff : Formula Rcst) :=
  let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs).

Definition Reval_formula' :=
  eval_sformula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst.

Definition QReval_formula :=
  eval_formula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR N.to_nat pow .

Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f.
Proof.
  intros.
  unfold Reval_formula.
  destruct f.
  unfold Reval_formula'.
  unfold Reval_expr.
  split ; destruct Fop ; simpl ; auto.
  apply Rge_le.
  apply Rle_ge.
Qed.

Definition Qeval_nformula :=
  eval_nformula 0 Rplus Rmult  (@eq R) Rle Rlt IQR.

Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
Proof.
  exact (fun env d =>eval_nformula_dec Rsor IQR env d).
Qed.

Definition RWitness := Psatz Q.

Definition RWeakChecker := check_normalised_formulas 0%Q 1%Q Qplus Qmult  Qeq_bool Qle_bool.

Require Import List.

Lemma RWeakChecker_sound :   forall (l : list (NFormula Q)) (cm : RWitness),
  RWeakChecker l cm = true ->
  forall env, make_impl (Qeval_nformula env) l False.
Proof.
  intros l cm H.
  intro.
  unfold Qeval_nformula.
  apply (checker_nf_sound Rsor QSORaddon l cm).
  unfold RWeakChecker in H.
  exact H.
Qed.

Require Import Coq.micromega.Tauto.

Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool.
Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool.

Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool.

Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool.

Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness)  : bool :=
  @tauto_checker (Formula Q) (NFormula Q)
  runsat rdeduce
  Rnormalise Rnegate
  RWitness RWeakChecker (map_bformula (map_Formula Q_of_Rcst)  f) w.

Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f  (Reval_formula env)  f.
Proof.
  intros f w.
  unfold RTautoChecker.
  intros TC env.
  apply (tauto_checker_sound  QReval_formula Qeval_nformula) with (env := env) in TC.
  rewrite eval_f_map in TC.
  rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto.
  intro.
  unfold QReval_formula.
  rewrite <- eval_formulaSC  with (phiS := R_of_Rcst).
  rewrite Reval_formula_compat.
  tauto.
  intro. rewrite Q_of_RcstR. reflexivity.
  apply Reval_nformula_dec.
  destruct t.
  apply (check_inconsistent_sound Rsor QSORaddon) ; auto.
  unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon).
  now apply (cnf_normalise_correct Rsor QSORaddon).
  intros. now apply (cnf_negate_correct Rsor QSORaddon).
  intros t w0.
  apply RWeakChecker_sound.
Qed.

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import coqutil.Datatypes.List.
Require Import bedrock2.Array.
Require Import bedrock2.Scalars.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Bedrock.Field.Common.Arrays.MaxBounds.
Require Import Crypto.Bedrock.Field.Common.Arrays.ByteBounds.
Local Open Scope Z_scope.

Section Bignum.
  Import bedrock2.Memory bedrock2.ptsto_bytes.
  Context  {width} {word : Interface.word width} {mem : map.map word Init.Byte.byte}.

  Local Notation k := (bytes_per_word width).
  Definition Bignum (n : nat) (px : word) (x : list word) : mem -> Prop :=
    sep (emp (length x = n)) (array scalar (word.of_Z k) px x).

  Definition EncodedBignum
             (n_bytes : nat) (px : word) (x : list Byte.byte)
    : mem -> Prop :=
    sep (emp (length x = n_bytes)) (array ptsto (word.of_Z 1) px x).

  Section Proofs.
    Context {word_ok : @word.ok width word} {map_ok : @map.ok word Init.Byte.byte mem}
      {BW : coqutil.Word.Bitwidth.Bitwidth width}.

    Local Notation lew_combine := (fun c => word.of_Z (LittleEndianList.le_combine c)).
    Local Notation lew_split := (fun w => LittleEndianList.le_split (Z.to_nat k) (word.unsigned w)).

    Lemma Bignum_of_bytes n :
      forall addr bs,
        length bs = (n * Z.to_nat (bytes_per_word width))%nat ->
        Lift1Prop.iff1
          (array ptsto (word.of_Z 1) addr bs)
          (Bignum n addr (map lew_combine (chunk (Z.to_nat k) bs))).
    Proof.
      cbv [Bignum].
      induction n; intros.
      { destruct bs; cbn [length] in *; try lia; [ ].
        repeat intro. intuition sepsimpl; eauto. }
      { rewrite <-(firstn_skipn (Z.to_nat k) bs).
        rewrite array_append.
        rewrite Scalars.scalar_of_bytes with (l:=List.firstn _ _);
          lazymatch goal with
          | [ |- _ <= width ] => destruct Bitwidth.width_cases; lia
          | _ => idtac
          end.
        2:{
          rewrite firstn_length, Min.min_l by lia.
          destruct Bitwidth.width_cases; subst width; trivial. }
        rewrite chunk_app_chunk; cycle 1.
        { destruct Bitwidth.width_cases; subst width; cbv; inversion 1. }
        { rewrite firstn_length; lia. }
        cbn [length array map]; progress (cancel; cbv [seps]).
        unshelve erewrite (_ : forall n m, (S n = S m <-> n = m)).
        { clear; intros; split; congruence. }
        rewrite <-IHn by (rewrite skipn_length; lia); clear IHn.
        Morphisms.f_equiv. f_equal. f_equal.
        rewrite word.unsigned_of_Z_1, Z.mul_1_l, firstn_length, H.
        destruct Bitwidth.width_cases; subst width; cbn; lia. }
    Qed.

    (* TODO: move to coqutil.List.Datatypes *)
    Lemma chunk_flat_map_exact {A B} k (Hk : k <> O)
      (f : A -> list B) (Hf : forall a : A, length (f a) = k) xs
      : chunk k (flat_map f xs) = map f xs.
    Proof.
      induction xs; trivial; cbn [flat_map map].
      rewrite ?chunk_app_chunk, IHxs; trivial.
    Qed.

    Lemma Bignum_to_bytes n :
      forall addr x,
        Lift1Prop.iff1
          (Bignum n addr x)
          (sep (emp (length (flat_map lew_split x) = (n * Z.to_nat k)%nat))
          (array ptsto (word.of_Z 1) addr (flat_map lew_split x))).
    Proof.
      intros.
      assert (length (flat_map lew_split x) = (length x * Z.to_nat k)%nat).
      { erewrite flat_map_const_length, Nat.mul_comm;
        auto using LittleEndianList.length_le_split. }
      rewrite Bignum_of_bytes by eassumption; cbv [Bignum].
      rewrite chunk_flat_map_exact, map_map; cycle 1.
      { destruct Bitwidth.width_cases; subst width; inversion 1. }
      { intros; apply LittleEndianList.length_le_split. }
      erewrite List.map_ext with (g:=fun x=>x), map_id; try cancel; cbv [seps].
      { rewrite sep_emp_emp. setoid_rewrite H.
        cbv [Lift1Prop.iff1 emp]; intuition (
          destruct Bitwidth.width_cases; subst width; subst; cbn in *; try nia). }
      intros.
      (* note: this mess could be cleaned up now that we use LittleEndianList *)
      destruct Bitwidth.width_cases; subst width; simpl k; simpl length(*+arguments*);
        rewrite ?LittleEndianList.le_combine_split; try exact eq_refl;
        rewrite Z.mod_small, word.of_Z_unsigned;
        trivial; eapply word.unsigned_range.
    Qed.
  End Proofs.
End Bignum.
Notation BignumSuchThat :=
  (fun n addr ws P =>
     let xs := map word.unsigned ws in
     sep (emp (P xs)) (Bignum n addr ws)).
Notation EncodedBignumSuchThat :=
  (fun n addr ws P =>
     let xs := map Byte.byte.unsigned ws in
     sep (emp (P xs)) (EncodedBignum n addr ws)).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e166m5_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e206m5_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e191m19_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import emma_orig.
(* Declaration of basic propositions. *)
Import Utf8_core.
Import ILLVarInt.MILL. (* only this *)
Import ILLVarInt.Tacs. (* only this *)
Require Import unprove.
Import FormulaMultiSet. (* and this *)
Require Import ILL_equiv.

Local Open Scope ILL_scope.
Local Open Scope Emma.

Inductive boolP : Prop := trueP | falseP.

Program Fixpoint exists_oplus_on_formula (cont: forall (e1:env) (f1:formula) (h1: e1 ⊢ f1) (e2:env) (f2:formula) (h2: e2 ⊢ f2),boolP) (φl φr:formula)  (e:env) (f:formula) (h: e ⊢ f) {struct h}: boolP :=
match h with
  | Id _ _ p => falseP
  | Impl_R _ p q x => exists_oplus_on_formula cont φl φr _ _ x
  | Impl_L _ Δ Δ' p q r _ _ x x0 => if exists_oplus_on_formula cont φl φr _ _ x then trueP else exists_oplus_on_formula cont φl φr _ _ x0
  | Times_R _ Δ p q _ _ x x0 => if exists_oplus_on_formula cont φl φr _ _ x then trueP else exists_oplus_on_formula cont φl φr _ _ x0
  | Times_L _ p q r _ x => exists_oplus_on_formula cont φl φr _ _ x
  | One_R _ _  => falseP
  | One_L _ p _ x => exists_oplus_on_formula cont φl φr _ _ x
  | And_R _ p q x x0 => if exists_oplus_on_formula cont φl φr _ _ x then trueP else exists_oplus_on_formula cont φl φr _ _ x0
  | And_L_1 _ p q r _ x => exists_oplus_on_formula cont φl φr _ _ x
  | And_L_2 _ p q r _ x => exists_oplus_on_formula cont φl φr _ _ x
  | Oplus_L _ p q r _ x x0 =>
    if FormulaOrdered.eq_dec p φl
      then if FormulaOrdered.eq_dec q φr
        then cont _ _  x _ _ x0
        else if exists_oplus_on_formula cont φl φr _ _ x then trueP else exists_oplus_on_formula cont φl φr _ _ x0
      else if exists_oplus_on_formula cont φl φr _ _ x then trueP else exists_oplus_on_formula cont φl φr _ _ x0
  | Oplus_R_1 _ p q x => exists_oplus_on_formula cont φl φr _ _ x
  | Oplus_R_2 _ p q x => exists_oplus_on_formula cont φl φr _ _ x
  | T_ _ => falseP
  | Zero_ _ p x => falseP
  | Bang_D _ p q _ x => exists_oplus_on_formula cont φl φr _ _ x
  | Bang_C _ p q _ x => exists_oplus_on_formula cont φl φr _ _ x
  | Bang_W _ p q _ x => exists_oplus_on_formula cont φl φr _ _ x
end.

Program Fixpoint forall_impl_l_on_formula
  (cont:forall (e1:env) (f1:formula) (h1: e1 ⊢ f1) (e2:env) (f2:formula) (h2: e2 ⊢ f2), boolP)
  (φl φr:formula)  (e:env) (f:formula) (h: e ⊢ f) {struct h}: boolP :=
match h with
  | Id _ _ p => trueP
  | Impl_R _ p q x => forall_impl_l_on_formula cont φl φr _ _ x
  | Impl_L _ Δ Δ' p q r _ _ x x0 =>
    if FormulaOrdered.eq_dec p φl
      then if FormulaOrdered.eq_dec q φr
        then cont _ _ x _ _ x0 (*if (cont _ _  x) then falseP else negb (cont _ _  x0) *)
        else
          if forall_impl_l_on_formula cont φl φr _ _ x
            then forall_impl_l_on_formula cont φl φr _ _ x0
            else falseP
      else if forall_impl_l_on_formula cont φl φr _ _ x then forall_impl_l_on_formula cont φl φr _ _ x0 else falseP
  | Times_R _ Δ p q _ _ x x0 => if forall_impl_l_on_formula cont φl φr _ _ x then forall_impl_l_on_formula cont φl φr _ _ x0 else falseP
  | Times_L _ p q r _ x => forall_impl_l_on_formula cont φl φr _ _ x
  | One_R _ _ => trueP
  | One_L _ p _ x => forall_impl_l_on_formula cont φl φr _ _ x
  | And_R _ p q x x0 => if forall_impl_l_on_formula cont φl φr _ _ x then forall_impl_l_on_formula cont φl φr _ _ x0 else falseP
  | And_L_1 _ p q r _ x => forall_impl_l_on_formula cont φl φr _ _ x
  | And_L_2 _ p q r _ x => forall_impl_l_on_formula cont φl φr _ _ x
  | Oplus_L _ p q r _ x x0 => if forall_impl_l_on_formula cont φl φr _ _ x then forall_impl_l_on_formula cont φl φr _ _ x0 else falseP
  | Oplus_R_1 _ p q x => forall_impl_l_on_formula cont φl φr _ _ x
  | Oplus_R_2 _ p q x => forall_impl_l_on_formula cont φl φr _ _ x
  | T_ _ => trueP
  | Zero_ _ p x => trueP
  | Bang_D _ p q _ x => forall_impl_l_on_formula cont φl φr _ _ x
  | Bang_C _ p q _ x => forall_impl_l_on_formula cont φl φr _ _ x
  | Bang_W _ p q _ x => forall_impl_l_on_formula cont φl φr _ _ x
end.
Definition orP (b1 b2:boolP) := if b1 then trueP else b2.
Definition negP (b:boolP) := if b then falseP else trueP.

Definition not_exists_oplus_on_formula lhs rhs (e1:env) (f1:formula) (h1: e1 ⊢ f1) (e2:env) (f2:formula) (h2: e2 ⊢ f2) :=
  negP (orP (exists_oplus_on_formula (fun _ _ _ _ _ _ => trueP) lhs rhs _ _ h1) (exists_oplus_on_formula (fun _ _ _ _ _ _ => trueP) lhs rhs _ _ h2)).

Eval vm_compute in (forall_impl_l_on_formula (not_exists_oplus_on_formula (G⊸1) (G⊸V)) R E _ _ originelle).
Eval vm_compute in (forall_impl_l_on_formula (not_exists_oplus_on_formula 1 ((B ⊸ V) & (B ⊸ 1))) G 1 _ _ originelle).

Program Fixpoint exists_AtheseA_on_formula
  (cont: forall (e1:env) (f1:formula) (h1: e1 ⊢ f1),boolP)
  (φl φr:formula)  (e:env) (f:formula) (h: e ⊢ f) {struct h}: boolP :=
match h with
  | Oplus_R_1 _ p q x =>
    if FormulaOrdered.eq_dec p φl
      then if FormulaOrdered.eq_dec q φr
        then cont _ _  x
        else exists_AtheseA_on_formula cont φl φr _ _ x
      else exists_AtheseA_on_formula cont φl φr _ _ x
  | Oplus_R_2 _ q p x =>
    if FormulaOrdered.eq_dec p φl
      then if FormulaOrdered.eq_dec q φr
        then cont _ _  x
        else exists_AtheseA_on_formula cont φl φr _ _ x
      else exists_AtheseA_on_formula cont φl φr _ _ x
  | Id _ _ p => falseP
  | Impl_R _ p q x => exists_AtheseA_on_formula cont φl φr _ _ x
  | Impl_L _ Δ Δ' p q r _ _ x x0 => exists_AtheseA_on_formula cont φl φr _ _ x0
  | Times_R _ Δ p q _ _ x x0 => if exists_AtheseA_on_formula cont φl φr _ _ x then trueP else exists_AtheseA_on_formula cont φl φr _ _ x0
  | Times_L _ p q r _ x => exists_AtheseA_on_formula cont φl φr _ _ x
  | One_R _ _ => falseP
  | One_L _ p _ x => exists_AtheseA_on_formula cont φl φr _ _ x
  | And_R _ p q x x0 => if exists_AtheseA_on_formula cont φl φr _ _ x then trueP else exists_AtheseA_on_formula cont φl φr _ _ x0
  | And_L_1 _ p q r _ x => exists_AtheseA_on_formula cont φl φr _ _ x
  | And_L_2 _ p q r _ x => exists_AtheseA_on_formula cont φl φr _ _ x
  | Oplus_L _ p q r _ x x0 => if exists_AtheseA_on_formula cont φl φr _ _ x then trueP else exists_AtheseA_on_formula cont φl φr _ _ x0
  | T_ _ => falseP
  | Zero_ _ p x => falseP
  | Bang_D _ p q _ x => exists_AtheseA_on_formula cont φl φr _ _ x
  | Bang_C _ p q _ x => exists_AtheseA_on_formula cont φl φr _ _ x
  | Bang_W _ p q _ x => exists_AtheseA_on_formula cont φl φr _ _ x
end.

Eval vm_compute in exists_AtheseA_on_formula (fun _ _ _ => trueP) A M _ _ originelle.
Eval vm_compute in exists_AtheseA_on_formula (fun _ _ _ => trueP) A M _ _ simpl_ex.

Lemma exists_AtheseA_on_formula_proof_eq_compat :
  ∀ f1 f2 Γ Γ' φ (h1:Γ⊢φ) (h2:Γ'⊢φ),
  Proof_eq.eq h1 h2 ->
    exists_AtheseA_on_formula (fun _ _ _ => trueP) f1 f2 _ _ h1
    = exists_AtheseA_on_formula (fun _ _ _ => trueP) f1 f2 _ _ h2.
Proof.
  intros f1 f2 Γ Γ' φ h1 h2 H.
  induction H;simpl.
  - reflexivity.
  - auto.
  - apply IHeq2.
  - rewrite IHeq1;rewrite IHeq2;reflexivity.
  - rewrite IHeq;reflexivity.
  - reflexivity.
  - rewrite IHeq;reflexivity.
  - rewrite IHeq1;rewrite IHeq2;reflexivity.
  - rewrite IHeq;reflexivity.
  - rewrite IHeq;reflexivity.
  - rewrite IHeq1;rewrite IHeq2;reflexivity.
  - rewrite IHeq;reflexivity.
  - rewrite IHeq;reflexivity.
  - reflexivity.
  - reflexivity.
  - rewrite IHeq;reflexivity.
  - rewrite IHeq;reflexivity.
  - rewrite IHeq;reflexivity.
Qed.

Lemma exists_AtheseA_on_formula_proof_eq_pre_morph_compat :
  ∀ f1 f2 Γ Γ' φ (h1:Γ⊢φ) (h2:Γ==Γ'),
  exists_AtheseA_on_formula (fun _ _ _ => trueP) f1 f2 _ _ h1
  = exists_AtheseA_on_formula (fun _ _ _ => trueP) f1 f2 _ _ (ILL_proof_pre_morph φ Γ Γ' h2 h1).
Proof.
  intros f1 f2 Γ Γ' φ h1 h2.
  apply exists_AtheseA_on_formula_proof_eq_compat.
  apply Proof_eq.sym;apply Proof_eq.eq_pre_morph.
Qed.

Lemma simple: { G, ((B⊸S)&(B⊸R))&1,(G⊸B)⊕(G⊸S)} ⊢ S⊕R.
Proof with try solve [ apply Id;reflexivity | prove_multiset_eq].
  oplus_l (G⊸B) (G⊸S).
  weak_impl_l G B...
  and_l_1 ((B ⊸ S) & (B ⊸ R)) 1.

  and_l_1 (B ⊸ S) (B ⊸ R).
  weak_impl_l B S...
  apply Oplus_R_1...

(*
  and_l_2 (B ⊸ S) (B ⊸ R).
  weak_impl_l B R...
  apply Oplus_R_2...
*)

  weak_impl_l G S...
  and_l_2 ((B ⊸ S) & (B ⊸ R)) 1.
  one_l.
  apply Oplus_R_1...
Defined.

Eval vm_compute in exists_AtheseA_on_formula (fun _ _ _ => trueP) A M _ _ originelle.
Eval vm_compute in exists_AtheseA_on_formula (fun _ _ _ => trueP) S R _ _ originelle.
Eval vm_compute in (exists_AtheseA_on_formula (fun _ _ _ => trueP) S R _ _ simple).
Eval vm_compute in (exists_AtheseA_on_formula (fun _ _ _ => trueP) R S _ _ simple).

Definition all_proofs_of env gamma := (forall (p:env⊢gamma), exists_AtheseA_on_formula (fun _ _ _ => trueP) S R _ _ p =trueP).

Definition no_proof_for env gamma := (forall (p:env⊢gamma), False).
#[local] Hint Unfold all_proofs_of no_proof_for : proof.

Lemma all_proofs_of_pre_morph : forall φ Γ Γ',
  all_proofs_of Γ φ -> eq_bool Γ Γ' = true -> all_proofs_of Γ' φ.
Proof.
  unfold all_proofs_of.
  intros φ Γ Γ' Hall Heq p.
  apply eq_bool_correct in Heq.
  assert (h:exists p': Γ⊢φ, Proof_eq.eq p p').
    symmetry in Heq; exists (ILL_proof_pre_morph _ _ _ Heq p).
    apply Proof_eq.sym;apply Proof_eq.eq_pre_morph.
      destruct h as [p' h].
      rewrite exists_AtheseA_on_formula_proof_eq_compat with (h2:=p') (1:=h); auto.
Qed.
#[local] Hint Resolve all_proofs_of_pre_morph : proof.

Lemma all_proofs_of_pre_morph' :
  forall φ Γ Γ', all_proofs_of Γ φ -> eq_bool Γ Γ' = true ->
    forall (p:Γ'⊢φ), exists_AtheseA_on_formula (fun _ _ _ => trueP) S R _ _ p =trueP.
Proof.
  intros φ Γ Γ' H H0 p.
  eapply all_proofs_of_pre_morph;eassumption.
Qed.
#[local] Hint Resolve all_proofs_of_pre_morph' : proof.
#[local] Hint Rewrite all_proofs_of_pre_morph' : proof.
Require Import Setoid.
Add Morphism all_proofs_of with signature (eq ==> Logic.eq ==> iff) as
all_proof_of_morph.
Proof.
  intros x y H y0.
  split;intros; eapply all_proofs_of_pre_morph;try eassumption.
  apply eq_bool_complete;assumption.
  apply eq_bool_complete;symmetry;assumption.
Qed.

#[local] Hint Extern 0 ( _ ==  _ ) => apply eq_bool_correct;vm_compute;reflexivity : proof.

Tactic Notation "complete" tactic1(t) := t; fail.

Ltac clean p :=
  try (complete eauto 2 with proof);
  (dependent simple inversion p||inversion p);clear p;subst;try discriminate;simpl.

Ltac decompose_add :=
    repeat (match goal with
            | H : _ ∈ (_ :: _) |- _  =>
              destruct (mem_destruct _ _ _ H);clear H
            | H : _ ∈ ∅ |- _ =>
              rewrite empty_no_mem in H;discriminate
            | H : ILLVarInt.MILL.eq _ _ |- _ => apply eq_is_eq in H;subst
          end).

Ltac var_not_in_env_tac_simple n' H :=
elim unusable_var_in_env with (n:=n') (1:=H);
[
  vm_compute;reflexivity |
  vm_compute;reflexivity |
  vm_compute;reflexivity |
  vm_compute;reflexivity |
    intros;decompose_add;simpl in *;repeat split;try discriminate;reflexivity
].

Ltac var_not_in_env_tac_aux H env :=
  match env with
    | Proposition ?n::?env' =>
      (complete (var_not_in_env_tac_simple n H)) ||
        var_not_in_env_tac_aux H env'
    | _ :: ?env' =>  var_not_in_env_tac_aux H env'
  end.

Ltac var_not_in_env_tac H :=
  match type of H with
    | ?env ⊢ _ =>
      var_not_in_env_tac_aux H env
  end.
Ltac is_var_env gamma :=
  match gamma with
    | empty => fail 1
    | _ :: _ => fail 1
    | _ \ _ => fail 1
    | _ ∪ _ => fail 1
    | _ => idtac
  end.

Ltac finish :=
  simpl;try reflexivity;
    try discriminate;
    try (complete auto with proof);
    try autorewrite with proof;
      try (complete (apply False_ind;auto with proof));
      match goal with
        |- (if ?e then trueP else trueP ) = trueP =>
          case e;reflexivity
        | i:?e⊢Proposition ?n' |- _ =>
          elim var_in_env with (n:=n') (3:=i);vm_compute;reflexivity
        | H: ?env⊢?g |- _ =>
          complete var_not_in_env_tac H
        | H : ?s == ?t |- _ =>
          (complete (apply eq_bool_complete in H;vm_compute in H;
            discriminate))|| (progress repeat (rewrite H in * ))
      end.

Ltac decomp :=
  simpl;try reflexivity;
  try discriminate;
  (* try complete auto with proof; *)
  (* try autorewrite with proof; *)
  match goal with
  | H : ?t = ?t |- _ => clear H
  | H : ?t == ?t |- _ => clear H
  | H:_ :: _ == _ ∪ _ |- _ =>
    symmetry in H
  | H: _ ∪ _ == _ :: _ |- _ =>
    let delta := fresh "Δ" in
    let h1 := fresh "H" in
    let h2 := fresh "H" in
    destruct (union_decompose _ _ _ _ H)
      as [[delta [h1 h2]]|[delta [h1 h2]]];clear H
  | H: empty == _ ∪ _ |- _ =>
    symmetry in H
  | H: _ ∪ _ == empty |- _ =>
    let h1 := fresh "H" in
    let h2 := fresh "H" in
    destruct (union_empty_decompose _ _  H) as [h1 h2];
    clear H
  | H : ?t == _ |- _ =>
    is_var_env t;
    match goal with
    | H': context [t] |- _ =>
      match H' with
      | H => fail 1
      | _ => fail 2
      end
    | _ => clear H
    end
  | H: ILLVarInt.MILL.eq _ _ |- _ => apply eq_is_eq in H; try (injection H;clear H;intros;subst)

  | H: _ ∈ _ |- _ => complete (vm_compute in H;discriminate)
  | H: _ ∈ (add _ _) |- _ =>
    destruct (mem_destruct _ _ _ H);clear H
  (* | H : ?s == ?t |- _ =>  *)
  (*   (complete (apply eq_bool_complete in H;vm_compute in H; *)
  (*     discriminate))|| (progress repeat (rewrite H in * )) *)
  | H : ?s == ?t |- _ =>
    (progress repeat (rewrite H in * ))
  | H: context C [ remove ?f ?env ] |- _ =>
    match env with
      context C' [ add f ?env' ] =>
      let e := context C' [ env' ] in
      setoid_replace (remove f env) with e in H by (apply eq_bool_correct;vm_compute;reflexivity)
    end
  | H:(?x ⊸ ?y) = _  |- _ =>
    try discriminate H;injection H;clear H;intros;subst
  | H: (_ ⊕ _) = _  |- _ =>
    try discriminate H;injection H;clear H;intros;subst
  | H:(_ ⊗ _) = _ |- _  =>
    try discriminate H;injection H;clear H;intros;subst
  | H: _  & _ = _  |- _  =>
    try discriminate H;injection H;clear H;intros;subst
  | H: _ = (?x ⊸ ?y) |- _ =>
    try discriminate H;injection H;clear H;intros;subst
  | H: _ = (_ ⊕ _) |- _ =>
    try discriminate H;injection H;clear H;intros;subst
  | H: _ = (_ ⊗ _) |- _  =>
    try discriminate H;injection H;clear H;intros;subst
  | H: _ = _  & _ |- _  =>
    try discriminate H;injection H;clear H;intros;subst
  | H: ?delta ⊢ _, H' : ?delta == ∅ |- _ =>
    apply False_ind;rewrite H' in H;clear - H;clean H;finish
  | H: ?env⊢?g |- _ =>
    (* try complete var_not_in_env_tac H;  *)
    match env with
    | context C' [?env' \ ?f] =>
      match env' with
      | context C [add f ?env''] =>
        let e' := context C [ env'' ] in
        let e := context C' [ e' ] in
        assert (heq: e == env) by (apply eq_bool_correct;vm_compute;reflexivity);
        symmetry in heq;
        let h := fresh "H" in
        let i' := fresh "i" in
        assert (h:(exists i':ILL_proof e g, Proof_eq.eq H i')) by (exists (ILL_proof_pre_morph _ _ _ heq H);
                                                                          apply Proof_eq.sym;
                                                                          apply Proof_eq.eq_pre_morph);
        destruct h as [i' h];
        rewrite exists_AtheseA_on_formula_proof_eq_compat with (h2:=i') (1:=h);
        clear H h heq
      end
    end
  | H: ?t == ?t', i: ?env⊢?f |- _ =>
    match env with
    | context [ t ] =>
      let f_env := (match eval pattern t in env with
                    | ?f _ => f
                    end) in
      let env'0 := constr:(f_env t')  in
      let env' := (eval cbv beta iota in env'0) in
      let h := fresh "H" in
      let i' := fresh "i" in
      let heq := fresh "heq" in
      assert (h:exists i': env'⊢f, Proof_eq.eq i i');[
        assert (heq:env'==env) by (rewrite H;reflexivity);
        symmetry in heq;
        exists (ILL_proof_pre_morph _ _ _ heq i);
        apply Proof_eq.sym;apply Proof_eq.eq_pre_morph
      | destruct h as [i' h];
        rewrite exists_AtheseA_on_formula_proof_eq_compat with (h2:=i') (1:=h);
        clear i h;try (rewrite H in *;clear H)
      ]
    end
  end.

Ltac one_step p := clean p; (repeat decomp);try (complete finish);auto with proof;eauto 3 with proof.

Ltac unusable_implies_tac n' f H :=
  apply unusable_implies with (1:=H) (n:=n') (φ:=f);
    [
      vm_compute;reflexivity |
        vm_compute;reflexivity |
          vm_compute;reflexivity |
            intros;decompose_add;repeat split;simpl in *;try discriminate;reflexivity].

Ltac unusable_var_strong_tac n1 n2 H :=
  apply unusable_var_in_env_strong with (1:=H) (n:=n1);[
  vm_compute;reflexivity|
  vm_compute;reflexivity|
  vm_compute;reflexivity|
  vm_compute;reflexivity|
  intros;decompose_add;simpl in *;  repeat split;try discriminate;try reflexivity;auto;
  intros _;right;
  exists n2;
    split;[((left;reflexivity)||(right;reflexivity))|split;[
      intros;decompose_add;simpl;reflexivity|vm_compute;reflexivity]]].

Lemma aux3 : all_proofs_of ({S}) (S ⊕ R).
Proof.
  intro p;one_step p.
Qed.

Lemma aux4 : no_proof_for ({G ⊸ S, B ⊸ S, G}) (S ⊕ R).
Proof.
  intros p.
  unusable_implies_tac 4 S p.
Qed.
Lemma aux4' : no_proof_for ({B ⊸ S,G ⊸ S,  G}) (S ⊕ R).
Proof.
  intros p.
  unusable_implies_tac 4 S p.
Qed.

Lemma aux2 : all_proofs_of ({B ⊸ S, G, (G ⊸ B) ⊕ (G ⊸ S)}) (S ⊕ R).
Proof.
  intros p; one_step p.
  - apply aux3.
  - apply False_ind.
    apply aux4.
    assumption.
Qed.

Lemma aux6 : no_proof_for ({G, (G ⊸ B) ⊕ (G ⊸ S)}) B.
Proof.
  intros p. one_step p.
Qed.

Lemma aux8 : ∀ x, no_proof_for ({B ⊸ R, G}) (Proposition x).
Proof.
  intros H p.
  unusable_implies_tac 4 R p.
Qed.

Lemma aux9 : no_proof_for ({S,B ⊸ R}) (S ⊕ R).
Proof.
  intros p.
  unusable_implies_tac 4 R p.
Qed.

Lemma aux9' : no_proof_for ({B ⊸ R,S}) (S ⊕ R).
Proof.
  intros p.
  unusable_implies_tac 4 R p.
Qed.

Lemma aux9's : no_proof_for ({B ⊸ R,S}) S.
Proof.
  intros p.
  unusable_implies_tac 4 R p.
Qed.
Lemma aux10 : ∀ x,no_proof_for ({G ⊸ S, B ⊸ R, G}) (Proposition x).
Proof.
  intros H p.
  unusable_implies_tac 4 R p.
Qed.

Lemma aux11 : no_proof_for ({B ⊸ R, G, (G ⊸ B) ⊕ (G ⊸ S)}) S.
Proof.
  intros p; one_step p.
Qed.
Lemma aux12 : no_proof_for ({B ⊸ R, G, (G ⊸ B) ⊕ (G ⊸ S)}) R.
Proof.
  intros p; one_step p.
  apply aux6;assumption.
  eapply aux10;eassumption.
Qed.

Lemma aux7 : no_proof_for ({G ⊸ S, B ⊸ R, G}) (S ⊕ R).
Proof.
  intro p. one_step p.
  eapply aux8;eassumption.
  eapply aux9. eassumption.
  eapply aux10. eassumption.
  eapply aux10. eassumption.
Qed.

Lemma aux5 : no_proof_for ({B ⊸ R, G, (G ⊸ B) ⊕ (G ⊸ S)}) (S ⊕ R).
Proof.
  intros p; one_step p.
  apply False_ind.
  apply aux6.
  assumption.
  apply aux7;assumption.
  apply aux11;assumption.
  apply aux12;assumption.
Qed.

Lemma aux13 : no_proof_for ({B ⊸ R, G, (G ⊸ B) ⊕ (G ⊸ S)}) (S ⊕ R).
  intros p; one_step p.
  apply aux6. assumption.
  apply aux7. assumption.
  apply aux11. assumption.
  apply aux12. assumption.
Qed.

Lemma aux16 :no_proof_for ({B ⊸ S, G}) G.
  intro p. unusable_implies_tac 4 S p.
Qed.

Lemma aux15 :no_proof_for ({(B ⊸ S) & (B ⊸ R), G}) G.
  intro p. one_step p.
  apply aux16. assumption.
  eapply aux8;eassumption.
Qed.

Lemma aux18 : no_proof_for ({B ⊸ S, S}) (S ⊕ R).
  intro p. unusable_implies_tac 4 S p.
Qed.

Lemma aux18s :no_proof_for ({B ⊸ S, S}) (S).
  intro p. unusable_implies_tac 4 S p.
Qed.

Lemma aux19 : no_proof_for ({S, (B ⊸ S) & (B ⊸ R)}) S.
  intro p. one_step p.

  apply aux18s. assumption.
  apply aux9's. assumption.
Qed.

Lemma aux17 : no_proof_for ({S, (B ⊸ S) & (B ⊸ R)}) (S ⊕ R).
  intro p. one_step p.
  apply aux18. assumption.
  apply aux9'. assumption.
  apply aux19. assumption.
Qed.
Lemma aux10' : no_proof_for ({B ⊸ R,G ⊸ S, G}) (S ⊕ R).
Proof.
  intros p.
  unusable_implies_tac 4 R p.
Qed.
Lemma aux10's : no_proof_for ({B ⊸ R,G ⊸ S, G}) S.
Proof.
  intros p.
  unusable_implies_tac 4 R p.
Qed.
Lemma aux21 : no_proof_for ({(B ⊸ S) & (B ⊸ R), G}) G.
  intro p. one_step p.
  apply aux16. assumption.
  eapply aux8. eassumption.
Qed.
Lemma aux15s : no_proof_for ({S,(B ⊸ S) & (B ⊸ R)}) S.
  intro p. one_step p.

  apply aux18s. assumption.
  eapply aux9's;eassumption.
Qed.
Lemma aux4's : no_proof_for ({B ⊸ S,G ⊸ S,  G}) S.
Proof.
  intros p.
  unusable_implies_tac 4 S p.
Qed.

Lemma aux20 : no_proof_for ({G ⊸ S, (B ⊸ S) & (B ⊸ R), G}) S.
  intro p. one_step p.
  apply aux21. assumption.
  apply aux15s. assumption.
  apply aux4's. assumption.
  apply aux10's. assumption.
Qed.
Lemma aux10'r : no_proof_for ({B ⊸ R,G ⊸ S, G}) R.
Proof.
  intros p.
  unusable_implies_tac 4 R p.
Qed.
Lemma aux22 : no_proof_for ({G ⊸ S, (B ⊸ S) & (B ⊸ R), G}) R.
  intro p. one_step p.

  apply aux10'r. assumption.
Qed.
Lemma aux14 : no_proof_for ({G ⊸ S, (B ⊸ S) & (B ⊸ R), G}) (S ⊕ R).
  intro p. one_step p.
  apply  aux15. assumption.
  apply aux17. assumption.
  apply aux4'. assumption.
  apply aux10'. assumption.
  apply aux20. assumption.
  apply aux22. assumption.
Qed.

#[local] Hint Resolve aux3 aux4 aux4' aux2 aux6 aux8 aux9 aux9' aux9's
  aux10 aux11 aux12 aux7 aux5 aux13 aux16 aux15
  aux18 aux18s aux19 aux17 aux10' aux10's aux21
  aux15s aux4's aux20 aux10'r aux22 aux14 : proof.

Lemma aux23 : no_proof_for ({(B ⊸ S) & (B ⊸ R), G, (G ⊸ B) ⊕ (G ⊸ S)}) R.
  intro p. one_step p.
Qed.

Lemma aux25 : no_proof_for ({G ⊸ B, G}) (S⊕R).
Proof.
  intros p. one_step p.
Qed.
Lemma aux6'' : no_proof_for ({G, (G ⊸ B) ⊕ (G ⊸ S)}) (S).
Proof.
  intros p. one_step p.
Qed.
Lemma aux6' : no_proof_for ({G, (G ⊸ B) ⊕ (G ⊸ S)}) (S⊕R).
Proof.
  intros p. one_step p.

  apply aux25. assumption.

  apply aux6''. assumption.
Qed.
Lemma aux26 : no_proof_for ({G ⊸ B, 1, G}) (S ⊕ R).
  intro p. one_step p.
  apply aux25;assumption.
Qed.
Lemma aux24s : no_proof_for ({1, G, (G ⊸ B) ⊕ (G ⊸ S)}) S.
  intro p. one_step p.
  apply aux6''. assumption.
Qed.

Lemma aux24 : no_proof_for ({1, G, (G ⊸ B) ⊕ (G ⊸ S)}) (S ⊕ R).
  intro p. one_step p.

  apply aux6'. assumption.
  apply aux26. assumption.

  apply aux24s. assumption.
Qed.

#[local] Hint Resolve aux23 aux25 aux6'' aux6' aux26 aux24s aux24 : core.

Lemma aux1 : all_proofs_of ({(B ⊸ S) & (B ⊸ R), G, (G ⊸ B) ⊕ (G ⊸ S)}) (S ⊕ R).
  intros p; one_step p.
Qed.
Lemma aux27r : no_proof_for ({G ⊸ S, G, ((B ⊸ S) & (B ⊸ R)) & 1}) R.
  intros p; one_step p.
Qed.

Lemma aux31 : no_proof_for ({G, ((B ⊸ S) & (B ⊸ R)) & 1, (G ⊸ B) ⊕ (G ⊸ S)}) R.
  intros p.
  one_step p.
  apply aux27r. assumption.
Qed.

Lemma aux29 : no_proof_for ({(B ⊸ S) & (B ⊸ R), S}) (S ⊕ R).
  intros p; one_step p.
Qed.
Lemma aux30 : all_proofs_of ({1, S}) (S ⊕ R).
  intros p; one_step p.
Qed.
Lemma aux28 : all_proofs_of ({S, ((B ⊸ S) & (B ⊸ R)) & 1}) (S ⊕ R).
  intros p; one_step p.
  apply False_ind. apply aux29. assumption.
  apply aux30.
Qed.

#[local] Hint Resolve aux27r aux31 aux29 aux30 aux28 : core.

Lemma aux32 : no_proof_for ({(B ⊸ S) & (B ⊸ R), G ⊸ S, G}) (S ⊕ R).
  intros p; one_step p.
Qed.

Lemma aux34 : all_proofs_of ({G ⊸ S, G}) (S ⊕ R).
  intros p; one_step p.
Qed.

Lemma aux33 : all_proofs_of ({1, G ⊸ S, G}) (S ⊕ R).
  intros p; one_step p.
  apply aux34.
Qed.

Lemma aux27 : all_proofs_of ({G ⊸ S, G, ((B ⊸ S) & (B ⊸ R)) & 1}) (S ⊕ R).
  intros p; one_step p.
  apply False_ind. apply aux32. assumption.
  apply aux33.
Qed.

#[local] Hint Resolve aux34 aux33 aux27 : core.

Lemma final: all_proofs_of ({ G,((B⊸S)&(B⊸R))&1,(G⊸B)⊕(G⊸S)}) (S⊕R).
Proof.
  intros p; one_step p.

  apply aux1.

  rewrite aux27.
  destruct (exists_AtheseA_on_formula
         (λ (e1 : env) (f1 : formula) (_ : e1 ⊢ f1), trueP)
         S R ({G ⊸ B, G, ((B ⊸ S) & (B ⊸ R)) & 1})
         (S ⊕ R) i1
    ); reflexivity.
Qed.

(* {G,G -o S,R, R -o E, !(S -o A), (E -o A) & 1, ...} |- A ++ M *)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e189m25_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e127m1_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.