(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.
Require Import List.

Require Import basics.
Require Import categories.
Require Import preord.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import plotkin.
Require Import profinite.
Require Import embed.
Require Import directed.
Require Import cont_functors.
Require Import cpo.

(**  * Bilimits and fixpoints of continuous functors.

       Here we construct the colimit of directed systems.
       The carrier of the bilimit is the disjoint union
       of the directed system.  The order on the bilimit
       elements holds if there exists some larger poset
       into which both elements can be embedded where
       the ordering holds.
  *)
Section bilimit.
  Variable hf:bool.
  Variable I:directed_preord.
  Variable DS:directed_system I (EMBED hf).

  Record limset :=
    LimSet
    { idx : I
    ; elem : ds_F DS idx
    }.

  Definition limset_order (x y:limset) :=
    exists k (Hxk : idx x ≤ k) (Hyk : idx y ≤ k),
      ds_hom DS (idx x) k Hxk (elem x)
      ≤ ds_hom DS (idx y) k Hyk (elem y).

  (**  This lemma shows that if two elements compare in any larger poset,
       the compare in _every_ larger poset.
    *)
  Lemma limset_order_exists_forall x y :
    limset_order x y <->
    forall k (Hxk : idx x ≤ k) (Hyk : idx y ≤ k),
      ds_hom DS (idx x) k Hxk (elem x)
      ≤ ds_hom DS (idx y) k Hyk (elem y).
  Proof.
    split; intros.
    destruct H as [k' [Hxk' [Hyk' ?]]].
    destruct (choose_ub I k k') as [q [??]].
    assert (Hxq : idx x ≤ q).
    transitivity k; auto.
    assert (Hyq : idx y ≤ q).
    transitivity k; auto.
    assert (ds_hom DS (idx x) q Hxq (elem x) ≤
            ds_hom DS (idx y) q Hyq (elem y)).
    rewrite <- (ds_compose DS (idx x) k' q Hxk' H1 Hxq).
    rewrite <- (ds_compose DS (idx y) k' q Hyk' H1 Hyq).
    simpl. apply embed_mono. auto.

    rewrite <- (ds_compose DS (idx x) k q Hxk H0 Hxq) in H2.
    rewrite <- (ds_compose DS (idx y) k q Hyk H0 Hyq) in H2.
    simpl in H2.

    apply embed_reflects in H2. auto.

    destruct (choose_ub I (idx x) (idx y)) as [k [??]].
    exists k, H0, H1.
    apply H.
  Qed.

  Lemma limset_order_refl (x:limset) : limset_order x x.
  Proof.
    exists (idx x). exists (ord_refl _ _).  exists (ord_refl _ _). auto.
  Qed.

  Lemma limset_order_trans (x y z:limset) :
    limset_order x y -> limset_order y z -> limset_order x z.
  Proof.
    intros [k1 [Hxk1 [Hyk1 ?]]].
    intros [k2 [Hyk2 [Hzk2 ?]]].
    destruct (choose_ub I k1 k2) as [k [??]].
    assert (Hxk : idx x ≤ k). transitivity k1; auto.
    assert (Hyk : idx y ≤ k). transitivity k1; auto.
    assert (Hzk : idx z ≤ k). transitivity k2; auto.
    exists k. exists Hxk. exists Hzk.
    transitivity (ds_hom DS (idx y) k Hyk (elem y)).
    rewrite <- (ds_compose DS (idx x) k1 k Hxk1 H1 Hxk).
    rewrite <- (ds_compose DS (idx y) k1 k Hyk1 H1 Hyk).
    simpl. apply embed_mono. auto.
    rewrite <- (ds_compose DS (idx y) k2 k Hyk2 H2 Hyk).
    rewrite <- (ds_compose DS (idx z) k2 k Hzk2 H2 Hzk).
    simpl. apply embed_mono. auto.
  Qed.

  Definition limord_mixin :=
    Preord.Mixin limset limset_order limset_order_refl limset_order_trans.

  Canonical Structure limord := Preord.Pack limset limord_mixin.

  (**  The order is decidable.
    *)
  Lemma limset_order_dec (x y:limset) :
    { limset_order x y } + { ~limset_order x y }.
  Proof.
    destruct (choose_ub I (idx x) (idx y)) as [k [??]].
    destruct (eff_ord_dec _ (PLT.effective (ds_F DS k))
                (ds_hom DS (idx x) k H (elem x))
                (ds_hom DS (idx y) k H0 (elem y))).
    left.
    exists k. exists H. exists H0. auto.
    right. intro.
    rewrite limset_order_exists_forall in H1.
    apply n. apply H1.
  Qed.

  (**  Furthermore, all the elements can be enumerated.
    *)
  Definition limset_enum : eset limord :=
    fun n => let (p,q) := pairing.unpairing n in
         match eff_enum _ (dir_effective I) p with
         | Some i =>
              match eff_enum _ (PLT.effective (ds_F DS i)) q with
              | Some x => Some (LimSet i x)
              | None => None
              end
         | None => None
         end.

  (** Thus, the bilimit is an effective order. *)
  Program Definition limord_effective : effective_order limord :=
    EffectiveOrder limord limset_order_dec limset_enum _.
  Next Obligation.
    intros [i x].
    generalize (eff_complete _ (dir_effective I) i).
    intros [p ?].
    case_eq (eff_enum I (dir_effective I) p); intros.
    2: rewrite H0 in H; elim H.
    rewrite H0 in H.
    destruct H.
    set (x' := ds_hom DS i c H x).
    assert (x' ∈ eff_enum _ (PLT.effective (ds_F DS c))).
    apply eff_complete.
    destruct H2 as [q ?].
    case_eq (eff_enum _ (PLT.effective (ds_F DS c)) q); intros.
    2: rewrite H3 in H2; elim H2.
    rewrite H3 in H2.
    exists (pairing.pairing (p,q)).
    unfold limset_enum.
    rewrite pairing.unpairing_pairing.
    rewrite H0. rewrite H3.
    split.
    exists c. simpl. exists H. exists (ord_refl _ _).
    rewrite (ds_ident DS c (ord_refl _ _)). simpl. auto.
    exists c. simpl. exists (ord_refl _ _). exists H.
    rewrite (ds_ident DS c (ord_refl _ _)). simpl. auto.
  Qed.

  (**  Moreover, the bilimit has normal sets.
    *)
  Lemma limord_has_normals : has_normals limord limord_effective hf.
  Proof.
    hnf. intros.
    destruct (choose_ub_set I (map idx X)) as [k ?].

    assert { M | X ≈ map (LimSet k) M }.
    clear Hinh.
    induction X.
    exists nil. simpl; auto.
    destruct IHX as [M ?].
    hnf; intros. apply u.
    simpl. apply cons_elem; auto.
    assert (Hak : idx a ≤ k).
    apply u. simpl. apply cons_elem; auto.
    exists (ds_hom DS (idx a) k Hak (elem a) :: M).
    split. hnf; simpl; intros.
    apply cons_elem in H.
    destruct H. rewrite H.
    apply cons_elem. left.
    split.
    exists k; simpl. exists Hak. exists (ord_refl _ _).
    rewrite (ds_ident DS k (ord_refl _ _)).
    simpl. auto.
    exists k; simpl. exists (ord_refl _ _). exists Hak.
    rewrite (ds_ident DS k (ord_refl _ _)).
    simpl. auto.
    apply cons_elem. right.
    rewrite <- e; auto.
    hnf; intros.
    simpl in H.
    apply cons_elem in H.
    destruct H.
    rewrite H.
    apply cons_elem. left.
    split.
    exists k; simpl. exists (ord_refl _ _). exists Hak.
    rewrite (ds_ident DS k (ord_refl _ _)).
    simpl. auto.
    exists k; simpl. exists Hak. exists (ord_refl _ _).
    rewrite (ds_ident DS k (ord_refl _ _)).
    simpl. auto.
    apply cons_elem. right.
    rewrite e; auto.

    destruct X0 as [M HM].
    exists (map (LimSet k) (mub_closure (PLT.plotkin (ds_F DS k)) M)).
    split.
    hnf; intros.
    rewrite HM in H.
    destruct H as [q [??]].
    apply in_map_iff in H.
    destruct H as [q' [??]].
    subst q.
    assert (q' ∈ mub_closure (PLT.plotkin (ds_F DS k)) M).
    apply mub_clos_incl. exists q'; auto.
    destruct H as [x [??]].
    rewrite H0.
    exists (LimSet k x).
    split.
    apply in_map. auto.
    split.
    exists k; simpl.
    exists (ord_refl _ _ ).
    exists (ord_refl _ _ ).
    apply embed_mono; auto.
    exists k; simpl.
    exists (ord_refl _ _ ).
    exists (ord_refl _ _ ).
    apply embed_mono; auto.
    split.
    revert Hinh.
    unfold inh.
    pattern hf at 1 2. case hf; auto.
    intros [x ?].
    rewrite HM in H.
    destruct H as [x' [??]].
    apply in_map_iff in H.
    destruct H as [q [??]].
    subst x'.
    assert (q ∈ mub_closure (PLT.plotkin (ds_F DS k)) M).
    apply mub_clos_incl. exists q; split; auto.
    destruct H as [q' [??]].
    exists (LimSet k q').
    exists (LimSet k q').
    split; auto.
    apply in_map. auto.

    intros.
    apply prove_directed.
    generalize (refl_equal hf).
    pattern hf at 2. case hf; intros.
    pattern hf at 1. rewrite H; auto.
    pattern hf at 1. rewrite H.
    destruct (choose_ub I (idx z) k) as [k' [Hzk' Hkk']].
    generalize (embed_directed0 (ds_hom DS k k' Hkk')
        (ds_hom DS (idx z) k' Hzk' (elem z))).
    rewrite H at 1.
    intros [q ?].
    destruct (mub_complete (PLT.plotkin (ds_F DS k)) nil q) as [q' [??]].
    hnf. pattern hf at 1. rewrite H. auto.
    hnf; simpl; intros. apply nil_elem in H1. elim H1.
    assert (q' ∈ mub_closure (PLT.plotkin (ds_F DS k)) M).
    apply mub_clos_mub with nil; auto.
    hnf. pattern hf at 1. rewrite H. auto.

    hnf; intros. apply nil_elem in H3; elim H3.
    destruct H3 as [q'' [??]].
    exists (LimSet k q'').
    apply finsubset_elem.
    intros. rewrite <- H5; auto.
    split.
    exists (LimSet k q'').
    split; auto.
    apply in_map. auto.
    exists k'. simpl. exists Hkk'. exists Hzk'.
    transitivity (ds_hom DS k k' Hkk' q); auto.
    apply embed_mono.
    rewrite <- H4; auto.

    intros.
    apply finsubset_elem in H.
    apply finsubset_elem in H0.
    destruct H. destruct H0.
    destruct H as [x' [??]].
    destruct H0 as [y' [??]].
    apply in_map_iff in H.
    destruct H as [x'' [??]].
    apply in_map_iff in H0.
    destruct H0 as [y'' [??]].
    subst x' y'.
    rewrite H3 in H1. rewrite H4 in H2.
    destruct H1 as [k' [Hkk' [Hzk' ?]]]. simpl in *.

    destruct H2 as [l [Hl1 [Hl2 ?]]]. simpl in *.
    destruct (choose_ub I k' l) as [m [Hm1 Hm2]].
    assert (Hkm : k ≤ m).
    transitivity k'; auto.
    assert (Hzm : idx z ≤ m).
    transitivity k'; auto.

    destruct (embed_directed2 (ds_hom DS k m Hkm)
      (ds_hom DS (idx z) m Hzm (elem z)))
      with x'' y'' as [c [?[??]]]; auto.
    rewrite <- (ds_compose DS k k' m Hkk' Hm1 Hkm).
    rewrite <- (ds_compose DS (idx z) k' m Hzk' Hm1 Hzm).
    simpl. apply embed_mono. auto.
    rewrite <- (ds_compose DS k l m Hl1 Hm2 Hkm).
    rewrite <- (ds_compose DS (idx z) l m Hl2 Hm2 Hzm).
    simpl. apply embed_mono. auto.

    destruct (mub_complete (PLT.plotkin (ds_F DS k))
      (x''::y''::nil) c) as [c' [??]].
    apply elem_inh with x''. apply cons_elem; auto.
    hnf; simpl; intros.
    apply cons_elem in H8. destruct H8.
    rewrite H8; auto.
    apply cons_elem in H8. destruct H8.
    rewrite H8; auto.
    apply nil_elem in H8. elim H8.
    assert (c' ∈ mub_closure (PLT.plotkin (ds_F DS k)) M).
    apply mub_clos_mub with (x''::y''::nil); auto.

    apply elem_inh with x''. apply cons_elem; auto.
    hnf; simpl; intros.
    apply cons_elem in H10. destruct H10.
    rewrite H10; auto.
    exists x''; split; auto.
    apply cons_elem in H10. destruct H10.
    rewrite H10; auto.
    exists y''; split; auto.
    apply nil_elem in H10. elim H10.
    destruct H10 as [c'' [??]].
    exists (LimSet k c'').
    split.
    rewrite H3.
    exists k'. simpl. exists Hkk'. exists Hkk'.
    apply embed_mono; auto.
    rewrite <- H11.
    destruct H8.
    apply H8. apply cons_elem; auto.
    split.
    rewrite H4.
    exists k'. simpl. exists Hkk'. exists Hkk'.
    apply embed_mono; auto.
    rewrite <- H11.
    destruct H8.
    apply H8.
    apply cons_elem. right.
    apply cons_elem. auto.
    apply finsubset_elem.
    intros. rewrite <- H12; auto.
    split; auto.
    exists (LimSet k c'').
    split; auto.
    apply in_map. auto.
    exists m. simpl.
    exists Hkm. exists Hzm.
    transitivity (ds_hom DS k m Hkm c); auto.
    apply embed_mono.
    rewrite <- H11; auto.
    intros. rewrite <- H1. auto.
    intros. rewrite <- H1. auto.
  Qed.

  (**  Altogether, this makes the bilimit a plotkin order.
    *)
  Definition limord_plotkin : plotkin_order hf limord :=
    norm_plt limord limord_effective hf limord_has_normals.

  Definition bilimit : PLT.ob hf :=
    PLT.Ob hf limset (PLT.Class _ _ limord_mixin limord_effective limord_plotkin).

  (**  Here we define the spokes of the colimit cocone.
    *)
  Program Definition limset_spoke (i:I) : hom (EMBED hf) (ds_F DS i) bilimit
    := Embedding hf (ds_F DS i : ob (EMBED hf)) bilimit
    (fun x => LimSet i x) _ _ _ _.
  Next Obligation.
    intros. hnf. simpl. exists i. exists (ord_refl _ _). exists (ord_refl _ _).
    rewrite (ds_ident DS i (ord_refl I i)). simpl. auto.
  Qed.
  Next Obligation.
    intros.
    destruct H as [k [Hki [Hki' ?]]]. simpl in *.
    rewrite <- (ds_compose DS i k k Hki' (ord_refl I k) Hki) in H.
    rewrite (ds_ident DS k (ord_refl I k)) in H.
    simpl in H.
    apply embed_reflects in H. auto.
  Qed.
  Next Obligation.
    intros.
    destruct (choose_ub I i (idx y)) as [k [??]].
    generalize (refl_equal hf). pattern hf at 2. case hf.
    intros. pattern hf at 1. rewrite H1. auto.
    intros. pattern hf at 1. rewrite H1.
    generalize (embed_directed0 (ds_hom DS i k H)
      (ds_hom DS (idx y) k H0 (elem y))).
    pattern hf at 1. rewrite H1.
    intros [q ?].
    exists q.
    hnf; simpl.
    exists k. exists H. exists H0.
    auto.
  Qed.
  Next Obligation.
    simpl; intros.
    destruct H as [k1 [Hik1 [Hyk1 ?]]]. simpl in *.
    destruct H0 as [k2 [Hik2 [Hyk2 ?]]]. simpl in *.
    destruct (choose_ub I k1 k2) as [k [??]].
    assert (i ≤ k). transitivity k1; auto.
    assert (idx y ≤ k). transitivity k1; auto.
    destruct (embed_directed2 (ds_hom DS i k H3)
      (ds_hom DS (idx y) k H4 (elem y)) a b) as [q [?[??]]].
    rewrite <- (ds_compose DS i k1 k Hik1 H1 H3).
    rewrite <- (ds_compose DS (idx y) k1 k Hyk1 H1 H4).
    simpl. apply embed_mono. auto.
    rewrite <- (ds_compose DS i k2 k Hik2 H2 H3).
    rewrite <- (ds_compose DS (idx y) k2 k Hyk2 H2 H4).
    simpl. apply embed_mono. auto.
    exists q. split; auto.
    exists k. simpl.
    exists H3. exists H4. auto.
  Qed.

  Lemma limset_spoke_commute : forall i j (Hij:i≤j),
     limset_spoke i ≈ limset_spoke j ∘ ds_hom DS i j Hij.
  Proof.
    intros; split; hnf; simpl; intros.
    exists j. simpl. exists Hij. exists (ord_refl _ _).
    rewrite (ds_ident DS j (ord_refl _ _)). simpl; auto.
    exists j. simpl. exists (ord_refl _ _). exists Hij.
    rewrite (ds_ident DS j (ord_refl _ _)). simpl; auto.
  Qed.

  Definition bilimit_cocone : cocone DS :=
    Cocone DS bilimit limset_spoke limset_spoke_commute.

  Section bilimit_univ.
    Variable YC:cocone DS.

    Program Definition limord_univ : bilimit ⇀ YC :=
      Embedding hf bilimit (YC : ob (EMBED hf))
        (fun x => let (i,x') := x in cocone_spoke YC i x')
        _ _ _ _.
    Next Obligation.
      simpl; intros.
      destruct a as [i a].
      destruct a' as [i' a'].
      hnf in H. simpl in H.
      destruct H as [k [Hk1 [Hk2 ?]]].
      generalize (cocone_commute YC i k Hk1); intros.
      rewrite H0; clear H0.
      generalize (cocone_commute YC i' k Hk2); intros.
      rewrite H0. simpl.
      apply embed_mono. auto.
    Qed.
    Next Obligation.
      simpl; intros.
      destruct a as [i a].
      destruct a' as [i' a'].
      destruct (choose_ub I i i') as [k [Hk1 Hk2]].
      exists k. simpl. exists Hk1. exists Hk2.
      apply (embed_reflects (cocone_spoke YC k)).
      apply (use_ord H).
      destruct (cocone_commute YC i k Hk1); intros.
      apply H1; auto.
      destruct (cocone_commute YC i' k Hk2); intros.
      apply H0; auto.
    Qed.
    Next Obligation.
      intro.
      generalize (refl_equal hf).
      pattern hf at 2.  case hf; intros.
      pattern hf at 1. rewrite H. auto.
      pattern hf at 1. rewrite H.
      destruct (choose_ub_set I nil) as [i _].
      generalize (embed_directed0 (cocone_spoke YC i) y).
      pattern hf at 1. rewrite H.
      intros [x ?].
      exists (LimSet i x). auto.
    Qed.
    Next Obligation.
      intros.
      destruct a as [i a].
      destruct b as [j b].
      destruct (choose_ub I i j) as [k [Hk1 Hk2]].
      rewrite (cocone_commute YC i k Hk1) in H.
      rewrite (cocone_commute YC j k Hk2) in H0.
      destruct (embed_directed2 (cocone_spoke YC k) y
        (ds_hom DS i k Hk1 a)
        (ds_hom DS j k Hk2 b)) as [c [?[??]]]; auto.
      exists (LimSet k c).
      split; auto.
      split.
      exists k. simpl.
      exists Hk1. exists (ord_refl _ _).
      rewrite (ds_ident DS k (ord_refl _ _)).
      simpl. auto.
      exists k. simpl.
      exists Hk2. exists (ord_refl _ _).
      rewrite (ds_ident DS k (ord_refl _ _)).
      simpl. auto.
    Qed.

    Lemma limord_univ_commute i :
      cocone_spoke YC i ≈ limord_univ ∘ limset_spoke i.
    Proof.
      cut (forall x,
        cocone_spoke YC i x ≈ limord_univ (limset_spoke i x)).
      intros. split; intro x; destruct (H x); auto.
      simpl; intros; auto.
    Qed.

    Lemma limord_univ_uniq (f:bilimit ⇀ YC) :
      (forall i, cocone_spoke YC i ≈ f ∘ limset_spoke i) ->
      f ≈ limord_univ.
    Proof.
      intros.
      cut (forall x, f x ≈ limord_univ x).
      intros. split; intro x; destruct (H0 x); auto.
      simpl. intros.
      destruct x as [i x].
      rewrite H. simpl. auto.
    Qed.
  End bilimit_univ.

  Definition bilimit_construction : directed_colimit DS bilimit_cocone :=
    DirectedColimit DS bilimit_cocone
      limord_univ
      limord_univ_commute
      limord_univ_uniq.

  Program Definition ep_set : dir_preord I → (PLT.hom_ord hf bilimit bilimit) :=
    Preord.Hom _ _
        (fun i => embed (embed_ep_pair (limset_spoke i)) ∘
                  project (embed_ep_pair (limset_spoke i)))
        _.
  Next Obligation.
    hnf; simpl; intros.
    hnf; simpl; intros.
    destruct a0 as [x y].
    apply PLT.compose_hom_rel in H0 as [z [??]].
    apply PLT.compose_hom_rel.
    exists (ds_hom DS a b H z).
    split; simpl.
    simpl in *.
    apply project_rel_elem.
    apply project_rel_elem in H0.
    rewrite <- H0.
    generalize (limset_spoke_commute a b H).
    intro.
    destruct H2. apply H3.
    apply embed_rel_elem.
    simpl in H1.
    apply embed_rel_elem in H1.
    rewrite H1.
    generalize (limset_spoke_commute a b H).
    intros [??]. apply H2.
  Qed.

  Program Definition Iset : Preord.carrier (cl_eset (directed_hf_cl hf) I)
    := exist _ (eff_enum I (dir_effective I)) _.
  Next Obligation.
    hnf. simpl; intros.
    destruct (choose_ub_set I M). exists x. split; auto.
    apply eff_complete.
  Qed.

  Lemma bilimit_cpo_colimit : forall x y:bilimit,
    y ≤ x ->
    exists i a,
      y ≤ limset_spoke i a /\
      limset_spoke i a ≤ x.
  Proof.
    intros. destruct H as [k [Hk1 [Hk2 ?]]].
    exists k. exists (ds_hom DS (idx x) k Hk2 (elem x)).
    split.
    exists k. simpl. exists Hk1. exists (ord_refl _ _).
    rewrite (ds_ident DS k (ord_refl _ _)); simpl; auto.
    exists k. simpl. exists (ord_refl _ _). exists Hk2.
    rewrite (ds_ident DS k (ord_refl _ _)); simpl; auto.
  Qed.

  Lemma bilimit_cpo_colimit1 :
    id(bilimit) ≤ ∐(image ep_set Iset).
  Proof.
    hnf. intros [x y] ?.
    simpl in H.
    apply approx_rels.ident_elem in H.
    simpl.
    apply union_axiom.
    destruct (bilimit_cpo_colimit x y) as [i [a [??]]]; auto.
    exists (PLT.hom_rel (ep_set#i)).
    split.
    apply image_axiom1'.
    exists (ep_set#i).
    split; auto.
    apply image_axiom1'.
    exists i. split; auto.
    apply eff_complete.
    simpl.
    apply PLT.compose_hom_rel.
    exists a. split.
    apply project_rel_elem. auto.
    apply embed_rel_elem. auto.
  Qed.

  Lemma bilimit_cpo_colimit2 :
    id(bilimit) ≈ ∐(image ep_set Iset).
  Proof.
    split. apply bilimit_cpo_colimit1.
    apply CPO.sup_is_least.
    hnf. simpl; intros.
    apply image_axiom2 in H. destruct H as [i [??]].
    rewrite H0.
    unfold ep_set. simpl.
    apply (ep_ident hf _ _ _ _
      (embed_func_is_ep_pair hf _ _ (limset_spoke i))).
  Qed.

End bilimit.

(**  The following two constructions show that a cocone is a colimit
     in EMBED iff every element can be factored through a spoke of the cocone.

     Passing thorough these constructions is generally the easiest way to
     demonstrate that an embedding functor is continuous.
  *)
Section colimit_decompose.
  Variable hf:bool.
  Variable I:directed_preord.
  Variable DS : directed_system I (EMBED hf).
  Variable CC : cocone DS.
  Variable Hcolimit : directed_colimit DS CC.

  Lemma colimit_decompose : forall x:cocone_point CC,
    { i:I & { a:ds_F DS i | cocone_spoke CC i a ≈ x }}.
  Proof.
    intros.
    set (y := colim_univ Hcolimit (bilimit_cocone hf I DS) x).
    exists (idx _ _ _ y).
    exists (elem _ _ _ y).
    split.
    apply (embed_reflects
      (colim_univ Hcolimit (bilimit_cocone hf I DS))).
    generalize (colim_commute Hcolimit (bilimit_cocone hf I DS) (idx _ _ _ y)).
    simpl. intros.
    transitivity (limset_spoke hf I DS (idx _ _ _ y) (elem hf I DS y)).
    rewrite H. auto.
    transitivity y; auto.
    destruct y; simpl; auto.
    apply (embed_reflects
      (colim_univ Hcolimit (bilimit_cocone hf I DS))).
    generalize (colim_commute Hcolimit (bilimit_cocone hf I DS) (idx _ _ _ y)).
    simpl. intros.
    transitivity (limset_spoke hf I DS (idx _ _ _ y) (elem hf I DS y)).
    transitivity y; auto.
    destruct y; simpl; auto.
    rewrite H; auto.
  Qed.
End colimit_decompose.

Section colimit_decompose2.
  Variable hf:bool.
  Variable I:directed_preord.
  Variable DS : directed_system I (EMBED hf).
  Variable CC : cocone DS.
  Hypothesis decompose : forall x:cocone_point CC,
    { i:I & { a:ds_F DS i | cocone_spoke CC i a ≈ x }}.

  Definition decompose_univ_func (YC:cocone DS) (x:cocone_point CC) :=
    cocone_spoke YC
       (projT1 (decompose x))
       (projT1 (projT2 (decompose x))).

  Program Definition decompose_univ (YC:cocone DS) : CC ⇀ YC :=
    Embedding hf (cocone_point CC: ob (EMBED hf))
                 (cocone_point YC : ob (EMBED hf))
                 (decompose_univ_func YC) _ _ _ _.
  Next Obligation.
    unfold decompose_univ_func. intros.
    destruct (decompose a) as [i [q ?]]. simpl.
    destruct (decompose a') as [j [q' ?]]. simpl.
    destruct (choose_ub I i j) as [k [??]].
    rewrite (cocone_commute YC i k H0).
    rewrite (cocone_commute YC j k H1).
    simpl.
    apply embed_mono.
    apply (embed_reflects (cocone_spoke CC k)).
    apply (use_ord H).
    rewrite <- e.
    rewrite (cocone_commute CC i k H0). auto.
    rewrite <- e0.
    rewrite (cocone_commute CC j k H1). auto.
  Qed.
  Next Obligation.
    unfold decompose_univ_func. intros.
    destruct (decompose a) as [i [q ?]]. simpl in *.
    destruct (decompose a') as [j [q' ?]]. simpl in *.
    destruct (choose_ub I i j) as [k [??]].
    rewrite (cocone_commute YC i k H0) in H.
    rewrite (cocone_commute YC j k H1) in H.
    simpl in H.
    apply embed_reflects in H.
    rewrite <- e.
    rewrite <- e0.
    rewrite (cocone_commute CC i k H0).
    rewrite (cocone_commute CC j k H1).
    simpl. apply embed_mono; auto.
  Qed.
  Next Obligation.
    intros.
    unfold decompose_univ_func.
    destruct hf; simpl; auto.
    destruct (choose_ub_set I nil) as [i ?].
    destruct (embed_directed0 (cocone_spoke YC i) y).
    exists (cocone_spoke CC i x).
    destruct (decompose (cocone_spoke CC i x)) as [m [z' ?]]. simpl.
    rewrite <- H.
    destruct (choose_ub I m i) as [k [??]].
    rewrite (cocone_commute YC m k H0).
    rewrite (cocone_commute YC i k H1).
    simpl. apply embed_mono.
    rewrite (cocone_commute CC m k H0) in e.
    rewrite (cocone_commute CC i k H1) in e.
    simpl in e.
    destruct e.
    apply (embed_reflects (cocone_spoke CC k)) in H2. auto.
  Qed.
  Next Obligation.
    unfold decompose_univ_func. intros.
    destruct (decompose a) as [i [q ?]]. simpl in *.
    destruct (decompose b) as [j [q' ?]]. simpl in *.
    destruct (choose_ub I i j) as [k [??]].
    rewrite (cocone_commute YC i k H1) in H.
    rewrite (cocone_commute YC j k H2) in H0.
    simpl in H, H0.
    destruct (embed_directed2 (cocone_spoke YC k) y
      (ds_hom DS i k H1 q)
      (ds_hom DS j k H2 q')) as [z [?[??]]]; auto.
    exists (cocone_spoke CC k z).
    split.
    destruct (decompose (cocone_spoke CC k z)) as [m [z' ?]]. simpl.
    rewrite <- H3.

    destruct (choose_ub I m k) as [k' [??]].
    rewrite (cocone_commute YC m k' H6).
    rewrite (cocone_commute YC k k' H7).
    simpl. apply embed_mono.
    destruct e1.
    rewrite (cocone_commute CC m k' H6) in H8.
    rewrite (cocone_commute CC k k' H7) in H8.
    simpl in H8.
    apply (embed_reflects (cocone_spoke CC k')) in H8. auto.

    split.
    rewrite <- e.
    rewrite (cocone_commute CC i k H1).
    simpl. apply embed_mono. auto.
    rewrite <- e0.
    rewrite (cocone_commute CC j k H2).
    simpl. apply embed_mono. auto.
  Qed.

  Program Definition decompose_is_colimit : directed_colimit DS CC :=
    DirectedColimit DS CC decompose_univ _ _.
  Next Obligation.
    intros. apply embed_lift'. simpl.
    unfold decompose_univ_func. simpl. intro x.
    destruct (decompose (cocone_spoke CC i x)) as [j [x' ?]]. simpl.
    destruct (choose_ub I i j) as [k [??]].
    rewrite (cocone_commute YC i k H).
    rewrite (cocone_commute YC j k H0).
    rewrite (cocone_commute CC i k H) in e.
    rewrite (cocone_commute CC j k H0) in e.
    simpl in e.
    destruct e; split; simpl.
    apply embed_reflects in H2. apply embed_mono; auto.
    apply embed_reflects in H1. apply embed_mono; auto.
  Qed.
  Next Obligation.
    simpl; intros.
    intros. apply embed_lift'. simpl.
    unfold decompose_univ_func. simpl. intro x.
    destruct (decompose x) as [i [x' ?]]. simpl.
    rewrite <- e.
    rewrite (H i).
    simpl; auto.
  Qed.
End colimit_decompose2.

(** With the bilimit in hand, we can construct the least
    fixpoint of continuous functors in the embeddings
    over the category of partial plotkin orders by appeal
    to the general fixpoint construction for continuous functors.
 *)
Section fixpoint.
  Variable F:functor (EMBED true) (EMBED true).
  Hypothesis Fcontinuous : continuous_functor F.

  Definition fixpoint : ob (EMBED true) :=
    cont_functors.fixpoint
           PPLT_EMBED_initialized
           F
           (bilimit_cocone true).

  Definition fixpoint_initial : Alg.initial_alg (EMBED true) F :=
    cont_functors.fixpoint_initial
           PPLT_EMBED_initialized
           F
           (bilimit_cocone true)
           (bilimit_construction true)
           Fcontinuous.

  Definition fixpoint_iso : F fixpoint ↔ fixpoint :=
    cont_functors.fixpoint_iso
           PPLT_EMBED_initialized
           F
           (bilimit_cocone true)
           (bilimit_construction true)
           Fcontinuous.
End fixpoint.

Require Import Arith.

(** We can also build fixpoints in the category of total
    Plotkin orders by requiring a little more data.
    This proof is a modification of Theorem 79 from
    Carl Gunter's PhD thesis (CMU, 1985).
 *)
Section total_fixpoint.
  Variable F:functor (EMBED false) (EMBED false).
  Hypothesis Fcontinuous : continuous_functor F.

  Variable A:ob PLT.
  Variable h:A ⇀ F A.

  Fixpoint iterF (x:nat) : ob PLT :=
    match x with
    | O => A
    | S x' => F (iterF x')
    end.

  Fixpoint injectA (j:nat) : A ⇀ iterF j :=
    match j as j' return A ⇀ iterF j' with
    | 0 => id
    | S n => F·(injectA n) ∘ h
    end.

  Fixpoint iter_hom (i:nat) : forall (j:nat) (Hij:i <= j), iterF i ⇀ iterF j :=
    match i as i' return forall (j:nat) (Hij:i' <= j), iterF i' ⇀ iterF j with
    | O => fun j Hij => injectA j
    | S i' => fun j =>
        match j as j' return forall (Hij:S i' <= j'), iterF (S i') ⇀ iterF j' with
        | O => fun Hij => False_rect _ (HSle0 i' Hij) (* impossible case *)
        | S j' => fun Hij => F·(iter_hom i' j' (gt_S_le i' j' Hij))
        end
    end.

  Lemma iter_hom_proof_irr i : forall j H1 H2,
    iter_hom i j H1 ≈ iter_hom i j H2.
  Proof.
    induction i; simpl; intros; auto.
    destruct j.
    elimtype False. inversion H1.
    apply Functor.respects.
    apply IHi.
  Qed.

  Program Definition kleene_chain_alt : directed_system nat_dirord (EMBED false) :=
    DirSys nat_dirord _ iterF iter_hom _ _.
  Next Obligation.
    induction i; simpl; intros.
    auto.
    apply Functor.ident; auto.
  Qed.
  Next Obligation.
    induction i. simpl; intros.
    clear Hij Hik.
    revert k Hjk; induction j; simpl; intros.
    apply cat_ident1.
    destruct k.
    elimtype False. inversion Hjk.
    simpl.
    rewrite (@cat_assoc (EMBED false)).
    apply cat_respects; auto.
    symmetry. apply Functor.compose.
    symmetry. apply IHj.

    intros. destruct j.
    elimtype False. inversion Hij.
    destruct k.
    elimtype False. inversion Hjk.
    simpl.
    rewrite <- (Functor.compose F _ _ _ (iter_hom j k (gt_S_le j k Hjk))).
    reflexivity. auto.
  Qed.

  Definition fixpoint_alt : ob PLT := bilimit false nat_dirord kleene_chain_alt.

  Let BL := Fcontinuous
               nat_dirord kleene_chain_alt
               (bilimit_cocone false nat_dirord kleene_chain_alt)
               (bilimit_construction false nat_dirord kleene_chain_alt).

  Program Definition cocone_plus1 : cocone (dir_sys_app kleene_chain_alt F)
    := Cocone (dir_sys_app kleene_chain_alt F) fixpoint_alt
      (fun i => cocone_spoke (bilimit_cocone false nat_dirord kleene_chain_alt) (S i)) _.
  Next Obligation.
    simpl; intros.
    assert (Hij' : S i <= S j). auto with arith.
    rewrite (cocone_commute (bilimit_cocone false nat_dirord kleene_chain_alt) (S i) (S j) Hij').
    simpl. apply cat_respects; auto.
    apply Functor.respects.
    apply iter_hom_proof_irr.
  Qed.

  Program Definition cocone_minus1 : cocone kleene_chain_alt
    := Cocone kleene_chain_alt (F fixpoint_alt)
           (fun i =>
              F·(cocone_spoke (bilimit_cocone false nat_dirord kleene_chain_alt) i) ∘
              iter_hom i (S i) (le_S i i (le_refl i)))
           _.
  Next Obligation.
    simpl. intros.
    assert (i <= S j). auto with arith.
    rewrite <- (@cat_assoc (EMBED false)).
    rewrite (kleene_chain_alt_obligation_2 i j (S j) Hij (le_S j j (le_refl j)) H).
    destruct i. simpl.

    rewrite Functor.ident; auto.
    rewrite (@cat_ident2 (EMBED false)).
    rewrite (@cat_assoc (EMBED false)).
    apply cat_respects; auto.
    apply Functor.compose.
    rewrite (limset_spoke_commute false nat_dirord kleene_chain_alt 0%nat j Hij).
    simpl. auto.

    simpl.
    etransitivity.
    symmetry.
    apply (Functor.compose F) with
      (f:=limset_spoke false nat_dirord kleene_chain_alt (S i))
      (g:=iter_hom i (S i) (gt_S_le i (S i) (le_S (S i) (S i) (le_refl (S i)))))
      (h:=limset_spoke false nat_dirord kleene_chain_alt j ∘
          iter_hom i j (gt_S_le i j H)).
    2: apply (Functor.compose F); auto.
    assert (i <= j) by auto with arith.
    rewrite <- (limset_spoke_commute false nat_dirord kleene_chain_alt i j).
    rewrite <- (limset_spoke_commute false nat_dirord kleene_chain_alt i (S i)).
    auto.
  Qed.

  Definition fixpoint_alt_in : F fixpoint_alt ⇀ fixpoint_alt :=
    colim_univ BL cocone_plus1.
  Definition fixpoint_alt_out : fixpoint_alt ⇀ F fixpoint_alt :=
    limord_univ false nat_dirord kleene_chain_alt cocone_minus1.

  Lemma fixpoint_alt_in_out : fixpoint_alt_in ∘ fixpoint_alt_out ≈ id.
  Proof.
    transitivity (limord_univ false nat_dirord kleene_chain_alt
      (bilimit_cocone false nat_dirord kleene_chain_alt)).
    apply (limord_univ_uniq false nat_dirord kleene_chain_alt
      (bilimit_cocone false nat_dirord kleene_chain_alt)).
    simpl; intros. unfold fixpoint_alt_in. unfold fixpoint_alt_out.
    rewrite <- (@cat_assoc (EMBED false)).
    rewrite <- (limord_univ_commute false nat_dirord kleene_chain_alt cocone_minus1 i).
    simpl.
    generalize (colim_commute BL cocone_plus1 i). simpl. intros.
    transitivity (limset_spoke false nat_dirord kleene_chain_alt (S i)
      ∘ iter_hom i (S i) (le_S i i (le_refl i))).
    apply (limset_spoke_commute false nat_dirord kleene_chain_alt i (S i)).
    rewrite (@cat_assoc (EMBED false)).
    apply cat_respects; auto.
    symmetry.
    apply (limord_univ_uniq false nat_dirord kleene_chain_alt
      (bilimit_cocone false nat_dirord kleene_chain_alt)).
    simpl; intros.
    symmetry. apply cat_ident2.
  Qed.

  Lemma fixpoint_alt_out_in : fixpoint_alt_out ∘ fixpoint_alt_in ≈ id.
  Proof.
    transitivity (colim_univ BL
        (cocone_app (bilimit_cocone false nat_dirord kleene_chain_alt) F)).
    apply (colim_uniq BL (cocone_app (bilimit_cocone false nat_dirord kleene_chain_alt) F)).
    simpl. unfold fixpoint_alt_out. unfold fixpoint_alt_in.
    intros.
    generalize (colim_commute BL cocone_plus1 i).
    simpl. intros.
    rewrite <- (@cat_assoc (EMBED false)).
    rewrite <- H.
    generalize (limord_univ_commute false nat_dirord kleene_chain_alt
      cocone_minus1 (S i)). simpl. intros.
    rewrite <- H0.
    apply Functor.compose.
    apply (limset_spoke_commute false nat_dirord kleene_chain_alt i (S i)).
    symmetry.
    apply (colim_uniq BL (cocone_app (bilimit_cocone false nat_dirord kleene_chain_alt) F)).
    simpl; intros.
    symmetry. apply cat_ident2.
  Qed.

  Definition fixpoint_embed : A ⇀ fixpoint_alt :=
    limset_spoke false nat_dirord kleene_chain_alt 0%nat.

  Definition fixpoint_alt_iso : F fixpoint_alt ↔ fixpoint_alt :=
    Isomorphism (EMBED false) (F fixpoint_alt) fixpoint_alt
       fixpoint_alt_in
       fixpoint_alt_out
       fixpoint_alt_out_in
       fixpoint_alt_in_out.

End total_fixpoint.


Print Nat.mul.

Theorem mult_n_1 : forall p : nat,
    p * 1 = p.
Proof.
  intros. simpl.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  simpl. reflexivity.
Qed.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__betweennotequal.
Require Export logic.
Definition lemma__raystrict : forall A B C, (euclidean__defs.Out A B C) -> (euclidean__axioms.neq A C).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (exists J, (euclidean__axioms.BetS J A C) /\ (euclidean__axioms.BetS J A B)) as H0 by exact H.
destruct H0 as [J H1].
destruct H1 as [H2 H3].
assert (* Cut *) (euclidean__axioms.neq A C) as H4.
- assert (* Cut *) ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq J A) /\ (euclidean__axioms.neq J C))) as H4.
-- apply (@lemma__betweennotequal.lemma__betweennotequal J A C H2).
-- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
exact H5.
- exact H4.
Qed.


Require Import Coq.ZArith.ZArith.

Local Open Scope Z_scope.

Class ZMonoid (dot : Z -> Z -> Z) (one : Z)
  := {
      zdot_assoc: forall x y z, dot x (dot y z) = dot (dot x y) z;
      zone_left: forall x, dot one x = x;
      zone_right: forall x, dot x one = x
    }.

(* An existing defintion ZFoo which requires function along with neutral element which form a Monoid. *)
Definition ZFoo (f: Z->Z->Z) (id:Z) `{ZMonoid f id} (x:Z) : Z. Admitted.

(* Let use ZFoo from ZBar for (+) and (0) *)
Instance ZMplus: ZMonoid Zplus 0. Proof. split;intros;ring. Qed.
Definition ZBar0 (x:Z) := ZFoo Zplus 0 x.

(* So far, so good. Let us try to use ZFoo with `abs` and 0 in the context where the argument is always non-negative. *)

(* We can prove that for non-negate integers 'abs' always absorbs 0 *)

Lemma Zmax_zero_left (x:Z):
  (x>=0) -> Z.max 0 x = x.
Proof.
  intros.
  unfold Z.max.
  simpl; destruct x; try reflexivity.
  contradiction H; apply Zlt_neg_0.
Qed.

Lemma Zmax_zero_right (x:Z):
  (x>=0) -> Z.max x 0 = x.
Proof.
  intros.
  rewrite Z.max_comm.
  apply Zmax_zero_left, H.
Qed.

(* However we could not create Zmonoid instance as there is no way to constrain 'abs` arguments to be non-negative *)
Instance Mmax: ZMonoid Zmax 0.
Proof.
  split.
  - apply Zmax_assoc.
  - intros; (* apply Zmax_zero_left. *) admit.
  - intros; (* eapply Zmax_zero_right. *) admit.
Admitted.

(* So this would work: *)
Definition Bar1 (x:Z) := ZFoo Zmax 0 (Zabs x).


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun eqtype ssrnat seq div fintype tuple.
From mathcomp
Require Import tuple bigop prime finset fingroup morphism perm automorphism.
From mathcomp
Require Import quotient action cyclic pgroup gseries sylow primitive_action.

(******************************************************************************)
(*  Definitions of the symmetric and alternate groups, and some properties.   *)
(*     'Sym_T == The symmetric group over type T (which must have a finType   *)
(*               structure).                                                  *)
(*            := [set: {perm T}]                                              *)
(*     'Alt_T == The alternating group over type T.                           *)
(******************************************************************************)

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

Import GroupScope.

Definition bool_groupMixin := FinGroup.Mixin addbA addFb addbb.
Canonical bool_baseGroup := Eval hnf in BaseFinGroupType bool bool_groupMixin.
Canonical boolGroup := Eval hnf in FinGroupType addbb.

Section SymAltDef.

Variable T : finType.
Implicit Types (s : {perm T}) (x y z : T).

(** Definitions of the alternate groups and some Properties **)
Definition Sym of phant T : {set {perm T}} := setT.

Canonical Sym_group phT := Eval hnf in [group of Sym phT].

Local Notation "'Sym_T" := (Sym (Phant T)) (at level 0).

Canonical sign_morph := @Morphism _ _ 'Sym_T _ (in2W (@odd_permM _)).

Definition Alt of phant T := 'ker (@odd_perm T).

Canonical Alt_group phT := Eval hnf in [group of Alt phT].

Local Notation "'Alt_T" := (Alt (Phant T)) (at level 0).

Lemma Alt_even p : (p \in 'Alt_T) = ~~ p.
Proof. by rewrite !inE /=; case: odd_perm. Qed.

Lemma Alt_subset : 'Alt_T \subset 'Sym_T.
Proof. exact: subsetT. Qed.

Lemma Alt_normal : 'Alt_T <| 'Sym_T.
Proof. exact: ker_normal. Qed.

Lemma Alt_norm : 'Sym_T \subset 'N('Alt_T).
Proof. by case/andP: Alt_normal. Qed.

Let n := #|T|.

Lemma Alt_index : 1 < n -> #|'Sym_T : 'Alt_T| = 2.
Proof.
move=> lt1n; rewrite -card_quotient ?Alt_norm //=.
have : ('Sym_T / 'Alt_T) \isog (@odd_perm T @* 'Sym_T) by apply: first_isog.
case/isogP=> g /injmP/card_in_imset <-.
rewrite /morphim setIid=> ->; rewrite -card_bool; apply: eq_card => b.
apply/imsetP; case: b => /=; last first.
  by exists (1 : {perm T}); [rewrite setIid inE | rewrite odd_perm1].
case: (pickP T) lt1n => [x1 _ | d0]; last by rewrite /n eq_card0.
rewrite /n (cardD1 x1) ltnS lt0n => /existsP[x2 /=].
by rewrite eq_sym andbT -odd_tperm; exists (tperm x1 x2); rewrite ?inE.
Qed.

Lemma card_Sym : #|'Sym_T| = n`!.
Proof.
rewrite -[n]cardsE -card_perm; apply: eq_card => p.
by apply/idP/subsetP=> [? ?|]; rewrite !inE.
Qed.

Lemma card_Alt : 1 < n -> (2 * #|'Alt_T|)%N = n`!.
Proof.
by move/Alt_index <-; rewrite mulnC (Lagrange Alt_subset) card_Sym.
Qed.

Lemma Sym_trans : [transitive^n 'Sym_T, on setT | 'P].
Proof.
apply/imsetP; pose t1 := [tuple of enum T].
have dt1: t1 \in n.-dtuple(setT) by rewrite inE enum_uniq; apply/subsetP.
exists t1 => //; apply/setP=> t; apply/idP/imsetP=> [|[a _ ->{t}]]; last first.
  by apply: n_act_dtuple => //; apply/astabsP=> x; rewrite !inE.
case/dtuple_onP=> injt _; have injf := inj_comp injt enum_rank_inj.
exists (perm injf); first by rewrite inE.
apply: eq_from_tnth => i; rewrite tnth_map /= [aperm _ _]permE; congr tnth.
by rewrite (tnth_nth (enum_default i)) enum_valK.
Qed.

Lemma Alt_trans : [transitive^n.-2 'Alt_T, on setT | 'P].
Proof.
case n_m2: n Sym_trans => [|[|m]] /= tr_m2; try exact: ntransitive0.
have tr_m := ntransitive_weak (leqW (leqnSn m)) tr_m2.
case/imsetP: tr_m2; case/tupleP=> x; case/tupleP=> y t.
rewrite !dtuple_on_add 2![x \in _]inE inE negb_or /= -!andbA.
case/and4P=> nxy ntx nty dt _; apply/imsetP; exists t => //; apply/setP=> u.
apply/idP/imsetP=> [|[a _ ->{u}]]; last first.
  by apply: n_act_dtuple => //; apply/astabsP=> z; rewrite !inE.
case/(atransP2 tr_m dt)=> /= a _ ->{u}.
case odd_a: (odd_perm a); last by exists a => //; rewrite !inE /= odd_a.
exists (tperm x y * a); first by rewrite !inE /= odd_permM odd_tperm nxy odd_a.
apply/val_inj/eq_in_map => z tz; rewrite actM /= /aperm; congr (a _).
by case: tpermP ntx nty => // <-; rewrite tz.
Qed.

Lemma aperm_faithful (A : {group {perm T}}) : [faithful A, on setT | 'P].
Proof.
by apply/faithfulP=> /= p _ np1; apply/eqP/perm_act1P=> y; rewrite np1 ?inE.
Qed.

End SymAltDef.

Notation "''Sym_' T" := (Sym (Phant T))
  (at level 8, T at level 2, format "''Sym_' T") : group_scope.
Notation "''Sym_' T" := (Sym_group (Phant T)) : Group_scope.

Notation "''Alt_' T" := (Alt (Phant T))
  (at level 8, T at level 2, format "''Alt_' T") : group_scope.
Notation "''Alt_' T" := (Alt_group (Phant T)) : Group_scope.

Lemma trivial_Alt_2 (T : finType) : #|T| <= 2 -> 'Alt_T = 1.
Proof.
rewrite leq_eqVlt => /predU1P[] oT.
  by apply: card_le1_trivg; rewrite -leq_double -mul2n card_Alt oT.
suffices Sym1: 'Sym_T = 1 by apply/trivgP; rewrite -Sym1 subsetT.
by apply: card1_trivg; rewrite card_Sym; case: #|T| oT; do 2?case.
Qed.

Lemma simple_Alt_3 (T : finType) : #|T| = 3 -> simple 'Alt_T.
Proof.
move=> T3; have{T3} oA: #|'Alt_T| = 3.
  by apply: double_inj; rewrite -mul2n card_Alt T3.
apply/simpleP; split=> [|K]; [by rewrite trivg_card1 oA | case/andP=> sKH _].
have:= cardSg sKH; rewrite oA dvdn_divisors // !inE orbC /= -oA.
case/pred2P=> eqK; [right | left]; apply/eqP.
  by rewrite eqEcard sKH eqK leqnn.
by rewrite eq_sym eqEcard sub1G eqK cards1.
Qed.

Lemma not_simple_Alt_4 (T : finType) : #|T| = 4 -> ~~ simple 'Alt_T.
Proof.
move=> oT; set A := 'Alt_T.
have oA: #|A| = 12 by apply: double_inj; rewrite -mul2n card_Alt oT.
suffices [p]: exists p, [/\ prime p, 1 < #|A|`_p < #|A| & #|'Syl_p(A)| == 1%N].
  case=> p_pr pA_int; rewrite /A; case/normal_sylowP=> P; case/pHallP.
  rewrite /= -/A => sPA pP nPA; apply/simpleP=> [] [_]; rewrite -pP in pA_int.
  by case/(_ P)=> // defP; rewrite defP oA ?cards1 in pA_int.
have: #|'Syl_3(A)| \in filter [pred d | d %% 3 == 1%N] (divisors 12).
  by rewrite mem_filter -dvdn_divisors //= -oA card_Syl_dvd ?card_Syl_mod.
rewrite /= oA mem_seq2 orbC.
case/predU1P=> [oQ3|]; [exists 2 | exists 3]; split; rewrite ?p_part //.
pose A3 := [set x : {perm T} | #[x] == 3]; suffices oA3: #|A :&: A3| = 8.
  have sQ2 P: P \in 'Syl_2(A) -> P :=: A :\: A3.
    rewrite inE pHallE oA p_part -natTrecE /= => /andP[sPA /eqP oP].
    apply/eqP; rewrite eqEcard -(leq_add2l 8) -{1}oA3 cardsID oA oP.
    rewrite andbT subsetD sPA; apply/exists_inP=> -[x] /= Px.
    by rewrite inE => /eqP ox; have:= order_dvdG Px; rewrite oP ox.
  have [/= P sylP] := Sylow_exists 2 [group of A].
  rewrite -(([set P] =P 'Syl_2(A)) _) ?cards1 // eqEsubset sub1set inE sylP.
  by apply/subsetP=> Q sylQ; rewrite inE -val_eqE /= !sQ2 // inE.
rewrite -[8]/(4 * 2)%N -{}oQ3 -sum1_card -sum_nat_const.
rewrite (partition_big (fun x => <[x]>%G) (mem 'Syl_3(A))) => [|x]; last first.
  by case/setIP=> Ax; rewrite /= !inE pHallE p_part cycle_subG Ax oA.
apply: eq_bigr => Q; rewrite inE /= inE pHallE oA p_part -?natTrecE //=.
case/andP=> sQA /eqP oQ; have:= oQ.
rewrite (cardsD1 1) group1 -sum1_card => [[/= <-]]; apply: eq_bigl => x.
rewrite setIC -val_eqE /= 2!inE in_setD1 -andbA -{4}[x]expg1 -order_dvdn dvdn1.
apply/and3P/andP=> [[/eqP-> _ /eqP <-] | [ntx Qx]]; first by rewrite cycle_id.
have:= order_dvdG Qx; rewrite oQ dvdn_divisors // mem_seq2 (negPf ntx) /=.
by rewrite eqEcard cycle_subG Qx (subsetP sQA) // oQ /order => /eqP->.
Qed.

Lemma simple_Alt5_base (T : finType) : #|T| = 5 -> simple 'Alt_T.
Proof.
move=> oT.
have F1: #|'Alt_T| = 60 by apply: double_inj; rewrite -mul2n card_Alt oT.
have FF (H : {group {perm T}}): H <| 'Alt_T -> H :<>: 1 -> 20 %| #|H|.
- move=> Hh1 Hh3.
  have [x _]: exists x, x \in T by apply/existsP/eqP; rewrite oT.
  have F2 := Alt_trans T; rewrite oT /= in F2.
  have F3: [transitive 'Alt_T, on setT | 'P] by apply: ntransitive1 F2.
  have F4: [primitive 'Alt_T, on setT | 'P] by apply: ntransitive_primitive F2.
  case: (prim_trans_norm F4 Hh1) => F5.
    by case: Hh3; apply/trivgP; apply: subset_trans F5 (aperm_faithful _).
  have F6: 5 %| #|H| by rewrite -oT -cardsT (atrans_dvd F5).
  have F7: 4 %| #|H|.
    have F7: #|[set~ x]| = 4 by rewrite cardsC1 oT.
    case: (pickP (mem [set~ x])) => [y Hy | ?]; last by rewrite eq_card0 in F7.
    pose K := 'C_H[x | 'P]%G.
    have F8 : K \subset H by apply: subsetIl.
    pose Gx := 'C_('Alt_T)[x | 'P]%G.
    have F9: [transitive^2 Gx, on [set~ x] | 'P].
      by rewrite -[[set~ x]]setTI -setDE stab_ntransitive ?inE.
    have F10: [transitive Gx, on [set~ x] | 'P].
      exact: ntransitive1 F9.
    have F11: [primitive Gx, on [set~ x] | 'P].
      exact: ntransitive_primitive F9.
    have F12: K \subset Gx by apply: setSI; apply: normal_sub.
    have F13: K <| Gx by rewrite /(K <| _) F12 normsIG // normal_norm.
    case: (prim_trans_norm F11 F13) => Ksub; last first.
      by apply: dvdn_trans (cardSg F8); rewrite -F7; apply: atrans_dvd Ksub.
    have F14: [faithful Gx, on [set~ x] | 'P].
      apply/subsetP=> g; do 2![case/setIP] => Altg cgx cgx'.
      apply: (subsetP (aperm_faithful 'Alt_T)).
      rewrite inE Altg /=; apply/astabP=> z _.
      case: (z =P x) => [->|]; first exact: (astab1P cgx).
      by move/eqP=> nxz; rewrite (astabP cgx') ?inE //.
    have Hreg g (z : T): g \in H -> g z = z -> g = 1.
      have F15 h: h \in H -> h x = x -> h = 1.
        move=> Hh Hhx; have: h \in K by rewrite inE Hh; apply/astab1P.
        by rewrite (trivGP (subset_trans Ksub F14)) => /set1P.
      move=> Hg Hgz; have:= in_setT x; rewrite -(atransP F3 z) ?inE //.
      case/imsetP=> g1 Hg1 Hg2; apply: (conjg_inj g1); rewrite conj1g.
      apply: F15; last by rewrite Hg2 -permM mulKVg permM Hgz.
      by case/normalP: Hh1 => _ nH1; rewrite -(nH1 _ Hg1) memJ_conjg.
    clear K F8 F12 F13 Ksub F14.
    case: (Cauchy _ F6) => // h Hh /eqP Horder.
    have diff_hnx_x n: 0 < n -> n < 5 -> x != (h ^+ n) x.
      move=> Hn1 Hn2; rewrite eq_sym; apply/negP => HH.
      have: #[h ^+ n] = 5.
        rewrite orderXgcd // (eqP Horder).
        by move: Hn1 Hn2 {HH}; do 5 (case: n => [|n] //).
      have Hhd2: h ^+ n \in H by rewrite groupX.
      by rewrite (Hreg _ _ Hhd2 (eqP HH)) order1.
    pose S1 := [tuple x; h x; (h ^+ 3) x].
    have DnS1: S1 \in 3.-dtuple(setT).
      rewrite inE memtE subset_all /= !inE /= !negb_or -!andbA /= andbT.
      rewrite -{1}[h]expg1 !diff_hnx_x // expgSr permM.
      by rewrite (inj_eq perm_inj) diff_hnx_x.
    pose S2 := [tuple x; h x; (h ^+ 2) x].
    have DnS2:  S2 \in 3.-dtuple(setT).
      rewrite inE memtE subset_all /= !inE /= !negb_or -!andbA /= andbT.
      rewrite -{1}[h]expg1 !diff_hnx_x // expgSr permM.
      by rewrite (inj_eq perm_inj) diff_hnx_x.
    case: (atransP2 F2 DnS1 DnS2) => g Hg [/=].
    rewrite /aperm => Hgx Hghx Hgh3x.
    have h_g_com: h * g = g * h.
      suff HH: (g * h * g^-1) * h^-1 = 1 by rewrite -[h * g]mul1g -HH !gnorm.
      apply: (Hreg _ x); last first.
        by rewrite !permM -Hgx Hghx -!permM mulKVg mulgV perm1.
      rewrite groupM // ?groupV // (conjgCV g) mulgK -mem_conjg.
      by case/normalP: Hh1 => _ ->.
    have: (g * (h ^+ 2) * g ^-1) x = (h ^+ 3) x.
      rewrite !permM -Hgx.
      have ->: h (h x) = (h ^+ 2) x by rewrite /= permM.
      by rewrite {1}Hgh3x -!permM /= mulgV mulg1 -expgSr.
    rewrite commuteX // mulgK {1}[expgn]lock expgS permM -lock.
    by move/perm_inj=> eqxhx; case/eqP: (diff_hnx_x 1%N isT isT); rewrite expg1.
  by rewrite (@Gauss_dvd 4 5) // F7.
apply/simpleP; split => [|H Hnorm]; first by rewrite trivg_card1 F1.
case Hcard1: (#|H| == 1%N); move/eqP: Hcard1 => Hcard1.
  by left; apply: card1_trivg; rewrite Hcard1.
right; case Hcard60: (#|H| == 60%N); move/eqP: Hcard60 => Hcard60.
  by apply/eqP; rewrite eqEcard Hcard60 F1 andbT; case/andP: Hnorm.
have Hcard20: #|H| = 20; last clear Hcard1 Hcard60.
  have Hdiv: 20 %| #|H| by apply: FF => // HH; case Hcard1; rewrite HH cards1.
  case H20: (#|H| == 20); first by apply/eqP.
  case: Hcard60; case/andP: Hnorm; move/cardSg; rewrite F1 => Hdiv1 _.
  by case/dvdnP: Hdiv H20 Hdiv1 => n ->; move: n; do 4!case=> //.
have prime_5: prime 5 by [].
have nSyl5: #|'Syl_5(H)| = 1%N.
  move: (card_Syl_dvd 5 H) (card_Syl_mod H prime_5).
  rewrite Hcard20; case: (card _) => // n Hdiv.
  move: (dvdn_leq  (isT: (0 < 20)%N) Hdiv).
  by move: (n) Hdiv; do 20 (case=> //).
case: (Sylow_exists 5 H) => S; case/pHallP=> sSH oS.
have{oS} oS: #|S| = 5 by rewrite oS p_part Hcard20.
suff: 20 %| #|S| by rewrite oS.
apply FF => [|S1]; last by rewrite S1 cards1 in oS.
apply: char_normal_trans Hnorm; apply: lone_subgroup_char => // Q sQH isoQS.
rewrite subEproper; apply/norP=> [[nQS _]]; move: nSyl5.
rewrite (cardsD1 S) (cardsD1 Q) 4!{1}inE nQS !pHallE sQH sSH Hcard20 p_part.
by rewrite (card_isog isoQS) oS.
Qed.

Section Restrict.

Variables (T : finType) (x : T).
Notation T' := {y | y != x}.

Lemma rfd_funP (p : {perm T}) (u : T') :
  let p1 := if p x == x then p else 1 in p1 (val u) != x.
Proof.
case: (p x =P x) => /= [pxx | _]; last by rewrite perm1 (valP u).
by rewrite -[x in _ != x]pxx (inj_eq perm_inj); apply: (valP u).
Qed.

Definition rfd_fun p := [fun u => Sub ((_ : {perm T}) _) (rfd_funP p u) : T'].

Lemma rfdP p : injective (rfd_fun p).
Proof.
apply: can_inj (rfd_fun p^-1) _ => u; apply: val_inj => /=.
rewrite -(can_eq (permK p)) permKV eq_sym.
by case: eqP => _; rewrite !(perm1, permK).
Qed.

Definition rfd p := perm (@rfdP p).

Hypothesis card_T : 2 < #|T|.

Lemma rfd_morph : {in 'C_('Sym_T)[x | 'P] &, {morph rfd : y z / y * z}}.
Proof.
move=> p q; rewrite !setIA !setIid; move/astab1P=> p_x; move/astab1P=> q_x.
apply/permP=> u; apply: val_inj.
by rewrite permE /= !permM !permE /= [p x]p_x [q x]q_x eqxx permM /=.
Qed.

Canonical rfd_morphism := Morphism rfd_morph.

Definition rgd_fun (p : {perm T'}) :=
  [fun x1 => if insub x1 is Some u then sval (p u) else x].

Lemma rgdP p : injective (rgd_fun p).
Proof.
apply: can_inj (rgd_fun p^-1) _ => y /=.
case: (insubP _ y) => [u _ val_u|]; first by rewrite valK permK.
by rewrite negbK; move/eqP->; rewrite insubF //= eqxx.
Qed.

Definition rgd p := perm (@rgdP p).

Lemma rfd_odd (p : {perm T}) : p x = x -> rfd p = p :> bool.
Proof.
have rfd1: rfd 1 = 1.
  by apply/permP => u; apply: val_inj; rewrite permE /= if_same !perm1.
have HP0 (t : {perm T}): #|[set x | t x != x]| = 0 -> rfd t = t :> bool.
- move=> Ht; suff ->: t = 1 by rewrite rfd1 !odd_perm1.
  apply/permP => z; rewrite perm1; apply/eqP/wlog_neg => nonfix_z.
  by rewrite (cardD1 z) inE nonfix_z in Ht.
elim: #|_| {-2}p (leqnn #|[set x | p x != x]|) => {p}[|n Hrec] p Hp Hpx.
  by apply: HP0; move: Hp; case: card.
case Ex: (pred0b (mem [set x | p x != x])); first by apply: HP0; move/eqnP: Ex.
case/pred0Pn: Ex => x1; rewrite /= inE => Hx1.
have nx1x: x1 != x by apply/eqP => HH; rewrite HH Hpx eqxx in Hx1.
have npxx1: p x != x1 by apply/eqP => HH; rewrite -HH !Hpx eqxx in Hx1.
have npx1x: p x1 != x.
  by apply/eqP; rewrite -Hpx; move/perm_inj => HH; case/eqP: nx1x.
pose p1 := p * tperm x1 (p x1).
have Hp1: p1 x = x.
  by rewrite /p1 permM; case tpermP => // [<-|]; [rewrite Hpx | move/perm_inj].
have Hcp1: #|[set x | p1 x != x]| <= n.
  have F1 y: p y = y -> p1 y = y.
    move=> Hy; rewrite /p1 permM Hy.
    by case: tpermP => [<-|/(canLR (permK p))<-|] //; apply/(canLR (permK p)).
  have F2: p1 x1 = x1 by rewrite /p1 permM tpermR.
  have F3: [set x | p1 x != x] \subset [predD1 [set x | p x != x] & x1].
    apply/subsetP => z; rewrite !inE permM.
    case tpermP => HH1 HH2.
    - rewrite eq_sym HH1 andbb; apply/eqP=> dx1.
      by rewrite dx1 HH1 dx1 eqxx in HH2.
    - by rewrite (perm_inj HH1) eqxx in HH2.
    by move->; rewrite andbT; apply/eqP => HH3; rewrite HH3 in HH2.
  apply: (leq_trans (subset_leq_card F3)).
  by move: Hp; rewrite (cardD1 x1) inE Hx1.
have ->: p = p1 * tperm x1 (p x1) by rewrite -mulgA tperm2 mulg1.
rewrite odd_permM odd_tperm eq_sym Hx1 morphM; last 2 first.
- by rewrite 2!inE; apply/astab1P.
- by rewrite 2!inE; apply/astab1P; rewrite -{1}Hpx /= /aperm -permM.
rewrite odd_permM Hrec //=; congr (_ (+) _).
pose x2 : T' := Sub x1 nx1x; pose px2 : T' := Sub (p x1) npx1x.
suff ->: rfd (tperm x1 (p x1)) = tperm x2 px2.
  by rewrite odd_tperm -val_eqE eq_sym.
apply/permP => z; apply/val_eqP; rewrite permE /= tpermD // eqxx.
case: (tpermP x2) => [->|->|HH1 HH2]; rewrite /x2 ?tpermL ?tpermR 1?tpermD //.
  by apply/eqP=> HH3; case: HH1; apply: val_inj.
by apply/eqP => HH3; case: HH2; apply: val_inj.
Qed.

Lemma rfd_iso : 'C_('Alt_T)[x | 'P] \isog 'Alt_T'.
Proof.
have rgd_x p: rgd p x = x by rewrite permE /= insubF //= eqxx.
have rfd_rgd p: rfd (rgd p) = p.
  apply/permP => [[z Hz]]; apply/val_eqP; rewrite !permE.
  rewrite /= [rgd _ _]permE /= insubF eq_refl // permE /=.
  by rewrite (@insubT _ (xpredC1 x) _ _ Hz).
have sSd: 'C_('Alt_T)[x | 'P] \subset 'dom rfd.
  by apply/subsetP=> p; rewrite !inE /=; case/andP.
apply/isogP; exists [morphism of restrm sSd rfd] => /=; last first.
  rewrite morphim_restrm setIid; apply/setP=> z; apply/morphimP/idP=> [[p _]|].
    case/setIP; rewrite Alt_even => Hp; move/astab1P=> Hp1 ->.
    by rewrite Alt_even rfd_odd.
  have dz': rgd z x == x by rewrite rgd_x.
  move=> kz; exists (rgd z); last by rewrite /= rfd_rgd.
    by rewrite 2!inE (sameP astab1P eqP).
  rewrite 4!inE /= (sameP astab1P eqP) dz' -rfd_odd; last exact/eqP.
  by rewrite rfd_rgd mker // ?set11.
apply/injmP=> x1 y1 /=.
case/setIP=> Hax1; move/astab1P; rewrite /= /aperm => Hx1.
case/setIP=> Hay1; move/astab1P; rewrite /= /aperm => Hy1 Hr.
apply/permP => z.
case (z =P x) => [->|]; [by rewrite Hx1 | move/eqP => nzx].
move: (congr1 (fun q : {perm T'} => q (Sub z nzx)) Hr).
by rewrite !permE => [[]]; rewrite Hx1 Hy1 !eqxx.
Qed.

End Restrict.

Lemma simple_Alt5 (T : finType) : #|T| >= 5 -> simple 'Alt_T.
Proof.
suff F1 n: #|T| = n + 5 -> simple 'Alt_T by move/subnK/esym/F1.
elim: n T => [| n Hrec T Hde]; first exact: simple_Alt5_base.
have oT: 5 < #|T| by rewrite Hde addnC.
apply/simpleP; split=> [|H Hnorm]; last have [Hh1 nH] := andP Hnorm.
  rewrite trivg_card1 -[#|_|]half_double -mul2n card_Alt Hde addnC //.
  by rewrite addSn factS mulnC -(prednK (fact_gt0 _)).
case E1: (pred0b T); first by rewrite /pred0b in E1; rewrite (eqP E1) in oT.
case/pred0Pn: E1 => x _; have Hx := in_setT x.
have F2: [transitive^4 'Alt_T, on setT | 'P].
  by apply: ntransitive_weak (Alt_trans T); rewrite -(subnKC oT).
have F3 := ntransitive1 (isT: 0 < 4) F2.
have F4 := ntransitive_primitive (isT: 1 < 4) F2.
case Hcard1: (#|H| == 1%N); move/eqP: Hcard1 => Hcard1.
  by left; apply: card1_trivg; rewrite Hcard1.
right; case: (prim_trans_norm F4 Hnorm) => F5.
  by rewrite (trivGP (subset_trans F5 (aperm_faithful _))) cards1 in Hcard1.
case E1: (pred0b (predD1 T x)).
  rewrite /pred0b in E1; move: oT.
  by rewrite (cardD1 x) (eqP E1); case: (T x).
case/pred0Pn: E1 => y Hdy; case/andP: (Hdy) => diff_x_y Hy.
pose K := 'C_H[x | 'P]%G.
have F8: K \subset H by apply: subsetIl.
pose Gx := 'C_('Alt_T)[x | 'P].
have F9: [transitive^3 Gx, on [set~ x] | 'P].
  by rewrite -[[set~ x]]setTI -setDE stab_ntransitive ?inE.
have F10: [transitive Gx, on [set~ x] | 'P].
  by apply: ntransitive1 F9.
have F11: [primitive Gx, on [set~ x] | 'P].
  by apply: ntransitive_primitive F9.
have F12: K \subset Gx by rewrite setSI // normal_sub.
have F13: K <| Gx by apply/andP; rewrite normsIG.
have:= prim_trans_norm F11; case/(_ K) => //= => Ksub; last first.
  have F14: Gx * H = 'Alt_T by apply/(subgroup_transitiveP _ _ F3).
  have: simple Gx.
    by rewrite (isog_simple (rfd_iso x)) Hrec //= card_sig cardC1 Hde.
  case/simpleP=> _ simGx; case/simGx: F13 => /= HH2.
    case Ez: (pred0b (predD1 (predD1 T x) y)).
      move: oT; rewrite /pred0b in Ez.
      by rewrite (cardD1 x) (cardD1 y) (eqP Ez) inE /= inE /= diff_x_y.
    case/pred0Pn: Ez => z; case/andP => diff_y_z Hdz.
    have [diff_x_z Hz] := andP Hdz.
    have: z \in [set~ x] by rewrite !inE.
    rewrite -(atransP Ksub y) ?inE //; case/imsetP => g.
    rewrite /= HH2 inE; move/eqP=> -> HH4.
    by case/negP: diff_y_z; rewrite HH4 act1.
  by rewrite /= -F14 -[Gx]HH2 (mulSGid F8).
have F14: [faithful Gx, on [set~ x] | 'P].
  apply: subset_trans (aperm_faithful 'Sym_T); rewrite subsetI subsetT.
  apply/subsetP=> g; do 2![case/setIP]=> _ cgx cgx'; apply/astabP=> z _ /=.
  case: (z =P x) => [->|]; first exact: (astab1P cgx).
  by move/eqP=> zx; rewrite [_ g](astabP cgx') ?inE.
have Hreg g z: g \in H -> g z = z -> g = 1.
  have F15 h: h \in H -> h x = x -> h = 1.
    move=> Hh Hhx; have: h \in K by rewrite inE Hh; apply/astab1P.
    by rewrite [K](trivGP (subset_trans Ksub F14)) => /set1P.
  move=> Hg Hgz; have:= in_setT x; rewrite -(atransP F3 z) ?inE //.
  case/imsetP=> g1 Hg1 Hg2; apply: (conjg_inj g1); rewrite conj1g.
  apply: F15; last by rewrite Hg2 -permM mulKVg permM Hgz.
  by rewrite memJ_norm ?(subsetP nH).
clear K F8 F12 F13 Ksub F14.
have Hcard: 5 < #|H|.
  apply: (leq_trans oT); apply dvdn_leq; first by apply: cardG_gt0.
  by rewrite -cardsT (atrans_dvd F5).
case Eh: (pred0b [predD1 H & 1]).
  by move: Hcard; rewrite /pred0b in Eh; rewrite (cardD1 1) group1 (eqP Eh).
case/pred0Pn: Eh => h; case/andP => diff_1_h /= Hh.
case Eg: (pred0b (predD1 (predD1 [predD1 H & 1] h) h^-1)).
  move: Hcard; rewrite ltnNge; case/negP.
  rewrite (cardD1 1) group1 (cardD1 h) (cardD1 h^-1) (eqnP Eg).
  by do 2!case: (_ \in _).
case/pred0Pn: Eg => g; case/andP => diff_h1_g; case/andP => diff_h_g.
case/andP => diff_1_g /= Hg.
case diff_hx_x: (h x == x).
by case/negP: diff_1_h; apply/eqP; apply: (Hreg _ _ Hh (eqP diff_hx_x)).
case diff_gx_x: (g x == x).
  case/negP: diff_1_g; apply/eqP; apply: (Hreg _ _ Hg (eqP diff_gx_x)).
case diff_gx_hx: (g x == h x).
  case/negP: diff_h_g; apply/eqP; symmetry; apply: (mulIg g^-1); rewrite gsimp.
  apply: (Hreg _ x); first by rewrite groupM // groupV.
  by rewrite permM -(eqP diff_gx_hx) -permM mulgV perm1.
case diff_hgx_x: ((h * g) x == x).
  case/negP: diff_h1_g; apply/eqP; apply: (mulgI h); rewrite !gsimp.
  by apply: (Hreg _ x); [apply: groupM | apply/eqP].
case diff_hgx_hx: ((h * g) x == h x).
  case/negP: diff_1_g; apply/eqP.
  by apply: (Hreg _ (h x)) => //; apply/eqP; rewrite -permM.
case diff_hgx_gx: ((h * g) x == g x).
  by case/idP: diff_hx_x; rewrite -(can_eq (permK g)) -permM.
case Ez: (pred0b
            (predD1 (predD1 (predD1 (predD1 T x) (h x)) (g x)) ((h * g) x))).
- move: oT; rewrite /pred0b in Ez.
  rewrite (cardD1 x) (cardD1 (h x)) (cardD1 (g x)) (cardD1 ((h * g) x)).
  by rewrite (eqP Ez) addnC; do 3!case: (_ x \in _).
case/pred0Pn: Ez => z.
case/and5P=> diff_hgx_z diff_gx_z diff_hx_z diff_x_z /= Hz.
pose S1 := [tuple x; h x; g x; z].
have DnS1: S1 \in 4.-dtuple(setT).
  rewrite inE memtE subset_all -!andbA !negb_or /= !inE !andbT.
  rewrite -!(eq_sym z) diff_gx_z diff_x_z diff_hx_z.
  by rewrite !(eq_sym x) diff_hx_x diff_gx_x eq_sym diff_gx_hx.
pose S2 := [tuple x; h x; g x; (h * g) x].
have DnS2: S2 \in 4.-dtuple(setT).
  rewrite inE memtE subset_all -!andbA !negb_or /= !inE !andbT !(eq_sym x).
  rewrite diff_hx_x diff_gx_x diff_hgx_x.
  by rewrite !(eq_sym (h x)) diff_gx_hx diff_hgx_hx eq_sym diff_hgx_gx.
case: (atransP2 F2 DnS1 DnS2) => k Hk [/=].
rewrite /aperm => Hkx Hkhx Hkgx Hkhgx.
have h_k_com: h * k = k * h.
  suff HH: (k * h * k^-1) * h^-1 = 1 by rewrite -[h * k]mul1g -HH !gnorm.
  apply: (Hreg _ x); last first.
    by rewrite !permM -Hkx Hkhx -!permM mulKVg mulgV perm1.
  by rewrite groupM // ?groupV // (conjgCV k) mulgK -mem_conjg (normsP nH).
have g_k_com: g * k = k * g.
  suff HH: (k * g * k^-1) * g^-1 = 1 by rewrite -[g * k]mul1g -HH !gnorm.
  apply: (Hreg _ x); last first.
    by rewrite !permM -Hkx Hkgx -!permM mulKVg mulgV perm1.
  by rewrite groupM // ?groupV // (conjgCV k) mulgK -mem_conjg (normsP nH).
have HH: (k * (h * g) * k ^-1) x = z.
   by rewrite 2!permM -Hkx Hkhgx -permM mulgV perm1.
case/negP: diff_hgx_z.
rewrite -HH !mulgA -h_k_com -!mulgA [k * _]mulgA.
by rewrite -g_k_com -!mulgA mulgV mulg1.
Qed.


(* Bonus lemmas that aren't used by the main proofs *)

Require Import Iron.Language.Simple.Exp.
Require Import Iron.Language.Simple.Ty.
Require Import Iron.Language.Simple.SubstExpExp.

(********************************************************************)
(* Weakening type environments *)
Lemma type_tyenv_weaken1
 :  forall te x t1 t2
 ,  TYPE te          x t1
 -> TYPE (t2 <: te)  x t1.
Proof.
 intros. gen te t1.
 induction_type x.

 Case "XLam".
  eapply TYLam. rewrite snoc_cons. auto.
Qed.

Lemma type_tyenv_weaken
 :  forall tenv1 tenv2 x1 t1
 ,  TYPE tenv1            x1 t1
 -> TYPE (tenv2 >< tenv1) x1 t1.
Proof.
 intros. gen tenv1.
 induction tenv2; intros.
  rewrite app_nil_right. auto.
  rewrite app_snoc.  apply IHtenv2.
   apply type_tyenv_weaken1. auto.
Qed.

(********************************************************************)
(* Strengthen type environments *)
Lemma type_tyenv_strengthen
 :  forall te te' n x t
 ,   wfX te' x
 ->  te' = firstn n te
 ->  TYPE te  x t
 ->  TYPE te' x t.
Proof.
 intros. gen te te' n t.
 induction_type x; subst.

 Case "XVar".
  destruct H; burn.

 Case "XLam".
  eapply TYLam.
  eapply IHx with (n := S n) (te := te :> t); burn.
Qed.

Lemma type_check_closed_in_empty_tyenv
 :  forall tenv x t
 ,  closedX x
 -> TYPE tenv x t
 -> TYPE nil  x t.
Proof.
 rip.
 eapply type_tyenv_strengthen; burn.
 symmetry.
 eapply firstn_zero.
Qed.

Theorem type_check_closed_in_any_tyenv
 :  forall tenv tenv' x1 t1
 ,  closedX x1
 -> TYPE tenv  x1 t1
 -> TYPE tenv' x1 t1.
Proof.
 rip.

 have (TYPE nil x1 t1)
  by burn using type_check_closed_in_empty_tyenv.

 rrwrite (tenv' = tenv' >< nil).
 eauto using type_tyenv_weaken.
Qed.

(* If an expression is well formed under a given environment,
   then all its indices are less than the length of this environment.
   Lifting indices more than this length doesn't do anything *)
Theorem liftX_wfX
 :  forall d x e
 ,  d = length e
 -> wfX e x
 -> liftX d x = x.
Proof.
 intros. gen e d.
 induction x; intros; norm.

 Case "XVar".
  lift_cases; intros; eauto.
  false. subst. destruct H0.
   eapply get_above_false in H; auto.

 Case "XLam".
  eapply IHx in H0; eauto.
  simpl in H0. symmetry. rewrite H. rewrite H0. auto.

 Case "XApp".
  spec IHx1 H1. rewrite IHx1; burn.
  spec IHx2 H2. rewrite IHx2; burn.
Qed.

(* If an expression is closed then it has no free indices.
   Lifting it doesn't do anything. *)
Lemma liftX_closed
 :  forall x
 ,  closedX x
 -> liftX 0 x = x.
Proof.
 rip. eapply liftX_wfX; burn. burn.
Qed.


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

Set Printing Depth 1000.
Definition lfind_eval  y:=
len y.

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ (Succ Zero))) Nil)).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil)))).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)))).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).


Require Import Notation.
Require Import GeneralTactics.

Lemma proof_irrelevance__uip_refl :
  (forall (P: Prop) (p1 p2: P), p1 = p2) ->
  forall A (x: A) (h: x = x), h = eq_refl x.
Proof using.
  intros ? *.
  assumption!.
Qed.

Module Type UipImpl.
  Axiom uip_refl : forall A (x: A) (h: x = x), h = eq_refl x.
End UipImpl.

Module UipTheory (M: UipImpl).

Lemma uip_refl : forall A (x: A) (h: x = x), h = eq_refl x.
Proof using.
  exact M.uip_refl.
Qed.

Lemma uip : forall A (x y: A) (p q: x = y),
  p = q.
Proof using.
  intros.
  destruct q.
  apply uip_refl.
Qed.

Lemma eq_K : forall A (x: A) (P: x = x -> Type),
  P (eq_refl x) ->
  forall p: x = x, P p.
Proof using.
  intros.
  now rewrite uip_refl.
Qed.

Lemma eq_rect_eq : forall A (x: A) (P: A -> Type) (y: P x) (h: x = x),
  y = eq_rect x P y x h.
Proof using.
  intros *.
  now rewrite (uip_refl _ _ h).
Qed.

Lemma inj_pair2 :
  forall A (P: A -> Type) a (x y: P a),
    ⟨a, x⟩ = ⟨a, y⟩ ->
    x = y.
Proof using.
  intros.
  inversion_sigma.
  now find rewrite <- eq_rect_eq in.
Qed.

Notation inj_pairT2 := inj_pair2.

(* Dependent inversion tactics leveraging LEM *)

Ltac destr_sigma_eq :=
  repeat match goal with
  | H: existT _ _ _ = existT _ _ _ |- _ =>
      simple apply inj_pairT2 in H
  end.

Tactic Notation "dependent" "inv" hyp(H) :=
  inv H;
  destr_sigma_eq;
  subst!.

Tactic Notation "dependent" "inv" hyp(H) "as" simple_intropattern(pat) :=
  inv H as pat;
  destr_sigma_eq;
  subst!.

Tactic Notation "dependent" "invc" hyp(H) :=
  invc H;
  destr_sigma_eq;
  subst!.

Tactic Notation "dependent" "invc" hyp(H) "as" simple_intropattern(pat) :=
  invc H as pat;
  destr_sigma_eq;
  subst!.

(* Here we give a redefinition of the JMeq construct. Unfortunately, the
   existing JMeq definition is irrevocably tied to the JMeq_eq axiom,
   which we'd rather not accept here, since it can be derived by
   UIP (and by extesion, LEM).
 *)

(* heq stands for "heterogeneous equality" *)
Unset Elimination Schemes.
Inductive heq (A: Type) (x : A) : forall B : Type, B -> Prop :=
	| heq_refl : heq A x A x.
Set Elimination Schemes.
Arguments heq {A} x {B} y.
Arguments heq_refl {A} x.

Notation "x ~= y" := (heq x y) (at level 70, no associativity).

(* Note: this is in fact equivalent to UIP. *)
Lemma heq_eq : forall A (x y: A),
  x ~= y ->
  x = y.
Proof using.
  intros * Heq.
  now dependent inv Heq.
Qed.

Theorem heq_rect : forall (A: Type) (x: A) (P : A -> Type),
  P x ->
  forall y : A, x ~= y -> P y.
Proof using.
  intros * ? * Heq.
  apply heq_eq in Heq.
  now induction Heq.
Qed.

Lemma heq_rec : forall (A: Type) (x: A) (P : A -> Set),
  P x ->
  forall y : A, x ~= y -> P y.
Proof using.
  exact heq_rect.
Qed.

Lemma heq_ind : forall (A: Type) (x: A) (P : A -> Prop),
  P x ->
  forall y : A, x ~= y -> P y.
Proof using.
  exact heq_rect.
Qed.

End UipTheory.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                          Dependent_lists.v                               *)
(****************************************************************************)

Require Export Eqdep.
Require Export Arith.

Global Set Asymmetric Patterns.
Set Implicit Arguments.
Unset Strict Implicit.

Section Dependent_lists.

  Variable A : Set.

  Inductive d_list : nat -> Set :=
    | d_nil : d_list 0
    | d_cons : forall n : nat, A -> d_list n -> d_list (S n).

  Definition eq_d_list := eq_dep nat d_list.

  Definition d_hd (n : nat) (l : d_list n) : Exc A :=
    match l in (d_list m) return (Exc A) with
    | d_nil => error
    | d_cons p a l' => value a
    end.

  Definition d_head (n : nat) (l : d_list n) :=
    match l in (d_list p) return (0 < p -> A) with
    | d_nil =>
        (* d_nil*)
        fun h : 0 < 0 => False_rec A (lt_irrefl 0 h)
        (* d_cons p a l' *)
    | d_cons p a l' => fun h : 0 < S p => a
    end.

  Definition d_Head (n : nat) (l : d_list (S n)) := d_head l (lt_O_Sn n).

  Definition d_tl (n : nat) (l : d_list n) : d_list (pred n) :=
    match l in (d_list m) return (d_list (pred m)) with
    | d_nil => d_nil
    | d_cons p a l' => l'
    end.

  Lemma empty_dep :
   forall (n : nat) (l : d_list n), n = 0 -> eq_d_list d_nil l.
  unfold eq_d_list in |- *; intros n l.
  dependent inversion_clear l; auto.
  intros H; absurd (S n0 = 0); auto.
  Qed.

  Hint Immediate empty_dep.

  Lemma empty : forall l : d_list 0, d_nil = l.
  intros l.
  apply (eq_dep_eq nat d_list 0).
  apply empty_dep; auto.
  Qed.

  Hint Immediate empty.

  Remark non_empty_dep :
   forall n m : nat,
   m = S n ->
   forall l : d_list (S n),
   {h : A &  {t : d_list n | eq_d_list l (d_cons h t)}}.
  intros n m H l.
  generalize H; clear H.
  dependent inversion_clear l
   with
    (fun (n' : nat) (l : d_list n') =>
     m = n' -> {a : A &  {l' : d_list n | eq_d_list l (d_cons a l')}}).
  unfold eq_d_list in |- *.
  intros H; exists a; exists d; auto.
  Qed.

  Lemma non_empty :
   forall (n : nat) (l : d_list (S n)),
   {a : A &  {t : d_list n | l = d_cons a t}}.
  intros n l.
  cut
   (sigT (fun a : A => sig (fun t : d_list n => eq_d_list l (d_cons a t)))).
  intros H; elim H; clear H.
  intros a H; elim H; clear H.
  intros t H.
  exists a; exists t.
  apply eq_dep_eq with (U := nat) (P := d_list) (p := S n).
  unfold eq_d_list in H; auto.
  apply (non_empty_dep (n:=n) (m:=S n)); auto.
  Qed.

  Lemma split_d_list :
   forall (n : nat) (l : d_list (S n)),
   l = d_cons (d_head l (lt_O_Sn n)) (d_tl l).
  intros n l.
  elim (non_empty l).
  intros h H; elim H; clear H.
  intros t e.
  rewrite e; simpl in |- *.
  auto.
  Qed.

  Definition d_Hd (n : nat) (l : d_list (S n)) :=
    let (a, P) return A := non_empty l in a.

  Lemma Non_empty_Hd :
   forall (n : nat) (a : A) (l : d_list n), d_Hd (d_cons a l) = a.
  intros n a l; unfold d_Hd in |- *.
  elim (non_empty (d_cons a l)).
  intros x H; elim H.
  clear H; intros X H.
  injection H; auto.
  Qed.

End Dependent_lists.

Hint Immediate empty_dep empty non_empty Non_empty_Hd.

(** Definitions of some usual mappings **)

Fixpoint d_map (A B : Set) (f : A -> B) (n : nat) (l : d_list A n) {struct l}
   : d_list B n :=
  match l in (d_list _ x) return (d_list B x) with
  | d_nil =>
      (*(d_nil A)*)  d_nil B
      (*(d_cons A p a t*)
  | d_cons p a t => d_cons (f a) (d_map f t)
  end.

Fixpoint d_map2 (A B C : Set) (f : A -> B -> C) (n : nat) {struct n} :
 d_list A n -> d_list B n -> d_list C n :=
  match n as x return (d_list A x -> d_list B x -> d_list C x) with
  | O => fun (_ : d_list A 0) (_ : d_list B 0) => d_nil C
  | S p =>
      fun (l1 : d_list A (S p)) (l2 : d_list B (S p)) =>
      d_cons (f (d_Head l1) (d_Head l2)) (d_map2 f (d_tl l1) (d_tl l2))
  end.

Fixpoint d_map3 (A B C D : Set) (f : A -> B -> C -> D)
 (n : nat) {struct n} :
 d_list A n -> d_list B n -> d_list C n -> d_list D n :=
  match
    n as x return (d_list A x -> d_list B x -> d_list C x -> d_list D x)
  with
  | O => fun (_ : d_list A 0) (_ : d_list B 0) (_ : d_list C 0) => d_nil D
  | S p =>
      fun (l1 : d_list A (S p)) (l2 : d_list B (S p)) (l3 : d_list C (S p)) =>
      d_cons (f (d_Head l1) (d_Head l2) (d_Head l3))
        (d_map3 f (d_tl l1) (d_tl l2) (d_tl l3))
  end.

Fixpoint d_map4 (A B C D E : Set) (f : A -> B -> C -> D -> E)
 (n : nat) {struct n} :
 d_list A n -> d_list B n -> d_list C n -> d_list D n -> d_list E n :=
  match
    n as x
    return
      (d_list A x -> d_list B x -> d_list C x -> d_list D x -> d_list E x)
  with
  | O =>
      fun (_ : d_list A 0) (_ : d_list B 0) (_ : d_list C 0) (_ : d_list D 0) =>
      d_nil E
  | S p =>
      fun (l1 : d_list A (S p)) (l2 : d_list B (S p))
        (l3 : d_list C (S p)) (l4 : d_list D (S p)) =>
      d_cons (f (d_Head l1) (d_Head l2) (d_Head l3) (d_Head l4))
        (d_map4 f (d_tl l1) (d_tl l2) (d_tl l3) (d_tl l4))
  end.


(* Lemmas used by the hmac proofs that are independent of C/CompCert/VST*)

Require Import Integers.
Require Import Coqlib.
Require Import List. Import ListNotations.
Require Import SHA256.
(* Require Import spec_sha. *)
(* Require Import sha_lemmas. *)
Require Import pure_lemmas.     (* sha *)
Require Import hmac_pure_lemmas.

Require Import HMAC_functional_prog_Z.

Lemma str_to_Z_length: forall k,
      String.length k = length (str_to_Z k).
Proof. intros. induction k; simpl; auto. Qed.

Lemma first64_sixtyfour {A} (a:A):
      firstn 64 (HMAC_progZ.HMAC_SHA256.sixtyfour a) = HMAC_progZ.HMAC_SHA256.sixtyfour a.
Proof. apply firstn_precise. simpl. reflexivity. Qed.

Lemma length_SF {A} (x:A): length (HMAC_progZ.HMAC_SHA256.sixtyfour x) = 64%nat.
Proof.
  unfold HMAC_progZ.HMAC_SHA256.sixtyfour.
  rewrite length_list_repeat; trivial.
Qed.

(* TODO: mkArgZ removed
Lemma Zlength_mkArgZ k pad: Zlength (HMAC_progZ.HMAC_SHA256.mkArgZ k pad) = Z.of_nat (min (length k) 64).
Proof. intros. repeat rewrite Zlength_correct.
   unfold HMAC_progZ.HMAC_SHA256.mkArgZ, HMAC_progZ.HMAC_SHA256.mkArg, HMAC_progZ.HMAC_SHA256.sixtyfour.
   repeat rewrite map_length.
   rewrite combine_length, length_list_repeat . trivial.
Qed.
*)

Lemma zeropad_isbyteZ: forall l, Forall isbyteZ l -> Forall isbyteZ (HMAC_progZ.HMAC_SHA256.zeroPad l).
Proof. unfold isbyteZ, HMAC_progZ.HMAC_SHA256.zeroPad; intros.
  rewrite Forall_forall in *. intros.
  apply in_app_or in H0.
  destruct H0. apply (H _ H0).
  apply in_list_repeat in H0. (*apply In_Nlist in H0.*) subst; omega.
Qed.

Lemma unsigned_Brepr_isbyte z: isbyteZ z -> Byte.unsigned (Byte.repr z) = z.
Proof. intros.
      unfold isbyteZ in H. apply Byte.unsigned_repr.
      unfold Byte.max_unsigned, Byte.modulus. simpl. omega.
Qed.

Lemma map_unsigned_Brepr_isbyte: forall l, Forall isbyteZ l ->
      map Byte.unsigned (map Byte.repr l) = l.
Proof. intros. induction l; simpl in *. trivial.
   rewrite IHl. rewrite Forall_forall in H.
   assert (In a (a::l)). left. trivial.
   specialize (H _ H0); clear H0.
   rewrite unsigned_Brepr_isbyte; trivial.
   rewrite Forall_forall in *. intros. apply H. right; trivial.
Qed.

Lemma isByte_ByteUnsigned b: isbyteZ (Byte.unsigned b).
Proof.
  unfold Byte.unsigned, Byte.intval. destruct b.
  unfold Byte.modulus, Byte.wordsize, Wordsize_8.wordsize in intrange.
  rewrite two_power_nat_correct in intrange.
  unfold Zpower_nat in intrange. simpl in intrange. unfold isbyteZ. omega.
Qed.

Lemma nth_zeropad_left {d d'}: forall l i (I: 0<= i < Zlength l),
      nth (Z.to_nat i) (HMAC_progZ.HMAC_SHA256.zeroPad l) d = nth (Z.to_nat i) l d'.
Proof. unfold HMAC_progZ.HMAC_SHA256.zeroPad. intros.
  destruct I.
  apply Z2Nat.inj_lt in H0; try omega.
  rewrite Zlength_correct, Nat2Z.id in H0.
  rewrite app_nth1; trivial.
  apply nth_indep; trivial.
Qed.

Lemma mkKey_left {d d'}: forall l (L: false = (Zlength l >? 64))
        i (I: 0<= i < Zlength l),
      nth (Z.to_nat i) (HMAC_progZ.HMAC_SHA256.mkKey l) d = nth (Z.to_nat i) l d'.
Proof.
  unfold HMAC_progZ.HMAC_SHA256.mkKey. intros. simpl. rewrite <- L.
  apply nth_zeropad_left; trivial.
Qed.

Lemma nth_zeropad_right {d} l i (I: Zlength l <= i < 64):
      nth (Z.to_nat i) (HMAC_progZ.HMAC_SHA256.zeroPad l) d = Z0.
Proof. unfold HMAC_progZ.HMAC_SHA256.zeroPad.
  specialize (Zlength_nonneg l). intros.
  rewrite app_nth2. rewrite nth_list_repeat'. trivial.
  apply minus_lt_compat_r. destruct I. apply Z2Nat.inj_lt in H1. apply H1.
  omega.
  omega.
  destruct I. apply Z2Nat.inj_le in H0; trivial.
    rewrite Zlength_correct, Nat2Z.id in H0. apply H0.
    omega.
  destruct I. apply Z2Nat.inj_le in H0; trivial.
    rewrite Zlength_correct, Nat2Z.id in H0. apply H0.
    omega.
Qed.

Lemma mkKey_right {d}: forall l (L: false = (Zlength l >? 64))
        i (I: Zlength l <= i < 64),
      nth (Z.to_nat i) (HMAC_progZ.HMAC_SHA256.mkKey l) d = Z0.
Proof.
  unfold HMAC_progZ.HMAC_SHA256.mkKey. intros. simpl. rewrite <- L.
  apply nth_zeropad_right; trivial.
Qed.

Lemma isbyte_map_ByteUnsigned l: Forall isbyteZ (map Byte.unsigned l).
Proof.
  rewrite Forall_forall. intros.
  apply list_in_map_inv in H. destruct H as [b [B1 _]]. subst x.
  apply isByte_ByteUnsigned.
Qed.

(* HMAC_progZ.SHA256_ changed *)

Lemma zeroPad_BlockSize: forall k, (length k <= HMAC_progZ.SHA256_.BlockSize)%nat ->
  length (HMAC_progZ.HMAC_SHA256.zeroPad k) = HMAC_progZ.SHA256_.BlockSize%nat.
Proof. unfold HMAC_progZ.HMAC_SHA256.zeroPad. intros. rewrite app_length, (*length_Nlist*) length_list_repeat. omega.
Qed.

Lemma length_SHA256': forall l,
  length (functional_prog.SHA_256' l) = HMAC_progZ.SHA256_.DigestLength.
Proof. intros. unfold functional_prog.SHA_256'. simpl.
  rewrite length_intlist_to_Zlist, functional_prog.length_process_msg. reflexivity.
Qed.

Lemma mkKey_length l: length (HMAC_progZ.HMAC_SHA256.mkKey l) = HMAC_progZ.SHA256_.BlockSize.
Proof. intros. unfold HMAC_progZ.HMAC_SHA256.mkKey.
  remember (Zlength l >? Z.of_nat HMAC_progZ.SHA256_.BlockSize) as z.
  destruct z. apply zeroPad_BlockSize.
    rewrite length_SHA256'.
    apply Nat2Z.inj_le. simpl. omega.
  apply zeroPad_BlockSize.
    rewrite Zlength_correct in Heqz.
    apply Nat2Z.inj_le.
    specialize (Zgt_cases (Z.of_nat (Datatypes.length l)) (Z.of_nat HMAC_progZ.SHA256_.BlockSize)). rewrite <- Heqz. trivial.
Qed.

Lemma mkKey_atBlockSize s: length s = HMAC_progZ.SHA256_.BlockSize%nat ->
      HMAC_progZ.HMAC_SHA256.mkKey s = s.
Proof. unfold HMAC_progZ.HMAC_SHA256.mkKey. rewrite Zlength_correct.
  intros. rewrite H.
  simpl. unfold HMAC_progZ.HMAC_SHA256.zeroPad. rewrite H. simpl.
  apply app_nil_r.
Qed.

Lemma isbyte_sha x: Forall isbyteZ (functional_prog.SHA_256' x).
Proof. apply isbyte_intlist_to_Zlist. Qed.

Lemma isbyte_hmac ipad opad m k:
   Forall isbyteZ (HMAC_functional_prog.HP.HMAC_SHA256.HMAC ipad opad m k).
Proof. apply isbyte_sha. Qed.

(* s256a_len from spec_sha *)
(*
Lemma updAbs_len: forall L s t, update_abs L s t -> s256a_len t = s256a_len s + Zlength L * 8.
Proof. intros. inversion H; clear H.
  unfold s256a_len. simpl.
  rewrite Zlength_app. subst.
  repeat rewrite Z.mul_add_distr_r.
  repeat rewrite <- Z.add_assoc.
  assert (Zlength blocks * WORD * 8 + Zlength newfrag * 8 =
          Zlength oldfrag * 8 + Zlength L * 8).
    assert (Zlength (oldfrag ++ L) = Zlength (SHA256.intlist_to_Zlist blocks ++ newfrag)).
      rewrite H4; trivial.
    clear H4. rewrite Zlength_app in H.
              rewrite <- (Z.mul_add_distr_r (Zlength oldfrag)), H. clear H.
              rewrite Zlength_app, Zlength_intlist_to_Zlist.
              rewrite (Z.mul_comm WORD). rewrite Z.mul_add_distr_r. trivial.
  rewrite H; trivial.
Qed.
*)

Lemma HMAC_length d k: length (HMAC_progZ.HMAC256 d k) = 32%nat.
Proof.
  unfold HMAC_progZ.HMAC_SHA256.HMAC, HMAC_progZ.HMAC_SHA256.OUTER.
  apply length_SHA256'.
Qed.
Lemma HMAC_Zlength d k: Zlength (HMAC_progZ.HMAC256 d k) = 32.
Proof.
  rewrite Zlength_correct, HMAC_length. reflexivity.
Qed.


From mathcomp
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype.
From mathcomp
Require Import tuple finfun bigop finset.

(* Auxiliary bigop lemmas, all of them are straightforward copies from
 * the ones in finset.v, thus finset's LICENSE applies. Not much to
 * document.
 *
 * We also define \bigcup in for fset_scope.
 *)

Section BigCupSeq.

Variables (T : finType) (I : eqType).
Implicit Types (P : pred I) (F :  I -> {set T}).

Lemma bigcup_seqP x P F l :
  reflect (exists2 i : I, i \in l & (x \in F i) && P i) (x \in \bigcup_(t <- l | P t) F t).
Proof.
rewrite big_tnth; apply/(iffP idP).
  by case/bigcupP=> i Hp Hin; exists (tnth (in_tuple l) i); rewrite ?mem_tnth ?Hin.
by case=> i /seq_tnthP[t ht] /andP[xf xp]; apply/bigcupP; exists t; rewrite -?ht.
Qed.

Lemma bigcups_seqP (U : pred T) (P : pred I) (F : I -> {set T}) (r : seq I) :
  reflect (forall i : I, i \in r -> P i -> F i \subset U)
          (\bigcup_(i <- r | P i) F i \subset U).
Proof.
apply/(iffP idP).
  by rewrite big_tnth; move/bigcupsP=> H i /seq_tnthP[idx -> hp]; exact: H.
by move=> H; rewrite big_tnth; apply/bigcupsP=> i ?; apply: H; rewrite ?mem_tnth.
Qed.

End BigCupSeq.

(* Add LoadPath "." as lib. *)
(* Require Import lib.finmap. *)
Require Import finmap.
Open Scope fset_scope.

Notation "\bigcup_ ( i <- r | P ) F" :=
  (\big[@fsetU _/fset0]_(i <- r | P%fset) F%fset) : fset_scope.

Notation "\bigcup_ ( i <- r ) F" :=
  (\big[@fsetU _/fset0]_(i <- r) F%fset) : fset_scope.

Notation "\bigcup_ ( i | P ) F" :=
  (\big[@fsetU _/fset0]_(i | P) F%fset) : fset_scope.

Notation "\bigcup_ ( i 'in' A | P ) F" :=
  (\big[@fsetU _/fset0]_(i in A | P) F%fset) : fset_scope.

Notation "\bigcup_ ( i 'in' A ) F" :=
  (\big[@fsetU _/fset0]_(i in A) F%fset) : fset_scope.

Section FSetMonoids.

Import Monoid.
Variable (T : choiceType).

(* Not valid for setI *)
(* Canonical fsetI_monoid := Law (@fsetIA T) (@fsetTI T) (@setIT T). *)
(* Canonical fsetI_comoid := ComLaw (@fsetIC T). *)
(* Canonical fsetI_muloid := MulLaw (@fset0I T) (@fsetI0 T). *)

Canonical fsetU_monoid := Law (@fsetUA T) (@fset0U T) (@fsetU0 T).
Canonical fsetU_comoid := ComLaw (@fsetUC T).
Canonical fsetU_addoid := AddLaw (@fsetIUl T) (@fsetIUr T).
Canonical fsetI_muloid := MulLaw (@fset0I T) (@fsetI0 T).

End FSetMonoids.

Section BigFOpsFin.

Variables (T : choiceType) (I : finType).
Implicit Types (P : pred I) (A B : {fset I}) (F :  I -> {fset T}).

Lemma bigfcup_sup j P F : P j -> F j `<=` \bigcup_(i | P i) F i.
Proof. by move=> Pj; rewrite (bigD1 j) //= fsubsetUl. Qed.

Lemma bigfcupP x F P :
  reflect (exists2 i : I, P i & x \in F i) (x \in (\bigcup_(i | P i) F i)).
Proof.
apply: (iffP idP) => [|[i Pi]]; last first.
  apply: fsubsetP x; exact: bigfcup_sup.
by elim/big_rec: _ => [|i _ Pi _ /fsetUP[|//]]; [rewrite in_fset0 | exists i].
Qed.

Lemma bigfcupsP (U : {fset T}) P F :
  reflect (forall i : I, P i -> F i `<=` U)
          (\bigcup_(i | P i) F i `<=` U).
Proof.
apply: (iffP idP) => [sFU i Pi| sFU].
  by apply: fsubset_trans sFU; apply: bigfcup_sup.
by apply/fsubsetP=> x /bigfcupP[i Pi]; apply: (fsubsetP (sFU i Pi)).
Qed.

End BigFOpsFin.

Section BigFOpsSeq.

Variables (T : choiceType) (I : eqType).
Implicit Types (l : seq I) (P : pred I) (U : {fset T}) (F :  I -> {fset T}).

Lemma bigfcup_seqP x F l :
  reflect (exists2 i : I, i \in l & x \in F i) (x \in \bigcup_(t <- l) F t).
Proof.
rewrite big_tnth; apply/(iffP idP).
  by case/bigfcupP=> u _ xf; exists (tnth (in_tuple l) u); rewrite ?mem_tnth.
by case=> i /seq_tnthP[t hi] xf; apply/bigfcupP; exists t; rewrite -?hi.
Qed.

Lemma bigfcups_seqP F U l :
  reflect (forall i : I, i \in l -> F i `<=` U) (\bigcup_(i <- l) F i `<=` U).
Proof.
rewrite big_tnth; apply/(iffP idP).
  by move/bigfcupsP=> H i /seq_tnthP[t ->]; apply: H.
by move=> H; apply/bigfcupsP=> i _; apply: H; rewrite mem_tnth.
Qed.

End BigFOpsSeq.


Require Import STLCdbj.syntax.
Require Import STLCdbj.bindings.
Require Import Cpdt.CpdtTactics.
Require Import STLCdbj.syn_typing.
Require Import Utf8.

Implicit Types V:Set.

(*
Inductive val (V: Set) : Set :=
  | v_var  : V -> val V
  | v_true : val V
  | v_false : val V
  | v_abs  : exp (inc V) -> val V
with exp (V : Set) : Set :=
  | e_val  : val V -> exp V
  | e_if   : exp V -> exp V -> exp V -> exp V
  | e_app  : exp V -> exp V -> exp V.
   *)

Inductive step {V} : exp V -> exp V -> Prop :=
  | st_app3: forall T exp_body v,
      step (e_app (e_val (v_abs T exp_body)) (e_val v)) ((V_subst_exp v) exp_body)
  | st_if2: forall a b,
      step (e_if (e_val v_true) a b) a
  | st_if3: forall a b,
      step (e_if (e_val v_false) a b) b
  | st_app1: forall e1 e1' e2,
      step e1 e1' ->
      step (e_app e1 e2) (e_app e1' e2)
  | st_app2: forall T exp_body e2 e2',
      step e2 e2' ->
      step (e_app (e_val (v_abs T exp_body)) e2) (e_app (e_val (v_abs T exp_body)) e2')
  | st_if1: forall cond cond' a b,
      step cond cond' ->
      step (e_if cond a b) (e_if cond' a b).

Notation "s1 '↝' s2" := (step s1 s2)
      (at level 101).

Theorem step_determinstic
{V} {x y : exp V}
(h0: step x y):
forall z,
 step x z ->
y = z.

Ltac cleanup_impossible:=
  match goal with
  | [h : step (e_val _) _ |- _] => inversion h
  | h0 :  val_has_type _ (v_abs _ _ _) ty_bool |- _ => inversion h0
  | [h : step (e_if (e_val (v_var _)) _ _) _ |- _] => inversion h
  | [h : step (e_if (e_val (v_abs _ _)) _ _) _ |- _] => inversion h

  end.

Ltac destruct_ALL :=
    repeat
      match goal with
      | [h : _ \/ _ |- _ ] => destruct h; subst; eauto
      | [h : _ /\ _ |- _ ] => destruct h; subst; eauto
      | [h : exists _ , _ |- _ ] => destruct h; subst; eauto
      | [h : Some _ = Some _ |- _] => inversion h; subst; eauto
      | [h : {_} + {_} |- _] => destruct h; subst; eauto
      end.

induction h0; intros z H;
inversion H; subst; eauto;
try cleanup_impossible; try discriminate; try contradiction;
crush;
match goal with
| [h : context[_ ->  _ = _] |- _] => erewrite h; eauto
end.
Qed.

Inductive steps {V} : exp V -> exp V -> Prop :=
  | sts_refl : forall x,
      steps x x
  | sts_trans: forall x y z,
      step x y ->
      steps y z ->
      steps x z.

Notation "x '↝¹' y" := (step x y)
      (at level 101).

Notation "x '↝⁺' y" := (steps x y)
      (at level 101).

Definition irreducible {V} (x : exp V) :=
    ~(exists y, step x y).

Lemma irreducible_val:
    forall V (s: val V),
      irreducible (e_val s).
    intros V s h. destruct_ALL; subst; eauto.
    try match goal with
          | h : step _ _  |- _ => inversion h; subst; eauto; fail
    end.
  Qed.

Section steps_property.

Hint Constructors step steps val_has_type exp_has_type exp val.

  Lemma irreducible_eapp_inv:
    forall V (a b : exp V),
      irreducible (e_app a b) ->
      irreducible a.

      unfold irreducible in *.
  intros V a b h. intros h1; subst; eauto; destruct_ALL; try contradiction; try discriminate; eauto; crush.
  Qed.

  Lemma irreducible_eif_inv:
    forall V (a b c : exp V),
      irreducible (e_if a b c) ->
      irreducible a.

      unfold irreducible in *.
  intros V a b c h. intros h1; subst; eauto; destruct_ALL; try contradiction; try discriminate; eauto.
  Qed.

  Hint Resolve irreducible_val irreducible_eapp_inv irreducible_eif_inv.

  Theorem steppable_dec:
    forall V (t : exp V),
      (exists t', step t t') \/ (irreducible t).

Ltac try_both_side  :=
    try (left; eauto; crush; fail);
    try (right; intros h; destruct_ALL;
    match goal with
    | h : step (e_if _ _ _ ) _ |- _ =>
      inversion h; subst
    | h : step (e_app _ _) _ |- _ =>
      inversion h; subst
    end;
        (* for example
             *)
    subst; eauto; try contradiction; try discriminate; try cleanup_impossible; eauto;crush; fail).
    intros V t. induction t; subst; eauto.
    + clear IHt2 IHt3. destruct_ALL; crush.
        destruct t1;
        try_both_side.
        destruct v; try_both_side.
    +  destruct_ALL; crush.
        destruct t1; try_both_side.
        destruct v; try_both_side.
        destruct t1; try_both_side.
        destruct v; try_both_side.
        destruct t2; try_both_side.
Qed.

End steps_property.