Require Import Omega.
Require Import List.
Require Import FunctionalExtensionality.
Require Import Eqdep_dec.
Require Import RelationClasses.

Record pos :=
  mkPos { row : nat;
          col : nat }.

Notation "x & y" := (mkPos x y) (at level 50).

Inductive pos_le : pos -> pos -> Prop :=
| Pos_le : forall n m n' m',
    n <= n' ->
    m <= m' ->
    pos_le (n & m) (n' & m').

Hint Constructors pos_le.
Hint Extern 4 (_ <= _) => omega.

Ltac destruct_pos :=
  match reverse goal with
    | [ p: pos |- _ ] =>
      let n := fresh "n" in
      let m := fresh "m" in
      destruct p as [n m]
  end.

Ltac invert_pos_le :=
  match goal with
  | [ H: pos_le _ _ |- _ ] =>
    inversion H; subst; clear H
  end.

Instance pos_le_preoroder : PreOrder pos_le.
Proof.
  constructor; hnf; intros;
    repeat invert_pos_le;
    repeat destruct_pos;
    eauto.
Qed.

Definition pos_le_dec (p1 p2: pos) : {pos_le p1 p2} + {~pos_le p1 p2}.
Proof.
  repeat destruct_pos.
  destruct (le_dec n n0);
    destruct (le_dec m m0);
    try solve [ left; eauto ];
    try solve [ right; intro;
                invert_pos_le; eauto ].
Defined.

Definition Board := pos -> bool.

Definition invariant (b:Board) :=
  forall p, b p = false ->
    forall p', pos_le p p' ->
          b p' = false.

Inductive State :=
| mkState : forall (b:Board), invariant b -> State.

Theorem invariant_prop_ext : forall (b:Board)
    (H1 H2: invariant b),
    H1 = H2.
Proof.
  intros.
  extensionality p.
  extensionality Hbp.
  extensionality p'.
  extensionality Hle.
  apply (UIP_dec Bool.bool_dec).
Qed.

Implicit Type (sigma:State).
Implicit Type (b:Board).
Implicit Type (p:pos).

Definition getBoard sigma : Board :=
  let (b, _) := sigma in b.

Theorem State_eq : forall sigma sigma',
    getBoard sigma = getBoard sigma' ->
    sigma = sigma'.
Proof.
  destruct sigma, sigma'; intros; simpl in *; subst.
  pose proof (invariant_prop_ext _ i i0); subst.
  auto.
Qed.

Definition remove' (b:Board) p : Board :=
  fun p' => if pos_le_dec p p'
         then false
         else b p'.

Lemma remove_preserves_invariant : forall b p,
    invariant b ->
    invariant (remove' b p).
Proof.
  unfold invariant; intros.
  unfold remove' in *.
  destruct (pos_le_dec p p'); eauto.
  destruct (pos_le_dec p p0); eauto.
  contradiction n.
  etransitivity; eassumption.
Qed.

Definition remove (sigma:State) (p: pos) : State.
Proof.
  destruct sigma.
  apply (mkState (remove' b p)).
  auto using remove_preserves_invariant.
Defined.

Inductive move : State -> State -> Prop :=
| isMove : forall sigma sigma' p, getBoard sigma p = true ->
                     getBoard sigma' = getBoard (remove sigma p) ->
                     move sigma sigma'.

Inductive Elements b (l: list pos) : Prop :=
| ElementsAre : (forall p, b p = true ->
                      In p l) ->
                Elements b l.

Theorem sumbool_bool_eq : forall P Q (x: {P} + {Q}) (b: bool),
    (if x then true else false) = b ->
    if b then P else Q.
Proof.
  destruct x, b; congruence.
Qed.

(* rectangle with top-right corner p *)
Definition rectangle p : State.
  apply (mkState (fun p' => if pos_le_dec p' p
                         then true else false)).
  unfold invariant; intros.
  apply sumbool_bool_eq in H.
  destruct (pos_le_dec p' p); eauto.
  contradiction H.
  etransitivity; eauto.
Defined.

Inductive LoseFrom : State -> Prop :=
| AllWin : forall sigma sigma'',
    move sigma sigma'' ->
    (forall sigma', move sigma sigma' -> WinFrom sigma') ->
    LoseFrom sigma
with WinFrom : State -> Prop :=
     | NoMoves : forall sigma,
         (forall sigma', ~move sigma sigma') ->
         WinFrom sigma
     | CanForce : forall sigma sigma',
         move sigma sigma' ->
         LoseFrom sigma' ->
         WinFrom sigma.

Definition empty : State.
  apply (mkState (fun _ => false)).
  unfold invariant; intros.
  auto.
Defined.

Lemma empty_nomoves : forall sigma sigma',
    getBoard sigma = getBoard empty ->
    ~move sigma sigma'.
Proof.
  inversion 2; subst.
  rewrite H in H1.
  simpl in *; congruence.
Qed.

Theorem empty_win : forall sigma,
    getBoard sigma = getBoard empty ->
    WinFrom sigma.
Proof.
  intros.
  apply NoMoves; intros.
  apply empty_nomoves; auto.
Qed.

Theorem empty_not_lose : forall sigma,
    getBoard sigma = getBoard empty ->
    ~LoseFrom sigma.
Proof.
  inversion 2; subst.
  inversion H1; subst.
  rewrite H in H3; simpl in *; congruence.
Qed.

Ltac econstructor_with e :=
  unshelve econstructor; [ exact e | .. ].

Lemma pos_le_0 : forall p,
    pos_le p (0 & 0) ->
    p = (0 & 0).
Proof.
  intros.
  destruct_pos; invert_pos_le.
  f_equal; omega.
Qed.

Lemma remove_0_from_corner :
  getBoard (remove (rectangle (0 & 0)) (0 & 0)) =
  getBoard empty.
Proof.
  extensionality p; simpl.
  unfold remove'.
  destruct (pos_le_dec (0 & 0) p); auto.
  destruct (pos_le_dec p (0 & 0)); auto.
  apply pos_le_0 in p0; subst.
  contradict n.
  reflexivity.
Qed.

Theorem bottom_good : LoseFrom (rectangle (0 & 0)) /\
                      ~WinFrom (rectangle (0 & 0)).
Proof.
  split.
  - econstructor_with empty.
    econstructor_with (0 & 0); auto.
    rewrite remove_0_from_corner; auto.

    intros.
    inversion H; subst.
    inversion H0; subst.
    apply sumbool_bool_eq in H3.
    apply pos_le_0 in H3; subst.
    rewrite remove_0_from_corner in H1.
    apply empty_win; auto.
  - inversion 1; subst.
    apply (H0 empty).
    econstructor_with (0 & 0); auto.
    rewrite remove_0_from_corner; auto.

    Search move.
    inversion H0; subst.
    inversion H2.
    apply sumbool_bool_eq in H5.
    apply pos_le_0 in H5; subst.
    rewrite remove_0_from_corner in *.
    eapply empty_not_lose; eauto.
Qed.

(* Local Variables: *)
(* company-coq-local-symbols: (("sigma" . ?σ) ("sigma'" . (?σ (Br . Bl) ?')) ("sigma''" . (?σ (Br . Bl) ?' (Br . Bl) ?')) ("State" . ?Σ)) *)
(* End: *)


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup finalg matrix.
Require Import Reals Lra.
From mathcomp Require Import Rstruct.
Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext.
Require Import Rbigop fdist proba entropy aep typ_seq natbin source_code.

(******************************************************************************)
(*        Source coding theorem (variable length, direct part)                *)
(*                                                                            *)
(* For details, see Ryosuke Obi, Manabu Hagiwara, and Reynald Affeldt.        *)
(* Formalization of variable-length source coding theorem: Direct part.       *)
(* International Symposium on Information Theory and Its Applications (ISITA  *)
(* 2014), Melbourne, Australia, October 26--29, 2014, pages 201--205. IEICE.  *)
(* IEEE Xplore, Oct 2014                                                      *)
(*                                                                            *)
(* original source file by R. Obi, quickly patched to compile with infotheo   *)
(* [2019-08-19] and simplified afterwards                                     *)
(******************************************************************************)

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

Local Open Scope reals_ext_scope.
Local Open Scope fdist_scope.
Local Open Scope entropy_scope.
Local Open Scope typ_seq_scope.

Local Open Scope R_scope.

Section R_lemma.
Variable (X : finType) (n' : nat).
Variable f0 : X -> R.
Let n := n'.+1.
Variable S : {set  X}.

Lemma rsum_split:
  \sum_(x| x \in X) f0 x = \sum_(x| x \in S) f0 x + \sum_(x| x \in ~: S) f0 x.
Proof.
rewrite (bigID (fun x => x \in S)) /=; congr (_ + _).
by apply eq_bigl => x /=; rewrite inE.
Qed.

Lemma log_pow_INR m k : (m > 0)%nat -> log (expn m k)%:R = k%:R * log m%:R.
Proof.
move=> m0; elim: k => [|k ih]; first by rewrite expn0 /log Log_1 mul0R.
rewrite expnS natRM /log LogM ?ltR0n // ?expn_gt0 ?m0 // -!/(log _) ih.
by rewrite -addn1 natRD addRC mulRDl mul1R.
Qed.

Lemma elevenOverTwelve_le_One : / 4 + / 3 + / 3 < 1.
Proof.
apply: (Rmult_lt_reg_r 3); first exact: Rplus_lt_pos.
rewrite 2!mulRDl -Rinv_l_sym // mul1R mulRC.
apply: (Rmult_lt_reg_r 4); first exact: Rmult_lt_0_compat.
rewrite 2!mulRDl -mulRA -Rinv_l_sym //=.
rewrite !(mulR1, mul1R) 2!mulRDl !mul1R.
rewrite addRC; apply: Rplus_lt_compat_l.
apply: Rplus_lt_compat_r; apply: (Rlt_le_trans _ _ _ (Rlt_plus_1 _)).
lra.
Qed.

End R_lemma.

Section Length.
Variable (X : finType) (n' : nat).
Let n := n'.+1.
Variable P : fdist X.
Variable epsilon : R.
Hypothesis eps_pos : 0 < epsilon.

Lemma fdist_support_LB : 1 <= INR #|X|.
Proof. by rewrite (_ : 1 = INR 1)  //; exact/le_INR/leP/fdist_card_neq0. Qed.

Lemma fdist_supp_lg_add_1_neq_0 : 1 + log (INR #|X|) <> 0.
Proof.
by apply: nesym; apply: Rlt_not_eq; apply: (Rplus_lt_le_0_compat _ _ Rlt_0_1);
 rewrite -(Log_1 2); apply: Log_increasing_le => //; apply: fdist_support_LB.
Qed.

Definition L_typ := ceil (INR n * (`H P + epsilon)).
Definition L_not_typ := ceil (log (INR #| [set : n.-tuple X]|)).

Lemma Lt_pos : 0 < IZR L_typ.
Proof.
apply: (Rlt_le_trans _ (INR n * (`H P + epsilon))); last exact: (proj1 (ceilP _)).
rewrite -(mulR0 0).
apply: (Rmult_le_0_lt_compat _ _ _ _ (Rle_refl _) (Rle_refl _)).
- by apply: lt_0_INR; apply/ltP.
- by apply(Rplus_le_lt_0_compat _ _ (entropy_ge0 P) eps_pos).
Qed.

Lemma Lnt_nonneg : 0 <= IZR L_not_typ.
Proof.
apply: (Rle_trans _ (log (INR #|[set: n.-tuple X]|))); last exact: (proj1 (ceilP _)).
rewrite -(Log_1 2); apply: Log_increasing_le => //.
rewrite cardsT card_tuple -natRexp.
by apply: pow_R1_Rle; apply: fdist_support_LB.
Qed.

Lemma card_le_TS_Lt : INR #| `TS P n epsilon | <= INR #|[ set : (Z.abs_nat L_typ).-tuple bool]|.
Proof.
apply: (Rle_trans _ _ _ (TS_sup _ _ _)).
rewrite cardsT /= card_tuple  /=  card_bool.
rewrite -natRexp2.
apply: Exp_le_increasing => //.
rewrite INR_Zabs_nat.
- exact: (proj1 (ceilP _)).
- by apply: le_IZR; apply: ltRW; apply: Lt_pos.
Qed.

Lemma card_le_Xn_Lnt' : INR #| [set: n.-tuple X]| <= INR #| [set: (Z.abs_nat L_not_typ).-tuple bool]|.
Proof.
have fact : log (INR (expn #|X| n)) <= IZR (ceil (log (INR (expn #|X| n)))).
  exact: (proj1 (ceilP _)).
rewrite /L_not_typ cardsT card_tuple.
rewrite {1}(_ : INR (expn #|X| n) = exp2 (log (INR (expn #|X| n)))).
-rewrite cardsT card_tuple card_bool -natRexp2.
 apply: Exp_le_increasing => //.
 rewrite /L_not_typ INR_Zabs_nat //.
 apply: le_IZR; apply: (Rle_trans _ (log (INR (expn #|X| n)))) => //.
 rewrite /= -(Log_1 2); apply: Log_increasing_le => //.
 rewrite -natRexp.
 by apply: pow_R1_Rle; apply: fdist_support_LB.
-rewrite logK //; last rewrite -natRexp.
 exact/pow_lt/(Rlt_le_trans _ 1 _ _ fdist_support_LB).
Qed.

End Length.

Section Enc_Dec.
Variable (X : finType) (n' : nat).
Let n := n'.+1.
Variable P : fdist X.
Variable epsilon : R.
Hypothesis eps_pos : 0 < epsilon.

Local Notation "'L_typ'" := (L_typ n' P epsilon).
Local Notation "'L_not_typ'" := (L_not_typ X n').

Definition enc_typ x :=
 let i := seq.index x (enum (`TS P n epsilon))
 in Tuple (size_bitseq_of_nat i (Z.abs_nat L_typ)).

Lemma  card_le_Xn_Lnt :
  (#|[finType of n.-tuple X] | <= #|[finType of (Z.abs_nat L_not_typ).-tuple bool]|)%nat.
Proof.
rewrite -!cardsT.
apply/leP.
apply: (INR_le _ _ (card_le_Xn_Lnt' n' P)).
Qed.

Definition enc_not_typ x := enum_val (widen_ord card_le_Xn_Lnt (enum_rank x)).

Lemma inj_enc_not_typ : injective enc_not_typ.
Proof. by move=> a1 a2 /enum_val_inj [] /ord_inj/enum_rank_inj. Qed.

Definition f : encT X (seq bool) n := fun x =>
  if x \in `TS P n epsilon then
    true :: enc_typ x
  else
    false :: enc_not_typ (tuple_of_row x).

Lemma f_inj : injective f.
Proof.
have card_TS_Lt : (#|`TS P n epsilon| <= (expn 2 (Z.abs_nat L_typ)))%nat.
  by apply/leP;  apply: INR_le; move: (card_le_TS_Lt n' P eps_pos);
       rewrite {1}cardsT card_tuple /= card_bool.
move=> t1 t2; rewrite /f.
case/boolP : (t1 == t2) ; first by move /eqP.
move=> mainCase.
case: ifP=>?; case: ifP=>? //; case=> H; last by apply/tuple_of_row_inj/inj_enc_not_typ/val_inj.
-  have {}H : index t1 (enum (`TS P n epsilon)) =
              index t2 (enum (`TS P n epsilon))
     by apply (@bitseq_of_nat_inj (Z.abs_nat L_typ)) => //;  apply: (leq_trans _ card_TS_Lt);
     apply: seq_index_enum_card => //;  apply: enum_uniq.
 rewrite -(@nth_index _ t1 t1 (enum (`TS P n epsilon))); last by rewrite mem_enum.
 rewrite -(@nth_index _ t1 t2 (enum (`TS P n epsilon))); last by rewrite mem_enum.
 by rewrite H.
Qed.

Definition phi_def : n.-tuple X.
move Hpick : [pick x | x \in [set: X] ] => p;
move: Hpick; case: (pickP _)=>[x _ _ | abs]; first apply: [tuple of nseq n x].
exfalso.
move: (fdist_card_neq0 P).
rewrite -cardsT card_gt0; case/set0Pn => ?.
by rewrite abs.
Defined.

Definition phi : decT X (seq bool) n := fun y =>
 if [ pick x | f x == y ] is Some x then x else row_of_tuple phi_def.

Lemma phi_f x : phi (f x) = x.
Proof.
rewrite /phi.
case:(pickP _)=> [x0 /eqP | H].
-by apply: f_inj.
-by move: (H x); rewrite eqxx.
Qed.

(*Definition extension (enc : encT X (seq bool) n) (x : seq ('rV[X]_n)) :=
flatten (map enc x).
NB: 2015/02/06 -> already defined in uniquely_decodable.v *)

Lemma uniq_decodable_f : uniquely_decodable f.
Proof.
elim => [ | a la H ]; case => [|b lb]; rewrite /extension /= /f //=;
 [by case : ifP |by case : ifP | ].
case: ifP  => aT; case: ifP=> bT //;  move /eqP; rewrite -/f eqseq_cat.
+ by case/andP=>[/eqP eq_ab ] /eqP /H ->; congr (_ :: _); apply: f_inj; rewrite /f aT bT.
+ by rewrite /= !/bitseq_of_nat !size_pad_seqL.
+ by case/andP=>[/eqP eq_ab ] /eqP /H ->; congr (_ :: _); apply: f_inj; rewrite /f aT bT.
+ by rewrite !size_tuple.
Qed.

End Enc_Dec.

Section E_Leng_Cw_Lemma.
Variables (X : finType).
Variable (n' : nat).
Let n := n'.+1.
Variable P : fdist X.
Variable epsilon : R.
Hypothesis eps_pos : 0 < epsilon.
Hypothesis aepbound_UB : aep_bound P epsilon <= INR n.

Local Notation "'L_typ'" := (L_typ n' P epsilon).
Local Notation "'L_not_typ'" := (L_not_typ X n').

Lemma eq_sizef_Lt :
  \sum_(x| x \in `TS P n epsilon) P `^ n (x) * (INR (size (f P epsilon x)) ) =
  \sum_(x| x \in `TS P n epsilon) P `^ n (x) * (IZR L_typ + 1).
Proof.
apply: eq_bigr=> i H.
apply: Rmult_eq_compat_l.
rewrite /f H /= size_pad_seqL -INR_Zabs_nat.
-by rewrite -addn1; rewrite plus_INR.
-by apply: le_IZR;apply: ltRW; apply: Lt_pos.
Qed.

Lemma eq_sizef_Lnt:
  \sum_(x| x \in ~:(`TS P n epsilon)) P `^ n (x) * (INR (size (f P epsilon x)) )
  = \sum_(x| x \in ~:(`TS P n epsilon)) P `^ n (x) * (IZR L_not_typ + 1) .
Proof.
apply: eq_bigr => ? H.
apply: Rmult_eq_compat_l.
move: H; rewrite in_setC.
rewrite /f; move /negbTE ->.
rewrite /= -addn1 size_tuple plus_INR INR_Zabs_nat.
-by [].
-by apply: le_IZR; apply: (Lnt_nonneg _ P).
Qed.

Lemma E_leng_cw_le_Length : @E_leng_cw _ _ P (f (n':=n') P epsilon) <=
  (IZR L_typ + 1) + epsilon * (IZR L_not_typ + 1) .
Proof.
rewrite /E_leng_cw /Ex /=.
under eq_bigr do rewrite mulRC.
rewrite (rsum_split _ (`TS P n'.+1 epsilon)).
rewrite eq_sizef_Lnt eq_sizef_Lt -!(big_morph _ (morph_mulRDl _) (mul0R _)) mulRC.
rewrite (_ : \sum_(i | i \in ~: `TS P n epsilon)
 P `^ n i = 1 - \sum_(i | i \in `TS P n epsilon) P `^ n i); last first.
- by rewrite -(FDist.f1 P`^n) (rsum_split _ (`TS P n epsilon)) addRC addRK.
- apply leR_add.
  + rewrite -[X in _ <= X]mulR1; apply: leR_wpmul2l => //.
    * by apply: addR_ge0 => //; exact/ltRW/Lt_pos.
    * by rewrite -(FDist.f1 (P `^ n)); apply: leR_sumRl => // *; exact/leRR.
  + apply: leR_wpmul2r => //.
    * by apply addR_ge0 => //; exact (Lnt_nonneg _ P).
    * by rewrite leR_subl_addr addRC -leR_subl_addr; exact: Pr_TS_1.
Qed.

End E_Leng_Cw_Lemma.

Section v_scode.
Variable (X : finType) (n' : nat).
Let n := n'.+1.
Variable P : fdist X.
Variable epsilon : R.
Hypothesis eps_pos : 0 < epsilon .
Definition epsilon':= epsilon / (3 + (3 * log (INR #|X|))).
Definition n0 := maxn (Z.abs_nat (ceil (INR 2 / (INR 1 + log (INR #|X|)))))
                     (maxn (Z.abs_nat (ceil (8 / epsilon)))
                     (Z.abs_nat (ceil (aep_sigma2 P/ epsilon' ^ 3)))).
Hypothesis n0_Le_n : (n0 < n)%nat.

Lemma n0_eps3 :  2 * (epsilon / (3 * (1 + log (INR #|X|)))) / INR n < epsilon / 3.
Proof.
move: (fdist_supp_lg_add_1_neq_0 P) => ?.
rewrite mulRC /Rdiv -?mulRA; apply: (Rmult_lt_compat_l _ _ _ eps_pos); rewrite ?mulRA (mulRC _ 2).
apply: (Rmult_lt_reg_l 3); first exact: Rplus_lt_pos.
rewrite Rinv_mult_distr // ?mulRA (mulRC 3 2) Rinv_r_simpl_l //.
apply: (Rmult_lt_reg_l (INR n)); first exact/ltR0n.
rewrite mulRC -mulRA (mulRC _ (INR n)) ?mulRA Rinv_r_simpl_l; last first.
  by apply/eqP; rewrite INR_eq0'.
rewrite Rinv_r_simpl_l //.
apply: (Rle_lt_trans _ _ _ (proj1 (ceilP _))).
rewrite -INR_Zabs_nat.
- apply: (lt_INR _ _).
  move : n0_Le_n; rewrite /n0 gtn_max.
  by case/andP => /ltP.
- apply: le_IZR;apply: (Rle_trans _ (2 * / (1 + log (INR #|X|)))); last exact: (proj1 (ceilP _)).
  apply: Rmult_le_pos; first exact: ltRW.
  apply: Rlt_le; apply: Rinv_0_lt_compat.
  apply: Rplus_lt_le_0_compat => //.
  rewrite -(Log_1 2).
  apply: Log_increasing_le => //.
  exact: fdist_support_LB.
Qed.

Lemma n0_eps4 :  2 * / INR n  < epsilon / 4.
Proof.
move: n0_Le_n; rewrite /n0 !gtn_max;  case/andP=> _;  case/andP=> Hyp _.
apply: (Rmult_lt_reg_l 4); first by lra.
rewrite /Rdiv (mulRC epsilon (/ 4)) mulRA mulRA ?mulRV; last first.
  by rewrite gtR_eqF //; lra.
rewrite (_ : 4 * 2 = 8) ?mul1R; last by lra.
apply: (Rmult_lt_reg_l (INR n)); first exact/ltR0n.
rewrite mulRA (mulRC _ 8) Rinv_r_simpl_l; last by apply/eqP; rewrite INR_eq0'.
apply: (Rmult_lt_reg_l ( / epsilon)); first by apply: Rinv_0_lt_compat.
rewrite mulRC (mulRC (/ epsilon) (INR n * epsilon)) Rinv_r_simpl_l;
  last by apply: nesym; apply: Rlt_not_eq=>//.
apply: (Rle_lt_trans _ (IZR (ceil (8 * / epsilon))) _ (proj1 (ceilP _))).
rewrite -INR_Zabs_nat.
- by apply: lt_INR; apply/ltP.
- apply: le_IZR;apply: (Rle_trans _ (8 * / epsilon)); last by apply: (proj1 (ceilP _)).
  by apply: Rle_mult_inv_pos; [lra | apply eps_pos].
Qed.

Lemma eps'_pos : 0 < epsilon'.
Proof.
rewrite /epsilon' /Rdiv -(mulR0 epsilon); apply ltR_pmul2l => //; apply/invR_gt0.
apply: Rplus_lt_le_0_compat; first lra.
apply: Rmult_le_pos; first lra.
rewrite -(Log_1 2).
exact: (Log_increasing_le _ _ (fdist_support_LB P)).
Qed.

Lemma le_aepbound_n : aep_bound P epsilon' <= INR n.
Proof.
rewrite /aep_bound .
apply: (Rle_trans _ _ _ (proj1 (ceilP _))).
rewrite -INR_Zabs_nat.
  apply: ltRW; apply: lt_INR.
  move: n0_Le_n.
  rewrite /n0 !gtn_max.
  case/andP=> _.
  case/andP=> _ H2.
  by apply/ltP.
apply: le_IZR; apply: (Rle_trans _ (aep_sigma2 P / epsilon' ^ 3)); last by apply: (proj1 (ceilP _)).
apply: Rmult_le_pos; first by apply: aep_sigma2_ge0.
by apply: Rlt_le; apply: Rinv_0_lt_compat; apply: (pow_lt _ _ eps'_pos).
Qed.

Lemma lb_entro_plus_eps :
 IZR (L_typ n' P epsilon') + 1 + epsilon' * (IZR (L_not_typ X n') + 1) <
   (`H P + epsilon) * INR n.
Proof.
move : (fdist_supp_lg_add_1_neq_0 P) => ?.
rewrite /L_typ /L_not_typ.
apply: (Rle_lt_trans _  (INR n'.+1 * (`H P + epsilon') + 1 + 1 +
   epsilon' * (log (INR #|[set: (n'.+1).-tuple X]|) + 1 + 1))).
- apply: Rplus_le_compat.
  + by apply: Rplus_le_compat; [apply: ltRW; apply: (proj2 (ceilP _)) | apply: Rle_refl].
  + apply: Rmult_le_compat_l; first by apply: Rlt_le; apply: eps'_pos.
    by apply: Rplus_le_compat; [apply: ltRW; apply: (proj2 (ceilP _)) | apply: Rle_refl].
- rewrite cardsT card_tuple log_pow_INR; last exact: fdist_card_neq0.
  rewrite -addRA -addRA -addRA addRC addRA addRC addRA -(Rinv_r_simpl_l (INR n) (1 + 1)); last first.
    by apply/eqP; rewrite INR_eq0'.
  rewrite (mulRC 2 _) -{1}mulRA -mulRDr -mulRA -mulRDr (mulRC epsilon' _) -mulRA.
  rewrite (mulRC _ epsilon') -mulRDr mulRC.
  apply: Rmult_lt_compat_r; first by apply: lt_0_INR; apply/ltP.
  rewrite -addRA -addRA; apply: Rplus_lt_compat_l.
  rewrite mulRDr (addRC (epsilon' * log (INR #|X|)) _) addRC addRA -addRA
    (addRC _ epsilon') -{2}(mulR1 epsilon') -mulRDr -addRA
    (addRC (epsilon' * (2 / INR n)) _) addRA addRC  mulRC addRC /epsilon'
    -{1}(mulR1 3) -{3}(mulR1 3) -mulRDr /Rdiv {1}(Rinv_mult_distr) // mulRA
    -mulRA -Rinv_l_sym // mulR1.
  apply: (Rle_lt_trans _ (epsilon / 4 + epsilon * / 3 + epsilon / 3)).
  * apply: Rplus_le_compat.
    - by apply: Rplus_le_compat; [apply: ltRW; apply: n0_eps4 | apply: Rle_refl].
    - by rewrite mulRC /Rdiv (mulRC 2 _) mulRA mulRC mulRA; apply: ltRW; apply: n0_eps3.
  * rewrite /Rdiv -?mulRDr -{2}(mulR1 epsilon);  apply: (Rmult_lt_compat_l _ _ _ eps_pos).
    by apply: elevenOverTwelve_le_One.
Qed.

Lemma v_scode' : exists sc : scode_vl _ n,
  cancel (enc sc) (dec sc) /\
  @E_leng_cw _ _ P (enc sc) / INR n < `H P + epsilon.
Proof.
move : (fdist_supp_lg_add_1_neq_0 P) => ?.
exists (mkScode (f P epsilon') (phi n' P epsilon')).
apply: conj=> [ x |]; first by apply: (phi_f _ eps'_pos).
apply: (Rmult_lt_reg_r (INR n)); first by apply: lt_0_INR; apply/ltP.
rewrite /Rdiv -mulRA -(mulRC (INR n)) mulRV ?INR_eq0' // mulR1.
apply: (Rle_lt_trans _ (IZR (L_typ n' P epsilon') + 1 + epsilon' * (IZR (L_not_typ X n') + 1))).
- by apply: E_leng_cw_le_Length; [apply: eps'_pos | apply: le_aepbound_n].
- by apply: lb_entro_plus_eps.
Qed.

End v_scode.

Section variable_length_source_coding.

Variables (X : finType) (P : fdist X).
Variable epsilon : R.
Hypothesis eps_pos : 0 < epsilon .
Local Notation "'n0'" := (n0 P epsilon).

Theorem v_scode_direct : exists n : nat,
  exists f : encT X (seq bool) n,
    injective f /\
    @E_leng_cw _ _ P f / n%:R < `H P + epsilon.
Proof.
apply: (ex_intro _ (n0.+1)).
have: (n0 < n0.+1)%nat by[].
case/v_scode'=> // sc [fphi ccl].
apply: (ex_intro _ (enc sc)).
by split => //; exact: (can_inj fphi).
Qed.

End variable_length_source_coding.


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.Overture Basics.Tactics.

(** * Wild categories, functors, and transformations *)

(** ** Directed graphs *)

Class IsGraph (A : Type) :=
{
  Hom : A -> A -> Type
}.

Notation "a $-> b" := (Hom a b).

Definition graph_hfiber {B C : Type} `{IsGraph C} (F : B -> C) (c : C)
  := {b : B & F b $-> c}.

(** ** 0-categorical structures *)

(** A wild (0,1)-category has 1-morphisms and operations on them, but no coherence. *)
Class Is01Cat (A : Type) `{IsGraph A} :=
{
  Id  : forall (a : A), a $-> a;
  cat_comp : forall (a b c : A), (b $-> c) -> (a $-> b) -> (a $-> c);
}.

Arguments cat_comp {A _ _ a b c} _ _.
Notation "g $o f" := (cat_comp g f).

Definition cat_postcomp {A} `{Is01Cat A} (a : A) {b c : A} (g : b $-> c)
  : (a $-> b) -> (a $-> c)
  := cat_comp g.

Definition cat_precomp {A} `{Is01Cat A} {a b : A} (c : A) (f : a $-> b)
  : (b $-> c) -> (a $-> c)
  := fun g => g $o f.

(** A wild 0-groupoid is a wild (0,1)-category whose morphisms can be reversed.  This is also known as a setoid. *)
Class Is0Gpd (A : Type) `{Is01Cat A} :=
  { gpd_rev : forall {a b : A}, (a $-> b) -> (b $-> a) }.

Definition GpdHom {A} `{Is0Gpd A} (a b : A) := a $-> b.
Notation "a $== b" := (GpdHom a b).

Global Instance reflexive_GpdHom {A} `{Is0Gpd A}
  : Reflexive GpdHom
  := fun a => Id a.

Global Instance reflexive_Hom {A} `{Is01Cat A}
  : Reflexive Hom
  := fun a => Id a.

Definition gpd_comp {A} `{Is0Gpd A} {a b c : A}
  : (a $== b) -> (b $== c) -> (a $== c)
  := fun p q => q $o p.
Infix "$@" := gpd_comp.

Global Instance transitive_GpdHom {A} `{Is0Gpd A}
  : Transitive GpdHom
  := fun a b c f g => f $@ g.

Global Instance transitive_Hom {A} `{Is01Cat A}
  : Transitive Hom
  := fun a b c f g => g $o f.

Notation "p ^$" := (gpd_rev p).

Global Instance symmetric_GpdHom {A} `{Is0Gpd A}
  : Symmetric GpdHom
  := fun a b f => f^$.

Global Instance symmetric_GpdHom' {A} `{Is0Gpd A}
  : Symmetric Hom
  := fun a b f => f^$.

Definition GpdHom_path {A} `{Is0Gpd A} {a b : A} (p : a = b)
  : a $== b.
Proof.
  destruct p; apply Id.
Defined.

(** A 0-functor acts on morphisms, but satisfies no axioms. *)
Class Is0Functor {A B : Type} `{IsGraph A} `{IsGraph B} (F : A -> B)
  := { fmap : forall (a b : A) (f : a $-> b), F a $-> F b }.

Arguments fmap {A B isgraph_A isgraph_B} F {is0functor_F a b} f : rename.

Class Is2Graph (A : Type) `{IsGraph A}
  := isgraph_hom : forall (a b : A), IsGraph (a $-> b).
Global Existing Instance isgraph_hom | 20.
#[global] Typeclasses Transparent Is2Graph.

(** ** Wild 1-categorical structures *)
Class Is1Cat (A : Type) `{!IsGraph A, !Is2Graph A, !Is01Cat A} :=
{
  is01cat_hom : forall (a b : A), Is01Cat (a $-> b) ;
  is0gpd_hom : forall (a b : A), Is0Gpd (a $-> b) ;
  is0functor_postcomp : forall (a b c : A) (g : b $-> c), Is0Functor (cat_postcomp a g) ;
  is0functor_precomp : forall (a b c : A) (f : a $-> b), Is0Functor (cat_precomp c f) ;
  cat_assoc : forall (a b c d : A) (f : a $-> b) (g : b $-> c) (h : c $-> d),
    (h $o g) $o f $== h $o (g $o f);
  cat_idl : forall (a b : A) (f : a $-> b), Id b $o f $== f;
  cat_idr : forall (a b : A) (f : a $-> b), f $o Id a $== f;
}.

Global Existing Instance is01cat_hom.
Global Existing Instance is0gpd_hom.
Global Existing Instance is0functor_postcomp.
Global Existing Instance is0functor_precomp.
Arguments cat_assoc {_ _ _ _ _ _ _ _ _} f g h.
Arguments cat_idl {_ _ _ _ _ _ _} f.
Arguments cat_idr {_ _ _ _ _ _ _} f.

Definition cat_assoc_opp {A : Type} `{Is1Cat A}
           {a b c d : A} (f : a $-> b) (g : b $-> c) (h : c $-> d)
  : h $o (g $o f) $== (h $o g) $o f
  := (cat_assoc f g h)^$.

(*
Definition Comp2 {A} `{Is1Cat A} {a b c : A}
           {f g : a $-> b} {h k : b $-> c}
           (q : h $-> k) (p : f $-> g)
  : (h $o f $-> k $o g)
  := ??

Infix "$o@" := Comp2.
*)

Definition cat_postwhisker {A} `{Is1Cat A} {a b c : A}
           {f g : a $-> b} (h : b $-> c) (p : f $== g)
  : h $o f $== h $o g
  := fmap (cat_postcomp a h) p.
Notation "h $@L p" := (cat_postwhisker h p).

Definition cat_prewhisker {A} `{Is1Cat A} {a b c : A}
           {f g : b $-> c} (p : f $== g) (h : a $-> b)
  : f $o h $== g $o h
  := fmap (cat_precomp c h) p.
Notation "p $@R h" := (cat_prewhisker p h).

Definition Monic {A} `{Is1Cat A} {b c: A} (f : b $-> c)
  := forall a (g h : a $-> b), f $o g $== f $o h -> g $== h.

Definition Epic {A} `{Is1Cat A} {a b : A} (f : a $-> b)
  := forall c (g h : b $-> c), g $o f $== h $o f -> g $== h.

(** Section might be a clearer name but it's better to avoid confusion with Coq keywords. *)

Record SectionOf {A} `{Is1Cat A} {a b : A} (f : a $-> b) :=
  {
    comp_right_inverse : b $-> a;
    is_section : f $o comp_right_inverse $== Id b
  }.

Record RetractionOf {A} `{Is1Cat A} {a b : A} (f : a $-> b) :=
  {
    comp_left_inverse : b $-> a;
    is_retraction : comp_left_inverse $o f $== Id a
  }.

(** Often, the coherences are actually equalities rather than homotopies. *)
Class Is1Cat_Strong (A : Type)`{!IsGraph A, !Is2Graph A, !Is01Cat A} :=
{
  is01cat_hom_strong : forall (a b : A), Is01Cat (a $-> b) ;
  is0gpd_hom_strong : forall (a b : A), Is0Gpd (a $-> b) ;
  is0functor_postcomp_strong : forall (a b c : A) (g : b $-> c),
    Is0Functor (cat_postcomp a g) ;
  is0functor_precomp_strong : forall (a b c : A) (f : a $-> b),
    Is0Functor (cat_precomp c f) ;
  cat_assoc_strong : forall (a b c d : A)
    (f : a $-> b) (g : b $-> c) (h : c $-> d),
    (h $o g) $o f = h $o (g $o f) ;
  cat_idl_strong : forall (a b : A) (f : a $-> b), Id b $o f = f ;
  cat_idr_strong : forall (a b : A) (f : a $-> b), f $o Id a = f ;
}.

Arguments cat_assoc_strong {_ _ _ _ _ _ _ _ _} f g h.
Arguments cat_idl_strong {_ _ _ _ _ _ _} f.
Arguments cat_idr_strong {_ _ _ _ _ _ _} f.

Definition cat_assoc_opp_strong {A : Type} `{Is1Cat_Strong A}
           {a b c d : A} (f : a $-> b) (g : b $-> c) (h : c $-> d)
  : h $o (g $o f) = (h $o g) $o f
  := (cat_assoc_strong f g h)^.

Global Instance is1cat_is1cat_strong (A : Type) `{Is1Cat_Strong A}
  : Is1Cat A | 1000.
Proof.
  srapply Build_Is1Cat.
  all: intros a b.
  - apply is01cat_hom_strong.
  - apply is0gpd_hom_strong.
  - apply is0functor_postcomp_strong.
  - apply is0functor_precomp_strong.
  - intros; apply GpdHom_path, cat_assoc_strong.
  - intros; apply GpdHom_path, cat_idl_strong.
  - intros; apply GpdHom_path, cat_idr_strong.
Defined.

(** Initial objects *)
Definition IsInitial {A : Type} `{Is1Cat A} (x : A)
  := forall (y : A), {f : x $-> y & forall g, f $== g}.
Existing Class IsInitial.

Definition mor_initial {A : Type} `{Is1Cat A} (x y : A) {h : IsInitial x}
  : x $-> y
  := (h y).1.

Definition mor_initial_unique {A : Type} `{Is1Cat A} (x y : A) {h : IsInitial x}
  (f : x $-> y)
  : mor_initial x y $== f
  := (h y).2 f.

(** Terminal objects *)
Definition IsTerminal {A : Type} `{Is1Cat A} (y : A)
  := forall (x : A), {f : x $-> y & forall g, f $== g}.
Existing Class IsTerminal.

Definition mor_terminal {A : Type} `{Is1Cat A} (x y : A) {h : IsTerminal y}
  : x $-> y
  := (h x).1.

Definition mor_terminal_unique {A : Type} `{Is1Cat A} (x y : A) {h : IsTerminal y}
  (f : x $-> y)
  : mor_terminal x y $== f
  := (h x).2 f.

(** Generalizing function extensionality, "Morphism extensionality" states that homwise [GpdHom_path] is an equivalence. *)
Class HasMorExt (A : Type) `{Is1Cat A} := {
  isequiv_Htpy_path : forall a b f g, IsEquiv (@GpdHom_path (a $-> b) _ _ _ f g)
}.

Global Existing Instance isequiv_Htpy_path.

Definition path_hom {A} `{HasMorExt A} {a b : A} {f g : a $-> b} (p : f $== g)
  : f = g
  := GpdHom_path^-1 p.

(** A 1-category with morphism extensionality induces a strong 1-category *)
Global Instance is1cat_strong_hasmorext {A : Type} `{HasMorExt A}
  : Is1Cat_Strong A.
Proof.
  rapply Build_Is1Cat_Strong; hnf; intros; apply path_hom.
  + apply cat_assoc.
  + apply cat_idl.
  + apply cat_idr.
Defined.

(** A 1-functor acts on 2-cells (satisfying no axioms) and also preserves composition and identities up to a 2-cell. *)
  (* The [!] tells Coq to use typeclass search to find the [IsGraph] parameters of [Is0Functor] instead of assuming additional copies of them. *)
Class Is1Functor {A B : Type} `{Is1Cat A} `{Is1Cat B}
  (F : A -> B) `{!Is0Functor F} :=
{
  fmap2 : forall a b (f g : a $-> b), (f $== g) -> (fmap F f $== fmap F g) ;
  fmap_id : forall a, fmap F (Id a) $== Id (F a);
  fmap_comp : forall a b c (f : a $-> b) (g : b $-> c),
    fmap F (g $o f) $== fmap F g $o fmap F f;
}.

Arguments fmap2 {A B
  isgraph_A is2graph_A is01cat_A is1cat_A
  isgraph_B is2graph_B is01cat_B is1cat_B}
  F {is0functor_F is1functor_F a b f g} p : rename.
Arguments fmap_id {A B
  isgraph_A is2graph_A is01cat_A is1cat_A
  isgraph_B is2graph_B is01cat_B is1cat_B}
  F {is0functor_F is1functor_F} a : rename.
Arguments fmap_comp {A B
  isgraph_A is2graph_A is01cat_A is1cat_A
  isgraph_B is2graph_B is01cat_B is1cat_B}
  F {is0functor_F is1functor_F a b c} f g : rename.

Class Faithful {A B : Type} (F : A -> B) `{Is1Functor A B F} :=
  faithful : forall (x y : A) (f g : x $-> y),
      fmap F f $== fmap F g -> f $== g.

(** Identity functor *)

Section IdentityFunctor.

  Context {A : Type} `{Is1Cat A}.

  Global Instance is0functor_idmap : Is0Functor idmap.
  Proof.
    by apply Build_Is0Functor.
  Defined.

  Global Instance is1functor_idmap : Is1Functor idmap.
  Proof.
    by apply Build_Is1Functor.
  Defined.

  #[export] Instance isFaithful_idmap : Faithful idmap.
  Proof.
    by unfold Faithful.
  Defined.
End IdentityFunctor.

(** Constant functor *)

Section ConstantFunctor.

  Context {A B : Type}.

  Global Instance is01functor_const
    `{IsGraph A} `{Is01Cat B} (x : B)
    : Is0Functor (fun _ : A => x).
  Proof.
    srapply Build_Is0Functor.
    intros a b f; apply Id.
  Defined.

  Global Instance is1functor_const
   `{Is1Cat A} `{Is1Cat B} (x : B)
    : Is1Functor (fun _ : A => x).
  Proof.
    srapply Build_Is1Functor.
    - intros a b f g p; apply Id.
    - intro; apply Id.
    - intros a b c f g. cbn.
      symmetry.
      apply cat_idl.
  Defined.

End ConstantFunctor.

(** Composite functors *)

Global Instance is0functor_compose {A B C : Type}
  `{IsGraph A, IsGraph B, IsGraph C}
  (F : A -> B) (G : B -> C) `{!Is0Functor F, !Is0Functor G}
  : Is0Functor (G o F).
Proof.
  srapply Build_Is0Functor.
  intros a b f; exact (fmap G (fmap F f)).
Defined.

Global Instance is1functor_compose {A B C : Type}
  `{Is1Cat A, Is1Cat B, Is1Cat C}
  (F : A -> B) `{!Is0Functor F, !Is1Functor F}
  (G : B -> C) `{!Is0Functor G, !Is1Functor G}
  : Is1Functor (G o F).
Proof.
  srapply Build_Is1Functor.
  - intros a b f g p; exact (fmap2 G (fmap2 F p)).
  - intros a; exact (fmap2 G (fmap_id F a) $@ fmap_id G (F a)).
  - intros a b c f g.
    refine (fmap2 G (fmap_comp F f g) $@ _).
    exact (fmap_comp G (fmap F f) (fmap F g)).
Defined.

(** We give all arguments names in order to refer to them later. This allows us to write things like [is0functor (isgraph_A := _)] without having to make all the variables explicit. *)
Arguments is0functor_compose {A B C} {isgraph_A isgraph_B isgraph_C}
  F {is0functor_F} G {is0functor_G} : rename.

Arguments is1functor_compose {A B C}
  {isgraph_A is2graph_A is01cat_A is1cat_A
   isgraph_B is2graph_B is01cat_B is1cat_B
   isgraph_C is2graph_C is01cat_C is1cat_C}
  F {is0functor_F} {is1functor_F}
  G {is0functor_G} {is1functor_G}
  : rename.

(** ** Wild 1-groupoids *)

Class Is1Gpd (A : Type) `{Is1Cat A, !Is0Gpd A} :=
{
  gpd_issect : forall {a b : A} (f : a $-> b), f^$ $o f $== Id a ;
  gpd_isretr : forall {a b : A} (f : a $-> b), f $o f^$ $== Id b ;
}.

(** Some more convenient equalities for morphisms in a 1-groupoid. The naming scheme is similar to [PathGroupoids.v].*)

Definition gpd_V_hh {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b)
  : f^$ $o (f $o g) $== g :=
  (cat_assoc _ _ _)^$ $@ (gpd_issect f $@R g) $@ cat_idl g.

Definition gpd_h_Vh {A} `{Is1Gpd A} {a b c : A} (f : c $-> b) (g : a $-> b)
  : f $o (f^$ $o g) $== g :=
  (cat_assoc _ _ _)^$ $@ (gpd_isretr f $@R g) $@ cat_idl g.

Definition gpd_hh_V {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b)
  : (f $o g) $o g^$ $== f :=
  cat_assoc _ _ _ $@ (f $@L gpd_isretr g) $@ cat_idr f.

Definition gpd_hV_h {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : b $-> a)
  : (f $o g^$) $o g $== f :=
  cat_assoc _ _ _ $@ (f $@L gpd_issect g) $@ cat_idr f.

Definition gpd_moveL_1M {A} `{Is1Gpd A} {x y : A} {p q : x $-> y}
  (r : p $o q^$ $== Id _) : p $== q.
Proof.
  refine ((cat_idr p)^$ $@ (p $@L (gpd_issect q)^$) $@ (cat_assoc _ _ _)^$ $@ _).
  refine ((r $@R q) $@ cat_idl q).
Defined.

Definition gpd_moveR_V1 {A} `{Is1Gpd A} {x y : A} {p : x $-> y}
  {q : y $-> x} (r : Id _ $== p $o q) : p^$ $== q.
Proof.
  refine ((cat_idr p^$)^$ $@ (p^$ $@L r) $@ _).
  apply gpd_V_hh.
Defined.

Definition gpd_moveR_1M {A : Type} `{Is1Gpd A} {x y : A} {p q : x $-> y}
  (r : p $o q^$ $== Id _) : p $== q.
Proof.
  refine ((cat_idr p)^$ $@ (p $@L (gpd_issect q)^$) $@ (cat_assoc _ _ _)^$ $@ _).
  refine ((r $@R q) $@ cat_idl q).
Defined.

Definition gpd_moveL_1V {A : Type} `{Is1Gpd A} {x y : A} {p : x $-> y}
  {q : y $-> x} (r : p $o q $== Id _) : p $== q^$.
Proof.
  refine (_ $@ (cat_idl q^$)).
  refine (_ $@ (r $@R q^$)).
  exact (gpd_hh_V _ _)^$.
Defined.

Definition gpd_moveR_hV {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
  {q : x $-> y} {r : x $-> z} (s : r $== p $o q)
  : r $o q^$ $== p
  := (s $@R q^$) $@ gpd_hh_V _ _.

Definition gpd_moveR_Vh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
  {q : x $-> y} {r : x $-> z} (s : r $== p $o q)
  : p^$ $o r $== q
  := (p^$ $@L s) $@ gpd_V_hh _ _.

Definition gpd_moveL_hM {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
  {q : x $-> y} {r : x $-> z} (s : r $o q^$ $== p)
  : r $== p $o q := ((gpd_hV_h _ _)^$ $@ (s $@R _)).

Definition gpd_moveL_hV {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
  {q : x $-> y} {r : x $-> z} (s : p $o q $== r)
  : p $== r $o q^$
  := (gpd_moveR_hV s^$)^$.

Definition gpd_moveL_Mh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
  {q : x $-> y} {r : x $-> z} (s : p^$ $o r $== q)
  : r $== p $o q := ((gpd_h_Vh _ _)^$ $@ (p $@L s)).

Definition gpd_moveL_Vh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
  {q : x $-> y} {r : x $-> z} (s : p $o q $== r)
  : q $== p^$ $o r
  := (gpd_moveR_Vh s^$)^$.

Definition gpd_rev2 {A : Type} `{Is1Gpd A} {x y : A} {p q : x $-> y}
  (r : p $== q) : p^$ $== q^$.
Proof.
  apply gpd_moveR_V1.
  apply gpd_moveL_hV.
  exact (cat_idl q $@ r^$).
Defined.

Definition gpd_rev_pp {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b)
  : (f $o g)^$ $== g^$ $o f^$.
Proof.
  apply gpd_moveR_V1.
  refine (_ $@ cat_assoc _ _ _).
  apply gpd_moveL_hV.
  refine (cat_idl _ $@ _).
  exact (gpd_hh_V _ _)^$.
Defined.

Definition gpd_rev_1 {A} `{Is1Gpd A} {a : A} : (Id a)^$ $== Id a.
Proof.
  refine ((gpd_rev2 (gpd_issect (Id a)))^$ $@ _).
  refine (gpd_rev_pp _ _ $@ _).
  apply gpd_isretr.
Defined.

Definition gpd_rev_rev {A} `{Is1Gpd A} {a0 a1 : A} (g : a0 $== a1)
  : (g^$)^$ $== g.
Proof.
  apply gpd_moveR_V1.
  exact (gpd_issect _)^$.
Defined.

(** 1-functors between 1-groupoids preserve identities *)
Definition gpd_1functor_V {A B} `{Is1Gpd A, Is1Gpd B}
           (F : A -> B) `{!Is0Functor F, !Is1Functor F}
           {a0 a1 : A} (f : a0 $== a1)
  : fmap F f^$ $== (fmap F f)^$.
Proof.
  apply gpd_moveL_1V.
  refine ((fmap_comp _ _ _)^$ $@ _ $@ fmap_id _ _).
  rapply fmap2.
  apply gpd_issect.
Defined.

(** Movement lemmas with extensionality *)

(** For more complex movements you probably want to apply [path_hom] and use the lemmas above. *)

Definition gpd_strong_V_hh {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : b $-> c) (g : a $-> b)
  : f^$ $o (f $o g) = g := path_hom (gpd_V_hh f g).

Definition gpd_strong_h_Vh {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : c $-> b) (g : a $-> b)
  : f $o (f^$ $o g) = g := path_hom (gpd_h_Vh f g).

Definition gpd_strong_hh_V {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : b $-> c) (g : a $-> b)
  : (f $o g) $o g^$ = f := path_hom (gpd_hh_V f g).

Definition gpd_strong_hV_h {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : b $-> c) (g : b $-> a)
  : (f $o g^$) $o g = f := path_hom (gpd_hV_h f g).

Definition gpd_strong_rev_pp {A} `{Is1Gpd A, !HasMorExt A} {a b c : A} (f : b $-> c) (g : a $-> b)
  : (f $o g)^$ = g^$ $o f^$
  := path_hom (gpd_rev_pp f g).

Definition gpd_strong_rev_1 {A} `{Is1Gpd A, !HasMorExt A} {a : A}
  : (Id a)^$ = Id a
  := path_hom gpd_rev_1.

Definition gpd_strong_rev_rev {A} `{Is1Gpd A, !HasMorExt A} {a0 a1 : A} (g : a0 $== a1)
  : (g^$)^$ = g := path_hom (gpd_rev_rev g).

Definition fmap_id_strong {A B} `{Is1Cat A, Is1Cat B, !HasMorExt B}
           (F : A -> B) `{!Is0Functor F, !Is1Functor F} (a : A)
  : fmap F (Id a) = Id (F a)
  := path_hom (fmap_id F a).

Definition gpd_strong_1functor_V {A B} `{Is1Gpd A, Is1Gpd B, !HasMorExt B}
           (F : A -> B) `{!Is0Functor F, !Is1Functor F}
           {a0 a1 : A} (f : a0 $== a1)
  : fmap F f^$ = (fmap F f)^$
  := path_hom (gpd_1functor_V F f).

Class Is3Graph (A : Type) `{Is2Graph A}
  := isgraph_hom_hom : forall (a b : A), Is2Graph (a $-> b).
Global Existing Instance isgraph_hom_hom | 30.
#[global] Typeclasses Transparent Is3Graph.

(** *** Preservation of initial and terminal objects *)

Class PreservesInitial {A B : Type} (F : A -> B)
  `{Is1Functor A B F} : Type
  := isinitial_preservesinitial
    : forall (x : A), IsInitial x -> IsInitial (F x).
Global Existing Instance isinitial_preservesinitial.

(** The initial morphism is preserved by such a functor. *)
Lemma fmap_initial {A B : Type} (F : A -> B)
  `{PreservesInitial A B F} (x y : A) (h : IsInitial x)
  : fmap F (mor_initial x y) $== mor_initial (F x) (F y).
Proof.
  exact (mor_initial_unique _ _ _)^$.
Defined.

Class PreservesTerminal {A B : Type} (F : A -> B)
  `{Is1Functor A B F} : Type
  := isterminal_preservesterminal
    : forall (x : A), IsTerminal x -> IsTerminal (F x).
Global Existing Instance isterminal_preservesterminal.

(** The terminal morphism is preserved by such a functor. *)
Lemma fmap_terminal {A B : Type} (F : A -> B)
  `{PreservesTerminal A B F} (x y : A) (h : IsTerminal y)
  : fmap F (mor_terminal x y) $== mor_terminal (F x) (F y).
Proof.
  exact (mor_terminal_unique _ _ _)^$.
Defined.

(** *** Functors preserving distinguished objects *)

Record BasepointPreservingFunctor (B C : Type)
       `{Is01Cat B, Is01Cat C} `{IsPointed B, IsPointed C} := {
    bp_map : B -> C;
    bp_is0functor : Is0Functor bp_map;
    bp_pointed : bp_map (point B) $-> point C
  }.

Arguments bp_pointed {B C}%type_scope {H H0 H1 H2 H3 H4} b.
Arguments Build_BasepointPreservingFunctor {B C}%type_scope {H H0 H1 H2 H3 H4}
  bp_map%function_scope {bp_is0functor} bp_pointed.

Coercion bp_map : BasepointPreservingFunctor >-> Funclass.

Global Existing Instance bp_is0functor.

Notation "B -->* C" := (BasepointPreservingFunctor B C) (at level 70).

Definition basepointpreservingfunctor_compose {B C D : Type}
           `{Is01Cat B, Is01Cat C, Is01Cat D}
           `{IsPointed B, IsPointed C, IsPointed D}
           (F : B -->* C) (G : C -->* D)
  : B -->* D.
Proof.
  snrapply Build_BasepointPreservingFunctor.
  - exact (G o F).
  - exact _.
  - exact (bp_pointed G $o fmap G (bp_pointed F)).
Defined.

Notation "G $o* F" := (basepointpreservingfunctor_compose F G) (at level 40).


Require Import Arith.
Require Import Omega.
Require Import Psatz.

Require Import kernel_numeric.
Require Import kernel_graph.
Require Import graph_examples.

(**
Graph constructions.
**)

Definition graph_clear: Graph -> Graph :=
  fun (G : Graph) => (Empty (V G)).

Definition graph_to_full: Graph -> Graph :=
  fun (G : Graph) => (K (V G)).

Definition graph_add_point_clear (G : Graph) :  Graph.
Proof.
  refine {| V :=  1 + (V G);
            E := fun x y => x < V G /\ y < V G /\ E G x y
         |}.
  - intros.
    destruct (lt_dec x G) ;
    destruct (lt_dec y G) ;
    destruct (E_decidable G x y) ; tauto.
  - intros x x_lt_G [H1 [H2 H3]].
    destruct (lt_dec x G).
    + absurd (G x x).
      * now apply E_irreflexive.
      * assumption.
    + tauto.
(*   - intros x x_lt_G1 y y_lt_G1 [H1 [H2 H3]].
    firstorder using E_symmetric.
*)
  - intros x xM y yM H.
    destruct H.
    destruct H0.
    split.
    + assumption.
    + split.
      * assumption.
      * now apply E_symmetric.
Defined.

Definition graph_add_point_full (G : Graph) :  Graph.
Proof.
  refine {| V :=  1 + (V G);
            E := fun x y => (x < V G /\ y < V G /\ E G x y
            ) \/ (x < V G /\ y >= V G) \/ (y < V G /\ x >= V G)
         |}.
  - intros.
    destruct (lt_dec x G).
    + destruct (lt_dec y G).
      * destruct (E_decidable G x y).
        tauto.
        right.
        intro H.
        destruct H.
        tauto.
        destruct H.
        omega.
        omega.
      * left.
        right.
        left.
        omega.
    + destruct (lt_dec y G).
      * left.
        right.
        right.
        omega.
      * right.
        intro H.
        destruct H.
        tauto.
        tauto.
  - intros.
    intro H0.
    destruct H0.
    + absurd (G x x).
      * now apply E_irreflexive.
      * tauto.
    + omega.
  - intros x xM y yM H.
    destruct H.
    + left.
      firstorder using E_symmetric.
    + right.
      tauto.
Defined.


From Coq Require Import
     List ZArith Ascii String
     extraction.ExtrOcamlIntConv.
Import ListNotations.

From SimpleIO Require SimpleIO.

From ExtLib Require Import
     Structures.Monads.
Import MonadNotation.
Local Open Scope monad.

From advent Require Import lib.

Section main.

Context {m : Type -> Type} `{Monad m}
        `{FoldRead Z m} `{MonadO Z m}.

(* Read integers and accumulate their sum. *)
Definition main : m unit :=
  fold_read (fun z0 z => z0 + z)%Z 0%Z >>= print.

End main.

Import SimpleIO.

Definition exec : io_unit := IO.unsafe_run main.

Extraction "day01_1.ml" exec.

Section spec.

(* Sum of a list of numbers. *)
Fixpoint sum_Z (zs : list Z) : Z :=
  match zs with
  | [] => 0
  | z :: zs => z + sum_Z zs
  end.

Lemma sum_Z_fold (zs : list Z) :
  sum_Z zs = fold_left Z.add zs 0%Z.
Proof.
  assert
    (H : forall zs z0, fold_left Z.add zs z0 = (z0 + sum_Z zs)%Z).
  - clear. induction zs; intro z; simpl.
    + rewrite Z.add_0_r. auto.
    + rewrite Z.add_assoc. auto.
  - rewrite H; auto.
Qed.

(* If you run [main] with the input [zs], then the printed output
   will be exactly [sum_Z zs]. *)
Definition correct (main : io_rel Z Z unit) : Prop :=
  forall zs, rel_spec Z Z main zs [sum_Z zs].

Theorem correct_main : correct main.
Proof.
  intros zs.
  unfold rel_spec.
  exists (Mk_io_state [] [sum_Z zs]); split; [| auto].
  exists (sum_Z zs); eexists.
  split.
  - apply fold_read_rel.
    split; [| reflexivity].
    apply sum_Z_fold.
  - hnf; auto.
Qed.

End spec.


From Coq Require Import Relations Relation_Operators.
From RelationAlgebra Require Import lattice monoid rel kat_tac.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype seq order choice.
From mathcomp Require Import finmap fingraph fintype finfun ssrnat path.
From Equations Require Import Equations.
From monae Require Import hierarchy monad_model.
From smallsteps Require Import relalg wftype monad.

(******************************************************************************)
(* Auxiliary definitions and lemmas about binary decidable relations.         *)
(*                                                                            *)
(*   mrel f       == a relation corresponding to non-deterministic function   *)
(*                   Given a monad M and monadic function f, mrel f denotes   *)
(*                   a relation consisting of pairs <x, y>, s.t. x \in f y.   *)
(*                   The monad M should have canonical morphism into          *)
(*                   list monad.                                              *)
(*   strictify f  == given a non-deterministic function, removes all the      *)
(*                   elements equal to the argument of the function.          *)
(*                   It can be used to obtain a strict (i.e. irreflexive)     *)
(*                   relation corresponding to f.                             *)
(*   suffix f     == given a well-founded function f and an element x,        *)
(*                   returns a strict suffix of x, i.e. a set { y | x R y }   *)
(*                   where R ::= sfrel f.                                     *)
(*   wsuffix f    == a weak (reflexive) suffix, i.e. a set { y | x R? y }     *)
(*   t_closure f  == given a well-founded function f returns its              *)
(*                   transitive closure as a decidable relation.              *)
(*                   t_closure f ≡ (sfrel f)^+                                *)
(*   rt_closure f == given a well-founded function f returns its              *)
(*                   reflexive-transitive closure as a decidable relation,    *)
(*                   t_closure f ≡ (sfrel f)^*                                *)
(******************************************************************************)

(* TODO: get rid of copy-paste from event-struct
 * in `relalg.v`, `wftype.v`, `mrel.v`
 *)

Set Implicit Arguments.
Unset Printing Implicit Defensive.
Set Equations Transparent.

Import Order.LTheory.
Local Open Scope order_scope.
Local Open Scope ra_terms.
Local Open Scope monae_scope.

Import NDMonadMorphism.Syntax.

(* A shorter name for list monad.
 * TODO: rename to Seq?
 * TODO: Use canonical structures to infer the
 *   monad instance for seq automatically?
 *)
Local Notation List := ModelNondet.list.

(* TODO: move to `monad.v` ? *)
Definition mrel {M : nondetMonad} {η : M ≈> List}
  {T : eqType} (f : T -> M T) : {dhrel T & T} :=
    [rel a b | b \in η T (f a)].

Section Strictify.

Context (T : eqType).
Variable  (M : nondetMonad) (η : M ≈> List).
Implicit Type (f : T -> M T).

Definition strictify f : T -> M T :=
  fun x => mfilter M (f x) (fun y => x != y).

Lemma strictify_weq f :
  @mrel M η T (strictify f) ≡ (@mrel M η T f \ eq_op).
Proof.
  move=> x y; rewrite /mrel /strictify /mfilter /=.
  by rewrite mem_mfilter andbC.
Qed.

Lemma strictify_leq f :
  @mrel M η T (strictify f) ≦ @mrel M η T f.
Proof. by rewrite strictify_weq; lattice. Qed.

End Strictify.

Module WfClosure.

Section WfRTClosure.

Context {disp : unit} {T : wfType disp}.

Variable (M : nondetMonad) (η : M ≈> List) (f : T -> M T).

(* Hypothesis descend : forall x y, y \in f x -> y < x. *)
Hypothesis descend : @mrel M η T f ≦ (>%O).

(* A hack to get around a bug in Equations
 * (see https://github.com/mattam82/Coq-Equations/issues/241).
 * In short, we cannot express this function directly in Equations' syntax
 * (we can do it by adding `noind` specifier, but then we cannot use `funelim`).
 * Thus we have to "tie a recursive knot" manually.
 *)
 Definition suffix_aux (x : T) (rec : forall y : T, y < x -> M T) :=
  let ys := f x in
  let ps := ys >>= (fun x =>
    if x \in η T ys =P true is ReflectT pf then
      rec x (descend _ _ pf)
    else
      Fail
  ) in
  Alt ys ps.

(* strict suffix of an element `x`, i.e. a set { y | x R y } *)
Equations suffix (x : T) : M T by wf x (<%O : rel T) :=
  suffix x := suffix_aux x suffix.

(* weak suffix of an element `x`, i.e. a set { y | x R? y } *)
Definition wsuffix (x : T) : M T :=
  Alt (Ret x) (suffix x).

(* decidable transitive closure *)
Definition t_closure : {dhrel T & T} :=
  fun x y => y \in η T (suffix x).

(* decidable reflexive-transitive closure *)
Definition rt_closure : {dhrel T & T} :=
  fun x y => y \in η T (wsuffix x).

(* ************************************************************************** *)
(*       THEORY                                                               *)
(* ************************************************************************** *)

Lemma t_closure_1nP x y :
  reflect (clos_trans_1n T (@mrel M η T f) x y) (t_closure x y).
Proof.
  rewrite /t_closure; funelim (suffix x)=> /=.
  apply /(iffP idP); rewrite mem_alt /mrel /=.
  { move=> /orP[|/mem_bindP[z]] //; first exact: t1n_step.
    case: eqP=> // S /descend yz /X tr.
    move: (tr yz) => H.
    by apply: t1n_trans; first exact: S. }
  move: X=> /[swap] [[?->//|{}y ? /[dup] ? L /[swap]]].
  move=> /[apply] H; apply/orP; right; apply/mem_bindP.
  exists y=> //. case: eqP => // /descend yz. exact: H.
Qed.

Lemma t_closureP x y :
  reflect (clos_trans T (@mrel M η T f) x y) (t_closure x y).
Proof.
  apply /(equivP (t_closure_1nP x y)).
  symmetry; exact: clos_trans_t1n_iff.
Qed.

Lemma clos_trans_gt :
  clos_trans T (@mrel M η T f) ≦ (>%O : rel T).
Proof.
  move=> ??; rewrite/mrel /=.
  elim=> [y z /descend | x y z _ ] //=.
  move=> /[swap] _ /[swap]; exact: lt_trans.
Qed.

Lemma t_closure_gt : t_closure ≦ (>%O : rel T).
Proof. by move=> x y /t_closureP /clos_trans_gt. Qed.

Lemma t_closure_antisym : antisymmetric t_closure.
Proof.
  move=> x y /andP[] /t_closure_gt ? /t_closure_gt ?.
  by apply /eqP; rewrite eq_le !ltW.
Qed.

Lemma t_closure_trans : transitive t_closure.
Proof.
  move=> y x z /t_closureP ? /t_closureP ?.
  apply /t_closureP /t_trans; eauto.
Qed.

Lemma rt_closureP x y :
  reflect (clos_refl_trans T (@mrel M η T f) x y) (rt_closure x y).
Proof.
  apply /equivP; last first.
  { rewrite clos_refl_transE clos_refl_hrel_qmk.
    apply or_iff_compat_l; symmetry.
    apply rwP; exact: t_closureP. }
  rewrite /t_closure /rt_closure /wsuffix mem_alt mem_ret eq_sym /=.
  by apply predU1P.
Qed.

Lemma rt_closureE : rt_closure ≡ t_closure^?.
Proof.
  move=> x y /=; rewrite /rt_closure /t_closure /wsuffix.
  rewrite alt_morph /Alt /= /monae_lib.curry /= mem_cat /dhrel_one.
  by rewrite mem_ret eq_sym.
Qed.

Lemma rt_closure_ge : rt_closure ≦ (>=%O : rel T).
Proof.
  rewrite rt_closureE.
  move=> x y /orP[/eqP<-//=|].
  move=> /t_closure_gt; exact: ltW.
Qed.

Lemma rt_closure_refl x : rt_closure x x.
Proof.
  rewrite /rt_closure alt_morph /Alt /= /monae_lib.curry /= mem_cat.
  by rewrite mem_ret eq_refl.
Qed.

Lemma rt_closure_antisym : antisymmetric rt_closure.
Proof.
  move=> x y /andP[].
  move=> /rt_closure_ge /= xy /rt_closure_ge /= yx.
  by apply /eqP; rewrite eq_le xy yx.
Qed.

Lemma rt_closure_trans : transitive rt_closure.
Proof.
  move=> y x z /rt_closureP xy /rt_closureP ?.
  by apply/rt_closureP; apply: rt_trans xy _.
Qed.

End WfRTClosure.

End WfClosure.


Load "Example15".
(*********************************************************************)
(***************if not(b) then x else y = if b then y else x***********)

Theorem Example16_B :  forall (n:nat) (b1 b2 :Bool), (if_then_else_B (notb  (Bvar n)) b1 b2) ## (if_then_else_B (Bvar n) b2 b1).
Proof.
intros.
unfold notb.
assert(H1: (if_then_else_B (if_then_else_B (Bvar n) FAlse TRue) b1 b2) ##
    (if_then_else_B (Bvar n) (  if_then_else_B FAlse b1 b2) ( if_then_else_B TRue b1 b2))).

apply IFMORPH_B2 .
rewrite H1.
rewrite IFFALSE_B.
rewrite IFTRUE_B.
reflexivity.
Qed.
Theorem Example16_M :  forall (n:nat) (m1 m2:message), (if_then_else_M (notb  (Bvar n)) m1 m2) # (if_then_else_M (Bvar n) m2 m1).
Proof.
intros.
unfold notb.
assert(H1: (if_then_else_M (if_then_else_B (Bvar n) FAlse TRue) m1 m2) #
    (if_then_else_M (Bvar n) (  if_then_else_M FAlse m1 m2) ( if_then_else_M TRue m1 m2))).

apply IFMORPH_M2 .
rewrite H1.
rewrite IFFALSE_M.
rewrite IFTRUE_M.
reflexivity.
Qed.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L.Datatypes Require Import LFinType LBool LProd Lists.
From Undecidability.L.Functions Require Import EqBool.

Section Lookup.
  Variable X Y : Type.
  Context {eqbX : X -> X -> bool}.
  Context `{eqbClass X eqbX}.

  Fixpoint lookup (x:X) (A:list (X*Y)) d: Y :=
    match A with
      [] => d
    | (key,Lproc)::A =>
      if eqb x key then Lproc else lookup x A d
    end.

  Context `{encodable X} `{@eqbComp X _ eqbX _}.

  Global Instance term_lookup `{encodable Y}:
    computable (lookup).
  Proof using H1.
  unfold lookup. unfold eqb.
  extract.
  Qed.

End Lookup.

Section funTable.

  Variable X : finType.
  Variable Y : Type.
  Variable f : X -> Y.

  Definition funTable :=
    map (fun x => (x,f x)) (elem X).

  Variable (eqbX : X -> X -> bool).
  Context `{eqbClass X eqbX}.

  Lemma lookup_funTable x d:
    lookup x funTable d = f x.
  Proof.
    unfold funTable.
    specialize (elem_spec x).
    generalize (elem X) as l.
    induction l;cbn;intros Hel.
    -tauto.
    -destruct (eqb_spec x a).
     +congruence.
     +destruct Hel. 1:congruence.
      eauto.
  Qed.

End funTable.


Require Export GeoCoq.Elements.OriginalProofs.lemma_ray1.
Require Export GeoCoq.Elements.OriginalProofs.lemma_raystrict.
Require Export GeoCoq.Elements.OriginalProofs.lemma_ray4.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_ray5 :
   forall A B C,
   Out A B C ->
   Out A C B.
Proof.
intros.
assert ((BetS A C B \/ eq B C \/ BetS A B C)) by (conclude lemma_ray1).
assert (neq A C) by (conclude lemma_raystrict).
assert (Out A C B) by (conclude lemma_ray4).
close.
Qed.

End Euclid.


Require Import FunInd.
Require Import OrderedType.
Require Import Utf8_core.
Require Import ILL.
Require Import vars.
Require Import multiset_spec.
Require Import multiset.
Require Import PeanoNat OrderedTypeEx.
Require Import Lia.
Module N_OT <: OrderedType.

  Definition t : Type := nat.

  Definition eq : t -> t -> Prop := eq.
  Definition lt : t -> t -> Prop := lt.

  Definition eq_refl : forall x : t, eq x x := @eq_refl _.
  Definition eq_sym : forall x y : t, eq x y -> eq y x := @eq_sym _.
  Definition eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z := @eq_trans _.

  Definition lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z := Nat.lt_trans.
  Definition lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    intros x y H. unfold lt,eq  in *; lia.
  Defined.

  Functional Scheme nat_compare_rect := Induction for Nat.compare Sort Type.

  Definition nat_compare_eq : ∀ n m : nat, Nat.compare n m = Eq → n = m.
  Proof.
    intros n m.
    functional induction (Nat.compare n m) using nat_compare_rect.
    intros _;reflexivity.
    intros abs;discriminate.
    intros abs;discriminate.
    intros H;rewrite (IHc H);reflexivity.
  Defined.

  Definition nat_compare_Lt_lt : forall n m, Nat.compare n m = Lt -> n<m.
  Proof.
    intros n m.
    functional induction (Nat.compare n m) using nat_compare_rect.
    intros abs;discriminate.
    intros;lia.
    intros abs;discriminate.
    intros H;assert (U:=IHc H).
    clear IHc H.
    intros;lia.
  Defined.

  Lemma nat_compare_Gt_gt : forall n m, Nat.compare n m = Gt -> n>m.
  Proof.
    intros n m.
    functional induction (Nat.compare n m) using nat_compare_rect.
    intros abs;discriminate.
    intros abs;discriminate.
    intros;lia.
    intros H;assert (U:=IHc H).
    clear IHc H.
    intros;lia.
  Defined.

  Lemma compare : forall x y : t, Compare lt eq x y.
  Proof.
    intros x y; destruct (Nat.compare x y) as [ | | ] eqn:Heqn.
    apply EQ. apply nat_compare_eq; assumption.
    apply LT. apply nat_compare_Lt_lt; assumption.
    apply GT. apply nat_compare_Gt_gt; assumption.
  Defined.

  #[local] Hint Immediate eq_sym : core.
  #[local] Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : core.

  Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
  Proof.
    unfold eq,t.
    intros [ | x] [ | y].
    left;reflexivity.
    right;intro abs;discriminate abs.
    right;intro abs;discriminate abs.
    case (Nat.eq_dec x y);intros Heq.
    left;rewrite Heq;reflexivity.
    right;intros abs;elim Heq;injection abs;intros;assumption.
  Defined.

End N_OT.
Module MILL.

  Include  ILL_Make(N_OT). (* Build ILL with vars as intergers *)

  Lemma eq_is_eq : forall f g, eq f g <-> f = g.
  Proof.
    intros f.
    induction f;destruct g;simpl;split;try tauto;try discriminate.
    intros;subst;try reflexivity.
    intros H;injection H;tauto.
    intros [H1 H2].
    destruct (IHf1 g1) as [h _];rewrite h;try assumption;clear h;
      destruct (IHf2 g2) as [h _];rewrite h;try assumption;reflexivity.
    intros H;injection H;clear H;intros;subst;split;apply FormulaOrdered.eq_refl.
    intros [H1 H2].
    destruct (IHf1 g1) as [h _];rewrite h;try assumption;clear h;
      destruct (IHf2 g2) as [h _];rewrite h;try assumption;reflexivity.
    intros H;injection H;clear H;intros;subst;split;apply FormulaOrdered.eq_refl.
    intros [H1 H2].
    destruct (IHf1 g1) as [h _];rewrite h;try assumption;clear h;
      destruct (IHf2 g2) as [h _];rewrite h;try assumption;reflexivity.
    intros H;injection H;clear H;intros;subst;split;apply FormulaOrdered.eq_refl.
    intros H1.
    destruct (IHf g) as [h _];rewrite h;try assumption;clear h;reflexivity.
    intros H;injection H;clear H;intros;subst;apply FormulaOrdered.eq_refl.
    intros [H1 H2].
    destruct (IHf1 g1) as [h _];rewrite h;try assumption;clear h;
      destruct (IHf2 g2) as [h _];rewrite h;try assumption;reflexivity.
    intros H;injection H;clear H;intros;subst;split;apply FormulaOrdered.eq_refl.
  Qed.
End MILL.

Module Tacs := ILL_tactics_refl(N_OT)(MILL).


Require Import HJ.Vars.
Set Arguments Implicit.

(**
  A count-down rsem with dynamic registration works exactly like
  a reverse semaphore, it includes has three operations:
  - an operation to register a task that increments the reverse semaphore;
  - an operation to signal, or deregister, a task that decrements the reverse semaphore;
  - an operation to wait that checks if the reverse semaphore is zero.
  The reason the we call it a "reverse" semaphore is because the blocking condition
  is reversed, that is a semaphore blocks while it is zero, whereas a reverse semaphore
  blocks until it becomes zero.

  We represent a rsem as a set of tasks to be able to bookkeep registered tasks.
  *)

Record rsem := mk_rsem {
  value : set_tid
}.

(**
  We create a rsem without any registered task.
  *)

Definition zero := mk_rsem Set_TID.empty.

Section API.

Variable l:rsem.

(**
  Registers a task in the rsem. Registered task must
  be eventually signaled or deregistered so that
  synchronization can happen.
  *)

Definition register (t:tid) :=
  mk_rsem (Set_TID.add t (value l)).

Definition inc := register.

(**
  Signaling a task revokes its registration,
  so tasks blocked on [wait] will no longer wait for
  the signalling task.
  *)

Definition signal (t:tid) :=
  mk_rsem (Set_TID.remove t (value l)).

Definition deregister := signal.
Definition dec := signal.

(**
  The [wait] operation should block until there are
  no registered tasks.
  *)

Inductive Wait : Prop :=
  wait_def:
    Set_TID.Empty (value l) ->
    Wait.

(**
  Asserts that task [t] is registerd in rsem [l].
  *)

Inductive Registered (t:tid) : Prop :=
  registered_def:
    Set_TID.In t (value l) ->
    Registered t.

End API.

Inductive Eq (l1:rsem) (l2:rsem) : Prop :=
  eq_def:
    Set_TID.eq (value l1) (value l2) ->
    Eq l1 l2.
Module Sem.

(** How do we represent that synchronization works? *)

Inductive op :=
  | REG
  | SIG
  | WAIT.

Inductive Redex (l:rsem) (t:tid) : op -> rsem -> Prop  :=
  | redex_reg:
    ~ Registered l t ->
    Redex l t REG (register l t)

  | redex_sig:
    Registered l t ->
    Redex l t SIG (signal l t)

  | redex_wait:
    Wait l ->
    Redex l t WAIT l.

End Sem.

Module Props.

Import Sem.

Inductive Check (l:rsem) (t:tid) : op -> Prop :=
  | check_reg:
    ~ Wait l ->
    ~ Registered l t ->
    Check l t REG
  | check_sig:
    Registered l t ->
    Check l t SIG
  | check_wait:
    ~ Registered l t ->
    Check l t WAIT.

(*
Module Commutativity.

Lemma check_respects_reduce:
  forall l l' t t' o o',
  Check l t o ->
  Redex l t' o' l' ->
  t <> t' ->
  Check l' t o.
Admitted.

Lemma check_reduces_inv:
  forall l t o l',
  Redex l t o l' ->
  Check l t o.
Admitted.

Lemma commutativity:
  forall l1 l2 l2' l3 l3' t1 t2 o1 o2,
  t1 <> t2 ->
  Redex l1 t1 o1 l2  -> Redex l2  t2 o2 l3 ->
  Redex l1 t2 o2 l2' -> Redex l2' t1 o1 l3' ->
  Eq l1 l2.
Admitted.
*)

Section Progress.
(**
  Progress means that either the rsem is a value, or there
  is at least an operation that can be issued.
  But how can we enumerate the available operations?

  At any time a task may be registered, which means that there is always
  *)

Variable l: rsem.

(**
  The first thing to show is that there is progress for
  unblocked tasks. We define a unblocking predicate that yields [true]
  when the operation is unblocking.
*)

Definition blocking (o:op) :=
  match o with
  | REG => false
  | SIG => false
  | WAIT => true
  end.

Lemma blocking_true:
  forall o,
  blocking o = true <-> o = WAIT.
Proof.
  destruct o; (simpl;
    (split; (
    intros;
    inversion H))); auto.
Qed.

(**
  Any unblocked
  The proof for this lemma is trivial, by inversion of proposition [Check].
  *)

Require Import HJ.Progress.

Lemma progress_unblocked:
  forall t o,
  Check l t o ->
  blocking o = false ->
  CanReduce (Redex l) t o.
Proof.
  intros.
  destruct o.
  - inversion H.
    subst.
    eauto using redex_reg, can_reduce_def.
  - inversion H.
    subst.
    eauto using redex_sig, can_reduce_def.
  - inversion H0.
Qed.

Variable r:Map_TID.t op.

Variable reg_in_r : forall t, Registered l t <-> Map_TID.In t r.

Variable r_check:
  forall t o, Map_TID.MapsTo t o r -> Check l t o.

Lemma registered_in_reqs:
  (forall t o, Map_TID.MapsTo t o r -> blocking o = true) ->
  forall t,
  Registered l t ->
  Map_TID.MapsTo t WAIT r.
Proof.
  intros.
  apply reg_in_r in H0.
  apply Map_TID_Extra.in_to_mapsto in H0.
  destruct H0 as (o,  Hmt).
  assert (o = WAIT). {
    apply H in Hmt.
    apply blocking_true.
    assumption.
  }
  subst.
  assumption.
Qed.

Lemma registered_check_wait:
  (forall t o, Map_TID.MapsTo t o r -> blocking o = true) ->
  forall t,
  Registered l t ->
  Check l t WAIT.
Proof.
  intros.
  auto using registered_in_reqs.
Qed.

Lemma progress_blocked:
  ~ Map_TID.Empty r ->
  (forall t o, Map_TID.MapsTo t o r -> blocking o = true) ->
  exists t o,
  Map_TID.MapsTo t o r /\
  CanReduce (Redex l) t o.
Proof.
  intros.
  (** Wait is enabled. *)
  assert (Hw: Wait l). {
    apply wait_def.
    unfold Set_TID.Empty.
    intros.
    destruct (Set_TID_Props.In_dec a (value l)).
    - assert (Hreg : Registered l a). { auto using registered_def. }
      assert (Check l a WAIT). {
        eapply registered_check_wait; auto.
      }
      inversion H1.
      contradiction H2.
    - assumption.
  }
  (** We can pick a task. *)
  destruct (Vars.Set_TID_Dep.choose (value l)) as [(t,Hin)|Hempty].
  - exists t.
    exists WAIT.
    split.
    + eauto using registered_def, registered_in_reqs.
    + exists l.
      auto using redex_wait.
  - apply Map_TID_Extra.nonempty_in in H.
    destruct H as (t, Hin).
    assert (Hsin : Set_TID.In t (value l)). {
      apply reg_in_r in Hin.
      inversion Hin.
      assumption.
    }
    unfold Set_TID.Empty in Hempty.
    assert (~ Set_TID.In t (value l)). {
      apply Hempty.
    }
    contradiction Hsin.
Qed.

Require HJ.Progress.

Variable reqs_spec :
  HJ.Progress.RequestSpec.request_spec r
  (Check l)
  (Registered l).

Let l_prog:
  @HJ.Progress.progress_spec op r (Check l) rsem (Redex l) blocking.
Proof.
  intros.
  refine (
    @HJ.Progress.mk_progress_spec op r (Check l) _
      (Redex l) blocking _ _); auto.
  - apply progress_unblocked.
  - apply progress_blocked.
Defined.

Lemma prog:
  ~ Map_TID.Empty r ->
  (** There is a task that can reduce. *)
  exists t o,
  Map_TID.MapsTo t o r /\ CanReduce (Redex l) t o.
Proof.
  intros.
  eauto using HJ.Progress.main_progress, l_prog.
Qed.
End Progress.
End Props.


Require Import VST.floyd.proofauto.
Require Import stdpp.list.
Require Import ZArith.
Require Import compcert.lib.Coqlib.
Require Import list_lemmas.

(*  Function to split a [large] integer into a list representation
    of size number of limbs (14 in this case).*)

Definition prime: Z := 2^448 - 2^224 - 1.

Local Open Scope Z.

Fixpoint int_to_list_aux (N : Z) (i : nat) :=
    match (i) with
    | 0%nat => nil
    | S i' => [(N / (2^(32 * (13 - (Z.of_nat i'))))) mod 2^32] ++ int_to_list_aux N i'
    end.

Definition int_to_list (N : Z) : list Z :=
    int_to_list_aux N 14.

Definition two_prime_mone_list : list Z :=
    [4294967293; 4294967295; 4294967295; 4294967295; 4294967295;
       4294967295; 4294967295; 4294967293; 4294967295; 4294967295;
       4294967295; 4294967295; 4294967295; 4294967295].

Definition prime_list : list Z :=
    [2^32-1; 2^32-1; 2^32-1; 2^32-1; 2^32-1;
     2^32-1; 2^32-1; 2^32-2; 2^32-1; 2^32-1;
     2^32-1; 2^32-1; 2^32-1; 2^32-1].

Definition f_fun (l : list Z) (i t : Z) : Z:=
    if (i =? 0) then (Znth i l) + t
    else  Int.unsigned (Int.shru (Int.repr ((Znth (i-1) l) + t)) (Int.repr 32)).

Fixpoint list_subtract (l1 l2: list Z) :=
    match l1, l2 with
    | [], _ => map (fun a => -1 * a) l2
    | _, [] => l1
    | h1::t1, h2::t2 => (h1 - h2)::list_subtract t1 t2
    end.

Fixpoint list_add_with_temp_aux (l : list Z) (temp : Z) (i : nat) :=
    match i with
    | 0 =>
    |

(*  Function (body) to unify the list representation of a large integer
    so that it is an integer. *)
Fixpoint list_to_int_aux (l  : list Z) (n : Z) : Z :=
    match l with
    | nil => 0
    | h :: t => ((h mod 2^32) * (Z.pow 2 (32 * (n)))) + (list_to_int_aux t (n+1))
    end.

(* Function to write an integer from a list representation. *)
Definition list_to_int (l : list Z) := list_to_int_aux l 0.

Compute ((list_to_int [1;1;0;1] - list_to_int [1;0;0;3]) mod 2^(32*4)).
Compute list_to_int (list_subtract [1;1;0;1] [1;0;0;3]) mod 2^(32*4).

(* NOTE: int_to_list loses information on numbers greater than prime + 2^(32*7) --
         no problem if doing list_to_int (a-prime) as long as a < 2*prime.*)

Compute (prime - 2^(32*7)).

(* Definition x : Z := prime + 2^(32*7) .

Compute list_to_int (int_to_list x) - x.
Compute prime. *)

(*  Checks if two lists have the same contents, where the contents are  *
 *  interpreted as Compcert's int (a Z integer taken modulo 2^32)       *)
Fixpoint list_Inteq (a b : list Z) : bool :=
    match a with
    | [] => match b with
        | []    => true
        | _::_  => false
        end
    | a0 :: a => match b with
        | []      => false
        | b0 :: b => Int.eq (Int.repr a0) (Int.repr b0) &&
                     list_Inteq a b
        end
    end.

(* LEMMAS *)

Lemma  int_to_list_length:
forall N : Z,
Zlength (int_to_list N) = 14.
Proof.
unfold int_to_list.
auto.
Qed.

Lemma  int_to_list__list_to_int_pres_length:
forall l : list Z,
Zlength (int_to_list (list_to_int l)) = 14.
Proof.
    intros.
    apply int_to_list_length.
Qed.

Lemma Znth_int_to_list:
forall (N : Z) (i : nat),
(Z.of_nat i) < 14 ->
Znth (Z.of_nat i) (int_to_list N) = (N / (2^(32 * (Z.of_nat i)))) mod 2^32.
Proof. (* This is a manual proof by induction. *)
    intros.
    induction i as [| i _]; try easy.
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy.
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    induction i as [| i _]; try easy;
    replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) by lia.
    simpl in H.
    replace (Z.of_nat
    (S (S (S (S (S (S (S (S (S (S (S (S (S (S i))))))))))))))) with 14 in H by lia.
    discriminate H.
    Qed.


Section ml.
Variables A B:Prop.
Theorem Andcomr: and A B -> and B A.
Proof.
    intros Hab.
    split; elim Hab; intros h0 h1; assumption.
    (* elim Hab.
    intros a b.
    split; assumption. *)
Qed.
End ml.

Check Andcomr.


Require Import Basics.
Require Import Paths.

(** We define two Higher indutive types in this file: suspensions and pushouts. **)

Module Export Suspension.
  Private Inductive Suspension (A : Type) : Type :=
    NN : Suspension A
  | SS : Suspension A.

  Axiom pathSuspension : forall {A : Type} , A -> (NN A) = (SS A).

  Definition SuspensionInduction {A : Type} {B : Type} (vn : B) (vs : B) (f: A -> (vn = vs)) (x : Suspension A) : B :=
    match x with
    |NN _ => (fun _ => vn)
    |SS _ => (fun _ => vs)
    end f .

  Axiom SuspensionInduction_path :
    forall A B (vn vs : B) f (a : A),
      f_equal (SuspensionInduction vn vs f) (pathSuspension a) = (f a).

  Definition SuspensionInductionDependant {A : Type}:
    forall (B : Suspension A -> Type)
           (vn : B (NN A)) (vs : B (SS A))
           (f : forall a : A,  (pathSuspension a) # vn = vs )
           (x : Suspension A), B x := fun B vn vs f x =>
    match x with
    |NN _ => (fun _ => vn)
    |SS _ => (fun _ => vs)
    end f .

  Axiom SuspensionInductionDependant_path :
    forall A B (vn : B (NN A)) (vs : B (SS A)) f (a : A),
      apd (SuspensionInductionDependant B vn vs f) (pathSuspension a) = (f a).
End Suspension.

Definition eqMorph (A T: Type) (F G : Suspension A -> T)
           (HN: F (NN A) = G (NN A))
           (HS: F (SS A) = G (SS A))
           (Heq : forall a : A,   HN @ (f_equal G (pathSuspension a)) = (f_equal F (pathSuspension a)) @ HS )
  : forall x : Suspension A, F x = G x.
Proof.
  unshelve eapply (@SuspensionInductionDependant A).
  - exact HN.
  - exact HS.
  - intro. apply transport_lemma. exact (Heq a).
Defined.

Definition SuspensionMap {A B : Type} (f : A -> B) (x : Suspension A) : Suspension B :=
  SuspensionInduction (NN B) (SS B) (fun a => pathSuspension (f a)) x.

(** The suspension allows us to recursively define the sphere and the ball **)
Fixpoint Sphere (n : nat) : Type :=
  match n with
  |0 => False
  |S m => Suspension (Sphere m)
  end.

Fixpoint Ball (n : nat) : Type :=
  match n with
  |0 => True
  |Datatypes.S m => Suspension  (Ball m)
  end.

Fixpoint Faces (n : nat) : (Sphere n) -> (Ball n) :=
  match n with
  |0 => (False_rect True)
  |S m => SuspensionMap (Faces m)
  end.

Fixpoint Source (n : nat) : (Ball n) -> (Sphere (S n)) :=
  match n with
  |0 => (fun _ => NN _)
  |S m => SuspensionMap (Source m)
  end.
Fixpoint Target (n : nat) : (Ball n) -> (Sphere (S n)) :=
  match n with
  |0 => (fun _ => SS _)
  |S m => SuspensionMap (Source m)
  end.

Arguments Sphere n : simpl nomatch.
Arguments Ball n : simpl nomatch.
Arguments Faces n : simpl nomatch.
Arguments Source n : simpl nomatch.
Arguments Target n : simpl nomatch.

Definition nFaces (n : nat) (T : Type) : (Ball n -> T) -> (Sphere n -> T) :=
  fun x => (compose x (Faces n)).

Module Export Pushout.
  Private Inductive Pushout {A B1 B2 : Type} (f1 : A -> B1) (f2: A -> B2) : Type :=
  |inl : B1 -> Pushout f1 f2
  |inr : B2 -> Pushout f1 f2.

  Arguments inl {_ _ _ _ _} _.
  Arguments inr {_ _ _ _ _} _.

  Axiom incoh : forall A B1 B2 : Type, forall f1 : A -> B1, forall f2: A -> B2,  forall a:A, @inl _ _ _ f1 f2 (f1 a) = @inr _ _ _ f1 f2 (f2 a).

  Arguments incoh {_ _ _ _ _} _.

  (** We first define a non-dependent version of the eliminator for PUshouts **)
  Definition Pushout_rect {A B1 B2 : Type} {f1 : A -> B1} {f2 : A -> B2}
             {B : Type} (g1 : B1 -> B) (g2 : B2 -> B)
             (H : forall a : A, (g1 (f1 a) = g2 (f2 a))) (x : Pushout f1 f2) : B :=
    match x with
    |inl  b1 => (fun _ => g1 b1)
    |inr  b2 => (fun _ => g2 b2)
    end H.

  Axiom Pushout_rect_compute_coh : forall {A B1 B2} {f1 : A -> B1} {f2 : A -> B2} {B} {g1 : B1 -> B} {g2 : B2 -> B} {H a},
      f_equal (@Pushout_rect _ _ _ f1 f2 _ g1 g2 H) (incoh a) = H a.

  Definition Pushout_rect_dep {A B1 B2 : Type} {f1 : A  -> B1} {f2 : A -> B2} :
    forall (P : Pushout f1 f2 -> Type)
           (g1 : forall b1 : B1, P (inl b1))
           (g2 : forall b2 : B2, P (inr b2))
           (H : forall a, (incoh a) # g1 (f1 a) = g2 (f2 a))
           (x : Pushout f1 f2), P x :=
    (fun P g1 g2 H x =>
       match x with
       |inl b1 => (fun _ => g1 b1)
       |inr b2 => (fun _ => g2 b2)
       end H
    ).

  Axiom Pushout_rect_dep_compute :
    forall {A B1 B2 : Type} {f1 : A -> B1} {f2 : A -> B2}
           {P : Pushout f1 f2 -> Type}
           {g1 : forall b1 : B1, P (inl  b1)}
           {g2 : forall b2 : B2, P (inr  b2)}
           {H : forall a, (incoh a) # g1 (f1 a) = g2 (f2 a)}
           {a},
      apd (Pushout_rect_dep P g1 g2 H) (incoh a) = H a.
End Pushout.

Lemma Pushout_rect_compute_inl : forall {A B1 B2 : Type}, forall {f1 : A -> B1}, forall {f2 : A -> B2},
          forall {B} {g1 : B1 -> B} {g2 : B2 -> B} {H :  forall a: A,  g1 (f1 a ) = g2 (f2 a )} {b1 b'1 : B1} {p : b1 = b'1} ,
            f_equal (Pushout_rect g1 g2 H) (f_equal inl p) = f_equal g1 p.
Proof.
  destruct p.
  reflexivity.
Defined.

Lemma Pushout_rect_compute_inr : forall {A B1 B2 : Type}, forall {f1 : A  -> B1}, forall {f2 : A  -> B2},
          forall {B} {g1 : B1 -> B} {g2 : B2 -> B} {H :  forall a: A, g1 (f1 a) = g2 (f2 a)} {b2 b'2 : B2} {p : b2 = b'2} ,
            f_equal (Pushout_rect g1 g2 H) (f_equal inr p) = f_equal g2 p.
Proof.
  destruct p.
  reflexivity.
Defined.

(** This is an equality criterion for morphisms from a Pushout **)

Definition eqMorphPushout {A B1 B2 T: Type} {f1 : A -> B1} {f2 : A -> B2} {F G : Pushout f1 f2 -> T}
           (H1: forall b1 : B1, F (inl b1) = G (inl b1))
           (H2: forall b2 : B2, F (inr b2) = G (inr b2))
           (Heq : forall (a : A),  H1 (f1 a) @ (f_equal G (incoh a)) = (f_equal F (incoh a)) @ H2 (f2 a) )
  : forall x : Pushout f1 f2, F x = G x.
Proof.
  simple refine  (Pushout_rect_dep _ _ _ _).
  - exact H1.
  - exact H2.
  - intros. simple refine (transport_lemma _ _ _ _ _ _). exact (Heq a).
Defined.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.

(** Every pre-order relation is a category. *)
Record PreOrder : Type :=
{
  PreOrder_car :> Type;

  PreOrder_rel :> PreOrder_car → PreOrder_car → Type
  where "a ≤ b" := (PreOrder_rel a b);

  PreOrder_rel_isProp : ∀ x y (h h' : PreOrder_rel x y), h = h';

  PreOrder_refl : ∀ a, a ≤ a;

  PreOrder_trans : ∀ a b c, a ≤ b → b ≤ c → a ≤ c
}.

Arguments PreOrder_rel {_} _ _.
Arguments PreOrder_refl {_} _.
Arguments PreOrder_trans {_ _ _ _} _ _.

Notation "a ≤ b" := (PreOrder_rel a b) : preorder_scope.

Section PreOrder_Cat.
  Context (P : PreOrder).

  Local Hint Resolve PreOrder_rel_isProp : core.

  Program Definition PreOrder_Cat : Category :=
    {|
      Obj := P;
      Hom := fun a b => (a ≤ b)%preorder;
      compose := @PreOrder_trans P;
      id := @PreOrder_refl P
    |}
  .

End PreOrder_Cat.


(*
 *   ____             __ _
 *  / ___|___  _ __  / _| |_   _  ___ _ __   ___ ___
 * | |   / _ \| '_ \| |_| | | | |/ _ \ '_ \ / __/ _ \
 * | |__| (_) | | | |  _| | |_| |  __/ | | | (_|  __/
 *  \____\___/|_| |_|_| |_|\__,_|\___|_| |_|\___\___|
 *
 *)

Require Import FreeMonoid.
Require Import StrongNormalisation.

Definition strongly_confluent (T : Type) (R : T -> T -> Prop) : Prop
     := forall (a b c : T), R a b -> R a c
          -> (b = c) \/ (R b c) \/ (R c b) \/ (exists (d : T), R b d /\ R c d).

Theorem reduction_strongly_confluent' (T : Type) :
    forall (a b c : (FreeMonT (WithInv T))), Reduction T a b -> Reduction T a c
        -> (b = c) \/ (exists (d : (FreeMonT (WithInv T))), Reduction T b d /\ Reduction T c d).
Proof.
    unfold strongly_confluent. intros a b c Hab.
    remember a as x. remember b as y.
    rewrite -> Heqy in Hab. rewrite -> Heqx in Hab.
    generalize dependent c. generalize dependent y. generalize dependent x.
    induction Hab.

    - intros a Heqx b Heqy c Hbc. destruct Hbc.
      + inversion Heqx. left. assumption.
      + inversion Heqx.
      + destruct Hbc.
        * inversion Heqx.
        * inversion Heqx. left. rewrite Heqy. symmetry. assumption.
        * inversion Heqx. right. exists m'. rewrite -> H2 in Hbc. rewrite <- Heqy in Hbc.
          split; try assumption. apply LeftRed.

    - intros a Heqx b Heqy z Hbc. destruct Hbc.
      + inversion Heqx.
      + inversion Heqx. left. assumption.
      + destruct Hbc.
        * inversion Heqx. left. rewrite Heqy. symmetry. assumption.
        * inversion Heqx.
        * inversion Heqx. right. exists m'. rewrite -> H2 in Hbc. rewrite <- Heqy in Hbc.
          split; try assumption. apply RightRed.

    - intros a Heqx b Heqy c Hred. destruct Hred.
      + destruct Hab; inversion Heqx.
        * left. rewrite <- H1. rewrite -> H0. assumption.
        * right. exists m'. split; try assumption.
          rewrite -> Heqy. rewrite <- H0. rewrite <- H1. apply LeftRed.
      + destruct Hab; inversion Heqx.
        * left. rewrite <- H1. rewrite -> H0. assumption.
        * right. exists m'. split; try assumption.
          rewrite -> Heqy. rewrite <- H0. rewrite <- H1. apply RightRed.
      + inversion Heqx. rewrite -> H1 in Hred.
        pose (IHHab m (eq_refl m) m' (eq_refl m') m'0 Hred) as Hind.
        destruct Hind as [ Hctxeq | [ red [ Hctxredm' Hctxredm'0 ] ] ].
        * left. rewrite -> Heqy. rewrite <- Hctxeq. reflexivity.
        * right. exists (App (WithInv T) x red). rewrite -> Heqy.
          split; apply CtxRed; assumption.
Qed.

Theorem reduction_strongly_confluent (T : Type) : strongly_confluent (FreeMonT (WithInv T)) (Reduction T).
Proof.
    intros a b c Hab Hbc. pose (reduction_strongly_confluent' T a b c Hab Hbc) as prf.
    destruct prf.
    - left. assumption.
    - right. right. right. assumption.
Qed.


(** * lsyntax: syntactic model for flat structures (lattice operations) *)

Require Export positives.
Require Import comparisons lattice lset sups.
Set Implicit Arguments.

(** * Free syntactic model *)

Section s.
Variable A: Set.
(* [A = ord n] in KAT proofs
   [A = positive] in reification, (and possibly in computations in the future) *)

(** Boolean lattice expressions over a set [A] of variables *)
Inductive expr :=
| e_bot
| e_top
| e_cup (e f: expr)
| e_cap (e f: expr)
| e_neg (e: expr)
| e_var (a: A).

(** level of an expression: the set of operations that appear in that expression *)
Fixpoint e_level e :=
  match e with
    | e_bot => BOT
    | e_top => TOP
    | e_cup x y => CUP + e_level x + e_level y
    | e_cap x y => CAP + e_level x + e_level y
    | e_neg x => BL + e_level x
      (* negation is ill-defined without the other Boolean operations,
         whence the [BL] rather than [NEG] *)
    | e_var _ => MIN
  end%level.

Section e.
Context {X: ops}.
Variable f: A -> X.

(** interpretation of an expression into an arbitray Boolean lattice
   structure, given an assignation [f] of the variables *)
Fixpoint eval e: X :=
  match e with
    | e_bot => bot
    | e_top => top
    | e_cup x y => eval x ⊔ eval y
    | e_cap x y => eval x ⊓ eval y
    | e_neg x => ! eval x
    | e_var a => f a
  end.
End e.

Section l.
Variable l: level.

(** * (In)equality of syntactic expressions.

   Rather than defining (in)equality of syntactic expressions as
   inductive predicates, we exploit the standard impredicative
   encoding of such predicates: two expressions are equal (resp.,
   lower or equal) iff they are equal (resp., lower or equal) under
   any interpretation.

   These definitions are parametrised by the level [l] at which one
   wants to interpret the expressions: this allows us to capture once
   and for all the equational theories of each flat structure. *)

Definition e_leq (x y: expr) := forall X (L: laws l X) (f: A -> X), eval f x ≦ eval f y.
Definition e_weq (x y: expr) := forall X (L: laws l X) (f: A -> X), eval f x ≡ eval f y.

(** by packing syntactic expressions and the above predicates into a
   canonical structure, we get all notations for free *)
Canonical Structure expr_ops := {|
  car := expr;
  leq := e_leq;
  weq := e_weq;
  cup := e_cup;
  cap := e_cap;
  neg := e_neg;
  bot := e_bot;
  top := e_top
|}.

(** we easily show that we get a model so that we immediately benefit
   from all lemmas about flat structures *)

Global Instance expr_laws: laws l expr_ops.
Proof.
  constructor; try right. constructor.
   intros x X L f. reflexivity.
   intros x y z H H' X L f. transitivity (eval f y); auto.
   intros x y. split.
    intro H. split; intros X L f. now apply weq_leq, H. now apply weq_geq, H.
    intros [H H'] X L f. apply antisym; auto.
   intros Hl x y z. split.
    intro H. split; intros X L f; specialize (H X L f); simpl in H; hlattice.
    intros [H H'] X L f. simpl. apply cup_spec; auto.
   intros Hl x y z. split.
    intro H. split; intros X L f; specialize (H X L f); simpl in H; hlattice.
    intros [H H'] X L f. simpl. apply cap_spec; auto.
   intros x X L f. apply leq_bx.
   intros x X L f. apply leq_xt.
   intros Hl x y z X L f. apply cupcap_.
   intros Hl x X L f. apply capneg.
   intros Hl x X L f. apply cupneg.
Qed.

(** the interpretation function is an homomorphism, so that it
   preserves all finite sups and infs *)
Lemma eval_sup I (J: list I) (f: I -> expr) (X: lattice.ops) (g: A -> X):
  eval g (sup (X:=expr_ops) f J) = \sup_(i\in J) eval g (f i).
Proof. apply f_sup_eq; now f_equal. Qed.

Lemma eval_inf I (J: list I) (f: I -> expr) (X: lattice.ops) (g: A -> X):
  eval g (sup (X:=dual expr_ops) f J) = \inf_(i\in J) eval g (f i).
Proof. apply (f_sup_eq (Y:=dual X)); now f_equal. Qed.

(** [e_var] is a unit for the underlying monad *)
Lemma eval_var (e: expr_ops): eval e_var e = e.
Proof. induction e; simpl; congruence. Qed.

End l.

End s.
Arguments e_var [A] a.
Arguments e_bot {A}.
Arguments e_top {A}.

Declare Scope last_scope.
Bind Scope last_scope with expr.
Delimit Scope last_scope with last.

(** additional notations, to specify explicitly at which level
   expressions are considered, or to work directly with the
   bare constructors (by opposition with the encapsulated ones,
   through lattice.ops)*)
Notation expr_ l := (car (expr_ops _ l)).
Notation "x <==_[ l ] y" := (@leq (expr_ops _ l) x%last y%last) (at level 79): ra_scope.
Notation "x ==_[ l ] y" := (@weq (expr_ops _ l) x%last y%last) (at level 79): ra_scope.

Infix "⊔" := e_cup: last_scope.
Infix "⊓" := e_cap: last_scope.
Notation "! x"  := (e_neg x): last_scope.

(** * Comparing expressions *)

(** we get a [cmpType] on expressions if the set of variable is such
   (currently used in ugregex_dec) *)

Section expr_cmp.
Context {A: cmpType}.
Fixpoint expr_compare (x y: expr A) :=
  match x,y with
    | e_bot, e_bot
    | e_top, e_top => Eq
    | e_var a, e_var b => cmp a b
    | e_cup x x', e_cup y y'
    | e_cap x x', e_cap y y' => lex (expr_compare x y) (expr_compare x' y')
    | e_neg x, e_neg y => expr_compare x y
    | e_bot, _      => Lt
    | _, e_bot      => Gt
    | e_top, _      => Lt
    | _, e_top      => Gt
    | e_var _, _    => Lt
    | _, e_var _    => Gt
    | e_cup _ _, _  => Lt
    | _, e_cup _ _  => Gt
    | e_cap _ _, _  => Lt
    | _, e_cap _ _  => Gt
  end.

Lemma expr_compare_spec: forall x y, compare_spec (x=y) (expr_compare x y).
Proof.
  induction x; destruct y; try (constructor; congruence).
  - eapply lex_spec; eauto. intuition congruence.
  - eapply lex_spec; eauto. intuition congruence.
  - simpl; case IHx; constructor; congruence.
  - simpl; case cmp_spec; constructor; congruence.
Qed.

Canonical Structure cmp_expr := mk_simple_cmp _ expr_compare_spec.

(** variables appearing in an expression ([A] needs to be a [cmpType]
   so that the resulting list is without duplicates) *)
Fixpoint vars (e: expr A): list A :=
  match e with
    | e_bot
    | e_top => []
    | e_cup x y
    | e_cap x y => union (vars x) (vars y)
    | e_neg x => vars x
    | e_var x => [x]
  end.
End expr_cmp.