Require Import Lt.
Require Import Omega.
Require Import MFix.Monad.
Require Import MFix.ILogic.
Require Import MFix.Fuel.
Require Import MFix.FuelLob3.

Set Implicit Arguments.
Set Strict Implicit.

Section logical.
  Variable T : Type.
  Variable ILogic_T : ILogic T.
  Variable Quant_T : Quant T.

  Variables A B : Type.

  Definition At (a : A) (P : B -> T) : (A -> B) -> T :=
    fun f => P (f a).
  Definition At' (P : A -> B -> T) : (A -> B) -> T :=
    fun f => lforall _ (fun x => P x (f x)).

End logical.

Section IndexedInd.
  (* Indexed fixpoint induction, take4 *)
  (* Critique:
    - Too low level, you need to unfold ret and bind to get anywhere.
   *)
  Definition FuelProp := fuel -> Prop.

  Definition Inj : Prop -> FuelProp := fun P _ => P.

  Definition atleast (n : nat) : FuelProp :=
    fun fuel => fuel >= n.

  (** |> P |- P  ->  P
   ** P |- |> P
   ** P must hold for divergence
   **)
  Definition later (fp : FuelProp) : FuelProp :=
    fun n => forall m, m < n -> fp m.

  Definition satisfies {B} (P : B -> FuelProp) (c : M B) : FuelProp :=
    fun fuel => match c fuel with
                  | None => ltrue
                  | Some x => P x fuel
                end.
(*
  Definition satisfiesF {A B} (P : A -> B -> FuelProp) (c : A -> M B) : FuelProp :=
    fun fuel =>
      forall x,
        match c x fuel with
          | None => ltrue
          | Some v =>
            P x v fuel
        end.
*)

  Definition satisfiesF {A B} (P : A -> B -> FuelProp) : (A -> M B) -> FuelProp :=
    At' _ (fun a => satisfies (P a)).

  Theorem satisfiesF_satisfiesF'
  : forall A B (P : A -> B -> FuelProp) c,
      forall f, (satisfiesF P c f <-> satisfiesF' P c f).
  Proof. reflexivity. Qed.

  Variable (A B : Type).
  Variable P : A -> B -> FuelProp.
  Variable f : (A -> M B) -> (A -> M B).

  Hypothesis Step
  : forall (r : A -> M B),
      monotoneF r ->
      lentails (satisfiesF (fun x y => later (P x y)) r) (satisfiesF P (f r)).

  Theorem mfixind : lentails ltrue (satisfiesF P (mfix f)).
  Proof.
    red. simpl. intros x [].
    induction x.
    { compute. auto. }
    { simpl in *. unfold satisfiesF in *. simpl in *.
      eapply Step.
      { red. red. intros.
        destruct (mfix f x0 x); constructor. }
      { simpl. auto. } }
  Qed.

(** NOTE: This is not the same because it requires you to only
 ** prove for a certain amount of fuel
  Theorem mfixind
  : (lforall _ (fun r : A -> M B =>
             Inj (monotoneF r) -->>
             (satisfiesF (fun x y => later (P x y)) r -->>
              satisfiesF P (f r))))
    |-- satisfiesF P (mfix f).
**)
End IndexedInd.

Module ExampleFactorial.

  Definition mkfact (fact : nat -> M nat) (n : nat) : M nat :=
    match n with
      | 0 => ret 1
      | S n' => bind (fact n') (fun m => ret (n*m))
    end.

  Definition fact := mfix mkfact.

  (* This works as expected. *)
  Eval compute in (fact 5 10).
  Eval compute in (fact 5 2).

  Fixpoint rfact (n : nat) :=
    match n with
      | 0 => 1
      | (S n') => n * (rfact n')
    end.

  Definition TerminatesWith {T} (n : fuel) (P : T -> Prop) : M T -> FuelProp :=
    fun c fuel => fuel >= n ->
                  match c fuel with
                    | None => False
                    | Some val => P val
                  end.
  Definition IfTerminates {T} (P : T -> Prop) : M T -> FuelProp :=
    fun c fuel => match c fuel with
                    | None => True
                    | Some val => P val
                  end.

  (** This is the same as the statement that we proved in FuelLob3 except that
   ** it uses >= rather than just >
   **)
  Definition Pfact : (nat -> M nat) -> FuelProp :=
    lforall _ (fun n => At n (TerminatesWith (S n) (fun result => result = rfact n))).

  Eval cbv beta iota zeta delta
       [ Pfact lforall  Quant_Fun Quant_Prop At TerminatesWith Inj lentails ltrue ILogic_Prop ILogic_Fun ]
    in lentails ltrue (Pfact fact).

  Example fact_correct
  : lentails ltrue (Pfact fact).
  Proof.
    unfold Pfact. simpl. intros. clear H.
    red. red.
    generalize @mfixind. simpl. unfold satisfiesF. simpl.
    intros.
    unfold fact.
    apply (fun b d => @mfixind1' nat nat (fun fuel f =>
                                            fuel >= S x0 ->
                                            match f x0 with
                                              | None => False
                                              | Some val => val = rfact x0
                                            end) b mkfact d x).
    { clear. intros.  inversion H. }
    { intros. unfold mkfact.

    { unfold mkfact, satisfiesF, later; simpl. intros.
      destruct x0; simpl.
      { reflexivity. }
      { unfold bind.
        specialize (H0 x0).
        destruct (r x0 x); auto.
        simpl in *. destruct x; intuition.
        red. assert (atleast x0 x). red. red in H1. omega.
        apply H0 in H2.
        red in H2. subst. reflexivity. } }

(** Old version, this isn't correct because it doesn't imply termination
  Definition Pfact : (nat -> M nat) -> FuelProp :=
     satisfiesF (fun n fn => limpl (atleast n) (Inj (fn = rfact n)) f).

  Example fact_correct
  : lentails ltrue (Pfact fact).
  Proof.
    eapply mfixind.
    { unfold mkfact, satisfiesF, later; simpl. intros.
      destruct x0; simpl.
      { reflexivity. }
      { unfold bind.
        specialize (H0 x0).
        destruct (r x0 x); auto.
        simpl in *. destruct x; intuition.
        red. assert (atleast x0 x). red. red in H1. omega.
        apply H0 in H2.
        red in H2. subst. reflexivity. } }
  Qed.
**)

  Theorem factTerminates : forall n, Terminates (fact n).
  Proof.
    intros. exists (S n).
    generalize (@fact_correct (S n) I n).
    destruct (fact n (S n)).
    abstract (rewrite fact_correct; auto; congruence).
  Defined.

  Definition pure_fact : nat -> nat :=
    Eval compute in purifyF fact (@factTerminates).

  (** pure_fact is a little bit slower... **)
  Time Eval vm_compute in pure_fact 7.
  Time Eval vm_compute in rfact 7.

End ExampleFactorial.


(* InK1m.v *)

Require Import Utf8 QArith NPeano.

Require Import Misc.
Require Import Field2.
Require Import Fpolynomial.
Require Import Newton.
Require Import Power_series.
Require Import Puiseux_series.
Require Import Ps_add.
Require Import Ps_mul.
Require Import Ps_div.
Require Import Ps_add_compat.
Require Import PSpolynomial.
Require Import Puiseux_base.
Require Import AlgCloCharPol.
Require Import PosOrder.
Require Import CharactPolyn.
Require Import ConvexHull.
Require Import PolyConvexHull.
Require Import F1Eq.
Require Import QbarM.

Set Implicit Arguments.

Add Parametric Morphism α (R : ring α) (K : field R) : (@in_K_1_m _ R K)
  with signature eq_ps ==> eq ==> iff
  as in_K_1_m_morph.
Proof.
intros a b Hab n.
split; intros H.
 inversion_clear H.
 destruct H0 as (ps₁, H).
 constructor.
 exists ps₁.
 destruct H as (H, Hpo).
 split; [ idtac | assumption ].
 transitivity a; assumption.

 inversion_clear H.
 destruct H0 as (ps₁, H).
 constructor.
 exists ps₁.
 destruct H as (H, Hpo).
 split; [ idtac | assumption ].
 symmetry in Hab.
 transitivity b; assumption.
Qed.

Section theorems.

Variable α : Type.
Variable R : ring α.
Variable K : field R.
Variable acf : algeb_closed_field K.

Theorem in_K_1_m_add_compat : ∀ m a b,
  in_K_1_m a m
  → in_K_1_m b m
  → in_K_1_m (a + b) m.
Proof.
intros m a b Ha Hb.
inversion_clear Ha.
rename H into Ha.
inversion_clear Hb.
rename H into Hb.
destruct Ha as (psa, (Ha, Hpa)).
destruct Hb as (psb, (Hb, Hpb)).
constructor.
remember Ha as Hab; clear HeqHab.
eapply ps_add_compat_r with (ps₃ := psb) in Hab.
rewrite Hb in Hab at 2.
unfold ps_add in Hab at 1.
unfold cm in Hab.
rewrite Hpa, Hpb in Hab.
unfold ps_ordnum_add in Hab.
unfold cm_factor in Hab.
rewrite Hpa, Hpb in Hab.
rewrite Z.mul_min_distr_nonneg_r in Hab; auto with Arith.
unfold ps_terms_add in Hab.
unfold cm_factor in Hab.
rewrite Hpa, Hpb in Hab.
rewrite Z.mul_min_distr_nonneg_r in Hab; auto with Arith.
rewrite Z.mul_min_distr_nonneg_r in Hab; auto with Arith.
rewrite <- Z.mul_sub_distr_r in Hab.
rewrite <- Z.mul_sub_distr_r in Hab.
remember (ps_ordnum psa) as oa.
remember (ps_ordnum psb) as ob.
remember (ps_terms psa) as sa.
remember (ps_terms psb) as sb.
remember (oa - Z.min oa ob)%Z as omab.
remember (ob - Z.min ob oa)%Z as omba.
exists
 (mkps
    (adjust_series (Z.to_nat omab) 1 sa + adjust_series (Z.to_nat omba) 1 sb)
    (Z.min oa ob) m).
split; auto with Arith.
rewrite <- Hab.
rewrite ps_adjust_eq with (n := O) (k := m).
unfold adjust_ps; simpl.
rewrite Z.sub_0_r.
rewrite series_shift_0.
apply mkps_morphism; auto with Arith.
unfold adjust_series; simpl.
rewrite Z2Nat.inj_mul; simpl; auto with Arith.
 rewrite Z2Nat.inj_mul; simpl; auto with Arith.
  rewrite <- stretch_shift_series_distr.
  rewrite <- stretch_shift_series_distr.
  rewrite <- series_stretch_add_distr.
  do 2 rewrite series_stretch_1.
  reflexivity.

  subst omba.
  rewrite <- Z.sub_max_distr_l, Z.sub_diag.
  apply Z.le_max_l.

 subst omab.
 rewrite <- Z.sub_max_distr_l, Z.sub_diag.
 apply Z.le_max_l.
Qed.

Theorem in_K_1_m_mul_compat : ∀ m a b,
  in_K_1_m a m
  → in_K_1_m b m
  → in_K_1_m (a * b) m.
Proof.
intros m a b Ha Hb.
inversion_clear Ha.
rename H into Ha.
inversion_clear Hb.
rename H into Hb.
destruct Ha as (psa, (Ha, Hpa)).
destruct Hb as (psb, (Hb, Hpb)).
constructor.
remember Ha as Hab; clear HeqHab.
eapply ps_mul_compat_r with (ps₃ := psb) in Hab.
rewrite Hb in Hab at 2.
unfold ps_mul in Hab at 1.
unfold cm, cm_factor in Hab.
rewrite Hpa, Hpb in Hab.
rewrite <- Z.mul_add_distr_r in Hab.
rewrite <- series_stretch_mul in Hab.
exists (mkps (ps_terms psa * ps_terms psb) (ps_ordnum psa + ps_ordnum psb) m).
split; auto with Arith.
rewrite <- Hab.
rewrite ps_adjust_eq with (n := O) (k := m).
unfold adjust_ps; simpl.
rewrite Z.sub_0_r.
rewrite series_shift_0.
reflexivity.
Qed.

Theorem ps_zero_in_K_1_m : ∀ m, in_K_1_m 0 m.
Proof.
intros m.
constructor.
exists (mkps 0 0 m).
split; [ idtac | reflexivity ].
symmetry.
rewrite ps_adjust_eq with (n := O) (k := m).
unfold adjust_ps; simpl.
rewrite series_shift_0; simpl.
rewrite series_stretch_series_0.
reflexivity.
Qed.

Theorem ps_lap_forall_forall : ∀ la (P : puiseux_series α → Prop),
  (∀ a b, (a = b)%ps → P a → P b)
  → ps_lap_forall P la ↔ (∀ a, ps_lap_in a la → P a).
Proof.
intros la P Hmorph.
split; [ intros Hfa a Hin | intros Hfa ].
 revert a Hin.
 induction la as [| b]; intros; [ contradiction | idtac ].
 simpl in Hin.
 destruct Hin as [(Hbla, Hba)| Hin].
  inversion_clear Hfa; [ contradiction | idtac ].
  eapply Hmorph; eassumption.

  inversion_clear Hfa.
   inversion_clear H.
   rewrite H1 in Hin; contradiction.

   apply IHla; assumption.

 induction la as [| b]; [ constructor; reflexivity | idtac ].
 destruct (ps_lap_nilp _ [b … la]) as [Hba| Hba].
  constructor 1; assumption.

  constructor 2; [ assumption | idtac | idtac ].
   apply Hfa; left.
   split; [ assumption | reflexivity ].

   apply IHla; intros a Ha.
   apply Hfa; right; assumption.
Qed.

Theorem hd_in_K_1_m : ∀ a la m,
  ps_lap_forall (λ b, in_K_1_m b m) [a … la]
  → in_K_1_m a m.
Proof.
intros a la m Hla.
destruct (ps_zerop K a) as [Ha| Ha].
 rewrite Ha; apply ps_zero_in_K_1_m.

 eapply ps_lap_forall_forall in Hla; eauto with Arith.
  intros b c Hbc Hb.
  rewrite <- Hbc; assumption.

  left.
  split; [ idtac | reflexivity ].
  intros H1; apply Ha; clear Ha.
  apply lap_eq_cons_nil_inv in H1.
  destruct H1; assumption.
Qed.

Theorem in_K_1_m_lap_add_compat : ∀ m la lb c,
  (∀ a, ps_lap_in a la → in_K_1_m a m)
  → (∀ b, ps_lap_in b lb → in_K_1_m b m)
  → ps_lap_in c (la + lb)
  → in_K_1_m c m.
Proof.
intros m la lb c Hla Hlb Hc.
rewrite <- fold_ps_lap_add in Hc.
revert lb Hlb Hc.
induction la as [| a]; intros.
 simpl in Hc.
 apply Hlb; assumption.

 destruct lb as [| b].
  simpl in Hc.
  destruct Hc as [(Ha, Hac)| Hc].
   rewrite <- Hac.
   apply Hla; left.
   split; [ assumption | reflexivity ].

   apply Hla; right; assumption.

  simpl in Hc.
  destruct Hc as [(Hab, Hac)| Hc].
   rewrite <- Hac.
   apply in_K_1_m_add_compat.
    eapply hd_in_K_1_m.
    apply ps_lap_forall_forall; eauto .
    intros d e Hde Hd.
    rewrite <- Hde; assumption.

    eapply hd_in_K_1_m.
    apply ps_lap_forall_forall; eauto .
    intros d e Hde Hd.
    rewrite <- Hde; assumption.

   apply IHla with (lb := lb).
    intros d Hd.
    apply Hla; right; assumption.

    intros d Hd.
    apply Hlb; right; assumption.

    assumption.
Qed.

Theorem in_K_1_m_lap_mul_compat : ∀ m la lb c,
  (∀ a, ps_lap_in a la → in_K_1_m a m)
  → (∀ b, ps_lap_in b lb → in_K_1_m b m)
  → ps_lap_in c (la * lb)
  → in_K_1_m c m.
Proof.
intros m la lb c Hla Hlb Hc.
rewrite <- fold_ps_lap_mul in Hc.
revert lb c Hlb Hc.
induction la as [| a]; intros.
 rewrite lap_mul_nil_l in Hc.
 contradiction.

 destruct lb as [| b].
  rewrite lap_mul_nil_r in Hc.
  contradiction.

  rewrite lap_mul_cons in Hc.
  simpl in Hc.
  destruct Hc as [(Hab, Hc)| Hc].
   rewrite <- Hc.
   apply in_K_1_m_mul_compat.
    eapply hd_in_K_1_m.
    apply ps_lap_forall_forall; eauto .
    intros d e Hde Hd.
    rewrite <- Hde; assumption.

    eapply hd_in_K_1_m.
    apply ps_lap_forall_forall; eauto .
    intros d e Hde Hd.
    rewrite <- Hde; assumption.

   apply in_K_1_m_lap_add_compat with (m := m) in Hc; auto with Arith.
    intros d Hd.
    apply in_K_1_m_lap_add_compat with (m := m) in Hd; auto with Arith.
     intros e He.
     apply IHla with (lb := [b]); auto with Arith.
      intros f Hf.
      apply Hla; right; assumption.

      intros f Hf.
      simpl in Hf.
      destruct Hf as [(Hb, Hbf)| ]; [ idtac | contradiction ].
      rewrite <- Hbf.
      apply Hlb; left.
      split; [ idtac | reflexivity ].
      intros H; apply Hb.
      apply lap_eq_cons_nil_inv in H.
      destruct H as (H, _); rewrite H.
      apply lap_eq_0.

     intros f Hf.
     clear Hc Hd.
     induction lb as [| b']; [ contradiction | idtac ].
     rewrite lap_mul_cons in Hf.
     simpl in Hf.
     destruct Hf as [(Hab, Habf)| Hf].
      rewrite <- Habf.
      apply in_K_1_m_mul_compat.
       eapply hd_in_K_1_m.
       apply ps_lap_forall_forall; eauto .
       intros g h Hgh Hg.
       rewrite <- Hgh; assumption.

       destruct (ps_zerop K b') as [Hb| Hb].
        rewrite Hb; apply ps_zero_in_K_1_m.

        apply Hlb; right; left.
        split; [ idtac | reflexivity ].
        intros H; apply Hb; clear Hb.
        apply lap_eq_cons_nil_inv in H.
        destruct H; assumption.

      rewrite lap_mul_nil_l in Hf.
      rewrite lap_eq_0, lap_add_nil_r in Hf.
      apply IHlb; auto with Arith.
      intros e He.
      apply Hlb.
      simpl in He; simpl.
      destruct He as [(Hbb, He)| He].
       left.
       split; [ idtac | assumption ].
       intros H; apply Hbb.
       apply lap_eq_cons_nil_inv in H.
       destruct H as (Hb, H).
       rewrite Hb.
       apply lap_eq_cons_nil_inv in H.
       destruct H as (_, H); rewrite H.
       apply lap_eq_0.

       right; right; assumption.

    intros d Hd.
    simpl in Hd.
    destruct Hd as [(Hab, Hd)| Hd].
     rewrite <- Hd; apply ps_zero_in_K_1_m.

     apply IHla with (lb := lb); auto with Arith.
      intros e He.
      destruct (ps_zerop K e) as [Hf| Hf].
       rewrite Hf; apply ps_zero_in_K_1_m.

       apply Hla; right; assumption.

      intros e He.
      destruct (ps_zerop K e) as [Hf| Hf].
       rewrite Hf; apply ps_zero_in_K_1_m.

       apply Hlb; right; assumption.
Qed.

Theorem in_K_1_m_lap_comp_compat : ∀ m la lb c,
  (∀ a, ps_lap_in a la → in_K_1_m a m)
  → (∀ b, ps_lap_in b lb → in_K_1_m b m)
  → ps_lap_in c (la ∘ lb)
  → in_K_1_m c m.
Proof.
intros m la lb c Hla Hlb Hc.
rewrite <- fold_ps_lap_comp in Hc.
revert lb c Hlb Hc.
induction la as [| a]; intros; [ contradiction | idtac ].
destruct lb as [| b].
 simpl in Hc.
 rewrite lap_mul_nil_r, lap_add_nil_l in Hc; simpl in Hc.
 destruct Hc as [(Ha, Hac)| ]; [ idtac | contradiction ].
 apply Hla; left.
 split; [ idtac | assumption ].
 intros H; apply Ha.
 inversion_clear H.
 rewrite H0.
 apply lap_eq_0.

 simpl in Hc.
 eapply in_K_1_m_lap_add_compat; [ idtac | idtac | eauto  ].
  intros d Hd.
  eapply in_K_1_m_lap_mul_compat; [ idtac | idtac | eauto  ].
   intros e He.
   apply IHla with (lb := [b … lb]).
    intros f Hf.
    apply Hla; right; assumption.

    intros f Hf.
    simpl in Hf.
    destruct Hf as [Hf| Hf].
     apply Hlb; left; assumption.

     apply Hlb; right; assumption.

    assumption.

   intros e He.
   simpl in He.
   destruct He as [He| He].
    apply Hlb; left; assumption.

    apply Hlb; right; assumption.

  intros d Hd.
  simpl in Hd.
  destruct Hd as [(Ha, Had)| ]; [ idtac | contradiction ].
  apply Hla; left.
  split; [ idtac | assumption ].
  intros H; apply Ha.
  inversion_clear H.
  rewrite H0.
  apply lap_eq_0.
Qed.

Theorem minus_beta_in_K_1_mq : ∀ f L m a c q,
  newton_segments f = Some L
  → pol_in_K_1_m f m
  → q = q_of_m m (γ L)
  → a = ps_monom c (- β L)
  → in_K_1_m a (m * q).
Proof.
intros f L m a c q HL Hm Hq Ha.
constructor; subst a.
remember (p_of_m m (γ L)) as p eqn:Hp .
pose proof (any_is_p_mq (γ L) m Hp Hq) as Hgp.
destruct Hgp as (Hgp, Hg).
remember HL as Hini; clear HeqHini.
apply exists_ini_pt_nat in Hini.
destruct Hini as (j, (αj, Hini)).
remember HL as Him; clear HeqHim.
symmetry in Hini.
eapply pol_ord_of_ini_pt in Him; eauto .
remember HL as Hbm; clear HeqHbm.
apply points_in_any_newton_segment with (h := Qnat j) (αh := αj) in Hbm.
 rewrite Him, Hgp in Hbm.
 remember (mh_of_m m αj (ps_poly_nth j f)) as mj.
 remember (mj * Zpos q + Z.of_nat j * p # m * q) as v.
 exists (ps_monom c (- v)); subst v; simpl.
 split; [ idtac | reflexivity ].
 rewrite Hbm.
 unfold ps_monom; simpl.
 rewrite ps_adjust_eq with (n := O) (k := m).
 unfold adjust_ps; simpl.
 rewrite Z.sub_0_r.
 rewrite fold_series_const.
 rewrite series_stretch_const, series_shift_0.
 apply mkps_morphism; try reflexivity.
  rewrite Z.mul_opp_l; f_equal.
  rewrite Z.mul_add_distr_r; f_equal.
  rewrite <- Z.mul_assoc; f_equal.
  apply Z.mul_comm.

  apply Pos.mul_comm.

 left; symmetry; eassumption.
Qed.

Theorem gamma_in_K_1_mq : ∀ L m a c q,
  q = q_of_m m (γ L)
  → (a = ps_monom c (γ L))%ps
  → in_K_1_m a (m * q).
Proof.
intros L m a c q Hq Ha.
constructor.
remember (p_of_m m (γ L)) as p eqn:Hp .
pose proof (any_is_p_mq (γ L) m Hp Hq) as Hgp.
destruct Hgp as (Hgp, Hg).
exists (ps_monom c (p # m * q)); simpl.
split; [ idtac | reflexivity ].
rewrite Ha, Hgp.
reflexivity.
Qed.

Theorem in_K_1_m_lap_mul_r_compat : ∀ a m n,
  in_K_1_m a m
  → in_K_1_m a (m * n).
Proof.
intros a m n Ha.
constructor.
inversion_clear Ha.
destruct H as (ps, (Hps, Hm)).
exists (adjust_ps 0 n ps).
split; [ idtac | simpl; rewrite Hm; reflexivity ].
rewrite ps_adjust_eq with (n := O) (k := n) in Hps.
assumption.
Qed.

Theorem next_pol_in_K_1_mq : ∀ f f₁ L m c q,
  newton_segments f = Some L
  → pol_in_K_1_m f m
  → c = ac_root (Φq f L)
  → q = q_of_m m (γ L)
  → f₁ = next_pol f (β L) (γ L) c
  → pol_in_K_1_m f₁ (m * q).
Proof.
intros f f₁ L m c q HL Hm Hc Hq Hf₁.
subst f₁.
unfold next_pol, next_lap; simpl.
apply ps_lap_forall_forall.
 intros a b Hab Hamq.
 rewrite <- Hab; assumption.

 intros b Hin.
 eapply in_K_1_m_lap_mul_compat; eauto .
  intros a Ha.
  destruct Ha as [Ha| ]; [ idtac | contradiction ].
  destruct Ha as (_, Ha).
  rewrite <- Ha.
  eapply minus_beta_in_K_1_mq; eauto .

  intros ps Hps.
  eapply in_K_1_m_lap_comp_compat; eauto .
   intros a Ha.
   apply in_K_1_m_lap_mul_r_compat.
   revert a Ha.
   apply ps_lap_forall_forall.
    intros a d Hab Hamq.
    rewrite <- Hab; assumption.

    assumption.

   intros a Ha; simpl in Ha.
   destruct Ha as [Ha| [Ha| ]]; [ idtac | idtac | contradiction ].
    destruct Ha as (Hla, Ha).
    symmetry in Ha.
    eapply gamma_in_K_1_mq; eassumption.

    destruct Ha as (Hla, Ha).
    symmetry in Ha.
    eapply gamma_in_K_1_mq; eassumption.
Qed.

End theorems.


Module TPConcreteTyping.

Load TPSmallSteps.
Import TPSmallSteps.
Load TPTyping.
Import TPTyping.

Inductive TPTypeEquation :=
| TPTypeEq (t1 t2 : TPType).

Inductive Subst' :=
| Subst (a b : TPType)
| Error.

Fixpoint TPTypeComplexity t :=
  match t with
    | TPTypeFun t1 t2 => plus (plus (TPTypeComplexity t1) (TPTypeComplexity t2)) (1%nat)
    | _ => 1%nat
  end.

Definition TPTypeEquationComplexity t :=
  match t with
    | TPTypeEq t1 t2 => plus (TPTypeComplexity t1) (TPTypeComplexity t2)
  end.

Definition TPTypeEquationListComplexity eqlist := fold_left plus (map TPTypeEquationComplexity eqlist) 0%nat.

Require Import Recdef.

Function unify (types : list TPTypeEquation) {measure TPTypeEquationListComplexity} : list Subst' :=
  match types with
    | nil => nil
    | ((TPTypeEq (TPTypeFun t1 t2) (TPTypeFun t1' t2')) :: lst) => unify ((TPTypeEq t1 t1') :: (TPTypeEq t2 t2') :: lst)
    | (TPTypeEq (TPTypeVar id) t) :: lst => (Subst t (TPTypeVar id)) :: unify lst
    | (TPTypeEq t (TPTypeVar id)) :: lst => (Subst t (TPTypeVar id)) :: unify lst
    | (TPTypeEq t1 t2) :: lst => if TPType_eq t1 t2 then unify lst else Error :: nil
  end.
Proof.
  intros.
  induction lst.
  now intuition.
  (*unfold complexity.*)
Admitted.

Inductive TPTypingJudgement :=
  | TPTypingJudge (env : list (string * TPType)) (exp : TPExp) (type : TPType).

(*
(* This function does not work because, due to a weird typing issue, op has type TPOperator instead of TPSmallSteps.TPSyntax.TPOperator *)
Fixpoint typing_rules env exp {struct exp} :=
  match exp with
    | TPExpConst TPConstantUnit => TPTypeUnit
    | TPExpConst (TPConstantBool _) => TPTypeBool
    | TPExpConst (TPConstantInt _) => TPTypeInt
    | TPExpConst (TPConstantOp op) => TPTypeOfOp op
    | TPExpConst TPConstantExn => TPTypeError
    | TPExpConst TPConstantHang => TPTypeError
    | TPExpId id => match find (fun a => string_eq id (fst a)) env with | Some (a,b) => b | None => TPTypeVar "" end
    | TPExpApp e1 e2 =>
      match typing_rules env e1 with
        | TPTypeFun t1 t2 => if TPType_eq (typing_rules env e2) t1 then t2 else TPTypeError
        | _ => TPTypeError
      end
    | TPExpAbstr id e => typing_rules env e
    | TPExpIf e1 e2 e3 => if negb (TPType_eq (typing_rules env e1) TPTypeBool) then TPTypeError else if negb (TPType_eq (typing_rules env e2) (typing_rules env e3)) then TPTypeError else typing_rules env e2
    | TPExpLet id e1 e2 => typing_rules ((id, typing_rules env e1) :: env) e2
    | TPExpRec id e => typing_rules env e
  end.
*)

End TPConcreteTyping.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import HoTT.Basics.
Require Import Types.Sigma Types.Forall.
Local Open Scope path_scope.

(** * Null homotopies of maps *)
Section NullHomotopy.
Context `{Funext}.

(** Geometrically, a nullhomotopy of a map [f : X -> Y] is an extension of [f] to a map [Cone X -> Y].  One might more simply call it e.g. [Constant f], but that is a little ambiguous: it could also reasonably mean e.g. a factorisation of [f] through [ Trunc -1 X ].  (Should the unique map [0 -> Y] be constant in one way, or in [Y]-many ways?) *)

Definition NullHomotopy {X Y : Type} (f : X -> Y)
  := {y : Y & forall x:X, f x = y}.

Lemma istrunc_nullhomotopy {n : trunc_index}
  {X Y : Type} (f : X -> Y) `{IsTrunc n Y}
  : IsTrunc n (NullHomotopy f).
Proof.
  apply @trunc_sigma; auto.
  intros y. apply (@trunc_forall _).
  intros x. apply trunc_succ.
Defined.

End NullHomotopy.


Require Import Lia.
Require Import Arith.
From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.
Require Import lib.SetSize.
Require Import IndefiniteDescription.
Require Import lib.ListSum.

Set Implicit Arguments.

Definition trace_wf (t: trace Event) :=
  forall i j (LTij: i < j) (LTj : NOmega.lt_nat_l j (trace_length t)) d
         (EQtid : tid (trace_nth i t d) = tid (trace_nth j t d)),
    index (trace_nth i t d) < index (trace_nth j t d).

Lemma trace_wf_nodup t (WF: trace_wf t) :
  trace_nodup t.
Proof using.
  unfold trace_wf; repeat red; ins.
  forward eapply WF with (d := d); eauto;
  rewrite H; ins; lia.
Qed.

Definition trace_no_init_tid t :=
  forall d (IN: trace_elems t d), tid d <> 0.

Ltac liaW no := (destruct no; [done|simpl in *; lia]).

Lemma trace_nodup_list {A: Type} (l: list A):
  NoDup l <-> trace_nodup (trace_fin l).
Proof.
  destruct (classic (inhabited A)).
  2: { destruct l; [| by destruct H].
       split; ins. red. ins. lia. }
  destruct H as [a].
  split.
  { intros ND. red. ins. red. ins. apply NoDup_nth in H; auto; lia. }
  { ins. apply NoDup_nth with (d := a). ins.
    red in H. simpl in H.
    pose proof (Nat.lt_trichotomy i j). des; auto.
    all: specialize H with (d := a); specialize_full H; eauto; congruence. }
Qed.

Lemma trace_nodup_size {A: Type} (tr: trace A) (ND: trace_nodup tr):
  trace_length tr = set_size (trace_elems tr).
Proof.
  destruct tr.
  { simpl. apply trace_nodup_list in ND.
    unfold set_size. destruct (excluded_middle_informative _).
    2: { destruct n. vauto. }
    f_equal. destruct (constructive_indefinite_description _ _). simpl in *.
    apply Permutation_length. apply NoDup_Permutation; auto.
    ins.
    symmetry. etransitivity.
    { rewrite in_undup_iff, in_filterP_iff. reflexivity. }
    intuition. }
  { simpl.
    unfold set_size. destruct (excluded_middle_informative _); auto.
    exfalso.
    apply set_finiteE in s. desc.
    red in ND. simpl in ND.

    forward eapply (@list_sum_separation _ _ fl (List.seq 0 (S (length findom)))) as EQ.
    { apply seq_NoDup. }
    { eauto. }
    { ins. apply s0. eauto. }
    forward eapply list_sum_bound with (l := (map
            (fun tn : nat =>
             length
               (filterP
                  (fun e : nat => nth_error findom tn = Some (fl e))
                  (List.seq 0 (S (length findom)))))
            (List.seq 0 (length findom)))) (k := 1).
    2: { rewrite <- EQ, map_length, !seq_length. lia. }
    intros len' H. apply in_map_iff in H as [ind [LEN IND]]. desc.
    remember (filterP (fun e : nat => nth_error findom ind = Some (fl e))
                      (List.seq 0 (S (length findom)))) as poss.
    rewrite <- LEN. do 2 (destruct poss; [vauto| ]).
    assert (In n (n :: n0 :: poss)) as IN1 by done. assert (In n0 (n :: n0 :: poss)) as IN2 by vauto.
    rewrite Heqposs in IN1, IN2. apply in_filterP_iff in IN1. apply in_filterP_iff in IN2. desc.
    pose proof (NPeano.Nat.lt_trichotomy n n0). des.
    2: { subst n0.
         assert (NoDup (n :: n :: poss)).
         { rewrite Heqposs. apply nodup_filterP, seq_NoDup. }
         inversion H. subst. by destruct H2. }
    all: edestruct ND; eauto; congruence. }
Qed.

Lemma trace_wf_helper (nu: nat -> Event) (tr: trace Event) (G: execution)
      (ENUM : enumerates nu (acts G \₁ is_init))
      (ORD_SB: forall i, lt_size i (acts G \₁ is_init) -> forall j, lt_size j (acts G \₁ is_init) -> sb G (nu i) (nu j) -> i < j)
      (EVENTS: trace_elems tr ≡₁ (acts G \₁ is_init))
      (ND: trace_nodup tr)
      (TRACE_NU: forall i d, NOmega.lt_nat_l i (trace_length tr) -> trace_nth i tr d = nu i)
      (WF: Wf G):
  trace_wf tr.
Proof.
  red. ins.
  rewrite !TRACE_NU. 2, 3: liaW (trace_length tr).
  rewrite !TRACE_NU in EQtid. 2, 3: liaW (trace_length tr).
  apply enumeratesE' in ENUM. desc.
  rewrite trace_nodup_size in LTj; auto. rewrite (set_size_equiv _ _ EVENTS) in LTj.
  assert (NOmega.lt_nat_l i (set_size (acts G \₁ is_init))) as LTi.
  { liaW (set_size (acts G \₁ is_init)). }

  pose proof (NPeano.Nat.lt_trichotomy (index (nu i)) (index (nu j))). des; auto.
  { exfalso. specialize INJ with (i := i) (j := j). specialize_full INJ; auto; [| lia].
    eapply wf_index; eauto.
    apply INSET in LTj. apply INSET in LTi. red in LTj, LTi. desc.
    splits; vauto. }
  exfalso.
  specialize ORD_SB with (i := j) (j := i). specialize_full ORD_SB; [| | | lia].
  1,2: by apply set_lt_size.
  apply INSET in LTj. apply INSET in LTi. red in LTj, LTi. desc.
  red. apply seq_eqv_lr. splits; auto.
  destruct (nu i), (nu j); vauto; by simpl in LTi0.
Qed.


(******************************************************************************)
(*   Copyright (c) 2019--2022 - Paulo Torrens <paulotorrens AT gnu DOT org>   *)
(******************************************************************************)

Require Import Lia.
Require Import Arith.
Require Import Relations.
Require Import Equality.
Require Import Local.Prelude.
Require Import Local.Syntax.
Require Import Local.Metatheory.
Require Import Local.Context.
Require Import Local.AbstractRewriting.
Require Import Local.Axiomatic.
Require Import Local.Reduction.
Require Import Local.TypeSystem.

(** ** Normalization. *)

Lemma SN_unlift:
  forall i k e,
  SN step (lift i k e) -> SN step e.
Proof.
  intros.
  apply SN_preimage with (lift i k); intros.
  - apply step_lift; auto.
  - assumption.
Qed.

Lemma SN_unsubst:
  forall y k e,
  SN step (subst y k e) -> SN step e.
Proof.
  intros.
  apply SN_preimage with (subst y k); intros.
  - apply step_subst; auto.
  - assumption.
Qed.

Lemma SN_bind_left:
  forall b ts c,
  SN step (bind b ts c) -> SN step b.
Proof.
  intros.
  apply SN_preimage with (fun b => bind b ts c); auto with cps.
Qed.

Lemma SN_bind_right:
  forall b ts c,
  SN step (bind b ts c) -> SN step c.
Proof.
  intros.
  apply SN_preimage with (fun c => bind b ts c); auto with cps.
Qed.

Definition sumup {T} (f: T -> nat) (ts: list T): nat :=
  fold_right Nat.add 0 (map f ts).

Lemma sumup_app:
  forall {T} f a b,
  @sumup T f (a ++ b) = sumup f a + sumup f b.
Proof.
  induction a; simpl; intros.
  - reflexivity.
  - unfold sumup; simpl.
    rewrite <- Nat.add_assoc; f_equal.
    apply IHa.
Defined.

Lemma sumup_cons:
  forall {T} f a b,
  @sumup T f (a :: b) = f a + sumup f b.
Proof.
  intros.
  reflexivity.
Defined.

Fixpoint count (t: pseudoterm): nat :=
  match t with
  | base =>
    1
  | negation ts =>
    1 + sumup count ts
  | _ =>
    0
  end.

Lemma sumup_count_is_well_founded:
  well_founded (ltof _ (sumup count)).
Proof.
  apply well_founded_ltof.
Defined.

Lemma count_arg:
  forall {t ts g},
  t = (negation ts :: g) ->
  sumup count (ts ++ g) < sumup count t.
Proof.
  intros.
  dependent destruction H.
  rewrite sumup_app, sumup_cons; simpl.
  lia.
Defined.

Lemma count_ret:
  forall {t ts g},
  t = (negation ts :: g) ->
  sumup count g < sumup count t.
Proof.
  intros.
  dependent destruction H.
  rewrite sumup_cons; simpl.
  lia.
Defined.

Lemma count_sub:
  forall {t g},
  t = (base :: g) ->
  sumup count g < sumup count t.
Proof.
  intros.
  dependent destruction H.
  rewrite sumup_cons; simpl.
  lia.
Defined.

(*

(* A neutral term should not trigger a reduction interacting with its context.
   So, e.g., in the lambda calculus, they are neither abstractions, which would
   trigger a reduction with ([] x), nor <a, b>, which would trigger a reduction
   with (pi1 []) or (pi2 []). Since the CPS calculus "works at a distance", we
   need something that DOESN'T jump to a set of variables. Luckly, as we're only
   dealing with static contexts, they appear in a row, and so this will work in
   a de Bruijn setting. *)
Inductive neutral: nat -> nat -> pseudoterm -> Prop :=
  | neutral_jump:
    forall k n f xs,
    f < k \/ f >= k + n ->
    neutral k n (jump f xs)
  | neutral_bind:
    forall k n b ts c,
    neutral (S k) n b ->
    neutral (k + length ts) n c ->
    neutral k n (bind b ts c).

Lemma neutral_weaken:
  forall e p k n,
  neutral p (k + n) e -> neutral (p + k) n e.
Proof.
  intros.
  dependent induction H.
  - constructor.
    lia.
  - rename k0 into p.
    constructor; auto.
    + apply IHneutral1; auto.
    + replace (p + k + length ts) with (p + length ts + k); try lia.
      apply IHneutral2; auto.
Qed.

Lemma neutral_context_invalid:
  forall (h: context) k n xs,
  n > 0 ->
  ~neutral k n (h (jump (k + #h) xs)).
Proof.
  induction h; intros.
  - simpl; intro.
    dependent destruction H0.
    lia.
  - simpl; intro.
    dependent destruction H0.
    eapply IHh with (n := n) (k := S k); auto.
    replace (S k + #h) with (k + S #h); try lia.
    eassumption.
  - simpl; intro.
    dependent destruction H0.
    eapply IHh with (n := n) (k := k + length ts); auto.
    replace (k + length ts + #h) with (k + (#h + length ts)); try lia.
    eassumption.
Qed.

*)

Definition candidate: Type :=
  pseudoterm -> Prop.

Definition ARR ts (U V: candidate): candidate :=
  fun b =>
    forall c,
    U c -> V (bind b ts c).

Definition SUB (V: candidate): candidate :=
  fun b =>
    forall x,
    (* TODO: See below: perhaps k<x> { k<y> = c } is better! *)
    V (subst x 0 b).

Definition L: env -> candidate :=
  Fix sumup_count_is_well_founded (fun _ => candidate) (fun t f =>
    match t as x return (t = x -> candidate) with
    (* Given (G, ~T)... *)
    | negation ts :: g =>
      fun H =>
        ARR ts (f _ (count_arg H)) (f _ (count_ret H))
    (* Given (G, b)... *)
    | base :: g =>
      fun H =>
        SUB (f _ (count_sub H))
    (* Empty context means we're done! *)
    | [] =>
      fun _ =>
        SN step
    (* We don't really care about anything else. *)
    | _ =>
      fun _ _ =>
        False
    end eq_refl).

Lemma L_arr_composition:
  forall ts g,
  L (negation ts :: g) = ARR ts (L (ts ++ g)) (L g).
Proof.
  intros.
  unfold L.
  rewrite Fix_eq.
  - fold L.
    reflexivity.
  - intros.
    destruct x; simpl; auto.
    destruct p; simpl; auto.
    + rewrite H.
      reflexivity.
    + do 2 rewrite H.
      reflexivity.
Qed.

Lemma L_sub_composition:
  forall g,
  L (base :: g) = SUB (L g).
Proof.
  intros.
  unfold L.
  rewrite Fix_eq.
  - fold L.
    reflexivity.
  - intros.
    destruct x; simpl; auto.
    destruct p; simpl; auto.
    + rewrite H.
      reflexivity.
    + do 2 rewrite H.
      reflexivity.
Qed.

(* Lemma L_ind:
  forall P: env -> pseudoterm -> Prop,
  forall f1: (forall g e, SN step e -> P g e),
  forall f2: (forall g e,
              (forall x, P g (subst x 0 e)) ->
              P (base :: g) e),
  forall f3: (forall g b ts,
              (forall c, L (ts ++ g) c ->
               P (ts ++ g) c /\ P g (bind b ts c)) ->
              P (negation ts :: g) b),
  forall g e, L g e -> P g e.
Proof.
  intros until g.
  remember (sumup count g) as k.
  generalize dependent g.
  induction k using lt_wf_ind; intros.
  destruct g; intros.
  - apply f1.
    exact H0.
  - destruct p.
    + destruct H0.
    + destruct H0.
    + rewrite L_sub_composition in H0.
      unfold SUB in H0.
      apply f2; intros.
      apply H with (sumup count g); auto.
      rewrite Heqk.
      apply count_sub; auto.
    + destruct H0.
    + destruct H0.
    + rewrite L_arr_composition in H0.
      unfold ARR in H0.
      apply f3; intros.
      split.
      * apply H with (sumup count (ts ++ g)); auto.
        rewrite Heqk; apply count_arg; auto.
      * apply H with (sumup count g); auto.
        rewrite Heqk; eapply count_ret; eauto.
    + destruct H0.
    + destruct H0.
Qed. *)

(*

Record reducible g (P: candidate): Prop := {
  cr1:
    forall e,
    P e -> SN step e;
  cr2:
    forall a b,
    P a -> [a => b] -> P b;
  cr3:
    forall a,
    (* Since the CPS calculus seems to be non-erasing, do we really need to
       restrict ourselves to neutral terms here...? *)
    neutral 0 g a -> (forall b, [a => b] -> P b) -> P a
}.

Lemma cr2_star:
  forall g P,
  reducible g P ->
  forall a b,
  P a -> [a =>* b] -> P b.
Proof.
  induction 3.
  - apply cr2 with g x; auto.
  - assumption.
  - auto.
Qed.

Lemma cr4:
  forall g P,
  reducible g P ->
  forall e,
  normal step e -> neutral 0 g e -> P e.
Proof.
  intros.
  apply cr3 with g; intros.
  - assumption.
  - assumption.
  - exfalso.
    firstorder.
Qed.

Lemma reducible_SN:
  forall g,
  reducible g (SN step).
Proof.
  constructor; intros.
  - assumption.
  - apply H.
    assumption.
  - constructor.
    assumption.
Qed.

Definition free_jump (ts g: env): pseudoterm :=
  jump (length ts + length g) (low_sequence (length ts)).

Lemma reducible_isnt_empty:
  forall R ts g,
  reducible (length ts) R ->
  exists2 c,
  R c & cool ts g c.
Proof.
  intros.
  exists (free_jump ts g).
  - apply cr4 with (length ts).
    + assumption.
    + do 2 intro.
      inversion H0.
    + constructor.
      lia.
  - split.
    + do 2 intro.
      inversion H0.
    + constructor.
      lia.
Qed.

Lemma reducible_ARR:
  forall g ts,
  reducible (length g) (L g) ->
  reducible (length ts) (L ts) ->
  reducible (length (negation ts :: g)) (L (negation ts :: g)).
Proof.
  constructor; intros.
  - rewrite L_composition in H1.
    unfold ARR in H1.
    destruct reducible_isnt_empty with (L ts) ts g as (c, ?, ?); auto.
    (* As in the lambda calculus... but instead of a variable, a free jump. *)
    apply SN_bind_left with ts c.
    apply cr1 with (length g) (L g); auto.
  - rewrite L_composition in H1 |- *.
    unfold ARR in H1 |- *; intros.
    apply cr2 with (length g) (bind a ts c); auto.
    auto with cps.
  - rewrite L_composition in H2 |- *.
    unfold ARR in H2 |- *; intros.
    destruct H3 as ((?, ?), ?).
    (* No need to do induction over SN step c as in the lambda calculus: it's
       already cool down in normal form! *)
    apply cr3 with (length g); intros.
    + assumption.
    + (* NOW this seems correct to me! Check H1 and H4... *)
      constructor; auto.
      apply neutral_weaken with (p := 0); auto.
    + dependent destruction H6.
      * (* It is neutral, so we CAN'T have a redex here! *)
        exfalso.
        eapply neutral_context_invalid with
          (k := 0) (n := S (length g)) (h := h); try lia.
        eassumption.
      * apply H2; firstorder.
      * (* In the lambda calculus we'd use cr2 here. *)
        exfalso.
        firstorder.
Qed.

Lemma reducible_L:
  forall g,
  reducible (length g) (L g).
Proof.
  intros.
  induction sumup_count_is_well_founded with g.
  clear H; rename H0 into H; unfold ltof in H.
  (* Ok, start wordering about the type... *)
  destruct x; try exact reducible_SN.
  - admit.
  - destruct p; try exact reducible_SN.
    + admit.
    + admit.
    + admit.
    + admit.
    + admit.
    + (* "Arrow types", in a way... *)
      eapply reducible_ARR.
      * apply H.
        eapply count_ret; eauto.
      * apply H.
        eapply count_arg; eauto.
    + admit.
    + admit.
Admitted.

Lemma SN_L:
  forall g e,
  L g e -> SN step e.
Proof.
  intros.
  apply cr1 with (length g) (L g); auto.
  apply reducible_L.
Qed.
*)

Goal
  forall A B C,
  let g :=
    [negation A; base; negation B; negation C]
  in L g void.
Proof.
  (* Lets see how things unfold... *)
  intros.
  unfold g.
  rewrite L_arr_composition.
  unfold ARR; intros.
  rewrite L_sub_composition.
  unfold SUB; intros.
  rewrite L_arr_composition.
  unfold ARR; intros.
  rewrite L_arr_composition; intros.
  unfold ARR; intros.
  rename c into a, c0 into b, c1 into c.
  unfold L.
  rewrite Fix_eq.
  - admit.
  - admit.
Admitted.

Lemma SN_L:
  forall g c,
  L g c -> SN step c.
Proof.
  (* Showing that L implies strong normalization seems to be harder than it is
     in the lambda calculus, as expected; perhaps we'll need a different set of
     conditions than the ones used in it. TODO: consider doing what was done in
     Yoshida's paper, as working with terms in normal form may be easier. *)
  admit.
Admitted.

Goal
  forall x c,
  (* Hmm... could this be a better definition? *)
  [bind (jump 0 [lift 1 0 x]) [void] c == subst x 0 c].
Proof.
  intros.
  etransitivity.
  apply sema_recjmp.
  reflexivity.
  simpl.
  rewrite <- lift_distributes_over_subst.
  etransitivity.
  apply sema_gc.
  apply lifting_more_than_n_makes_not_free_n; lia.
  unfold remove_binding.
  rewrite subst_lift_simplification; try lia.
  rewrite lift_zero_e_equals_e.
  reflexivity.
Qed.

Inductive exchange {T}: nat -> relation (list T) :=
  | exchange_head:
    forall x1 x2 xs,
    exchange 0 (x1 :: x2 :: xs) (x2 :: x1 :: xs)
  | exchange_tail:
    forall k x xs1 xs2,
    exchange k xs1 xs2 -> exchange (S k) (x :: xs1) (x :: xs2).

Lemma exchange_sym:
  forall {T} n g h,
  @exchange T n g h -> @exchange T n h g.
Proof.
  induction 1; constructor; auto.
Qed.

Lemma exchange_app:
  forall {T} n g h i,
  @exchange T n h i -> @exchange T (length g + n) (g ++ h) (g ++ i).
Proof.
  induction g; simpl; intros.
  - assumption.
  - constructor; auto.
Qed.

Lemma exchange_preserve_sumup:
  forall {T} f n g h,
  @exchange T n g h ->
  sumup f g = sumup f h.
Proof.
  induction 1; intros.
  - do 4 rewrite sumup_cons.
    lia.
  - do 2 rewrite sumup_cons.
    lia.
Qed.

Ltac do_stuff :=
  simpl;
  try (rewrite lift_bound_ge; [| lia ]);
  simpl;
  try (rewrite lift_bound_lt; [| lia ]);
  simpl;
  try (rewrite subst_bound_gt; [| lia ]);
  simpl;
  try (rewrite subst_bound_eq; [| lia ]);
  simpl;
  try (rewrite subst_bound_lt; [| lia ]);
  simpl;
  try rewrite lift_zero_e_equals_e;
  simpl.

Lemma hmmm:
  forall e x k p,
  subst x k (switch_bindings (k + S p) e) =
    switch_bindings (k + p) (subst (switch_bindings p x) k e).
Proof.
  induction e using pseudoterm_deepind; intros.
  - admit.
  - admit.
  - admit.
  - admit.
  - unfold switch_bindings.
    destruct (lt_eq_lt_dec (2 + k + p) n) as [ [ ? | ? ] | ? ];
    destruct (lt_eq_lt_dec (k + p) n) as [ [ ? | ? ] | ? ];
    destruct (lt_eq_lt_dec k n) as [ [ ? | ? ] | ? ];
    try lia;
    repeat do_stuff; auto.
    f_equal; lia.
    + admit.
    + admit.
  - admit.
  - admit.
  - rewrite switch_bindings_distributes_over_bind.
    do 2 rewrite subst_distributes_over_bind.
    rewrite switch_bindings_distributes_over_bind.
    f_equal.
    + replace (S (k + S p)) with (S k + S p); try lia.
      replace (S (k + p)) with (S k + p); try lia.
      apply IHe1.
    + admit.
    + do 2 rewrite traverse_list_length; simpl.
      replace (k + S p + length ts) with (k + length ts + S p); try lia.
      replace (k + p + length ts) with (k + length ts + p); try lia.
      apply IHe2.
Admitted.

Inductive foobar_inv_case: relation pseudoterm :=
  | foobar_inv_case1:
    foobar_inv_case base base
  | foobar_inv_case2:
    forall ts,
    foobar_inv_case (negation ts) base
  | foobar_inv_case3:
    forall ts,
    foobar_inv_case base (negation ts)
  | foobar_inv_case4:
    forall ts1 ts2,
    foobar_inv_case (negation ts2) (negation ts1).

Lemma foobar_inv:
  forall x1 x2 g,
  valid_env (x1 :: x2 :: g) -> foobar_inv_case x1 x2.
Proof.
  intros.
  dependent destruction H.
  dependent destruction H.
  - dependent destruction H.
    dependent destruction H.
    + constructor.
    + constructor.
    + exfalso.
      eapply typing_bound_cant_be_prop.
      eauto with cps.
  - dependent destruction H0.
    dependent destruction H0.
    + constructor.
    + constructor.
    + exfalso.
      eapply typing_bound_cant_be_prop.
      eauto with cps.
  - exfalso.
    eapply typing_bound_cant_be_prop.
    eauto with cps.
Qed.

Lemma L_weakening:
  forall g e,
  L g e ->
  forall t,
  valid_env (t :: g) ->
  L (t :: g) (lift 1 0 e).
Proof.
  intros.
  dependent destruction H0.
  dependent destruction H0.
  - rewrite L_sub_composition.
    unfold SUB; intros.
    rewrite subst_lift_simplification; try lia.
    rewrite lift_zero_e_equals_e; auto.
  - rewrite L_arr_composition.
    unfold ARR; intros.
    admit.
  - exfalso.
    eapply typing_bound_cant_be_prop.
    eauto with cps.
Admitted.

Lemma L_distr:
  forall g,
  valid_env g -> DISTR (fun a b =>
    L g b -> L g a).
Proof.
  unfold DISTR; intros.
  (* This will be a nightmare in the de Bruijn setting. *)
  admit.
Admitted.

Lemma L_exchange:
  forall g n h,
  exchange n g h ->
  valid_env g ->
  forall e,
  L g e -> L h (switch_bindings n e).
Proof.
  intros g.
  remember (sumup count g) as k.
  generalize dependent g.
  induction k using lt_wf_ind.
  destruct 2; intros.
  - dependent destruction Heqk.
    destruct foobar_inv with x1 x2 xs; auto.
    + do 2 rewrite L_sub_composition in H1 |- *.
      unfold SUB in H1 |- *; intros x y.
      admit.
    + rewrite L_arr_composition in H1.
      rewrite L_sub_composition in H1 |- *.
      rewrite L_arr_composition.
      unfold ARR, SUB in H1 |- *; intros.
      admit.
    + rewrite L_sub_composition in H1.
      rewrite L_arr_composition in H1 |- *.
      rewrite L_sub_composition.
      unfold ARR, SUB in H1 |- *; intros.
      admit.
    + do 2 rewrite L_arr_composition in H1 |- *.
      unfold ARR in H1 |- *; intros c1 ?H c2 ?H.
      (* Steps we need to follow:
           1) By using weakening, H3 can have a negation ts1 added;
           2) By using our IH, we can move it after the ts2, so it'll fit as the
              first argument for H1 (we'll have ts2 ++ negation ts1 ++ xs);
           3) Now we can repeatedly add each of ts1 into H3 by weaneking;
           4) By using our IH, we can move these t1 into the right in H3 (so we
              will have ts2 ++ ts1 ++ xs);
           5) By plugging H3 into H2 (using IH to move negation ts2 right), we
              get enough info for the second argument for H1;
           6) Since switch bindings is involutive, apply it twice on e in H1!

         If I did math correctly in my head, we're left exactly with a (DISTR)!
      *)
      apply L_distr.
      * eauto with cps.
      * (* Clearly, we have simple types... *)
        admit.
      * rewrite switch_bindings_is_involutive.
        replace (traverse_list (lift 1) 0 ts2) with ts2.
        replace (traverse_list remove_binding 0 ts1) with ts1.
        replace (traverse_list (lift (length ts1)) 0 ts2) with ts2.
        apply H1.
        --- admit.
        --- admit.
        --- admit.
        --- admit.
        --- admit.
  - dependent destruction H1.
    assert (valid_env xs1); eauto with cps.
    dependent destruction Heqk.
    dependent destruction H1.
    + rewrite L_sub_composition in H2 |- *.
      unfold SUB in H2 |- *; intros.
      replace (S k0) with (0 + S k0); auto.
      rewrite hmmm.
      apply H with (sumup count g) g.
      * apply count_sub.
        reflexivity.
      * reflexivity.
      * assumption.
      * assumption.
      * apply H2.
    + rename k0 into p.
      rewrite L_arr_composition in H3 |- *.
      unfold ARR in H3 |- *; intros.
      rewrite <- switch_bindings_is_involutive with (k := p).
      eapply H with (sumup count g) g.
      * eapply count_ret.
        reflexivity.
      * reflexivity.
      * assumption.
      * assumption.
      * rewrite switch_bindings_distributes_over_bind.
        (* It appears we'd need a limiting on the dependent case! Or rather, we
           should simply ignore types here, making L a set of untyped terms. *)
        replace (traverse_list switch_bindings p ts) with ts.
        rewrite switch_bindings_is_involutive.
        apply H3.
        eapply H with (sumup count (ts ++ g)) (ts ++ xs2).
        apply count_arg.
        reflexivity.
        eapply exchange_preserve_sumup.
        apply exchange_app.
        eassumption.
        rewrite Nat.add_comm.
        apply exchange_app.
        apply exchange_sym.
        assumption.
        (* Derive from H1 and H2. *)
        admit.
        assumption.
        (* We have simple types. *)
        admit.
    + exfalso.
      eapply typing_bound_cant_be_prop.
      eauto with cps.
Admitted.

Lemma fundamental:
  forall e g,
  typing g e void -> L g e.
Proof.
  induction e; inversion_clear 1.
  (* Case: bound. *)
  - exfalso.
    (* Commands don't have types, but variables do. *)
    eapply typing_bound_cant_be_void.
    eauto with cps.
  (* Case: jump. *)
  - clear IHe.
    dependent destruction H0.
    (* Follows from the structural rules on semantic types! But this will be so
       much painful to prove with de Bruijn indexes... *)
    admit.
  (* Case: bind. *)
  - (* Follows trivially by definition. *)
    specialize (IHe1 (negation ts :: g) H0).
    specialize (IHe2 (ts ++ g) H2).
    rewrite L_arr_composition in IHe1.
    apply IHe1.
    assumption.
Admitted.

Theorem strong_normalization:
  forall g e,
  typing g e void -> SN step e.
Proof.
  intros.
  apply SN_L with g.
  apply fundamental.
  assumption.
Qed.

Corollary consistency:
  forall e,
  ~typing [] e void.
Proof.
  do 2 intro.
  assert (SN step e).
  - apply strong_normalization with [].
    assumption.
  - (* It is closed, so it can't be normalizable! *)
    admit.
Admitted.


Require Import RelationClasses Morphisms Setoid.

From mathcomp Require Import all_ssreflect.

From GraphTheory Require Import edone finite_quotient preliminaries set_tac.
From GraphTheory Require Import digraph sgraph treewidth minor checkpoint.
From GraphTheory Require Import equiv setoid_bigop structures pttdom ptt.
From GraphTheory Require Import mgraph mgraph2 ptt mgraph2_tw2 skeleton.
From GraphTheory Require Import bounded extraction_def extraction_iso excluded.

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

Set Bullet Behavior "Strict Subproofs".

Section ExtractionTop.
Variable sym : Type.
Notation graph := (graph unit (flat sym)).
Notation graph2 := (graph2 unit (flat sym)).
Open Scope ptt_ops.

(** ** Extraction from Disconnected Graphs *)

Arguments iso_id {Lv Le G}.
Arguments merge_union_K_l [Lv Le F K i o h] k.

Lemma iso2_TGT (G : graph2) : top · G · top ≃2 point (G ⊎ g2_top) (inr input) (inr output).
Proof.
  rewrite-> topL, topR => /=.
  Iso2 (iso_sym (union_A _ _ _)).
Qed.

Lemma iso2_GTG (G H : graph2) :
  G · top · H ≃2 point (G ⊎ H) (unl input) (unr output).
Proof.
  rewrite-> topR.
  setoid_rewrite-> (merge_iso2 (iso_sym (union_A _ _ _))) => /=.
  setoid_rewrite-> (merge_iso2 (union_iso iso_id (union_C _ _))) => /=.
  rewrite-> (merge_iso2 (union_A _ _ _)) => /=.
  rewrite-> (merge_union_K_l (fun _ => unr input))=>//.
  2: case; apply/eqquotP; by eqv.
  apply: merge_nothing. by repeat constructor.
Qed.

Lemma par_component (G : graph) (H : graph2) :
  point (G ⊎ g2_top) (inr input) (inr output) ∥ H ≃2 point (G ⊎ H) (inr input) (inr output).
Proof.
  rewrite-> par2C.
  setoid_rewrite-> (merge_iso2 (union_A _ _ _)) =>/=.
  rewrite-> (merge_union_K_l (fun x: two_graph _ _ => if x then unl input else unl output))=>//=.
  setoid_rewrite-> (merge_iso2 (union_C _ _)) =>/=.
  apply merge_nothing. by repeat constructor. by case.
  move => [[]|[]] /=; apply/eqquotP; eqv.
Qed.

Notation induced2 := component.

Lemma component_induced (G : graph2) (C : {set G}) (iC : input \in C) (oC : output \in C) :
  component C = point (induced C) (Sub input iC) (Sub output oC).
Proof.
  rewrite /induced2. move: (setU11 _ _) => A. move: (setU1r _ _) => B. move: A B.
  rewrite (setU1_mem oC) (setU1_mem iC) => A B.
  by rewrite (bool_irrelevance A iC) (bool_irrelevance B oC).
Qed.

Definition component1 (G : graph) (x : G) :=
  point (induced (@component_of (skeleton G) x))
        (Sub x (@in_component_of (skeleton G) x))
        (Sub x (@in_component_of (skeleton G) x)).

Lemma iso2_disconnected_component (G : graph2) x :
  input \in ~: @component_of G x -> output \in ~: @component_of G x ->
  G ≃2 top · (component1 x · top) ∥ component (~: @component_of G x).
Proof.
  move => iC oC. symmetry.
  rewrite (component_induced iC oC).
  set C := component_of _.
  rewrite /component1.
  set G1 := point _ _ _. set G2 := point _ _ _.
  rewrite -> dot2A,iso2_TGT. simpl. setoid_rewrite -> par_component.
  rewrite /G1 /G2 /=.
  have comp_C : C \in @components G [set: G]. apply: component_of_components.
  Iso2 (iso_component comp_C).
Qed.

Lemma iso_disconnected_io (G : graph2) :
  (forall x : G, (x \in @component_of G input) || (x \in @component_of G output)) ->
  output \notin @component_of G input ->
  G ≃2 @component1 G input · (top · @component1 G output).
Proof.
  move => no_comp dis_io. symmetry.
  rewrite -> dot2A. rewrite -> iso2_GTG.
  rewrite {1}/component1. rewrite /=.
  move: (in_component_of _) => I1. move: (in_component_of _) => I2.
  have E : @component_of G output = ~: @component_of G input.
  { apply/setP => z. rewrite inE. apply/idP/idP.
    - move => Z1. apply: contraNN dis_io => Z2.
      by rewrite -(same_component Z2) (same_component Z1).
    - move/(_ z) : no_comp. by case: (z \in _). }
  rewrite E in I2 *.
  move: (@component_of_components G input) => comp_i.
  Iso2 (iso_component comp_i).
Qed.

Lemma CK4F_component (G : graph2) (x : G) :
  K4_free (sskeleton G) -> CK4F (component1 x).
Proof.
  move => K4F_G. split => //.
  - apply: connected_induced. exact: connected_component_of.
  - apply: subgraph_K4_free (sub_pointxx _) _. exact: induced_K4_free.
Qed.

Definition term_of_rec' (t : graph2 -> term sym) (G : graph2) :=
  if [pick x | (input \notin @component_of G x) && (output \notin @component_of G x)] is Some x
  then top · (term_of (component1 x) · top) ∥ t (induced2 (~: component_of x))
  else
    if output \in @component_of G input
    then term_of G
    else term_of (@component1 G input) · (top · term_of (@component1 G output)).

Definition term_of' := Fix top (fun G : graph2 => #|G|) term_of_rec'.

Lemma induced2_compN_small (G : graph2) (x : G) :
  input \notin @component_of G x -> output \notin @component_of G x ->
  #|induced2 (~: @component_of G x)| < #|G|.
Proof.
  move => X1 X2. rewrite /= card_sub. apply: proper_card. apply/properP; split => //.
  - exact/subsetP.
  - exists x => //. rewrite !inE (@in_component_of G) orbF.
    apply/negP => /orP[] /eqP ?; subst; by rewrite (@in_component_of G) in X1 X2.
Qed.

Lemma term_of_rec_eq' (f g : graph2 -> term sym) (G : graph2) :
  (forall H : graph2, #|H| < #|G| -> f H = g H) -> term_of_rec' f G = term_of_rec' g G.
Proof.
  move => Efg. rewrite /term_of_rec'. case: pickP => [x /andP [X1 X2]|//].
  rewrite Efg //. exact: induced2_compN_small.
Qed.

Lemma term_of_eq' G : term_of' G = term_of_rec' term_of' G.
Proof.
  apply Fix_eq with (fun _ => True) => // f g x _ H.
  by apply: term_of_rec_eq'; auto.
Qed.

Theorem term_of_iso' (G : graph2) :
  K4_free (sskeleton G) -> G ≃2 graph_of_term (term_of' G).
Proof.
  elim/card_ind : G => G IH K4F_G.
  rewrite term_of_eq' /term_of_rec'. case: pickP => [x /andP [X1 X2]|H].
  - rewrite /=. rewrite <- term_of_iso, <- IH.
   + apply: iso2_disconnected_component; by rewrite inE.
   + exact: induced2_compN_small.
   + apply: subgraph_K4_free K4F_G. exact: sskeleton_subgraph_for.
   + exact: CK4F_component.
  - case: ifP; last first.
    + move/negbT => io.
      rewrite /=. rewrite <- !term_of_iso; first apply: iso_disconnected_io => //.
      * move => x. move/(_ x) : H. apply: contraFT. rewrite negb_or.
        by rewrite !(@component_exchange G x).
      * exact: CK4F_component.
      * exact: CK4F_component.
    + move => E. apply: term_of_iso. split => //.
      apply: connected_one_component (@component_of_components G input) _.
      apply/subsetP => x _. move/(_ x) : H. apply: contraFT => H.
      rewrite !(component_exchange x) H /=. by rewrite (same_component E).
Qed.

Corollary minor_exclusion_2p (G : graph2) :
  K4_free (sskeleton G) <->
  exists (T : forest) (B : T -> {set G}), [/\ sdecomp T (sskeleton G) B & width B <= 3].
Proof.
  split => [K4F_G|[T [B [B1 B2 B3]]]].
  - have [T [B] [B1 B2]] := (graph_of_TW2 (term_of' G)).
    have I := term_of_iso' K4F_G. symmetry in I. apply sskel_iso2 in I.
    have [D D1 D2] := decomp_iso B1 I.
    exists T. exists D. by rewrite D2.
  - exact: TW2_K4_free B1 B2 B3.
Qed.

End ExtractionTop.

(** Remark: contrary to the textbook definition, we do not substract 1
in the definition of treewidth. Consequently, [width <= 3] means
treewidth two. *)

Corollary graph_minor_TW2 (G : sgraph) :
  K4_free G <->
  exists (T : forest) (B : T -> {set G}), sdecomp T G B /\ width B <= 3.
Proof.
  split=> [| [T][B][]]; last exact: TW2_K4_free.
  case: (posnP #|G|) =>[G_empty | /card_gt0P[x _]].
  { exists tunit; exists (fun _ => [set: G]). split; first exact: triv_sdecomp.
    apply: leq_trans (width_bound _) _. by rewrite G_empty. }
  move=>HG.
  have [G' [iso_G _]] := flesh_out (0 : flat nat) tt x.
  apply (iso_K4_free iso_G) in HG.
  apply minor_exclusion_2p in HG as (T&B&D&W).
  case: (decomp_iso D iso_G) => B' D' W'.
  exists T. exists B'. by rewrite W'.
Qed.

Print Assumptions graph_minor_TW2.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require BuiltIn.
Require real.Real.
Require real.Square.

(* Why3 assumption *)
Definition dot (x1:R) (x2:R) (y1:R) (y2:R): R :=
  ((x1 * y1)%R + (x2 * y2)%R)%R.

(* Why3 assumption *)
Definition norm2 (x1:R) (x2:R): R :=
  ((Reals.RIneq.Rsqr x1) + (Reals.RIneq.Rsqr x2))%R.

Axiom norm2_pos : forall (x1:R) (x2:R), (0%R <= (norm2 x1 x2))%R.

Axiom Lagrange : forall (a1:R) (a2:R) (b1:R) (b2:R), (((norm2 a1
  a2) * (norm2 b1 b2))%R = ((Reals.RIneq.Rsqr (dot a1 a2 b1
  b2)) + (Reals.RIneq.Rsqr ((a1 * b2)%R - (a2 * b1)%R)%R))%R).

Axiom CauchySchwarz_aux : forall (x1:R) (x2:R) (y1:R) (y2:R),
  ((Reals.RIneq.Rsqr (dot x1 x2 y1 y2)) <= ((norm2 x1 x2) * (norm2 y1
  y2))%R)%R.

(* Why3 assumption *)
Definition norm (x1:R) (x2:R): R := (Reals.R_sqrt.sqrt (norm2 x1 x2)).

Axiom norm_pos : forall (x1:R) (x2:R), (0%R <= (norm x1 x2))%R.

Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.99.1," timelimit 3; admit.
Import R_sqrt.

Open Scope R_scope.

(* Why3 goal *)
Theorem sqr_le_sqrt : forall (x:R) (y:R), ((Reals.RIneq.Rsqr x) <= y)%R ->
  (x <= (Reals.R_sqrt.sqrt y))%R.
(* Why3 intros x y h1. *)
intros x y h1.
assert (0 <= Rsqr x) by ae.
assert (0 <= y) by ae.
assert (h : (x < 0 \/ x >= 0)%R).
  ae.
destruct h.
  ae.
replace x with (sqrt (Rsqr x)).
apply sqrt_le_1.
ae.
ae.
ae.
ae.
Admitted.


From Typonomikon Require Import F2.

Unset Guard Checking.
CoFixpoint fib : Stream nat := scons 0 (zipWith plus fib (scons 1 fib)).
Set Guard Checking.

Inductive TXY (X Y A : Type) : Type :=
| ConsXY    : A -> X -> TXY X Y A
| ZipWithXY : (A -> A -> A) -> Y -> Y -> TXY X Y A.
(* | YXY       : Y -> TXY X Y A. *)

Arguments ConsXY    {X Y A} _ _.
Arguments ZipWithXY {X Y A} _ _ _.
(* Arguments YXY       {X Y A} _. *)

Inductive SX (X A : Type) : Type :=
| SConsX    : A -> X -> SX X A
| SZipWithX : (A -> A -> A) -> SX X A -> SX X A -> SX X A.

Arguments SConsX    {X A} _ _.
Arguments SZipWithX {X A} _ _ _.

CoInductive StreamZipWith (A : Type) : Type :=
{
  Out : TXY (StreamZipWith A) (SX (StreamZipWith A) A) A;
}.

Arguments Out {A} _.

Definition ZipWith (A : Type) : Type := SX (StreamZipWith A) A.

Definition StreamZipWith_to_ZipWith {A : Type} (s : StreamZipWith A) : ZipWith A :=
match Out s with
| ConsXY h t      => SConsX h t
| ZipWithXY f l r => SZipWithX f l r
(* | YXY s'          => s' *)
end.

Definition Cons {A : Type} (h : A) (t : StreamZipWith A) : StreamZipWith A :=
{|
  Out := ConsXY h t;
|}.

Definition ZipWith' {A : Type} (f : A -> A -> A) (l r : StreamZipWith A) : StreamZipWith A :=
{|
  Out := ZipWithXY f (StreamZipWith_to_ZipWith l) (StreamZipWith_to_ZipWith r);
|}.

Fixpoint whnf {A : Type} (z : ZipWith A) : A * StreamZipWith A :=
match z with
| SConsX h t      => (h, t)
| SZipWithX f l r =>
  let '(h1, t1) := whnf l in
  let '(h2, t2) := whnf r in
    (f h1 h2, ZipWith' f t1 t2)
end.

CoFixpoint toStream {A : Type} (z : StreamZipWith A) : Stream A :=
match Out z with
| ConsXY h t      => scons h (toStream t)
| ZipWithXY f l r =>
  let (h1, t1) := whnf l in
  let (h2, t2) := whnf r in
    scons (f h1 h2) (toStream (ZipWith' f t1 t2))
(* | YXY s' => *)
(*         let (h, t) := whnf s' in scons h (toStream t) *)
end.

CoFixpoint fibSZW : StreamZipWith nat.
Proof.
  apply (Cons 0).
  refine {| Out := ZipWithXY plus _ _ |}.
    exact (StreamZipWith_to_ZipWith fibSZW).
    exact (SConsX 1 fibSZW).
Abort.

(* Compute take 5 (toStream fibSZW). *)


Load GradVer14LemmaAliasing.
(* Load GradVer12LemmaFootprint. *)
Import Semantics.

Definition phiOrthogonal (p1 p2 : phi) := disjoint (FV p1) (FV p2).

Definition phiIsIndependentVar (x : x) (p : phi) := forall H r A v,
  evalphi H r A p -> evalphi H (rhoSubst x v r) A p.

Lemma phiImpliesSatisfiable : forall p1 p2,
  phiImplies p1 p2 ->
  phiSatisfiable p1 ->
  phiSatisfiable p2.
Proof.
  unfold phiImplies, phiSatisfiable.
  intros.
  unf.
  repeat eexists.
  apply H0.
  eauto.
Qed.

Lemma phiSatisfiableAppComm : forall p1 p2,
  phiSatisfiable (p1 ++ p2) ->
  phiSatisfiable (p2 ++ p1).
Proof.
  unfold phiSatisfiable; intros.
  unf.
  repeat eexists.
  apply evalphiSymm.
  eassumption.
Qed.

Lemma phiFVorIsIndependentVar : forall x p,
  phiIsIndependentVar x p \/ In x (FV p).
Proof.
  intros.
  assert (CL := classic (In x0 (FV p0))).
  intuition.
  constructor.
  unfold phiIsIndependentVar.
  intros.
  apply evalphiRemoveRhoSubst;
  intuition.
Qed.

Lemma phiOrthogonalityImpliesIndependence : forall p1 p2 x,
    phiOrthogonal p1 p2 ->
    In x (FV p1) ->
    phiIsIndependentVar x p2.
Proof.
  intros.
  unfold phiOrthogonal, disjoint in *.
  specialize (H0 x0).
  assert (CL := phiFVorIsIndependentVar x0 p2).
  intuition.
Qed.

Lemma disjointAppA : forall {T : Type} (p1a p1b p2 : list T),
  disjoint (p1a ++ p1b) p2 <->
  disjoint p1a p2 /\
  disjoint p1b p2.
Proof.
  unfold disjoint in *.
  split; intros.
  - split; intros; specialize (H0 x0); intuition.
  - intuition.
    rewrite in_app_iff.
    specialize (H1 x0).
    specialize (H2 x0).
    intuition.
Qed.

Lemma phiOrthogonalAppA : forall p1a p1b p2,
  phiOrthogonal (p1a ++ p1b) p2 <->
  phiOrthogonal p1a p2 /\
  phiOrthogonal p1b p2.
Proof.
  unfold phiOrthogonal in *.
  intros;
  rewrite FVApp in *.
  apply disjointAppA.
Qed.

Definition vWithOmap (omap : o -> o) (v' : v) : v :=
  match v' with
  | vo o => vo (omap o)
  | _ => v'
  end.
Definition rhoWithOmap (omap : o -> o) (r : rho) : rho :=
  fun x => option_map
           (vWithOmap omap)
           (r x).

(* Definition colocateH (H0 H1 : H) := λ o : nat,
       match modulo o 2 with
       | 0 => H0 (div o 2)
       | Datatypes.S _ => H1 (div (o - 1) 2)
       end.

Definition colocateRho (xs0 : list x) (r0 r1 : rho) := λ x,
       if existsb (x_decb x) xs0
       then rhoWithOmap (λ o, 2 * o) r0 x
       else rhoWithOmap (λ o, 2 * o + 1) r1 x.

Definition colocateAccess (A0 A1 : A_d) :=
    map (fun x => (2 * (fst x)    , snd x)) A0 ++
    map (fun x => (2 * (fst x) + 1, snd x)) A1. *)

(* Require Import Coq.Logic.FunctionalExtensionality.

Lemma colocateRhoEmpty : forall r0 r1,
  colocateRho [] r0 r1 = rhoWithOmap (λ o, 2 * o + 1) r1.
Proof.
  intros.
  unfold colocateRho.
  apply functional_extensionality.
  simpl.
  tauto.
Qed. *)

(*
Lemma phiSatisfiableAppHelper : forall p0 p1 H0 H1 r0 r1 A0 A1,
  (∀ x, ¬ In x (FV p0) ∨ ¬ In x (FV p1)) ->
  evalphi H0 r0 A0 p0 ->
  evalphi H1 r1 A1 p1 ->
  evalphi
    (colocateH H0 H1)
    (colocateRho (FV p0) r0 r1)
    (colocateAccess A0 A1)
    (p0 ++ p1).
Proof.
  induction p0.
  - induction p1; intros; simpl in *; try constructor.
    inversionx H4.
    eca.
    * apply incl_appr.
      generalize A1 H2 H9. clear.
      induction A1; intros; simpl in *.
Admitted.

Lemma phiSatisfiableApp : forall p0 p1,
  phiOrthogonal p0 p1 ->
  phiSatisfiable p0 ->
  phiSatisfiable p1 ->
  phiSatisfiable (p0 ++ p1).
Proof.
  intros; simpl in *;
  intuition.
  unfold phiOrthogonal, disjoint, phiSatisfiable in *.
  unf.
  repeat eexists.
  eapply phiSatisfiableAppHelper; eauto.
Qed.

Lemma phiSatisfiableAppRev : forall p0 p1,
  phiSatisfiable (p0 ++ p1) ->
  phiSatisfiable p0 /\ phiSatisfiable p1.
Proof.
  unfold phiSatisfiable.
  intros.
  unf.
  split; repeat eexists.
  - eapply evalphiPrefix. eauto.
  - eapply evalphiSuffix. eauto.
Qed.

(**)
Lemma evale'RemoveRhoSubstsVo : forall h r r' e o,
  evale' h (rhoSubsts (FVe e) r' r) e = Some (vo o) <->
  evale' h r' e = Some (vo o).
Proof.
  induction e0; intros; simpl in *.
  - tauto.
  - unfold rhoSubst.
    dec (x_dec x0 x0).
    destruct (r' x0); simpl; split; intros; try tauto; inversion H0.
  - destruct (evale' h r' e0);
    destruct (evale' h (rhoSubsts (FVe e0) r' r) e0);
    try destruct v0;
    try destruct v1;
    try tauto;
    specialize (IHe0 o1); unf; intuition;
    inversionx H2;
    assumption.
Qed.

Lemma footprint'RemoveRhoSubsts2 : forall h r r' p,
  footprint' h (rhoSubsts (FV' p) r' r) p =
  footprint' h r' p.
Proof.
  intros.
  destruct p0; simpl; try tauto.
  assert (ee := evale'RemoveRhoSubstsVo h r r' e0).
  destruct (evale' h r' e0);
  destruct (evale' h (rhoSubsts (FVe e0) r' r) e0);
  try destruct v0;
  try destruct v1;
  try tauto;
  specialize (ee o0);
  intuition;
  inversionx H2.
  tauto.
Qed.

(**)
Definition rhoDefinedAt (r : rho) (xs : list x) :=
  forall x, In x xs -> exists v, r x = Some v.

Lemma evaleRhoDefinedAt : forall H r e v,
  evale H r e v ->
  rhoDefinedAt r (FVe e).
Proof.
  unfold rhoDefinedAt.
  induction e0;
  intros;
  common;
  simpl in *.
  - inversion H2.
  - intuition.
    subst.
    eexists.
    eauto.
  - destruct (evale' H0 r e0) eqn: eve; inversionx H1.
    eapply IHe0; auto.
    unfold evale.
    eauto.
Qed.

Lemma evalphi'RhoDefinedAt : forall H r A p,
  evalphi' H r A p ->
  rhoDefinedAt r (FV' p).
Proof.
  unfold rhoDefinedAt.
  intros.
  inversionx H1;
  simpl in *.
  - inversion H2.
  - apply evaleRhoDefinedAt in H4.
    apply evaleRhoDefinedAt in H5.
    specialize (H4 x0).
    specialize (H5 x0).
    apply in_app_iff in H2.
    intuition.
  - apply evaleRhoDefinedAt in H4.
    apply evaleRhoDefinedAt in H5.
    specialize (H4 x0).
    specialize (H5 x0).
    apply in_app_iff in H2.
    intuition.
  - apply evaleRhoDefinedAt in H4.
    intuition.
  - intuition.
    subst.
    eexists.
    eauto.
Qed.

Lemma rhoDefinedAtIncl : forall xs2 r xs1,
  incl xs2 xs1 ->
  rhoDefinedAt r xs1 ->
  rhoDefinedAt r xs2.
Proof.
  unfold incl, rhoDefinedAt.
  intros.
  apply H1.
  apply H0.
  assumption.
Qed.

Lemma rhoSubstsId : forall r r' x xs,
  rhoDefinedAt r' xs ->
  In x xs ->
  rhoSubsts xs r' r x = r' x.
Proof.
  induction xs;
  intros;
  inversionx H1.
  - unfold rhoSubsts.
    simpl.
    rewrite rhoSubstId.
    assert (In x0 (x0 :: xs)). constructor. tauto.
    apply H0 in H1.
    unf.
    rewrite H2.
    auto.
  - simpl.
    eapply (rhoDefinedAtIncl xs) in H0; try (apply incl_tl; apply incl_refl).
    unfold rhoSubst.
    dec (x_dec x0 a).
    * apply H0 in H2.
      unf.
      rewrite H1.
      tauto.
    * apply IHxs; auto.
Qed.

Lemma evale'RemoveRhoSubsts2 : forall h xs r r' e,
  rhoDefinedAt r' xs ->
  incl (FVe e) xs ->
  evale' h (rhoSubsts xs r' r) e =
  evale' h r' e.
Proof.
  induction e0;
  intros;
  simpl in *;
  auto.
  - apply inclSingle in H1.
    apply rhoSubstsId; auto.
  - rewrite IHe0; auto.
Qed.

Lemma evalphi'RemoveRhoSubsts2 : forall h p r r' a,
  rhoDefinedAt r' (FV' p) ->
  evalphi' h (rhoSubsts (FV' p) r' r) a p <->
  evalphi' h r' a p.
Proof.
  split;
  intros.
  - inversionx H1;
    econstructor;
    unfold evale in *;
    eauto.
  * erewrite evale'RemoveRhoSubsts2 in H3; eauto.
    simpl.
    intuition.
  * erewrite evale'RemoveRhoSubsts2 in H4; eauto.
    simpl.
    intuition.
  * erewrite evale'RemoveRhoSubsts2 in H3; eauto.
    simpl.
    intuition.
  * erewrite evale'RemoveRhoSubsts2 in H4; eauto.
    simpl.
    intuition.
  * apply evale'RemoveRhoSubstsVo in H3.
    assumption.
  * erewrite rhoSubstsId in H3; eauto.
    simpl.
    intuition.
  - inversionx H1;
    econstructor;
    unfold evale in *;
    eauto;
    try (erewrite evale'RemoveRhoSubsts2; eauto; simpl; intuition);
    try (erewrite rhoSubstsId           ; eauto; simpl; intuition).
Qed.

Lemma inclAexcept2 : forall a a1 a2,
  incl a1 a2 ->
  incl (Aexcept a1 a) (Aexcept a2 a).
Proof.
  unfold incl, Aexcept, except.
  intros.
  apply filter_In.
  apply filter_In in H1.
  intuition.
Qed.

Lemma evalphiAccessIncl : forall p h r a1 a2,
  incl a1 a2 ->
  evalphi h r a1 p ->
  evalphi h r a2 p.
Proof.
  induction p0;
  intros;
  try constructor.
  inversionx H1.
  eca.
  - eapply incl_tran; eauto.
  - eapply IHp0; eauto.
    apply inclAexcept2.
    assumption.
Qed.

(* Definition invNoAlias
  (Heap : H) (rho : rho) (A : A_d) (phi : phi) : Prop :=
    let sfp := staticFootprint phi in
      forall f x1 x2,
        In (e1, f) sfp ->
        In (e2, f) sfp ->
        evale H rho e1 <> rho x2. *)

(* x = 3 * x = y => y = 3 *)
(* BUT NOT x = y => y = 3 *)

(* x = 3 * y = 3 => y = 3 *)
(* BUT NOT x = y => y = 3 *)

(* x = 3 * x = y => y : int *)
(* BUT NOT x = y => y : int *)

 (*
Lemma phiImpliesNarrowingSingle : forall p p1 p2,
  phiOrthogonal [p] p2 ->
  phiSatisfiable (p :: p1) ->
  phiImplies (p :: p1) p2 ->
  phiImplies p1 p2.
Proof.
  intros.
  unfold phiOrthogonal, phiSatisfiable, phiImplies in *.
  unf.
  simpl in *.
  rewrite app_nil_r in *.
  intros.
  specialize (H2 h (rhoSubsts (FV' p0) x1 r) (footprint' h x1 p0 ++ a)).
  rewrite (evalphiRemoveRhoSubsts p2) in H2; auto.
  eapply evalphiAccessIncl; eauto.

  eauto.

  assert (evalphi h r (footprint' h x1 p0 ++ a) p2 = evalphi h r a p2) as xxx. admit.
  rewrite xxx in *. clear xxx.

  apply H2.
  eca.
  - rewrite footprint'RemoveRhoSubsts2.
    intuition.
  - rewrite footprint'RemoveRhoSubsts2.
    rewrite evalphi'RemoveRhoSubsts2.
  * inversionx H3. admit.
  * inversionx H3.
    eapply evalphi'RhoDefinedAt.
    eauto.
  - rewrite footprint'RemoveRhoSubsts2.

  assert (disj)
  (*show that x2 is irrelevant for access to p2's expressions*)
Admitted.

Lemma phiImpliesNarrowing : forall p0 p1 p2,
  phiOrthogonal p0 p2 ->
  phiSatisfiable (p0 ++ p1) ->
  phiImplies (p0 ++ p1) p2 ->
  phiImplies p1 p2.
Proof.
  induction p0;
  intros;
  simpl in *;
  try assumption.
  assert (Hsat := H1).
  rewrite cons2app in H0.
  rewrite cons2app in H1.
  apply phiOrthogonalAppA in H0.
  apply phiSatisfiableAppRev in H1.
  unf.
  apply IHp0; auto.
  eapply phiImpliesNarrowingSingle; eauto.
Qed.

Lemma phiImpliesNarrowingSingleNeqNull : forall p p1 e,
  disjoint (FV' p) (FVe e) ->
  phiSatisfiable (p :: p1) ->
  phiImplies (p :: p1) [phiNeq e (ev vnull)] ->
  phiImplies p1 [phiNeq e (ev vnull)].
Proof.
  intros.
  unfold phiSatisfiable, phiImplies in *.
  unf.
  intros.
  specialize (H2 x0 (rhoSubsts (FV' p0) x1 r) x2).

  eca;
  simpl.
  - apply inclEmpty.
  - eca; unfold evale; simpl; eauto.
Admitted.*)

Definition envIdenticalAt
  (xs : list x)
  (H0 : H) (r0 : rho) (A0 : A_d)
  (H1 : H) (r1 : rho) (A1 : A_d) : Prop :=
  (forall x, In x xs -> r0 x = r1 x) /\
  (forall o, (exists x, r0 x = Some (vo o)) ->
    H0 o = H1 o /\
    forall f, In (o, f) A0 <-> In (o, f) A1).
Definition envEqualsAt
  (xs : list x)
  (H0 : H) (r0 : rho) (A0 : A_d)
  (H1 : H) (r1 : rho) (A1 : A_d) : Prop :=
  forall (p : phi),
    incl (FV p) xs ->
    (evalphi H0 r0 A0 p <-> evalphi H1 r1 A1 p).

(* Lemma envIdenticalEquals : forall xs H0 r0 A0 H1 r1 A1,
  envIdenticalAt xs H0 r0 A0 H1 r1 A1 ->
  envEqualsAt    xs H0 r0 A0 H1 r1 A1.
Proof.
  unfold envIdenticalAt, envEqualsAt.
  induction xs;
  intros;
  simpl in *.
  - generalize p0 H3. clear.
    induction p0; intros; try (split; intros; constructor).
    simpl in *.
    assert (incl (FV p0) []). unfold incl in *. intuition.
    assert (incl (FV' a) []). unfold incl in *. intuition.
    intuition.
    * .
    destruct p0; try (split; intros; constructor).
    simpl in *.

    rewrite inclEmptyFalse in H3.
  unfold  *)

(*colocate H r A without touching , so that p still holds, *)
Lemma evalphiRelocate : forall xs H1 r1 A1 H0 r0 A0 p,
  disjoint xs (FV p) ->
  evalphi H0 r0 A0 p ->
  exists Hx rx Ax,
    evalphi Hx rx Ax p /\
    envEqualsAt xs H1 r1 A1 Hx rx Ax.
Proof.
  induction xs; intros; simpl in *.
  - repeat eexists; eauto.
Admitted.

Lemma evalphiAppRev : ∀ (p1 p2 : list phi') (H : H) (r : rho) (A : A_d),
      evalphi H r A p1 ∧ evalphi H r (Aexcept A (footprint H r p1)) p2
      -> evalphi H r A (p1 ++ p2).
Proof.
  induction p1; intros; simpl in *; unf.
  - common.
    assumption.
  - inversionx H2.
    eca.
    apply IHp1.
    rewrite AexceptApp.
    intuition.
Qed.

Lemma phiImpliesNarrowing : forall p0 p1 p2,
  phiOrthogonal p1 p0 ->
  phiOrthogonal p2 p0 ->
  phiSatisfiable p0 ->
  phiSatisfiable p1 ->
  phiImplies (p0 ++ p1) p2 ->
  phiImplies p1 p2.
Proof.
  unfold phiImplies. intros.
  unfold phiSatisfiable in H2.
  unf.
  assert (disjoint (FV p1 ++ FV p2) (FV p0)).
    unfold phiOrthogonal in *.
    rewrite disjointAppA.
    auto.
  eapply (evalphiRelocate (FV p1 ++ FV p2) h r a) in H6; auto.
  unf.
  specialize (H4 x3 x4 x5).
  assert (incl (FV p1) (FV p1 ++ FV p2)). intuition.
  assert (incl (FV p2) (FV p1 ++ FV p2)). intuition.
  assert (evalphi x3 x4 x5 (p0 ++ p1)).
    apply evalphiAppRev.
    intuition.
    specialize (H8 p1).
    intuition.
Admitted.

(* x = 3 * x = y => y = 3 *)
(* BUT NOT x = y => y = 3 *)

(* x = 3 * x = y => y : int *)
(* BUT NOT x = y => y : int *)

Lemma hasStaticTypeNarrowing : forall p0 p1 e T,
  disjoint (FV p1) (FV p0) ->
  disjoint (FVe e) (FV p0) ->
  phiSatisfiable p0 ->
  phiSatisfiable p1 ->
  hasStaticType (p0 ++ p1) e T ->
  hasStaticType p1 e T.
Proof.
  induction e0;
  intros;
  inversionx H4;
  try constructor.
  - eapply phiImpliesNarrowing; eauto.
  - eca.
    eapply phiImpliesNarrowing; eauto.
    unfold phiOrthogonal.
    simpl in *.
    repeat rewrite app_nil_r.
    assumption.
Qed.

(*extract to other lemmas*)
Lemma hasStaticTypePhiComm : forall p0 p1 e T,
  hasStaticType (p0 ++ p1) e T ->
  hasStaticType (p1 ++ p0) e T.
Proof.
  induction e0;
  intros;
  inversionx H0;
  try constructor.
  - apply phiImpliesAppCommA.
    assumption.
  - eca.
    apply phiImpliesAppCommA.
    assumption.
Qed.

*)


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

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

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

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

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

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

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

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

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. lfind. Admitted.


Set Implicit Arguments.
(* Load the CFML library. *)
Require Import CFML.CFLib.
Require Import CFML.Stdlib.Array_proof CFML.Stdlib.Pervasives_proof.
Require Import TLC.LibListZ.
(* Load the examples CF definitions. *)
Require Import PairInsertionSort_funs_ml.

Require Import Permutation.
Hint Constructors Permutation.
Hint Constructors Forall.
Ltac auto_tilde ::= rew_list in *; eauto with maths.

Definition sorted (l : list int) :=
  forall i, 0 <= i -> i < length l - 1 -> l[i] <= l[i+1].

Lemma insert_spec : forall al jr
  (l1 h l2 : list int) (x : int) (j : int) (shift : int),
  app insert [al x jr shift]
    PRE (al ~> Array (l1 ++ h ++ l2) \* jr ~~> j \*
         \[ shift > 0 /\ length l1 = j + 1 /\ length h = shift /\ sorted l1 ])
    POST (fun (t : unit) =>
      Hexists l1a h' l1b j',
      al ~> Array (l1a ++ h' ++ x :: l1b ++ l2) \* jr ~~> j' \*
      \[ length l1a = j' + 1 /\ length h' = shift - 1 /\ l1a ++ l1b = l1 /\
         sorted (l1a ++ x :: l1b)]).
Proof.
  introv.
  xcf.
  xpull; intros; unpack.
  xwhile_inv_basic (fun (b : bool) (m : int) =>
    Hexists l1a h' l1b,
      al ~> Array (l1a ++ h' ++ l1b ++ l2) \*
      jr ~~> m \*
      \[ m + 1 = length l1a /\
         length h' = shift /\
         l1 = l1a ++ l1b /\
         Forall (fun z => z > x) l1b /\
         b = isTrue (m >= 0 /\ l1a[m] > x) ]) (downto (-1)).
  - hsimpl (>> __ j l1 h (@nil int)).
    splits~.
  - intros b m.
    xpull.
    intros l1a h' l1b ?.
    unpack.
    xapps.
    xand.
    + xapps. xapps.
      { apply~ index_of_inbound. }
      xrets.
      splits~.
      rewrite~ read_app.
      assert (m < length l1a) by math.
      case_if~. splits~.
    + xsimpl. splits~.
  - intros m. xpull.
    intros l1a h' l1b ?.
    unpack.
    xapps. xapps.
    { apply~ index_of_inbound. }
    xapps. xapps.
    { apply~ index_of_inbound. }
    xapps.
    rew_bool_eq in *. unpack.
    forwards~[y [l1a' ->]]: (length_pos_inv_last l1a).
    forwards~[s [hs ->]]: (length_pos_inv_last h').
    xsimpl~ __ (m - 1) l1a' (y :: hs) (y :: l1b).
    { rewrite~ read_middle.
      rewrite update_app_r with (i := m) (j := shift); auto_tilde.
      rewrite~ update_cons_pos.
      rewrite update_app_r with (i := shift - 1) (j := 0); auto_tilde.
      rewrite~ update_zero. }
    splits~. constructor~.
    rewrite~ read_middle in H8.
  - intros m l1a h' l1b ?.
    unpack.
    xapps.
    xapps.
    { apply~ index_of_inbound. }
    forwards~[s [hs ->]]: (length_pos_inv_last h').
    xsimpl~ l1a hs l1b m.
    { rewrite update_app_r with (i := m + 1) (j := shift - 1); auto_tilde.
      rewrite update_app_r with (i := shift -1) (j := 0); auto_tilde.
      rewrite ~ update_zero. }
    splits~.
    admit.
Qed.

Lemma sort_spec : forall a (L : list int),
  app sort [a]
    PRE (a ~> Array L)
    POST (fun (t : unit) => Hexists L', a ~> Array L' \* \[sorted L' /\ Permutation L L']).
Proof.
  introv.
  xcf.
  xapp as ir.
  xwhile_inv_basic_measure (fun (b:bool) (m:int) =>
    Hexists L1 L2 i,
    a ~> Array (L1 ++ L2) \*
    ir ~~> i \*
    \[ m = length L2 /\ length L1 = i /\ sorted L1 /\ Permutation L (L1 ++ L2) /\
       b = isTrue (m > 1) ]
  ).
  - hsimpl __ (@nil int) L.
    splits~. admit. (* nil is sorted *)
  - intros b m.
    xpull.
    intros l1 l2 i ?.
    unpack.
    xapps.
    xapps.
    xrets.
    splits~.
    splits~.
  - intros m.
    xpull. intros l1 l2 i ?.
    unpack.
    xapps. xapps.
    { apply~ index_of_inbound. }
    xapps. xapps. xapps.
    { apply~ index_of_inbound. }
    xapps. xapps. xapps.
    rew_bool_eq in H3.
    destruct l2 as [ | x1 [ | x2 l2]];
    try solve [false~; math].
    rewrite~ read_middle.
    assert ((l1 ++ x1 :: x2 :: l2)[i + 1] = x2) as ->.
    { rewrite~ read_app.
      case_if~. rewrite~ read_cons_case.
      case_if~. rewrite~ read_cons_case.
      case_if~. }
    xseq (ir ~~> i \* a ~> Array (l1 ++ x1 :: x2 :: l2) \*
      Hexists xv yv, x ~~> xv \* y ~~> yv \* \[yv <= xv /\
      Permutation (xv :: yv :: nil) (x1 :: x2 :: nil)]).
    { xif.
      - xapps. xapps. xapps. xapps.
        xsimpl~.
      - xrets~. }
    intros xv yv Hxy.
    xapps. xapps. xapps.

    xapp_spec~ insert_spec (>> __ (x1 :: x2 :: nil)).
    intros l1a h' l1b j' ?.
    unpack.
    assert (length h' = 1) by auto_tilde; clear H5.
    xapps.

    xapp_spec~ insert_spec (>> l1a h' (xv :: l1b ++ l2)).
    { splits~. admit. }
    intros l1a' h'' l1b' j'' ?.
    unpack.
    assert (h'' = nil) as -> by apply~ length_zero_inv; clear H11.

    xapps. xapps.
    xsimpl~ __ (m - 2) (l1a' ++ yv :: l1b' ++ xv :: l1b) l2.
    subst~.
    splits~.
    + admit.
    + admit.
  - intros m l1 l2 i ?.
    unpack.
    xapps. xapps. xrets.
    xif.
    + xapps. xapps.
      { apply~ index_of_inbound. }
      xapps. xapps.
      destruct l2 as [ | x [ | ]]; try solve [false~; math].
      rewrite~ read_last_case.
      case_if~.

      xapp_spec~ insert_spec (>> __ (x :: nil)).
      xpull.
      intros l1a h l1b j' ?.
      unpack.
      xsimpl~.
      assert (h = nil) as -> by apply~ length_zero_inv.
      splits~.
      admit.
    + xrets.
      assert (l2 = nil) as -> by apply~ length_zero_inv.
      splits~.
Qed.


(** Operations on the [FSet A] for an arbitrary [A] *)
Require Import HoTT HitTactics prelude.
Require Import kuratowski_sets monad_interface extensionality
        list_representation.isomorphism list_representation.list_representation.

Section operations.
  (** Monad operations. *)
  Definition fset_fmap {A B : Type} : (A -> B) -> FSet A -> FSet B.
  Proof.
    intro f.
    hrecursion.
    - exact ∅.
    - apply (fun a => {|f a|}).
    - apply (∪).
    - apply assoc.
    - apply comm.
    - apply nl.
    - apply nr.
    - apply (idem o f).
  Defined.

  Global Instance fset_pure : hasPure FSet.
  Proof.
    split.
    apply (fun _ a => {|a|}).
  Defined.

  Global Instance fset_bind : hasBind FSet.
  Proof.
    split.
    intros A.
    hrecursion.
    - exact ∅.
    - exact idmap.
    - apply (∪).
    - apply assoc.
    - apply comm.
    - apply nl.
    - apply nr.
    - apply union_idem.
  Defined.

  (** Set-theoretical operations. *)
  Global Instance fset_comprehension : forall A, hasComprehension (FSet A) A.
  Proof.
    intros A P.
    hrecursion.
    - apply ∅.
    - intro a.
      refine (if (P a) then {|a|} else ∅).
    - apply (∪).
    - apply assoc.
    - apply comm.
    - apply nl.
    - apply nr.
    - intros; simpl.
      apply union_idem.
  Defined.

  Definition single_product {A B : Type} (a : A) : FSet B -> FSet (A * B).
  Proof.
    hrecursion.
    - apply ∅.
    - intro b.
      apply {|(a, b)|}.
    - apply (∪).
    - apply assoc.
    - apply comm.
    - apply nl.
    - apply nr.
    - intros.
      apply idem.
  Defined.

  Definition product {A B : Type} : FSet A -> FSet B -> FSet (A * B).
  Proof.
    intros X Y.
    hrecursion X.
    - apply ∅.
    - intro a.
      apply (single_product a Y).
    - apply (∪).
    - apply assoc.
    - apply comm.
    - apply nl.
    - apply nr.
    - intros ; apply union_idem.
  Defined.

  Definition disjoint_sum {A B : Type} (X : FSet A) (Y : FSet B) : FSet (A + B) :=
    (fset_fmap inl X) ∪ (fset_fmap inr Y).

  Local Ltac remove_transport
    := intros ; apply path_forall ; intro Z ; rewrite transport_arrow
       ; rewrite transport_const ; simpl.
  Local Ltac pointwise
    := repeat (f_ap) ; try (apply path_forall ; intro Z2) ;
      rewrite transport_arrow, transport_const, transport_sigma
      ; f_ap ; hott_simpl ; simple refine (path_sigma _ _ _ _ _)
      ; try (apply transport_const) ; try (apply path_ishprop).

  Context `{Univalence}.

  (** Separation axiom for finite sets. *)
  Definition separation (A B : Type) : forall (X : FSet A) (f : {a | a ∈ X} -> B), FSet B.
  Proof.
    hinduction.
    - intros f.
      apply ∅.
    - intros a f.
      apply {|f (a; tr idpath)|}.
    - intros X1 X2 HX1 HX2 f.
      pose (fX1 := fun Z : {a : A & a ∈ X1} => f (pr1 Z;tr (inl (pr2 Z)))).
      pose (fX2 := fun Z : {a : A & a ∈ X2} => f (pr1 Z;tr (inr (pr2 Z)))).
      specialize (HX1 fX1).
      specialize (HX2 fX2).
      apply (HX1 ∪ HX2).
    - remove_transport.
      rewrite assoc.
      pointwise.
    - remove_transport.
      rewrite comm.
      pointwise.
    - remove_transport.
      rewrite nl.
      pointwise.
    - remove_transport.
      rewrite nr.
      pointwise.
    - remove_transport.
      rewrite <- (idem (Z (x; tr 1%path))).
      pointwise.
  Defined.

  (** [FSet A] has decidable emptiness. *)
  Definition isEmpty {A : Type} (X : FSet A) : Decidable (X = ∅).
  Proof.
    hinduction X ; try (intros ; apply path_ishprop).
    - apply (inl idpath).
    - intros.
      refine (inr (fun p => _)).
      refine (transport (fun Z : hProp => Z) (ap (fun z => a ∈ z) p) _).
      apply (tr idpath).
    - intros X Y H1 H2.
      destruct H1 as [p1 | p1], H2 as [p2 | p2].
      * left.
        rewrite p1, p2.
        apply nl.
      * right.
        rewrite p1, nl.
        apply p2.
      * right.
        rewrite p2, nr.
        apply p1.
      * right.
        intros p.
        apply p1.
        apply fset_ext.
        intros.
        apply path_iff_hprop ; try contradiction.
        intro H1.
        refine (transport (fun z => a ∈ z) p _).
        apply (tr(inl H1)).
  Defined.
End operations.

Section operations_decidable.
  Context {A : Type}.
  Context `{MerelyDecidablePaths A}.
  Context `{Univalence}.

  Global Instance isIn_decidable (a : A) : forall (X : FSet A),
      Decidable (a ∈ X).
  Proof.
    hinduction ; try (intros ; apply path_ishprop).
    - apply _.
    - apply (m_dec_path _).
    - apply _.
  Defined.

  Global Instance fset_member_bool : hasMembership_decidable (FSet A) A :=
    fun a X =>
      match (dec a ∈ X) with
      | inl _ => true
      | inr _ => false
      end.

  Global Instance subset_decidable : forall (X Y : FSet A), Decidable (X ⊆ Y).
  Proof.
    hinduction ; try (intros ; apply path_ishprop).
    - apply _.
    - apply _.
    - unfold subset in *.
      apply _.
  Defined.

  Global Instance fset_subset_bool : hasSubset_decidable (FSet A).
  Proof.
    intros X Y.
    apply (if (dec (X ⊆ Y)) then true else false).
  Defined.

  Global Instance fset_intersection : hasIntersection (FSet A)
    := fun X Y => {|X & (fun a => a ∈_d Y)|}.

  Definition difference := fun X Y => {|X & (fun a => negb a ∈_d Y)|}.
End operations_decidable.

Section FSet_cons_rec.
  Context `{A : Type}.

  Variable (P : Type)
           (Pset : IsHSet P)
           (Pe : P)
           (Pcons : A -> FSet A -> P -> P)
           (Pdupl : forall X a p, Pcons a ({|a|} ∪ X) (Pcons a X p) = Pcons a X p)
           (Pcomm : forall X a b p, Pcons a ({|b|} ∪ X) (Pcons b X p)
                                           = Pcons b ({|a|} ∪ X) (Pcons a X p)).

  Definition FSet_cons_rec (X : FSet A) : P :=
    FSetC_prim_rec A P Pset Pe
                   (fun a Y p => Pcons a (FSetC_to_FSet Y) p)
                   (fun _ _ => Pdupl _ _)
                   (fun _ _ _ => Pcomm _ _ _)
                   (FSet_to_FSetC X).

  Definition FSet_cons_beta_empty : FSet_cons_rec ∅ = Pe := idpath.

  Definition FSet_cons_beta_cons (a : A) (X : FSet A)
    : FSet_cons_rec ({|a|} ∪ X) = Pcons a X (FSet_cons_rec X)
    := ap (fun z => Pcons a z _) (repr_iso_id_l _).
End FSet_cons_rec.