From Tealeaves Require Export
  Axioms
  LibTactics.

(*|
Declare a scope for Tealeaves' notations.
|*)

Declare Scope tealeaves_scope.
Delimit Scope tealeaves_scope with tea.
#[global] Open Scope tealeaves_scope.

(*|
Open <<type_scope>> globally because (\*\) should mean [prod]
|*)

#[global] Open Scope type_scope.

(** * General operations *)

(** General-purpose functions used throughout Tealeaves. *)
(******************************************************************************)

(** We use <<exfalso>> to reason about traversable functors. *)
Definition exfalso {A : Type} : False -> A :=
  fun bot => match bot with end.

#[local] Generalizable All Variables.

Polymorphic Definition compose {A B C} (g : B -> C) (f : A -> B) : A -> C := fun a => g (f a).

Notation "g ∘ f" := (compose g f) (at level 40, left associativity).

(** Helpful to avoid inserting a hidden <<compose>> between two
    functors that would later need to be unfolded. TODO Get rid of this. *)
Notation "F ○ G" := (fun X => F (G X)) (at level 40, left associativity).

Lemma compose_assoc `{f : C -> D} `{g : B -> C} `{h : A -> B} :
  f ∘ (g ∘ h) = (f ∘ g) ∘ h.
Proof.
  reflexivity.
Qed.

Definition const {A B : Type} (b : B) : A -> B := fun _ => b.

Definition evalAt `(a : A) `(f : A -> B) := f a.

Definition strength_arrow `(p : A * (B -> C)) : B -> A * C := fun b => (fst p, snd p b).

Definition costrength_arrow `(p : (A -> B) * C) : A -> B * C := fun a => (fst p a, snd p).

Definition pair_right {A B} : B -> A -> A * B := fun b a => (a, b).

Definition precompose {A B C} := (fun (f : A -> B) (g : B -> C)  => g ○ f).

Theorem commute_hom_action1 :
  forall (A B C D : Type) (f1 : A -> B) (f2 : B -> C) (f3 : C -> D),
    compose f3 (precompose f1 f2) = precompose f1 (compose f3 f2).
Proof.
  reflexivity.
Qed.

Theorem commute_hom_action2 :
  forall (A B C D : Type) (f1 : A -> B) (f3 : C -> D),
    compose f3 ∘ precompose f1 = precompose f1 ∘ compose f3.
Proof.
  reflexivity.
Qed.

(** * Tactics *)
(******************************************************************************)

(** ** Tactics for rewriting *)
(******************************************************************************)

(** *** Rewriting the left or right side of an equation *)
(******************************************************************************)
Ltac get_lhs :=
  match goal with
  | |- ?R ?f ?g =>
    constr:(f)
  end.

Ltac get_rhs :=
  match goal with
  | |- ?R ?f ?g =>
    constr:(g)
  end.

Ltac change_left new :=
  match goal with
  | |- ?R ?f ?g =>
    change (R new g)
  end.

Ltac change_right new :=
  match goal with
  | |- ?R ?f ?g =>
    change (R f new)
  end.

Tactic Notation "change" "left" constr(new) := change_left new.
Tactic Notation "change" "right" constr(new) := change_right new.

(** *** Re-association of an expression *)
(******************************************************************************)
Tactic Notation "reassociate" "<-" := rewrite compose_assoc.
Tactic Notation "reassociate" "<-" "in" ident(h) := rewrite compose_assoc in h.
Tactic Notation "reassociate" "->" := rewrite <- compose_assoc.
Tactic Notation "reassociate" "->" "in" ident(h):= rewrite <- compose_assoc in h.

Ltac guard_left x :=
  let lhs := get_lhs in pose (x := lhs); change_left x.

Ltac guard_right x :=
  let rhs := get_rhs in pose (x := rhs); change_right x.

Ltac reassociate_left_on_right :=
  let x := fresh "guard" in
  guard_left x; reassociate <-; subst x.

Ltac reassociate_right_on_right :=
  let x := fresh "guard" in
  guard_left x; reassociate ->; subst x.

Ltac reassociate_left_on_left :=
  let x := fresh "guard" in
  guard_right x; reassociate <-; subst x.

Ltac reassociate_right_on_left :=
  let x := fresh "guard" in
  guard_right x; reassociate ->; subst x.

Tactic Notation "reassociate" "<-" "on" "left" := reassociate_left_on_left.
Tactic Notation "reassociate" "->" "on" "left" := reassociate_right_on_left.
Tactic Notation "reassociate" "<-" "on" "right" := reassociate_left_on_right.
Tactic Notation "reassociate" "->" "on" "right" := reassociate_right_on_right.

(** We wrap <<reassociate_xxx_near>> with <<progress>> to detect situations in
    which the <<change>> simply fails to match (and thus has no effect), which
    in practice indicates a user mistake. *)
Ltac reassociate_right_near f3 :=
  progress (change (?f1 ∘ ?f2 ∘ f3) with (f1 ∘ (f2 ∘ f3))).

Ltac reassociate_left_near f1 :=
  progress (change (f1 ∘ (?f2 ∘ ?f3)) with (f1 ∘ f2 ∘ f3)).

Tactic Notation "reassociate" "->" "near" uconstr(f3) := reassociate_right_near f3.
Tactic Notation "reassociate" "<-" "near" uconstr(f1) := reassociate_left_near f1.

(** *** Expressing functions as compositions *)
(******************************************************************************)
Ltac compose_near arg :=
  progress (change (?f (?g arg)) with ((f ∘ g) arg)).

Ltac compose_near_on_left arg :=
  let x := fresh "guard" in
  guard_right x; compose_near arg; subst x.

Ltac compose_near_on_right arg :=
  let x := fresh "guard" in
  guard_left x; compose_near arg; subst x.

Tactic Notation "compose" "near" constr(arg) := compose_near arg.
Tactic Notation "compose" "near" constr(arg) "on" "left" := compose_near_on_left arg.
Tactic Notation "compose" "near" constr(arg) "on" "right" := compose_near_on_right arg.

(** *** Rewriting with setoids *)
(******************************************************************************)
Tactic Notation "rewrites" uconstr(r1) :=
  setoid_rewrite r1.

Tactic Notation "rewrites" uconstr(r1) "," uconstr(r2) :=
  rewrites r1; rewrites r2.

Tactic Notation "rewrites" uconstr(r1) "," uconstr(r2) "," uconstr(r3):=
  rewrites r1; rewrites r2, r3.

Tactic Notation "rewrites" uconstr(r1) "," uconstr(r2) "," uconstr(r3) "," uconstr(r4) :=
  rewrites r1; rewrites r2, r3, r4.

(** ** Unfolding operational typeclasses *)
(******************************************************************************)
Ltac head_of expr :=
  match expr with
  | ?f ?x => head_of f
  | ?head => head
  | _ => fail
  end.

Ltac head_of_matches expr head :=
  match expr with
  | ?f ?x =>
    head_of_matches f head
  | head => idtac
  | _ => fail
  end.

Goal False.
  Fail head_of_matches 0 S. (* Tactic failure. *)
  head_of_matches (S 0) S. (* Success *)
  head_of_matches 5 S. (* Success *)
Abort.

(** Unfold operational typeclasses in the goal. *)
Ltac unfold_operational_tc inst :=
  repeat (match goal with
          | |- context[?op ?maybe_inst] =>
            head_of_matches maybe_inst inst;
            change (op maybe_inst) with maybe_inst
          | |- context[?op ?F ?maybe_inst] =>
            head_of_matches maybe_inst inst;
            change (op F maybe_inst) with maybe_inst
          | |- context[?op ?F ?G ?maybe_inst] =>
            head_of_matches maybe_inst inst;
            change (op F G inst) with maybe_inst
          | |- context[?op ?F ?G ?H ?maybe_inst] =>
            head_of_matches maybe_inst inst;
            change (op F G H inst) with maybe_inst
          | |- context[?op ?F ?G ?H ?I ?maybe_inst] =>
            head_of_matches maybe_inst inst;
            change (op F G H I inst) with maybe_inst
          | |- context[?op ?F ?G ?H ?I ?J ?maybe_inst] =>
            head_of_matches maybe_inst inst;
            change (op F G H I J inst) with maybe_inst
          | |- context[?op ?F ?G ?H ?I ?J ?K ?maybe_inst] =>
            head_of_matches maybe_inst inst;
            change (op F G H I J K inst) with maybe_inst
          end); unfold inst.

(** Unfold operational typeclasses in hypotheses. *)
Ltac unfold_operational_tc_hyp :=
  repeat (match goal with
          | H : context[?op ?maybe_inst] |- _ =>
            head_of_matches maybe_inst inst;
            change (op maybe_inst) with maybe_inst in H
          | H :context[?op ?F ?maybe_inst] |- _ =>
            head_of_matches maybe_inst inst;
            change (op F maybe_inst) with maybe_inst
          | H :context[?op ?F ?G ?maybe_inst] |- _ =>
            head_of_matches maybe_inst inst;
            change (op F G inst) with maybe_inst
          | H :context[?op ?F ?G ?H ?maybe_inst] |- _ =>
            head_of_matches maybe_inst inst;
            change (op F G H inst) with maybe_inst
          | H :context[?op ?F ?G ?H ?I ?maybe_inst] |- _ =>
            head_of_matches maybe_inst inst;
            change (op F G H I inst) with maybe_inst
          | H :context[?op ?F ?G ?H ?I ?J ?maybe_inst] |- _ =>
            head_of_matches maybe_inst inst;
            change (op F G H I J inst) with maybe_inst
          | H :context[?op ?F ?G ?H ?I ?J ?K ?maybe_inst] |- _ =>
            head_of_matches maybe_inst inst;
            change (op F G H I J K inst) with maybe_inst
          end); unfold inst.

Tactic Notation "unfold_ops" constr(inst) :=
  unfold_operational_tc inst.

Tactic Notation "unfold_ops" constr(inst) constr(inst1) :=
  unfold_ops inst; unfold_ops inst1.

Tactic Notation "unfold_ops" constr(inst) constr(inst1) constr(inst2) :=
  unfold_ops inst; unfold_ops inst1 inst2.

Tactic Notation "unfold_ops" constr(inst) "in" "*" :=
  unfold_operational_tc inst;
    unfold_operational_tc_hyp inst.

Tactic Notation "unfold_ops" constr(inst) constr(inst1) "in" "*" :=
  unfold_ops inst in *; unfold_ops inst1 in *.

Tactic Notation "unfold_ops" constr(inst) constr(inst1) constr(inst2) "in" "*" :=
  unfold_ops inst in *; unfold_ops inst1 in *; unfold_ops inst2 in *.

(** Unfold all operational typeclasses. This will unfold anything that
    looks like an operational typeclass. *)
(******************************************************************************)
Ltac unfold_all_transparent_tcs :=
  repeat (match goal with
          | |- context[?op ?inst] =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op inst) with x
          | |- context[?op ?F ?inst] =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F inst) with x
          | |- context[?op ?F ?G ?inst] =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G inst) with x
          | |- context[?op ?F ?G ?H ?inst] =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G H inst) with x
          | |- context[?op ?F ?G ?H ?I ?inst] =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G H I inst) with x
          | |- context[?op ?F ?G ?H ?I ?J ?inst] =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G H I J inst) with x
          | |- context[?op ?F ?G ?H ?I ?J ?K ?inst] =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G H I J K inst) with x
          end); cbn beta zeta.

Ltac unfold_all_transparent_tcs_hyp :=
  repeat (match goal with
          | H :context[?op ?inst] |- _ =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op inst) with x
          | H :context[?op ?F ?inst] |- _ =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F inst) with x
          | H :context[?op ?F ?G ?inst] |- _ =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G inst) with x
          | H :context[?op ?F ?G ?H ?inst] |- _ =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G H inst) with x
          | H :context[?op ?F ?G ?H ?I ?inst] |- _ =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G H I inst) with x
          | H :context[?op ?F ?G ?H ?I ?J ?inst] |- _ =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G H I J inst) with x
          | H :context[?op ?F ?G ?H ?I ?J ?K ?inst] |- _ =>
            let hd := get_head inst in
            let x := eval unfold hd at 1 in inst in
                change (op F G H I J K inst) with x
          end); cbn beta zeta.

Tactic Notation "unfold" "transparent" "tcs" :=
  unfold_all_transparent_tcs.

Tactic Notation "unfold" "transparent" "tcs" "in" "*" :=
  unfold_all_transparent_tcs; unfold_all_transparent_tcs_hyp.

(** ** Support for comparing natural numbers *)
(******************************************************************************)
From Coq.Arith Require Import
     PeanoNat Compare_dec.

(** This gives access to the [lia] tactic *)
Require Export Psatz.

(** This lemma reduces a goal to three subgoals based on the possible ordering
    between two natural numbers. Each branch may invoke two hypothesis, one
    stipulating the ordering and the other stipulating an equation for
    [Nat.compare]. *)
Lemma comparison_naturals : forall (n m : nat) (p : Prop),
    (n ?= m = Lt -> n < m -> p) ->
    (n ?= m = Eq -> n = m -> p) ->
    (n ?= m = Gt -> n > m -> p) ->
    p.
Proof.
  intros n m ? ?lt ?eq ?gt.
  destruct (lt_eq_lt_dec n m) as [[? | ?] |];
    rewrite ?Nat.compare_eq_iff,
    ?Nat.compare_lt_iff, ?Nat.compare_gt_iff in *;
    auto.
Qed.

(** Compare natural numbers with [comparison_naturals], the try rewriting
    occurrences in [Nat.compare] and other basic tactics.*)
Ltac compare_nats_args n k :=
  apply (@comparison_naturals n k);
  (let ineq := fresh "ineq"
    with ineqp := fresh "ineqp"
    with ineqrw := fresh "ineqrw" in
    intros ineqrw ineqp;
    repeat rewrite ineqrw in *;
    (* In the n = k case, substitute the equality *)
    try match type of ineqp with
        | ?x = ?y => subst
        end; try lia; repeat f_equal; try lia; try reflexivity).

Tactic Notation "compare" "naturals" constr(n) "and" constr(m) :=
  compare_nats_args n m.

(** ** General tactics *)
(******************************************************************************)
Ltac invert_pair_eq :=
  match goal with
  | H : (?x, ?y) = (?z, ?w) |- _ =>
      inversion H
  end.

Ltac injection_all :=
  repeat match goal with
    | H : ?f = ?g |- _ =>
        injection H; intros; clear H
    end.

Ltac destruct_all_existentials :=
  repeat match goal with
    | H : exists (x : ?A), ?P |- _ =>
        let x := fresh "x" in
        let H' := fresh "H" in
        destruct H as [x H']
    end.

Ltac destruct_all_pairs :=
  repeat match goal with
    | H : ?P1 /\ ?P2 |- _ =>
        destruct H
    | H : prod ?A ?B |- _ =>
        destruct H
    end.

Ltac preprocess :=
  repeat (destruct_all_pairs +
            destruct_all_existentials +
            injection_all + subst).

Tactic Notation "pp" tactic(tac) :=
  preprocess; tac.


(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

From Coq Require Import Arith List.
From CoLoR Require Import more_list list_sort term_spec ac cf_eq_ac matching_sound.

Module Type S.

Declare Module Import SMatching : matching_sound.S.
Import WFMMatching WFMatching Matching Cf_eq_ac Ac EqTh T.

(* Parameter remove_a_subterm
Parameter remove_several_subterms
Parameter remove_several_subterms_bis
Parameter remove_several_subterms_bis_nil *)
Parameter solve_is_complete :
  forall pb, well_formed_pb pb -> forall sigma, is_well_formed_sol pb sigma ->
  match pb.(unsolved_part) with
  | nil => True
    | _ :: _ => exists pb', In pb' (solve pb) /\ is_well_formed_sol pb' sigma
  end.

End S.

Module Make (SMatching1 : matching_sound.S) :
 S with Module SMatching := SMatching1.
Module SMatching := SMatching1.

Import SMatching1 WFMMatching WFMatching Matching Cf_eq_ac Ac EqTh T F X Sort LPermut.

Lemma remove_a_subterm :
  forall sigma f v l1 t l2, arity f = AC -> well_formed_cf_subst sigma ->
  well_formed_cf (Term f (Var v :: l1)) ->
  well_formed_cf (Term f l2)  ->
  apply_cf_subst sigma (Var v) = t ->
  apply_cf_subst sigma (Term f (Var v :: l1)) = Term f l2 ->
  match remove T.eq_bool t l2 with
  | None =>
        match t with
        | Var _ => False
        | Term g _ => f=g
        end
  | Some rmv =>  apply_cf_subst sigma (build f l1) = build f rmv
  end.
Proof.
intros sigma f v l1 t l2 Ar W_sigma Wt1 Wt2 v_sigma t1_sigma.
generalize (in_remove _ _ T.eq_bool_ok t l2);
destruct (remove T.eq_bool t l2) as [l2''' | ].
intros [cp1 [l2' [l2'' [ H'' [l2_eq l2'''_eq]]]]]; subst cp1.
injection l2'''_eq; clear l2'''_eq; intro; subst l2 l2''';
apply flatten_cf with f; trivial.
apply well_formed_cf_apply_subst; trivial;
apply well_formed_cf_build_cons with (Var v); trivial.
apply well_formed_cf_build_inside with t; trivial.
rewrite <- (flatten_apply_cf_subst sigma l1 Ar);
rewrite (flatten_build (l2' ++ l2'') Ar).
simpl in t1_sigma; rewrite Ar in t1_sigma;
simpl in v_sigma; rewrite v_sigma in t1_sigma.
injection t1_sigma; clear t1_sigma; intro t1_sigma.
destruct t as [ x | g ll].
rewrite (@permut_cons_inside (Var x) (Var x)) by reflexivity.
(* dummy rewrite <- t1_sigma ne marche pas *)
(* avec depliage, ca marche unfold EDS.A, TO.A; rewrite <- t1_sigma. *)
setoid_rewrite <- t1_sigma.
apply permut_sym; apply quick_permut_bis; reflexivity.
revert t1_sigma; generalize (F.Symb.eq_bool_ok f g); case (F.Symb.eq_bool f g); [intro f_eq_g | intros _].
absurd (f=g); trivial.
apply (well_formed_cf_alien Ar Wt2 (Term g ll)).
apply in_or_app; right; left; trivial.
intro t1_sigma;
rewrite (@permut_cons_inside (Term g ll) (Term g ll)) by reflexivity.
setoid_rewrite <- t1_sigma.
apply permut_sym; apply quick_permut_bis; reflexivity.
intros s s_in_l2'_l2'';
destruct (in_app_or _ _ _ s_in_l2'_l2'') as [s_in_l2' | s_in_l2''];
apply (well_formed_cf_alien Ar Wt2); apply in_or_app; [left | right; right]; trivial.
intros t_not_in_l2;
simpl in t1_sigma; rewrite Ar in t1_sigma;
simpl in v_sigma; rewrite v_sigma in t1_sigma;
inversion t1_sigma.
destruct t as [x | g ll].
apply t_not_in_l2; subst l2.
rewrite <- (mem_permut_mem (Var x)  (quick_permut (Var x :: flatten f (map (apply_cf_subst sigma) l1)))); left; trivial.
reflexivity.
revert H0; generalize (F.Symb.eq_bool_ok f g); case (F.Symb.eq_bool f g); [intros f_eq_g _; assumption | intros f_diff_g].
intro H; apply False_rect; apply t_not_in_l2; subst l2.
rewrite <- (mem_permut_mem (Term g ll) (quick_permut (Term g ll :: flatten f (map (apply_cf_subst sigma) l1)))).
left; reflexivity.
Qed.

Lemma remove_several_subterms :
  forall sigma f v l1 t l2, arity f = AC -> well_formed_cf_subst sigma ->
  well_formed_cf (Term f (Var v :: l1)) ->
  well_formed_cf (Term f l2) ->
  apply_cf_subst sigma (Var v) = t ->
  apply_cf_subst sigma (Term f (Var v :: l1)) = Term f l2 ->
  match t with
  | Var _ => True
  | Term g l0 =>
     if F.Symb.eq_bool f g
     then
       match remove_list l0 l2 with
       | None => False
       | Some l3 =>
         if le_gt_dec (length l1) (length l3)
         then apply_cf_subst sigma (build f l1) = build f l3
         else False
       end
     else True
  end.
Proof.
intros sigma f v l1 t l2 Ar W_sigma Wt1 Wt2 v_sigma t1_sigma;
destruct t as [ x | g ll]; trivial.
generalize (F.Symb.eq_bool_ok f g); case (F.Symb.eq_bool f g); [intro f_eq_g; subst g | intros _; trivial].
assert (W_v : well_formed_cf (Var v)). simpl; trivial.
assert (W_v_sigma := well_formed_cf_apply_subst W_sigma _ W_v);
rewrite v_sigma in W_v_sigma.
generalize (in_remove_list (well_formed_cf_sorted Ar W_v_sigma)
                    (well_formed_cf_sorted Ar Wt2)).
destruct (remove_list ll l2) as [l2' | ].
intro P; elim (le_gt_dec (length l1) (length l2')); intro L.
assert (Al_l2' : forall t, In t l2' -> match t with Var _ => True | Term g _ => f <> g end).
intros t In_t; apply (well_formed_cf_alien Ar Wt2).
rewrite <- (list_permut.in_permut_in P).
apply in_or_app; right; trivial.
apply flatten_cf with f; trivial.
apply well_formed_cf_apply_subst; trivial;
apply well_formed_cf_build_cons with (Var v); trivial.
apply well_formed_cf_build; trivial.
apply le_trans with (length l1); trivial.
apply le_S_n; generalize (well_formed_cf_length Ar Wt1); trivial.
intros t In_t; apply (well_formed_cf_subterms Wt2).
rewrite <- (list_permut.in_permut_in P);
apply in_or_app; right; trivial.
rewrite <- (flatten_apply_cf_subst sigma l1 Ar);
rewrite (flatten_build l2' Ar Al_l2').
rewrite (permut_app1 ll).
transitivity l2.
simpl in t1_sigma; rewrite Ar in t1_sigma.
inversion_clear t1_sigma.
simpl in v_sigma; rewrite v_sigma.
generalize (F.Symb.eq_bool_ok f f); case (F.Symb.eq_bool f f); [intros _ | intro f_diff_f; apply False_rect; apply f_diff_f; reflexivity].
apply quick_permut.
symmetry; trivial.
generalize (plus_lt_compat_l _ _ (length ll) L).
rewrite <- length_app; assert (L' := list_permut.permut_length P).
setoid_rewrite L'; clear L'.
simpl in t1_sigma; rewrite Ar in t1_sigma.
inversion_clear t1_sigma; rewrite length_quicksort;
simpl in v_sigma; rewrite v_sigma;
generalize (F.Symb.eq_bool_ok f f); case (F.Symb.eq_bool f f); [intros _ | intro f_diff_f; apply False_rect; apply f_diff_f; reflexivity].
rewrite length_app; intro L'; assert (L'' := plus_lt_reg_l _ _ (length ll) L'); clear L L'.
absurd (length l1 < length l1); auto with arith.
refine (le_lt_trans _ _ _ _ L'').
rewrite <- (length_map (apply_cf_subst sigma)).
apply length_flatten_bis; trivial.
intros t' t'_in_map_l1; rewrite in_map_iff in t'_in_map_l1;
destruct t'_in_map_l1 as [t [Wt t_sigma]].
subst; apply well_formed_cf_apply_subst; trivial.
apply (well_formed_cf_subterms Wt1); right; trivial.
intro P; apply (P (flatten f (map (apply_cf_subst sigma) l1)));
simpl in v_sigma; simpl in t1_sigma;
rewrite Ar in t1_sigma; rewrite v_sigma in t1_sigma;
inversion_clear t1_sigma.
simpl; trivial;
generalize (F.Symb.eq_bool_ok f f); case (F.Symb.eq_bool f f); [intros _ | intro f_diff_f; apply False_rect; apply f_diff_f; reflexivity].
apply quick_permut; auto.
Qed.

Lemma remove_several_subterms_bis :
  forall sigma f v v' l1 t l2, arity f = AC -> well_formed_cf_subst sigma ->
  well_formed_cf (Term f (Var v :: l1)) ->
  well_formed_cf (Term f l2) ->
  apply_cf_subst sigma (Var v) =
     Term f (quicksort (flatten f (apply_cf_subst sigma (Var v') :: t :: nil))) ->
  apply_cf_subst sigma (Term f (Var v :: l1)) = Term f l2 ->
  match t with  | Var _ => True  | Term g _ => f<>g end ->
  match remove T.eq_bool t l2 with
  | None => False
  | Some l3 => apply_cf_subst sigma  (build f (Var v' :: l1)) = build f l3
  end.
Proof.
intros sigma f v v' l1 t l2 Ar W_sigma Wt1 Wt2 v_sigma t1_sigma.
generalize (in_remove _ _ T.eq_bool_ok t l2);
destruct (remove T.eq_bool t l2) as [l2''' | ].
intros [cp1' [l2' [l2'' [ H'' [l2_eq l2'''_eq]]]]] Al_t.
injection l2'''_eq; clear l2'''_eq; intro l2'''_eq;
apply flatten_cf with f; trivial.
apply well_formed_cf_apply_subst; trivial; apply well_formed_cf_build; trivial.
simpl; auto with arith.
intros s [s_eq_v' | s_in_l1]; [subst; simpl | apply (well_formed_cf_subterms Wt1); right]; trivial.
intros s [s_eq_v' | s_in_l1]; [subst; simpl | apply (well_formed_cf_alien Ar Wt1); right]; trivial.
subst l2 l2'''; apply well_formed_cf_build_inside with t; subst; trivial.

rewrite <- (flatten_apply_cf_subst sigma (Var v' :: l1) Ar);
rewrite (flatten_build l2''' Ar); subst l2 l2''' cp1'.
rewrite (@permut_cons_inside t t) by reflexivity.
pattern (Var v :: l1) in t1_sigma; simpl in t1_sigma; rewrite Ar in t1_sigma.
pattern (Var v') in v_sigma; unfold apply_cf_subst in v_sigma.
rewrite v_sigma in t1_sigma; clear v_sigma.
revert t1_sigma; generalize (F.Symb.eq_bool_ok f f); case (F.Symb.eq_bool f f); [intros _ t1_sigma | intro f_diff_f; apply False_rect; apply f_diff_f; reflexivity].
assert (Inj : forall l' l'', Term f l' = Term f l'' -> l' = l'').
intros l' l'' H'; injection H'; intros; subst; trivial.
setoid_rewrite <- (Inj _ _ t1_sigma); clear Inj.
apply permut_sym; apply quick_permut_bis.
transitivity
  (flatten f (apply_cf_subst sigma (Var v')  :: t :: nil) ++
   flatten f (map (apply_cf_subst sigma) l1)).
rewrite <- permut_app2; apply quick_permut_bis; auto.
replace (flatten f (map (apply_cf_subst sigma) (Var v' :: l1))) with
((flatten f (apply_cf_subst sigma (Var v') :: nil)) ++
        flatten f (map (apply_cf_subst sigma) l1));
[ rewrite app_comm_cons | rewrite <- flatten_app; trivial].
rewrite <- permut_app2.
replace (flatten f (apply_cf_subst sigma (Var v') :: t :: nil)) with
((flatten f (apply_cf_subst sigma (Var v') :: nil) ++ flatten f (t :: nil)));
[idtac | rewrite <- flatten_app; simpl app; trivial].
replace (flatten f (t :: nil)) with (t :: nil).
apply permut_sym; rewrite <- permut_cons_inside.
rewrite <- app_nil_end; auto.
reflexivity.
simpl; destruct t as [x | g ll]; trivial.
generalize (F.Symb.eq_bool_ok f g); case (F.Symb.eq_bool f g); [intro f_eq_g; absurd (f = g); trivial | intros _; trivial].
intros s s_in_l2'_l2'';
destruct (in_app_or _ _ _ s_in_l2'_l2'') as [s_in_l2' | s_in_l2''];
apply (well_formed_cf_alien Ar Wt2); apply in_or_app; [left | right; right]; trivial.

intros Not_in Al_t;
pattern (Var v :: l1) in t1_sigma; simpl in t1_sigma; rewrite Ar in t1_sigma.
pattern (Var v') in v_sigma;
unfold apply_cf_subst in v_sigma.
rewrite v_sigma in t1_sigma; clear v_sigma.
revert t1_sigma; generalize (F.Symb.eq_bool_ok f f); case (F.Symb.eq_bool f f); [intros _ t1_sigma | intro f_diff_f; apply False_rect; apply f_diff_f; reflexivity].
assert (Inj : forall l' l'', Term f l' = Term f l'' -> l' = l'').
intros l' l'' H'; injection H'; intros; subst; trivial.
rewrite <- (Inj _ _ t1_sigma) in Not_in; clear Inj.
apply Not_in.
apply in_impl_mem.
reflexivity.
rewrite <- in_quick_in.
apply in_or_app; left.
rewrite <- in_quick_in.
replace (flatten f (match find eq_var_bool v' sigma with
         | Some v_sigma => v_sigma
         | None => Var v'
         end :: t :: nil)) with
(flatten f (apply_cf_subst sigma (Var v')  :: nil) ++ flatten f (t :: nil)).
apply in_or_app; right; destruct t as [x | g ll]; simpl.
left; trivial.
generalize (F.Symb.eq_bool_ok f g); case (F.Symb.eq_bool f g); [intro f_eq_g; absurd (f = g); trivial | intros _; left; trivial].
rewrite <- flatten_app; simpl app; trivial.
Qed.

Lemma remove_several_subterms_bis_nil :
  forall sigma f v v' t l2, arity f = AC -> well_formed_cf_subst sigma ->
  well_formed_cf (Term f l2) ->
  apply_cf_subst sigma (Var v) =
     Term f (quicksort (flatten f (apply_cf_subst sigma (Var v') :: t :: nil))) ->
  apply_cf_subst sigma (Var v) = Term f l2 ->
  match t with  | Var _ => True  | Term g _ => f<>g end ->
  match remove T.eq_bool t l2 with
  | None => False
  | Some l3 => apply_cf_subst sigma (Var v') = build f l3
  end.
Proof.
intros sigma f v v' t l2 Ar W_sigma Wt2 v_sigma t1_sigma Al_t;
generalize (in_remove _ _ T.eq_bool_ok t l2);
destruct (remove T.eq_bool t l2) as [l2''' | ].
intros [cp1 [l2' [l2'' [ H' [l2_eq l2'''_eq]]]]].
injection l2'''_eq; clear l2'''_eq; intro l2'''_eq;
subst l2 l2'''; apply flatten_cf with f; trivial.
apply well_formed_cf_apply_subst; trivial; simpl; trivial.
apply well_formed_cf_build_inside with t; subst; trivial.
apply permut_trans with (l2' ++ l2'').
rewrite (@permut_cons t t).
apply permut_trans with (l2' ++ t :: l2'').
assert (H:= trans_eq (sym_eq v_sigma) t1_sigma).
assert (Inj : forall l' l'', Term f l' = Term f l'' -> l' = l'').
intros l' l'' H''; injection H''; intros; subst; trivial.
subst cp1; rewrite <- (Inj _ _ H); clear Inj.
apply permut_sym; apply quick_permut_bis.
apply permut_trans with
(flatten f (apply_cf_subst sigma (Var v') :: nil) ++ flatten f (t :: nil)).
rewrite <- flatten_app; simpl app; apply permut_refl.
refine (permut_trans (list_permut_app_app _ _) _).
simpl; destruct t as [ x | g ll ]; [apply permut_refl | idtac].
generalize (F.Symb.eq_bool_ok f g); case (F.Symb.eq_bool f g); [intro f_eq_g; absurd (f = g); trivial | intros _; reflexivity].
apply permut_sym; rewrite <- permut_cons_inside; reflexivity.
reflexivity.
apply permut_sym; apply flatten_build_inside with t; subst cp1; trivial.

intros Not_in; apply Not_in.
assert (H := trans_eq (sym_eq v_sigma) t1_sigma).
assert (Inj : forall l' l'', Term f l' = Term f l'' -> l' = l'').
intros l' l'' H'; injection H'; intros; subst; trivial.
rewrite <- (Inj _ _ H); clear Inj.
apply in_impl_mem.
reflexivity.
rewrite <- in_quick_in.
assert (H':= flatten_app f (apply_cf_subst sigma (Var v') :: nil) (t :: nil)).
simpl in H'; simpl; rewrite  H'; apply in_or_app; right.
destruct t as [ x | g ll ]; simpl; [left; trivial | idtac].
generalize (F.Symb.eq_bool_ok f g); case (F.Symb.eq_bool f g); [intro f_eq_g; absurd (f = g); trivial | intros _; left; reflexivity].
Qed.

Lemma solve_is_complete :
  forall pb, well_formed_pb pb -> forall sigma, is_well_formed_sol pb sigma ->
  match pb.(unsolved_part) with
  | nil => True
    | _ :: _ => exists pb', In pb' (solve pb) /\ is_well_formed_sol pb' sigma
  end.
Proof.
intros pb W sigma' [sigma [S [S' W_sigma]]].
case_eq pb; intros ex [ | [t1 t2] unsolved_p] solved_p partly_solved_p Pb; simpl; trivial.
assert (R' : forall t:term, is_rough_sol pb (((fresh_var pb), t) :: sigma)).
intro t; apply add_new_var_to_rough_sol; trivial.
assert (Fresh_var := fresh_var_spec pb).
rewrite Pb in S'.
rewrite Pb in W; destruct W as [W1_pb [W2_pb [W3_pb [W4_pb [W5_pb W6_pb]]]]].
rewrite Pb in S; destruct S as [S1 [S2 S3]].
destruct (W1_pb t1 t2 (or_introl _ (eq_refl _))) as [Wt1 Wt2].
assert (t1_sigma := S1 t1 t2 (or_introl _ (eq_refl _))).
simpl unsolved_part in *; simpl solved_part in *; simpl partly_solved_part in *; simpl existential_vars in *.
unfold solve; simpl; destruct t1 as [v | f1 l1].
(* 1/2 t1 is a variable v *)
case_eq (find X.eq_bool v solved_p); [intros x_val F | intros F].
(* 1/3 t1 = v has a (complete) value *)
generalize (T.eq_bool_ok x_val t2); case (T.eq_bool x_val t2); [intro x_val_eq_t2 | intro x_val_diff_t2].

subst x_val; exists (mk_pb ex unsolved_p solved_p partly_solved_p); split.
left; trivial.
exists sigma; repeat split; trivial.
simpl; intros a b ab_in_unsolved_p; apply S1; right; trivial.
absurd (x_val = t2); trivial.
generalize (S3 v); simpl; rewrite F; simpl in t1_sigma; rewrite t1_sigma.
intro; apply sym_eq; trivial.

(* 1/2 t1 = v has no complete value *)
case_eq (find X.eq_bool v partly_solved_p); [intros pst F'| intros F'].
(* 1/3 t1 =v has no complete value, but has a partial value *)
assert (E := S2 v).
simpl partly_solved_part in E; rewrite F' in E; rewrite t1_sigma in E; rewrite E.
generalize (F.Symb.eq_bool_ok (head_symb pst) (head_symb pst));
case (F.Symb.eq_bool (head_symb pst) (head_symb pst)); [intros _ | intros h_diff_h; apply False_rect; apply h_diff_h; reflexivity].
generalize (W3_pb v); simpl partly_solved_part; rewrite F'.
destruct_arity (head_symb pst) n Af2; [intros [Wct Act] | contradiction | contradiction].
rewrite E in Wt2; rewrite <- t1_sigma in E.
assert (H := remove_several_subterms_bis_nil _ _ v (new_var pst) (closed_term pst) _
                     Af2 W_sigma Wt2 E E Act).
destruct (remove T.eq_bool (closed_term pst)
                     (quicksort (flatten (head_symb pst)
                                        (apply_cf_subst sigma (Var (new_var pst))
                                        :: closed_term pst :: nil)))) as [l2' | ].

exists (mk_pb ex ((Var (new_var pst), build (head_symb pst) l2') :: unsolved_p) solved_p partly_solved_p);
split.
left; trivial.
exists sigma; repeat split; trivial.
simpl; intros t1 t3 [In_t1t3 | In_t1t3].
injection In_t1t3; intros; subst t1 t3; trivial.
apply S1; right; trivial.
contradiction.

(* 1/2 t1 = v has no complete value, nor a partial value *)
exists (mk_pb ex unsolved_p ((v, t2) :: solved_p) partly_solved_p); split.
left; trivial.
exists sigma; repeat split; trivial.
simpl; intros t1 t3 In_t1t3; apply S1; right; trivial.
simpl; intro v0; generalize (X.eq_bool_ok v0 v); case (X.eq_bool v0 v); [intro v0_eq_v | intro v0_diff_v].
subst v0; trivial.
apply (S3 v0).

(* 1/1 t1 = f1(l1) *)
destruct t2 as [v' | f2 l2]; [inversion t1_sigma | idtac].
generalize (F.Symb.eq_bool_ok f1 f2); case (F.Symb.eq_bool f1 f2); [intro f1_eq_f2 | intros; absurd (f1 =f2); trivial; inversion t1_sigma; trivial].
(* 1/1 t1 = f1(l1), t2 = f1(l2) *)
subst f2; destruct_arity f1 n1 Af1.
(* 1/3 f1 is AC *)
destruct (le_gt_dec (length l1) (length l2)) as [Ll2 | Ll2].
(* 1/4 length l1 <= length l2 *)
unfold ac_elementary_solve; destruct l1 as [ | t l1].
absurd (2<=0); auto with arith; apply (well_formed_cf_length Af1 Wt1).

destruct t as [v | f k].
(* 1/5 t1 = f1(v,l1), t2 = f1(l2) *)
case_eq (find X.eq_bool v solved_p); [intros pst F | intros F].
assert (v_sigma := S3 v).
simpl solved_part; simpl solved_part in v_sigma; rewrite F in v_sigma.
(* 1/6 v has a complete value *)
assert (t_sigma := remove_a_subterm _ _ _ _ _ _ Af1 W_sigma Wt1 Wt2 v_sigma t1_sigma).
unfold ac_elementary_solve_term_var_with_val_term; rewrite F.
case_eq (remove T.eq_bool pst l2); [intros l2' H | intros H]; rewrite H in t_sigma.
simpl; exists (mk_pb ex ((build f1 l1, build f1 l2') :: unsolved_p) solved_p partly_solved_p); split.
left; trivial.
exists sigma; repeat split; trivial.
intros t1 t2 [In_t1t2 | In_t1t2]; [injection In_t1t2; intros; subst t1 t2 | apply S1; right]; trivial.

destruct pst as [v' | f k]; [contradiction | subst f].
assert (t_sigma := remove_several_subterms _ _ _ _ _ _ Af1 W_sigma Wt1 Wt2 v_sigma t1_sigma).
simpl in t_sigma; revert t_sigma;
generalize (F.Symb.eq_bool_ok f1 f1); case (F.Symb.eq_bool f1 f1); [intros _ | intro f1_diff_f1; apply False_rect; apply f1_diff_f1; reflexivity].
destruct (remove_list k l2) as [k2' | ]; [idtac | contradiction].
unfold TO.A in *;
destruct (le_gt_dec (length l1) (length k2')) as [Lk2' | Lk2']; [idtac | contradiction].

simpl; exists (mk_pb ex ((build f1 l1, build f1 k2') :: unsolved_p) solved_p partly_solved_p); split.
left; trivial.
exists sigma; repeat split; trivial.
intros t1 t2 [In_t1t2 | In_t1t2]; [injection In_t1t2; intros; subst | apply S1; right]; trivial.

(* 1/5 v has no complete value *)
simpl; rewrite F.
assert (v_sigma := S2 v).
cbv zeta in v_sigma.
assert (W3_v := W3_pb v).
case_eq (find X.eq_bool v partly_solved_p); [intros pst F' | intros F'];
rewrite F' in v_sigma; rewrite F' in W3_v.
(* 1/6 v has no complete value, but has a partial value *)
destruct_arity (head_symb pst) n Ahsp; [idtac | contradiction | contradiction].
unfold ac_elementary_solve_term_var_with_part_val_term.
destruct W3_v as [Wct Act].
generalize (F.Symb.eq_bool_ok f1 (head_symb pst));
case (F.Symb.eq_bool f1 (head_symb pst)); [intro f1_eq_hd_pst | intro f1_diff_hd_pst].
rewrite <- f1_eq_hd_pst in *.

assert (t_sigma := remove_several_subterms_bis _ _ _ _ _ _ _ Af1 W_sigma Wt1 Wt2 v_sigma t1_sigma Act).
destruct (remove T.eq_bool (closed_term pst) l2) as [ l2' | ]; [idtac | contradiction].

exists (mk_pb ex ((build f1 (Var (new_var pst) :: l1), build f1 l2') :: unsolved_p) solved_p partly_solved_p); split.
left; trivial.
exists sigma; repeat split; trivial.
simpl; intros t1 t2 [In_t1t2 | In_t1t2]; [injection In_t1t2; intros; subst t1 t2 | apply S1; right]; trivial.

refine (exists_map_without_repetition _ T.eq_bool_ok _ _ _ _).
assert (v_sigma_in_l2 : In (apply_cf_subst sigma (Var v)) l2).
rewrite v_sigma; simpl apply_cf_subst in v_sigma; simpl apply_cf_subst in t1_sigma;
rewrite Af1 in t1_sigma; rewrite v_sigma in t1_sigma.
revert t1_sigma; generalize (F.Symb.eq_bool_ok f1 (head_symb pst));
case (F.Symb.eq_bool f1 (head_symb pst)); [intros f1_eq_hd_pst | intros _ t1_sigma].
absurd (f1 = head_symb pst); trivial.
injection t1_sigma; clear t1_sigma; intro l1_sigma; subst l2.
rewrite <- in_quick_in; left; trivial.
exists (apply_cf_subst sigma (Var v)); split; trivial.
assert (Wv : well_formed_cf (Var v)).
simpl; trivial.
assert (W := well_formed_cf_apply_subst W_sigma (Var v) Wv).
clear Wv; rewrite v_sigma; rewrite v_sigma in W;
generalize (F.Symb.eq_bool_ok (head_symb pst) (head_symb pst));
case (F.Symb.eq_bool (head_symb pst) (head_symb pst)); [intros _ | intros h_diff_h; apply False_rect; apply h_diff_h; reflexivity].
assert (v'_sigma := remove_several_subterms_bis_nil _ _ _ _ _ _ Ahsp W_sigma W v_sigma v_sigma Act).
assert (t_sigma := remove_a_subterm _ _ _ _ _ _ Af1 W_sigma Wt1 Wt2 (eq_refl _) t1_sigma).
destruct (remove T.eq_bool (closed_term pst)
      (quicksort
         (flatten (head_symb pst)
            (apply_cf_subst sigma (Var (new_var pst))
             :: closed_term pst :: nil)))) as [k2 | ]; [idtac | contradiction].
rewrite <- v_sigma; destruct (remove T.eq_bool (apply_cf_subst sigma (Var v)) l2) as [l2' | ].
exists sigma; repeat split; trivial.
simpl.
intros t1 t2 [In_t1t2 | [In_t1t2 | In_t1t2]];
[injection In_t1t2; intros; subst t1 t2 | injection In_t1t2; intros; subst t1 t2 | apply S1; right]; trivial.
rewrite v_sigma in t_sigma; apply f1_diff_hd_pst; trivial.

(* 1/5 v has no complete value, nor a partial value *)
clear v_sigma; clear W3_v.
unfold ac_elementary_solve_term_var_without_val_term.
refine (exists_map12_without_repetition _ T.eq_bool_ok _ _ _ _).
assert (t_sigma := remove_a_subterm sigma _ _ _ _ _ Af1 W_sigma Wt1 Wt2 (eq_refl _) t1_sigma).
case_eq (apply_cf_subst sigma (Var v)); [intros v' v_sigma | intros f k v_sigma]; rewrite v_sigma in t_sigma.
(* 1/6 the actual value of v is a variable *)
exists (Var v').
assert (H := in_remove _ _ T.eq_bool_ok (Var v') l2).
case_eq (remove T.eq_bool (Var v') l2); [intros l2' H' | intros H'];
rewrite H' in t_sigma; [rewrite H' in H; split | contradiction].
destruct H as [t [l' [l'' [v_sigma_eq_t [l2_eq H]]]]]; subst; apply in_or_app; right; left; trivial.
unfold TO.A in *; destruct (le_gt_dec (length l2) (length l1 + 1)) as [Ll2' | Ll2'].
exists sigma; repeat split; trivial.
simpl; intros t1 t2 [In_t1t2 | In_t1t2]; [injection In_t1t2; intros; subst t1 t2 | apply S1; right]; trivial.
simpl; intro v0; generalize (X.eq_bool_ok v0 v); case (X.eq_bool v0 v); [intro v0_eq_v | intro v0_diff_v].
subst v0; trivial.
apply S3.
left; exists sigma; repeat split; trivial.
simpl; intros t1 t2 [In_t1t2 | In_t1t2]; [injection In_t1t2; intros; subst t1 t2 | apply S1; right]; trivial.
simpl; intro v0; generalize (X.eq_bool_ok v0 v); case (X.eq_bool v0 v); [intro v0_eq_v | intro v0_diff_v].
subst v0; trivial.
apply S3.
(* 1/5 the actual value of v is a composite term f(k) *)
assert (H := in_remove _ _ T.eq_bool_ok (Term f k) l2).
case_eq (remove T.eq_bool (Term f k) l2); [intros l2' H' | intros H']; rewrite H' in *.
(* 1/6 the actual value of v is f(k), where f <> f1, and f(k) is in l2 *)
exists (Term f k); split.
destruct H as [t [l' [l'' [v_sigma_eq_t [l2_eq H]]]]]; subst; apply in_or_app; right; left; trivial.
rewrite H'; unfold TO.A in *; destruct (le_gt_dec (length l2) (length l1 + 1)) as [Ll2' | Ll2'].
exists sigma; repeat split; trivial.
simpl; intros t1 t2 [In_t1t2 | In_t1t2]; [injection In_t1t2; intros; subst t1 t2 | apply S1; right]; trivial.
simpl; intro v0; generalize (X.eq_bool_ok v0 v); case (X.eq_bool v0 v); [intro v0_eq_v | intro v0_diff_v].
subst v0; trivial.
apply S3.
left; exists sigma; repeat split; trivial.
simpl; intros t1 t2 [In_t1t2 | In_t1t2]; [injection In_t1t2; intros; subst t1 t2 | apply S1; right]; trivial.
simpl; intro v0; generalize (X.eq_bool_ok v0 v); case (X.eq_bool v0 v); [intro v0_eq_v | intro v0_diff_v].
subst v0; trivial.
apply S3.

(* 1/5 the actual value of v is f(k), where f = f1, and f(k) is NOT in l2, but a subterm a of k is *)
subst f; assert (W_fk : well_formed_cf (Term f1 k)).
rewrite <- v_sigma; generalize (W_sigma v); simpl.
destruct (find X.eq_bool v sigma); simpl; trivial.

destruct k as [ | a k]; simpl in W_fk; rewrite Af1 in W_fk.
destruct W_fk as [_ [W_fk _]]; inversion W_fk.
assert (a_in_l2 : In a l2).
simpl in t1_sigma; rewrite Af1 in t1_sigma; simpl in v_sigma; rewrite v_sigma in t1_sigma.
revert t1_sigma;
generalize (F.Symb.eq_bool_ok f1 f1); case (F.Symb.eq_bool f1 f1); [intros _ t1_sigma | intro f1_diff_f1; apply False_rect; apply f1_diff_f1; reflexivity].
injection t1_sigma; intros; subst l2;rewrite <- in_quick_in; left; trivial.
assert (W_sigma' : well_formed_cf_subst (((fresh_var pb), (build f1 k)) :: sigma)).
unfold well_formed_cf_subst; simpl; intros v0;
generalize (X.eq_bool_ok v0 (fresh_var pb)); case (X.eq_bool v0 (fresh_var pb)); [intro v0_eq_fv | intro v0_diff_fv].
apply well_formed_cf_build_cons with a; simpl; trivial; rewrite Af1; trivial.
apply (W_sigma v0).
assert (v_sigma' : apply_cf_subst (((fresh_var pb), (build f1 k)) :: sigma) (Var v) =
 Term f1
   (quicksort
      (flatten f1
         (apply_cf_subst (((fresh_var pb), (build f1 k)) :: sigma)
            (Var (fresh_var pb)) :: a :: nil)))).
simpl apply_cf_subst.
generalize (X.eq_bool_ok (fresh_var pb) (fresh_var pb)); case (X.eq_bool (fresh_var pb) (fresh_var pb));
[intros _ | intro fv_diff_fv; apply False_rect; apply fv_diff_fv; reflexivity].
generalize (X.eq_bool_ok v (fresh_var pb)); case (X.eq_bool v (fresh_var pb)); [intro v_eq_fv | intros _].
absurd (v = fresh_var pb); trivial.
intros _; apply Fresh_var; rewrite <- v_eq_fv; subst pb;
unfold occurs_in_pb; simpl; do 3 left; trivial.
simpl in v_sigma; rewrite v_sigma.
apply (f_equal (fun l => Term f1 l)).
apply sort_is_unique.
destruct W_fk as [_ [_ [W_fk _]]]; trivial.
apply quick_sorted.
apply permut_sym; apply quick_permut_bis.
replace (flatten f1 (build f1 k :: a :: nil)) with (flatten f1 (build f1 k :: nil) ++ flatten f1 (a :: nil));
[idtac | rewrite <- flatten_app; simpl app; trivial].
refine (permut_trans (list_permut_app_app _ _) _).
apply permut_trans with (a :: flatten f1 (build f1 k :: nil)).
simpl; destruct a as [ | g ll]; [apply permut_refl | idtac].
generalize (F.Symb.eq_bool_ok f1 g); case (F.Symb.eq_bool f1 g);  [intro f1_eq_g | reflexivity].
absurd (f1=g); trivial.
destruct W_fk as [_ [_ [_ W_fk]]]; apply (W_fk (Term g ll)); left; trivial.
rewrite <- permut_cons.
apply flatten_build_cons with a; simpl; trivial; rewrite Af1; trivial.
reflexivity.
assert (t1_sigma' : apply_cf_subst (((fresh_var pb), (build f1 k)) :: sigma) (Term f1 (Var v :: l1)) = Term f1 l2).
rewrite <- add_new_var_to_subst; trivial.
intro fv_in_t1; apply Fresh_var; rewrite Pb; unfold occurs_in_pb;
simpl unsolved_part; rewrite <- Pb; do 2 left; trivial.
assert (Aa : match a with
        | Var _ => True
        | Term g _ => f1 <> g
        end).
destruct W_fk as [_ [_ [_ W_fk]]]; apply W_fk; left; trivial.
assert (H1 := remove_several_subterms_bis
         (((fresh_var pb), (build f1 k)) :: sigma) f1 v (fresh_var pb) l1
          a l2 Af1 W_sigma' Wt1 Wt2 v_sigma' t1_sigma' Aa).
exists a; split; trivial.
destruct (remove T.eq_bool a l2) as [l2' | ]; [idtac | contradiction].
unfold TO.A in *; destruct (le_gt_dec (length l2) (length l1 + 1)) as [Ll2' | Ll2'].
absurd (length l2 < length l2); auto with arith.
rewrite plus_comm in Ll2';  apply le_lt_trans with (S (length l1)); trivial.
pattern (Var v :: l1) in t1_sigma; simpl in t1_sigma; rewrite Af1 in t1_sigma.
simpl in v_sigma; rewrite v_sigma in t1_sigma.
revert t1_sigma;
generalize (F.Symb.eq_bool_ok f1 f1); case (F.Symb.eq_bool f1 f1); [intros _ t1_sigma | intro f1_diff_f1; apply False_rect; apply f1_diff_f1; reflexivity].
injection t1_sigma; intro H2; rewrite <- H2; clear H2.
rewrite length_quicksort; simpl; apply le_n_S; rewrite length_app.
replace (S (length l1)) with (1 + length l1); trivial; apply plus_le_compat.
destruct W_fk as [_ [W_fk _]]; apply le_S_n; trivial.
rewrite <- (length_map (apply_cf_subst sigma) l1).
apply length_flatten_bis; trivial.
intros t' t'_in_map_l1; rewrite in_map_iff in t'_in_map_l1;
destruct t'_in_map_l1 as [t [Wt t_sigma]].
subst; apply well_formed_cf_apply_subst; trivial.
apply (well_formed_cf_subterms Wt1); right; trivial.

right; exists (((fresh_var pb), (build f1 k)) :: sigma).
assert (R'' := (R' (build f1 k))).
rewrite Pb in R''; destruct R'' as [R1 [R2 R3]];
simpl in R1; rewrite <- Pb in R1;
simpl in R2; rewrite <- Pb in R2;
simpl in R3; rewrite <- Pb in R3;
simpl; rewrite <- Pb; repeat split; trivial.
intros t1 t2 [In_t1t2 | In_t1t2]; [injection In_t1t2; intros; subst | apply R1; right]; trivial.
simpl partly_solved_part; simpl find;
intro v'; assert (R2_v' := R2 v').
generalize (X.eq_bool_ok v' v); case (X.eq_bool v' v); [intro v'_eq_v | intro v'_diff_v]; trivial.
subst v'; rewrite v_sigma'; trivial.
intro v'; assert (S'_v' := S' v').
generalize (X.eq_bool_ok v' (fresh_var pb)); case (X.eq_bool v' (fresh_var pb)); [intro v'_eq_fv | intro v'_diff_fv];
[do 2 left; subst v' | destruct S'_v' as [S'_v' | S'_v']; [left; right | right]]; trivial.

(* 1/4  t1 = f1(f k,l1), t2 = f1(l2) *)
unfold ac_elementary_solve_term_term_term.
refine (exists_map_without_repetition _ T.eq_bool_ok _ _ _ _).
exists (apply_cf_subst sigma (Term f k)).
assert (f_diff_s := well_formed_cf_alien Af1 Wt1 _ (or_introl _ (eq_refl _))).
simpl in f_diff_s.
assert (s_l0_in_l2 : In (apply_cf_subst sigma (Term f k)) l2).
generalize (S1 _ _ (or_introl _ (eq_refl _))); simpl; rewrite Af1;
generalize (F.Symb.eq_bool_ok f1 f); case (F.Symb.eq_bool f1 f); [intros f1_eq_f; absurd (f1 = f); trivial | intro f_diff_f1].
intro H; injection H; intros; subst l2.
rewrite <- in_quick_in; left; trivial.
split; [trivial | idtac].
generalize (in_remove _ _ T.eq_bool_ok (apply_cf_subst sigma (Term f k)) l2);
destruct (remove T.eq_bool (apply_cf_subst sigma (Term f k)) l2) as
   [l2''' | ]; [idtac | intro; absurd (In (apply_cf_subst sigma (Term f k)) l2); trivial].
intros [a' [l2' [l2'' [H [l2_eq l2'''_eq]]]]]; subst a';
injection l2'''_eq; clear l2'''_eq; intro; subst l2 l2''';
simpl; generalize (F.Symb.eq_bool_ok f f); case (F.Symb.eq_bool f f); [intros _ | intro f_diff_f; apply False_rect; apply f_diff_f; reflexivity].
exists sigma; repeat split; trivial.
simpl unsolved_part; intros t1 t2 [In_t1t2 | [In_t1t2 | In_t1t2]].
injection In_t1t2; intros; subst.
apply flatten_cf with f1; trivial.
apply well_formed_cf_apply_subst; trivial;
apply (well_formed_cf_subterms Wt1); left; trivial.
apply (well_formed_cf_apply_subst W_sigma (Term f k)).
apply (well_formed_cf_subterms Wt1); left; trivial.
apply permut_refl.
injection In_t1t2; intros; subst.
apply flatten_cf with f1; trivial.
apply well_formed_cf_apply_subst; trivial;
apply well_formed_cf_build_cons with (Term f k); trivial.
apply well_formed_cf_build_inside with (apply_cf_subst sigma (Term f k)); trivial.
rewrite <- (flatten_apply_cf_subst sigma l1 Af1).
rewrite (flatten_build (l2' ++ l2'') Af1).
rewrite (@permut_cons_inside (apply_cf_subst sigma (Term f k))
                                              (apply_cf_subst sigma (Term f k))); [idtac | reflexivity].
simpl in t1_sigma; rewrite Af1 in t1_sigma;
injection t1_sigma; clear t1_sigma; intro t1_sigma;
(* dummy *)
setoid_rewrite <- t1_sigma.
generalize (F.Symb.eq_bool_ok f1 f); case (F.Symb.eq_bool f1 f); [intros f1_eq_f; absurd (f1 = f); trivial | intro f_diff_f1].
apply quick_permut.
intros t t_in_l2'_l2'';
destruct (in_app_or _ _ _ t_in_l2'_l2'') as [t_in_l2' | t_in_l2''];
apply (well_formed_cf_alien Af1 Wt2); apply in_or_app; [left | right; right]; trivial.
apply S1; right; trivial.
intro; apply H; apply in_impl_mem; trivial.

(* 1/3 length l1 > length l2 *)
absurd (length l1 > length l2); trivial;
unfold gt; apply le_not_lt;
simpl in t1_sigma; rewrite Af1 in t1_sigma; inversion_clear t1_sigma;
rewrite length_quicksort;
apply length_flatten_ter; trivial.
intros; apply (well_formed_cf_subterms Wt1); trivial.

(* 1/2 arity f1 = C *)
generalize (well_formed_cf_unfold _ Wt1); rewrite Af1; intros [Wl1 [Ll1 Sl1]].
generalize (well_formed_cf_unfold _ Wt2); rewrite Af1; intros [Wl2 [Ll2 Sl2]].
destruct l1 as [ | a1 [ | b1 [ | c1 l1]]]; [absurd (0 = 2) | absurd (1 = 2) | idtac | absurd (S(S(S(length l1))) = 2); simpl in Ll1; try discriminate]; trivial.
destruct l2 as [ | a2 [ | b2 [ | c2 l2]]]; [absurd (0 = 2) | absurd (1 = 2) | idtac | absurd (S(S(S(length l2))) = 2); simpl in Ll2; try discriminate]; trivial.
simpl in t1_sigma; rewrite Af1 in t1_sigma;
injection t1_sigma; clear t1_sigma; intro t1_sigma.
assert (P := quick_permut (apply_cf_subst sigma a1 :: apply_cf_subst sigma b1 :: nil));
rewrite t1_sigma in P.
generalize (list_permut.permut_length_2 P); clear P.
intros [[a1_sigma b1_sigma] | [a1_sigma b1_sigma]].
exists (mk_pb ex ((a1, a2) :: (b1, b2) :: unsolved_p) solved_p partly_solved_p); split.
left; trivial.
exists sigma; repeat split; trivial.
simpl; intros t1 t2 [t1t2_eq_a1a2 | [t1t2_eq_b1b2 | t1t2_in_l]];
[ injection t1t2_eq_a1a2; intros; subst
| injection t1t2_eq_b1b2; intros; subst
| apply  S1; right]; trivial.
exists (mk_pb ex ((a1, b2) :: (b1, a2) :: unsolved_p) solved_p partly_solved_p); split.
right; left; trivial.
exists sigma; repeat split; trivial.
simpl; intros t1 t2 [t1t2_eq_a1b2 | [t1t2_eq_b1a2 | t1t2_in_l]];
[ injection t1t2_eq_a1b2; intros; subst
| injection t1t2_eq_b1a2; intros; subst
| apply  S1; right]; trivial.

(* 1/1 arity f1 = Free n *)
simpl in t1_sigma; rewrite Af1 in t1_sigma.
injection t1_sigma; clear t1_sigma; intro t1_sigma.
assert (T1 : forall t1 t2, In (t1,t2) unsolved_p -> apply_cf_subst sigma t1 = t2).
intros t1 t2 t1t2_in_unsolved_p; apply S1; right; trivial.
assert (U1 : match
      fold_left2
        (fun (current_list_of_eqs : list (term * term)) (t1 t2 : term) =>
         (t1, t2) :: current_list_of_eqs) unsolved_p l1 l2
    with
    | Some new_list_of_equations =>
       forall t1 t2, In (t1,t2) new_list_of_equations ->
          apply_cf_subst sigma t1 = t2
    | None => False
    end).
subst l2.
revert T1; generalize l1 unsolved_p.
intro l; induction l as [ | t l]; simpl.
intros unsol T1 t1 t2 t1t2_in_unsol; apply T1; trivial.
intros unsol T1; generalize (IHl ((t, apply_cf_subst sigma t) :: unsol)).
destruct (fold_left2
    (fun (current_list_of_eqs : list (term * term)) (t1 t2 : term) =>
     (t1, t2) :: current_list_of_eqs) ((t, apply_cf_subst sigma t) :: unsol)
    l (map (apply_cf_subst sigma) l)) as [l' | ].
intro IH; apply IH; intros t1 t2 [t1t2_eq_ttsigma | t1t2_in_unsol].
injection t1t2_eq_ttsigma; intros; subst; trivial.
apply T1; trivial.
intro IH; apply IH; intros t1 t2 [t1t2_eq_ttsigma | t1t2_in_unsol].
injection t1t2_eq_ttsigma; intros; subst; trivial.
apply T1; trivial.
destruct (fold_left2
        (fun (current_list_of_eqs : list (term * term)) (t1 t2 : term) =>
         (t1, t2) :: current_list_of_eqs) unsolved_p l1 l2) as [l | ].
exists (mk_pb ex l solved_p partly_solved_p); split.
left; trivial.
exists sigma; repeat split; trivial.
contradiction.
Qed.

End Make.


Require Import Omega.
Require Import Bool.
Require Import RelationClasses.

Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import DenseOrder.
Require Import Loc.
Require Import Language.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Single.

Require Import SimMemory.
Require Import MemoryProps.
Require Import JoinedView.

Set Implicit Arguments.

Lemma times_sorted_split l0 l1
      (SORTED: times_sorted (l0++l1))
  :
    times_sorted l0 /\ times_sorted l1 /\
    (<<LT: forall x0 x1 (IN0: List.In x0 l0) (IN1: List.In x1 l1), Time.lt x0 x1>>).
Proof.
  remember (l0++l1). ginduction l.
  { i. destruct l0; ss. clarify. splits; auto. ss. }
  i. destruct l0; ss; clarify.
  { splits; eauto; ss. econs. }
  inv SORTED. eapply IHl in TL; ss. des. splits; auto.
  { econs; eauto.
    eapply List.Forall_forall. i. eapply List.Forall_forall in HD; eauto.
    eapply List.in_or_app; eauto.
  }
  ii. des; clarify; eauto.
  eapply List.Forall_forall; eauto. eapply List.in_or_app; eauto.
Qed.

Inductive message_from_to (mem: Memory.t) (loc: Loc.t):
  Time.t -> Time.t -> Prop :=
| message_from_to_intro
    from to val released
    (GET: Memory.get loc to mem = Some (from, Message.concrete val (Some released)))
  :
    message_from_to mem loc from to
.
Hint Constructors message_from_to.

Lemma message_from_to_ts mem (CLOSED: Memory.closed mem) loc:
  message_from_to mem loc <2= Time.lt.
Proof.
  ii. inv PR. dup GET.
  eapply memory_get_ts_strong in GET. des; clarify.
  inv CLOSED. rewrite INHABITED in GET0. ss.
Qed.

Lemma finite_sub_order_wf l
      (R: Time.t -> Time.t -> Prop) (LT: R <2= Time.lt)
      (INCL: forall ts0 ts1 (LT: R ts0 ts1), List.In ts1 l)
  :
    well_founded R.
Proof.
  revert l INCL.
  assert (forall n l
                 (LEN: length l = n)
                 (SORTED: times_sorted l)
                 (INCL: forall ts0 ts1
                               (IN: List.In ts1 l)
                               (LT: R ts0 ts1)
                               (EXIST: exists ts, R ts ts0),
                     List.In ts0 l),
             forall ts1 (IN: List.In ts1 l), Acc R ts1).
  { induction n.
    - i. destruct l; ss.
    - i. hexploit (list_match_rev l). i. des; clarify.
      erewrite List.app_length in LEN. ss.
      rewrite Nat.add_comm in LEN. ss. clarify.
      eapply times_sorted_split in SORTED. des. ss.
      econs. i. eapply NNPP.
      ii. eapply H0. econs. i. exfalso. eapply H0.
      exploit (INCL y ts1); eauto. i.
      eapply List.in_app_or in x0. ss; des; clarify.
      + eapply IHn; eauto. i. des.
        exploit (INCL ts0 ts2); eauto.
        { eapply List.in_or_app. auto. }
        { i. eapply List.in_app_or in x1. ss. des; clarify.
          exploit (LT0 ts2 ts0); eauto. i.
          eapply LT in LT1. exfalso. eapply Time.lt_strorder. etrans; eauto. }
      + eapply List.in_app_or in IN. ss. des; clarify.
        * eapply LT0 in IN; eauto. exfalso.
          eapply LT in H. eapply Time.lt_strorder. etrans; eauto.
        * eapply LT in H1. exfalso. eapply Time.lt_strorder; eauto.

  }
  i. hexploit (sorting_sorted l). i. des.
  ii. eapply NNPP. ii. eapply H0. econs. i. exfalso. eapply H0.
  eapply INCL in H1. eapply H in SORTED; eauto.
  - i. des. eapply COMPLETE; eauto.
  - eapply COMPLETE; eauto.
Qed.

Lemma message_from_to_well_founded mem (CLOSED: Memory.closed mem) loc:
  well_founded (message_from_to mem loc).
Proof.
  Local Opaque sorting.
  hexploit (cell_finite_sound_exists (mem loc)). i. des.
  eapply finite_sub_order_wf; eauto.
  { eapply message_from_to_ts; auto. }
  { i. inv LT. eapply COMPLETE. eauto. }
Qed.

Definition get_released_view_fun (c: Configuration.t) (f: Loc.t -> Time.t -> option View.t): Prop :=
  forall loc to,
    match (f loc to) with
    | None =>
      forall tid st lc from val released
             (THREAD: IdentMap.find tid (Configuration.threads c) = Some (st, lc))
             (GET: Memory.get loc to (Local.promises lc) = Some (from, Message.concrete val (Some released))),
        False
    | Some releasedvw =>
      exists tid st lc from val released,
      (<<THREAD: IdentMap.find tid (Configuration.threads c) = Some (st, lc)>>) /\
      (<<GET: Memory.get loc to (Local.promises lc) = Some (from, Message.concrete val (Some released))>>) /\
      (<<RELEASED: releasedvw = View.join ((TView.rel (Local.tview lc)) loc) (View.singleton_ur loc to)>>) /\
      (<<CLOSED: Memory.closed_view releasedvw (Configuration.memory c)>>) /\
      (<<WF: View.wf releasedvw>>)
    end.

Program Definition make_views (mem: Memory.t) (CLOSED: Memory.closed mem)
        (f: Loc.t -> Time.t -> option View.t): Loc.t -> Time.t -> list View.t :=
  fun loc =>
    @Fix Time.t (message_from_to mem loc) (message_from_to_well_founded CLOSED loc) (fun _ => list View.t)
         (fun to _make_views =>
            match Memory.get loc to mem with
            | Some (from, Message.concrete val (Some released)) =>
              let pview := match f loc to with
                           | Some releasedvw => [releasedvw]
                           | None => []
                           end in (pview ++ released :: List.map (View.join (View.singleton_ur loc to)) (_make_views from _))
            | _ => []
            end).
Next Obligation.
  econs; eauto.
Qed.

Lemma make_views_red mem (CLOSED: Memory.closed mem) f loc to:
  make_views CLOSED f loc to =
  match Memory.get loc to mem with
  | Some (from, Message.concrete val (Some released)) =>
    let pview := match f loc to with
                 | Some releasedvw => [releasedvw]
                 | None => []
                 end in (pview ++ released :: List.map (View.join (View.singleton_ur loc to)) (make_views CLOSED f loc from))
  | _ => []
  end.
Proof.
  unfold make_views at 1. rewrite Fix_eq at 1; des_ifs. i.
  assert (f0 = g).
  { extensionality y. extensionality p. eapply H. } clarify.
Qed.

Lemma make_views_joined_memory mem (CLOSED: Memory.closed mem) f
      (WF: forall loc ts releasedvw (EQ: f loc ts = Some releasedvw),
          Memory.closed_view releasedvw mem)
  :
    joined_memory (make_views CLOSED f) mem.
Proof.
  econs.
  - i. rewrite make_views_red. rewrite GET.
    specialize (WF loc ts). splits.
    + eapply joined_view_exact. eapply List.in_or_app.
      right. ss. auto.
    + i. eapply List.in_or_app. right. right.
      rewrite View.join_comm. eapply List.in_map. eauto.
  - i. rewrite make_views_red in SOME. des_ifs; eauto.
  - intros loc.
    eapply (well_founded_ind (message_from_to_well_founded CLOSED loc) (fun to => List.Forall (fun vw => Memory.closed_view vw mem) (make_views CLOSED f loc to))); eauto.
    intros to. i. rewrite make_views_red.
    destruct (Memory.get loc to mem) as [[from [val [released|]|]]|] eqn:EQ; eauto.
    eapply Forall_app.
    + des_ifs. eapply WF in Heq. des; auto.
    + econs.
      { eapply CLOSED in EQ. des. inv MSG_CLOSED. inv CLOSED0. auto. }
      { eapply list_map_forall; eauto. i. ss.
        eapply Memory.join_closed_view; eauto.
        eapply Memory.singleton_ur_closed_view; eauto. eapply CLOSED. }
Qed.

Lemma make_views_wf_views mem (CLOSED: Memory.closed mem) f
      (WF: forall loc ts releasedvw (EQ: f loc ts = Some releasedvw),
          View.wf releasedvw)
  :
    wf_views (make_views CLOSED f).
Proof.
  intros loc.
  eapply (well_founded_ind (message_from_to_well_founded CLOSED loc) (fun to => List.Forall View.wf (make_views CLOSED f loc to))).
  intros to. i. rewrite make_views_red.
  destruct (Memory.get loc to mem) as [[from [val [released|]|]]|] eqn:EQ; eauto.
  eapply Forall_app.
  + des_ifs. eapply WF in Heq; eauto.
  + econs.
    { eapply CLOSED in EQ. des. inv MSG_WF. inv WF0. eauto. }
    { eapply list_map_forall; eauto. i. eapply View.join_wf; auto.
      eapply View.singleton_ur_wf; eauto. }
Qed.

Lemma joined_view_exist (c: Configuration.t)
      (WF: Configuration.wf c)
  :
    exists views,
      JConfiguration.wf views c.
Proof.
  assert (exists f, <<FSPEC: get_released_view_fun c f>>).
  { eapply (choice (fun loc floc =>
                      forall to, match (floc to) with
                                 | None =>
                                   forall tid st lc from val released
                                          (THREAD: IdentMap.find tid (Configuration.threads c) = Some (st, lc))
                                          (GET: Memory.get loc to (Local.promises lc) = Some (from, Message.concrete val (Some released))),
                                     False
                                 | Some releasedvw =>
                                   exists tid st lc from val released,
                                   (<<THREAD: IdentMap.find tid (Configuration.threads c) = Some (st, lc)>>) /\
                                   (<<GET: Memory.get loc to (Local.promises lc) = Some (from, Message.concrete val (Some released))>>) /\
                                   (<<RELEASED: releasedvw = View.join ((TView.rel (Local.tview lc)) loc) (View.singleton_ur loc to)>>) /\
                                   (<<CLOSED: Memory.closed_view releasedvw (Configuration.memory c)>>) /\
                                   (<<WF: View.wf releasedvw>>)
                                 end)).
    intros loc.
    eapply (choice (fun to releasedvw =>
                      match releasedvw with
                      | None =>
                        forall tid st lc from val released
                               (THREAD: IdentMap.find tid (Configuration.threads c) = Some (st, lc))
                               (GET: Memory.get loc to (Local.promises lc) = Some (from, Message.concrete val (Some released))),
                          False
                      | Some releasedvw =>
                        exists tid st lc from val released,
                        (<<THREAD: IdentMap.find tid (Configuration.threads c) = Some (st, lc)>>) /\
                        (<<GET: Memory.get loc to (Local.promises lc) = Some (from, Message.concrete val (Some released))>>) /\
                        (<<RELEASED: releasedvw = View.join ((TView.rel (Local.tview lc)) loc) (View.singleton_ur loc to)>>) /\
                        (<<CLOSED: Memory.closed_view releasedvw (Configuration.memory c)>>) /\
                        (<<WF: View.wf releasedvw>>)
                      end)).
    intros to.
    destruct (classic (exists tid st lc from val released,
                          (<<THRAED: IdentMap.find tid (Configuration.threads c) = Some (st, lc)>>) /\
                          (<<GET: Memory.get loc to (Local.promises lc) = Some (from, Message.concrete val (Some released))>>))).
    { des. exists (Some (View.join ((TView.rel (Local.tview lc)) loc) (View.singleton_ur loc to))). esplits; eauto.
      - destruct st. eapply Memory.join_closed_view.
        + eapply WF; eauto.
        + eapply WF in GET; eauto. eapply Memory.singleton_ur_closed_view; eauto.
          eapply WF.
      - destruct st. eapply View.join_wf.
        + eapply WF; eauto.
        + eapply View.singleton_ur_wf. }
    { exists None. i. eapply H. esplits; eauto. }
  }
  dup WF. inv WF0.
  des. exists (make_views MEM f). econs; eauto.
  - ii. rewrite make_views_red.
    dup GET. eapply WF in GET0; eauto. rewrite GET0.
    specialize (FSPEC loc ts). des_ifs.
    + des. clarify. destruct (Ident.eq_dec tid tid0); dep_clarify; eauto. exfalso.
      destruct st0. eapply WF in n; eauto.
      inv n. inv DISJOINT. exploit DISJOINT0; eauto. i. des; ss.
      eapply memory_get_ts_strong in GET. eapply memory_get_ts_strong in GET1. des; clarify.
      eapply x0; econs; eauto; ss; try refl.
    + exfalso. eapply FSPEC; eauto.
  - eapply make_views_joined_memory.
    i. specialize (FSPEC loc ts). rewrite EQ in *. des. eauto.
  - eapply make_views_wf_views.
    i. specialize (FSPEC loc ts). rewrite EQ in *. des. eauto.
Qed.


Require Import Coq.ZArith.BinInt.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.GeneralizeVarWf.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.GeneralizeVar.

Definition Wf_GeneralizeVar
           {t} (e1 : expr base_type op t)
           e'
           (He' : GeneralizeVar e1 = Some e')
  : Wf e'
  := @Wf_GeneralizeVar
       base_type op base_type_beq internal_base_type_dec_bl
       internal_base_type_dec_lb
       (fun _ t => Op (OpConst 0%Z) TT)
       t e1 e' He'.

Definition Wf_GeneralizeVar_arrow
           {s d} (e : expr base_type op (Arrow s d))
           e'
           (He' : GeneralizeVar e = Some e')
  : Wf e'
  := @Wf_GeneralizeVar_arrow
       base_type op base_type_beq internal_base_type_dec_bl
       internal_base_type_dec_lb
       (fun _ t => Op (OpConst 0%Z) TT)
       s d e e' He'.

Hint Resolve Wf_GeneralizeVar Wf_GeneralizeVar_arrow : wf.


Require Import coqutil.Macros.subst coqutil.Macros.unique bedrock2.Notations coqutil.Map.Interface coqutil.Map.OfListWord.
Require Import Coq.ZArith.BinIntDef coqutil.Word.Interface coqutil.Word.Bitwidth.
Require Import coqutil.dlet bedrock2.Syntax bedrock2.Semantics.

Section WeakestPrecondition.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * cmd)}.
  Context {ext_spec: ExtSpec}.
  Implicit Types (t : trace) (m : mem) (l : locals).

  Definition literal v (post : word -> Prop) : Prop :=
    dlet! v := word.of_Z v in post v.
  Definition get (l : locals) (x : String.string) (post : word -> Prop) : Prop :=
    bind_ex_Some v <- map.get l x; post v.
  Definition load s m a (post : _ -> Prop) : Prop :=
    bind_ex_Some v <- load s m a; post v.
  Definition store sz m a v post :=
    bind_ex_Some m <- store sz m a v; post m.

  Section WithMemAndLocals.
    Context (m : mem) (l : locals).
    Definition expr_body rec (e : Syntax.expr) (post : word -> Prop) : Prop :=
      match e with
      | expr.literal v =>
        literal v post
      | expr.var x =>
        get l x post
      | expr.op op e1 e2 =>
        rec e1 (fun v1 =>
        rec e2 (fun v2 =>
        post (interp_binop op v1 v2)))
      | expr.load s e =>
        rec e (fun a =>
        load s m a post)
      | expr.inlinetable s t e =>
        rec e (fun a =>
        load s (map.of_list_word t) a post)
      | expr.ite c e1 e2 =>
        rec c (fun b => rec (if word.eqb b (word.of_Z 0) then e2 else e1) post)
    end.
    Fixpoint expr e := expr_body expr e.
  End WithMemAndLocals.

  Section WithF.
    Context {A B} (f: A -> (B -> Prop) -> Prop).
    Definition list_map_body rec (xs : list A) (post : list B -> Prop) : Prop :=
      match xs with
      | nil => post nil
      | cons x xs' =>
        f x (fun y =>
        rec xs' (fun ys' =>
        post (cons y ys')))
      end.
    Fixpoint list_map xs := list_map_body list_map xs.
  End WithF.

  Section WithFunctions.
    Context (call : String.string -> trace -> mem -> list word -> (trace -> mem -> list word -> Prop) -> Prop).
    Definition dexpr m l e v := expr m l e (eq v).
    Definition dexprs m l es vs := list_map (expr m l) es (eq vs).
    Definition cmd_body (rec:_->_->_->_->_->Prop) (c : cmd) (t : trace) (m : mem) (l : locals)
             (post : trace -> mem -> locals -> Prop) : Prop :=
      (* give value of each pure expression when stating its subproof *)
      match c with
      | cmd.skip => post t m l
      | cmd.set x ev =>
        bind_ex v <- dexpr m l ev;
        dlet! l := map.put l x v in
        post t m l
      | cmd.unset x =>
        dlet! l := map.remove l x in
        post t m l
      | cmd.store sz ea ev =>
        bind_ex a <- dexpr m l ea;
        bind_ex v <- dexpr m l ev;
        store sz m a v (fun m =>
        post t m l)
      | cmd.stackalloc x n c =>
        Z.modulo n (bytes_per_word width) = 0 /\
        forall a mStack mCombined,
          anybytes a n mStack -> map.split mCombined m mStack ->
          dlet! l := map.put l x a in
          rec c t mCombined l (fun t' mCombined' l' =>
          exists m' mStack',
          anybytes a n mStack' /\ map.split mCombined' m' mStack' /\
          post t' m' l')
      | cmd.cond br ct cf =>
        bind_ex v <- dexpr m l br;
        (word.unsigned v <> 0%Z -> rec ct t m l post) /\
        (word.unsigned v = 0%Z -> rec cf t m l post)
      | cmd.seq c1 c2 =>
        rec c1 t m l (fun t m l => rec c2 t m l post)
      | cmd.while e c =>
        exists measure (lt:measure->measure->Prop) (inv:measure->trace->mem->locals->Prop),
        Coq.Init.Wf.well_founded lt /\
        (exists v, inv v t m l) /\
        (forall v t m l, inv v t m l ->
          bind_ex b <- dexpr m l e;
          (word.unsigned b <> 0%Z -> rec c t m l (fun t' m l =>
            exists v', inv v' t' m l /\ lt v' v)) /\
          (word.unsigned b = 0%Z -> post t m l))
      | cmd.call binds fname arges =>
        bind_ex args <- dexprs m l arges;
        call fname t m args (fun t m rets =>
          bind_ex_Some l <- map.putmany_of_list_zip binds rets l;
          post t m l)
      | cmd.interact binds action arges =>
        bind_ex args <- dexprs m l arges;
        exists mKeep mGive, map.split m mKeep mGive /\
        ext_spec t mGive action args (fun mReceive rets =>
          bind_ex_Some l' <- map.putmany_of_list_zip binds rets l;
          forall m', map.split m' mKeep mReceive ->
          post (cons ((mGive, action, args), (mReceive, rets)) t) m' l')
      end.
    Fixpoint cmd c := cmd_body cmd c.
  End WithFunctions.

  Definition func call '(innames, outnames, c) (t : trace) (m : mem) (args : list word) (post : trace -> mem -> list word -> Prop) :=
      bind_ex_Some l <- map.of_list_zip innames args;
      cmd call c t m l (fun t m l =>
        list_map (get l) outnames (fun rets =>
        post t m rets)).

  Definition call_body rec (functions : list (String.string * (list String.string * list String.string * cmd.cmd)))
                (fname : String.string) (t : trace) (m : mem) (args : list word)
                (post : trace -> mem -> list word -> Prop) : Prop :=
    match functions with
    | nil => False
    | cons (f, decl) functions =>
      if String.eqb f fname
      then func (rec functions) decl t m args post
      else rec functions fname t m args post
    end.
  Fixpoint call functions := call_body call functions.

  Definition program funcs main t m l post : Prop := cmd (call funcs) main t m l post.
End WeakestPrecondition.

Ltac unfold1_cmd e :=
  lazymatch e with
    @cmd ?width ?BW ?word ?mem ?locals ?ext_spec ?CA ?c ?t ?m ?l ?post =>
    let c := eval hnf in c in
    constr:(@cmd_body width BW word mem locals ext_spec CA
                      (@cmd width BW word mem locals ext_spec CA) c t m l post)
  end.
Ltac unfold1_cmd_goal :=
  let G := lazymatch goal with |- ?G => G end in
  let G := unfold1_cmd G in
  change G.

Ltac unfold1_expr e :=
  lazymatch e with
    @expr ?width ?word ?mem ?locals ?m ?l ?arg ?post =>
    let arg := eval hnf in arg in
    constr:(@expr_body width word mem locals m l (@expr width word mem locals m l) arg post)
  end.
Ltac unfold1_expr_goal :=
  let G := lazymatch goal with |- ?G => G end in
  let G := unfold1_expr G in
  change G.

Ltac unfold1_list_map e :=
  lazymatch e with
    @list_map ?A ?B ?P ?arg ?post =>
    let arg := eval hnf in arg in
    constr:(@list_map_body A B P (@list_map A B P) arg post)
  end.
Ltac unfold1_list_map_goal :=
  let G := lazymatch goal with |- ?G => G end in
  let G := unfold1_list_map G in
  change G.

Ltac unfold1_call e :=
  lazymatch e with
    @call ?width ?BW ?word ?mem ?locals ?ext_spec ?fs ?fname ?t ?m ?l ?post =>
    let fs := eval hnf in fs in
    constr:(@call_body width BW word mem locals ext_spec
                       (@call width BW word mem locals ext_spec) fs fname t m l post)
  end.
Ltac unfold1_call_goal :=
  let G := lazymatch goal with |- ?G => G end in
  let G := unfold1_call G in
  change G.

Import Coq.ZArith.ZArith.

Notation "'fnspec!' name a0 .. an '/' g0 .. gn '~>' r0 .. rn ',' '{' 'requires' tr mem := pre ';' 'ensures' tr' mem' ':=' post '}'" :=
  (fun functions =>
     (forall a0,
        .. (forall an,
              (forall g0,
                  .. (forall gn,
                         (forall tr mem,
                             pre ->
                             WeakestPrecondition.call
                               functions name tr mem (cons a0 .. (cons an nil) ..)
                               (fun tr' mem' rets =>
                                  (exists r0,
                                      .. (exists rn,
                                             rets = (cons r0 .. (cons rn nil) ..) /\
                                             post) ..)))) ..)) ..))
    (at level 200,
     name at level 0,
     a0 binder, an binder,
     g0 binder, gn binder,
     r0 closed binder, rn closed binder,
     tr name, tr' name, mem name, mem' name,
     pre at level 200,
     post at level 200).

Notation "'fnspec!' name a0 .. an '/' g0 .. gn ',' '{' 'requires' tr mem := pre ';' 'ensures' tr' mem' ':=' post '}'" :=
  (fun functions =>
     (forall a0,
        .. (forall an,
              (forall g0,
                  .. (forall gn,
                         (forall tr mem,
                             pre ->
                             WeakestPrecondition.call
                               functions name tr mem (cons a0 .. (cons an nil) ..)
                               (fun tr' mem' rets =>
                                  rets = nil /\ post))) ..)) ..))
    (at level 200,
     name at level 0,
     a0 binder, an binder,
     g0 binder, gn binder,
     tr name, tr' name, mem name, mem' name,
     pre at level 200,
     post at level 200).

Notation "'fnspec!' name a0 .. an '~>' r0 .. rn ',' '{' 'requires' tr mem := pre ';' 'ensures' tr' mem' ':=' post '}'" :=
  (fun functions =>
     (forall a0,
        .. (forall an,
               (forall tr mem,
                   pre ->
                   WeakestPrecondition.call
                     functions name tr mem (cons a0 .. (cons an nil) ..)
                     (fun tr' mem' rets =>
                        (exists r0,
                            .. (exists rn,
                                   rets = (cons r0 .. (cons rn nil) ..) /\
                                   post) ..)))) ..))
    (at level 200,
     name at level 0,
     a0 binder, an binder,
     r0 closed binder, rn closed binder,
     tr name, tr' name, mem name, mem' name,
     pre at level 200,
     post at level 200).

Notation "'fnspec!' name '/' g0 .. gn '~>' r0 .. rn ',' '{' 'requires' tr mem := pre ';' 'ensures' tr' mem' ':=' post '}'" :=
  (fun functions =>
        (forall an,
              (forall g0,
                  .. (forall gn,
                         (forall tr mem,
                             pre ->
                             WeakestPrecondition.call
                               functions name tr mem nil
                               (fun tr' mem' rets =>
                                  (exists r0,
                                      .. (exists rn,
                                             rets = (cons r0 .. (cons rn nil) ..) /\
                                             post) ..)))) ..)))
    (at level 200,
     name at level 0,
     g0 binder, gn binder,
     r0 closed binder, rn closed binder,
     tr name, tr' name, mem name, mem' name,
     pre at level 200,
     post at level 200).

Notation "'fnspec!' name a0 .. an ',' '{' 'requires' tr mem := pre ';' 'ensures' tr' mem' ':=' post '}'" :=
  (fun functions =>
     (forall a0,
        .. (forall an,
               (forall tr mem,
                   pre ->
                   WeakestPrecondition.call
                     functions name tr mem (cons a0 .. (cons an nil) ..)
                     (fun tr' mem' rets =>
                        rets = nil /\ post))) ..))
    (at level 200,
     name at level 0,
     a0 binder, an binder,
     tr name, tr' name, mem name, mem' name,
     pre at level 200,
     post at level 200).

Notation "'fnspec!' name '/' g0 .. gn ',' '{' 'requires' tr mem := pre ';' 'ensures' tr' mem' ':=' post '}'" :=
  (fun functions =>
              (forall g0,
                  .. (forall gn,
                         (forall tr mem,
                             pre ->
                             WeakestPrecondition.call
                               functions name tr mem nil
                               (fun tr' mem' rets =>
                                  rets = nil /\ post))) ..))
    (at level 200,
     name at level 0,
     g0 binder, gn binder,
     tr name, tr' name, mem name, mem' name,
     pre at level 200,
     post at level 200).

Notation "'fnspec!' name '~>' r0 .. rn ',' '{' 'requires' tr mem := pre ';' 'ensures' tr' mem' ':=' post '}'" :=
  (fun functions =>
     (forall tr mem,
         pre ->
         WeakestPrecondition.call
           functions name tr mem nil
           (fun tr' mem' rets =>
              (exists r0,
                  .. (exists rn,
                         rets = (cons r0 .. (cons rn nil) ..) /\
                         post) ..))))
    (at level 200,
     name at level 0,
     r0 closed binder, rn closed binder,
     tr name, tr' name, mem name, mem' name,
     pre at level 200,
     post at level 200).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C AB BC ABC BCprime Bprime Cprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ BC O /\ (wd_ Bprime O /\ (wd_ BC BCprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime BCprime /\ (col_ O Eprime Bprime /\ col_ O Eprime Cprime))))))))))))))))) -> col_ O B ABC)).
Proof.
  time tac.
Qed.

End FOFProblem.


From iris.algebra Require Export base.
From Autosubst Require Export Autosubst.

Global Instance Prop_inh : Inhabited Prop.
Proof. exact {| inhabitant := False |}. Qed.

Global Instance fun_inh `{∀ x : A, Inhabited (B x)} : Inhabited (∀ x, B x).
Proof. exact {| inhabitant := (λ x, inhabitant) |}. Qed.

CoInductive Stream (A : Type) : Type :=
  { Shead : A; Stail : Stream A }.

Arguments Shead {_} _.
Arguments Stail {_} _.

Lemma Stream_unfold {A} (p : Stream A) : p = {|Shead := Shead p; Stail := Stail p|}.
Proof. by destruct p. Qed.

CoFixpoint Sconst {A : Type} (a : A) := {| Shead := a; Stail := Sconst a |}.

Global Instance Stream_inh `{Inhabited A} : Inhabited (Stream A).
Proof. exact {| inhabitant := Sconst inhabitant |}. Qed.

CoInductive Seq {A : Type} : Stream A → Stream A → Prop :=
  Seq_refl : forall x y t1 t2,
    x = y → Seq t1 t2 → Seq {|Shead := x; Stail := t1|} {|Shead := y; Stail := t2|}.

Lemma eq_Seq {A : Type} (x y : Stream A) : x = y → Seq x y.
Proof.
  intros ->; revert y.
  cofix IH => y.
  destruct y.
  econstructor; auto.
Qed.

Axiom Seq_eq : ∀ {A : Type} (x y : Stream A), Seq x y → x = y.

Fixpoint Stake {A : Type} n (s : Stream A) : list A :=
  match n with
    O => []
  | S n' => (Shead s) :: (Stake n' (Stail s))
  end.

Definition Sdrop {A : Type} n (s : Stream A) : Stream A :=
  Nat.iter n Stail s.

Fixpoint Snth {A : Type} n (s : Stream A) : A :=
  match n with
  | O => Shead s
  | S n' => Snth n' (Stail s)
  end.

Lemma Snth_Sdrop {A : Type} n (s : Stream A) :
    Shead (Sdrop n s) = Snth n s.
Proof.
  revert s; induction n => s; simpl; first done.
  by rewrite -IHn /Sdrop -Nat_iter_S_r.
 Qed.

Lemma Snth_Sconst {A : Type} n (a : A) :
  Snth n (Sconst a) = a.
Proof.
  induction n; auto.
Qed.

Fixpoint prepend_n_from {A : Type} n (s s' : Stream A) :=
  match n with
    O => s'
  | S n' => {| Shead := Shead s;
              Stail := prepend_n_from n' (Stail s) s' |}
  end.

Lemma prepend_n_from_Snth {A : Type} n {s s' : Stream A} :
  prepend_n_from (S n) s s' =
  prepend_n_from n s {| Shead := Snth n s; Stail := s' |}.
Proof.
  simpl; revert s s'.
  induction n as [|n] => s s'; simpl; auto.
  f_equal.
  by rewrite IHn.
Qed.

Lemma prepen_n_from_same {A} n (μ : Stream A) :
  prepend_n_from n μ (Nat.iter n Stail μ) = μ.
Proof.
  revert μ. induction n => μ; auto.
  rewrite Nat_iter_S_r.
  destruct μ as [h t]; simpl.
  by rewrite IHn.
Qed.

Fixpoint append_l_s {A} (l : list A) (s : Stream A) :=
  match l with
  | [] => s
  | a :: l' => {|Shead := a; Stail := append_l_s l' s |}
  end.

Lemma append_l_s_app {A} (vs : list A) v μ :
  append_l_s (vs ++ [v]) μ = append_l_s vs {| Shead := v; Stail := μ |}.
Proof.
  induction vs; simpl; first done.
  by rewrite IHvs.
Qed.

CoFixpoint Smap {A B} (f : A → B) (μ : Stream A) : Stream B :=
  {|
    Shead := f (Shead μ);
    Stail := Smap f (Stail μ)
  |}.

CoFixpoint Smix {A} (mixer : Stream bool) (μ μ' : Stream A) : Stream A :=
  {|
    Shead := if Shead mixer then Shead μ else Shead μ';
    Stail := Smix (Stail mixer)
                    (if Shead mixer then Stail μ else μ)
                    (if Shead mixer then μ' else Stail μ')
  |}.

Lemma Smix_trues {A} (μ1 μ2 : Stream A) : Smix (Sconst true) μ1 μ2 = μ1.
Proof.
  apply Seq_eq.
  revert μ1 μ2; cofix => μ1 μ2.
  rewrite [Smix _ _ _]Stream_unfold.
  destruct μ1; simpl; constructor; eauto.
Qed.

Lemma Smix_falses {A} (μ1 μ2 : Stream A) : Smix (Sconst false) μ1 μ2 = μ2.
Proof.
  apply Seq_eq.
  revert μ1 μ2; cofix => μ1 μ2.
  rewrite [Smix _ _ _]Stream_unfold.
  destruct μ2; simpl; constructor; eauto.
Qed.

Definition interleaving {A} (μ1 μ2 : Stream A) : Stream A → Prop :=
  λ μ, ∃ mixer, Smix mixer μ1 μ2 = μ.

Lemma interR {A} v (μ1 μ2 μ : Stream A) :
  interleaving μ1 μ2 μ →
  interleaving {|Shead := v; Stail := μ1 |} μ2
               {|Shead := v; Stail := μ |}.
Proof.
  intros [mixer <-].
  exists {| Shead := true ; Stail := mixer |}.
  by rewrite [Smix {| Shead := true |} _ _]Stream_unfold /=.
Qed.

Lemma interL {A} v (μ1 μ2 μ : Stream A) :
  interleaving μ1 μ2 μ →
  interleaving μ1 {|Shead := v; Stail := μ2 |}
               {|Shead := v; Stail := μ |}.
Proof.
  intros [mixer <-].
  exists {| Shead := false ; Stail := mixer |}.
  by rewrite [Smix {| Shead := false |} _ _]Stream_unfold /=.
Qed.

Lemma interleaving_inh {A} (μ1 μ2 : Stream A) : (interleaving μ1 μ2) μ1.
Proof.
  exists (Sconst true); apply Smix_trues.
Qed.

Lemma Smix_Smap {A B} mixer (f : A → B) (μ μ' : Stream A) :
  Smap f (Smix mixer μ μ') = Smix mixer (Smap f μ) (Smap f μ').
Proof.
  apply Seq_eq.
  revert mixer μ μ'; cofix => mixer μ μ'.
  destruct mixer as [[] mixer].
  - destruct μ as [x μ].
    do 2 rewrite [Smix {| Shead := true |} _ _]Stream_unfold /=.
    rewrite [Smap _ _]Stream_unfold; simpl.
    constructor; auto.
  - destruct μ' as [x μ'].
    do 2 rewrite [Smix {| Shead := false |} _ _]Stream_unfold /=.
    rewrite [Smap _ _]Stream_unfold; simpl.
    constructor; auto.
Qed.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   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)         *)
(************************************************************************)

(** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
   in topoi [[Diaconescu75]]. Lacas and Werner adapted the proof to show
   that the axiom of choice in equivalence classes entails
   Excluded-Middle in Type Theory [[LacasWerner99]].

   Three variants of Diaconescu's result in type theory are shown below.

   A. A proof that the relational form of the Axiom of Choice +
      Extensionality for Predicates entails Excluded-Middle (by Hugo
      Herbelin)

   B. A proof that the relational form of the Axiom of Choice + Proof
      Irrelevance entails Excluded-Middle for Equality Statements (by
      Benjamin Werner)

   C. A proof that extensional Hilbert epsilon's description operator
      entails excluded-middle (taken from Bell [[Bell93]])

   See also [[Carlström04]] for a discussion of the connection between the
   Extensional Axiom of Choice and Excluded-Middle

   [[Diaconescu75]] Radu Diaconescu, Axiom of Choice and Complementation,
   in Proceedings of AMS, vol 51, pp 176-178, 1975.

   [[LacasWerner99]] Samuel Lacas, Benjamin Werner, Which Choices imply
   the excluded middle?, preprint, 1999.

   [[Bell93]] John L. Bell, Hilbert's epsilon operator and classical
   logic, Journal of Philosophical Logic, 22: 1-18, 1993

   [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent
   to AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
*)
Require ClassicalFacts ChoiceFacts.

(**********************************************************************)
(** * Pred. Ext. + Rel. Axiom of Choice -> Excluded-Middle       *)

Section PredExt_RelChoice_imp_EM.

(** The axiom of extensionality for predicates *)

Definition PredicateExtensionality :=
  forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q.

(** From predicate extensionality we get propositional extensionality
   hence proof-irrelevance *)

Import ClassicalFacts.

Variable pred_extensionality : PredicateExtensionality.

Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
Proof.
  intros A B H.
  change ((fun _ => A) true = (fun _ => B) true).
  rewrite
   pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B).
    reflexivity.
    intros _; exact H.
Qed.

Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2.
Proof.
  apply (ext_prop_dep_proof_irrel_cic prop_ext).
Qed.

(** From proof-irrelevance and relational choice, we get guarded
   relational choice *)

Import ChoiceFacts.

Variable rel_choice : RelationalChoice.

Lemma guarded_rel_choice : GuardedRelationalChoice.
Proof.
 apply
  (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
Qed.

(** The form of choice we need: there is a functional relation which chooses
    an element in any non empty subset of bool *)

Import Bool.

Lemma AC_bool_subset_to_bool :
  exists R : (bool -> Prop) -> bool -> Prop,
   (forall P:bool -> Prop,
      (exists b : bool, P b) ->
       exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')).
Proof.
  destruct (guarded_rel_choice _ _
   (fun Q:bool -> Prop =>  exists y : _, Q y)
   (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
    exact (fun _ H => H).
  exists R; intros P HP.
  destruct (HR P HP) as (y,(Hy,Huni)).
  exists y; firstorder.
Qed.

(** The proof of the excluded middle *)
(** Remark: P could have been in Set or Type *)

Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P.
Proof.
intro P.

(* first we exhibit the choice functional relation R *)
destruct AC_bool_subset_to_bool as [R H].

set (class_of_true := fun b => b = true \/ P).
set (class_of_false := fun b => b = false \/ P).

(* the actual "decision": is (R class_of_true) = true or false? *)
destruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
exists true; left; reflexivity.
destruct H0.

(* the actual "decision": is (R class_of_false) = true or false? *)
destruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
exists false; left; reflexivity.
destruct H1.

(* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
right.
intro HP.
assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
intro b; split.
unfold class_of_false; right; assumption.
unfold class_of_true; right; assumption.
assert (Heq : class_of_true = class_of_false).
apply pred_extensionality with (1 := Hequiv).
apply diff_true_false.
rewrite <- H0.
rewrite <- H1.
rewrite <- H0''. reflexivity.
rewrite Heq.
assumption.

(* cases where P is true *)
left; assumption.
left; assumption.

Qed.

End PredExt_RelChoice_imp_EM.

(**********************************************************************)
(** * Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)

(** This is an adaptation of Diaconescu's theorem, exploiting the
    form of extensionality provided by proof-irrelevance *)

Section ProofIrrel_RelChoice_imp_EqEM.

Import ChoiceFacts.

Variable rel_choice : RelationalChoice.

Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y.

(** Let [a1] and [a2] be two elements in some type [A] *)

Variable A :Type.
Variables a1 a2 : A.

(** We build the subset [A'] of [A] made of [a1] and [a2] *)

Definition A' := @sigT A (fun x => x=a1 \/ x=a2).

Definition a1':A'.
exists a1 ; auto.
Defined.

Definition a2':A'.
exists a2 ; auto.
Defined.

(** By proof-irrelevance, projection is a retraction *)

Lemma projT1_injective : a1=a2 -> a1'=a2'.
Proof.
  intro Heq ; unfold a1', a2', A'.
  rewrite Heq.
  replace (or_introl (a2=a2) (eq_refl a2))
     with (or_intror (a2=a2) (eq_refl a2)).
  reflexivity.
  apply proof_irrelevance.
Qed.

(** But from the actual proofs of being in [A'], we can assert in the
    proof-irrelevant world the existence of relevant boolean witnesses *)

Lemma decide : forall x:A', exists y:bool ,
  (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false).
Proof.
  intros [a [Ha1|Ha2]]; [exists true | exists false]; auto.
Qed.

(** Thanks to the axiom of choice, the boolean witnesses move from the
    propositional world to the relevant world *)

Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2.
Proof.
  destruct
    (rel_choice A' bool
       (fun x y =>  projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false))
    as (R,(HRsub,HR)).
    apply decide.
  destruct (HR a1') as (b1,(Ha1'b1,_Huni1)).
  destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2') as (b2,(Ha2'b2,Huni2)).
  destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2.
    rewrite (projT1_injective H) in Ha1'b1.
    assert (false = true) by auto using Huni2.
    discriminate.
  left; assumption.
Qed.

(** An alternative more concise proof can be done by directly using
    the guarded relational choice *)

Declare Implicit Tactic auto.

Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2.
Proof.
  assert (decide: forall x:A, x=a1 \/ x=a2 ->
                exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false).
    intros a [Ha1|Ha2]; [exists true | exists false]; auto.
  assert (guarded_rel_choice :=
          rel_choice_and_proof_irrel_imp_guarded_rel_choice
	  rel_choice
	  proof_irrelevance).
  destruct
    (guarded_rel_choice A bool
      (fun x => x=a1 \/ x=a2)
      (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false))
      as (R,(HRsub,HR)).
      apply decide.
  destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity.
  destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2) as (b2,(Ha2b2,Huni2)). right; reflexivity.
  destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2; subst a1.
    assert (false = true) by auto using Huni2, Ha1b1.
    discriminate.
  left; assumption.
Qed.

End ProofIrrel_RelChoice_imp_EqEM.

(**********************************************************************)
(** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *)

(** Proof sketch from Bell [[Bell93]] (with thanks to P. Castéran) *)

Local Notation inhabited A := A (only parsing).

Section ExtensionalEpsilon_imp_EM.

Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A.

Hypothesis epsilon_spec :
  forall (A:Type) (i:inhabited A) (P:A->Prop),
  (exists x, P x) -> P (epsilon A i P).

Hypothesis epsilon_extensionality :
  forall (A:Type) (i:inhabited A) (P Q:A->Prop),
  (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q.

Local Notation eps := (epsilon bool true) (only parsing).

Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P.
Proof.
  intro P.
  pose (B := fun y => y=false \/ P).
  pose (C := fun y => y=true  \/ P).
  assert (B (eps B)) as [Hfalse|HP]
    by (apply epsilon_spec; exists false; left; reflexivity).
  assert (C (eps C)) as [Htrue|HP]
    by (apply epsilon_spec; exists true; left; reflexivity).
    right; intro HP.
    assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption).
    rewrite epsilon_extensionality with (1:=H) in Hfalse.
    rewrite Htrue in Hfalse.
    discriminate.
  auto.
  auto.
Qed.

End ExtensionalEpsilon_imp_EM.