(*
Copyright © 2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Export CoRN.metric2.UniformContinuity.
Require Export CoRN.metric2.Compact.
Require Export CoRN.metric2.Prelength.
Require Export CoRN.metric2.CompleteProduct.
Require Import CoRN.model.totalorder.QposMinMax.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.logic.Classic.

Set Implicit Arguments.

Local Open Scope Q_scope.

Section Graph.
(**
* Graphing
Uniformly continuous functions over compact sets can be graph.  A graph of a
funciton f : X --> Y is the the subset of X*Y {(x,f x) | x in S} where S is
the domain under consideration.  This graph is compact when S is a compact
subset of X.
*)
Variable X Y:MetricSpace.
Let XY := ProductMS X Y.

(** [graphPoint] is the fundamental function of graphing.  It will be lifted in
various ways to produce a graph *)
Definition graphPoint_raw (f:X -> Y) (x:X) : XY := (x,f x).

Local Open Scope uc_scope.

Variable f : X --> Y.

Definition graphPoint_modulus (e:Qpos) : Qpos :=
match (mu f e) with
| QposInfinity => e
| Qpos2QposInf d => Qpos_min e d
end.

Lemma graphPoint_uc : is_UniformlyContinuousFunction (graphPoint_raw f) graphPoint_modulus.
Proof.
 intros e a b H.
 unfold graphPoint_modulus in *.
 split.
  change (ball_ex e a b).
  eapply ball_ex_weak_le;[|apply H].
  destruct (mu f e) as [d|].
   apply Qpos_min_lb_l.
  apply Qle_refl.
 apply uc_prf.
 eapply ball_ex_weak_le;[|apply H].
 destruct (mu f e) as [d|].
  apply Qpos_min_lb_r.
 constructor.
Qed.

Definition graphPoint : X --> XY :=
Build_UniformlyContinuousFunction graphPoint_uc.

(** The compact image of graphFunction is the graph of [Cmap f] over any
compact set S *)
Definition CompactGraph (plFEX:PrelengthSpace (FinEnum X)) : Compact X --> Compact XY :=
CompactImage (1#1) plFEX graphPoint.

Lemma CompactGraph_correct1 : forall plX plFEX x s, (inCompact x s) ->
inCompact (Couple (x,(Cmap plX f x))) (CompactGraph plFEX s).
Proof.
 intros plX plFEX x s Hs.
 unfold CompactGraph.
 setoid_replace (Couple (X:=X) (Y:=Y) (x, (Cmap plX f x))) with (Cmap plX graphPoint x).
  auto using CompactImage_correct1.
 intros e1 e2.
 rewrite Qplus_0_r.
 split;simpl.
  unfold graphPoint_modulus.
  eapply ball_weak_le;[|apply regFun_prf].
  destruct (mu f e2); simpl.
   assert (Qmin (proj1_sig e2) (proj1_sig q) <= proj1_sig e2) by auto with *.
   rewrite -> Qle_minus_iff in *.
   rewrite Q_Qpos_min.
   rewrite <- Qle_minus_iff.
   apply Qplus_le_r.
   rewrite <- Qle_minus_iff in H.
   exact H.
  apply Qle_refl.
 apply (mu_sum plX e2 (e1::nil) f).
 simpl.
 unfold graphPoint_modulus.
 eapply ball_ex_weak_le;[|apply regFun_prf_ex].
 destruct (mu f e1) as [d0|]; try constructor.
 destruct (mu f e2) as [d|]; try constructor.
 simpl. rewrite Q_Qpos_min.
 assert (Qmin (proj1_sig e2) (proj1_sig d) <= proj1_sig d) by auto with *.
 apply Qplus_le_r.
 exact H.
Qed.

Lemma CompactGraph_correct2 : forall plFEX p s, inCompact p (CompactGraph plFEX s) ->
inCompact (Cfst p) s.
Proof.
 intros plFEX p s H e1 e2.
 simpl.
 unfold Cfst_raw.
 apply FinSubset_ball_closed.
 intros d dpos.
 set (d':=((1#2)*exist _ _ dpos)%Qpos).
 assert (Qeq (proj1_sig e1 + proj1_sig e2 + d)
             (proj1_sig ((e1 + d') + (d'+ e2))%Qpos))
   by (simpl; ring).
 apply (@FinSubset_ball_wd_full _ _ _
           H0 _ _ (reflexivity _) _ _ (reflexivity _)).
 clear H0.
 pose proof (H e1 d') as H'.
 clear H.
 unfold XY in *.
 destruct (approximate p e1) as [a b].
 simpl in *.
 unfold FinEnum_map_modulus, graphPoint_modulus in H'.
 set (d2:=match mu f d' with | Qpos2QposInf d => Qpos_min d' d | QposInfinity => d' end) in *.
 eapply FinSubset_ball_triangle_r with (approximate s d2).
  clear - H'.
  induction (approximate s d2).
  exfalso; exact (FinSubset_ball_nil H').
  apply FinSubset_ball_orC in H'.
  destruct H' as [G | [H' _] | H'] using orC_ind.
 intro abs; contradict G; intro G; contradiction.
 intro abs; contradict abs. exists a0.
 split. left. reflexivity.
   assumption.
   apply FinSubset_ball_cons.
  apply IHl.
  assumption.
 eapply ball_weak_le;[|apply regFun_prf].
 unfold d2.
 destruct (mu f d') as [d0|]; auto with *.
 simpl. rewrite Q_Qpos_min.
 assert (Qmin (proj1_sig d') (proj1_sig d0) <= proj1_sig d') by auto with *.
 apply Qplus_le_l.
 exact H.
Qed.

Lemma CompactGraph_correct3 : forall plX plFEX p s, inCompact p (CompactGraph plFEX s) ->
msp_eq (Cmap plX f (Cfst p)) (Csnd p).
Proof.
 intros plX plFEX p s H.
 apply ball_eq.
 intros e1 epos.
 apply regFunBall_e.
 intros e2.
 set (e':=((1#6)*exist _ _ epos)%Qpos).
 setoid_replace (proj1_sig e2 + e1 + proj1_sig e2)
   with (proj1_sig ((e2 + e') + ((e' + e') + (e' + e')) + (e2 + e'))%Qpos)
   by (unfold e'; simpl; ring).
 set (d' := graphPoint_modulus e').
 assert (Hd'1 : proj1_sig d' <= proj1_sig e').
  unfold d', graphPoint_modulus.
  destruct (mu f e'); auto with *.
  apply Qpos_min_lb_l.
 assert (Hd'2 : QposInf_le d' (mu f e')).
  unfold d', graphPoint_modulus.
  destruct (mu f e').
   apply Qpos_min_lb_r.
  constructor.
 assert (H':= H d' d').
 apply ball_triangle with (approximate (Csnd p) d').
  apply ball_triangle with (f (Cfst_raw p d')).
   apply (mu_sum plX e' (e2::nil) f).
   simpl.
   apply ball_ex_weak_le with (mu f e2 + d')%QposInf.
    destruct (mu f e2); try constructor.
    destruct (mu f e'); try constructor.
    clear - Hd'2.
    simpl in *.
    apply Qplus_le_r.
    exact Hd'2.
   unfold Cfst_raw.
   simpl.
   assert (Z:=regFun_prf_ex p (mu f e2) d').
   destruct (mu f e2); try constructor.
   destruct Z; auto.
  assert (L:existsC X (fun x => ball (proj1_sig d' + proj1_sig d') (approximate p d') (x, (f x)))).
   clear -H'.
   simpl in H'.
   unfold FinEnum_map_modulus, graphPoint_modulus in H'.
   induction (@approximate _ (FinEnum_ball X) s (Qpos2QposInf match @mu X Y f d' return Qpos with
     | Qpos2QposInf d => Qpos_min d' d | QposInfinity => d' end)).
   exfalso; exact (FinSubset_ball_nil H').
   apply FinSubset_ball_orC in H'.
   destruct H' as [G | H | H] using orC_ind.
 intro abs; contradict G; intro G; contradiction.
    apply existsWeaken.
    exists a.
    apply H.
   auto.
  clear - L Hd'1 Hd'2 plX.
  destruct L as [G | a [Hl Hr]] using existsC_ind.
  apply (msp_stable (msp _)), G.
  apply ball_triangle with (f a).
   simpl.
   apply (mu_sum plX e' (e'::nil) f).
   simpl.
   unfold graphPoint_modulus in d'.
   apply ball_ex_weak_le with (d' + d')%Qpos.
    clear - Hd'2.
    destruct (mu f e'); try constructor.
    simpl in *.
    apply Qplus_le_compat; exact Hd'2.
   apply Hl.
  apply ball_sym.
  eapply ball_weak_le;[|apply Hr].
  simpl.
  clear - Hd'1.
  apply Qplus_le_compat; exact Hd'1.
 eapply ball_weak_le;[|apply regFun_prf].
 simpl.
 rewrite Qplus_comm.
 apply Qplus_le_r.
 exact Hd'1.
Qed.

Lemma CompactGraph_graph : forall (plX : PrelengthSpace X) plFEX p q1 q2 s,
 inCompact (Couple (p,q1)) (CompactGraph plFEX s) ->
 inCompact (Couple (p,q2)) (CompactGraph plFEX s) ->
 msp_eq q1 q2.
Proof.
 intros plX plFEX p q1 q2 s Hq1 Hq2.
 transitivity (Cmap plX f p).
  symmetry.
  rewrite <- (CoupleCorrect2 p q1).
  refine (CompactGraph_correct3 _ _).
  apply Hq1.
 rewrite <- (CoupleCorrect2 p q2).
 refine (CompactGraph_correct3 _ _).
 apply Hq2.
Qed.

Lemma CompactGraph_correct : forall plX plFEX x y s,
inCompact (Couple (x,y)) (CompactGraph plFEX s) <->
(inCompact x s /\ msp_eq y (Cmap plX f x)).
Proof.
 intros plX plFEX x y s.
 split; intros H.
  split; rewrite <- (CoupleCorrect2 x y).
   apply (@CompactGraph_correct2 plFEX).
   exact H.
  symmetry.
  transitivity (Csnd (Couple (x,y))).
   refine (CompactGraph_correct3 _ _).
   apply H.
  apply CoupleCorrect3.
 destruct H as [H0 H1].
 change (x, y) with (PairMS x y).
 rewrite -> H1.
 apply CompactGraph_correct1.
 auto.
Qed.

End Graph.

Section GraphBind.

(**
** Graph and Bind
The previous section used [graphPoint] to produce the graph of [Cmap f] over
any compact set S.  In this section we use [graphPoint_b] to produce the
graph of [Cbind f] over any compact set S.  It proceeds in largely the same
way. *)

(*This section ought to be defined in terms of Graph,
 but I'm too tired to figure out how to do it properly.
 Instead I just brainlessly cut and paste and modify the above
 section. *)

Variable X Y:MetricSpace.
Let XY := ProductMS X Y.

Definition graphPoint_b_raw (f:X -> Complete Y) (x:X) : Complete XY := Couple (Cunit x,f x).

Local Open Scope uc_scope.

Variable f : X --> Complete Y.

Lemma graphPoint_b_uc : is_UniformlyContinuousFunction (graphPoint_b_raw f) (graphPoint_modulus f).
Proof.
 intros e a b H d1 d2.
 split.
  change (ball_ex (Qpos2QposInf d1 + e + Qpos2QposInf d2) a b).
  eapply ball_ex_weak_le;[|apply H].
  unfold graphPoint_modulus.
  destruct (mu f e) as [d|].
 - simpl.
   apply Qle_trans with (proj1_sig e + 0).
   rewrite Qplus_0_r.
    apply Qpos_min_lb_l.
    rewrite <- (Qplus_comm (proj1_sig e)), <- Qplus_assoc.
    apply Qplus_le_r.
    apply (Qpos_nonneg (d1+d2)).
 - simpl.
   apply Qle_trans with (proj1_sig e + 0).
   rewrite Qplus_0_r.
    apply Qle_refl.
    rewrite <- (Qplus_comm (proj1_sig e)), <- Qplus_assoc.
    apply Qplus_le_r.
    apply (Qpos_nonneg (d1+d2)).
 - simpl.
 revert d1 d2.
 change (ball (proj1_sig e) (f a) (f b)).
 apply uc_prf.
 eapply ball_ex_weak_le;[|apply H].
 unfold graphPoint_modulus.
 destruct (mu f e) as [d|].
  apply Qpos_min_lb_r.
 constructor.
Qed.

Definition graphPoint_b : X --> Complete XY :=
Build_UniformlyContinuousFunction graphPoint_b_uc.

Definition CompactGraph_b (plFEX:PrelengthSpace (FinEnum X)) : Compact X --> Compact XY :=
CompactImage_b (1#1) plFEX graphPoint_b.

Local Open Scope Q_scope.

Lemma CompactGraph_b_correct1 : forall plX plFEX x s, (inCompact x s) ->
inCompact (Couple (x,(Cbind plX f x))) (CompactGraph_b plFEX s).
Proof.
 intros plX plFEX x s Hs.
 unfold CompactGraph_b.
 setoid_replace (Couple (X:=X) (Y:=Y) (x, (Cbind plX f x))) with (Cbind plX graphPoint_b x).
  auto using CompactImage_b_correct1.
 intros e1 e2.
 rewrite Qplus_0_r.
 split.
 apply ball_weak_le with (proj1_sig (e1 + (graphPoint_modulus f ((1 # 2) * e2)))%Qpos)
 ;[|apply regFun_prf].
  unfold graphPoint_modulus.
  destruct (mu f ((1#2)*e2)). simpl.
   rewrite Q_Qpos_min.
  assert (Qmin ((1#2)*proj1_sig e2) (proj1_sig q)
          <= ((1#2)*proj1_sig e2)) by auto with *.
  apply Qplus_le_r.
  apply (Qle_trans _ _ _ H).
  rewrite <- (Qmult_1_l (proj1_sig e2)) at 2.
  apply Qmult_le_r.
  apply Qpos_ispos.
  discriminate.
   simpl.
   apply Qplus_le_r.
  rewrite <- (Qmult_1_l (proj1_sig e2)) at 2.
  apply Qmult_le_r.
  apply Qpos_ispos.
  discriminate.
 simpl. unfold Cjoin_raw.
 rewrite <- ball_Cunit.
 setoid_replace (proj1_sig e1 + proj1_sig e2)
   with (proj1_sig ((1#2)*e1 + ((1#2)*e1 + (1#2)*e2) + (1#2)*e2)%Qpos)
   by (simpl; ring).
 eapply ball_triangle;[|apply ball_approx_r].
 eapply ball_triangle.
 apply (ball_approx_l (approximate (Cmap_fun plX f x) (Qpos2QposInf ((1 # 2)%Qpos * e1)))
                      ((1#2)*e1)).
 set (e1':=((1 # 2) * e1)%Qpos).
 set (e2':=((1 # 2) * e2)%Qpos).
 simpl.
 apply (mu_sum plX e2' (e1'::nil) f).
 apply ball_ex_weak_le
   with (e:= (mu f e1' + graphPoint_modulus f ((1 # 2) * e2))%QposInf).
 2: apply regFun_prf_ex.
 unfold e1'.
 unfold graphPoint_modulus.
 replace (fold_right QposInf_plus (mu f e2') (map (mu f) (((1 # 2) * e1)%Qpos :: nil)))
   with (mu f ((1 # 2) * e1) + mu f e2')%QposInf by reflexivity.
 destruct (mu f ((1#2)*e1)) as [d0|]; try constructor.
 unfold e2'.
 destruct (mu f ((1 # 2) * e2)) as [d|]; try constructor.
 simpl. rewrite Q_Qpos_min.
 assert (Qmin (proj1_sig e2') (proj1_sig d) <= proj1_sig d) by auto with *.
 apply Qplus_le_r.
 exact H.
Qed.

Lemma CompactGraph_b_correct2 : forall plFEX p s, inCompact p (CompactGraph_b plFEX s) ->
 inCompact (Cfst p) s.
Proof.
 intros plFEX p s H e1 e2.
 simpl.
 unfold Cfst_raw.
 apply FinSubset_ball_closed.
 intros d dpos.
 set (d':=((1#2)*exist _ _ dpos)%Qpos).
 assert (Qeq (proj1_sig e1 + proj1_sig e2 + d)
             (proj1_sig ((e1 + d') + (d'+ e2))%Qpos))
   by (simpl; ring).
 apply (@FinSubset_ball_wd_full _ _ _
           H0 _ _ (reflexivity _) _ _ (reflexivity _)).
 clear H0.
 assert (H':=H e1 d').
 clear H.
 unfold XY in *.
 destruct (approximate p e1) as [a b].
 simpl in *.
 unfold Cjoin_raw in H'.
 simpl in *.
 unfold FinEnum_map_modulus, graphPoint_modulus in H'.
 remember (match mu f ((1#2)*d') with
           | Qpos2QposInf d => Qpos_min ((1#2)*d') d
           | QposInfinity => ((1#2)*d')%Qpos end) as d2.
 simpl in Heqd2. rewrite <- Heqd2 in H'.
 eapply FinSubset_ball_triangle_r with (approximate s d2).
  clear - H'.
  induction (approximate s d2).
  exfalso; exact (FinSubset_ball_nil H').
  apply FinSubset_ball_orC in H'.
  destruct H' as [G | [H' _] | H'] using orC_ind.
 intro abs; contradict G; intro G; contradiction.
 intro abs; contradict abs. exists a0.
 split. left. reflexivity.
   assumption.
   apply FinSubset_ball_cons.
  apply IHl.
  assumption.
 eapply ball_weak_le;[|apply regFun_prf].
 rewrite Heqd2.
 destruct (@mu X (Complete Y) f
              (Qpos_mult
                 (@exist Q (Qlt {| Qnum := Z0; Qden := xH |})
                         {| Qnum := Z.pos xH; Qden := xO xH |} (@eq_refl comparison Lt)) d'))
   as [d0|].
 simpl.
 assert (Qmin ((1#2)* proj1_sig d') (proj1_sig d0) <= ((1#2)*proj1_sig d'))
   by auto with *.
 apply Qplus_le_l.
  rewrite Q_Qpos_min.
 apply (Qle_trans _ _ _ H).
 apply Qmult_le_l. reflexivity.
 simpl.
 rewrite <- (Qmult_1_l d) at 2.
 apply Qmult_le_r.
 apply dpos.
 discriminate.
  simpl.
  apply Qplus_le_l.
 rewrite <- (Qmult_1_l ((1 # 2) * d)) at 2.
 apply Qmult_le_r.
 apply (Qpos_ispos d').
 discriminate.
Qed.

Lemma CompactGraph_b_correct3 : forall plX plFEX p s, inCompact p (CompactGraph_b plFEX s) ->
msp_eq (Cbind plX f (Cfst p)) (Csnd p).
Proof.
 intros plX plFEX p s H.
 apply ball_eq.
 intros e1 epos.
 apply regFunBall_e.
 intros e2.
 set (e':=((1#6)*exist _ _ epos)%Qpos).
 setoid_replace (proj1_sig e2 + e1 + proj1_sig e2)
   with (proj1_sig ((e2 + e') + ((e' + e') + (e' + e')) + (e2 + e'))%Qpos)
   by (unfold e'; simpl; ring).
 set (d' := graphPoint_modulus f ((1#2)*e')).
 assert (Hd'1 : proj1_sig d' <= proj1_sig e').
  unfold d', graphPoint_modulus.
  destruct (mu f ((1#2)*e')); autorewrite with QposElim.
   apply Qle_trans with ((1#2)*proj1_sig e'); auto with *.
  rewrite <- (Qmult_1_l (proj1_sig e')) at 2.
  apply Qmult_le_r.
  apply Qpos_ispos.
  discriminate.
  rewrite <- (Qmult_1_l (proj1_sig e')).
  apply Qmult_le_r.
  apply Qpos_ispos.
  discriminate.
 assert (Hd'2 : QposInf_le (d') (mu f ((1#2)*e'))).
  unfold d', graphPoint_modulus.
  destruct (mu f ((1#2)*e')).
   apply Qpos_min_lb_r.
  constructor.
 assert (H':= H ((1#2)*d')%Qpos d').
 apply ball_triangle with (approximate (Csnd p) (Qpos2QposInf ((1#2)%Qpos*d'))).
  simpl (approximate (Cbind plX f (Cfst (X:=X) (Y:=Y) p)) e2).
  apply ball_triangle
    with (approximate (f (Cfst_raw p (Qpos2QposInf (1#2)*d')))
                      (Qpos2QposInf (1#2)*d'))%Qpos.
   unfold Cjoin_raw.
   simpl.
   apply ball_weak_le with (proj1_sig ((1#2)*e2 + ((1#2)*e2 + (1#2)*e') + (1#2)*d')%Qpos).
   simpl.
    clear - Hd'1.
    rewrite -> Qle_minus_iff in *.
    setoid_replace (proj1_sig e2 + (1 # 6) * e1 +
  -
  ((1 # 2) * proj1_sig e2 + ((1 # 2) * proj1_sig e2 + (1 # 2) * ((1 # 6) * e1)) +
   (1 # 2) * proj1_sig d'))
      with ((1 # 2) * (proj1_sig e' + - proj1_sig d'))
      by (simpl; ring).
    apply Qmult_le_0_compat. discriminate.
    exact Hd'1.
   cut (ball ((1 # 2) * proj1_sig e2 + (1 # 2) * proj1_sig e') (f (Cfst_raw p (mu f ((1 # 2) * e2))))
     (f (Cfst_raw p ((1 # 2) * d')%Qpos))).
    intros L.
    apply L.
   apply (mu_sum plX ((1#2)*e') (((1#2)*e2)::nil) f)%Qpos.
   apply ball_ex_weak_le
     with (QposInf_plus (mu f ((1#2)*e2)) (Qpos2QposInf (1#2)*d'))%Qpos.
   simpl.
   destruct (@mu X (Complete Y) f
          (Qpos_mult
             (@exist Q (Qlt {| Qnum := Z0; Qden := xH |})
                     {| Qnum := Z.pos xH; Qden := xO xH |} (@eq_refl comparison Lt)) e2))
   ; try constructor.
   simpl in Hd'2.
   destruct (@mu X (Complete Y) f
          (Qpos_mult
             (@exist Q (Qlt {| Qnum := Z0; Qden := xH |})
                     {| Qnum := Z.pos xH; Qden := xO xH |} (@eq_refl comparison Lt)) e'))
   ; try constructor.
    clear - Hd'2.
    simpl in *.
    apply Qplus_le_r.
    refine (Qle_trans _ _ _ _ Hd'2).
    rewrite <- (Qmult_1_l (proj1_sig d')) at 2.
    apply Qmult_le_r.
    apply Qpos_ispos.
    discriminate.
   unfold Cfst_raw.
   assert (Z:=regFun_prf_ex p (mu f ((1#2)*e2)) (Qpos2QposInf (1#2)%Qpos*d')).
   destruct (mu f ((1#2)*e2)); try constructor.
   destruct Z; auto.
   assert (L:existsC X (fun x => ball (proj1_sig (((1#2)*d') + d')%Qpos)
                                   (approximate p (Qpos2QposInf (1#2)%Qpos*d')) (Couple_raw ((Cunit x), (f x)) (Qpos2QposInf ((1#2)*d')%Qpos)))).
   clear -H'.
   simpl in H'.
   unfold Cjoin_raw in H'.
   simpl in H'.
   unfold FinEnum_map_modulus, graphPoint_modulus in H'.
   remember (match mu f ((1 # 2) * d') with
                  | Qpos2QposInf d => Qpos_min ((1 # 2) * d') d
                  | QposInfinity => ((1 # 2) * d')%Qpos
                  end) as mm.
   simpl in Heqmm. rewrite <- Heqmm in H'.
   induction (@approximate _ (FinEnum_ball X) s mm).
   exfalso; exact (FinSubset_ball_nil H').
   apply FinSubset_ball_orC in H'.
   destruct H' as [G | H | H] using orC_ind.
 intro abs; contradict G; intro G; contradiction.
    apply existsWeaken.
    exists a.
    apply H.
   auto.
  clear - L Hd'1 Hd'2 plX.
  destruct L as [G | a [Hl Hr]] using existsC_ind.
  apply (msp_stable (msp _)), G.
  apply ball_triangle with (approximate (f a) (Qpos2QposInf ((1#2)%Qpos*d'))).
   apply ball_weak_le with (proj1_sig ((1#2)*d' + ((1#2)*e' + (1#2)*e') + (1#2)*d')%Qpos).
    clear - Hd'1.
    simpl.
    rewrite -> Qle_minus_iff in *.
    setoid_replace ( (1 # 6) * e1 + (1 # 6) * e1 +
  -
  ((1 # 2) * proj1_sig d' + ((1 # 2) * ((1 # 6) * e1) + (1 # 2) * ((1 # 6) * e1)) +
   (1 # 2) * proj1_sig d'))
      with (proj1_sig e' + - proj1_sig d') by (simpl; ring).
    exact Hd'1.
   simpl.
   rewrite <- ball_Cunit.
   eapply ball_triangle;[|apply (ball_approx_r _ ((1#2)*d')%Qpos)].
   eapply ball_triangle;[apply (ball_approx_l _ ((1#2)*d'))|].
   apply (mu_sum plX ((1#2)*e') (((1#2)*e')::nil) f)%Qpos.
   simpl.
   unfold graphPoint_modulus in d'.
   apply ball_ex_weak_le with (d' + d')%Qpos.
    clear - Hd'2.
    simpl in Hd'2.
    destruct (@mu X (Complete Y) f
          (Qpos_mult
             (@exist Q (Qlt {| Qnum := Z0; Qden := xH |})
                     {| Qnum := Z.pos xH; Qden := xO xH |} (@eq_refl comparison Lt)) e'))
    ; try constructor.
    simpl in *.
    apply Qplus_le_compat; exact Hd'2.
   simpl.
   eapply ball_weak_le;[|apply Hl].
   simpl.
   apply Qplus_le_l.
   rewrite <- (Qmult_1_l (proj1_sig d')) at 2.
   apply Qmult_le_r.
   apply Qpos_ispos.
   discriminate.
  apply ball_sym.
  eapply ball_weak_le;[|apply Hr].
  apply Qplus_le_compat.
  2: exact Hd'1.
  refine (Qle_trans _ _ _ _ Hd'1).
   rewrite <- (Qmult_1_l (proj1_sig d')).
   apply Qmult_le_r.
   apply Qpos_ispos.
   discriminate.
 eapply ball_weak_le;[|apply (regFun_prf (Csnd p) ((1#2)*d')%Qpos)].
 rewrite Qplus_comm.
 apply Qplus_le_r.
  refine (Qle_trans _ _ _ _ Hd'1).
   rewrite <- (Qmult_1_l (proj1_sig d')).
   apply Qmult_le_r.
   apply Qpos_ispos.
   discriminate.
Qed.

Lemma CompactGraph_b_graph : forall (plX : PrelengthSpace X) plFEX p q1 q2 s,
 inCompact (Couple (p,q1)) (CompactGraph_b plFEX s) ->
 inCompact (Couple (p,q2)) (CompactGraph_b plFEX s) ->
 msp_eq q1 q2.
Proof.
 intros plX plFEX p q1 q2 s Hq1 Hq2.
 transitivity (Cbind plX f p).
  symmetry.
  rewrite <- (CoupleCorrect2 p q1).
  refine (CompactGraph_b_correct3 _ _).
  apply Hq1.
 rewrite <- (CoupleCorrect2 p q2).
 refine (CompactGraph_b_correct3 _ _).
 apply Hq2.
Qed.

Lemma CompactGraph_b_correct : forall plX plFEX x y s,
inCompact (Couple (x,y)) (CompactGraph_b plFEX s) <->
(inCompact x s /\ msp_eq y (Cbind plX f x)).
Proof.
 intros plX plFEX x y s.
 split; intros H.
  split; rewrite <- (CoupleCorrect2 x y).
   apply (@CompactGraph_b_correct2 plFEX).
   exact H.
  symmetry.
  transitivity (Csnd (Couple (x,y))).
   refine (CompactGraph_b_correct3 _ _).
   apply H.
  apply CoupleCorrect3.
 destruct H as [H0 H1].
 change (x, y) with (PairMS x y).
 rewrite -> H1.
 apply CompactGraph_b_correct1.
 auto.
Qed.

End GraphBind.


From Mtac2 Require Import Base MTele Logic.
Import M.notations.

Set Universe Polymorphism.
Unset Universe Minimization ToSet.

From Coq Require Import JMeq.

Notation "x =j= y" := (JMeq x y)
                 (at level 70, y at next level, no associativity).
Lemma JMeq_types : forall {A B} {x: A} {y: B} (H: x =j= y), A =m= B.
Proof.
  intros.
  destruct H. reflexivity.
Qed.

Lemma JMeq_meq : forall {A} (x: A) (y: A) (H: x =j= y), x =m= y.
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

(** Given a term [t] of type [T], assumed to be of the form [let x : A := y in
    t'], with [T] being [let x : A := y in P] (or its let-expanded version), it
    gets a function [f] and executes [f A x y P meq_refl t' JMeq_refl] under the
    context extended with [x : A := y].  Assuming it returns value [b], it
    returns it after checking no harm is done: [x] is not free in [b]. Note that
    one might tink that it's wrong to return [y] or [P]. However, these terms
    where well-typed in the original context, so there is no problem. [x] is the
    only one being added to the context, and the one to care about. *)
Definition full_nu_let {T} (n: name) (t: T)
  {B : Type}
  (f : forall A (x y: A) P (eqxy: x =m= y) (t': P) (eqP: t =j= t'), M B) :
  M B.
  intros. exact M.mkt.
Qed.

(** Given a variable [x] of type [A], a definition (supposed to be equal) [y],
    and a term [t] of type [P], it returns a [t'] equals to [t]: [let z : A := y
    in t{z/x}]. It won't check if [y] is the actual definition, as long it is
    equal to [x] (that's what [eqxy] says), and assuming [x] is a variable, it
    should be sound to return the let-binding. The reason why the returned term
    has the same type as [P] is because [let z:A := y in t{z/x}] has type
    [P{y/x}] and, since [x =m= y], we get [P{x/x}] which is [P]. *)
Definition full_abs_let : forall {A : Type} {P : Type} (x y : A) (eqxy: x=m=y) (t: P),
    M {t' : P & t =m= t'}.
  intros. exact M.mkt.
Qed.

Definition old_nu_let {A B C : Type} (n: name) (blet: C) (f: A -> C -> M B) : M B :=
  full_nu_let n blet (fun A' x y P eqxy t' eqt'  =>
    eqAA' <- M.unify_or_fail UniCoq A' A;
    let x := reduce (RedWhd [rl:RedMatch]) (match eqAA' with meq_refl => x end) in
    let eqCP := dreduce (@JMeq_types, @meq_sym) (meq_sym (JMeq_types eqt')) in
    let t' := reduce (RedWhd [rl:RedMatch]) (match eqCP with meq_refl => t' end) in
    f x t').

Obligation Tactic := simpl; intros.
Program
Definition let_completeness {B} (term: B) : M {blet : B & blet =m= term} :=
  full_nu_let (TheName "m") term (fun A m d P eqmd body eqP=>
    body_let <- full_abs_let (P:=P) m d eqmd body;
    let (blet, jeq) := body_let in
    M.ret (existT _ _ _ : { blet : _ & blet =m= term})).
Next Obligation.
  apply JMeq_types in eqP.
  rewrite eqP.
  exact blet.
Defined.
Next Obligation.
  cbv.
  simpl in jeq.
  destruct eqmd.
  destruct (JMeq_types eqP).
  rewrite eqP.
  rewrite jeq.
  reflexivity.
Defined.

Program
Definition let_soundness {A} {P} (x d: A) (term: P) (eqxd : x =m= d) : M {t : P & t =m= term} :=
  letb <- full_abs_let x d eqxd term;
  let (blet, eq) := letb in
  full_nu_let (TheName "m") blet (fun B a b T eqab t' eqblet =>
     _).
Next Obligation.
  refine (M.ret (existT _ _ _)).
  simpl in eq.
  generalize (JMeq_types eqblet).
  intro eqPT.
  generalize t' eqblet.
  clear t' eqblet.
  rewrite <- eqPT.
  intros t' eqblet.
  rewrite eq. rewrite eqblet.
  reflexivity.
Qed.

Print Module M.M.

(** Let [T] equals to [forall x:A, B x] and [t] equals to [fun x:A => b], it
    introduces [x:A] in the context, and executes [f A x B b meq_refl meq_refl],
    the first [meq_refl] being the equality of types [T =m= forall x:A, B x] and
    the second of the body, morally [t x =m= b]. The value returned by [f] must
    not contain [x]. *)
Definition dest_fun_type (T C: Type) (t: T): Type.
  refine ((forall A (x: A) (B: A->Type) (b: B x)
  (eqTB : T =m= (forall z:A, B z)) (eqt: (_ : (forall z, B z)) x =m= b), M C) -> M C).
  rewrite eqTB in t. exact t.
Defined.

Definition dest_fun {T C} t : dest_fun_type T C t.
  intros; constructor. Qed.

Definition abs_fun: forall{A: Type} {P: A->Type} (x: A) (t: P x),
  M {t': forall x, P x & t' x =m= t}.
  constructor. Qed.

Require Import ssreflect.

Lemma equal_f_dep : forall {A B} {f g : forall (x : A), B x},
  f =m= g -> forall x, f x =m= g x.
Proof. by move=>? ? ? ? ->. Qed.

Axiom functional_extensionality_dep : forall {A} {B : A -> Type},
  forall (f g : forall x : A, B x),
  (forall x, f x =m= g x) -> f =m= g.

Program
Definition fun_completeness {T: Type} (t: T) : M {A:Type & {P:A->Type & {funp : forall x:A, P x & funp =j= t}}} :=
  dest_fun t (fun A x B b eqTB eqt =>
    absf <- abs_fun x b;
    let (t', eqtb') := absf in
      M.ret (existT _ A (existT _ B (existT _ t' _)))).
Next Obligation.
  cbv in eqt.
  rewrite -eqt in eqtb'.
  move: eqtb'.
  (* We know that [t' x =m= t' x] but we can't conclude that [t' =m=
  t]. Informally, this holds because [x] can be substituted by any [y], and then
  conclude with functional_extensionality_dep. *)
Admitted.

Axiom forall_extensionality : forall (A : Type) (B C : A -> Type),
  (forall x : A, B x =m= C x) -> (forall x : A, B x) =m= (forall x : A, C x).

Axiom forall_extensionality_domain : forall (A B: Type) (C: A -> Type) (D: B -> Type),
  (forall x : A, C x) =m= (forall x : B, D x) -> A =m= B. (* this is not true I think *)

Axiom forall_extensionality_codomain : forall (A: Type) (C: A -> Type) (D: A -> Type),
  (forall x, C x) =m= (forall x, D x) -> C =m= D. (* does it make sense? *)

Program
Definition fun_soundness {A: Type} {P: A->Type} (x: A) (b: P x) : M {b':P x & b' =m= b} :=
  absf <- abs_fun x b;
  let (funp, feq) := absf in
  dest_fun funp (fun A' x' B' b' eqPP' eqbb' =>
     M.ret (existT _ _ _ : {b':P x & b' =m= b})).
Next Obligation.
  move/forall_extensionality_domain: (eqPP')=>eqAA'.
  move: B' x' b' eqPP' eqbb'.
  rewrite -eqAA'.
  intros.
  move/forall_extensionality_codomain: (eqPP')=>eqPB'.
  move: b' eqPP' eqbb'.
  rewrite -eqPB'.
  move=>b' eqPP'.
  cbv.
Admitted.

Require Import BinNat.
Inductive level := aLevel : N -> level | aVar : N -> level.
Inductive sort := sProp | sSet | sType : level -> sort.

Definition dest_sort : Type -> M sort.
  intros. exact M.mkt. Qed.

Definition make_sort : sort -> M Type.
  intros. exact M.mkt. Qed.

(* There's nothing we can prove about this *)

(** Let's see what we can do with decompose_forallT *)
Require Import Mtac2.lib.Datatypes.

(* So far it doesn't provide any equality, so we can't prove anything *)
Axiom admit : forall P, P.
Program
Definition forall_complete (T:Type) : M {T':Type & T' =m= T} :=
  M.decompose_forallT (B:=fun _=>{T':Type & T' =m= T}) T (fun A b =>
     M.nu Generate mNone (fun x=>
       r <- M.abs_prod_type x (b x);
       M.ret (existT _ r (admit _)) : M {T':Type & T' =m= T})) (M.failwith "error").

Require Import Mtac2.
(* but it works *)
Goal (forall x, x > 0 : Type) =m= (forall x, x > 0 : Type).
MProof.
  r <- forall_complete (forall x, x > 0);
  let (x, _) := r in
  T.exact (meq_refl x).
Qed.

Import M.notations.

(** An [abs_fun] function without generating terms of equalities on the OCaml side *)
Definition abs_fun' {A : Type} {P : A -> Type} (x : A) {B : _} (c : P x) :
  (forall (f : forall x, P x), M (B (f x))) -> M (B c).
  constructor. Qed.

(** The abs_fun from above can be defined in term of this last one: *)
Definition abs_fun'' : forall{A: Type} {P: A->Type} (x: A) (c : P x),
    M {t': forall x, P x & t' x =m= c}.
  intros. refine (abs_fun' x (B:=fun c => {t' : forall x, P x & t' x =m= c}) _ _).
  intros. refine (M.ret _). econstructor. reflexivity.
Defined.

(** Given a function [F : A->Type], it returns [forall x, F x] (and a proof of
this equality)*)
Definition abs_prod' {A} (F: A->Type) : M {T:Type& T =m= forall x, F x}.
  constructor. Qed.

(** Just for the record, this is how you get the original abs_prod *)
Definition abs_prod {A} (x:A) (t: Type) : M Type :=
  f <- M.abs_fun x t;
  '(existT _ T _) <- abs_prod' f;
  M.ret T.

(** A version of [abs_prod] returning proofs: given [x] and [t], it returns a
term [T] and a function [F] such that [T = forall y, F y], and [F x = t]. *)
Definition abs_prod_pf {A} (x:A) (t: Type) : M {T & {F & F x =m= t /\ T =m= forall x, F x}}.
  refine (
  '(existT _ f pf) <- abs_fun'' x t;
  '(existT _ T pfT) <- abs_prod' f;
  M.ret _).
  exists T.
  exists f.
  split; assumption.
Defined.


From Undecidability.L Require Export Prelim.ARS Prelim.MoreBase.
From Undecidability.Shared.Libs.PSL Require Export Base Bijection.
From Undecidability.L Require Export L.

Require Import Lia.

#[export] Hint Constructors ARS.star : cbv.

(* * The call-by-value lambda calculus L *)

(* ** Syntax   *)

Notation "'#' v" := (var v) (at level 1).
(* Notation "(λ  s )" := (lam s) (right associativity, at level 0).  *)

Module L_Notations_app.
  Coercion app : term >-> Funclass.
End L_Notations_app.

Module L_Notations.

  Coercion var : nat >-> term.
  Export L_Notations_app.
End L_Notations.

Instance term_eq_dec : eq_dec term.
Proof.
  intros s t; unfold dec; repeat decide equality.
Defined. (* because instance *)

Definition term_eq_dec_proc s t := if Dec (s = t) then true else false.

#[export] Hint Resolve term_eq_dec : core.

(* Notation using binders *)

Inductive hoas : Type := hv (n : nat) | ha (s t : hoas) | hl (f : nat -> hoas) | hter (t : term).

Fixpoint TH n s :=
  match s with
  | hv m => var (n - m - 1)
  | ha s t => app (TH n s) (TH n t)
  | hl f => lam (TH (S n) (f n))
  | hter t => t
  end.

(* TODO: should not be a coercion *)
Definition convert := TH 0.

Module HOAS_Notations.

  Coercion hv : nat >-> hoas.
  Coercion ha : hoas >-> Funclass.
  Notation "'!!' s" := (hter s) (at level 0).

  Notation "[ 'L_HOAS' p ]" := (convert p) (at level 0, format  "[ 'L_HOAS'  p ]").

  Notation "'λ' x .. y , p" := (hl (fun x => .. (hl (fun y => p)) ..))
    (at level 100, x binder, right associativity,
     format "'[' 'λ'  '/  ' x  ..  y ,  '/  ' p ']'").

End HOAS_Notations.

(* Use Eval simpl in (term) when defining an term using convert.
This converts while defining and therefore makes all later steps faster.
See "important terms" below

Also: remember to give the type of combinators explicitly becuase we want to use the coercion!
(e.g. "Definition R:term := ..." )*)

Arguments convert /.

(* Important terms *)

(* Import L_Notations. *)
Import HOAS_Notations.

Definition r := Eval simpl in [L_HOAS λ r f, f (λ x , r r f x) ].
Definition R := app r r.
Definition rho (s : term)  := Eval simpl in [L_HOAS λ x, !!r !!r !!s x].

Definition I := Eval simpl in [L_HOAS λ x, x].
Definition K := Eval simpl in [L_HOAS λ x y, x].

Definition omega : term := Eval simpl in [L_HOAS λ x , x x].
Definition Omega : term := app omega omega.

(*  Substitution *)

(* Important definitions *)

Definition closed s := forall n u, subst s n u = s.

Definition lambda s := exists t, s = lam t.

Definition proc s := closed s /\ lambda s.

Lemma lambda_lam s : lambda (lam s).
Proof.
  exists s; reflexivity.
Qed.

#[export] Hint Resolve lambda_lam : core.

Instance lambda_dec s : dec (lambda s).
Proof.
  destruct s;[right;intros C;inv C;congruence..|left;eexists;eauto].
Defined. (* because instance *)

(* Size of terms *)

Fixpoint size (t : term) :=
  match t with
  | var n => 1 + n
  | app s t => 1+ size s + size t
  | lam s => 1 + size s
  end.

Fixpoint size' (t : term) :=
  match t with
  | var n => 0
  | app s t => 1+ size' s + size' t
  | lam s => 1 + size' s
  end.

(* Alternative definition of closedness *)

Inductive bound : nat -> term -> Prop :=
  | dclvar k n : k > n -> bound k (var n)
  | dclApp k s t : bound k s -> bound k t -> bound k (app s t)
  | dcllam k s : bound (S k) s -> bound k (lam s).

Lemma bound_closed_k s k u : bound k s -> subst s k u = s.
Proof with eauto.
  intros H; revert u; induction H; intros u; simpl.
  - destruct (Nat.eqb_spec n k)... lia.
  - rewrite IHbound1, IHbound2...
  - f_equal...
Qed.

Lemma bound_ge k s : bound k s -> forall m, m >= k -> bound m s.
Proof.
  induction 1; intros m Hmk; econstructor; eauto.
  - lia.
  - eapply IHbound. lia.
Qed.

Lemma bound_gt k s : bound k s -> forall m, m > k -> bound m s.
Proof.
  intros. apply (bound_ge H). lia.
Qed.

Lemma bound_closed s k u : bound 0 s -> subst s k u = s.
Proof.
  intros H. destruct k.
  - eapply bound_closed_k. eassumption.
  - eapply bound_gt in H. eapply bound_closed_k. eassumption. lia.
Qed.

Lemma closed_k_bound k s : (forall n u, n >= k -> subst s n u = s) -> bound k s.
Proof.
  revert k. induction s; intros k H.
  - econstructor. specialize (H n (#(S n))). simpl in H.
    decide (n >= k) as [Heq | Heq].
    + destruct (Nat.eqb_spec n n); [injection (H Heq)|]; lia.
    + lia.
  - econstructor; [eapply IHs1 | eapply IHs2]; intros n u Hnk;
    injection (H n u Hnk); congruence.
  - econstructor. eapply IHs. intros n u Hnk.
    destruct n. lia.
    injection (H n u). tauto. lia.
Qed.

Lemma closed_dcl s : closed s <-> bound 0 s.
Proof.
  split.
  -eauto using closed_k_bound.
  -unfold closed. eauto using bound_closed.
Qed.

Lemma closed_app (s t : term) : closed (app s t) -> closed s /\ closed t.
Proof.
  intros cls. rewrite closed_dcl in cls. inv cls. split; rewrite closed_dcl; eassumption.
Qed.

Lemma app_closed (s t : term) : closed s -> closed t -> closed (app s t).
Proof.
  intros H H' k u. simpl. now rewrite H, H'.
Qed.

Instance bound_dec k s : dec (bound k s).
Proof with try ((left; econstructor; try lia; tauto) || (right; inversion 1; try lia; tauto)).
  revert k; induction s; intros k.
  - destruct (le_lt_dec n k) as [Hl | Hl]... destruct (le_lt_eq_dec _ _ Hl)...
  - destruct (IHs1 k), (IHs2 k)...
  - induction k.
    + destruct (IHs 1)...
    + destruct (IHs (S (S k)))...
Defined. (* because instance *)

Instance closed_dec s : dec (closed s).
Proof.
  decide (bound 0 s);[left|right];now rewrite closed_dcl.
Defined. (* because instance *)

(* ** Reduction *)

Reserved Notation "s '≻' t" (at level 50).

Inductive step : term -> term -> Prop :=
| stepApp  s t     : app (lam s) (lam t) ≻ subst s 0 (lam t)
| stepAppR s t  t' : t ≻ t' -> app s t ≻ app s t'
| stepAppL s s' t  : s ≻ s' -> app s t ≻ app s' t
where "s '≻' t" := (step s t).

#[export] Hint Constructors step : core.

Ltac inv_step :=
  match goal with
    | H : step (lam _) _ |- _ => inv H
    | H : step (var _) _ |- _ => inv H
    | H : star step (lam _) _ |- _ => inv H
    | H : star step (var _) _ |- _ => inv H
  end.

Lemma closed_subst s t k : bound (S k) s -> bound k t -> bound k (subst s k t).
Proof.
  revert k t; induction s; intros k t cls_s cls_t; simpl; inv cls_s; eauto 6 using bound, bound_gt.
  destruct (Nat.eqb_spec n k); eauto. econstructor.  lia.
Qed.

Lemma closed_step s t : s ≻ t -> closed s -> closed t.
Proof.
  rewrite !closed_dcl; induction 1; intros cls_s; inv cls_s; eauto using bound.
  inv H2. eauto using closed_subst.
Qed.

Lemma comb_proc_red s : closed s -> proc s \/ exists t, s ≻ t.
Proof with try tauto.
  intros cls_s. induction s.
  - eapply closed_dcl in cls_s. inv cls_s. lia.
  - eapply closed_app in cls_s. destruct IHs1 as [[C [t A]] | A], IHs2 as [[D [t' B]] | B]...
    + right. subst. eexists. eauto.
    + right; subst. firstorder; eexists. eapply stepAppR. eassumption.
    + right; subst. firstorder; eexists. eapply stepAppL. eassumption.
    + right. subst. firstorder. eexists. eapply stepAppR. eassumption.
  - left. split. eassumption. firstorder.
Qed.

Goal forall s, closed s -> ((~ exists t, s ≻ t) <-> proc s).
Proof.
  intros s cls_s. split.
  destruct (comb_proc_red cls_s).
  - eauto.
  - tauto.
  - destruct 1 as [? [? ?]]. subst. destruct 1 as [? B]. inv B.
Qed.

(* Properties of the reduction relation *)

Theorem uniform_confluence : uniform_confluent step.
Proof with repeat inv_step; eauto using step.
  intros s; induction s; intros t1 t2 step_s_t1 step_s_t2; try now inv step_s_t2.
  inv step_s_t1.
  - inv step_s_t2; try eauto; inv_step.
  - inv step_s_t2...
    + destruct (IHs2 _ _ H2 H3).
      * left. congruence.
      * right. destruct H as [u [A B]]...
    + right...
  - inv step_s_t2...
    + right...
    + destruct (IHs1 _ _ H2 H3).
      * left. congruence.
      * right. destruct H as [u [A B]]...
Qed.

Notation "s '>(' l ')' t" := (pow step l s t) (at level 50, format "s  '>(' l ')'  t").
Arguments pow: simpl never.

Lemma confluence : confluent step.
Proof.
  intros x y z x_to_y x_to_z.
  eapply star_pow in x_to_y. destruct x_to_y as [n x_to_y].
  eapply star_pow in x_to_z. destruct x_to_z as [m x_to_z].
  destruct (parametrized_confluence uniform_confluence x_to_y x_to_z) as
      [k [l [u [_ [_ [C [D _]]]]]]].
  exists u. split; eapply star_pow; eexists; eassumption.
Qed.

Lemma step_Lproc s v :
  lambda v -> app (lam s) v ≻ subst s 0 v.
Proof.
  intros [t lamv].
  rewrite lamv.
  repeat econstructor.
Qed.

Lemma lam_terminal u: lambda u -> terminal step u.
Proof.
  intros H ? R;inv H;inv R.
Qed.

(* Properties of the reflexive, transitive closure of reduction *)

Notation "s '>*' t" := (star step s t) (at level 50).

Instance star_PreOrder : PreOrder (star step).
Proof.
  constructor; hnf.
  - eapply starR.
  - eapply star_trans.
Qed.

Lemma step_star s s':
  s ≻ s' -> s >* s'.
Proof.
  eauto using star.
Qed.

Instance step_star_subrelation : subrelation step (star step).
Proof.
  cbv. apply step_star.
Qed.

Lemma star_trans_l s s' t :
  s >* s' -> app s t >* app s' t.
Proof.
  induction 1; eauto using star, step.
Qed.

Lemma star_trans_r (s s' t:term):
  s >* s' -> app t s >* app t s'.
Proof.
  induction 1; eauto using star, step.
Qed.

Instance star_step_app_proper :
  Proper ((star step) ==> (star step) ==> (star step)) app.
Proof.
  cbv. intros s s' A t t' B.
  etransitivity. apply (star_trans_l _ A). now apply star_trans_r.
Qed.

Lemma closed_star s t: s >* t -> closed s -> closed t.
Proof.
  intros R. induction R;eauto using closed_step.
Qed.

Instance star_closed_proper :
  Proper ((star step) ==> Basics.impl) closed.
Proof.
  exact closed_star.
Qed.

(*  Properties of star: *)

Instance pow_step_congL k:
  Proper ((pow step k) ==> eq ==> (pow step k)) app.
Proof.
  intros s t R u ? <-. revert s t R u.
  induction k;cbn in *;intros ? ? R ?. congruence. destruct R as [s' [R1 R2]].
  exists (app s' u). firstorder.
Qed.

Instance pow_step_congR k:
  Proper (eq ==>(pow step k) ==> (pow step k)) app.
Proof.
  intros s ? <- t u R. revert s t u R.
  induction k;cbn in *;intros ? ? ? R. congruence. destruct R as [t' [R1 R2]].
  exists (app s t'). firstorder.
Qed.

(* Equivalence *)

Reserved Notation "s '==' t" (at level 50).

Inductive equiv : term -> term -> Prop :=
  | eqStep s t : step s t -> s == t
  | eqRef s : s == s
  | eqSym s t : t == s -> s == t
  | eqTrans s t u: s == t -> t == u -> s == u
where "s '==' t" := (equiv s t).

#[export] Hint Immediate eqRef : core.

(* Properties of the equivalence relation *)

Instance equiv_Equivalence : Equivalence equiv.
Proof.
  constructor; hnf.
  - apply eqRef.
  - intros. eapply eqSym. eassumption.
  - apply eqTrans.
Qed.

Lemma equiv_ecl s t : s == t <-> ecl step s t.
Proof with eauto using ecl, equiv.
  split; induction 1...
  - eapply ecl_sym...
  - eapply ecl_trans...
Qed.

Lemma church_rosser s t : s == t -> exists u, s >* u /\ t >* u.
Proof.
  rewrite equiv_ecl. eapply confluent_CR, confluence.
Qed.

Lemma star_equiv s t :
  s >* t -> s == t.
Proof.
  induction 1.
  - reflexivity.
  - eapply eqTrans. econstructor; eassumption. eassumption.
Qed.
#[export] Hint Resolve star_equiv : core.

Instance star_equiv_subrelation : subrelation (star step) equiv.
Proof.
  cbv. apply star_equiv.
Qed.

Instance step_equiv_subrelation : subrelation step equiv.
Proof.
  cbv. intros ? ? H. apply star_equiv, step_star. assumption.
Qed.

Lemma equiv_lambda s t : lambda t -> s == t -> s >* t.
Proof.
  intros H eq. destruct (church_rosser eq) as [u [A B]]. inv B. assumption. inv H. inv H0.
Qed.

Lemma eqStarT s t u : s >* t -> t == u -> s == u.
Proof.
  eauto using equiv.
Qed.

Lemma eqApp s s' u u' : s == s' -> u == u' -> app s u == app s' u'.
Proof with eauto using equiv, step.
  intros H; revert u u'; induction H; intros z z' H'...
  - eapply eqTrans. eapply eqStep. eapply stepAppL. eassumption.
    induction H'...
  - induction H'...
Qed.

Instance equiv_app_proper :
  Proper (equiv ==> equiv ==> equiv) app.
Proof.
  cbv. intros s s' A t t' B.
  eapply eqApp; eassumption.
Qed.

(* Definition of convergence *)

Definition converges s := exists t, s == t /\ lambda t.

Lemma converges_equiv s t : s == t -> (converges s <-> converges t).
Proof.
  intros H; split; intros [u [A lu]]; exists u;split;try assumption; rewrite <- A.
  - symmetry. eassumption.
  - eassumption.
Qed.

Instance converges_proper :
  Proper (equiv ==> iff) converges.
Proof.
  intros s t H. now eapply converges_equiv.
Qed.
(*
Lemma eq_lam s t : lambda s -> lambda t -> lam s == lam t <-> s = t.
Proof.
  split.
  - intros H. eapply equiv_lambda in H; repeat inv_step; reflexivity.
  - intros []. reflexivity.
Qed.

Lemma unique_normal_forms' (s t t' : term) : s == lam t -> s == lam t' -> lam t = lam t'.
Proof.
  intros Ht Ht'. rewrite Ht in Ht'. eapply eq_lam in Ht'. congruence.
Qed.*)

Lemma unique_normal_forms (s t : term) : lambda s -> lambda t ->  s == t -> s = t.
Proof.
  intros ls lt. intros H. apply equiv_lambda in H;try assumption. inv ls. inv H. reflexivity. inv H0.
Qed.

(* Eta expansion *)

Lemma Eta (s : term ) t : closed s -> lambda t -> app (lam (app s #0)) t == app s t.
Proof.
  intros cls_s lam_t. eapply star_equiv, starC; eauto using step_Lproc. simpl. rewrite cls_s. reflexivity.
Qed.

(* Useful lemmas *)

Lemma pow_trans s t u i j: pow step i s t -> pow step j t u -> pow step (i+j) s u.
Proof.
  intros. subst. apply pow_add. now exists t.
Qed.

Instance pow_star_subrelation i: subrelation (pow step i) (star step).
Proof.
  intros ? ? ?.
  eapply pow_star;eauto.
Qed.

(* Definition of evaluation *)

Definition eval s t := s >* t /\ lambda t.
Notation "s '⇓' t" := (eval s t) (at level 51).
#[export] Hint Unfold eval : core.

Lemma eval_unique s v1 v2 :
  s ⇓ v1 -> s ⇓ v2 -> v1 = v2.
Proof.
  intros (R1&L1) (R2&L2).
  eapply unique_normal_forms.
  1-2:eassumption.
  now rewrite <-R1,R2.
Qed.

Instance eval_star_subrelation : subrelation eval (star step).
Proof.
  now intros ? ? [].
Qed.

Instance reduce_eval_proper : Proper (Basics.flip (star step) ==> eq ==> Basics.impl) eval.
Proof.
  repeat intro. subst. unfold Basics.flip in H. destruct H1. split. etransitivity. eassumption. assumption. assumption.
Qed.

Instance equiv_eval_proper: Proper (equiv ==> eq ==> Basics.impl) eval.
Proof.
  repeat intro;subst. destruct H1. split;try auto. apply equiv_lambda. auto. now rewrite <- H0, H.
Qed.

Definition evalIn i s t := s >(i) t /\ lambda t.

Notation "s '⇓(' l ')' t" := (evalIn l s t) (at level 50, format "s  '⇓(' l ')'  t").

Definition redLe l s t := exists i , i <= l /\ pow step i s t.
Notation "s '>(<=' l ')' t" := (redLe l s t) (at level 50, format "s  '>(<=' l ')'  t").

Definition evalLe l s t := s >(<=l) t /\ lambda t.
Notation "s '⇓(<=' l ')' t" := (evalLe l s t) (at level 50, format "s  '⇓(<=' l ')'  t").

Instance evalLe_eval_subrelation i: subrelation (evalLe i) eval.
Proof.
  intros ? ? [[? []] ?]. split. eapply pow_star_subrelation. all:eauto.
Qed.

Lemma evalLe_evalIn s t k:
  s ⇓(<=k) t -> exists k', k' <= k /\ s ⇓(k') t.
Proof.
  unfold evalLe,redLe,evalIn. firstorder.
Qed.

Lemma evalIn_evalLe s t k k':
  k' <= k -> s ⇓(k') t -> s ⇓(<=k) t.
Proof.
  unfold evalLe,redLe,evalIn. firstorder.
Qed.

Instance evalIn_evalLe_subrelation i: subrelation (evalIn i) (evalLe i).
Proof.
  intros s t (R & lt). split;[now exists i|trivial].
Qed.

Instance pow_redLe_subrelation i: subrelation (pow step i) (redLe i).
Proof.
  intros s t R. now exists i.
Qed.

Instance evalLe_redLe_subrelation i: subrelation (evalLe i) (redLe i).
Proof.
  now intros ? ? [].
Qed.

Instance evalIn_eval_subrelation i: subrelation (evalIn i) eval.
Proof.
  intros ? ? [?  ?]. split. eapply pow_star_subrelation. all:eauto.
Qed.

Instance redLe_star_subrelation i: subrelation (redLe i) (star step).
Proof.
  intros ? ? (j & leq & R). now rewrite R.
Qed.

Instance le_redLe_proper: Proper (le ==> eq ==> eq ==> Basics.impl) redLe.
Proof.
  intros ? ? ? ? ? -> ? ? -> (i&lt&R).
  exists i. split. lia. tauto.
Qed.

Lemma redLe_mono s t n n' :
  s >(<=n) t -> n <= n' -> s >(<=n') t.
Proof.
  intros ? <-. easy.
Qed.

Instance le_evalLe_proper: Proper (le ==> eq ==> eq ==> Basics.impl) evalLe.
Proof.
  intros ? ? H' ? ? -> ? ? -> [H p].
  split. 2:tauto. now rewrite <- H'.
Qed.

Lemma evalIn_mono s t n n' :
  s ⇓(<=n) t -> n <= n' -> s ⇓(<=n') t.
Proof.
  intros ? <-. easy.
Qed.

Lemma evalIn_trans s t u i j :
  s >(i) t -> t ⇓(j) u -> s ⇓(i+j) u.
Proof.
  intros R1 [R2 lam].
  split; eauto using pow_trans.
Qed.

Lemma redLe_trans s t u i j :
  s >(<=i) t -> t >(<=j) u -> s >(<=i+j) u.
Proof.
  intros [i' [? R1]] [j' [? R2]].
  exists (i'+j'). split. lia. apply pow_add. hnf; eauto.
Qed.

Lemma redLe_trans_eq s t u i j k :
  i+j=k ->  s >(<=i) t -> t >(<=j) u -> s >(<=k) u.
Proof.
  intros;subst;eauto using redLe_trans.
Qed.

Lemma evalLe_trans s t u i j :
  s >(<=i) t -> t ⇓(<=j) u -> s ⇓(<=i+j) u.
Proof.
  intros R1 [R2 lam].
  split; eauto using redLe_trans.
Qed.

Instance pow0_refl : Reflexive (pow step 0).
Proof.
  intro. reflexivity.
Qed.

Instance redLe_refl : Reflexive (redLe 0).
Proof.
  intro. eexists; split;reflexivity.
Qed.

Lemma evalIn_unique s k1 k2 v1 v2 :
  s ⇓(k1) v1 -> s ⇓(k2) v2 -> k1 = k2 /\ v1 = v2.
Proof.
  intros (R1&L1) (R2&L2).
  eapply uniform_confluence_parameterized_both_terminal.
  all:eauto using lam_terminal,uniform_confluence.
Qed.

Lemma eval_evalIn s t:
  eval s t -> exists k, evalIn k s t.
Proof.
  intros [(R&?)%star_pow ?]. unfold evalIn. eauto.
Qed.

(* Helpfull Lemmas*)

Lemma pow_trans_lam' t v s k j:
  lambda v -> pow step j t v -> pow step k t s  -> j>=k /\ pow step (j-k) s v.
Proof.
  intros lv A B.
  destruct (parametrized_confluence uniform_confluence A B)
     as [m' [l [u [m_le_Sk [l_le_n [C [D E]]]]]]].
  cut (m' = 0).
  -intros ->. split. lia. replace (j-k) with l by lia. hnf in C. subst v. tauto.
  -destruct m'; eauto. destruct C. destruct H. inv lv. inv H.
Qed.

Lemma evalLe_trans_rev t v s k j:
  evalLe j t v -> pow step k t s  -> j>=k /\ evalLe (j-k) s v.
Proof.
  intros [(i&lti&R) lv] B.
  edestruct (pow_trans_lam' lv R B). split. lia. split. 2:tauto. eexists;split. 2:eauto. lia.
Qed.

Lemma pow_trans_lam t v s k n :
  lambda v -> pow step n t v -> pow step (S k) t s  -> exists m, m < n /\ pow step m s v.
Proof.
  intros H1 H2 H3. edestruct (pow_trans_lam' H1 H2 H3) as (H'1&H'2). do 2 eexists. 2:eassumption. lia.
Qed.

Lemma powSk t t' s : t ≻ t' -> t' >* s -> exists k, pow step (S k) t s.
Proof.
  intros A B.
  eapply star_pow in B. destruct B as [n B]. exists n.
  unfold pow. simpl. econstructor. unfold pow in B. split; eassumption.
Qed.

(* Properties of rho *)

Lemma rho_dcls n s : bound (S n) s -> bound n (rho s).
Proof.
  unfold rho,r. intros H. repeat (apply dcllam || apply dclApp || apply dclvar);try assumption;try lia.
Qed.

Lemma closed_dcl_x x s: closed s -> bound x s.
Proof.
  intros. apply (@bound_ge 0). now apply closed_dcl. lia.
Qed.
Lemma rho_cls s : closed s -> closed (rho s).
Proof.
  intros. rewrite closed_dcl.  apply rho_dcls. now apply closed_dcl_x.
Qed.

Lemma rho_lambda s : lambda (rho s).
Proof.
  eexists. reflexivity.
Qed.

Lemma step_eval s t v :
  s ≻ t -> L.eval t v -> L.eval s v.
Proof.
  induction 1 in v |- *; intros He.
  - repeat econstructor; eauto.
  - inv He. econstructor; eauto.
  - inv He. econstructor; eauto.
Qed.

Lemma eval_iff s t :
  L.eval s t <-> s ⇓ t.
Proof.
  split.
  - induction 1.
    + split. reflexivity. eauto.
    + split.
      destruct IHeval2 as [IH1 [v' ->]].
      2:eapply IHeval3.
      rewrite IHeval1, IH1.
      econstructor. 2:eapply IHeval3.
      econstructor.
  - intros [H1 [v ->]].
    revert H1. revert s.
    eapply (star_simpl_ind (y := lam v)).
    + econstructor.
    + intros s s' H1 H2 IH.
      eapply step_eval; eauto.
Qed.


(* File reduced by coq-bug-finder from original input, then from 1829 lines to 37 lines, then from 47 lines to 18 lines *)

Class Contr_internal (A : Type) :=
  BuildContr { center : A ;
               contr : (forall y : A, True) }.
Class Contr A := Contr_is_contr : Contr_internal A.
Inductive Unit : Set := tt.
Instance contr_unit : Contr Unit | 0 :=
  let x := {|
        center := tt;
        contr := fun t : Unit => I
      |} in x. (* success *)

Instance contr_internal_unit' : Contr_internal Unit | 0 :=
  {|
    center := tt;
    contr := fun t : Unit => I
  |}.

Instance contr_unit' : Contr Unit | 0 :=
  {|
    center := tt;
    contr := fun t : Unit => I
  |}.
(* Error: Mismatched contexts while declaring instance:
 Expected: (Contr_is_contr : Contr_internal _UNBOUND_REL_1)
 Found:   tt  (fun t : Unit => I) *)


(** * Main proofs for the program reduction over programs of [cWhile]. *)
Require Export syntax sos reductions hoare.
Require Export Classes.RelationClasses.

(** Basic properties on reductions over the [skip] command. *)

Section BasicPropertiesForSkip.

  Lemma starn_skip_skip :
    forall n R s c' y,
      starn (stmt * st) (prog_red R) n (skip, s) (c', y) ->
      c' = skip.
  Proof.
    induction n;intros.
    inv H.
    inv H.
    destruct2 y0 H1.
    inv H0.
    destruct H0;simpl in *.
    symmetry in H0;subst.
    apply IHn in H2.
    assumption.
  Qed.

  Lemma star_skip_skip:
    forall R s c' y,
      (skip,s) -(R)⋆-> (c',y) -> c' = skip.
  Proof.
    intros.
    do_star2starn H.
    eapply starn_skip_skip;eauto.
  Qed.

  Lemma star_skip_means_R_star :
    forall R s s',
      star _ (prog_red R) (skip,s) (skip,s') ->
      star _ R s s'.
  Proof.
    intros.
    dependent induction H.
    constructor.

    destruct2 y H.
    inv H.
    destruct H.
    simpl in *.
    symmetry in H;subst.
    constructor 2 with s1.
    assumption.
    apply IHstar;auto.
  Qed.

  Lemma starn_skip_inv :
    forall n x1,
      starn (stmt * st) (prog_red ID) n (skip, x1) (skip, x1).
  Proof.
    induction n;intros.
    constructor.
    constructor 2 with (skip,x1).
    right;unfold ID;split;auto.
    apply IHn.
  Qed.

  Lemma star_skip_inv :
    forall s,
      (skip,s) -(ID)⋆-> (skip,s).
  Proof.
    intros.
    constructor.
  Qed.

  Lemma reflexive_ID_eq :
    forall x y,
    star st ID x y -> x = y.
  Proof.
    induction 1;intros.
    reflexivity.
    red in H.
    subst.
    reflexivity.
  Qed.

  Lemma reflexive_assg_G_val :
    forall v a s0 s',
    star (stmt * st) (prog_red ID) (v ::= a, s0) (skip, s') ->
    s' = (s0) [v ← aeval s0 a].
  Proof.
    intros.
    dependent induction H.
    destruct2 y H.
    inv H.
    apply  star_skip_means_R_star in H0.
    apply reflexive_ID_eq in H0.
    symmetry;auto.
    destruct H.
    simpl in *.
    subst.
    apply IHstar.
    red in H1;subst.
    reflexivity.
    reflexivity.
  Qed.

  Lemma skip_false :
    forall x v a s',
      star (stmt * st) cstep (skip, (x) [v ← aeval x a]) (skip, s') ->
      s' = (x) [v ← aeval x a].
  Proof.
    intros.
    inv H.
    inv H0.
  Qed.

  Lemma star_and_l :
    forall Rl Rr s0 s',
      star st (rstAnd Rl Rr) s0 s' ->
      star (stmt * st) (prog_red Rl) (skip, s0) (skip, s').
  Proof.
    intros *.
    induction 1;auto.
    destruct H.
    constructor 2 with (skip,y).
    right;split;auto.
    assumption.
  Qed.

  Lemma star_and_r :
    forall Rl Rr s0 s',
      star st (rstAnd Rl Rr) s0 s' ->
      star (stmt * st) (prog_red Rr) (skip, s0) (skip, s').
  Proof.
    intros *.
    induction 1;auto.
    destruct H.
    constructor 2 with (skip,y).
    right;split;auto.
    assumption.
  Qed.

End BasicPropertiesForSkip.

(** Inversion lemmas for reductions over [ifb] conditionals. *)

Section IfInvLemmas.

  Lemma star_if_inv_true :
    forall R b c1 c2 s1 s2,
      stable R ([⊤]b) ->
      star _ (prog_red R) (ifb b then c1 else c2 fi,s1) (skip,s2) ->
      b2assrt b s1 ->
      star _ (prog_red R) (c1,s1) (skip,s2).
  Proof.
    intros.
    dependent induction H0.

    destruct2 y H2.
    inv H2.
    destruct H2.
    simpl in *.
    symmetry in H2.
    subst.
    constructor 2 with (c1,s0).
    right;split;auto.
    eapply IHstar;eauto.
    eapply H;eauto.
  Qed.

  Lemma star_if_inv_true_n :
    forall n R b c1 c2 s1 s2,
      stable R ([⊤]b) ->
      starn _ (prog_red R) n (ifb b then c1 else c2 fi,s1) (skip,s2) ->
      b2assrt b s1 ->
      exists m,
      starn _ (prog_red R) m (c1,s1) (skip,s2) /\ m <= n.
  Proof.
    induction n;intros.
    inv H0.

    inv H0.
    destruct2 y H3.
    inv H2.
    exists n;split;auto with arith.

    destruct H2.
    simpl in *.
    symmetry in H2.
    subst.
    assert(b2assrt b s0) by (eapply H;split;eauto).
    pose proof IHn _ _ _ _ _ _ H H4 H2.
    destruct H5.
    destruct H5.
    exists (S x).
    split;auto with arith.
    constructor 2 with (c1,s0);auto.
    right;split;auto.
  Qed.

  Lemma star_if_inv_false :
    forall R b c1 c2 s1 s2,
      stable R ([⊥]b) ->
      star _ (prog_red R) (ifb b then c1 else c2 fi,s1) (skip,s2) ->
      ~b2assrt b s1 ->
      star _ (prog_red R) (c2,s1) (skip,s2).
  Proof.
    intros.
    dependent induction H0.

    destruct2 y H2.
    inv H2.
    destruct H2.
    simpl in *.
    symmetry in H2.
    subst.
    constructor 2 with (c2,s0).
    right;split;auto.
    eapply IHstar;eauto.
    eapply H;eauto.
  Qed.

End  IfInvLemmas.

(** Lemmas for reductions over atomic execution of commands. *)

Section AtomicReduction.

  Lemma red_atomic_imp_skip :
    forall b c c' s s',
      (wait b do c end,s) ⇒ (c',s') ->
      c' = skip.
  Proof.
    intros.
    dependent induction H.
    reflexivity.
  Qed.

  Lemma star_id_implies_star_cstep :
    forall x s y,
      star _ (prog_red ID) (x,s) (skip,y) ->
      star _ (cstep) (x,s) (skip,y).
  Proof.
    induction 1.
    constructor.

    destruct H.
    constructor 2 with y0;auto.
    unfold interf in H.
    destruct H.
    rewrite (surjective_pairing x0) in H |- *.
    simpl in H.
    rewrite H.
    red in H1.
    rewrite H1.
    rewrite <- surjective_pairing.
    assumption.
  Qed.

  Lemma star_id_implies_star_cstep_gen :
    forall x s x' y,
      star _ (prog_red ID) (x,s) (x',y) ->
      star _ (cstep) (x,s) (x',y).
  Proof.
    induction 1.
    constructor.

    destruct H.
    constructor 2 with y0;auto.
    unfold interf in H.
    destruct H.
    rewrite (surjective_pairing x0) in H |- *.
    simpl in H.
    rewrite H.
    red in H1.
    rewrite H1.
    rewrite <- surjective_pairing.
    assumption.
  Qed.

  Lemma star_id_implies_star_cstep_inv :
    forall x s y,
      star _ (cstep) (x,s) (skip,y) ->
      star _ (prog_red ID) (x,s) (skip,y).
  Proof.
    induction 1.
    constructor.

    constructor 2 with y0;auto.
    left;auto.
  Qed.

  Lemma red_atomic_implies_cstep :
    forall b c c' s s',
      (wait b do c end,s) ⇒ (c',s') ->  star _ (prog_red ID) (c,s) (c',s').
  Proof.
    intros.
    dependent induction H.
    eapply star_id_implies_star_cstep_inv.
    assumption.
  Qed.

  Lemma star_does_atomic :
    forall R b x y s,
      b2assrt b s ->
      star _ (prog_red ID) (x,s) (skip,y) ->
      star _ (prog_red R) (wait b do x end,s) (skip,y).
  Proof.
    intros.
    dependent induction H0.
    constructor 2 with (skip,y);auto.
    left.
    constructor;auto.

    destruct2 y0 H1.
    econstructor 2 with (skip,y).
    left.
    econstructor.
    assumption.
    constructor 2 with (s0,s1).
    assumption.
    apply star_id_implies_star_cstep.
    assumption.
    auto.
    destruct H1.
    simpl in *;subst.
    red in H2.
    subst.
    apply IHstar;auto.
  Qed.

  Lemma star_does_atomic_inv :
    forall R b x y s,
      star _ (prog_red R) (wait b do x end,s) (skip,y) ->
      exists s' s'',
        star _ R s s' /\
        star _ (prog_red ID) (x,s') (skip,s'') /\
        star _ R s'' y.
  Proof.
    intros.
    dependent induction H.

    destruct2 y0 H.
    inv H.
    apply star_id_implies_star_cstep_inv in H7.
    exists s s1.
    split;auto.
    split;auto.
    apply star_skip_means_R_star in H0.
    assumption.

    destruct H.
    simpl in *.
    symmetry in H.
    subst.
    pose proof IHstar b _ _ _ refl_equal refl_equal.
    destruct H.
    destruct H.
    destruct H.
    destruct H2.
    exists x0 x1.
    split;auto.
    constructor 2 with s1.
    assumption.
    assumption.
  Qed.

  Lemma atomic_implies_skip :
    forall R b c x c' y,
      star (stmt * st) (prog_red R) (wait b do c end, x) (c', y) ->
      (c' = wait b do c end) \/ c' = skip.
  Proof.
    intros.
    dependent induction H.
    left;auto.

    destruct2 y0 H.
    inv H.
    do_star2starn H0.
    apply starn_skip_skip in H0.
    right;auto.

    destruct H;simpl in *.
    symmetry in H.
    subst.
    eapply IHstar.
    reflexivity.
    reflexivity.
  Qed.

  Lemma atomic_atomic_implies_Rstar :
    forall R b c x y,
      star (stmt * st) (prog_red R) (wait b do c end, x) (wait b do c end, y) ->
      star _ R x y.
  Proof.
    intros.
    dependent induction H.
    constructor.

    destruct2 y0 H.
    inv H.
    do_star2starn H0.
    apply starn_skip_skip in H0.
    discriminate.
    destruct H.
    simpl in *.
    symmetry in H.
    subst.
    constructor 2 with s0.
    assumption.
    eapply IHstar;eauto.
  Qed.

End AtomicReduction.

(** Inversion lemmas for the sequencial composition of programs. *)

Section ProgramReductionSequence.

  Variables R G : Env.

  Lemma sequence_compose :
    forall cl s s',
      star _ (prog_red R) (cl,s) (skip,s') ->
      forall cr s'',
        star _ (prog_red R) (cr,s') (skip,s'') ->
        star _ (prog_red R) (cl;cr,s) (skip,s'').
  Proof.
    intros.
    dependent induction H.
    constructor 2 with (cr,s').
    left;auto.
    assumption.
    destruct2 y H.
    constructor 2 with (s0;cr,s1).
    left.
    constructor;auto.
    eapply IHstar;eauto.
    destruct H.
    simpl in *.
    subst.
    constructor 2 with (s0;cr,s1).
    right;split;auto.
    eapply IHstar;eauto.
  Qed.

  Lemma sequence_reduces_in_parts_3:
   forall R cl cr s t,
      star _ (prog_red R) (cl;cr,s) (skip,t) ->
      exists s',
        star _ (prog_red R) (cl,s) (skip,s') /\
             star _ (prog_red R) (cr,s') (skip,t).
  Proof.
    intros.
    dependent induction H.

    destruct2 y H.
    inv H.
    pose proof IHstar c1' cr s1 t refl_equal refl_equal.
    destruct H1 as [s' [H4 H5]].
    exists s'.
    split;auto.
    constructor 2 with (c1',s1).
    left;auto.
    apply H4.

    exists s1.
    split;auto.

    destruct H.
    simpl in *.
    symmetry in H.
    subst.
    pose proof IHstar cl cr s1 t refl_equal refl_equal.
    destruct H as [s' [H3 H4]].
    exists s'.
    split.
    constructor 2 with (cl,s1).
    right.
    split;auto.
    apply H3.
    apply H4.
  Qed.

  Lemma sequence_reduces_in_parts_sequential_n:
    forall n cl cr s t,
      starn _ (prog_red R) n (cl;cr,s) (skip,t) ->
      exists s',
        star _ (prog_red R) (cl,s) (skip,s') /\
             exists n1, starn _ (prog_red R) n1 (cr,s') (skip,t) /\ n1 <= n.
  Proof.
    induction n;intros.
    inv H.

    inv H.
    destruct2 y H1.
    inv H0.
    pose proof IHn _ _ _ _ H2.
    destruct H1.
    destruct H1.
    destruct H4.
    exists x.
    split.
    constructor 2 with (c1',s1).
    left;auto.
    assumption.
    exists x0.
    destruct H4.
    split;auto with arith.
    exists s1.
    split;auto.
    exists n.
    split;auto with arith.

    destruct H0.
    simpl in *.
    symmetry in H0.
    subst.
    pose proof IHn _ _ _ _ H2.
    destruct H0.
    destruct H0.
    destruct H3.
    destruct H3.
    exists x.
    split.
    constructor 2 with (cl,s1).
    right;split;auto.
    assumption.
    exists x0.
    split;auto with arith.
  Qed.

  Lemma sequence_reduces_skip :
    forall R b c c' x s',
      star (stmt * st) (prog_red R) (skip; while b do c end, x) (c', s') ->
      (c' = (skip;while b do c end))  \/
      star _ (prog_red R) (while b do c end,x) (c',s').
  Proof.
    intros.
    dependent induction H.
    left;auto.

    destruct2 y H.
    inv H.
    inv H2.
    right;auto.
    destruct H.
    simpl in *.
    symmetry in H.
    subst.
    pose proof IHstar b c c' s0 s' refl_equal refl_equal.
    destruct H;auto.
    right.
    constructor 2 with (while b do c end,s0).
    right;split;auto.
    assumption.
  Qed.

End ProgramReductionSequence.

Section CommandReasoningLemmas.

  Lemma rel_from_skipn :
    forall n R s s',
      starn _ (prog_red R) n (skip,s) (skip,s') ->
      starn _ R n s s'.
  Proof.
    induction n;intros.
    inv H.
    constructor.

    inv H.
    destruct2 y H1.
    inv H0.
    destruct H0;simpl in *;subst.
    constructor 2 with s1;auto.
  Qed.

  Lemma while_true_cond :
    forall R b c s s',
      b2assrt b s ->
      stable R ([⊤]b) ->
      star _ (prog_red R) (while b do c end,s) (skip,s') ->
      star _ (prog_red R) (c;while b do c end,s) (skip,s').
  Proof.
    intros.
    dependent induction H1.
    destruct y;destruct H2.
    simpl in *.
    inv H2.
    pose proof star_if_inv_true R b (c; while b do c end) skip s1 s' H0 H1 H.
    assumption.
    destruct H2.
    simpl in *.
    symmetry in H2;subst.
    constructor 2 with (c; while b do c end, s1).
    right.
    red.
    auto.
    apply IHstar;auto.
    eapply H0;eauto.
  Qed.

  Lemma while_true_cond_step :
    forall R b c s,
      b2assrt b s ->
      stable R ([⊤]b) ->
      star _ (prog_red R) (while b do c end,s) (c;while b do c end,s).
  Proof.
    intros.
    constructor 2 with ((ifb b then c;while b do c end else skip fi),s).
    left.
    constructor.
    constructor 2 with (c;while b do c end,s).
    left.
    constructor;auto.
    constructor.
  Qed.

  Lemma goes_by_star_same_command :
    forall R c s s',
      star _ R s s' ->
      star _ (prog_red R) (c,s) (c,s').
  Proof.
    intros.
    dependent induction H.
    constructor.
    econstructor 2 with (c,y).
    right.
    red.
    split.
    reflexivity.
    simpl.
    assumption.
    assumption.
  Qed.

  Lemma goes_by_star_same_rel :
    forall R c c' s s',
      star _ (prog_red R) (c,s) (c',s') ->
      forall s'', star _ R s' s'' ->
      star _ (prog_red R) (c,s) (c',s'').
  Proof.
    intros.
    dependent induction H0.
    assumption.
    apply IHstar.
    eapply star_trans.
    apply H.
    econstructor 2 with (c',y).
    right.
    red.
    split.
    reflexivity.
    simpl.
    assumption.
    constructor.
  Qed.

  Lemma while_true_cond_weak :
    forall R b c s s',
      b2assrt b s ->
      stable R ([⊤]b) ->
      star _ (prog_red R) (while b do c end,s) (skip,s') ->
      exists s'',
        star _ R s s'' /\
        star _ (prog_red R) (ifb b then c;while b do c end else skip fi ,s'') (skip,s').
  Proof.
    intros.
    dependent induction H1.
    destruct y;destruct H2.
    simpl in *.
    inv H2.
    exists s1.
    split;auto.

    destruct H2.
    simpl in *.
    symmetry in H2.
    subst.
    assert(b2assrt b s1).
    eapply H0;eauto.
    pose proof IHstar s' s1 c b H2 H0 refl_equal refl_equal.
    destruct H4.
    destruct H4.
    exists x.
    split.
    constructor 2 with s1.
    assumption.
    assumption.
    assumption.
  Qed.

  Lemma while_false_cond :
    forall R b c s s',
      ~b2assrt b s ->
      stable R ([⊤]b) ->
      stable R ([⊥]b) ->
      star _ (prog_red R) (while b do c end,s) (skip,s') ->
      star _ (prog_red R) (skip,s) (skip,s').
  Proof.
    intros.
    dependent induction H2.
    destruct y;destruct H3.
    simpl in *.
    inv H3.
    pose proof star_if_inv_false R b (c; while b do c end) skip s1 s' H1 H2 H.
    assumption.
    destruct H3.
    simpl in *.
    symmetry in H3;subst.
    constructor 2 with (skip, s1).
    right.
    red.
    auto.
    eapply IHstar;eauto.
    intro.
    eapply H1.
    split;eauto.
    assumption.
  Qed.

  Lemma while_split :
    forall R b c s s',
      star _ (prog_red R) (while b do c end,s) (skip,s') ->
      exists s'',exists c',
        star _ (prog_red R) (while b do c end,s) (c',s'') /\
        star _ (prog_red R) (c',s'') (skip,s').
  Proof.
    intros.
    dependent induction H.
    destruct y;destruct H.
    inv H.
    exists s1 (ifb b then c; while b do c end else skip fi).
    split;auto.
    econstructor.
    left.
    apply H.
    constructor.
    destruct H.
    simpl in *.
    symmetry in H.
    subst.
    pose proof IHstar b c s1 s' refl_equal refl_equal.
    destruct H as [s'' [c'' [H2 H3]]].
    exists s'' c''.
    split;auto.
    econstructor 2 with (while b do c end,s1).
    right.
    red.
    simpl.
    split;auto.
    assumption.
  Qed.

  Lemma hoare_while_aux :
    forall R (G:StR) (P:assrt) c b,
      (forall x, G x x) ->
      stable R ([⊤]b) ->
      stable R ([⊥]b) ->
      stable R P ->
      HG_val R G (assrtT b[∧]P) c P ->
      forall s, P s ->
      (forall s', star _ (prog_red R) (while b do c end, s) (skip,s') ->
             forall p p',
             star _ (prog_red R) p p' ->
             fst p  = (while b do c end) ->
             fst p' = skip ->
             P (snd p) ->  (([⊥]b)[∧]P) (snd p')).
  Proof.
    intros until p.
    intros p' Hr.
    pattern p, p'.
    eapply RT_ind_gen;eauto.

    intros.
    rewrite H6 in H7;discriminate.

    intros.
    destruct x as (x,m1).
    destruct y as (y,m2).
    destruct z as (z,m3).
    simpl in *.
    subst.
    destruct H6.
    inv H6.
    inv H7.
    destruct H9.
    inv H9.
    pose proof rel_from_skipn _ _ _ _ H10.
    pose proof stable_star _ _ H2.
    pose proof stable_star _ _ H1.
    split.
    eapply H14;split;eauto.
    eapply starn2star with n0;auto.
    eapply H13.
    split;eauto.
    eapply starn2star with n0;auto.
    cut(exists t, star _ (prog_red R) (c,m2) (skip,t) /\
                       exists m, starn _ (prog_red R) m (while b do c end,t) (skip,m3)
                                       /\ m <= (S n0)).
    intros.
    destruct H12.
    destruct H12.
    destruct H13.
    destruct H13.
    assert((([⊤]b)[∧]P) m2).
    split;auto.
    pose proof H3 _ H15.
    destruct H16.
    eapply H8.
    apply H14.
    apply H13.
    auto.
    auto.
    simpl.
    apply H16.
    assumption.

    pose proof sequence_reduces_in_parts_sequential_n _ _ _ _ _ _ H10.
    destruct H12.
    exists x.
    destruct H12.
    split;auto.
    destruct H13.
    exists x0.
    destruct H13;auto.

    destruct2 y H9.
    simpl in *.
    symmetry in H9.
    subst.
    destruct(b2assrt_dec b s1).
    pose proof H10.
    do_starn2star H10.

    pose proof star_if_inv_true_n _ _ _ _ _ _ _ H0 H9 b0.
    destruct H10.
    destruct H10.
    cut(exists t, star _ (prog_red R) (c,s1) (skip,t) /\
                   exists m, starn _ (prog_red R) m (while b do c end,t) (skip,m3)
                                       /\ m <= (S n0)).
    intro.
    destruct H15.
    destruct H15.
    destruct H16.
    destruct H16.
    eapply H8.
    apply H17.
    apply H16.
    reflexivity.
    reflexivity.
    simpl.
    assert(P s1).
    eapply H2;eauto.
    assert((([⊤]b)[∧]P) s1).
    split;auto.
    pose proof H3 _ H19.
    destruct H20.
    apply H20.
    apply H15.

    pose proof sequence_reduces_in_parts_sequential_n _ _ _ _ _ _ H10.
    destruct H15.
    destruct H15.
    destruct H16.
    destruct H16.
    exists x0.
    split;auto.
    exists x1.
    split;auto with arith.
    omega.

    pose proof H10.
    do_starn2star H9.
    pose proof star_if_inv_false _ _ _ _ _ _ H1 H13 n.
    do_star2starn H9.
    pose proof rel_from_skipn _ _ _ _ H9.
    pose proof stable_star _ _ H2.
    pose proof stable_star _ _ H1.
    split.
    eapply H16;split;eauto.
    eapply starn2star with n1;auto.
    eapply H15.
    split;eauto.
    eapply starn2star with (S n1);auto.
    constructor 2 with s1.
    assumption.
    assumption.

    destruct H6.
    simpl in *.
    symmetry in H6.
    subst.
    assert(n<=n) by auto with arith.
    pose proof H8 _ _ H6 H7 refl_equal refl_equal.
    apply H10.
    simpl.
    eapply H2.
    split;eauto.
  Qed.

  Lemma hoare_while :
    forall R (G:StR) (P:assrt) c b,
      (forall x, G x x) ->
      stable R ([⊤]b) ->
      stable R ([⊥]b) ->
      stable R P ->
      HG_val R G (assrtT b[∧]P) c P ->
      forall s, P s ->
      (forall s', star _ (prog_red R) (while b do c end, s) (skip,s') ->
                  (assrtF b[∧]P) s').
  Proof.
    intros.
    inv H5.
    destruct2 y H6.
    inv H6.
    pose proof hoare_while_aux R G P c b H H0 H1 H2 H3 _ H4 _ H5.
    specialize H8 with (while b do c end,s1) (skip,s').
    simpl in H8.
    eapply H8;auto.

    destruct H6.
    simpl in *.
    symmetry in H6.
    subst.
    pose proof hoare_while_aux R G P c b H H0 H1 H2 H3 _ H4 _ H5.
    specialize H6 with (while b do c end,s1) (skip,s').
    simpl in H6.
    apply H6;auto.
    eapply H2;split;eauto.
  Qed.

  (* (** The soundness lemma for the while loop construct for the sequential part of CWhile. *) *)

  Lemma hoare_while_aux_ID :
    forall (G:StR) (P:assrt) c b,
      G_val (assrtT b[∧]P) c G P ->
      forall s, P s ->
      (forall s', star _ (prog_red ID) (while b do c end, s) (skip,s') ->
             forall p p',
             star _ (prog_red ID) p p' ->
             fst p  = (while b do c end) ->
             fst p' = skip ->
             P (snd p) ->  (([⊥]b)[∧]P) (snd p') /\ star st G (snd p) (snd p')).
  Proof.
    intros until p.
    intros p' Hr.
    pattern p, p'.
    eapply RT_ind_gen;eauto.

    intros.
    rewrite H3 in H2;discriminate.

    intros.
    destruct x as (x,m1).
    destruct y as (y,m2).
    destruct z as (z,m3).
    simpl in *.
    subst.
    destruct H2.
    inv H2.
    inv H3.
    destruct H5.
    inv H5.
    assert(m2=m3).
    do_starn2star H6.
    apply star_skip_means_R_star in H8.
    apply reflexive_ID_eq in H8.
    assumption.

    rewrite <- H8.
    split;auto.
    split;auto.

    cut(exists t, star _ (prog_red ID) (c,m2) (skip,t) /\
                       exists m, starn _ (prog_red ID) m (while b do c end,t) (skip,m3)
                                       /\ m <= (S n0)).
    intros.
    destruct H8.
    destruct H8.
    destruct H9.
    destruct H9.
    assert((([⊤]b)[∧]P) m2).
    split;auto.
    pose proof H _ H11 _ H8.
    destruct H12.
    split.
    eapply H4.
    apply H10.
    apply H9.
    auto.
    auto.
    simpl.
    apply H12.
    pose proof H4 (while b do c end, x) _ H10 H9 refl_equal refl_equal H12.
    destruct H15.
    simpl in *.
    eapply star_trans;eauto.

    pose proof sequence_reduces_in_parts_sequential_n _ _ _ _ _ _ H6.
    destruct H8.
    exists x.
    destruct H8.
    split;auto.
    destruct H9.
    exists x0.
    destruct H9;auto.

    destruct2 y H5.
    simpl in *.
    symmetry in H5.
    subst.
    destruct(b2assrt_dec b s1).
    pose proof H6.
    do_starn2star H6.

    assert(stable ID ([⊤]b)).
    red.
    intros.
    destruct H6.
    red in H10.
    subst;auto.

    pose proof star_if_inv_true_n _ ID _ _ _ _ _ H6 H5 b0.
    destruct H10.
    destruct H10.
    cut(exists t, star _ (prog_red ID) (c,s1) (skip,t) /\
                   exists m, starn _ (prog_red ID) m (while b do c end,t) (skip,m3)
                                       /\ m <= (S n0)).
    intro.
    destruct H12.
    destruct H12.
    destruct H13.
    destruct H13.
    split.
    eapply H4.
    apply H14.
    apply H13.
    reflexivity.
    reflexivity.
    simpl.
    assert(P s1).
    red in H8;subst;auto.
    assert((([⊤]b)[∧]P) s1).
    split;auto.
    pose proof H _ H16 _ H12.
    destruct H17;auto.
    red in H.
    red in H8.
    rewrite H8 in H7.
    assert((([⊤]b)[∧]P) s1).
    split;auto.
    pose proof H _ H15 _ H12.
    destruct H16.

    pose proof H4 (while b do c end, x0) _ H14 H13 refl_equal refl_equal H16.
    destruct H18.
    simpl in H19.
    rewrite H8.
    eapply star_trans;eauto.

    pose proof sequence_reduces_in_parts_sequential_n _ _ _ _ _ _ H10.
    destruct H12.
    destruct H12.
    destruct H13.
    destruct H13.
    exists x0.
    split;auto.
    exists x1.
    split;auto with arith.
    omega.

    pose proof H6.
    do_starn2star H5.
    assert(stable ID ([⊥]b)).
    red.
    intros.
    destruct H5.
    red in H10;auto.
    subst;auto.
    pose proof star_if_inv_false _ _ _ _ _ _ H5 H9 n.
    do_star2starn H10.
    pose proof rel_from_skipn _ _ _ _ H10.
    assert(s1=m3).
    do_starn2star H11.
    apply reflexive_ID_eq in H12.
    assumption.
    split.
    split.
    rewrite <- H12;auto.
    rewrite <- H12.
    red in H8.
    rewrite H8 in H7;auto.
    rewrite <- H12.
    red in H8.
    rewrite H8.
    constructor.

    destruct H2.
    simpl in *.
    symmetry in H2.
    subst.
    assert(n<=n) by auto with arith.
    pose proof H4 _ _ H2 H3 refl_equal refl_equal.
    split.
    apply H6.
    simpl.
    red in H5.
    subst;auto.
    simpl in H6.
    red in H5.
    subst.
    apply H6 in H7.
    destruct H7;auto.
  Qed.

  Lemma hoare_while_ID :
    forall (G:StR) (P:assrt) c b,
      G_val (assrtT b[∧]P) c G P ->
      forall s, P s ->
      (forall s', star _ (prog_red ID) (while b do c end, s) (skip,s') ->
                  (assrtF b[∧]P) s' /\ star _ G s s').
  Proof.
    intros.
    inv H1.
    destruct2 y H2.
    inv H2.
    pose proof hoare_while_aux_ID G P c b H _ H0 _ H1.
    specialize H4 with (while b do c end,s1) (skip,s').
    simpl in H4.
    eapply H4;auto.

    destruct H2.
    simpl in *.
    symmetry in H2.
    subst.
    pose proof hoare_while_aux_ID G P c b H _ H0 _ H1.
    specialize H2 with (while b do c end,s1) (skip,s').
    simpl in H2.
    red in H4.
    subst.
    apply H2;auto.
  Qed.

  (** Basic [skip||skip] reduction *)

  Lemma par_skip_l_red_skip :
    forall n R cl s s',
      starn _ (prog_red R) n (cl,s) (skip,s') ->
      star _  (prog_red R) (par cl with skip end,s) (skip,s').
  Proof.
    induction n;intros.
    inv H.
    constructor 2 with (skip,s');auto.
    left.
    constructor.

    inv H.
    destruct y;destruct H1.
    constructor 2 with (par s0 with skip end,s1).
    left.
    constructor.
    assumption.
    eapply IHn.
    assumption.

    destruct H0;simpl in *;subst.
    constructor 2 with (par s0 with skip end, s1).
    right;split;auto.
    eapply IHn;auto.
  Qed.

  Lemma par_skip_r_red_skip :
    forall n R cr s s',
      starn _ (prog_red R) n (cr,s) (skip,s') ->
      star _  (prog_red R) (par skip with cr end,s) (skip,s').
  Proof.
    induction n;intros.
    inv H.
    constructor 2 with (skip,s');auto.
    left.
    constructor.

    inv H.
    destruct y;destruct H1.
    constructor 2 with (par skip with s0 end,s1).
    left.
    constructor.
    assumption.
    eapply IHn.
    assumption.

    destruct H0;simpl in *;subst.
    constructor 2 with (par skip with s0 end, s1).
    right;split;auto.
    eapply IHn;auto.
  Qed.

    Lemma par_skip_skip_red_skip :
    forall n R cl cl' cr s s',
      starn _ (prog_red R) n (cl,s) (cl',s') ->
      star _  (prog_red R) (par cl with cr end,s) (par cl' with cr end,s').
  Proof.
    induction n;intros.
    inv H.
    constructor.

    inv H.
    destruct y;destruct H1.
    constructor 2 with (par s0 with cr end, s1).
    left.
    constructor;auto.
    eapply IHn;auto.

    destruct H0.
    constructor 2 with (par cl with cr end,s1).
    right;split;auto.
    simpl in *;subst.
    eapply IHn;eauto.
  Qed.

  Lemma par_decompose_left :
    forall n R cl cl' s s',
      starn _ (prog_red R) n (cl,s) (cl',s') ->
      forall s'' cr cr', star _ (prog_red R) (par cl' with cr end,s')
                                             (par cl' with cr' end,s'') ->
      star _  (prog_red R) (par cl with cr end,s) (par cl' with cr' end,s'').
  Proof.
    induction n;intros.
    inv H.

    inv H.
    destruct y;destruct H2;simpl in *.
    constructor 2 with (par s0 with cr end,s1).
    left.
    constructor.
    assumption.
    eapply IHn;eauto.

    destruct H1;simpl in *;subst.
    constructor 2 with (par s0 with cr end,s1).
    right;split;auto.
    eapply IHn;eauto.
  Qed.

  Lemma par_decompose_right :
    forall n R cr cr' s s',
      starn _ (prog_red R) n (cr,s) (cr',s') ->
      forall s'' cl cl', star _ (prog_red R) (par cl with cr' end,s')
                                             (par cl' with cr' end,s'') ->
      star _  (prog_red R) (par cl with cr end,s) (par cl' with cr' end,s'').
  Proof.
    induction n;intros.
    inv H.

    inv H.
    destruct y;destruct H2;simpl in *.
    constructor 2 with (par cl with s0 end,s1).
    left.
    constructor.
    assumption.
    eapply IHn;eauto.

    destruct H1;simpl in *;subst.
    constructor 2 with (par cl with s0 end,s1).
    right;split;auto.
    eapply IHn;eauto.
  Qed.

End CommandReasoningLemmas.

 (** Naive tactic to destroy and name the parts of the term representing the
    conclusion of [HG_val] *)

Ltac simpl_HG K H :=
  let H1 := fresh "H" in
    pose proof (H _ K) as H1;
  let H2 := fresh "H" in
    let H3 := fresh "H" in
      destruct H1 as [H2 H3];
  let n := fresh "n" in
    let s := fresh "s" in
      let H4 := fresh "H" in
        let H5 := fresh "H" in
          destruct H2 as [n [s [H4 H5]]].


(* File: Le_Ks.v  (last edited on 27/10/2000) (c) Klaus Weich  *)

From IPC Require Export Rev_App.

(*****************************************************************)

Inductive le_ni : nested_imps -> nested_imps -> Prop :=
  | Le_NI_Nil : le_ni NNil NNil
  | Le_NI_Cons_NN :
      forall (x : nimp) (ni1 ni2 : nested_imps),
      le_ni ni1 ni2 -> le_ni (Undecorated x :: ni1) (Undecorated x :: ni2)
  | Le_NI_Cons_DN :
      forall (x : nimp) (k : kripke_tree) (ni1 ni2 : nested_imps),
      le_ni ni1 ni2 -> le_ni (Decorated x k :: ni1) (Undecorated x :: ni2)
  | Le_NI_Cons_DD :
      forall (x : nimp) (k : kripke_tree) (ni1 ni2 : nested_imps),
      le_ni ni1 ni2 -> le_ni (Decorated x k :: ni1) (Decorated x k :: ni2).

Lemma in_k_le :
 forall (ni1 ni2 : nested_imps) (x : nimp) (k : kripke_tree),
 le_ni ni1 ni2 -> In (Decorated x k) ni2 -> In (Decorated x k) ni1.
intros ni1 ni2 x k le12.
elim le12; clear le12 ni1 ni2.
intros; assumption.

intros x' ni1 ni2 le12 ih in_k.
right.
apply ih.
inversion_clear in_k.
 discriminate H.
assumption.

intros x' k' ni1 ni2 le12 ih in_k.
right.
apply ih.
inversion_clear in_k.
 discriminate H.
assumption.

intros x' k' ni1 ni2 le12 ih in_k.
inversion_clear in_k.
left; assumption.
right; apply ih; assumption.
Qed.

Lemma le_ni_refl : forall ni : nested_imps, le_ni ni ni.
intros ni; elim ni; clear ni.
apply Le_NI_Nil.
intros a; case a; clear a.
intros x N ih.
apply Le_NI_Cons_NN; assumption.
intros x k ni ih.
apply Le_NI_Cons_DD; assumption.
Qed.

Lemma le_ni_trans :
 forall ni1 ni2 ni3 : nested_imps,
 le_ni ni1 ni2 -> le_ni ni2 ni3 -> le_ni ni1 ni3.
intros ni1 ni2 ni3 le12.
generalize ni3; clear ni3.
elim le12; clear le12 ni1 ni2.
intros; assumption.
intros x ni1 ni2 le12 ih ni3 le23.
inversion_clear le23.
apply Le_NI_Cons_NN.
apply ih; assumption.
intros x k ni1 ni2 le12 ih ni3 le23.
inversion_clear le23.
apply Le_NI_Cons_DN.
apply ih; assumption.
intros x k ni1 ni2 le12 ih ni3 le23.
inversion_clear le23.
apply Le_NI_Cons_DN.
apply ih; assumption.
apply Le_NI_Cons_DD.
apply ih; assumption.
Qed.

(*****************************************************************)

Inductive filter_deco_spec (i : Int) (N : nested_imps) : Set :=
    Filter_Deco_Spec_Intro :
      forall ni1 : nested_imps,
      le_ni N ni1 ->
      (forall (x : nimp) (k : kripke_tree),
       In (Decorated x k) ni1 -> forces_t k (Atom i)) ->
      filter_deco_spec i N.

Lemma filter_deco :
 forall (i : Int) (ni : nested_imps), filter_deco_spec i ni.
intros i ni.
elim ni; clear ni.
fold NNil in |- *.
apply Filter_Deco_Spec_Intro with NNil.
apply Le_NI_Nil.
intros x k in_k.
inversion_clear in_k.

intros a; case a; clear a.
intros x ni ih.
elim ih; clear ih.
intros ni1 le1 forces_i.
apply Filter_Deco_Spec_Intro with (Undecorated x :: ni1).
apply Le_NI_Cons_NN; assumption.
intros x' k' in_k0.
apply forces_i with x'.
inversion_clear in_k0.
 discriminate H.
assumption.

intros x k ni ih.
elim ih; clear ih.
intros ni1 le1 forces_i.
case k; clear k.
intros Atms succs.
case Atms; clear Atms.
intros t avl_t.
elim (lookup_dec unit i t avl_t).
intros d; case d; clear d.
intros lookup.
apply
 Filter_Deco_Spec_Intro
  with (Decorated x (node atoms (AVL_intro unit t avl_t) succs) :: ni1).
apply Le_NI_Cons_DD; assumption.
intros x' k' in_k0.
inversion_clear in_k0.
 injection H; clear H; intros.
 rewrite <- H; assumption.
apply forces_i with x'; assumption.

intros notlookup.
apply Filter_Deco_Spec_Intro with (Undecorated x :: ni1).
apply Le_NI_Cons_DN; assumption.
simpl in |- *; intros x' k' in_k0.
inversion_clear in_k0.
 discriminate H.
apply forces_i with x'; assumption.
Qed.

(*****************************************************************)

Inductive eqv_ni : nested_imps -> nested_imps -> Prop :=
  | Eqv_NI_Nil : eqv_ni NNil NNil
  | Eqv_NI_Cons_NN :
      forall (x : nimp) (ni1 ni2 : nested_imps),
      eqv_ni ni1 ni2 -> eqv_ni (Undecorated x :: ni1) (Undecorated x :: ni2)
  | Eqv_NI_Cons_DN :
      forall (x : nimp) (k : kripke_tree) (ni1 ni2 : nested_imps),
      eqv_ni ni1 ni2 -> eqv_ni (Decorated x k :: ni1) (Undecorated x :: ni2)
  | Eqv_NI_Cons_DD :
      forall (x : nimp) (k k' : kripke_tree) (ni1 ni2 : nested_imps),
      eqv_ni ni1 ni2 -> eqv_ni (Decorated x k :: ni1) (Decorated x k' :: ni2)
  | Eqv_NI_Cons_ND :
      forall (x : nimp) (k : kripke_tree) (ni1 ni2 : nested_imps),
      eqv_ni ni1 ni2 -> eqv_ni (Undecorated x :: ni1) (Decorated x k :: ni2).

Lemma eqv_ni_trans :
 forall ni1 ni2 ni3 : nested_imps,
 eqv_ni ni1 ni2 -> eqv_ni ni2 ni3 -> eqv_ni ni1 ni3.
intros ni1 ni2 ni3 eqv12.
generalize ni3; clear ni3.
elim eqv12; clear eqv12 ni1 ni2.
intros; assumption.
intros x ni1 ni2 eqv12 ih ni3 eqv23.
inversion_clear eqv23.
apply Eqv_NI_Cons_NN.
apply ih; assumption.
apply Eqv_NI_Cons_ND.
apply ih; assumption.
intros x k ni1 ni2 eqv12 ih ni3 eqv23.
inversion_clear eqv23.
apply Eqv_NI_Cons_DN.
apply ih; assumption.
apply Eqv_NI_Cons_DD.
apply ih; assumption.
intros x k k' ni1 ni2 eqv12 ih ni3 eqv23.
inversion_clear eqv23.
apply Eqv_NI_Cons_DN.
apply ih; assumption.
apply Eqv_NI_Cons_DD.
apply ih; assumption.
intros x k ni1 ni2 eqv12 ih ni3 eqv23.
inversion_clear eqv23.
apply Eqv_NI_Cons_NN.
apply ih; assumption.
apply Eqv_NI_Cons_ND.
apply ih; assumption.
Qed.

Lemma le_eqv : forall ni1 ni2 : nested_imps, le_ni ni1 ni2 -> eqv_ni ni1 ni2.
intros ni1 ni2 le12; elim le12; clear le12 ni1 ni2.
apply Eqv_NI_Nil.
intros x ni1 ni2 le12 ih; apply Eqv_NI_Cons_NN; assumption.
intros x k ni1 ni2 le12 ih; apply Eqv_NI_Cons_DN; assumption.
intros x k ni1 ni2 le12 ih; apply Eqv_NI_Cons_DD; assumption.
Qed.

Lemma eqv_sym :
 forall ni1 ni2 : nested_imps, eqv_ni ni1 ni2 -> eqv_ni ni2 ni1.
intros ni1 ni2 eqv12; elim eqv12; clear eqv12 ni1 ni2.
apply Eqv_NI_Nil.
intros x ni1 ni2 eqv12 ih; apply Eqv_NI_Cons_NN; assumption.
intros x k ni1 ni2 eqv12 ih; apply Eqv_NI_Cons_ND; assumption.
intros x k k' ni1 ni2 eqv12 ih; apply Eqv_NI_Cons_DD; assumption.
intros x k ni1 ni2 eqv12 ih; apply Eqv_NI_Cons_DN; assumption.
Qed.

Lemma ge_eqv : forall ni1 ni2 : nested_imps, le_ni ni2 ni1 -> eqv_ni ni1 ni2.
intros ni1 ni2 le21.
apply eqv_sym.
apply le_eqv; assumption.
Qed.

(*****************************************************************)

Lemma eqv_ni_rec :
 forall P : nested_imps -> nested_imps -> Set,
 P NNil NNil ->
 (forall (x : nimp) (ni1 ni2 : nested_imps),
  eqv_ni ni1 ni2 ->
  P ni1 ni2 -> P (Undecorated x :: ni1) (Undecorated x :: ni2)) ->
 (forall (x : nimp) (k : kripke_tree) (ni1 ni2 : nested_imps),
  eqv_ni ni1 ni2 ->
  P ni1 ni2 -> P (Decorated x k :: ni1) (Undecorated x :: ni2)) ->
 (forall (x : nimp) (k k' : kripke_tree) (ni1 ni2 : nested_imps),
  eqv_ni ni1 ni2 ->
  P ni1 ni2 -> P (Decorated x k :: ni1) (Decorated x k' :: ni2)) ->
 (forall (x : nimp) (k : kripke_tree) (ni1 ni2 : nested_imps),
  eqv_ni ni1 ni2 ->
  P ni1 ni2 -> P (Undecorated x :: ni1) (Decorated x k :: ni2)) ->
 forall ni1 ni2 : nested_imps, eqv_ni ni1 ni2 -> P ni1 ni2.
intros P base step_nn step_rn step_rr step_nr ni1.
elim ni1; clear ni1.
intros ni2; case ni2; clear ni2.
intros; apply base.
intros a ni2 eqv; elimtype False; inversion_clear eqv.

intros a; case a; clear a.
intros x ni1 ih ni2.
case ni2; clear ni2.
intros eqv; elimtype False; inversion_clear eqv.
intros a; case a; clear a.
intros x' ni2 eqv.
cut (x = x').
intro eq_x;  rewrite eq_x; clear eq_x.
apply step_nn.
inversion_clear eqv; assumption.
apply ih.
inversion_clear eqv; assumption.
inversion_clear eqv; trivial.
intros x' k' ni2 eqv.
cut (x = x').
intro eq_x;  rewrite eq_x; clear eq_x.
apply step_nr.
inversion_clear eqv; assumption.
apply ih.
inversion_clear eqv; assumption.
inversion_clear eqv; trivial.

intros x k ni1 ih ni2.
case ni2; clear ni2.
intros eqv; elimtype False; inversion_clear eqv.
intros a; case a; clear a.
intros x' ni2 eqv.
cut (x = x').
intro eq_x;  rewrite eq_x; clear eq_x.
apply step_rn.
inversion_clear eqv; assumption.
apply ih.
inversion_clear eqv; assumption.
inversion_clear eqv; trivial.
intros x' k' ni2 eqv.
cut (x = x').
intro eq_x;  rewrite eq_x; clear eq_x.
apply step_rr.
inversion_clear eqv; assumption.
apply ih.
inversion_clear eqv; assumption.
inversion_clear eqv; trivial.
Qed.

(*****************************************************************)

Inductive inf_deco_spec (ni1 ni2 : nested_imps) : Set :=
    Inf_Deco_Spec_Intro :
      forall ni : nested_imps,
      le_ni ni ni1 ->
      eqv_ni ni ni2 ->
      (forall (x : nimp) (k : kripke_tree),
       In (Decorated x k) ni ->
       In (Decorated x k) ni1 \/ In (Decorated x k) ni2) ->
      inf_deco_spec ni1 ni2.

Lemma inf_deco :
 forall ni1 ni2 : nested_imps, eqv_ni ni1 ni2 -> inf_deco_spec ni1 ni2.
intros ni1 ni2 eqv12.
elim eqv12; clear eqv12 ni1 ni2.
apply Inf_Deco_Spec_Intro with NNil.
apply Le_NI_Nil.
apply Eqv_NI_Nil.
intros; left; assumption.

intros x ni1 ni2 eqv12 ih.
elim ih; clear ih.
intros ni le eqv inf.
apply Inf_Deco_Spec_Intro with (Undecorated x :: ni).
apply Le_NI_Cons_NN; assumption.
apply Eqv_NI_Cons_NN; assumption.
intros x' k' in_k0.
inversion_clear in_k0.
left; left; assumption.
elim (inf x' k' H); clear inf H.
intros in_ni1; left; right; assumption.
intros in_ni2; right; right; assumption.

intros x k ni1 ni2 eqv12 ih.
elim ih; clear ih.
intros ni le eqv inf.
apply Inf_Deco_Spec_Intro with (Decorated x k :: ni).
apply Le_NI_Cons_DD; assumption.
apply Eqv_NI_Cons_DN; assumption.
intros x' k' in_k0.
inversion_clear in_k0.
left; left; assumption.
elim (inf x' k' H); clear inf H.
intros in_ni1; left; right; assumption.
intros in_ni2; right; right; assumption.

intros x k k' ni1 ni2 eqv12 ih.
elim ih; clear ih.
intros ni le eqv inf.
apply Inf_Deco_Spec_Intro with (Decorated x k :: ni).
apply Le_NI_Cons_DD; assumption.
apply Eqv_NI_Cons_DD; assumption.
intros x0 k0 in_k0.
inversion_clear in_k0.
left; left; assumption.
elim (inf x0 k0 H); clear inf H.
intros in_ni1; left; right; assumption.
intros in_ni2; right; right; assumption.

intros x k ni1 ni2 eqv12 ih.
elim ih; clear ih.
intros ni le eqv inf.
apply Inf_Deco_Spec_Intro with (Decorated x k :: ni).
apply Le_NI_Cons_DN; assumption.
apply Eqv_NI_Cons_DD; assumption.
intros x0 k0 in_k0.
inversion_clear in_k0.
right; left; assumption.
elim (inf x0 k0 H); clear inf H.
intros in_ni1; left; right; assumption.
intros in_ni2; right; right; assumption.
Qed.

(************************************************************************)

Remark eqv_nimps_eq :
 forall ni1 ni2 : nested_imps,
 eqv_ni ni1 ni2 -> nested_imps2nimps ni1 = nested_imps2nimps ni2.
intros ni1 ni2 eqv.
elim eqv; clear eqv ni1 ni2; simpl in |- *.
trivial.
intros x ni1 ni2 eqv ih;  rewrite ih; trivial.
intros x k ni1 ni2 eqv ih;  rewrite ih; trivial.
intros x k1 k2 ni1 ni2 eqv ih;  rewrite ih; trivial.
intros x k ni1 ni2 eqv ih;  rewrite ih; trivial.
Qed.

Lemma in_ngamma_eqv :
 forall (work : nf_list) (ds : disjs) (ni1 ni2 : nested_imps)
   (ai : atomic_imps) (a : atoms) (c : normal_form),
 eqv_ni ni1 ni2 ->
 in_ngamma work ds ni1 ai a c -> in_ngamma work ds ni2 ai a c.
intros work ds ni1 ni2 ai a c eqv12 ini1.
apply in_ngamma_ni_eq with ni1; try assumption.
apply eqv_nimps_eq; assumption.
Qed.

Lemma in_ngamma_le :
 forall (work : nf_list) (ds : disjs) (ni1 ni2 : nested_imps)
   (ai : atomic_imps) (a : atoms) (c : normal_form),
 le_ni ni1 ni2 ->
 in_ngamma work ds ni1 ai a c -> in_ngamma work ds ni2 ai a c.
intros work ds ni1 ni2 ai a c le12 in_ngamma.
apply in_ngamma_eqv with ni1.
apply le_eqv; assumption.
assumption.
Qed.

Lemma in_ngamma_ge :
 forall (work : nf_list) (ds : disjs) (ni1 ni2 : nested_imps)
   (ai : atomic_imps) (a : atoms) (c : normal_form),
 le_ni ni2 ni1 ->
 in_ngamma work ds ni1 ai a c -> in_ngamma work ds ni2 ai a c.
intros work ds ni1 ni2 ai a c le21 in_ngamma.
apply in_ngamma_eqv with ni1.
apply ge_eqv; assumption.
assumption.
Qed.

(***********************************************************************)

Inductive le_app_spec (ni1 : nested_imps) (n : nat) : Set :=
    Le_App_Spec_Intro :
      forall ni11 ni12 : nested_imps,
      ni1 = ni11 ++ ni12 -> length ni11 = n -> le_app_spec ni1 n.

Lemma le_app0 :
 forall ni1 ni21 ni22 : nested_imps,
 le_ni ni1 (ni21 ++ ni22) -> le_app_spec ni1 (length ni21).
intros ni1 ni21 ni22.
generalize ni1; clear ni1.
elim ni21; clear ni21.
simpl in |- *; intros ni1 le.
exists NNil ni1.
trivial.
trivial.
intros x ni21 ih ni1.
case ni1; clear ni1.
intros le; elimtype False; inversion_clear le.
simpl in |- *; intros x' ni1 le1.
elim (ih ni1); clear ih.
intros ni11 ni12 eq len.
exists (x' :: ni11) ni12.
 rewrite eq.
trivial.
simpl in |- *.
 rewrite len; trivial.
inversion_clear le1; assumption.
Qed.

Lemma le_ni_app_nn :
 forall (ni1 ni2 ni3 ni4 : nested_imps) (x : nimp),
 length ni1 = length ni3 ->
 le_ni (ni1 ++ ni2) (ni3 ++ ni4) ->
 le_ni (ni1 ++ Undecorated x :: ni2) (ni3 ++ Undecorated x :: ni4).
intros ni1 ni2 ni3 ni4 x.
generalize ni3; clear ni3.
elim ni1; clear ni1.
intros ni3; case ni3; clear ni3.
simpl in |- *; intros len le.
apply Le_NI_Cons_NN; assumption.
intros y ni3 len le.
inversion_clear len.
intros y ni1 ih.
intros ni3; case ni3; clear ni3.
simpl in |- *; intros len le; inversion_clear len.
simpl in |- *; intros y' ni3 len le.
inversion_clear le.
apply Le_NI_Cons_NN.
apply ih.
 injection len; intros; assumption.
assumption.
apply Le_NI_Cons_DN.
apply ih.
 injection len; intros; assumption.
assumption.
apply Le_NI_Cons_DD.
apply ih.
 injection len; intros; assumption.
assumption.
Qed.

Lemma le_ni_app_dn :
 forall (ni1 ni2 ni3 ni4 : nested_imps) (x : nimp) (k : kripke_tree),
 length ni1 = length ni3 ->
 le_ni (ni1 ++ ni2) (ni3 ++ ni4) ->
 le_ni (ni1 ++ Decorated x k :: ni2) (ni3 ++ Undecorated x :: ni4).
intros ni1 ni2 ni3 ni4 x k.
generalize ni3; clear ni3.
elim ni1; clear ni1.
intros ni3; case ni3; clear ni3.
simpl in |- *; intros len le.
apply Le_NI_Cons_DN; assumption.
intros y ni3 len le.
inversion_clear len.
intros y ni1 ih.
intros ni3; case ni3; clear ni3.
simpl in |- *; intros len le; inversion_clear len.
simpl in |- *; intros y' ni3 len le.
inversion_clear le.
apply Le_NI_Cons_NN.
apply ih.
 injection len; intros; assumption.
assumption.
apply Le_NI_Cons_DN.
apply ih.
 injection len; intros; assumption.
assumption.
apply Le_NI_Cons_DD.
apply ih.
 injection len; intros; assumption.
assumption.
Qed.

Lemma le_ni_app_dd :
 forall (ni1 ni2 ni3 ni4 : nested_imps) (x : nimp) (k : kripke_tree),
 length ni1 = length ni3 ->
 le_ni (ni1 ++ ni2) (ni3 ++ ni4) ->
 le_ni (ni1 ++ Decorated x k :: ni2) (ni3 ++ Decorated x k :: ni4).
intros ni1 ni2 ni3 ni4 x k.
generalize ni3; clear ni3.
elim ni1; clear ni1.
intros ni3; case ni3; clear ni3.
simpl in |- *; intros len le.
apply Le_NI_Cons_DD; assumption.
intros y ni3 len le.
inversion_clear len.
intros y ni1 ih.
intros ni3; case ni3; clear ni3.
simpl in |- *; intros len le; inversion_clear len.
simpl in |- *; intros y' ni3 len le.
inversion_clear le.
apply Le_NI_Cons_NN.
apply ih.
 injection len; intros; assumption.
assumption.
apply Le_NI_Cons_DN.
apply ih.
 injection len; intros; assumption.
assumption.
apply Le_NI_Cons_DD.
apply ih.
 injection len; intros; assumption.
assumption.
Qed.


(* ----------------------------------------------------------------------------------- *)
(** ** Final bicategory and proof that it's univalent.

   Note: UniMath.CategoryTheory.categories.StandardCategories has the definition of
   final 1-category ([unit_category]).                                                *)
(* ----------------------------------------------------------------------------------- *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.AdjointUnique.

Local Open Scope cat.
Local Open Scope bicategory_scope.

Section Final_Bicategory.
  Definition final_1_id_comp_cells : prebicat_1_id_comp_cells
    := tpair (λ C : precategory_data, prebicat_2cell_struct C)
             unit_category
             (λ (a b : unit_category) (f g : a --> b), unit).

  Definition final_2_id_comp_struct
    : prebicat_2_id_comp_struct final_1_id_comp_cells.
  Proof.
    repeat split; exact tounit.
  Defined.

  Definition final_prebicat_data : prebicat_data
    := final_1_id_comp_cells,, final_2_id_comp_struct.

  Lemma final_bicat_laws : prebicat_laws final_prebicat_data.
  Proof.
    repeat apply make_dirprod; intros; apply isProofIrrelevantUnit.
  Qed.

  Definition final_prebicat : prebicat
    := final_prebicat_data,, final_bicat_laws.

  Lemma cellset_final_prebicat
    : isaset_cells final_prebicat.
  Proof.
    red. cbn. intros. exact isasetunit.
  Qed.

  Definition final_bicat : bicat
    := final_prebicat,, cellset_final_prebicat.

  Definition final_bicat_invertible_2cell
             {x y : final_bicat}
             {f g : x --> y}
             (α : f ==> g)
    : is_invertible_2cell α.
  Proof.
    refine (tt ,, (_ ,, _)) ; reflexivity.
  Defined.

  Definition final_bicat_adjoint_equivalence
             {x y : final_bicat}
             (f : x --> y)
    : left_adjoint_equivalence f.
  Proof.
    use tpair.
    - use tpair.
      + exact (!f).
      + exact (tt ,, tt).
    - split ; split ; cbn.
      + reflexivity.
      + reflexivity.
      + apply final_bicat_invertible_2cell.
      + apply final_bicat_invertible_2cell.
  Defined.

  (** It is univalent *)
  Definition final_bicat_is_univalent_2_1
    : is_univalent_2_1 final_bicat.
  Proof.
    intros x y p q.
    use isweqimplimpl.
    - intros.
      apply isasetaprop.
      apply isapropunit.
    - apply isasetaprop.
      apply isasetaprop.
      exact isapropunit.
    - simple refine (isaprop_total2 (_ ,, _) (λ η , _ ,, _)).
      + exact isapropunit.
      + apply isaprop_is_invertible_2cell.
  Defined.

  Definition final_bicat_is_univalent_2_0
    : is_univalent_2_0 final_bicat.
  Proof.
    intros x y.
    apply isweqimplimpl.
    - intros.
      induction x, y.
      reflexivity.
    - apply isasetaprop.
      exact isapropunit.
    - simple refine (isaprop_total2 (_ ,, _) (λ η , _ ,, _)).
      + apply isasetaprop.
        exact isapropunit.
      + apply isaprop_left_adjoint_equivalence.
        exact final_bicat_is_univalent_2_1.
  Defined.

  Definition final_bicat_is_univalent_2
    : is_univalent_2 final_bicat.
  Proof.
    split.
    - exact final_bicat_is_univalent_2_0.
    - exact final_bicat_is_univalent_2_1.
  Defined.

End Final_Bicategory.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal6.

From lfind Require Import LFind.
Lemma lfind_state  (x:lst) (y:lst):@eq natural (len (append x y)) (plus (len x) (len y)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal6_theorem0_64_len_append/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (x:lst) (y:lst) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y.
QuickChick collect_data.
Success.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e450m2e225m1_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.