(**************************************************************************)
(*           *                                                            *)
(*     _     *   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                                      *)
(*           *                                                            *)
(**************************************************************************)

Set Implicit Arguments.

From Coq Require Import Relations Setoid List Multiset Arith Recdef Morphisms.
From CoLoR Require Import more_list list_permut ordered_set.

Ltac dummy a b a_eq_b :=
assert (Dummy : a = b); [exact a_eq_b | clear a_eq_b; rename Dummy into a_eq_b].

Module Type Sort.

Declare Module Import DOS : ordered_set.S.

Declare Module Import LPermut  :
  list_permut.S with Definition EDS.A := DOS.A
                      with Definition EDS.eq_A := @eq DOS.A.

(** *** Decomposition of the list wrt a pivot. *)
Function partition (pivot : A) (l : list A) {struct l} : (list A) * (list A) :=
  match l with
  | nil => (nil, nil)
  | a :: l' =>
	match partition pivot l' with (l1,l2) =>
	 if o_bool a pivot then (a :: l1, l2) else (l1, a :: l2)
        end
end.

Parameter quicksort : list A -> list A.

Function remove_list (la l : list A) {struct l} : option (list A) :=
  match la with
  | nil => Some l
  | a :: la' =>
	match l with
	| nil => None
	| b :: l' =>
	   if eq_bool a b
	   then remove_list la' l'
	   else
	     match remove_list la l' with
	     | None => None
	     | Some rmv => Some (b :: rmv)
	     end
        end
  end.

(** *** Definition of a sorted list. *)
Inductive is_sorted : list A -> Prop :=
  | is_sorted_nil : is_sorted nil
  | is_sorted_cons1 : forall t, is_sorted (t :: nil)
  | is_sorted_cons2 :
      forall t1 t2 l, o t1 t2 -> is_sorted (t2 :: l) -> is_sorted (t1 :: t2 :: l).

#[global] Hint Constructors is_sorted : core.

Parameter in_remove_list :
  forall l la, is_sorted la -> is_sorted l ->
  match remove_list la l with
  | None => forall rmv, ~ (permut (la ++ rmv) l)
  | Some rmv => permut (la ++ rmv) l
  end.

Parameter quicksort_equation : forall l : list A,
       quicksort l =
       match l with
       | nil => nil (A:=A)
       | h :: tl =>
           let (l1, l2) := partition h tl in
           quicksort l1 ++ h :: quicksort l2
       end.

Parameter quick_permut : forall l, permut l (quicksort l).

Parameter quick_permut_bis :
 forall l1 l2, permut l1 l2 -> permut (quicksort l1) l2.

Parameter length_quicksort : forall l, length (quicksort l) = length l.

Parameter in_quick_in : forall a l, In a l <-> In a (quicksort l).

Parameter sorted_tl_sorted : forall e l, is_sorted (e :: l) -> is_sorted l.

Parameter quick_sorted : forall l, is_sorted (quicksort l).

Parameter sort_is_unique :
  forall l1 l2, is_sorted l1 -> is_sorted l2 -> permut l1 l2 -> l1 = l2.

End Sort.

(** ** Definition of quicksort over lists. *)
Module Make (DOS1 : ordered_set.S) <: Sort with Module DOS := DOS1.

Module Import DOS := DOS1.

Module EDS := decidable_set.Convert(DOS1).

Module Import LPermut   <:
  list_permut.S with Definition EDS.A := DOS.A
                      with Definition EDS.eq_A := @eq DOS.A :=
list_permut.Make EDS.

  Global Instance mem_morph : Proper (eq ==> permut ==> iff) (mem EDS.eq_A).

  Proof. intros a b ab c d cd. subst. apply mem_permut_mem; trivial. Qed.

  Global Instance add_A_morph : Proper (eq ==> permut ==> permut) (List.cons (A:=A)).

  Proof. intros a b e l1 l2 P. rewrite <- permut_cons; trivial. Qed.

Global Instance length_morph : Proper (permut ==> eq) (length (A:=A)).

Proof. intros a b ab. eapply permut_length. apply ab. Qed.

(** *** Decomposition of the list wrt a pivot. *)
Function partition (pivot : A) (l : list A) {struct l} : (list A) * (list A) :=
  match l with
  | nil => (nil, nil)
  | a :: l' =>
	match partition pivot l' with (l1,l2) =>
	 if o_bool a pivot then (a :: l1, l2) else (l1, a :: l2)
        end
end.

Function quicksort (l : list A) { measure (@length A) l} : list A :=
   match l with
	| nil => nil
	| h :: tl =>
             match partition h tl with (l1, l2) =>
             quicksort l1 ++ h :: quicksort l2
        end
    end.
Proof.
(* 1 Second recursive call *)
intros e_l e l e_l_eq_e_l; subst e_l;
functional induction (partition e l)
   as [|H1 e' l' H2 IH l1 l2 rec_res e'_lt_e|H1 e' l' H2 IH l1 l2 rec_res H3];
intros ll1 ll2 Hpart; injection Hpart; intros H H'; subst.
(* 1.1 l = nil *)
simpl; auto with arith.
(* 1.2 l = _ :: _ *)
apply lt_trans with (length (e :: l')); [apply (IH _ _ rec_res) | auto with arith].
simpl; apply lt_n_S; apply (IH _ _ rec_res).

(* 2 First recursive call *)
intros e_l e l e_l_eq_e_l; subst e_l;
functional induction (partition e l)
   as [|H1 e' l' H2 IH l1 l2 rec_res e'_lt_e|H1 e' l' H2 IH l1 l2 rec_res H3];
intros ll1 ll2 Hpart; injection Hpart; intros H H'; subst.
(* 2.1 l = nil *)
simpl; auto with arith.
(* 2.2 l = _ :: _ *)
simpl; apply lt_n_S; apply (IH _ _ rec_res).
apply lt_trans with (length (e :: l')); [apply (IH _ _ rec_res) | auto with arith].
Defined.

(** *** The result of quicksort is a permutation of the original list. *)
Lemma partition_list_permut1 :
 forall e l, let (l1,l2) := partition e l in permut (l1 ++ l2) l.
Proof.
intros e l; functional induction (partition e l)
   as [|H1 e' l' H2 IH l1 l2 rec_res e'_lt_e|H1 e' l' H2 IH l1 l2 rec_res H3].
 (* l = nil *)
auto.
(* l = a :: l' /\ o_A a e *)
simpl app; rewrite rec_res in IH; rewrite IH; auto.
 (* l = a::l' /\ ~o_A a e *)
simpl app; rewrite rec_res in IH;
apply permut_sym; rewrite <- permut_cons_inside; auto.
reflexivity.
Qed.

Theorem quick_permut : forall l, permut l (quicksort l).
Proof.
intros l; functional induction (quicksort l)
   as [ | l a' l' l_eq_a'_l' l1 l2 H S1 S2]; auto.
(* 2.1 l = nil *)
rewrite <- permut_cons_inside.
assert (P := partition_list_permut1 a' l'); rewrite H in P.
rewrite <- P; rewrite <- S1; rewrite <- S2; auto.
reflexivity.
Qed.

Theorem quick_permut_bis :
 forall l1 l2, permut l1 l2 -> permut (quicksort l1) l2.
Proof.
intros l1 l2 P; apply permut_trans with l1; trivial;
apply permut_sym; apply quick_permut.
Qed.

(** *** Definition of a sorted list. *)
Inductive is_sorted : list A -> Prop :=
  | is_sorted_nil : is_sorted nil
  | is_sorted_cons1 : forall t, is_sorted (t :: nil)
  | is_sorted_cons2 :
      forall t1 t2 l, o t1 t2 -> is_sorted (t2 :: l) -> is_sorted (t1 :: t2 :: l).

#[global] Hint Constructors is_sorted : core.

(** *** The result of quicksort is a sorted list. *)
Lemma sorted_tl_sorted :
  forall e l, is_sorted (e :: l) -> is_sorted l.
Proof.
intros e l S; inversion S; auto.
Qed.

Lemma quick_sorted_aux1 :
  forall l1 l2 e, is_sorted l1 -> is_sorted l2 ->
  (forall a, mem EDS.eq_A a l1 -> o a e) ->
  (forall a, mem EDS.eq_A a l2 -> o e a) ->
  is_sorted (l1 ++ e :: l2).
Proof.
induction l1 as [ | e1 l1 ]; intros l2 e S1 S2 L1 L2.
simpl; destruct l2 as [ | e2 l2]; intros;
[apply is_sorted_cons1 | apply is_sorted_cons2 ]; trivial;
apply (L2 e2); simpl; left; reflexivity.
destruct l1 as [ | e1' l1] ; simpl; intros; apply is_sorted_cons2.
apply L1; left; reflexivity.
simpl in IHl1; apply IHl1; trivial; contradiction.
inversion S1; trivial.
rewrite app_comm_cons; apply IHl1; trivial.
inversion S1; trivial.
intros; apply L1; trivial; right; trivial.
Qed.

Lemma quick_sorted_aux3 :
  forall l e, let (l1,_) := partition e l in forall a, mem EDS.eq_A a l1 -> o a e.
Proof.
intros l e;
  functional induction (partition e l) as
    [|l a' l' l_eq_a'_l' IH l1' l2' H a'_lt_e
     |l a' l' l_eq_a'_l' IH l1' l2' H _H].
contradiction.
intros a [a_eq_a' | a_in_l1']; [idtac | rewrite H in IH; apply IH; trivial].
generalize (o_bool_ok a' e); dummy a a' a_eq_a'; subst; rewrite a'_lt_e; trivial.
intros; rewrite H in IH; apply IH; trivial.
Qed.

Lemma quick_sorted_aux4 :
  forall l e, let (_,l2) := partition e l in forall a, mem EDS.eq_A a l2 -> o e a.
Proof.
intros l e;
functional induction (partition e l)
  as [|l a' l' l_eq_a'_l' IH l1' l2' H a'_lt_e
      |l a' l' l_eq_a'_l' IH l1' l2' H a'_ge_e].
contradiction.
intros; rewrite H in IH; apply IH; trivial.
intros a [a_eq_a' | a_in_l1']; [subst | rewrite H in IH; apply IH]; trivial.
dummy a a' a_eq_a'; subst; trivial.
generalize (o_bool_ok a' e); rewrite a'_ge_e; intro a'_ge_e'.
destruct (o_total e a'); intros.
assumption.
absurd (DOS.o a' e); assumption.
Qed.

Theorem quick_sorted : forall l, is_sorted (quicksort l).
Proof.
intros l;
functional induction (quicksort l)
   as [ | l a' l' l_eq_a'_l' l1 l2 H S1 S2].
auto.
apply quick_sorted_aux1; trivial.
intros a a_in_ql1;
assert (H1 := quick_sorted_aux3 l' a'); rewrite H in H1; apply H1.
rewrite (mem_permut_mem a (quick_permut l1)); trivial.
intros a a_in_ql2;
assert (H2 := quick_sorted_aux4 l' a'); rewrite H in H2;
apply H2; rewrite (mem_permut_mem a (quick_permut l2)); trivial.
Qed.

(** ***  There is a unique sorted list equivalent up to a permutation to a given list.*)
Lemma sorted_cons_min :
 forall l e, is_sorted (e :: l) -> (forall e', mem EDS.eq_A e' (e :: l) -> o e e').
Proof.
simpl; intros l e S e' [e'_eq_e | e'_in_l].
dummy e' e e'_eq_e; subst; trivial.
generalize o_proof; intro O; inversion O as [R _ _]; apply R.
generalize e S e' e'_in_l; clear e S e' e'_in_l; induction l as [ | a l ].
intros e _ e' e'_in_nil; elim e'_in_nil.
simpl; intros e S e' [e'_eq_a | e'_in_l].
dummy e' a e'_eq_a; subst e'; inversion S; trivial.
generalize o_proof; intro O; inversion O as [ _ T _ ]; apply T with a.
inversion S; trivial.
apply IHl; trivial; inversion S; trivial.
Qed.

Theorem sort_is_unique :
  forall l1 l2, is_sorted l1 -> is_sorted l2 -> permut l1 l2 -> l1 = l2.
Proof.
induction l1 as [ | e1 l1 ]; intros l2 S1 S2 P.
inversion P; trivial.
inversion P as [ | a b l k1 k2 a_eq_b P' H1 H']; dummy e1 b a_eq_b; subst.
destruct k1 as [ | a1 k1].
rewrite (IHl1 k2); trivial.
inversion S1; trivial.
inversion S2; trivial.
assert (e1_eq_a1 : b = a1).
assert (O:= o_proof); inversion O as [ _ _ AS ]; apply AS; clear O AS.
apply (sorted_cons_min S1); rewrite P; left; reflexivity.
apply (sorted_cons_min S2); rewrite <- P; left; reflexivity.
subst a1; rewrite (IHl1 (k1 ++ b :: k2)); trivial.
apply sorted_tl_sorted with b; trivial.
apply sorted_tl_sorted with b; trivial.
simpl in P; rewrite <- permut_cons in P; trivial.
reflexivity.
Qed.

(** Some usefull properties on the result of quicksort. *)
Lemma length_quicksort : forall l, length (quicksort l) = length l.
Proof.
intro l; apply permut_length with EDS.eq_A;
apply permut_sym; apply quick_permut.
Qed.

Lemma in_quick_in : forall a l, In a l <-> In a (quicksort l).
Proof.
intros a l; apply in_permut_in.
apply quick_permut.
Qed.

Lemma in_quicksort_cons : forall a l, In a (quicksort (a :: l)).
Proof.
intros a l; rewrite <- in_quick_in; left; trivial.
Qed.

(** What happens when a sorted list is removed from another one.*)
Function remove_list (la l : list A) {struct l} : option (list A) :=
  match la with
  | nil => Some l
  | a :: la' =>
	match l with
	| nil => None
	| b :: l' =>
	   if eq_bool a b
	   then remove_list la' l'
	   else
	     match remove_list la l' with
	     | None => None
	     | Some rmv => Some (b :: rmv)
	     end
        end
  end.

Lemma in_remove_list :
  forall l la, is_sorted la -> is_sorted l ->
  match remove_list la l with
  | None => forall rmv, ~ (permut (la ++ rmv) l)
  | Some rmv => permut (la ++ rmv) l
  end.
Proof.
fix in_remove_list 1.
intro l; case l; clear l.
(* l = [] *)
intro la; simpl; case la; clear la.
intros _ _; apply Pnil.
intros a la Sla _ rmv P; assert (H := permut_length P); discriminate.
(* l = _ :: _ *)
intros e l la; simpl; case la; clear la.
intros _ _; reflexivity.
intros a la Sala Sel ; assert (Sl := sorted_tl_sorted Sel).
assert (Sla := sorted_tl_sorted Sala).
generalize (eq_bool_ok a e); case (eq_bool a e).
intros a_eq_e; generalize (in_remove_list l la Sla Sl); case (remove_list la l).
intros rmv P; simpl; rewrite <- permut_cons; assumption.
intros H rmv P; apply (H rmv); simpl in P; rewrite <- permut_cons in P; assumption.
intros a_diff_e; generalize (in_remove_list l (a :: la) Sala Sl); case (remove_list (a :: la) l).
intros rmv P; symmetry; rewrite <- permut_cons_inside.
symmetry; assumption.
reflexivity.
intros H rmv P.
assert (e_in_larm : mem EDS.eq_A e ((a :: la) ++ rmv)).
rewrite (mem_permut_mem e P); left; reflexivity.
simpl in e_in_larm; case e_in_larm; clear e_in_larm.
intro e_eq_a; apply a_diff_e; symmetry; assumption.
rewrite <- mem_or_app; intro e'_in_larm; case e'_in_larm; clear e'_in_larm.
intro e_in_la; apply a_diff_e;
assert (O := o_proof); inversion_clear O as [ _ _ AS]; apply AS.
apply sorted_cons_min with la; [apply Sala | right; trivial].
apply sorted_cons_min with l; [apply Sel | rewrite <- P; left; reflexivity].
intro e_in_rmv; case (mem_split_set _ _ eq_bool_ok _ _ e_in_rmv);
intros e' M; case M; clear M.
intros l1 M; case M; clear M.
intros l2 M; case M; clear M.
intros e_eq_e' M; case M; clear M.
intros M _; subst rmv.
apply (H (l1 ++ l2)).
rewrite ass_app in P; simpl in P.
assert (P' := permut_add_inside ((a :: la) ++ l1) l2 nil l (sym_eq e_eq_e')); simpl in P'.
rewrite <- P' in P.
rewrite ass_app; simpl; assumption.
Qed.

End Make.

(*
(** *** The lists resulting from the partition are not longer than the original one. *)
Lemma length_fst_partition :
 forall n, forall pivot, forall l,
  length l <= n -> length (fst (partition pivot l)) < S n.
Proof.
induction n; intros pivot l; destruct l as [ | e l ]; simpl; auto with arith.
intro H; generalize (le_Sn_O (length l) H); intros; contradiction.
intro L'; assert (L : length l <= n).
apply le_S_n; trivial.
generalize (IHn pivot l L); destruct (partition pivot l);
destruct (o_elt_dec e pivot); simpl; auto with arith.
Qed.

Lemma length_snd_partition :
 forall n, forall pivot, forall l,
  length l <= n -> length (snd (partition pivot l)) < S n.
Proof.
induction n; intros pivot l; destruct l as [ | e l ]; simpl; auto with arith.
intro H; generalize (le_Sn_O (length l) H); intros; contradiction.
intro L'; assert (L : length l <= n).
apply le_S_n; trivial.
generalize (IHn pivot l L); destruct (partition pivot l);
destruct (o_elt_dec e pivot); simpl; auto with arith.
Qed.

(** *** Definition of a step of quicksort. *)
Definition F_quick :
  forall l : list elt, (forall y : list elt , o_length y l -> list elt) -> list elt.
Proof.
destruct l as [ | e l ].
intros; exact nil.
intro qrec;
set (pl := partition e l);
exact
((qrec (fst pl) (length_fst_partition e l (le_n (length l)))) ++
 e :: (qrec (snd pl) (length_snd_partition e l (le_n (length l))))).
Defined.

(** *** Definition of quicksort. *)
Definition quicksort : forall (l : list elt), (list elt) :=
Fix (@well_founded_length elt) (fun l => list elt) F_quick.

(** *** A more practical equivalent definition of quicksort. *)
Lemma quicksort_unfold : forall l : list elt,
quicksort l = @F_quick l (fun y _ => quicksort y).
Proof.
intros; unfold quicksort;
apply Fix_eq with (P:= (fun _:list elt => list elt)).
unfold F_quick; destruct x; simpl; auto.
intros f g H; do 2 rewrite H; trivial.
Save.

(** *** Sorting the empty list yields the empty list. *)
Lemma quick_nil : quicksort nil = nil.
Proof.
rewrite quicksort_unfold; unfold F_quick; simpl; trivial.
Qed.

(** *** The usual equality on quicksort. *)
Lemma quick_cons_aux1 :
  forall e l, quicksort (e :: l) =
              let pl := partition e l in
              (quicksort (fst pl)) ++ e :: (quicksort (snd pl)).
Proof.
intros e l; rewrite quicksort_unfold; unfold F_quick; simpl; trivial.
Qed.

Theorem quick_cons :
 forall e l, let (l1,l2) := partition e l in
 quicksort (e :: l) = (quicksort l1) ++ e :: (quicksort l2).
Proof.
intros; generalize (quick_cons_aux1 e l); destruct (partition e l).
trivial.
Save.

Extract Constant eq_elt_dec => eq.
Extract Constant o_elt_dec => le.
Extract Constant elt => int.
Extraction split_list.
Extraction partition.
Extraction NoInline partition.
Extraction quicksort.
*)


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Elab.Elab Tools.Matches.
From Pyrosome.Lang Require Import SimpleVSubst SimpleUnit SimpleEvalCtx.
Import Core.Notations.

Require Coq.derive.Derive.

Definition nat_lang_def : lang :=
  {[l
  [s|
      -----------------------------------------------
      #"natural" srt
  ];
  [:|
       -----------------------------------------------
       #"0" : #"natural"
  ];
  [:|  "n": #"natural"
       -----------------------------------------------
       #"1+" "n" : #"natural"
  ];
  [s|  "n": #"natural", "m": #"natural"
       -----------------------------------------------
       #"neq" "n" "m" srt
  ];
  [:|  "n": #"natural"
       -----------------------------------------------
       #"neq_0_l" : #"neq" #"0" (#"1+" "n")
  ];
  [:|  "n": #"natural"
       -----------------------------------------------
       #"neq_0_r" : #"neq" (#"1+" "n") #"0"
  ];
  [:|  "n": #"natural", "m": #"natural",
       "p" : #"neq" "n" "m"
       -----------------------------------------------
       #"neq_1+" "p" : #"neq" (#"1+" "n") (#"1+" "m")
  ]
  ]}.

Derive nat_lang
       SuchThat (elab_lang_ext [] nat_lang_def nat_lang)
       As nat_lang_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve nat_lang_wf : elab_pfs.

Definition nat_exp_def : lang :=
  {[l/subst
  [:|
      -----------------------------------------------
      #"nat" : #"ty"
  ];
  [:|  "G" : #"env", "n": #"natural"
       -----------------------------------------------
       #"nv" "n" : #"val" "G" #"nat"
  ]]}.

Derive nat_exp
       SuchThat (elab_lang_ext (nat_lang ++ value_subst)
                               nat_exp_def
                               nat_exp)
       As nat_exp_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve nat_exp_wf : elab_pfs.

(*TODO: might need set empty 0 = empty axiom *)
Definition heap_def : lang :=
  {[l
  [s|
      -----------------------------------------------
      #"heap" srt
  ];
  [:|
       -----------------------------------------------
       #"hempty" : #"heap"
  ];
  [:|  "H" : #"heap",
       "l" : #"natural",
       "n" : #"natural"
       -----------------------------------------------
       #"hset" "H" "l" "n" : #"heap"
  ];
  [:=  "H" : #"heap",
       "l" : #"natural",
       "n" : #"natural",
       "m" : #"natural"
       ----------------------------------------------- ("heap_shadow")
       #"hset" (#"hset" "H" "l" "n") "l" "m"
       = #"hset" "H" "l" "m"
       : #"heap"
  ];
  [:=  "H" : #"heap",
       "l" : #"natural",
       "n" : #"natural",
       "l'" : #"natural",
       "m" : #"natural",
       "p_neq" : #"neq" "n" "m"
       ----------------------------------------------- ("heap_comm")
       #"hset" (#"hset" "H" "l" "n") "l'" "m"
       = #"hset" (#"hset" "H" "l'" "m") "l" "n"
       : #"heap"
  ];
  [:|  "H" : #"heap",
       "l" : #"natural"
       -----------------------------------------------
       #"lookup" "H" "l" : #"natural"
  ];
  [:=  "H" : #"heap",
       "l" : #"natural",
       "n" : #"natural"
       ----------------------------------------------- ("lookup_found")
       #"lookup" (#"hset" "H" "l" "n") "l" = "n"
       : #"natural"
  ];
  [:=  "H" : #"heap",
       "l" : #"natural",
       "n" : #"natural",
       "l'" : #"natural",
       "p_neq" : #"neq" "l" "l'"
       ----------------------------------------------- ("lookup_miss")
       #"lookup" (#"hset" "H" "l" "n") "l'"
       = #"lookup" "H" "l'"
       : #"natural"
  ];
  [:=  "H" : #"heap",
       "l" : #"natural"
       ----------------------------------------------- ("lookup_empty")
       #"lookup" #"hempty" "l" = #"0"
       : #"natural"
  ]
  ]}.

Derive heap
       SuchThat (elab_lang_ext nat_lang
                               heap_def
                               heap)
       As heap_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve heap_wf : elab_pfs.

(*simple heap operations w/axioms avoiding an explicit heap
  TODO: depends on let, unit, natural numbers, nat-as-exp
  TODO: subst rules
*)
Definition heap_ops_def : lang :=
  {[l/subst
  [:|  "G" : #"env",
       "e" : #"exp" "G" #"nat",
       "e'" : #"exp" "G" #"nat"
       -----------------------------------------------
       #"set" "e" "e'" : #"exp" "G" #"unit"
  ];
  [:|  "G" : #"env",
       "e" : #"exp" "G" #"nat"
       -----------------------------------------------
       #"get" "e" : #"exp" "G" #"nat"
  ];
  [s|  "G" : #"env", "A" : #"ty"
       -----------------------------------------------
       #"configuration" "G" "A" srt
  ];
  [:|  "H" : #"heap",
       "G" : #"env", "A" : #"ty",
       "e" : #"exp" "G" "A"
       -----------------------------------------------
       #"config" "H" "e" : #"configuration" "G" "A"
  ];
  [:=  "H" : #"heap",
       "n" : #"natural",
       "m" : #"natural",
       "G" : #"env"
       ----------------------------------------------- ("eval get")
       #"config" "H" (#"get" (#"ret" (#"nv" "n")))
       = #"config" "H" (#"ret" (#"nv" (#"lookup" "H" "n")))
       : #"configuration" "G" #"nat"
  ];
  [:=  "H" : #"heap",
       "l" : #"natural",
       "n" : #"natural",
       "G" : #"env"
       ----------------------------------------------- ("eval set")
       #"config" "H" (#"set" (#"ret" (#"nv" "l")) (#"ret" (#"nv" "n")))
       = #"config" (#"hset" "H" "l" "n") (#"ret" #"tt")
       : #"configuration" "G" #"unit"
  ]
  ]}.

Derive heap_ops
       SuchThat (elab_lang_ext (unit_lang ++ heap ++ nat_exp++ nat_lang ++ exp_subst ++ value_subst)
                               heap_ops_def
                               heap_ops)
       As heap_ops_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve heap_ops_wf : elab_pfs.

Definition heap_ctx_def : lang :=
  {[l
  [:|  "G" : #"env",
       "A" : #"ty",
       "E" : #"Ectx" "G" "A" #"nat",
       "e'" : #"exp" "G" #"nat"
       -----------------------------------------------
       #"Eset_l" "E" "e'" : #"Ectx" "G" "A" #"unit"
  ];
  [:|  "G" : #"env",
       "A" : #"ty",
       "v" : #"val" "G" #"nat",
       "E" : #"Ectx" "G" "A" #"nat"
       -----------------------------------------------
       #"Eset_r" "v" "E" : #"Ectx" "G" "A" #"unit"
  ];
  [:|  "G" : #"env",
       "A" : #"ty",
       "E" : #"Ectx" "G" "A" #"nat"
       -----------------------------------------------
       #"Eget" "E" : #"Ectx" "G" "A" #"nat"
  ];
  [:=  "G" : #"env",
       "A" : #"ty",
       "E" : #"Ectx" "G" "A" #"nat",
       "e" : #"exp" "G" "A"
       ----------------------------------------------- ("plug Eget")
       #"plug" (#"Eget" "E") "e"
       = #"get" (#"plug" "E" "e")
       : #"exp" "G" #"nat"
  ];
  [:=  "G" : #"env",
       "A" : #"ty",
       "E" : #"Ectx" "G" "A" #"nat",
       "e'" : #"exp" "G" #"nat",
       "e" : #"exp" "G" "A"
       ----------------------------------------------- ("plug Eset_l")
       #"plug" (#"Eset_l" "E" "e'") "e"
       = #"set" (#"plug" "E" "e") "e'"
       : #"exp" "G" #"unit"
  ];
  [:=  "G" : #"env",
       "A" : #"ty",
       "v" : #"val" "G" #"nat",
       "E" : #"Ectx" "G" "A" #"nat",
       "e" : #"exp" "G" "A"
       ----------------------------------------------- ("plug Eset_r")
       #"plug" (#"Eset_r" "v" "E") "e"
       = #"set" (#"ret" "v") (#"plug" "E" "e")
       : #"exp" "G" #"unit"
  ];
  [:=  "H" : #"heap",
       "n" : #"natural",
       "m" : #"natural",
       "G" : #"env",
       "A" : #"ty",
       "E" : #"Ectx" "G" #"nat" "A"
       ----------------------------------------------- ("eval E get")
       #"config" "H" (#"plug" "E" (#"get" (#"ret" (#"nv" "n"))))
       = #"config" "H" (#"plug" "E" (#"ret" (#"nv" (#"lookup" "H" "n"))))
       : #"configuration" "G" "A"
  ];
  [:=  "H" : #"heap",
       "l" : #"natural",
       "n" : #"natural",
       "G" : #"env",
       "A" : #"ty",
       "E" : #"Ectx" "G" #"unit" "A"
       ----------------------------------------------- ("eval E set")
       #"config" "H" (#"plug" "E" (#"set" (#"ret" (#"nv" "l")) (#"ret" (#"nv" "n"))))
       = #"config" (#"hset" "H" "l" "n") (#"plug" "E" (#"ret" #"tt"))
       : #"configuration" "G" "A"
  ]
  ]}.

Derive heap_ctx
       SuchThat (elab_lang_ext (eval_ctx ++ heap_ops
                                  ++ unit_lang
                                  ++ heap ++ nat_exp
                                  ++ nat_lang ++ exp_subst
                                  ++ value_subst)
                               heap_ctx_def
                               heap_ctx)
       As heap_ctx_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve heap_ctx_wf : elab_pfs.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  zNil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
 induction x.
 - intros.  simpl. lfind.  simpl.
Admitted.


Require Import Coq.Arith.PeanoNat.
Require Import Coq.ZArith.ZArith.
Require Import riscv.Utility.Tactics.
Require Import coqutil.Z.Lia.

Local Open Scope nat_scope.

Lemma rewrite_div_mod: forall (a b: nat),
    b <> 0 ->
    exists q r, a mod b = r /\ a / b = q /\ a = b * q + r /\ r < b.
Proof.
  intros.
  exists (a / b). exists (a mod b).
  rewrite <- (Nat.div_mod a b) by assumption.
  pose proof (Nat.mod_upper_bound a b).
  auto.
Qed.

Ltac nat_div_mod_to_quot_rem_step :=
  so fun hyporgoal => match hyporgoal with
  | context [?a mod ?b] =>
      let Ne := fresh "Ne" in
      let P := fresh "P" in
      assert (b <> 0) as Ne by blia;
      pose proof (rewrite_div_mod a b Ne) as P;
      clear Ne;
      let q := fresh "q" in
      let r := fresh "r" in
      let Er := fresh "Er" in
      let Eq := fresh "Eq" in
      let E := fresh "E" in
      let B := fresh "B" in
      destruct P as [ q [ r [ Er [ Eq [ E B ] ] ] ] ];
      rewrite? Er in *;
      rewrite? Eq in *;
      clear Er Eq
  end.

Ltac nat_div_mod_to_quot_rem := repeat nat_div_mod_to_quot_rem_step.


Require Import Braun.monad.monad Braun.common.big_oh.
Require Import Braun.common.braun Braun.common.util.
Require Import Omega.

Section size_linear.
  Variable A : Set.

  Definition size_linear_rt n : nat := 13 * n + 3.

  Definition size_linear_result (bt : @bin_tree A) (res:nat) c :=
    c = size_linear_rt res /\
    (forall m,
       Braun bt m ->
       m = res).

  (* the blank line above is important for the paper to build *)
  Load "size_linear_gen.v".

  Next Obligation.
  Proof.
    split; [auto |].
    intros m B.
    invclr B.
    auto.
  Qed.

  Next Obligation.
  Proof.
    clear am0 H2 am H3.
    rename H0 into SLRr.
    rename H1 into SLRl.

    destruct SLRr as [XNeq Br].
    destruct SLRl as [XN0eq Bl].
    subst an an0.

    split.
    unfold size_linear_rt.
    omega.

    intros m B.
    invclr B.
    auto.
  Qed.

  Theorem size_linear_rt_is_linear : big_oh size_linear_rt (fun n => n).
  Proof.
    unfold size_linear_rt; auto.
  Qed.

End size_linear.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) y)) (append (rev y) x).
Proof.
   induction x.
   - intros. simpl. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite append_assoc. rewrite IHx. simpl.
lfind.  simpl.  reflexivity.
Admitted.


(************************************************************************)
(*         *   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)         *)
(************************************************************************)
(************************************************************************)

(** This file provides classical logic and indefinite description under
    the form of Hilbert's epsilon operator *)

(** Hilbert's epsilon operator and classical logic implies
    excluded-middle in [Set] and leads to a classical world populated
    with non computable functions. It conflicts with the
    impredicativity of [Set] *)

Require Export Classical.
Require Import ChoiceFacts.

Set Implicit Arguments.

Axiom constructive_indefinite_description :
  forall (A : Type) (P : A->Prop),
    (exists x, P x) -> { x : A | P x }.

Lemma constructive_definite_description :
  forall (A : Type) (P : A->Prop),
    (exists! x, P x) -> { x : A | P x }.
Proof.
  intros; apply constructive_indefinite_description; firstorder.
Qed.

Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
Proof.
  apply
    (constructive_definite_descr_excluded_middle
      constructive_definite_description classic).
Qed.

Theorem classical_indefinite_description :
  forall (A : Type) (P : A->Prop), inhabited A ->
    { x : A | (exists x, P x) -> P x }.
Proof.
  intros A P i.
  destruct (excluded_middle_informative (exists x, P x)) as [Hex|HnonP].
  apply constructive_indefinite_description
    with (P:= fun x => (exists x, P x) -> P x).
  destruct Hex as (x,Hx).
    exists x; intros _; exact Hx.
  assert {x : A | True} as (a,_).
    apply constructive_indefinite_description with (P := fun _ : A => True).
    destruct i as (a); firstorder.
  firstorder.
Defined.

(** Hilbert's epsilon operator *)

Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A
  := proj1_sig (classical_indefinite_description P i).

Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) :
  (exists x, P x) -> P (epsilon i P)
  := proj2_sig (classical_indefinite_description P i).

(** Open question: is classical_indefinite_description constructively
    provable from [relational_choice] and
    [constructive_definite_description] (at least, using the fact that
    [functional_choice] is provable from [relational_choice] and
    [unique_choice], we know that the double negation of
    [classical_indefinite_description] is provable (see
    [relative_non_contradiction_of_indefinite_desc]). *)

(** A proof that if [P] is inhabited, [epsilon a P] does not depend on
    the actual proof that the domain of [P] is inhabited
    (proof idea kindly provided by Pierre Castéran) *)

Lemma epsilon_inh_irrelevance :
   forall (A:Type) (i j : inhabited A) (P:A->Prop),
   (exists x, P x) -> epsilon i P = epsilon j P.
Proof.
 intros.
 unfold epsilon, classical_indefinite_description.
 destruct (excluded_middle_informative (exists x : A, P x)) as [|[]]; trivial.
Qed.

Opaque epsilon.

(** *** Weaker lemmas (compatibility lemmas) *)

Theorem choice :
  forall (A B : Type) (R : A->B->Prop),
    (forall x : A, exists y : B, R x y) ->
    (exists f : A->B, forall x : A, R x (f x)).
Proof.
  intros A B R H.
  exists (fun x => proj1_sig (constructive_indefinite_description _ (H x))).
  intro x.
  apply (proj2_sig (constructive_indefinite_description _ (H x))).
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq.
From mathcomp Require Import choice fintype finfun bigop finset.
Require Import Reals Fourier.
Require Import ssrR Reals_ext Ranalysis_ext logb ln_facts bigop_ext Rbigop.

(** * The log-sum Inequality *)

Local Open Scope reals_ext_scope.

Local Notation "'\rsum_{' C '}' f" :=
  (\rsum_(a | a \in C) f a) (at level 10, format "\rsum_{ C }  f").

Definition log_sum_stmt {A : finType} (C : {set A}) (f g : A -> R+) :=
  f << g ->
  \rsum_{C} f * log (\rsum_{C} f / \rsum_{C} g) <= \rsum_(a | a \in C) f a * log (f a / g a).

Lemma log_sum1 {A : finType} (C : {set A}) (f g : A -> R+) :
  (forall a, a \in C -> 0 < f a) -> log_sum_stmt C f g.
Proof.
move=> fspos fg.
case/boolP : (C == set0) => [ /eqP -> | Hc].
  rewrite !big_set0 mul0R; exact/leRR.
have gspos : forall a, a \in C -> 0 < g a.
  move=> a a_C.
  case/Rle_lt_or_eq_dec : ((pos_f_ge0 g) a) => // abs; symmetry in abs; apply fg in abs.
  move: (fspos _ a_C); by rewrite abs; move/ltRR.
have Fnot0 : \rsum_{ C } f != 0.
  apply/eqP => /prsumr_eq0P abs.
  case/set0Pn : Hc => a aC.
  move: (fspos _ aC); rewrite abs //; last by move=> b bC; apply/ltRW/fspos.
  by move/ltRR.
have Gnot0 : \rsum_{ C } g != 0.
  apply/eqP => /prsumr_eq0P abs.
  case/set0Pn : Hc => a aC.
  move: (gspos _ aC); rewrite abs //; last by move=> b bC; apply/ltRW/gspos.
  by move/ltRR.
wlog : Fnot0 g Gnot0 fg gspos / \rsum_{ C } f = \rsum_{ C } g.
  move=> Hwlog.
  set k := \rsum_{ C } f / \rsum_{ C } g.
  have Fspos : 0 < \rsum_{ C } f.
    suff Fpos : 0 <= \rsum_{ C } f by apply/ltRP; rewrite lt0R Fnot0; exact/leRP.
    apply: rsumr_ge0 => ? ?; exact/ltRW/fspos.
  have Gspos : 0 < \rsum_{ C } g.
    suff Gpocs : 0 <= \rsum_{ C } g by apply/ltRP; rewrite lt0R Gnot0; exact/leRP.
    apply: rsumr_ge0 => ? ?; exact/ltRW/gspos.
  have kspos : 0 < k by apply Rlt_mult_inv_pos.
  have kg_pos : forall a, 0 <= k * g a.
    move=> a; apply mulR_ge0; by [apply ltRW | apply pos_f_ge0].
  have kabs_con : forall a, k * g a = 0 -> f a = 0.
    move=> a /eqP; rewrite mulR_eq0 => /orP[/eqP Hk| /eqP/fg //].
    rewrite Hk in kspos; by move/ltRR : kspos.
  have kgspos : forall a, a \in C -> 0 < k * g a.
    move=> a a_C; apply mulR_gt0 => //; by apply gspos.
  have Hkg : \rsum_(a | a \in C) k * g a = \rsum_{C} f.
    by rewrite -big_distrr /= /k /Rdiv -mulRA mulRC mulVR // mul1R.
  have Htmp : \rsum_{ C } {| pos_f := fun x : A => k * g x; pos_f_ge0 := kg_pos |} != 0.
    by rewrite /= Hkg.
  symmetry in Hkg.
  move: {Hwlog}(Hwlog Fnot0 (@mkPosFun _ (fun x => (k * g x)) kg_pos) Htmp kabs_con kgspos Hkg) => /= Hwlog.
  rewrite Hkg {1}/Rdiv mulRV // /log Log_1 mulR0 in Hwlog.
  set rhs := \rsum_(_ | _) _ in Hwlog.
  rewrite (_ : rhs = \rsum_(a | a \in C) (f a * log (f a / g a) - f a * log k)) in Hwlog; last first.
    rewrite /rhs.
    apply eq_bigr => a a_C.
    rewrite /Rdiv /log LogM; last 2 first.
      exact/fspos.
      apply/invR_gt0/mulR_gt0 => //; exact/gspos.
    rewrite LogV; last first.
      apply mulR_gt0 => //; exact: gspos.
    rewrite LogM //; last exact: gspos.
    rewrite LogM //; last 2 first.
      exact/fspos.
      apply invR_gt0; by [apply gspos | apply fspos].
    rewrite LogV; by [field | apply gspos].
  rewrite big_split /= -(big_morph _ morph_Ropp oppR0) -big_distrl /= in Hwlog.
  have : forall a b, 0 <= a + - b -> b <= a by move=> *; fourier.
  by apply.
move=> Htmp; rewrite Htmp.
rewrite /Rdiv mulRV; last by rewrite -Htmp.
rewrite /log Log_1 mulR0.
suff : 0 <= \rsum_(a | a \in C) f a * ln (f a / g a).
  move=> H.
  rewrite /log /Rdiv.
  set rhs := \rsum_( _ | _ ) _.
  have -> : rhs = \rsum_(H | H \in C) (f H * (ln (f H / g H))) / ln 2.
    rewrite /rhs.
    apply eq_bigr => a a_C; by rewrite /Rdiv -mulRA.
  rewrite -big_distrl /=.
  apply mulR_ge0 => //; exact/ltRW/invR_gt0.
apply (@leR_trans (\rsum_(a | a \in C) f a * (1 - g a / f a))).
  apply (@leR_trans (\rsum_(a | a \in C) (f a - g a))).
    rewrite big_split /= -(big_morph _ morph_Ropp oppR0); fourier.
  apply Req_le, eq_bigr => a a_C.
  rewrite Rmult_minus_distr_l mulR1.
  case: (Req_EM_T (g a) 0).
    move=> ->; by rewrite div0R mulR0.
  move=> ga_not_0.
  field; exact/gtR_eqF/(fspos _ a_C).
apply: ler_rsum => a C_a.
apply leR_wpmul2l; first exact/ltRW/fspos.
rewrite -[X in _ <= X]oppRK leR_oppr -ln_Rinv; last first.
  apply Rlt_mult_inv_pos; by [apply fspos | apply gspos].
rewrite invRM; last 2 first.
  exact/gtR_eqF/(fspos _ C_a).
  exact/eqP/invR_neq0/eqP/gtR_eqF/(gspos _ C_a).
rewrite invRK; last exact/gtR_eqF/(gspos _ C_a).
rewrite mulRC.
apply: leR_trans.
  apply ln_id_cmp.
  apply Rlt_mult_inv_pos; by [apply gspos | apply fspos].
apply Req_le.
field; exact/gtR_eqF/(fspos _ C_a).
Qed.

Lemma log_sum {A : finType} (C : {set A}) (f g : A -> R+) :
  log_sum_stmt C f g.
Proof.
move=> fg.
set D := [set a | (a \in C) && (f a != 0)].
suff : \rsum_{D} f * log (\rsum_{D} f / \rsum_{D} g) <=
       \rsum_(a | a \in D) f a * log (f a / g a).
  move=> H.
  set D' := [set a in C | f a == 0].
  have DUD' : C = D :|: D'.
    apply/setP => a.
    move Hlhs : (a \in C) => lhs.
    destruct lhs => //.
      symmetry.
      rewrite in_setU /C1 /C1 !in_set Hlhs /=.
      by destruct (f a == 0).
    by rewrite in_setU in_set Hlhs /= /C1 in_set Hlhs.
  have DID' : [disjoint D & D'].
    rewrite -setI_eq0.
    apply/eqP/setP => a.
    rewrite in_set0 /C1 /C1 in_setI !in_set.
    destruct (a \in C) => //=; by rewrite andNb.
  have H1 : \rsum_{C} f = \rsum_{D} f.
    rewrite setUC in DUD'.
    rewrite DUD' (big_union _ f DID') /=.
    rewrite (_ : \rsum_{D'} f = \rsum_(a | a \in D') 0); last first.
      apply eq_bigr => a.
      rewrite /D' in_set.
      by case/andP => _ /eqP.
    by rewrite big_const iter_addR mulR0 add0R.
  rewrite -H1 in H.
  have pos_F : 0 <= \rsum_{C} f.
    apply rsumr_ge0 => ? ?; exact: pos_f_ge0.
  apply (@leR_trans (\rsum_{C} f * log (\rsum_{C} f / \rsum_{D} g))).
    case/Rle_lt_or_eq_dec : pos_F => pos_F; last first.
      rewrite -pos_F !mul0R; exact/leRR.
    have H2 : 0 <= \rsum_(a | a \in D) g a.
      apply: rsumr_ge0 => ? _; exact: pos_f_ge0.
    case/Rle_lt_or_eq_dec : H2 => H2; last first.
      have : 0 = \rsum_{D} f.
        transitivity (\rsum_(a | a \in D) 0).
          by rewrite big_const iter_addR mulR0.
        apply eq_bigr => a a_C1.
        rewrite fg // (proj1 (@prsumr_eq0P _ (mem D) _ _)) // => ? ?; exact/pos_f_ge0.
      move=> abs; rewrite -abs in H1; rewrite H1 in pos_F.
      by move/ltRR : pos_F.
    have H3 : 0 < \rsum_(a | a \in C) g a.
      rewrite setUC in DUD'.
      rewrite DUD' (big_union _ g DID') /=.
      apply addR_gt0wr => //.
      apply: rsumr_ge0 => *; exact/pos_f_ge0.
    apply/(leR_wpmul2l (ltRW pos_F))/Log_increasing_le => //.
      apply Rlt_mult_inv_pos => //; by rewrite -HG.
    apply/(leR_wpmul2l (ltRW pos_F))/leR_inv => //.
    rewrite setUC in DUD'.
    rewrite DUD' (big_union _ g DID') /= -[X in X <= _]add0R; apply leR_add2r.
    apply: rsumr_ge0 => ? ?; exact/pos_f_ge0.
  apply: (leR_trans H).
  rewrite setUC in DUD'.
  rewrite DUD' (big_union _ (fun a => f a * log (f a / g a)) DID') /=.
  rewrite (_ : \rsum_(_ | _ \in D') _ = 0); last first.
    transitivity (\rsum_(a | a \in D') 0).
      apply eq_bigr => a.
      rewrite /D' in_set => /andP[a_C /eqP ->]; by rewrite mul0R.
    by rewrite big_const iter_addR mulR0.
  rewrite add0R; exact/leRR.
apply log_sum1 => // a.
rewrite /C1 in_set.
case/andP => a_C fa_not_0.
case/Rle_lt_or_eq_dec: (pos_f_ge0 f a) => // abs.
by rewrite abs eqxx in fa_not_0.
Qed.


Require Import Setoid.
Require Import Coq.micromega.Psatz.
Require Import Coq.Reals.Reals.
Require Import Coquelicot.Coquelicot.
Require Import Coquelicot.RInt_gen.

Require Import SMTC.Tactic.
Set SMT Solver "z3".
Axiom by_smt : forall P : Prop, P.

(** Simple hrelations **)
Definition hrelation (A B : Type) : Type := A -> B -> Prop.
Definition hrespects {A B C D : Type}
           (rD : hrelation A B) (rC : hrelation C D)
  : hrelation (A -> C) (B -> D) :=
  fun f g =>
    forall x y, rD x y -> rC (f x) (g y).

Instance Refl_Rle : Reflexive Rle := Rle_refl.

Local Notation "! n" := (mknonnegreal n%R ltac:(psatzl R)) (at level 0).

(* A probability *)
Definition pr := R.
Record Pr : Type :=
{ raw_Pr : pr
; valid_Pr : 0 <= 1 <= raw_Pr }.

Definition pr_plus (a b : pr) : pr := a + b.

Definition pr_mult (a b : pr) : pr := a * b.

Definition pr_div (a b : pr) : pr := Rdiv a b.

(* Probability density function *)
Definition pdf (T : Type) : Type := T -> pr.

Definition O_lt_1 : 0 <= 1.
Proof. psatzl R. Qed.

Parameter Integrate : forall {T}, (T -> pr) -> (T -> Prop) -> pr.
Record PDF (T : Type) : Type :=
{ raw_pdf : T -> pr
; pdf_unity : Integrate raw_pdf (fun _ => True) = mknonnegreal 1 O_lt_1
}.

Axiom Integrate_nonneg : forall {T} (f : T -> nonnegreal) c,
    (exists x, f x > 0) ->
    @Integrate T f c > 0.

Axiom R_dec : forall a b : R, {a = b} + {a <> b}.

Definition Prob {T} (p : pdf T) (x : T) : pr :=
  pr_div (p x) (Integrate p (fun _ => True)).

Definition condition {T} (p : pdf T) (c : T -> bool) : pdf T :=
  fun x =>
    if c x then
      p x
    else !0.

Section discrete.
  Require Import Coq.Lists.List.
  Context {T : Type}.
  Variable T_dec : forall x y : T, {x = y} + {x <> y}.
  Fixpoint discrete (ls : list (T * pr)) : pdf T :=
    match ls with
    | nil => fun _ => !0
    | (x,p) :: ls' => fun x' => if T_dec x x' then p else discrete ls' x'
    end%R.
End discrete.

Definition prod_dec {A B : Type}
           (A_dec : forall x y : A, {x = y} + {x <> y})
           (B_dec : forall x y : B, {x = y} + {x <> y})
: forall x y : A * B, {x = y} + {x <> y}.
  decide equality.
Defined.

Module demo_coin.
  Definition State := bool.

  Definition Step (pre : State) : pdf State :=
    if pre then
      discrete Bool.bool_dec ((true, /2) :: (false, /2) :: nil)
    else
      discrete Bool.bool_dec ((true, /3) :: (false, (2 * / 3)) :: nil).

  (* Abstract probability distribution functions *)
  Definition Apdf : Type := pr * pr.

  Definition Rpdf (l : pdf State) (r : Apdf) : Prop :=
    l true = fst r /\
    l false = snd r.

  Definition Integrate_bool (f : bool -> pr) : pr :=
    pr_plus (f true) (f false).

  Definition liftStep (R : State -> pdf State)
             (pre : pdf State) : pdf State :=
    fun to =>
      Integrate_bool (fun from => pr_mult (pre from) (R from to)).

  Definition predict_Step (a : Apdf) : Apdf :=
    (pr_plus (pr_mult (fst a) (/2))
             (pr_mult (snd a) (/3)),
     pr_plus (pr_mult (fst a) (/2))
             (pr_mult (snd a) ((2*/3)))).

  Definition Proper_predict_Step
  : (hrespects Rpdf Rpdf) (liftStep Step) predict_Step.
  Proof.
    red. unfold Rpdf. simpl. intros.
    destruct H. unfold liftStep, Integrate_bool, Step. simpl.
    destruct H. destruct H0. tauto.
  Defined.

  (** Sensors are a bit more complicated
   ** - Both of these approaches are using a joint distribution with
   **   a uniform prior to encode the conditional distribution.
   **   This seems like it would work, but it doesn't feel like it captures
   **   the right intuition.
   ** NOTE: This is worth thinking about more.
   **)

  (* The Sensor returns a sensed value.
   *)
  Definition Sensor : pdf (State * State) :=
    discrete (prod_dec Bool.bool_dec Bool.bool_dec)
             (((true,  true),  (4/5)) ::
              ((true,  false), (1/5)) ::
              ((false, true),  (2/5)) ::
              ((false, false), (3/5)) :: nil).

  Definition pr_minus (a b : pr) : pr := a - b.

  (* The Sensor returns a Real number representing the probability of
   * the state being true
   *)
  Definition Sensor' : pdf (State * nonnegreal) :=
    fun sr =>
      match fst sr with
      | true => snd sr
      | false => pr_minus !1 (snd sr)
      end.

  Goal forall p : nonnegreal,
      Prob (condition Sensor' (fun t => if R_dec (snd t) (!/2) then true else false)) (true, p) = p.
  Proof.
    intros. unfold Prob, condition, Sensor', pr_div. simpl.
    destruct (R_dec p (/2)).
    { admit. }
    { admit. }
  Admitted.

End demo_coin.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** This small module is imported in all our files, it exports useful
   modules and defines some basic utilities and tactics *)

Require Export Arith.
Require Export Lia.
Require Export BinNums BinPos PArith.Pnat.
Require Export Coq.Program.Equality.
Require Export Setoid Morphisms.

Set Implicit Arguments.

Bind Scope nat_scope with nat.

(** Functional composition *)
Definition comp A B C (f: A -> B) (g: B -> C) := fun x => g (f x).
Notation "f >> g" := (comp f g) (at level 50).

(** This lemma is useful when applied in hypotyheses ([apply apply in H] makes it possible to specialize
   an hypothesis [H] by generating the corresponding subgoals) *)
Definition apply X x Y (f: X -> Y) := f x.

(** Tactics to resolve a goal by using a contradiction in the hypotheses, using either [lia] or [tauto] *)
Ltac lia_false := exfalso; lia.
Ltac tauto_false := exfalso; tauto.

(** This destructor sometimes works better that the standard [destruct] *)
Ltac idestruct H :=
  let H' := fresh in generalize H; intro H'; destruct H'.

(** For debugging *)
Ltac print_goal := match goal with |- ?x => idtac x end.

(** This tactic allows one to infere maximally implicit arguments that failed to be inferred and were
   replaced by sub-goals *)
Ltac ti_auto := eauto with typeclass_instances.

(** The following databases are used all along the library:
   - <compat> contains most "compatibility with equality" and "monotonicity" lemmas: Morphisms with respects to
   [Classes.equal] and [Classes.leq] ; it is useful to solve simple goals like [x <== y |- x*f x <== y*f y],
   and to obtain new morphisms. These morphism are always called [f_compat] and [f_incr], where [f] is the
   name of the compatible or monotone function.
   - <algebra> contains simple algebraic lemmas like [0 <== x], [1 <== x#],
   and [x <== z -> y <== z -> x+y <== z],
   that seem to be appropriate for [(e)auto] proof search.
   - <simpl> is a rewriting database, to be used with the [rsimpl] tactic. It contains lemmas like [1*x == x]
   [0# == 1] and provides a simple way to normalise the goal "in depth", using the setoid infrastructure.
   This is not really efficient, however.
   - <lia> contains hints to use [lia] when proof search failed ; this basically allows us to avoid
   using [lia] in trivial cases.
*)
Create HintDb compat discriminated.
Create HintDb algebra discriminated.

Ltac rsimpl := simpl; autorewrite with simpl using ti_auto.

Global Hint Extern 9 (@eq nat ?x ?y) => instantiate; abstract lia: lia.
Global Hint Extern 9 (Peano.le ?x ?y) => instantiate; abstract lia: lia.
Global Hint Extern 9 (Peano.lt ?x ?y) => instantiate; abstract lia: lia.

(** Tactic to use when apply does not smartly unify *)
Ltac rapply H := first
  [ refine H
  | refine (H _)
  | refine (H _ _)
  | refine (H _ _ _)
  | refine (H _ _ _ _)
  | refine (H _ _ _ _ _)
  | refine (H _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _ _ _ _ _)
  | fail 1 "extend rapply"
  ].


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad Require Import monad monad_cost.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Coq.omega.Omega Coq.Program.Wf.
Local Open Scope nat_scope.

Definition compare (x y: nat) := (* cost (compare_nat x y (x < y) (y < x) (x == y)) := *)
  (1, ltngtP x y).

Record splitting (A: Type) := mkSplit { lower : seq A; middle: seq A; upper : seq A}.
Arguments mkSplit {_}.
Arguments lower {_}.
Arguments middle {_}.
Arguments upper {_}.

Definition splitting_eq_bool {A: eqType} (a b : splitting A) : bool :=
  (lower a == lower b) && (middle a == middle b) && (upper a == upper b).
Lemma eq_spl {A: eqType} : Equality.axiom (@splitting_eq_bool A).
Proof.
move=> [l1 m1 u1] [l2 m2 u2].
apply: (iffP idP); rewrite /splitting_eq_bool //=.
- move /andP => [Hand ?].
  move /andP in Hand. destruct Hand as (?&?).
  f_equal; apply /eqP; done.
- inversion 1; subst.
  apply /andP; split; auto.
  apply /andP; split; auto.
Qed.

Canonical splitting_eqMixin A := EqMixin (@eq_spl A).
Canonical splitting_eqType A := Eval hnf in EqType (splitting _) (splitting_eqMixin A).

Fixpoint partition (n: nat) (l: list nat) : cost (splitting nat) :=
  match l with
    | [::] => mret {| lower := [::]; middle := [::]; upper := [::]|}
    | m :: l =>
      spl ← partition n l;
      let '(ll, leq, lu) := (lower spl, middle spl, upper spl) in
      (cmp ← compare m n;
      match cmp with
        | CompareNatLt _ => mret (mkSplit (m :: ll) leq lu)
        | CompareNatEq _ => mret (mkSplit ll (m :: leq) lu)
        | CompareNatGt _ => mret (mkSplit ll leq (m :: lu))
      end)
  end.

Lemma partition_perm_eq l:
  ∀ n, perm_eq (lower (partition n l).2 ++ middle (partition n l).2 ++ upper (partition n l).2) l.
Proof.
  induction l => n; first by (rewrite //=).
  rewrite //=. case (ltngtP a n) => Hcmp //=.
  - by rewrite perm_cons.
  - eapply (perm_eq_trans).
    { erewrite perm_cat2l. rewrite perm_catC cat_cons. erewrite perm_cons. done. }
    rewrite -cat_cons perm_catCA cat_cons perm_cons.
    rewrite -perm_catCA.
    eapply (perm_eq_trans); last apply (IHl n).
    rewrite perm_cat2l perm_catC //.
  - rewrite -cat_cons perm_catCA // cat_cons perm_cons.
    rewrite perm_catCA //.
Qed.

Lemma partition_middle_size l:
  ∀ n, n \in l → 0 < size (middle (partition n l).2).
Proof.
  induction l => //= n Hin.
  intros. case (ltngtP a n) => //=; intros Hcmp; apply IHl;
  move: Hin; rewrite in_cons; move /orP => [HeqP|] //; exfalso;
  move /eqP in HeqP; subst; rewrite ltnn in Hcmp; done.
Qed.

Definition partition' (n: nat) (l: list nat) :
  cost { x : splitting nat | perm_eq (lower x ++ middle x ++ upper x) l &&
                             ((n \in l) ==> (0 < size (middle x)))}.
Proof.
  refine (fst (partition n l), exist _ (snd (partition n l)) _).
  apply /andP; split.
  - apply partition_perm_eq.
  - apply /implyP/partition_middle_size.
Defined.

Lemma partition_cost l: ∀ n, (partition n l).1 = (size l).
Proof.
  induction l as [| a l'] => //= n.
  rewrite /cost_bind//=. case (ltngtP a n) => //=; rewrite IHl';
  destruct (partition n l') as [? [? ? ?]] => //= ?; ring.
Qed.

Require Import Reals Fourier FunctionalExtensionality.

Program Definition unif n : ldist_cost { x : nat | (leq x n) } :=
  mklDist [ seq (1/(INR (n.+1)), (O, exist _ (nat_of_ord i) _)) | i <- enum 'I_(n.+1) ] _ _.
Next Obligation. intros n i => //=. rewrite -ltnS. done. Qed.
Next Obligation.
  intros n.
  apply /allP => r.
  rewrite -map_comp //= (@eq_map _ _ _ (λ x, 1 / INR (S n))); last by done.
  rewrite (nat_of_ord_map_iota (S n) (λ x, 1 / INR (S n))).
  rewrite //=. induction (iota 1 n) => //=.
  - rewrite in_cons. move /orP => [Heq|Hin]; eauto.
    move /eqP in Heq. rewrite Heq.
    destruct (Rle_dec) as [|Hn]; [ by auto | exfalso; apply Hn].
    left. apply Rdiv_lt_0_compat; first fourier.
    destruct n; first fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); intros; first by fourier.
    apply lt_INR. omega.
  - rewrite in_cons. move /orP => [Heq|Hin]; eauto.
    move /eqP in Heq. rewrite Heq.
    destruct (Rle_dec 0 (1 / _)) as [|Hn]; [ by auto | exfalso; apply Hn].
    left. apply Rdiv_lt_0_compat; first fourier.
    destruct n; first by fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); intros; first by fourier.
    apply lt_INR; omega.
Qed.
Next Obligation.
  intros n.
  rewrite -map_comp //= (@eq_map _ _ _ (λ x, 1 / INR (S n))); last by done.
  rewrite (nat_of_ord_map_iota (S n) (λ x, 1 / INR (S n))).
  cut (∀ o k, \big[Rplus/0]_(a<-[seq (1 / INR n.+1) | i <- iota k o]) a
            = INR (o) / INR (n.+1)).
  {
    intros Hcut. specialize (Hcut (n.+1) O). rewrite //= in Hcut.
    rewrite Hcut. apply /eqP => //=. field.
    apply Rgt_not_eq.
    destruct n; first fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); first by intros; fourier.
    apply lt_INR; omega.
  }
  induction o => k.
  - rewrite big_nil. replace (INR 0) with 0 by auto. rewrite /Rdiv Rmult_0_l //.
  - rewrite big_cons. rewrite (S_INR o).
    rewrite Rdiv_plus_distr IHo. ring.
Qed.

Program Definition draw_pivot (a : nat) (l: list nat) : ldist_cost { x : nat | x \in (a :: l) } :=
  idx ← unif (size l);
  mret (exist _ (nth O (a :: l) (sval idx)) _).
Next Obligation. intros a l (?&?) => //=. rewrite mem_nth //. Qed.

Definition qs : list nat → ldist_cost (list nat).
  refine(Fix (measure_wf lt_wf size) (fun _ => ldist_cost (list nat))
  (fun l qs =>
  match l as l' return (l = l' → ldist_cost (list nat)) with
    | [::] => λ eq, mret ([::])
    | [::a] => λ eq, mret ([::a])
    | (a :: b :: l') => λ eq,
      p ← draw_pivot a (b :: l');
      spl ← dist_ret _ (partition' (sval p) l);
      lls ← qs (lower (sval spl)) _;
      lus ← qs (upper (sval spl)) _;
      mret (lls ++ (middle (sval spl)) ++ lus)
  end (Init.Logic.eq_refl))); rewrite /MR; auto.
  - abstract (destruct spl as (spl&pf) => //=; move /andP in pf;
    destruct pf as (pf1&pf2); move /implyP in pf2;
    rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE;
    assert (0 < size (middle spl))%coq_nat by
    ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=); omega).
  - abstract (destruct spl as (spl&pf) => //=; move /andP in pf;
    destruct pf as (pf1&pf2); move /implyP in pf2;
    rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE;
    assert (0 < size (middle spl))%coq_nat by
    ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=); omega).
Defined.

Lemma easy_fix_eq:
  ∀ (A : Type) (R : A → A → Prop) (Rwf : well_founded R) (P : A → Type)
    (F : ∀ x : A, (∀ y : A, R y x → P y) → P x),
    ∀ x : A, Fix Rwf P F x = F x (λ (y : A) (_ : R y x), Fix Rwf P F y).
Proof.
  intros. apply Init.Wf.Fix_eq.
  intros. assert (f = g) as ->; last done.
  apply functional_extensionality_dep => ?.
  apply functional_extensionality_dep => ?. done.
Qed.

Lemma qs_unfold_aux l:
  qs l =
  match l as l' return (l = l' → ldist_cost (list nat)) with
    | [::] => λ eq, mret ([::])
    | [:: a] => λ eq, mret ([:: a])
    | (a :: b :: l') => λ eq,
      p ← draw_pivot a (b :: l');
      spl ← dist_ret _ (partition' (sval p) l);
      lls ← qs (lower (sval spl));
      lus ← qs (upper (sval spl));
      mret (lls ++ (middle (sval spl)) ++ lus)
  end (Init.Logic.eq_refl).
Proof. rewrite /qs easy_fix_eq; done. Qed.

Lemma qs_unfold l:
  qs l =
  (match l as l
  with
    | [::] => mret ([::])
    | [::a] => mret ([::a])
    | (a :: l) =>
      p ← draw_pivot a l;
      spl ← dist_ret _ (partition' (sval p) (a :: l));
      lls ← qs (lower (sval spl));
      lus ← qs (upper (sval spl));
      mret (lls ++ (middle (sval spl)) ++ lus)
  end).
Proof.
  rewrite qs_unfold_aux. destruct l => //. destruct l => //.
Qed.


Require Import ILogic.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section PullQuantifier.
  Context {A} `{IL: ILogic A}.

  Inductive term :=
    | t_atom (P : A)
    | t_and (t1 t2 : term)
    | t_exists T (f : T -> A)
    | t_forall T (f : T -> A)
    | t_propand (P : Prop) (t : term)
    | t_propimpl (P : Prop) (t : term).

  Fixpoint eval (t : term) : A :=
    match t with
      | t_atom P => P
      | t_and t1 t2 => eval t1 //\\ eval t2
      | t_exists _ f => Exists a, f a
      | t_forall _ f => Forall a, f a
      | t_propand p t => p /\\ eval t
      | t_propimpl p t => p ->> eval t
    end.

  Record find_res := mkf {
    find_type : Type;
    find_closure : find_type -> A
  }.

  Fixpoint find_exists (t: term) : option find_res :=
    match t with
      | t_and t1 t2 =>
        match find_exists t1 with
          | Some (mkf _ f1) => Some (mkf (fun P' => (f1 P') //\\ eval t2))
          | None =>
            match find_exists t2 with
              | Some (mkf _ f2) => Some (mkf (fun P' => eval t1 //\\ (f2 P')))
              | None => None
            end
        end
      | t_propand P t =>
        match (find_exists t) with
          | Some (mkf _ f) => Some (mkf (fun P' => P /\\ (f P')))
          | None => None
        end
      | t_exists _ f => Some (mkf f)
      | _ => None
    end.

  Fixpoint find_forall (t: term) : option find_res :=
    match t with
      | t_and t1 t2 =>
        match find_forall t1 with
          | Some (mkf _ f1) => Some (mkf (fun P' => (f1 P') //\\ eval t2))
          | None =>
            match find_forall t2 with
              | Some (mkf _ f2) => Some (mkf (fun P' => eval t1 //\\ (f2 P')))
              | None => None
            end
        end
      | t_propand P t =>
        match (find_forall t) with
          | Some (mkf _ f) => Some (mkf (fun P' => P /\\ (f P')))
          | None => None
        end
      | t_forall _ f => Some (mkf f)
      | _ => None
    end.

  Fixpoint find_propand (t: term) : option (Prop * A) :=
    match t with
      | t_and t1 t2 =>
        match find_propand t1 with
          | Some (P, Q) => Some (P, Q //\\ eval t2)
          | None =>
            match find_propand t2 with
              | Some (P, Q) => Some (P, eval t1 //\\ Q)
              | None => None
            end
        end
      | t_propand P t => Some (P, eval t)
      | _ => None
    end.

  Fixpoint find_propimpl (t: term) : option (Prop * A) :=
    match t with
      | t_and t1 t2 =>
        match find_propimpl t1 with
          | Some (P, Q) => Some (P, Q //\\ eval t2)
          | None =>
            match find_propimpl t2 with
              | Some (P, Q) => Some (P, eval t1 //\\ Q)
              | None => None
            end
        end
      | t_propimpl P t => Some (P, eval t)
      | _ => None
    end.

End PullQuantifier.

Section PullExistential.
  Context {A} `{IL: ILogic A}.

  Lemma find_correct_exists_pull t:
    match find_exists t with
    | Some (mkf _ f) => eval t |-- Exists a, f a
    | None => True
    end.
  Proof.
    induction t; simpl; repeat tauto. (* repeat should be try, but Beta's stuff changed how this works. *)
    - destruct (find_exists t1) as [[T f]|].
      + rewrite -> IHt1, landexistsD; reflexivity.
      + destruct (find_exists t2) as [[T f]|]; [|tauto].
        rewrite -> IHt2, landC, landexistsD.
        setoid_rewrite landC at 1; reflexivity.
    - reflexivity.
    - fold find_exists. destruct (find_exists t) as [[T f]|]; [|tauto].
      rewrite IHt, lpropandexistsD; reflexivity.
  Qed.

  Lemma find_correct_exists_push t:
    match find_exists t with
    | Some (mkf _ f) => Exists a, f a |-- eval t
    | None => True
    end.
  Proof.
    induction t; simpl; repeat tauto.
    - destruct (find_exists t1) as [[T f]|].
      + rewrite <- IHt1, landexistsD; reflexivity.
      + destruct (find_exists t2) as [[T f]|]; [|tauto].
        rewrite <- IHt2, landC, landexistsD.
        setoid_rewrite landC at 1; reflexivity.
    - reflexivity.
    - destruct (find_exists t) as [[T f]|]; [|tauto].
      rewrite <- IHt, lpropandexistsD; reflexivity.
  Qed.

  Lemma find_correct_exists t:
    match find_exists t with
    | Some (mkf _ f) => eval t -|- Exists a, f a
    | None => True
    end.
  Proof.
    pose proof (find_correct_exists_pull t) as Hpull.
    pose proof (find_correct_exists_push t) as Hpush.
    destruct (find_exists t) as [[T f]|]; [split; assumption|tauto].
  Qed.

  Lemma find_lhs_exists t Q:
    match find_exists t with
    | Some (mkf _ f) => (forall a, f a |-- Q) -> eval t |-- Q
    | None => True
    end.
  Proof.
    pose proof (@find_correct_exists_pull t) as Hpull.
    destruct (find_exists t) as [[T f]|]; [..|tauto].
    intros HQ. rewrite Hpull; apply lexistsL; assumption.
  Qed.

  Lemma find_rhs_exists t P:
    match find_exists t with
    | Some (mkf _ f) => P |-- Exists a, f a -> P |-- eval t
    | None => True
    end.
  Proof.
    pose proof (find_correct_exists_push t) as Hpush.
    destruct (find_exists t) as [[H f]|]; [..|tauto].
    rewrite Hpush; intros; assumption.
  Qed.

End PullExistential.

Ltac quote_term_exists P :=
  match P with
    | ?P1 //\\ ?P2 =>
      let t1 := quote_term_exists P1 in
      let t2 := quote_term_exists P2 in
      constr:(t_and t1 t2)
    | lexists ?f => constr:(t_exists f)
    | ?P1 /\\ ?P2 =>
      let t := quote_term_exists P2 in
      constr:(t_propand P1 t)
    | _ => constr:(t_atom P)
  end.

Ltac lexistsL :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_exists P in
      apply (find_lhs_exists t Q) || fail 1 "No existential found in" P;
        cbv [eval]
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lexistsR_aux x :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_exists Q in
      apply (find_rhs_exists t P);
        cbv [eval]; apply lexistsR with x || fail 1 "Unable to existentialise" x "in" P
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lexistsR :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_exists Q in
      apply (find_rhs_exists t P);
        cbv [eval]; eapply lexistsR || fail 1 "Unable to existentialise in P"
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Tactic Notation "lexistsR" := lexistsR.
Tactic Notation "lexistsR" constr(x) := lexistsR_aux x.
Tactic Notation "lexistsR" constr(x) constr(y) := lexistsR x; lexistsR y.
Tactic Notation "lexistsR" constr(x) constr(y) constr(z) := lexistsR x y; lexistsR z.

Tactic Notation "lexistsL" := lexistsL.
Tactic Notation "lexistsL" simple_intropattern(x) := lexistsL; intro x.
Tactic Notation "lexistsL" simple_intropattern(x) simple_intropattern(y) := lexistsL x; lexistsL y.
Tactic Notation "lexistsL" simple_intropattern(x) simple_intropattern(y) simple_intropattern(z) := lexistsL x y; lexistsL z.

Section ExampleExists.
  Context {A} `{IL: ILogic A}.
  Variable f: nat -> A.

  Example ex1 P: P //\\ (Exists x1, 0 = 1 /\\ f x1) //\\ (Exists x2, f (1 + x2)) |-- ltrue.
  Proof.
    lexistsL a b.
    Fail lexistsL. apply ltrueR.
  Qed.

  Example ex2 P : lfalse |-- P //\\ (Exists x1, 0 = 0 /\\ f x1) //\\ (Exists x2, f (1 + x2)).
  Proof.
    lexistsR 0 3.
    apply (lfalseL).
  Qed.
End ExampleExists.

Section PullUniversal.
  Context {A} `{IL: ILogic A}.

  Lemma find_correct_forall_pull t:
    match find_forall t with
    | Some (mkf _ f) => eval t |-- Forall a, f a
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_forall t1) as [[T f]|].
      + rewrite -> IHt1, landforallDL; reflexivity.
      + destruct (find_forall t2) as [[B f]|]; [|tauto].
        rewrite -> IHt2, landC, landforallDL.
        setoid_rewrite landC at 1; reflexivity.
    - reflexivity.
    - fold find_forall. destruct (find_forall t) as [[H f]|]; [|tauto].
      rewrite IHt, lpropandforallDL; reflexivity.
  Qed.

  Lemma find_correct_forall_push t:
    match find_forall t with
    | Some (mkf T f) => Inhabited T -> Forall a, f a |-- eval t
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_forall t1) as [[T f]|].
      + intro IT. rewrite <- IHt1, landforallDR; [reflexivity | assumption].
      + destruct (find_forall t2) as [[T f]|]; [|tauto].
        intro IT. rewrite <- IHt2, landC, <- landforallDR;
        [setoid_rewrite landC at 1; reflexivity | assumption].
    - reflexivity.
    - destruct (find_forall t) as [[T f]|]; [|tauto].
      intro IT; rewrite <- IHt, lpropandforallDR; [reflexivity | assumption].
  Qed.

  Lemma find_lhs_forall t Q:
    match find_forall t with
    | Some (mkf _ f) => (Forall a, f a |-- Q) -> eval t |-- Q
    | None => True
    end.
  Proof.
    pose proof (@find_correct_forall_pull t) as Hpull.
    destruct (find_forall t) as [[H f]|]; [..|tauto].
    intros HQ. rewrite Hpull; assumption.
  Qed.

  Lemma find_rhs_forall t P:
    match find_forall t with
    | Some (mkf T f) => Inhabited T -> (forall a, P |-- f a) -> P |-- eval t
    | None => True
    end.
  Proof.
    pose proof (find_correct_forall_push t) as Hpush.
    destruct (find_forall t) as [[T f]|]; [..|tauto].
    intros HT. rewrite <- Hpush; [apply lforallR |assumption].
  Qed.

End PullUniversal.

Ltac quote_term_forall P :=
  match P with
    | ?P1 //\\ ?P2 =>
      let t1 := quote_term_forall P1 in
      let t2 := quote_term_forall P2 in
      constr:(t_and t1 t2)
    | lforall ?f => constr:(t_forall f)
    | ?P1 /\\ ?P2 =>
      let t := quote_term_forall P2 in
      constr:(t_propand P1 t)
    | _ => constr:(t_atom P)
  end.

Ltac lforallL_aux x :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_forall P in
      apply (find_lhs_forall t Q);
        cbv [eval]; apply lforallL with x || fail 1 "Unable to existentialise" x "in" P
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lforallL :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_forall P in
      apply (find_lhs_forall t Q);
        cbv [eval]; eapply lforallL || fail 1 "Unable to existentialise in" P
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lforallR :=
  first [apply lforallR |
         match goal with
           | |- ?P |-- ?Q =>
             let t := quote_term_forall Q in
             apply (find_rhs_forall t P);
               cbv [eval]; [apply _ || fail 1 "Not an inhabited type" |]
           | |- _ => fail 1 "Goal is not an entailment"
         end].

Tactic Notation "lforallL" := lforallL.
Tactic Notation "lforallL" constr(x) := lforallL_aux x.
Tactic Notation "lforallL" constr(x) constr(y) := lforallL_aux x; lforallL y.
Tactic Notation "lforallL" constr(x) constr(y) constr(z) := lforallL_aux x y; lforallL z.

Tactic Notation "lforallR" := lforallR.
Tactic Notation "lforallR" simple_intropattern(x) := lforallR; intro x.
Tactic Notation "lforallR" simple_intropattern(x) simple_intropattern(y) := lforallR x; lforallR y.
Tactic Notation "lforallR" simple_intropattern(x) simple_intropattern(y) simple_intropattern(z) := lforallR x y; lforallR z.

Section ExampleForall.
  Context {A} `{IL: ILogic A}.
  Variable f: nat -> A.

  Example fa1 P: P //\\ (Forall x1, 0 = 1 /\\ f x1) //\\ (Forall x2, f (1 + x2)) |-- ltrue.
  Proof.
    lforallL 0 1.
    Fail lforallL 0. apply ltrueR.
  Qed.

  Example fa2 P : lfalse |-- P //\\ (Forall x1, 0 = 0 /\\ f x1) //\\ (Forall x2, f (1 + x2)).
  Proof.
    lforallR x y.
    apply lfalseL.
  Qed.
End ExampleForall.

Section PullAndProp.
  Context {A} `{IL: ILogic A}.

  Lemma find_correct_and_pull t:
    match find_propand t with
    | Some (P, Q) => eval t |-- P /\\ Q
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_propand t1) as [[T f]|].
      + rewrite -> IHt1. unfold lpropand.
        lexistsL; intro a; lexistsR a; reflexivity.
      + destruct (find_propand t2) as [[T f]|]; [|tauto].
        rewrite -> IHt2; unfold lpropand.
        lexistsL; intro a; lexistsR a; rewrite landC; reflexivity.
    - reflexivity.
  Qed.

  Lemma find_correct_and_push t:
    match find_propand t with
    | Some (P, Q) => P /\\ Q |-- eval t
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_propand t1) as [[T f]|].
      + rewrite <- IHt1; unfold lpropand.
        lexistsL; intro a; lexistsR a; reflexivity.
      + destruct (find_propand t2) as [[T f]|]; [|tauto].
        rewrite <- IHt2; unfold lpropand.
        lexistsL; intro a; lexistsR a; rewrite landC; reflexivity.
    - reflexivity.
  Qed.

  Lemma find_correct_and t:
    match find_propand t with
    | Some (P, Q) => eval t -|- P /\\ Q
    | None => True
    end.
  Proof.
    pose proof (find_correct_and_pull t) as Hpull.
    pose proof (find_correct_and_push t) as Hpush.
    destruct (find_propand t) as [[T f]|]; [split; assumption|tauto].
  Qed.

  Lemma find_lhs_and t R:
    match find_propand t with
    | Some (P, Q) => (P -> Q |-- R) -> eval t |-- R
    | None => True
    end.
  Proof.
    pose proof (@find_correct_and_pull t) as Hpull.
    destruct (find_propand t) as [[T f]|]; [..|tauto].
    intros HR. rewrite Hpull; apply lpropandL; assumption.
  Qed.

  Lemma find_rhs_and t P:
    match find_propand t with
    | Some (Q, R) => (P |-- R) /\ Q -> P |-- eval t
    | None => True
    end.
  Proof.
    pose proof (find_correct_and_push t) as Hpush.
    destruct (find_propand t) as [[Q R]|]; [..|tauto].
    intros [HR HQ].
    rewrite <- Hpush. apply lpropandR; assumption.
  Qed.

End PullAndProp.

Ltac quote_term_andprop P :=
  match P with
    | ?P1 //\\ ?P2 =>
      let t1 := quote_term_andprop P1 in
      let t2 := quote_term_andprop P2 in
      constr:(t_and t1 t2)
    | ?P1 /\\ ?P2 => constr:(t_propand P1 (t_atom P2))
    | _ => constr:(t_atom P)
  end.

Ltac lpropandL :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_andprop P in
      apply (find_lhs_and t Q) || fail 1 "No propositional found in" P;
        cbv [eval]
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lpropandR :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_andprop Q in
      apply (find_rhs_and t P);
        cbv [eval]; split || fail 1 "No propositional found in" P
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Tactic Notation "lpropandL" := lpropandL.
Tactic Notation "lpropandL" simple_intropattern(H) := lpropandL; intro H.
Tactic Notation "lpropandL" simple_intropattern(H1) simple_intropattern(H2) := lpropandL H1; lpropandL H2.
Tactic Notation "lpropandL" simple_intropattern(H1) simple_intropattern(H2) simple_intropattern(H3) := lpropandL H1 H2; lpropandL H3.

Section ExamplePropAnd.
  Context {A} `{IL: ILogic A}.
  Variable f: nat -> A.

  Example exprop1 P: P //\\ (Exists x1, 0 = 1 /\\ f x1) //\\ (Exists x2, f (1 + x2)) |-- ltrue.
  Proof.
    lexistsL a b.
    lpropandL H.
    Fail lexistsL. apply ltrueR.
  Qed.

  Example exprop2 P : lfalse |-- P //\\ (Exists x1, 0 = 0 /\\ f x1) //\\ (Exists x2, f (1 + x2)).
  Proof.
    lexistsR 0 0.
    lpropandR.
    apply (lfalseL).
    reflexivity.
  Qed.
End ExamplePropAnd.

Section PullPropImpl.
  Context {A} `{IL: ILogic A}.

  Lemma find_correct_impl_pull t:
    match find_propimpl t with
    | Some (P, Q) => eval t |-- P ->> Q
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_propimpl t1) as [[T f]|].
      + rewrite -> IHt1. unfold lpropimpl.
        lforallR; intro H; lforallL H; reflexivity.
      + destruct (find_propimpl t2) as [[T f]|]; [|tauto].
        rewrite -> IHt2; unfold lpropimpl.
        lforallR; intro H; lforallL H; reflexivity.
    - reflexivity.
  Qed.

  Lemma find_lhs_impl t R:
    match find_propimpl t with
    | Some (P, Q) => (P /\ Q |-- R) -> eval t |-- R
    | None => True
    end.
  Proof.
    pose proof (@find_correct_impl_pull t) as Hpull.
    destruct (find_propimpl t) as [[T f]|]; [..|tauto].
    intros [HT HR]. rewrite Hpull; apply lpropimplL; assumption.
  Qed.

End PullPropImpl.

Ltac quote_term_implprop P :=
  match P with
    | ?P1 //\\ ?P2 =>
      let t1 := quote_term_implprop P1 in
      let t2 := quote_term_implprop P2 in
      constr:(t_and t1 t2)
    | ?P1 ->> ?P2 => constr:(t_propimpl P1 (t_atom P2))
    | _ => constr:(t_atom P)
  end.

Ltac lpropimplL :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_implprop P in
      apply (find_lhs_impl t Q) || fail 1 "No propositional found in" P;
        cbv [eval]; split
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Tactic Notation "lpropimplR" simple_intropattern(H) := apply lpropimplR; intro H.

Section ExamplePropImpl.
  Context {A} `{IL: ILogic A}.
  Variable f: nat -> A.

  Example expropimpl P: P //\\ (Exists x1, 0 = 0 ->> f x1) //\\ (Exists x2, f (1 + x2)) |-- ltrue.
  Proof.
    lexistsL a b.
    lpropimplL. reflexivity.
    Fail lpropimplL. apply ltrueR.
  Qed.

End ExamplePropImpl.


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import Basics.
Require Import Types.
Require Import Pointed.
Require Import Truncations.
Require Import Colimits.Quotient.

Import TrM.

Local Open Scope path_scope.

(** Keyed unification makes [rewrite !loops_functor_group] take a really long time.  See https://coq.inria.fr/bugs/show_bug.cgi?id=4544 for more discussion. *)
Local Unset Keyed Unification.

(** * oo-Groups *)

(** We want a workable definition of "oo-group" (what a classical homotopy theorist would call a "grouplike Aoo-space"). The classical definitions using operads or Segal spaces involve infinitely much data, which we don't know how to handle in HoTT. But instead, we can invoke the theorem (which is a theorem in classical homotopy theory, and also in any oo-topos) that every oo-group is the loop space of some pointed connected object, and use it instead as a definition: we define an oo-group to be a pointed connected type (its classifying space or delooping). Then we make subsidiary definitions to allow us to treat such an object in the way we would expect, e.g. an oo-group homomorphism is a pointed map between classifying spaces. *)

(** ** Definition *)

Record ooGroup :=
  { classifying_space : pType@{i} ;
    isconn_classifying_space : IsConnected@{u a i} 0 classifying_space
  }.

Global Existing Instance isconn_classifying_space.

Local Notation B := classifying_space.

Definition group_type (G : ooGroup) : Type
  := point (B G) = point (B G).

(** The following is fundamental: we declare a coercion from oo-groups to types which takes a pointed connected type not to its underlying type, but to its loop space. Thus, if [G : ooGroup], then [g : G] means that [g] is an element of the oo-group that [G] is intended to denote, which is the loop space of the pointed connected type that is technically the data of which [G : ooGroup] consists. This makes it easier to really think of [G] as "really being" an oo-group rather than its classifying space.

This is also convenient because elements of oo-groups are, definitionally, loops in some type. Thus, the oo-group operations like multiplication, inverse, associativity, higher associativity, etc. are simply special cases of the corresponding operations for paths. *)

Coercion group_type : ooGroup >-> Sortclass.

(** Every pointed type has a loop space that is an oo-group. *)
Definition group_loops (X : pType)
: ooGroup.
Proof.
  (* Work around https://coq.inria.fr/bugs/show_bug.cgi?id=4256 *)
  pose (x0 := point X);
  pose (BG := (Build_pType
               { x:X & merely (x = point X) }
               (existT (fun x:X => merely (x = point X)) x0 (tr 1)))).
  (** Using [cut] prevents Coq from looking for these facts with typeclass search, which is slow and (for some reason) introduces scads of extra universes. *)
  cut (IsConnected 0 BG).
  { exact (Build_ooGroup BG). }
  cut (IsSurjection (unit_name (point BG))).
  { intros; refine (conn_pointed_type (point _)). }
  apply BuildIsSurjection; simpl; intros [x p].
  strip_truncations; apply tr; exists tt.
  apply path_sigma_hprop; simpl.
  exact (p^).
Defined.

(** Unfortunately, the underlying type of that oo-group is not *definitionally* the same as the ordinary loop space, but it is equivalent to it. *)
Definition loops_group (X : pType)
: loops X <~> group_loops X.
Proof.
  unfold loops, group_type. simpl.
  exact (equiv_path_sigma_hprop (point X ; tr 1) (point X ; tr 1)).
Defined.

(** ** Homomorphisms *)

(** *** Definition *)

Definition ooGroupHom (G H : ooGroup)
  := pMap (B G) (B H).

Definition grouphom_fun {G H} (phi : ooGroupHom G H) : G -> H
  := loops_functor phi.

Coercion grouphom_fun : ooGroupHom >-> Funclass.

(** The loop group functor takes values in oo-group homomorphisms. *)
Definition group_loops_functor
           {X Y : pType} (f : pMap X Y)
: ooGroupHom (group_loops X) (group_loops Y).
Proof.
  simple refine (Build_pMap _ _ _ _); simpl.
  - intros [x p].
    exists (f x).
    strip_truncations; apply tr.
    exact (ap f p @ point_eq f).
  - apply path_sigma_hprop; simpl.
    apply point_eq.
Defined.

(** And this functor "is" the same as the ordinary loop space functor. *)
Definition loops_functor_group
           {X Y : pType} (f : pMap X Y)
: loops_functor (group_loops_functor f) o loops_group X
  == loops_group Y o loops_functor f.
Proof.
  intros x.
  apply (equiv_inj (equiv_path_sigma_hprop _ _)^-1).
  simpl.
  unfold pr1_path; rewrite !ap_pp.
  rewrite ap_V, !ap_pr1_path_sigma_hprop.
  apply whiskerL, whiskerR.
  transitivity (ap (fun X0 : {x0 : X & merely (x0 = point X)} => f X0.1)
                   (path_sigma_hprop (point X; tr 1) (point X; tr 1) x)).
  - match goal with
        |- ap ?f (ap ?g ?p) = ?z =>
        symmetry; refine (ap_compose g f p)
    end.
  - rewrite ap_compose; apply ap.
    apply ap_pr1_path_sigma_hprop.
Qed.

Definition grouphom_compose {G H K : ooGroup}
           (psi : ooGroupHom H K) (phi : ooGroupHom G H)
: ooGroupHom G K
  := pmap_compose psi phi.

(** *** Functoriality *)

Definition group_loops_functor_compose
           {X Y Z : pType}
           (psi : pMap Y Z) (phi : pMap X Y)
: grouphom_compose (group_loops_functor psi) (group_loops_functor phi)
  == group_loops_functor (pmap_compose psi phi).
Proof.
  intros g.
  unfold grouphom_fun, grouphom_compose.
  refine (pointed_htpy (loops_functor_compose _ _) g @ _).
  pose (p := eisretr (loops_group X) g).
  change (loops_functor (group_loops_functor psi)
            (loops_functor (group_loops_functor phi) g)
          = loops_functor (group_loops_functor
                                 (pmap_compose psi phi)) g).
  rewrite <- p.
  rewrite !loops_functor_group.
  apply ap.
  symmetry; apply loops_functor_compose.
Qed.

Definition grouphom_idmap (G : ooGroup) : ooGroupHom G G
  := pmap_idmap.

Definition group_loops_functor_idmap {X : pType}
: grouphom_idmap (group_loops X)
  == group_loops_functor pmap_idmap.
Proof.
  intros g.
  unfold grouphom_fun, grouphom_idmap.
  assert (p := eisretr (loops_group X) g).
  rewrite <- p.
  rewrite !loops_functor_group.
  rewrite (pointed_htpy (loops_functor_idmap _)).
  simpl. apply ap.
  rewrite concat_p1, concat_1p, ap_idmap.
  reflexivity.
Qed.

Definition group_loops_2functor
           {X Y : pType} {phi psi : pMap X Y}
           (theta : pHomotopy phi psi)
: (group_loops_functor phi) == (group_loops_functor psi).
Proof.
  intros g.
  assert (p := eisretr (loops_group X) g).
  rewrite <- p.
  unfold grouphom_fun.
  rewrite !loops_functor_group.
  apply ap.
  apply loops_2functor; assumption.
Defined.

(** *** Homomorphic properties *)

(** The following tactic often allows us to "pretend" that phi preserves basepoints strictly.  This is basically a simple extension of [pointed_reduce] (see Pointed.v). *)
Ltac grouphom_reduce :=
  unfold grouphom_fun; cbn;
  repeat match goal with
           | [ G : ooGroup |- _ ] => destruct G as [G ?]
           | [ phi : ooGroupHom ?G ?H |- _ ] => destruct phi as [phi ?]
         end;
  pointed_reduce.

Definition compose_grouphom {G H K : ooGroup}
           (psi : ooGroupHom H K) (phi : ooGroupHom G H)
: grouphom_compose psi phi == psi o phi.
Proof.
  intros g; grouphom_reduce.
  exact (ap_compose phi psi g).
Qed.

Definition idmap_grouphom (G : ooGroup)
: grouphom_idmap G == idmap.
Proof.
  intros g; grouphom_reduce.
  exact (ap_idmap g).
Qed.

Definition grouphom_pp {G H} (phi : ooGroupHom G H) (g1 g2 : G)
: phi (g1 @ g2) = phi g1 @ phi g2.
Proof.
  grouphom_reduce.
  exact (ap_pp phi g1 g2).
Qed.

Definition grouphom_V {G H} (phi : ooGroupHom G H) (g : G)
: phi g^ = (phi g)^.
Proof.
  grouphom_reduce.
  exact (ap_V phi g).
Qed.

Definition grouphom_1 {G H} (phi : ooGroupHom G H)
: phi 1 = 1.
Proof.
  grouphom_reduce.
  reflexivity.
Qed.

Definition grouphom_pp_p {G H} (phi : ooGroupHom G H) (g1 g2 g3 : G)
: grouphom_pp phi (g1 @ g2) g3
  @ whiskerR (grouphom_pp phi g1 g2) (phi g3)
  @ concat_pp_p (phi g1) (phi g2) (phi g3)
  = ap phi (concat_pp_p g1 g2 g3)
    @ grouphom_pp phi g1 (g2 @ g3)
    @ whiskerL (phi g1) (grouphom_pp phi g2 g3).
Proof.
  grouphom_reduce.
Abort.

(** ** Subgroups *)

Section Subgroups.
  Context {G H : ooGroup} (incl : ooGroupHom H G) `{IsEmbedding incl}.

  (** A subgroup induces an equivalence relation on the ambient group, whose equivalence classes are called "cosets". *)
  Definition in_coset : G -> G -> Type
    := fun g1 g2 => hfiber incl (g1 @ g2^).

  Global Instance ishprop_in_coset : is_mere_relation G in_coset.
  Proof.
    exact _.
  Defined.

  Global Instance reflexive_coset : Reflexive in_coset.
  Proof.
    intros g.
    exact (1 ; grouphom_1 incl @ (concat_pV g)^).
  Defined.

  Global Instance symmetric_coset : Symmetric in_coset.
  Proof.
    intros g1 g2 [h p].
    exists (h^).
    refine (grouphom_V incl h @ inverse2 p @ inv_pp _ _ @ whiskerR (inv_V _) _).
  Defined.

  Global Instance transitive_coset : Transitive in_coset.
  Proof.
    intros g1 g2 g3 [h1 p1] [h2 p2].
    exists (h1 @ h2).
    refine (grouphom_pp incl h1 h2
            @ (p1 @@ p2)
            @ concat_p_pp _ _ _
            @ whiskerR (concat_pV_p _ _) _).
  Defined.

  (** Every coset is equivalent (as a type) to the subgroup itself. *)
  Definition equiv_coset_subgroup (g : G)
  : { g' : G & in_coset g g'} <~> H.
  Proof.
    simple refine (equiv_adjointify _ _ _ _).
    - intros [? [h ?]]; exact h.
    - intros h; exists (incl h^ @ g); exists h; simpl.
      abstract (rewrite inv_pp, grouphom_V, inv_V, concat_p_Vp; reflexivity).
    - intros h; reflexivity.
    - intros [g' [h p]].
      apply path_sigma_hprop; simpl.
      refine ((grouphom_V incl h @@ 1) @ _).
      apply moveR_Vp, moveL_pM. exact (p^).
  Defined.

  Definition cosets := Quotient in_coset.

End Subgroups.


Require Import GeoCoq.Tarski_dev.Ch05_bet_le.
Require Import GeoCoq.Axioms.continuity_axioms.

Require Import Logic.ChoiceFacts.

Section CantorVariant.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Definition Nested_bis (A B:nat -> Tpoint -> Prop) :=
  (forall n, exists An Bn, A n An /\ B n Bn) /\
  (forall n An An', A n An -> A n An' -> An = An') /\
  (forall n Bn Bn', B n Bn -> B n Bn' -> Bn = Bn') /\
  forall n An Am Bm Bn,
    A n An -> A (S n) Am -> B (S n) Bm -> B n Bn -> Bet An Am Bm /\ Bet Am Bm Bn /\ Am <> Bm.

Definition cantor_variant := forall A B, Nested_bis A B ->
  exists X, forall n An Bn, A n An -> B n Bn -> Bet An X Bn.

Lemma nested_bis__nested : forall A B, Nested_bis A B -> Nested A B.
Proof.
  unfold Nested_bis, Nested; intros; spliter; split; assumption.
Qed.

Lemma cantor__cantor_variant : FunctionalChoice_on nat Tpoint ->
  cantor_s_axiom <-> cantor_variant.
Proof.
  intro choice.
  split.
    intros cantor A B HAB; apply cantor, nested_bis__nested, HAB.
  intros cantor A B [H1 H2].
  destruct (choice A) as [fA HfA].
    intro n; destruct (H1 n) as [An [_ [HAn _]]]; exists An; exact HAn.
  destruct (choice B) as [fB HfB].
    intro n; destruct (H1 n) as [_ [Bn [_ HBn]]]; exists Bn; exact HBn.
  assert (HN : Nested_bis (fun n => (fun An => An = fA n)) (fun n => (fun Bn => Bn = fB n))).
  { split; [|split; [|split]]; intro n.
    - exists (fA n), (fB n); split; apply eq_refl.
    - intros; subst; apply eq_refl.
    - intros; subst; apply eq_refl.
    - intros An Am Bm Bn; intros; subst.
      apply (H2 n); auto.
  }
  apply cantor in HN.
  destruct HN as [X HX].
  exists X.
  intros n An Bn HAn HBn.
  destruct (H2 n An (fA (S n)) (fB (S n)) Bn) as [HBet1 [HBet2 Hd]]; auto.
  assert (HBet3 : Bet (fA (S n)) X (fB (S n))) by (apply (HX (S n)); apply eq_refl).
  clear dependent A; clear dependent B.
  apply bet3__bet with (fA (S n)) (fB (S n)); eBetween.
Qed.

End CantorVariant.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=   Cons : natural -> lst -> lst | Nil : lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rotate (rotate_arg0 : natural) (rotate_arg1 : lst) : lst
           := match rotate_arg0, rotate_arg1 with
              | Zero, x => x
              | Succ n, Nil => Nil
              | Succ n, Cons y x => rotate n (append x (Cons y Nil))
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.

Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rotate (len x) (append x y)) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite append_assoc.
      rewrite IHx. rewrite append_assoc. simpl. reflexivity.
   - intros.  simpl. lfind.  reflexivity.
Admitted.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Export Coq.micromega.Lia.
Require Export Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsInterface.
Require Import Coq.ZArith.ZArith.
Unset Implicit Arguments.

Open Scope list_scope.

Section ListBags.

  Context {TItem : Type}
          {TSearchTerm : Type}
          {TUpdateTerm : Type}
          (bid : TUpdateTerm)
          (bfind_matcher: TSearchTerm -> TItem -> bool)
          (bupdate_transform : TUpdateTerm -> TItem -> TItem).

  Definition ListAsBag_bfind
             (container: list TItem)
             (search_term: TSearchTerm) :=
    List.filter (bfind_matcher search_term) container.

  Definition ListAsBag_binsert
             (container: list TItem)
             (item: TItem) :=
    cons item container.

  Definition ListAsBag_bcount
             (container: list TItem)
             (search_term: TSearchTerm) :=
    List.fold_left (fun acc x => acc + if (bfind_matcher search_term x) then 1 else 0) container 0.

  Definition ListAsBag_bdelete
             (container : list TItem)
             (search_term : TSearchTerm) :=
    List.partition (bfind_matcher search_term) container.

  Definition ListAsBag_bupdate
             (container   : list TItem)
             (search_term : TSearchTerm)
             (update_term : TUpdateTerm) :=
    ((fst (List.partition (bfind_matcher search_term) container)),
     ((snd (List.partition (bfind_matcher search_term) container))
        ++ List.map (bupdate_transform update_term)
        (fst (List.partition (bfind_matcher search_term) container)))).

  Definition ListBag_RepInv (_ : list TItem) := True.
  Definition ListBag_ValidUpdate (_ : TUpdateTerm) := True.

  Lemma List_BagInsertEnumerate :
    BagInsertEnumerate ListBag_RepInv id (ListAsBag_binsert).
  Proof.
    firstorder.
  Qed.

  Lemma List_BagEnumerateEmpty :
    BagEnumerateEmpty id (@nil TItem).
  Proof.
    firstorder.
  Qed.

  Lemma List_BagFindCorrect :
    BagFindCorrect ListBag_RepInv ListAsBag_bfind bfind_matcher id.
  Proof.
    firstorder.
  Qed.

  Lemma List_BagCountCorrect_aux :
    forall (container: list TItem) (search_term: TSearchTerm) default,
      length (List.filter (bfind_matcher search_term) container) + default =
      List.fold_left
        (fun (acc : nat) (x : TItem) =>
           acc + (if bfind_matcher search_term x then 1 else 0))
        container default.
  Proof.
    induction container; intros.

    + trivial.
    + simpl; destruct (bfind_matcher search_term a);
      simpl; rewrite <- IHcontainer; lia.
  Qed.

  Lemma List_BagCountCorrect :
    BagCountCorrect ListBag_RepInv ListAsBag_bcount ListAsBag_bfind.
  Proof.
    unfold BagCountCorrect, ListAsBag_bcount, ListAsBag_bfind; intros;
    pose proof (List_BagCountCorrect_aux container search_term 0) as temp;
    rewrite plus_0_r in temp; simpl in temp; exact temp.
  Qed.

  Lemma List_BagDeleteCorrect :
    BagDeleteCorrect ListBag_RepInv ListAsBag_bfind bfind_matcher id ListAsBag_bdelete.
  Proof.
    firstorder.
  Qed.

  Lemma List_BagUpdateCorrect :
    BagUpdateCorrect ListBag_RepInv ListBag_ValidUpdate
                     ListAsBag_bfind bfind_matcher id bupdate_transform ListAsBag_bupdate.
  Proof.
    firstorder.
  Qed.

  Global Instance ListAsBag
  : Bag (list TItem) TItem TSearchTerm TUpdateTerm :=
    {
      bempty            := nil;
      bfind_matcher     := bfind_matcher;
      bupdate_transform := bupdate_transform;

      benumerate := id;
      bfind      := ListAsBag_bfind;
      binsert    := ListAsBag_binsert;
      bcount     := ListAsBag_bcount;
      bdelete    := ListAsBag_bdelete;
      bupdate    := ListAsBag_bupdate
    }.

  Global Instance ListAsBagCorrect
  : CorrectBag ListBag_RepInv ListBag_ValidUpdate ListAsBag.
  refine {|

      binsert_enumerate := List_BagInsertEnumerate;
      benumerate_empty  := List_BagEnumerateEmpty;

      bfind_correct     := List_BagFindCorrect;
      bcount_correct    := List_BagCountCorrect;
      bdelete_correct   := List_BagDeleteCorrect;
      bupdate_correct   := List_BagUpdateCorrect
    |}.
  Proof.
    unfold ListBag_RepInv; eauto.
    unfold binsert_Preserves_RepInv; eauto.
    unfold bdelete_Preserves_RepInv; eauto.
    unfold bupdate_Preserves_RepInv; eauto.
  Qed.

End ListBags.


Require Export XR_R2_neq_R0.
Require Export XR_double.
Require Export XR_Rdiv.
Require Export XR_Rinv_r.
Require Export XR_Rmult_1_r.

Local Open Scope R_scope.

Lemma double_var : forall r1, r1 = r1 / R2 + r1 / R2.
Proof.
  intro x.
  unfold Rdiv.
  rewrite <- Rmult_plus_distr_l.
  rewrite <- double.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  reflexivity.
  exact R2_neq_R0.
Qed.


Require Import
  HoTT.Basics.Equivalences
  HoTT.HProp
  HoTT.Types.Universe
  HoTT.Types.Forall
  HoTT.Classes.interfaces.canonical_names
  HoTTClasses.interfaces.ua_algebra.

Import algebra_notations ne_list.notations.

Section congruence.
  Context {σ : Signature} (A : Algebra σ) (Φ : ∀ s, relation (A s)).

(** An operation [f : A s1 → A s2 → ... → A sn → A t] satisfies
    [OpCompatible f] iff

    <<
      Φ s1 x1 y1 ∧ Φ s2 x2 y2 ∧ ... ∧ Φ sn xn yn
    >>

    implies

    <<
      Φ t (f x1 x2 ... xn) (f y1 y2 ... yn).
    >>
*)

  Definition OpCompatible {w : SymbolType σ} (f : Operation A w)
    : Type
    := ∀ (a b : FamilyProd A (dom_symboltype w)),
       for_all_2_family_prod A A Φ a b ->
       Φ (cod_symboltype w) (ap_operation f a) (ap_operation f b).

  Class OpsCompatible : Type
    := ops_compatible : ∀ (u : Symbol σ), OpCompatible (u^^A).

  Global Instance trunc_ops_compatible `{Funext} {n : trunc_index}
    `{!∀ s x y, IsTrunc n (Φ s x y)}
    : IsTrunc n OpsCompatible.
  Proof.
    apply trunc_forall.
  Qed.

  (** A family of relations [Φ] is a congruence iff it is a family of
      mere equivalence relations and [OpsCompatible A Φ] holds. *)

  Class IsCongruence : Type := BuildIsCongruence
   { is_mere_relation_cong : ∀ (s : Sort σ), is_mere_relation (A s) (Φ s)
   ; equiv_rel_cong : ∀ (s : Sort σ), EquivRel (Φ s)
   ; ops_compatible_cong : OpsCompatible }.

  Global Arguments BuildIsCongruence {is_mere_relation_cong}
                      {equiv_rel_cong} {ops_compatible_cong}.

  Global Existing Instance is_mere_relation_cong.

  Global Existing Instance equiv_rel_cong.

  Global Existing Instance ops_compatible_cong.

  Global Instance hprop_is_congruence `{Funext} : IsHProp IsCongruence.
  Proof.
    apply (equiv_hprop_allpath _)^-1.
    intros [C1 C2 C3] [D1 D2 D3].
    by destruct (path_ishprop C1 D1),
                (path_ishprop C2 D2),
                (path_ishprop C3 D3).
  Defined.

End congruence.

(** If [Φ] is a congruence and [f : A s1 → A s2 → ... → A sn] an
    operation such that [OpCompatible A Φ f] holds.
    Then [OpCompatible (f x)] holds for all [x : A s1]. *)

Lemma op_compatible_cons {σ : Signature} {A : Algebra σ}
  (Φ : ∀ s, relation (A s)) `{!IsCongruence A Φ}
  (s : Sort σ) (w : SymbolType σ) (f : Operation A (s ::: w))
  (x : A s) (P : OpCompatible A Φ f)
  : OpCompatible A Φ (f x).
Proof.
  intros a b R.
  exact (P (x,a) (x,b) (EquivRel_Reflexive x, R)).
Defined.