From Coq Require Import Arith Lia.
From Equations Require Import Equations.  (* tactic depelim *)
Ltac refl := reflexivity.
Notation "'Sigma' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'Sigma'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.
Notation pi1 := projT1.
Notation pi2 := projT2.
Definition size_rec {X: Type} (sigma: X -> nat) {p: X -> Type} :
  (forall x, (forall y, sigma y < sigma x -> p y) -> p x) ->
  (forall x, p x).
Proof.
  intros F.
  enough (forall n x, sigma x < n -> p x) as H.
  { intros x. apply (H (S (sigma x))). lia. }
  induction n as [|n IH]; intros x H.
  - exfalso. lia.
  - apply F. intros y H1. apply IH. lia.
Defined.
Definition size_rec2 {X Y: Type} (sigma: X -> Y -> nat) {p: X -> Y -> Type} :
  (forall x y, (forall x' y', sigma x' y' < sigma x y -> p x' y') -> p x y) ->
  (forall x y, p x y).
Proof.
  intros F.
  enough (forall '(x,y), p x y) as H.
  { intros x y. apply (H (x,y)). }
  refine (size_rec (fun '(x,y) => sigma x y) (fun '(x,y) IH => _)). cbn in IH.
  apply F. intros x' y' H. apply (IH (x',y')), H.
Defined.

(*** Preliminaries *)

Implicit Types
         (x y z: nat)
         (f: nat -> nat -> nat)
         (p: nat -> nat -> nat -> Prop).

Definition functional p :=
  forall x y z z', p x y z -> p x y z' -> z = z'.

Definition total p :=
  forall x y, exists z, p x y z.

Definition sub p p' :=
  forall x y z, p x y z -> p' x y z.

Definition agreep p p' :=
  sub p p' /\ sub p' p.

Definition agreef f f' :=
  forall x y, f x y = f' x y.

Definition respects f p :=
  forall x y, p x y (f x y).

Definition agree f p :=
  forall x y z, p x y z <-> f x y = z.

Fact sub_fun_fun p p' :
  sub p p' -> functional p' -> functional p.
Proof.
  intros H1 H2. hnf. intros * H3 H4.
  eapply H2; apply H1; eassumption.
Qed.

Fact agreep_sym p p' :
  agreep p p' -> agreep p' p.
Proof.
  firstorder.
Qed.

Fact agreep_trans p1 p2 p3 :
  agreep p1 p2 -> agreep p2 p3 -> agreep p1 p3.
Proof.
  firstorder.
Qed.

Fact total_fun_agree p p' :
  total p -> functional p' -> sub p p' -> agreep p p'.
Proof.
  intros H1 H2 H3. split. exact H3.
  intros x y z H4.
  specialize (H1 x y) as [z' H1].
  enough (z = z') as -> by auto.
  apply H3 in H1. eapply H2; eassumption.
Qed.

Fact fun_respects_agree f p :
  functional p -> respects f p -> agree f p.
Proof.
  intros H1 H2 x y z. split.
  - specialize (H2 x y). specialize (H1 x y (f x y) z). auto.
  - intros <-. apply H2.
Qed.

(*** GCD predicates *)

Definition gcd_pred p : Prop :=
  (forall y, p 0 y y) /\
  (forall x y z, p x y z -> p y x z) /\
  (forall x y z, x <= y ->  p x (y - x) z -> p x y z).

Definition gcd_rec (p: nat -> nat -> Type) :
  (forall y, p 0 y) ->
  (forall x y, p y x -> p x y) ->
  (forall x y, x <= y -> p x (y - x) -> p x y) ->
  forall x y, p x y.
Proof.
  intros e1 e2 e3.
  apply (size_rec2 (fun x y => x + y)).
  intros x y IH.
  destruct x.
  - apply e1.
  - destruct y.
    + apply e2,e1.
    + destruct (le_lt_dec x y) as [H|H].
      * apply e3. lia. apply IH. lia.
      * apply e2,e3. lia. apply IH. lia.
Qed.

Fact gcd_pred_total p :
  gcd_pred p -> forall x y, Sigma z, p x y z.
Proof.
  intros (H11&H12&H13).
  apply gcd_rec.
  - intros y. exists y. apply H11.
  - intros x y [z IH]. exists z. apply H12, IH.
  - intros x y H [z IH]. exists z. apply H13. exact H. exact IH.
Qed.

Inductive G : nat -> nat -> nat -> Prop :=
| G1 y : G 0 y y
| G2 x y z: G x y z -> G y x z
| G3 x y z : x <= y -> G x (y - x) z -> G x y z.

Fact G_gcd_pred :
  gcd_pred G.
Proof.
  repeat split. exact G1. exact G2. exact G3.
Qed.

Fact G_sub p  :
  gcd_pred p -> sub G p.
Proof.
  intros (H1&H2&H3). hnf.
  induction 1 as [y|x y z _ IH|x y z H _ IH].
  - apply H1.
  - apply H2, IH.
  - apply H3; easy.
Qed.

Fact fun_gcd_pred_agree_G p :
  gcd_pred p -> functional p -> agreep p G.
Proof.
  intros H1 H2.
  apply agreep_sym,total_fun_agree.
  - intros x y.
    edestruct gcd_pred_total as [z H3].
    + exact G_gcd_pred.
    + exists z. exact H3.
  - exact H2.
  - apply G_sub, H1.
Qed.

Fact gcd_pred_fun :
  Sigma f, forall p, gcd_pred p -> respects f p.
Proof.
  exists (fun x y => pi1 (gcd_pred_total G G_gcd_pred x y)).
  intros p H x y. destruct gcd_pred_total as [z H1]. cbn.
  apply G_sub; easy.
Qed.

Fact gcd_pred_fun_agree :
  Sigma f, forall p, gcd_pred p -> functional p -> agree f p.
Proof.
  destruct gcd_pred_fun as [f H0]. exists f.
  intros p H1 H2. apply fun_respects_agree. exact H2.
  apply H0, H1.
Qed.

(*** Arithmetic GCD Predicate *)

Definition divides n x : Prop
  := exists k, x = k * n.

Definition gamma x y z : Prop :=
  forall n, divides n z <-> divides n x /\ divides n y.

Fact divides_zero n :
  divides n 0.
Proof.
  exists 0. refl.
Qed.

Fact divides_minus x y n :
  x <= y -> divides n x -> divides n y <->  divides n (y - x).
Proof.
  intros H [k ->]. split.
  - intros [l ->]. exists (l-k). nia.
  - intros [l H1]. exists (k + l). nia.
Qed.

Fact gamma_gcd_pred :
  gcd_pred gamma.
Proof.
  hnf. split. 2:split.
  - intros y n. generalize (divides_zero n). tauto.
  - intros x y z. unfold gamma. firstorder.
  - intros x y z H H1 n.
    specialize (H1 n).
    generalize (divides_minus _ _ n H).
    tauto.
Qed.

Fact divides_bnd n x :
  x > 0 -> divides n x -> n <= x.
Proof.
  intros H [k ->]. destruct k.
  - exfalso. lia.
  - nia.
Qed.

Fact divides_eq' x y :
  x > 0 -> y > 0 -> divides x y -> divides y x -> x = y.
Proof.
  intros H1 H2 H3%divides_bnd H4%divides_bnd; lia.
Qed.

Fact divides_eq x y :
  (forall n, divides n x <-> divides n y) -> x = y.
Proof.
  destruct x, y; intros H.
  - refl.
  - exfalso.
    enough (S(S y) <= S y) by lia.
    apply divides_bnd. lia.
    apply H, divides_zero.
  - exfalso.
    enough (S(S x) <= S x) by lia.
    apply divides_bnd. lia.
    apply H, divides_zero.
  - apply divides_eq'. lia. lia.
    + apply H. exists 1. lia.
    + apply H. exists 1. lia.
Qed.

Fact gamma_fun :
  functional gamma.
Proof.
  hnf. intros * H H'.
  apply divides_eq. intros n. split.
  - intros H1. apply H',H,H1.
  - intros H1. apply H,H',H1.
Qed.

(*** Deterministic GCD Predicate *)

Inductive G': nat -> nat -> nat -> Prop :=
| G'1: forall y, G' 0 y y
| G'2: forall x, G' (S x) 0 (S x)
| G'3: forall x y z, x <= y -> G' (S x) (y - x) z -> G' (S x) (S y) z
| G'4: forall x y z, y < x -> G' (x - y) (S y) z -> G' (S x) (S y) z.

Fact G'_fun :
  functional G'.
Proof.
  hnf. induction 1 as  [y|x|x y z H _ IH|x y z H _ IH]; intros H1.
  - depelim H1. refl.
  - depelim H1. refl.
  - depelim H1. auto. exfalso; lia.
  - depelim H1. exfalso; lia. auto.
Qed.

Fact G'_comm x y z :
  G' x y z -> G' y x z.
Proof.
  induction 1 as [y|x|x y z H _ IH|x y z H _ IH].
  - destruct y; constructor.
  - constructor.
  - assert (x < y \/ x = y) as [H1|<-] by lia.
    + apply G'4; easy.
    + replace (x-x) with 0 in IH by lia.
      depelim IH.
      apply G'3. lia.
      replace (x-x) with 0 by lia. constructor.
  - apply G'3. 2:exact IH. lia.
Qed.

Fact G'_sub x y z :
  x <= y -> G' x (y - x) z -> G' x y z.
Proof.
  intros H.
  destruct x.
  - replace (y - 0) with y by lia. easy.
  - destruct y.
    + exfalso; lia.
    + intros H1. apply G'3. lia. exact H1.
Qed.

Fact G'_gcd_pred :
  gcd_pred G'.
Proof.
  repeat split.
  - exact G'1.
  - exact G'_comm.
  - exact G'_sub.
Qed.

Fact G_fun :
  functional G.
Proof.
  eapply sub_fun_fun. 2:apply G'_fun.
  apply G_sub, G'_gcd_pred.
Qed.

(*** GCD Functions *)

Definition gcd_fun f : Prop :=
  (forall y, f 0 y = y) /\
  (forall x y, f x y = f y x) /\
  (forall x y, x <= y -> f x y = f x (y - x)).

Fact gcd_fun_respects f p :
  gcd_fun f -> gcd_pred p -> respects f p.
Proof.
  intros (H11&H12&H13) (H21&H22&H23).
  hnf. apply gcd_rec.
  - intros y. rewrite H11. apply H21.
  - intros x y. rewrite H12. apply H22.
  - intros x y H IH. rewrite H13. 2:exact H. apply H23. exact H. exact IH.
Qed.

Fact gcd_fun_if f p :
  functional p -> gcd_pred p -> respects f p -> gcd_fun f.
Proof.
  intros H1 (H21&H22&H23) H3. repeat split.
  - intros y. eapply H1. apply H3. apply H21.
  - intros x y. eapply H1. apply H3. apply H22. apply H3.
  - intros x y H. eapply H1. apply H3. apply H23. exact H. apply H3.
Qed.

Fact gcd_fun_ex :
  Sigma f, gcd_fun f.
Proof.
  destruct gcd_pred_fun as [f H]. exists f.
  eapply gcd_fun_if.
  - apply G'_fun.
  - apply G'_gcd_pred.
  - apply H, G'_gcd_pred.
Qed.

Fact gcd_fun_agreef f f' :
  gcd_fun f -> gcd_fun f' -> agreef f f'.
Proof.
  intros (H11&H12&H13) (H21&H22&H23).
  hnf. apply gcd_rec.
  - intros y. rewrite H11, H21. refl.
  - intros x y H. rewrite H12, H22. exact H.
  - intros x y H H1. rewrite H13, H23; assumption.
Qed.

(*** Procedural Specification *)

Definition Gamma f x y :=
  match x, y with
  | 0, y => y
  | S x, 0 => S x
  | (S x), (S y) => if le_lt_dec x y then f (S x) (y - x) else f (x - y) (S y)
  end.

Definition Gamma_sat f := forall x y, f x y = Gamma f x y.

Goal forall f, Gamma_sat f <->
          (forall y, f 0 y = y) /\
          (forall x, f (S x) 0 = S x) /\
          (forall x y, f (S x) (S y) = if le_lt_dec x y then f (S x) (y - x)
                                  else f (x - y) (S y)).
Proof.
  intros f. split.
  - intros F. repeat split; intros; rewrite F; refl.
  - intros E x y.
    destruct x. easy.
    destruct y; cbn; easy.
Qed.

Fact Gamma_com f :
  Gamma_sat f -> forall x y, f x y = f y x.
Proof.
  intros F.
  refine (size_rec2 (fun x y => x + y) _).
  intros x y IH. rewrite !F.
  destruct x,y; cbn. 1-3:refl.
  destruct le_lt_dec as [H|H];
    destruct le_lt_dec as [H'|H'].
  - assert (x = y) as <- by lia. refl.
  - apply IH; lia.
  - apply IH; lia.
  - exfalso; lia.
Qed.

Fact Gamma_gcd_fun f :
  Gamma_sat f <-> gcd_fun f.
Proof.
  split.
  - intros H. repeat split.
    + apply H.
    + apply Gamma_com, H.
    + intros x y H1. rewrite !H.
      destruct x.
      { cbn. lia. }
      destruct y.
      { refl. }
      unfold Gamma at 1.
      destruct le_lt_dec as [H2|H2].
      2:{ exfalso. lia. }
      apply H.
  - intros (E1&E2&E3) x y.
    destruct x.
    { apply E1. }
    destruct y; cbn.
    { rewrite E2. apply E1. }
    destruct le_lt_dec as [H1|H1].
    + rewrite E3 by lia. refl.
    + rewrite E2. rewrite E3 by lia. apply E2.
Qed.

Fact Gamma_unique f g :
  Gamma_sat f -> Gamma_sat g -> agreef f g.
Proof.
  intros F G.
  refine (size_rec2 (fun x y => x + y) _).
  intros x y IH. rewrite F, G.
  destruct x as [|x]. refl.
  destruct y as [|y]. refl.
  cbn. destruct le_lt_dec as [H|H]; apply IH; lia.
Qed.

(** Step-indexed Construction *)

Fixpoint g n x y :=
  match n, x, y with
  | 0, _, _ => 0
  | S _, 0, y' => y'
  | S _, S x' , 0 => S x'
  | S n', S x' , S y' => if le_lt_dec x' y'
                        then g n' x (y' - x')
                        else g n' (x' - y') y
  end.

Definition gcd x y := g (S (x + y)) x y.

Compute gcd 12 16.

Fact g_index_eq n n' x y :
  n > x + y -> n' >  x + y -> g n x y = g n' x y.
Proof.
  revert x y n n'.
  refine (size_rec2 (fun x y => x + y) _).
  intros x y IH n n' H1 H2.
  destruct n. lia.
  destruct n'. lia.
  destruct x. refl.
  destruct y. refl.
  cbn [g].
  destruct le_lt_dec; apply IH; lia.
Qed.

Fact gcd3 x y :
  gcd (S x) (S y) = if le_lt_dec x y
                    then gcd (S x) (y - x)
                    else gcd (x - y) (S y).
Proof.
  unfold gcd at 1. cbn [g].
  destruct le_lt_dec as [H|H];
    apply g_index_eq; lia.
Qed.

Fact Gamma_sat_gcd :
  Gamma_sat gcd.
Proof.
  intros [|x] y. refl.
  destruct y as [|y]. refl.
  cbn [Gamma]. apply gcd3.
Qed.

Fact gcd_gcd_fun :
  gcd_fun gcd.
Proof.
  apply Gamma_gcd_fun, Gamma_sat_gcd.
Qed.


From Undecidability.L Require Export Datatypes.LNat Datatypes.LBool Tactics.LTactics Computability.Computability Tactics.Lbeta.

Section MuRecursor.

Variable P : term.
Hypothesis P_proc : proc P.
Hint Resolve P_proc : LProc.

Hypothesis dec'_P : forall (n:nat), (exists (b:bool), app P (ext n) == ext b ).

Lemma dec_P : forall n:nat, {b:bool | app P (ext n) == ext b}.
  intros. eapply lcomp_comp.
  -apply bool_enc_inv_correct.
  -apply dec'_P.
Qed.

Section hoas.
  Import HOAS_Notations.
  Definition mu' := Eval cbn -[enc] in rho (λ mu P n, (P n) (!!K n) (λ Sn, mu P Sn) (!!(ext S) n)).
End hoas.

Import L_Notations.

Lemma mu'_proc : proc mu'.
  unfold mu'; Lproc.
Qed.

Hint Resolve mu'_proc : LProc.

Lemma mu'_n_false n: P (ext n)  == ext false -> mu' P (ext n) >* mu' P (ext (S n)).
Proof.
  intros R. apply equiv_lambda in R;[|Lproc]. recStep mu'. unfold K. Lsimpl.
Qed.

Lemma mu'_0_false n: (forall n', n' < n -> P (ext n')  == ext false) -> mu' P (ext 0) >* mu' P (ext n).
Proof.
  intros H. induction n.
  -reflexivity.
  -rewrite IHn.
   +apply mu'_n_false. apply H. lia.
   +intros. apply H. lia.
Qed.

Lemma mu'_n_true (n:nat): P (ext n)  == ext true -> mu' P (ext n) == ext n.
Proof.
  intros R. recStep mu'. Lsimpl. rewrite R. unfold K.  Lsimpl.
Qed.

(* TODO: mu' sound*)
Lemma mu'_sound v n: proc v -> mu' P (ext (n:nat)) == v ->
                     (forall n', n' < n -> P (ext n') == ext false) ->
                     exists n0, n0 >= n /\ P (ext n0) == ext true /\ v == ext n0
                                /\ forall n', n' < n0 -> P (ext (n':nat)) == ext false.
Proof.
  intros pv. intros R. apply equiv_lambda in R;try Lproc. apply star_pow in R. destruct R as [k R]. revert n R. apply complete_induction with (x:=k);clear k;intros k. intros IH n R H.
  specialize (dec_P n).
  destruct (dec_P n) as [[] eq].
  -exists n;intuition. apply pow_star in R. apply star_equiv in R. rewrite <- R. now rewrite mu'_n_true.
  -assert (R':=mu'_n_false eq). apply star_pow in R'. destruct R' as [k' R'].
   destruct (parametrized_confluence uniform_confluence R R') as [x [l [u [le1 [le2 [R1 [R2 eq']]]]]]]. destruct x.
   +inv R1. apply IH in R2 as [n0 [ge1 [Rn0 [eq0 H0]]]].
    *exists n0. repeat split;try assumption;lia.
    *decide (l=k);[|lia]. subst l. assert (k'=0) by lia. subst k'. inv R'. apply inj_enc in H1. lia.
    *intros. decide (n'=n). subst. tauto.  apply H. lia.
   +destruct R1 as [? [C _]]. destruct pv as [_ [v']]. subst v. inv C.
Qed.

Lemma mu'_complete n0 : P (ext n0) == ext true
                        -> (forall n', n' < n0 -> P (ext n') == ext false)
                        -> mu' P (ext 0) == ext n0.
Proof.
  intros. rewrite mu'_0_false with (n:=n0);try tauto.
  -recStep mu'. Lsimpl. rewrite H. unfold K. Lsimpl.
Qed.

(* the mu combinator:*)

Definition mu :term := lam (mu' #0 (ext 0)).

Lemma mu_proc : proc mu.
  unfold mu. Lproc.
Qed.

Hint Resolve mu_proc : LProc.

Lemma mu_sound v : lambda v -> mu P == v -> exists n, v = ext n /\ P (ext n) == ext true /\ (forall n', n' < n -> P (ext n') == ext false).
Proof.
  unfold mu. intros lv R. standardizeHypo 100. apply mu'_sound in R.
  -destruct R as [n ?]. exists n. intuition. apply unique_normal_forms;try Lproc. assumption.
  -split;[|Lproc]. apply equiv_lambda in R;auto. apply closed_star in R;Lproc.
  -intros. lia.
Qed.

Lemma mu_complete (n:nat) : P (ext n) == ext true -> exists n0:nat, mu P == ext n0.
Proof.
  remember 0 as n0.
  assert (forall n':nat, n'< n-(n-n0) -> P (ext n') == ext false) by (intros;lia).
  assert ((n-n0)+n0=n) by lia. remember (n-n0) as k. clear Heqk Heqn0 H0 n0. induction k.
  -simpl in *. subst. intros. eexists. unfold mu. Lsimpl. apply mu'_complete;eauto. intros. apply H. lia.
  -intros. destruct (dec_P (n-S k)) as [y P'].
   destruct y.
   +eexists. unfold mu. Lsimpl. apply mu'_complete. exact P'. exact H.
   +apply IHk. intros. decide (n' = n - (S k)).
     *subst. exact P'.
     *apply H. lia.
     *assumption.
Qed.

Lemma mu_spec : converges (mu P) <-> exists n : nat, P (ext n) == ext true.
Proof.
  split.
  - intros (? & ? & ?). eapply mu_sound in H as (? & ? & ? & ?); eauto.
  - intros []. eapply mu_complete in H as []. exists (ext x0). split. eauto. eapply proc_ext.
Qed.

End MuRecursor.

Hint Resolve mu'_proc : LProc.
Hint Resolve mu_proc : LProc.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Import GRing.Theory Num.Def Num.Theory.

Require Import games potential.

Section AtomicRoutingGame.
  Variable T : finType. (** The type of nodes *)
  Variable num_players : nat. (** The number of players *)

  (** We represent graphs by their adjacency matrices *)
  Variable g : 'M[bool]_(#|T|, #|T|).

  Variable rty : realFieldType.
  (** Edge costs are modeled by a function mapping
        - node i  : #|T|    The source node for this edge
        - node j  : #|T|    The target node for this edge
        - traffic : nat     The amount of traffic over this edge
      to a real number type [rty]. *)
  Variable ecosts : forall x y : 'I_#|T|, nat -> rty.
  Hypothesis ecosts_pos : forall x y n, (0 <= ecosts x y n)%R.

  (** Players are pairs of source-sink vertices. *)
  Record player : Type :=
    mkPlayer {
        source : 'I_#|T|;
        sink : 'I_#|T|
      }.
  Variable players : 'I_num_players -> player.

  Definition path := ('I_#|T| ^ #|T|)%type.

  (** A path [p] is a source-sink path from [x] to [y] if either
      - p x = y AND x->y is admitted by [g], or
      - exists z, p x = z AND x->z is admitted by [g] AND
                  p is a source-sink path from z to y *)
   Inductive sspath : 'I_#|T| -> 'I_#|T| -> path -> Prop :=
   | sspath_refl (p : path) x : g x (p x) -> sspath x (p x) p
   | sspath_cons (p : path) x y :
       g x (p x) ->
       sspath (p x) y p ->
       sspath x y p.

  Fixpoint sspath_rec n (x y : 'I_#|T|) : pred path :=
    [pred p : path |
     [|| [&& p x == y & g x (p x)]
       | [&& g x (p x) & if n is n'.+1 then sspath_rec n' (p x) y p
                              else false]]].

  (** We should prove [sspath_pred] equivalent to [sspath] under the assumption
      that all paths are cycle-free (they can have length no greater than
      the number of nodes in the graph, #|T|. *)
  Definition sspath_pred (x y : 'I_#|T|) := sspath_rec #|T| x y.

  Notation src i := (source (players i)).
  Notation snk i := (sink (players i)).

  (** We explode the [strategy] type to a get free [eqType] and [finType] instances. *)
  Definition strategy (i : 'I_num_players) :=
    sig (fun the_path => sspath_pred (src i) (snk i) the_path).
  Definition mkStrategy
             (i : 'I_num_players)
             (the_path : path)
             (path_valid : sspath_pred (src i) (snk i) the_path) : strategy i :=
    exist (fun the_path => sspath_pred (src i) (snk i) the_path) the_path path_valid.
  Definition the_path (i : 'I_num_players) (s : strategy i) : path := projT1 s.
  Definition path_valid (i : 'I_num_players) (s : strategy i) := projT2 s.

  (** A state maps players to strategies, or more precisely, dependent
      pairs of a player number and indexed strategy.

      TODO: A better representation is the dependent finite functions
      from player number to indexed strategy, but ssreflect doesn't
      contain such a library. *)
  Definition strategy_pkg := {: {i : 'I_num_players & strategy i}}.
  Notation st := ((strategy_pkg ^ num_players)%type).

  Definition path_of (s : st) (i : 'I_num_players) : path :=
    the_path (projT2 (s i)).

  Definition edgeOfPlayer i (s : st) (x y : 'I_#|T|) :=
    path_of s i x == y.

  Definition edgePlayers (s : st) (x y : 'I_#|T|) : pred 'I_num_players :=
    [pred i | edgeOfPlayer i s x y].

  (** The traffic (in number of players) over edge [x],[y] *)
  Definition traffic_edge (s : st) (x y : 'I_#|T|) : nat :=
    #|edgePlayers s x y|.

  (** The cost, in st [s], of a particular edge [x],[y]. *)
  Definition cost_edge (s : st) (x y : 'I_#|T|) :=
    ecosts x y (traffic_edge s x y).

  Local Open Scope ring_scope.

  Definition costFun (i : 'I_num_players) (s : st) : rty :=
    \sum_(x : 'I_#|T|)
    \sum_(y : 'I_#|T|)
    if edgeOfPlayer i s x y then cost_edge s x y else 0.

  Instance costInstance
    : CostClass num_players rty [finType of strategy_pkg]
    := costFun.

  Program Instance costAxiomInstance
    : CostAxiomClass costInstance.
  Next Obligation.
    rewrite /(cost) /costInstance /costFun.
    apply big_ind => //. apply addr_ge0.
    move => i0 _. apply big_ind => //.
    apply addr_ge0. move => i' _.
    case: (edgeOfPlayer i f i0 i') => //.
    rewrite /cost_edge => //.
  Qed.

  Definition movesFun (i : 'I_num_players) : rel strategy_pkg :=
    [fun p p' : strategy_pkg => projT1 p == projT1 p'].

  Instance movesInstance
    : MovesClass num_players [finType of strategy_pkg]
    := movesFun.

  Instance gameInstance : game costAxiomInstance movesInstance := {}.

  Definition phiFun (s : st) : rty :=
    \sum_(x : 'I_#|T|)
    \sum_(y : 'I_#|T|)
    \sum_(1 <= i < (traffic_edge s x y).+1)
    ecosts x y i.

  Instance phiInstance : PhiClass costAxiomInstance movesInstance := phiFun.

  (** Lift a unilateral move to a state update *)
  Definition Move (i : 'I_num_players) : rel st :=
    [fun t t' : st =>
       [&& moves i (t i) (t' i)
         & [forall j : 'I_num_players, (i != j) ==> (t j == t' j)]]].

  Lemma traffic11 (i : 'I_num_players) (x y : 'I_#|T|) t t' :
    Move i t t' ->
    edgeOfPlayer i t' x y ->
    edgeOfPlayer i t x y ->
    traffic_edge t' x y = traffic_edge t x y.
  Proof.
    rewrite /Move /edgeOfPlayer /=; case /andP=> Hx; move/forallP=> /= H H2 H3.
    rewrite /traffic_edge /edgePlayers /edgeOfPlayer.
    f_equal.
    rewrite /mem /=.
    f_equal.
    extensionality i0.
    case H4: (i == i0); first by move: (eqP H4)=> <-; rewrite H2 H3.
    have H5: i != i0.
    { apply/negP; move/eqP=> H5; rewrite H5 in H4.
      case: (@eqP _ i0 i0) H4=> //.
    }
    have H6: path_of t i0 = path_of t' i0.
    { move: (eqP ((implyP (H i0)) H5)).
      by rewrite /path_of=> ->.
    }
    by rewrite -H6.
  Qed.

  Lemma traffic00 (i : 'I_num_players) (x y : 'I_#|T|) t t' :
    Move i t t' ->
    edgeOfPlayer i t' x y = false ->
    edgeOfPlayer i t x y = false ->
    traffic_edge t' x y = traffic_edge t x y.
  Proof.
    rewrite /Move /edgeOfPlayer /=; case /andP=> Hx; move/forallP=> /= H H2 H3.
    rewrite /traffic_edge /edgePlayers /edgeOfPlayer.
    f_equal.
    rewrite /mem /=.
    f_equal.
    extensionality i0.
    case H4: (i == i0); first by move: (eqP H4)=> <-; rewrite H2 H3.
    have H5: i != i0.
    { apply/negP; move/eqP=> H5; rewrite H5 in H4.
      case: (@eqP _ i0 i0) H4=> //.
    }
    have H6: path_of t i0 = path_of t' i0.
    { move: (eqP ((implyP (H i0)) H5)).
      by rewrite /path_of=> ->.
    }
    by rewrite -H6.
  Qed.

  Lemma traffic10 (i : 'I_num_players) (x y : 'I_#|T|) t t' :
    Move i t t' ->
    edgeOfPlayer i t' x y ->
    edgeOfPlayer i t x y = false ->
    traffic_edge t' x y = (traffic_edge t x y).+1.
  Proof.
    rewrite /Move /edgeOfPlayer /=; case /andP=> Hx; move/forallP=> /= H H2 H3.
    rewrite /traffic_edge.
    rewrite (cardD1x (j:=i))=> //.
    rewrite /addn /=.
    f_equal.
    rewrite /edgePlayers.
    apply: eq_card=> j.
    rewrite /in_mem /=.
    case H4: (j == i)=> /=.
    move: (eqP H4)=> ->.
    by rewrite /edgeOfPlayer H2 H3 andbC.
    have H5: (i != j).
    { by apply/negP=> H5; move: (eqP H5)=> H6; rewrite H6 eq_refl in H4.
    }
    move: (implyP (H j)); move/(_ H5)/eqP=> H6.
    rewrite /edgeOfPlayer /path_of H6.
    by rewrite andbC.
  Qed.

  Lemma traffic01 (i : 'I_num_players) (x y : 'I_#|T|) t t' :
    Move i t t' ->
    edgeOfPlayer i t' x y = false ->
    edgeOfPlayer i t x y ->
    (traffic_edge t' x y).+1 = traffic_edge t x y.
  Proof.
    rewrite /Move /edgeOfPlayer /=; case /andP=> Hx; move/forallP=> /= H H2 H3.
    rewrite /traffic_edge.
    symmetry.
    rewrite (cardD1x (j:=i))=> //.
    rewrite /addn /=.
    f_equal.
    rewrite /edgePlayers.
    apply: eq_card=> j.
    rewrite /in_mem /=.
    case H4: (j == i)=> /=.
    move: (eqP H4)=> ->.
    by rewrite /edgeOfPlayer H2 H3 andbC.
    have H5: (i != j).
    { by apply/negP=> H5; move: (eqP H5)=> H6; rewrite H6 eq_refl in H4.
    }
    move: (implyP (H j)); move/(_ H5)/eqP=> H6.
    rewrite /edgeOfPlayer /path_of H6.
    by rewrite andbC.
  Qed.

  Lemma subr_xx (x : rty) : x - x = 0.
  Proof.
    suff: x - x == 0; first by move/eqP=> <-.
    by rewrite subr_eq0; apply/eqP.
  Qed.

  Lemma sum_add1 (f : nat -> rty) m (Hpos : (0 < m)%N) :
    \sum_(1 <= i < m.+1) f i - \sum_(1 <= i < m) f i = f m.
  Proof.
    rewrite big_nat_recl=> //.
    rewrite -addrA -sumrB telescope_sumr=> //.
    by rewrite addrA [f (S O) + _]addrC -addrA subr_xx addr0.
  Qed.

  Lemma sum_sub1 (f : nat -> rty) m (Hpos : (0 < m)%N) :
    \sum_(1 <= i < m) f i - \sum_(1 <= i < m.+1) f i = - f m.
  Proof.
    rewrite addrC.
    rewrite big_nat_recl=> //.
    rewrite opprD.
    rewrite -addrA.
    suff H: -f 1%N + -(-(\sum_(1 <= i < m) f i - \sum_(1 <= i < m) f i.+1)) = -f m.
    { rewrite opprK in H.
      by rewrite -H; f_equal; rewrite addrC.
    }
    rewrite -sumrB addrC raddf_sum /=.
    suff H: - (\sum_(1 <= i < m) (f i.+1 - f i)) - f 1%N = - f m.
    { rewrite -H.
      f_equal.
      f_equal.
      f_equal.
      extensionality i.
      f_equal.
      by rewrite opprB.
    }
    rewrite telescope_sumr=> //.
    by rewrite opprB addrC addrA [-f _ + _]addrC subr_xx sub0r.
  Qed.

  Lemma phi_exact' (i : 'I_num_players) (t t' : st) :
    Move i t t' ->
    Phi t' - Phi t = cost i t' - cost i t.
  Proof.
    move=> H.
    rewrite -!sumrB; simpl.
    f_equal.
    extensionality x.
    f_equal.
    rewrite -!sumrB.
    f_equal.
    extensionality y.
    f_equal.
    rewrite /cost_edge.
    case Ht': (edgeOfPlayer i t' x y); case Ht: (edgeOfPlayer i t x y).
    { (*true, true*)
      rewrite (traffic11 H Ht' Ht).
      rewrite -sumrB.
      rewrite subr_xx.
      rewrite sumrB.
      by rewrite subr_xx.
    }
    { (*true, false*)
      rewrite (traffic10 H Ht' Ht).
      move: (traffic_edge _ _ _)=> n.
      move Hecosts: (ecosts x y)=> f.
      move Hm: (n.+1)=> m.
      rewrite sum_add1.
      by rewrite subr0.
      by rewrite -Hm.
    }
    { (*false, true*)
      rewrite (traffic01 H Ht' Ht).
      case Hn: (traffic_edge _ _ _)=> [|n].
      { rewrite /traffic_edge in Hn.
        rewrite (cardD1x (j:=i)) in Hn=> //.
      }
      move Hecosts: (ecosts x y)=> f.
      rewrite sum_sub1=> //.
      by rewrite sub0r.
    }
    rewrite subr0.
    rewrite (traffic00 H Ht' Ht).
    by rewrite subr_xx.
  Qed.

  Lemma phi_exact (i : 'I_num_players) (t : st) t_i' :
    moves i (t i) t_i' ->
    let t' := upd i t t_i' in
    Phi t' - Phi t = cost i t' - cost i t.
  Proof.
    move => H t'; apply: phi_exact'.
    rewrite /t'; apply/andP; split.
    { rewrite /upd ffunE eq_refl; apply: H. }
    apply/forallP; rewrite /upd => j; apply/implyP.
    rewrite ffunE; case: (i == j) => //.
  Qed.

  Instance PhiAxiomInstance : PhiAxiomClass phiInstance := phi_exact.
  Instance AtomicPotentialInstance : Potential PhiAxiomInstance := {}.
End AtomicRoutingGame.


From mm Require Import util.
Set Implicit Arguments.

Module prop.
  Inductive t :=
  | under : t -> t -> t
(*
  | over : t -> t -> t
  | fuse : t -> t -> t
  | twist : t -> t -> t
  | ichoose : t -> t -> t
  | uchoose : t -> t -> t
*)
  | one : t
  .

  Fixpoint size (A : t) : nat :=
    match A with
    | one => 1
    | under A1 A2 => S (size A1 + size A2)
    end.
End prop.

Module expr.
    Inductive t :=
    | var : t
    | tt : t
    | lettt : t -> t
    | underabs : t -> t
    | underapp : t -> t -> t
    .

    Fixpoint size (e : t) : nat :=
      match e with
      | var => 1
      | tt => 1
      | lettt e' => S (size e')
      | underabs e' => S (size e')
      | underapp e1 e2 => S (size e1 + size e2)
      end.
End expr.

Module cf_sequent.
  (* cut-free sequent calculus with proof terms *)

  Inductive t : list prop.t -> expr.t -> prop.t -> Prop :=
  | id : forall A, t [A] expr.var A
  | under_R : forall Ω A B e,
      t (B :: Ω) e A ->
      t Ω (expr.underabs e) (prop.under B A)
  | under_L : forall Ω_L Ω' Ω_R A B C e1 e2,
      t Ω' e1 B ->
      t (Ω_L ++ A :: Ω_R) e2 C ->
      t (Ω_L ++ Ω' ++ prop.under B A :: Ω_R) (expr.underapp e1 e2) C

  | one_R : t [] expr.tt prop.one
  | one_L : forall Ω_L Ω_R e C,
      t (Ω_L ++ Ω_R) e C ->
      t (Ω_L ++ prop.one :: Ω_R) (expr.lettt e) C
  .

  Lemma cut_admissible' :
    forall n e1 e2 A Ω Ω_L Ω_R C,
      prop.size A + expr.size e1 + expr.size e2 < n ->
      t Ω e1 A ->
      t (Ω_L ++ A :: Ω_R) e2 C ->
      exists e, t (Ω_L ++ Ω ++ Ω_R) e C /\ expr.size e <= expr.size e1 + expr.size e2.
  Proof.
    induction n; intros e1 e2 A Ω Ω_L Ω_R C LT SA SC.
    - lia.
    - invc SC.
      + apply app_singleton_middle_inv in H0.
        invc H0.
        rewrite app_nil_r.
        exists e1. split. auto. lia.
      + rewrite app_comm_cons in H.
        eapply IHn with (e2 := e) (e1 := e1) in H; eauto.
        2: simpl in *; lia.
        destruct H as [e' [? ?]].
        eexists.
        split.
        econstructor.
        exact H.
        simpl in *. lia.
      + simpl in *.
        rewrite <- app_ass in H.
        apply app_middle_inv in H.
        destruct H as [[? ? ?]|[W [? ?]]|[W [? ?]]]; subst.
        * invc SA.
          -- eexists. split.
             rewrite app_ass.
             simpl.
             apply under_L; eauto.
             simpl in *. lia.
          -- simpl in *.
             eapply IHn with (e1 := e0) (e2 := e) (Ω_L := []) in H4; eauto.
             2: lia.
             destruct H4 as [e' [He' Size']].
             simpl in *.
             eapply IHn with (e2 := e3)(e1 := e') in H1; eauto.
             2: lia.
             destruct H1 as [e'' [He'' Size'']].
             rewrite app_ass in *.
             eexists. split. eauto.
             lia.
          -- simpl in *.
             eapply under_L with (A := A0) in H0; eauto.
             rewrite <- app_ass in H0.
             eapply IHn with (A := prop.under B A0) in H0; eauto.
             2: simpl in *; lia.
             destruct H0 as [? [??]].
             rewrite !app_ass in *.
             rewrite <- app_ass in H0.
             rewrite <- app_ass in H0.
             simpl in H0.
             eapply under_L with (B := B0) in H0; eauto.
             rewrite !app_ass in *.
             eexists.
             split.
             eauto.
             simpl in *. lia.
          -- eapply under_L with (B := B)(A := A0) in H1; eauto.
             rewrite <- app_ass in H1.
             eapply IHn in H1; [| |eassumption].
             2: simpl in*; lia.
             destruct H1 as [?[??]].
             eexists. split.
             rewrite !app_ass.
             rewrite <- app_ass.
             rewrite <- app_ass.
             simpl.
             apply one_L.
             rewrite !app_ass in *.
             eassumption.
             simpl in *. lia.
        * apply app_inv in H.
          destruct H as [[W' [? ?]]|[W' [? ?]]]; subst.
          -- apply app_cons_inv in H2.
             destruct H2 as [[? ?]|[W1 [? ?]]]; subst.
             ++ rewrite app_nil_r in *.
                eapply IHn with (A := A) (Ω_L := []) in H0; [| |eassumption].
                2: lia.
                destruct H0 as [e' [S' Size']].
                simpl in S'.
                eapply under_L with (A := A0) (B := B) in H1; eauto.
                rewrite !app_ass in *.
                eexists.
                split. eauto.
                simpl in *; lia.
             ++ rewrite !app_ass in *.
                simpl in *.
                eapply IHn with (A := A) in H1; eauto.
                2: lia.
                destruct H1 as [e' [S' Size']].
                rewrite <- app_ass in S'.
                rewrite <- app_ass in S'.
                eapply under_L with (B := B) in S'; eauto.
                rewrite !app_ass in *.
                eexists. split. eauto.
                simpl in *. lia.
          -- eapply IHn with (A := A) in H0; eauto.
             2: lia.
             destruct H0 as [e' [S' Size']].
             eapply under_L with (B := B) in H1; eauto.
             rewrite !app_ass in *.
             eexists. split. eauto.
             simpl in *. lia.
        * rewrite app_comm_cons' in H1.
          rewrite <- app_ass in H1.
          eapply IHn with (A := A) in H1; eauto.
          2: lia.
          destruct H1 as [e' [S' Size']].
          rewrite !app_ass in *.
          simpl in *.
          eapply under_L with (B := B) in S'; eauto.
          eexists. split. eauto.
          simpl in *. lia.
      + destruct Ω_L; discriminate.
      + apply app_middle_inv in H.
        destruct H as [[? ? ?]|[W [? ?]]|[W [? ?]]]; subst.
        * invc SA.
          -- eexists. split.
             apply one_L. eauto.
             simpl in *. lia.
          -- apply one_L in H0.
             eapply IHn with (A := prop.one) in H0; [| |eassumption].
             2: simpl in *; lia.
             destruct H0 as [e' [S' Size']].
             rewrite !app_ass in *.
             simpl in *.
             rewrite <- app_ass in S'.
             eapply under_L with (B := B) in S'; eauto.
             rewrite !app_ass in *.
             eexists. split. eauto.
             simpl in *. lia.
          -- eexists. split. eauto.
             simpl in *. lia.
          -- rewrite app_ass. simpl.
             rewrite <- app_ass.

             eapply IHn with (e1 := e0)(e2 := expr.lettt e) in H.
             3: apply one_L; eassumption.
             2: simpl in *; lia.

             destruct H as [e' [He' Size']].
             eexists. split.
             apply one_L.
             rewrite !app_ass in *.
             eauto.
             simpl in *. lia.
        * rewrite app_ass in *.
          simpl in *.
          eapply IHn with (e2 := e) (e1 := e1) in H0; eauto.
          2: lia.
          destruct H0 as [? [? ?]].
          eexists. split.
          rewrite <- app_ass.
          rewrite <- app_ass.
          apply one_L.
          rewrite !app_ass.
          eauto.
          simpl in *. lia.
        * rewrite <- app_ass in H0.
          eapply IHn with (e1 := e1) (e2 := e) in H0; eauto.
          2: simpl in *; lia.
          destruct H0 as [? [? ?]].
          eexists. split.
          rewrite !app_ass in *.
          simpl.
          apply one_L.
          eauto.
          simpl in *. lia.
  Qed.

  Theorem cut_admissible :
    forall A e2 Ω e1 Ω_L Ω_R C,
      t Ω e1 A ->
      t (Ω_L ++ A :: Ω_R) e2 C ->
      exists e, t (Ω_L ++ Ω ++ Ω_R) e C.
  Proof.
    intros A e2 Ω e1 Ω_L Ω_R C SA SC.
    eapply cut_admissible' in SC; eauto.
    destruct SC as [? [? _]].
    eauto.
  Qed.
  Print Assumptions cut_admissible.
End cf_sequent.

Module sequent.

  Inductive t : list prop.t -> prop.t -> Prop :=
  | id : forall A, t [A] A
  | under_R : forall Ω A B,
      t (B :: Ω) A ->
      t Ω (prop.under B A)
  | under_L : forall Ω_L Ω' Ω_R A B C,
      t Ω' B ->
      t (Ω_L ++ A :: Ω_R) C ->
      t (Ω_L ++ Ω' ++ prop.under B A :: Ω_R) C

  | one_R : t [] prop.one
  | one_L : forall Ω_L Ω_R C,
      t (Ω_L ++ Ω_R) C ->
      t (Ω_L ++ prop.one :: Ω_R) C

  | cut : forall Ω_L Ω Ω_R A B,
      t Ω A ->
      t (Ω_L ++ A :: Ω_R) B ->
      t (Ω_L ++ Ω ++ Ω_R) B
  .

  Theorem cut_elim :
    forall Ω A,
      t Ω A ->
      exists e, cf_sequent.t Ω e A.
  Proof.
    induction 1.
    - eexists. constructor.
    - destruct IHt. eexists. econstructor. eauto.
    - destruct IHt1, IHt2. eexists.
      econstructor; eauto.
    - eexists. constructor.
    - destruct IHt.
      eexists. econstructor. eauto.
    - destruct IHt1, IHt2.
      eapply cf_sequent.cut_admissible; eauto.
  Qed.
End sequent.


Require Import PeanoNat.
Require Import Lia.
Require Import RL.Utilities.lt_nat_tuples.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_solve.

Lemma Exists_inf_split A : forall P (l : list A),
    Exists_inf P l ->
    {' (a, la, lb) : _ &
                     prod (P a)
                          (l = la ++ a :: lb)}.
Proof.
  intros P l Hex; induction Hex.
  - split with (x , nil, l); repeat split; try assumption; try reflexivity.
  - destruct IHHex as [[[a la] lb] [Hp Heq]].
    split with (a , x :: la, lb); repeat split; try assumption; rewrite Heq; reflexivity.
Qed.

Lemma Forall_inf_Permutation_Type A : forall P (l l' : list A),
    Permutation_Type l l' ->
    Forall_inf P l ->
    Forall_inf P l'.
Proof.
  intros P l l' Hperm.
  induction Hperm; intros Hall.
  - apply Forall_inf_nil.
  - inversion Hall; subst.
    apply Forall_inf_cons ; [ apply X | ].
    apply IHHperm; apply X0.
  - inversion Hall; inversion X0; subst.
    apply Forall_inf_cons;  [ | apply Forall_inf_cons]; assumption.
  - apply IHHperm2.
    apply IHHperm1.
    apply Hall.
Qed.

Lemma Exists_inf_Permutation_Type A : forall P (l l' : list A),
    Permutation_Type l l' ->
    Exists_inf P l ->
    Exists_inf P l'.
Proof.
  intros P l l' Hperm.
  induction Hperm; intros Hex.
  - inversion Hex.
  - inversion Hex; subst.
    + apply Exists_inf_cons_hd; assumption.
    + apply Exists_inf_cons_tl; apply IHHperm; apply X.
  - inversion Hex;  [ | inversion X]; subst.
    + apply Exists_inf_cons_tl; apply Exists_inf_cons_hd; apply X.
    + apply Exists_inf_cons_hd; apply X0.
    + apply Exists_inf_cons_tl; apply Exists_inf_cons_tl; apply X0.
  - apply IHHperm2; apply IHHperm1; apply Hex.
Qed.

Lemma decomp_Permutation_Type_2 A : forall l l' (x y : A),
    Permutation_Type (x :: y :: l) l' ->
    {' (l1,l2,l3) : _ & {l' = l1 ++ x :: l2 ++ y :: l3} +
                        {l' = l1 ++ y :: l2 ++ x :: l3}}.
Proof.
  intros l l' x y Hperm.
  destruct (in_inf_split x l') as [[la lb] Heq].
  { apply Permutation_Type_in_inf with (x :: y :: l); [ apply Hperm | ].
    left; reflexivity. }
  case (in_inf_app_or la lb y).
  { apply Permutation_Type_in_inf with (y :: l) ; [ | left; reflexivity].
    apply Permutation_Type_cons_inv with x.
    rewrite Heq in Hperm; Permutation_Type_solve. }
  - intros Hin.
    apply in_inf_split in Hin as [[l1 l2] Heq' ].
    split with (l1 , l2 , lb).
    right; subst.
    rewrite <- ? app_assoc; reflexivity.
  - intros Hin.
    apply in_inf_split in Hin as [[l1 l2] Heq' ].
    split with (la , l1 , l2).
    left; subst; reflexivity.
Qed.

Lemma In_inf_seq : forall i k n,
    (i < n)%nat ->
    In_inf (i + k)%nat (seq k n).
Proof.
  intros i k n; revert i k; induction n; intros i k Hlt; try (exfalso; now inversion Hlt).
  destruct i; simpl; [ left; auto | ].
  right.
  replace (S (i + k)) with (i + S k)%nat by lia.
  apply IHn ; lia.
Qed.

Lemma in_inf_rev_inv A : forall (l : list A) a,
    In_inf a (rev l) ->
    In_inf a l.
Proof.
  intros l a Hin.
  rewrite <- rev_involutive.
  apply in_inf_rev.
  apply Hin.
Qed.

Lemma In_inf_map_S : forall i l,
    In_inf i l ->
    In_inf (S i) (map S l).
Proof.
  intros i; induction l; intros Hin; inversion Hin; subst; simpl; auto.
Qed.

Lemma not_0_In_inf_map_S : forall l,
    In_inf 0%nat (map S l) ->
    False.
Proof.
  induction l; intros Hin; inversion Hin; subst; simpl; auto.
  inversion H.
Qed.

Lemma In_inf_map_S_inv : forall i l,
    In_inf (S i) (map S l) ->
    In_inf i l.
Proof.
  intros i; induction l; intros Hin; inversion Hin; subst; simpl; auto.
Qed.

Lemma Forall_inf_lt_map_S : forall L n,
    Forall_inf (fun x => x < n)%nat L ->
    Forall_inf (fun x => x < S n)%nat (map S L).
Proof.
  induction L; intros n Hall; [apply Forall_inf_nil | ].
  inversion Hall; subst.
  apply Forall_inf_cons; [ lia | apply IHL; apply X].
Qed.

Lemma not_In_inf_seq : forall k n i,
    (i < k)%nat ->
    In_inf i (seq k n) ->
    False.
Proof.
  intros k n; revert k; induction n; intros k i Hlt Hin; inversion Hin; subst.
  - lia.
  - apply IHn with (S k) i; try assumption.
    lia.
Qed.

Lemma In_inf_seq_lt : forall k n i,
    In_inf i (seq k n) ->
    (i < k + n)%nat.
Proof.
  intros k n; revert k; induction n;  intros k i Hin; inversion Hin.
  - subst; lia.
  - replace (k + S n)%nat with (S k + n)%nat by lia.
    apply IHn.
    apply X.
Qed.

Lemma In_inf_remove_not A : forall eq_dec (l : list A) a,
    In_inf a (remove eq_dec a l) ->
    False.
Proof.
  intros eq_dec; induction l; intros a' Hin; [ inversion Hin | ].
  case_eq (eq_dec a' a); intros H1 H2.
  - subst; rewrite remove_cons in Hin.
    apply IHl with a.
    apply Hin.
  - simpl in Hin.
    rewrite H2 in Hin.
    inversion Hin ; [ apply H1; auto | ].
    apply IHl with a'.
    apply X.
Qed.

Lemma In_inf_remove_In_inf A : forall eq_dec (l : list A) a1 a2,
    In_inf a1 (remove eq_dec a2 l) ->
    (a1 <> a2) * (In_inf a1 l).
Proof.
  intros eq_dec; induction l; intros a1 a2 Hin; [ inversion Hin | ].
  case_eq (eq_dec a2 a); intros H1 H2; simpl in Hin; rewrite H2 in Hin.
  - destruct (IHl a1 a2 Hin) as [Hneq Hin'].
    split; auto.
    right; apply Hin'.
  - inversion Hin; subst.
    + split; auto.
      left; auto.
    + destruct (IHl a1 a2 X) as [Hneq Hin'].
      split; auto.
      right; auto.
Qed.

Lemma In_inf_remove_In_inf_inv A : forall eq_dec (l : list A) a1 a2,
    (a1 <> a2) * (In_inf a1 l) ->
    In_inf a1 (remove eq_dec a2 l).
Proof.
  intros eq_dec; induction l; intros a1 a2 [Hneq Hin]; [ inversion Hin | ].
  inversion Hin.
  - subst.
    simpl.
    case (eq_dec a2 a1); intros H; try (subst; now exfalso).
    clear H.
    left; auto.
  - simpl.
    case (eq_dec a2 a); intros H ; [ | right ]; apply IHl; split; auto.
Qed.

Lemma rev_reverse_order_gt : forall L,
    (forall i j : nat,
        (j < length L)%nat ->
        (i < j)%nat -> (nth i L 0 > nth j L 0)%nat) ->
    forall i j : nat,
      (i < length (rev L))%nat ->
      (i > j)%nat -> (nth i (rev L) 0 > nth j (rev L) 0)%nat.
Proof.
  intros L H i j Hlen Hgt.
  rewrite rev_length in Hlen.
  rewrite ? rev_nth; try lia.
  apply H; lia.
Qed.

Lemma rev_reverse_order_lt : forall L,
    (forall i j : nat,
        (j < length L)%nat ->
        (i < j)%nat -> (nth i L 0 < nth j L 0)%nat) ->
    forall i j : nat,
      (i < length (rev L))%nat ->
      (i > j)%nat -> (nth i (rev L) 0 < nth j (rev L) 0)%nat.
Proof.
  intros L H i j Hlen Hlt.
  rewrite rev_length in Hlen.
  rewrite ? rev_nth; try lia.
  apply H; lia.
Qed.

Lemma in_inf_map_cons A : forall (a : A) l L,
    In_inf l L ->
    In_inf (a :: l) (map (cons a) L).
Proof.
  intros a l; induction L; intros Hin ; [ inversion Hin | ].
  inversion Hin; subst.
  - simpl; left; reflexivity.
  - simpl; right; apply IHL.
    apply X.
Qed.

Lemma in_inf_map_cons_inv A : forall (a : A) l L,
    In_inf l (map (cons a) L) ->
    { l' & prod (l = a :: l') (In_inf l' L) }.
Proof.
  intros a l L; induction L; intros Hin; inversion Hin; subst.
  - split with a0.
    split; try reflexivity.
    left; reflexivity.
  - destruct (IHL X) as [l' [Heq Hin']].
    split with l'.
    repeat split; try assumption.
    right; apply Hin'.
Qed.

Lemma rev_not_nil A : forall (L : list A),
    L <> nil ->
    rev L <> nil.
Proof.
  destruct L; auto.
  simpl.
  intros _.
  intros H.
  assert (Permutation_Type (a :: rev L) nil); [ rewrite <- H; Permutation_Type_solve | ].
  symmetry in X; apply Permutation_Type_nil in X.
  inversion X.
Qed.

Lemma rev_nth_all_lt : forall l n,
    (forall i, nth i l 0 < n)%nat ->
    forall i, (nth i (rev l) 0 < n)%nat.
Proof.
  induction l; intros n H i.
  - destruct n; destruct i; auto.
  - simpl.
    case_eq (i <? (length (rev l)))%nat.
    + intros Hlt.
      rewrite app_nth1 ; [ | apply Nat.ltb_lt in Hlt; apply Hlt].
      apply IHl.
      intros i'.
      apply (H (S i')).
    + intros H'.
      rewrite app_nth2 ; [ | apply Nat.ltb_nlt in H'; lia].
      specialize (H 0%nat); simpl in H.
      remember (length (rev l)).
      clear - H H'.
      revert n0 H'.
      induction i; intros n0 H'.
      * simpl; apply H.
      *  destruct n0; [ destruct i; simpl; lia | ].
         change (S i - S n0)%nat with (i - n0)%nat.
         apply IHi.
         apply H'.
Qed.

Lemma Forall_inf_nth A : forall (P : A -> Type) (l : list A),
    Forall_inf P l ->
    forall (i : nat) (a : A), (i < length l)%nat -> P (nth i l a).
Proof.
  intros P; induction l; intros Hall i a' Hlen; [ exfalso; inversion Hlen | ].
  inversion Hall; subst.
  destruct i; [simpl; apply X | ].
  apply IHl; try assumption.
  simpl in Hlen; lia.
Qed.

Lemma nth_Forall_inf A : forall (P : A -> Type) (l : list A),
    (forall (i : nat) (a : A), (i < length l)%nat -> P (nth i l a)) ->
    Forall_inf P l.
Proof.
  intros P; induction l; intros H; [ apply Forall_inf_nil | ].
  apply Forall_inf_cons.
  - apply (H 0 a)%nat.
    simpl; lia.
  - apply IHl.
    intros i a' Hlen.
    apply (H (S i) a').
    simpl; lia.
Qed.

Lemma In_inf_concat {A} :
  forall L (x : A),
    In_inf x (concat L) ->
    {l & prod (In_inf l L) (In_inf x l)}.
Proof.
  induction L; intros x Hin; [ inversion Hin | ].
  simpl in Hin.
  apply in_inf_app_or in Hin.
  destruct Hin.
  - split with a; split; auto.
    left; reflexivity.
  - destruct (IHL x i) as [l [H1 H2]].
    split with l; split; auto.
    right; apply H1.
Qed.

Lemma In_inf_seq_le_start :
  forall i j k,
    In_inf i (seq j k) ->
    (j <= i)%nat.
Proof.
  intros i j k; revert j; induction k; intros j Hin; inversion Hin; subst; try (specialize (IHk (S j) X)); lia.
Qed.

Lemma rev_reverse_order : forall L,
    (forall i j : nat,
        (j < length L)%nat ->
        (i < j)%nat -> (nth j L 0 < nth i L 0)%nat) ->
    forall i j : nat,
      (j < length (rev L))%nat ->
      (i < j)%nat -> (nth i (rev L) 0 < nth j (rev L) 0)%nat.
Proof.
  intros L H i j Hlen Hgt.
  rewrite rev_length in Hlen.
  rewrite ? rev_nth; try lia.
  apply H; lia.
Qed.

Lemma all_neq_not_In_inf {A} : forall l (a : A),
    Forall_inf (fun x => x <> a) l ->
    In_inf a l -> False.
Proof.
  induction l; intros a0 Hall Hin; inversion Hin; inversion Hall; subst; try contradiction.
  apply IHl with a0; assumption.
Qed.

Lemma all_neq_0_map_S : forall l,
    Forall_inf (fun x => x <> 0%nat) l ->
    { l' & l = map S l' }.
Proof.
  induction l; intros Hall; inversion Hall; subst.
  - split with nil; auto.
  - destruct a ; [ contradiction | ].
    destruct IHl as [l' Heq]; auto.
    split with (a :: l'); subst; auto.
Qed.

Lemma NoDup_inf_rev {A} : forall (l : list A),
    NoDup_inf l ->
    NoDup_inf (rev l).
Proof.
  intros l.
  apply Permutation_Type_NoDup_inf.
  apply Permutation_Type_rev.
Qed.

Lemma NoDup_inf_nth {A} : forall l,
    (forall (a0 : A) i j, i < length l -> j < length l -> i <> j -> nth i l a0 <> nth j l a0) ->
    NoDup_inf l.
Proof.
  intros l; induction l; intros H; [ apply NoDup_inf_nil | ].
  apply NoDup_inf_cons.
  - intros Hin.
    apply (In_inf_nth _ _ a) in Hin as [n Hlen Heq].
    refine (H a 0 (S n) _ _ _ _); simpl; try lia.
    auto.
  - apply IHl.
    intros a0 i j Hlen1 Hlen2 Hneq.
    refine (H a0 (S i) (S j) _ _ _); simpl; lia.
Qed.

Lemma list_split_max : forall v,
    v <> nil ->
    {' (la, lb, k) : _ & prod (v = la ++ k :: lb)
                              ((Forall_inf (fun x => x <= k) la) *
                               (Forall_inf (fun x => x <= k) lb))}.
Proof.
  induction v ; [ contradiction | ].
  destruct v; intros _.
  - split with (nil, nil, a).
    repeat split; auto.
  - destruct IHv as [[[la lb] k] [Heq [H1 H2]]]; [ intros H; inversion H | ].
    case_eq (k <=? a); intros H.
    + split with (nil, n :: v, a).
      apply Nat.leb_le in H.
      repeat split; auto.
      rewrite Heq.
      apply Forall_inf_app; [ | apply Forall_inf_cons].
      * refine (Forall_inf_arrow _ _ H1).
        intros a0 H'; lia.
      * apply H.
      * refine (Forall_inf_arrow _ _ H2).
        intros a0 H'; lia.
    + split with (a :: la, lb, k).
      apply Nat.leb_nle in H.
      repeat split; try rewrite Heq; auto.
      apply Forall_inf_cons; auto.
      lia.
Qed.

Lemma Forall_inf_le_not_In_inf : forall l k,
    Forall_inf (fun x => x <= k) l ->
    (In_inf k l -> False) ->
    Forall_inf (fun x => x < k) l.
Proof.
  induction l; intros k Hall Hnin; inversion Hall; subst; auto.
  apply Forall_inf_cons.
  - assert (a <> k).
    { intros H; subst; apply Hnin; left; auto. }
    lia.
  - apply IHl; auto.
    intros Hin; apply Hnin; right; auto.
Qed.

Lemma NoDup_inf_lt_length : forall v n,
    Forall_inf (fun x => x < n) v ->
    NoDup_inf v ->
    length v <= n.
Proof.
  intros v; remember (length v).
  revert v Heqn.
  induction n; intros v Heqn k Hall Hndup; try lia.
  assert (v <> nil) as Hnnil.
  { destruct v; try now inversion Heqn; auto. }
  destruct (list_split_max v Hnnil) as [[[la lb] k'] [Heq [H1 H2]]].
  apply Permutation_Type_NoDup_inf with _ _ (k' :: la ++ lb) in Hndup; [ | rewrite Heq;Permutation_Type_solve ].
  inversion Hndup; subst.
  transitivity (S k').
  - apply le_n_S.
    refine (IHn (la ++ lb) _ k' _ _).
    + replace (length (la ++ lb)) with (pred (length (la ++ k' :: lb))) by (rewrite ? app_length; simpl; lia).
      rewrite <- Heqn; reflexivity.
    + apply Forall_inf_le_not_In_inf; [ apply Forall_inf_app | ]; auto.
    + apply X.
  - apply Forall_inf_elt in Hall.
    apply Hall.
Qed.

Lemma seq_NoDup_inf : forall i j,
    NoDup_inf (seq i j).
Proof.
  intros i j; revert i; induction j; intros i; simpl.
  - apply NoDup_inf_nil.
  - apply NoDup_inf_cons; auto.
    apply not_In_inf_seq; lia.
Qed.

Lemma remove_NoDup_inf {A} (Eq_dec : forall (a b : A), {a = b} + {a <> b}): forall (a : A) l,
    NoDup_inf l ->
    NoDup_inf (remove Eq_dec a l).
Proof.
  intros a; induction l; intros Hndup; inversion Hndup; subst; simpl; auto.
  case (Eq_dec a a0); intros H.
  - apply IHl; assumption.
  - apply NoDup_inf_cons; [ | apply IHl; assumption].
    intros H1.
    apply H0.
    apply (In_inf_remove_In_inf _ _ _ _ _ H1).
Qed.

(* return a list of all non empty subsets of [0..n] *)
Fixpoint make_subsets n :=
  match n with
  | 0%nat => nil
  | S n => (n :: nil) :: (map (cons n) (make_subsets n)) ++ make_subsets n
  end.

Lemma make_subsets_length : forall k,
    length (make_subsets k) = pred (2 ^ k).
Proof.
  induction k; simpl; try lia.
  rewrite app_length; rewrite map_length.
  rewrite IHk.
  assert (2 ^ k <> 0).
  { apply pow_not_0; lia. }
  lia.
Qed.

Lemma cond_is_in_make_subsets : forall n l,
    l <> nil ->
    (forall i, nth i l 0 < n)%nat ->
    (forall i j, (j < length l)%nat -> (i < j)%nat -> (nth i l 0 > nth j l 0)%nat) ->
    In_inf l (make_subsets n).
Proof.
  induction n; intros l Hnnil Hle Hlt.
  - specialize (Hle 0%nat).
    exfalso; destruct l; inversion Hle.
  - destruct l; [exfalso; apply Hnnil; reflexivity | ].
    case_eq (n0 =? n); intros Heq.
    + apply Nat.eqb_eq in Heq; subst.
      destruct l.
      * left; reflexivity.
      * right.
        apply in_inf_or_app; left.
        apply in_inf_map_cons.
        apply IHn.
        -- intros H'; inversion H'.
        -- intros i.
           case_eq (i <? length (n0 :: l))%nat; intros H.
           ++ specialize (Hlt 0%nat (S i)).
              simpl in Hlt.
              change (match i with
                      | 0 => n0
                      | S m => nth m l 0
                      end)%nat with (nth i (n0 :: l) 0)%nat in Hlt.
              apply Nat.ltb_lt in H; simpl in H.
              lia.
           ++ apply Nat.ltb_nlt in H.
              rewrite nth_overflow ; destruct n; try lia.
              exfalso.
              specialize (Hlt 0 1)%nat.
              simpl in Hlt; lia.
        -- intros i j Hlen' Hlt'.
           assert (H' := Hlt (S i) (S j)).
           change (nth (S i) (S n :: n0 :: l) 0%nat) with (nth i (n0 :: l) 0%nat) in *.
           change (nth (S j) (S n :: n0 :: l) 0)%nat with (nth j (n0 :: l) 0%nat) in *.
           apply H'; simpl in *; lia.
    + right; apply in_inf_or_app; right.
      apply IHn.
      -- intros H'; inversion H'.
      -- intros i.
         destruct i; [ specialize (Hle 0%nat); apply Nat.eqb_neq in Heq; simpl in *; lia | ].
         case_eq (S i <? length (n0 :: l))%nat; intros H; [ apply Nat.ltb_lt in H | apply Nat.ltb_nlt in H].
         ++ specialize (Hle i).
            specialize (Hlt i (S i)).
            lia.
         ++ rewrite nth_overflow; destruct n; try lia.
            destruct n0; inversion Heq.
            specialize (Hle 0)%nat.
            simpl in Hle; lia.
      -- intros i j Hlen' Hlt'.
         specialize (Hle j); specialize (Hlt i j).
         apply Hlt; lia.
Qed.

Lemma cond_is_in_make_subsets_inv : forall n l,
    In_inf l (make_subsets n) ->
    (l <> nil) * (forall i, nth i l 0 < n)%nat * (forall i j, (j < length l)%nat -> (i < j)%nat -> (nth i l 0 > nth j l 0)%nat).
Proof.
  induction n; intros l; [ intros Hin | intros [Heq | Hin]].
  - inversion Hin.
  - destruct l; [ | destruct l]; inversion Heq; subst.
    repeat split.
    + intros H; inversion H.
    + intros i; destruct i; [ | destruct i]; simpl; lia.
    + intros i j Hlen Hlt.
      destruct j ; [inversion Hlt | ].
      destruct j; try now inversion Hlen.
  - destruct (in_inf_app_or _ _ _ Hin).
    + destruct (in_inf_map_cons_inv _ _ _ _ i) as [l' [Heq Hin']]; subst.
      destruct (IHn l' Hin') as [[Hnnil Hlen] Hlt].
      clear i Hin.
      repeat split.
      * intros H; inversion H.
      * intros i.
        destruct i.
        -- simpl; lia.
        -- specialize (Hlen i).
           simpl.
           lia.
      * intros i j Hlen' Hlt'.
        destruct j; try now inversion Hlt'.
        change (nth (S j) (S n :: l') 0)%nat with (nth j l' 0)%nat.
        destruct i.
        -- simpl.
           specialize (Hlen j).
           lia.
        -- change (nth (S i) (S n :: l') 0)%nat with (nth i l' 0)%nat.
           apply Hlt; simpl in *; lia.
    + specialize (IHn l i).
      clear Hin i.
      destruct IHn as [[Hnil Hlen] Hlt].
      repeat split; auto.
      intro i; specialize (Hlen i); lia.
Qed.

(* return the complementary list of v *)
Fixpoint complementary (v : list nat) n :=
  match v with
  | nil => seq 0%nat n
  | i :: v => remove (Nat.eq_dec) i (complementary v n)
  end.

Lemma In_inf_complementary : forall v n i,
    In_inf i v ->
    In_inf i (complementary v n) ->
    False.
Proof.
  induction v; intros n i Hin1 Hin2; [ inversion Hin1 | ].
  simpl in Hin2.
  case_eq (i =? a); intros H.
  - apply Nat.eqb_eq in H; subst.
    apply In_inf_remove_not in Hin2.
    apply Hin2.
  - inversion Hin1; [ apply Nat.eqb_neq in H; lia | ].
    apply IHv with n i; auto.
    apply In_inf_remove_In_inf in Hin2.
    apply Hin2.
Qed.

Lemma In_inf_complementary_inv : forall v n i,
    (i < n)%nat ->
    (In_inf i (complementary v n) -> False) ->
    In_inf i v.
Proof.
  induction v; intros n i Hlt H.
  - exfalso; apply H.
    replace i with (i + 0)%nat by lia.
    apply In_inf_seq.
    apply Hlt.
  - simpl in *.
    case_eq (a =? i); intros Heq.
    + left.
      apply Nat.eqb_eq in Heq; auto.
    + right.
      apply IHv with n; auto.
      intros Hin.
      apply H.
      apply In_inf_remove_In_inf_inv.
      apply Nat.eqb_neq in Heq; split; auto.
Qed.

Lemma In_inf_complementary2 : forall v n i,
    In_inf i (complementary v n) ->
    In_inf i v ->
    False.
Proof.
  induction v; intros n i Hin1 Hin2; [ inversion Hin2 | ].
  simpl in Hin1.
  case_eq (i =? a); intros H.
  - apply Nat.eqb_eq in H; subst.
    apply In_inf_remove_not in Hin1.
    apply Hin1.
  - inversion Hin2; [ apply Nat.eqb_neq in H; lia | ].
    apply IHv with n i; auto.
    apply In_inf_remove_In_inf in Hin1.
    apply Hin1.
Qed.

Lemma In_inf_complementary2_inv : forall v n i,
    (i < n)%nat ->
    (In_inf i v -> False) ->
    In_inf i (complementary v n).
Proof.
  induction v; intros n i Hlt H.
  - replace i with (i + 0)%nat by lia.
    apply In_inf_seq.
    apply Hlt.
  - simpl in *.
    case_eq (a =? i); intros Heq.
    + exfalso; apply H; left; apply Nat.eqb_eq; apply Heq.
    + apply In_inf_remove_In_inf_inv.
      apply Nat.eqb_neq in Heq; split; auto.
Qed.

Lemma complementary_partition : forall v n i,
    (i < n)%nat ->
    (In_inf i v) + (In_inf i (complementary v n)).
Proof.
  intros v n i Hlt.
  assert (Hin := in_inf_dec Nat.eq_dec i v).
  inversion Hin.
  - left; apply X.
  - right.
    apply In_inf_complementary2_inv; auto.
Qed.

Lemma In_inf_complementary_lt : forall L n i,
    In_inf i (complementary L n) ->
    (i < n)%nat.
Proof.
  induction L; intros n i Hin.
  - simpl complementary in Hin.
    replace n with (0 + n)%nat by lia.
    apply In_inf_seq_lt.
    apply Hin.
  - simpl in Hin.
    apply In_inf_remove_In_inf in Hin as [Hneq Hin].
    apply IHL; auto.
Qed.

Lemma complementary_NoDup_inf : forall v n,
    NoDup_inf (complementary v n).
Proof.
  induction v; intros n; simpl.
  - apply seq_NoDup_inf.
  - apply remove_NoDup_inf.
    apply IHv.
Qed.

Lemma remove_length_not_In_inf {A} (Eq_dec : forall (a b : A), {a = b} + {a <> b}): forall (a : A) l,
    (In_inf a l -> False) ->
    length (remove Eq_dec a l) = length l.
Proof.
  intros a; induction l; intros Hnin; simpl; try reflexivity.
  case (Eq_dec a a0); intros H.
  - exfalso; subst.
    apply Hnin.
    left; reflexivity.
  - simpl; rewrite IHl; auto.
    intros Hin; apply Hnin; right; apply Hin.
Qed.

Lemma remove_length_In_inf_no_dup {A} (Eq_dec : forall (a b : A), {a = b} + {a <> b}): forall (a : A) l,
    In_inf a l ->
    NoDup_inf l ->
    length (remove Eq_dec a l) = pred (length l).
Proof.
  intros a l; induction l; intros Hin Hndup; try now inversion Hin.
  inversion Hin; subst.
  - rewrite remove_cons.
    simpl.
    inversion Hndup; subst.
    apply remove_length_not_In_inf.
    apply H0.
  - simpl.
    case (Eq_dec a a0); intros H.
    + apply remove_length_not_In_inf; inversion Hndup; subst; assumption.
    +  inversion Hndup; subst.
       simpl; rewrite IHl; try assumption.
       destruct l; simpl; try lia.
       inversion X.
Qed.

Lemma complementary_length_lt_no_dup : forall v n,
    Forall_inf (fun x => x < n) v ->
    NoDup_inf v ->
    length (complementary v n) = n - (length v).
Proof.
  induction v; intros n Hall Hndup; simpl.
  - rewrite seq_length; lia.
  - inversion Hall; subst.
    inversion Hndup; subst.
    specialize (IHv n X X0).
    rewrite remove_length_In_inf_no_dup.
    + rewrite IHv.
      lia.
    + apply In_inf_complementary2_inv; assumption.
    + apply complementary_NoDup_inf.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.suma.
Require Import GeoCoq.Tarski_dev.Ch13_1.

Section alternate_interior_angles_consecutive_interior_angles.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma alternate_interior__consecutive_interior :
   alternate_interior_angles_postulate -> consecutive_interior_angles_postulate.
Proof.
  intros aia A B C D Hos HPar.
  split.
    assert_diffs; auto.
  destruct (segment_construction A B B A) as [A' []].
  exists A'; split; trivial.
  apply conga_comm, conga_sym, aia; [|assert_diffs; apply par_col_par_2 with A; Col; Par].
  apply l9_2, l9_8_2 with A; trivial.
  apply one_side_not_col123 in Hos.
  repeat split.
    Col.
    intro; apply Hos; ColR.
  exists B; split; Col.
Qed.

End alternate_interior_angles_consecutive_interior_angles.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Rbase.
Require Import Rbasic_fun.
Open Local Scope R_scope.

(****************************************************)
(** Rsqr : some results                             *)
(****************************************************)

Ltac ring_Rsqr := unfold Rsqr in |- *; ring.

Lemma Rsqr_neg : forall x:R, Rsqr x = Rsqr (- x).
Proof.
  intros; ring_Rsqr.
Qed.

Lemma Rsqr_mult : forall x y:R, Rsqr (x * y) = Rsqr x * Rsqr y.
Proof.
  intros; ring_Rsqr.
Qed.

Lemma Rsqr_plus : forall x y:R, Rsqr (x + y) = Rsqr x + Rsqr y + 2 * x * y.
Proof.
  intros; ring_Rsqr.
Qed.

Lemma Rsqr_minus : forall x y:R, Rsqr (x - y) = Rsqr x + Rsqr y - 2 * x * y.
Proof.
  intros; ring_Rsqr.
Qed.

Lemma Rsqr_neg_minus : forall x y:R, Rsqr (x - y) = Rsqr (y - x).
Proof.
  intros; ring_Rsqr.
Qed.

Lemma Rsqr_1 : Rsqr 1 = 1.
Proof.
  ring_Rsqr.
Qed.

Lemma Rsqr_gt_0_0 : forall x:R, 0 < Rsqr x -> x <> 0.
Proof.
  intros; red in |- *; intro; rewrite H0 in H; rewrite Rsqr_0 in H;
    elim (Rlt_irrefl 0 H).
Qed.

Lemma Rsqr_pos_lt : forall x:R, x <> 0 -> 0 < Rsqr x.
Proof.
  intros; case (Rtotal_order 0 x); intro;
    [ unfold Rsqr in |- *; apply Rmult_lt_0_compat; assumption
      | elim H0; intro;
        [ elim H; symmetry  in |- *; exact H1
          | rewrite Rsqr_neg; generalize (Ropp_lt_gt_contravar x 0 H1);
            rewrite Ropp_0; intro; unfold Rsqr in |- *;
              apply Rmult_lt_0_compat; assumption ] ].
Qed.

Lemma Rsqr_div : forall x y:R, y <> 0 -> Rsqr (x / y) = Rsqr x / Rsqr y.
Proof.
  intros; unfold Rsqr in |- *.
  unfold Rdiv in |- *.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  reflexivity.
  assumption.
  assumption.
Qed.

Lemma Rsqr_eq_0 : forall x:R, Rsqr x = 0 -> x = 0.
Proof.
  unfold Rsqr in |- *; intros; generalize (Rmult_integral x x H); intro;
    elim H0; intro; assumption.
Qed.

Lemma Rsqr_minus_plus : forall a b:R, (a - b) * (a + b) = Rsqr a - Rsqr b.
Proof.
  intros; ring_Rsqr.
Qed.

Lemma Rsqr_plus_minus : forall a b:R, (a + b) * (a - b) = Rsqr a - Rsqr b.
Proof.
  intros; ring_Rsqr.
Qed.

Lemma Rsqr_incr_0 :
  forall x y:R, Rsqr x <= Rsqr y -> 0 <= x -> 0 <= y -> x <= y.
Proof.
  intros; case (Rle_dec x y); intro;
    [ assumption
      | cut (y < x);
        [ intro; unfold Rsqr in H;
          generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2);
            intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3);
              intro; elim (Rlt_irrefl (x * x) H4)
          | auto with real ] ].
Qed.

Lemma Rsqr_incr_0_var : forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> x <= y.
Proof.
  intros; case (Rle_dec x y); intro;
    [ assumption
      | cut (y < x);
        [ intro; unfold Rsqr in H;
          generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1);
            intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2);
              intro; elim (Rlt_irrefl (x * x) H3)
          | auto with real ] ].
Qed.

Lemma Rsqr_incr_1 :
  forall x y:R, x <= y -> 0 <= x -> 0 <= y -> Rsqr x <= Rsqr y.
Proof.
  intros; unfold Rsqr in |- *; apply Rmult_le_compat; assumption.
Qed.

Lemma Rsqr_incrst_0 :
  forall x y:R, Rsqr x < Rsqr y -> 0 <= x -> 0 <= y -> x < y.
Proof.
  intros; case (Rtotal_order x y); intro;
    [ assumption
      | elim H2; intro;
        [ rewrite H3 in H; elim (Rlt_irrefl (Rsqr y) H)
          | generalize (Rmult_le_0_lt_compat y x y x H1 H1 H3 H3); intro;
            unfold Rsqr in H; generalize (Rlt_trans (x * x) (y * y) (x * x) H H4);
              intro; elim (Rlt_irrefl (x * x) H5) ] ].
Qed.

Lemma Rsqr_incrst_1 :
  forall x y:R, x < y -> 0 <= x -> 0 <= y -> Rsqr x < Rsqr y.
Proof.
  intros; unfold Rsqr in |- *; apply Rmult_le_0_lt_compat; assumption.
Qed.

Lemma Rsqr_neg_pos_le_0 :
  forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> - y <= x.
Proof.
  intros; case (Rcase_abs x); intro.
  generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
    generalize (Rlt_le 0 (- x) H1); intro; rewrite (Rsqr_neg x) in H;
      generalize (Rsqr_incr_0 (- x) y H H2 H0); intro;
        rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar;
          apply Rle_ge; assumption.
  apply Rle_trans with 0;
    [ rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption
      | apply Rge_le; assumption ].
Qed.

Lemma Rsqr_neg_pos_le_1 :
  forall x y:R, - y <= x -> x <= y -> 0 <= y -> Rsqr x <= Rsqr y.
Proof.
  intros; case (Rcase_abs x); intro.
  generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
    generalize (Rlt_le 0 (- x) H2); intro;
      generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive;
        intro; generalize (Rge_le y (- x) H4); intro; rewrite (Rsqr_neg x);
          apply Rsqr_incr_1; assumption.
  generalize (Rge_le x 0 r); intro; apply Rsqr_incr_1; assumption.
Qed.

Lemma neg_pos_Rsqr_le : forall x y:R, - y <= x -> x <= y -> Rsqr x <= Rsqr y.
Proof.
  intros; case (Rcase_abs x); intro.
  generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
    generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive;
      intro; generalize (Rge_le y (- x) H2); intro; generalize (Rlt_le 0 (- x) H1);
        intro; generalize (Rle_trans 0 (- x) y H4 H3); intro;
          rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption.
  generalize (Rge_le x 0 r); intro; generalize (Rle_trans 0 x y H1 H0); intro;
    apply Rsqr_incr_1; assumption.
Qed.

Lemma Rsqr_abs : forall x:R, Rsqr x = Rsqr (Rabs x).
Proof.
  intro; unfold Rabs in |- *; case (Rcase_abs x); intro;
    [ apply Rsqr_neg | reflexivity ].
Qed.

Lemma Rsqr_le_abs_0 : forall x y:R, Rsqr x <= Rsqr y -> Rabs x <= Rabs y.
Proof.
  intros; apply Rsqr_incr_0; repeat rewrite <- Rsqr_abs;
    [ assumption | apply Rabs_pos | apply Rabs_pos ].
Qed.

Lemma Rsqr_le_abs_1 : forall x y:R, Rabs x <= Rabs y -> Rsqr x <= Rsqr y.
Proof.
  intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y);
    apply (Rsqr_incr_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)).
Qed.

Lemma Rsqr_lt_abs_0 : forall x y:R, Rsqr x < Rsqr y -> Rabs x < Rabs y.
Proof.
  intros; apply Rsqr_incrst_0; repeat rewrite <- Rsqr_abs;
    [ assumption | apply Rabs_pos | apply Rabs_pos ].
Qed.

Lemma Rsqr_lt_abs_1 : forall x y:R, Rabs x < Rabs y -> Rsqr x < Rsqr y.
Proof.
  intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y);
    apply (Rsqr_incrst_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)).
Qed.

Lemma Rsqr_inj : forall x y:R, 0 <= x -> 0 <= y -> Rsqr x = Rsqr y -> x = y.
Proof.
  intros; generalize (Rle_le_eq (Rsqr x) (Rsqr y)); intro; elim H2; intros _ H3;
    generalize (H3 H1); intro; elim H4; intros; apply Rle_antisym;
      apply Rsqr_incr_0; assumption.
Qed.

Lemma Rsqr_eq_abs_0 : forall x y:R, Rsqr x = Rsqr y -> Rabs x = Rabs y.
Proof.
  intros; unfold Rabs in |- *; case (Rcase_abs x); case (Rcase_abs y); intros.
  rewrite (Rsqr_neg x) in H; rewrite (Rsqr_neg y) in H;
    generalize (Ropp_lt_gt_contravar y 0 r);
      generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0;
        intros; generalize (Rlt_le 0 (- x) H0); generalize (Rlt_le 0 (- y) H1);
          intros; apply Rsqr_inj; assumption.
  rewrite (Rsqr_neg x) in H; generalize (Rge_le y 0 r); intro;
    generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0;
      intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj;
        assumption.
  rewrite (Rsqr_neg y) in H; generalize (Rge_le x 0 r0); intro;
    generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0;
      intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj;
        assumption.
  generalize (Rge_le x 0 r0); generalize (Rge_le y 0 r); intros; apply Rsqr_inj;
    assumption.
Qed.

Lemma Rsqr_eq_asb_1 : forall x y:R, Rabs x = Rabs y -> Rsqr x = Rsqr y.
Proof.
  intros; cut (Rsqr (Rabs x) = Rsqr (Rabs y)).
  intro; repeat rewrite <- Rsqr_abs in H0; assumption.
  rewrite H; reflexivity.
Qed.

Lemma triangle_rectangle :
  forall x y z:R,
    0 <= z -> Rsqr x + Rsqr y <= Rsqr z -> - z <= x <= z /\ - z <= y <= z.
Proof.
  intros;
    generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H0);
      rewrite Rplus_comm in H0;
        generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H0);
          intros; split;
            [ split;
              [ apply Rsqr_neg_pos_le_0; assumption
                | apply Rsqr_incr_0_var; assumption ]
              | split;
                [ apply Rsqr_neg_pos_le_0; assumption
                  | apply Rsqr_incr_0_var; assumption ] ].
Qed.

Lemma triangle_rectangle_lt :
  forall x y z:R,
    Rsqr x + Rsqr y < Rsqr z -> Rabs x < Rabs z /\ Rabs y < Rabs z.
Proof.
  intros; split;
    [ generalize (plus_lt_is_lt (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H);
      intro; apply Rsqr_lt_abs_0; assumption
      | rewrite Rplus_comm in H;
        generalize (plus_lt_is_lt (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H);
          intro; apply Rsqr_lt_abs_0; assumption ].
Qed.

Lemma triangle_rectangle_le :
  forall x y z:R,
    Rsqr x + Rsqr y <= Rsqr z -> Rabs x <= Rabs z /\ Rabs y <= Rabs z.
Proof.
  intros; split;
    [ generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H);
      intro; apply Rsqr_le_abs_0; assumption
      | rewrite Rplus_comm in H;
        generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H);
          intro; apply Rsqr_le_abs_0; assumption ].
Qed.

Lemma Rsqr_inv : forall x:R, x <> 0 -> Rsqr (/ x) = / Rsqr x.
Proof.
  intros; unfold Rsqr in |- *.
  rewrite Rinv_mult_distr; try reflexivity || assumption.
Qed.

Lemma canonical_Rsqr :
  forall (a:nonzeroreal) (b c x:R),
    a * Rsqr x + b * x + c =
    a * Rsqr (x + b / (2 * a)) + (4 * a * c - Rsqr b) / (4 * a).
Proof.
  intros.
  rewrite Rsqr_plus.
  repeat rewrite Rmult_plus_distr_l.
  repeat rewrite Rplus_assoc.
  apply Rplus_eq_compat_l.
  unfold Rdiv, Rminus in |- *.
  replace (2 * 1 + 2 * 1) with 4; [ idtac | ring ].
  rewrite (Rmult_plus_distr_r (4 * a * c) (- Rsqr b) (/ (4 * a))).
  rewrite Rsqr_mult.
  repeat rewrite Rinv_mult_distr.
  repeat rewrite (Rmult_comm a).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm 2).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm (/ 2)).
  rewrite (Rmult_comm 2).
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm a).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm 2).
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  repeat rewrite Rplus_assoc.
  rewrite (Rplus_comm (Rsqr b * (Rsqr (/ a * / 2) * a))).
  repeat rewrite Rplus_assoc.
  rewrite (Rmult_comm x).
  apply Rplus_eq_compat_l.
  rewrite (Rmult_comm (/ a)).
  unfold Rsqr in |- *; repeat rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  ring.
  apply (cond_nonzero a).
  discrR.
  apply (cond_nonzero a).
  discrR.
  discrR.
  apply (cond_nonzero a).
  discrR.
  discrR.
  discrR.
  apply (cond_nonzero a).
  discrR.
  apply (cond_nonzero a).
Qed.

Lemma Rsqr_eq : forall x y:R, Rsqr x = Rsqr y -> x = y \/ x = - y.
Proof.
  intros; unfold Rsqr in H;
    generalize (Rplus_eq_compat_l (- (y * y)) (x * x) (y * y) H);
      rewrite Rplus_opp_l; replace (- (y * y) + x * x) with ((x - y) * (x + y)).
  intro; generalize (Rmult_integral (x - y) (x + y) H0); intro; elim H1; intros.
  left; apply Rminus_diag_uniq; assumption.
  right; apply Rminus_diag_uniq; unfold Rminus in |- *; rewrite Ropp_involutive;
    assumption.
  ring.
Qed.


Section Functions.

  Definition injective (A B : Set) (f : A -> B) := forall a a', f a = f a' -> a = a'.

  Definition surjective (A B : Set) (f : A -> B) := forall b, (exists a, f a = b).

  Definition left_inverse (A B : Set) (f : A -> B) (g : B -> A) :=
    forall a, g (f a) = a.

  Definition right_inverse (A B : Set) (f : A -> B) (g : B -> A) :=
    forall b, f (g b) = b.

  Definition nonempty (A : Set) := exists x : A, True.

  Theorem fun_intro (A B : Set) (f : A -> B) : forall a a', a = a' -> f a = f a'.
  Proof.
    intros a a' H; rewrite H; reflexivity.
  Qed.

  Variable (A B : Set).

  Arguments injective {A} {B} _.
  Arguments surjective {A} {B} _.
  Arguments left_inverse {A} {B} _ _.
  Arguments right_inverse {A} {B} _ _.

  Definition partial_inverse (f : A -> B) := B -> option A.
  Definition is_partial_inverse (f : A -> B) (f_inv: partial_inverse f) :=
    forall b a,
      (f_inv b = Some a -> f a = b) /\
      (f_inv b = None -> ~exists a, f a = b).

  Axiom partial_inverse_exists :
    forall f, exists (f_inv : partial_inverse f), is_partial_inverse f f_inv.

  Theorem partial_inverse_false f f_inv :
    is_partial_inverse f f_inv ->
    forall a, f_inv (f a) = None -> False.
  Proof.
    intros PartialInverse a H.
    remember (f a) as b.
    apply (PartialInverse b a) in H.
    contradict H.
    exists a.
    auto.
  Qed.

  Theorem partial_inverse_injective f f_inv :
    injective f -> is_partial_inverse f f_inv -> forall a, f_inv (f a) = Some a.
  Proof.
    intros f_injective PartialInverse a.
    remember (f_inv (f a)) as Q.
    symmetry in HeqQ.
    destruct Q;
      [apply PartialInverse, f_injective in HeqQ; rewrite HeqQ; reflexivity |
       apply (partial_inverse_false _ _ PartialInverse) in HeqQ; contradict HeqQ].
  Qed.

  Theorem left_inverse_iff_injective (f : A -> B) :
    nonempty A -> (exists g, left_inverse f g) <-> injective f.
  Proof.
    destruct (partial_inverse_exists f) as [f_inv PartialInverse].
    intros [s _].
    split.
    - intros [g left_inverse] a a' H.
    apply (fun_intro _ _ g (f a) (f a')) in H.
    repeat rewrite left_inverse in H; exact H.
    (* opposite side requires defining a total inverse function
       from the partial inverse *)
    - intros f_injective.
      exists (fun b =>
                match (f_inv b) with
                | Some a => a
                | None => s
                end).
      intros a.
      rewrite (partial_inverse_injective _ _ f_injective PartialInverse a); auto.
  Qed.

  Theorem right_inverse_iff_surjective (f : A -> B):
    nonempty A -> (exists g, right_inverse f g) <-> surjective f.
  Proof.
    destruct (partial_inverse_exists f) as [f_inv PartialInverse].
    intros [s _].
    split.
    - intros [g right_inverse].
      unfold surjective.
      intros b; exists (g b).
      rewrite right_inverse; reflexivity.
    - intros f_surjective.
      exists (fun b => match (f_inv b) with | Some a => a | None => s end).
      intros b.
      remember (f_inv b) as Q.
      symmetry in HeqQ.
      destruct Q.
      apply (PartialInverse) in HeqQ.
      exact HeqQ.
      apply (PartialInverse _ s) in HeqQ.
      contradict HeqQ.
      apply f_surjective.
  Qed.

  Definition monomorphism (f: A -> B) := forall (Z: Set) α α' (a : Z), f (α a) = f (α' a) -> α a = α' a.

  Definition singleton (C: Set) := C -> Set.

  Theorem monomorphism_iff_injective f :
    nonempty A -> injective f -> monomorphism f.
  Proof.
    intros A_nonempty f_injective Z α α' a.
    apply left_inverse_iff_injective in f_injective; auto.
    destruct f_injective as [g g_left_inverse].
    intros f_equiv.
    apply (fun_intro _ _ g _ _) in f_equiv.
    repeat rewrite g_left_inverse in f_equiv.
    assumption.
  Qed.

End Functions.


Require Arith.

(** * Basic setup *)

Class Eq (T : Type) :=
  { eq : T -> T -> Prop;
    eq_refl : forall x, eq x x;
    eq_symm : forall x y, eq x y -> eq y x;
    eq_trans : forall x y z, eq x y -> eq y z -> eq x z }.

Notation "x == y" := (eq x y) (at level 42).

Class Preord (T : Type) :=
  { ord : T -> T -> Prop;
    ord_refl : forall x, ord x x;
    ord_trans : forall x y z, ord x y -> ord y z -> ord x z }.

Notation "x ≤ y" := (ord x y) (at level 42).

Instance Nat_Preord : Preord nat :=
  { ord x y := x <= y }.
- reflexivity.
- etransitivity; eassumption.
Qed.

Instance Preord_Eq (T : Type) { H: Preord T} : Eq T :=
  { eq x y := x ≤ y /\ y ≤ x }.
- intros. destruct H. split; apply ord_refl0.
- intuition.
- intros. destruct H0; destruct H1; destruct H.
  split; eapply ord_trans0; eauto.
Qed.

(** * A naive approach *)

Require Import Streams.

CoInductive stream_ub {T : Type} `{Preord T} : Stream T -> T -> Prop :=
| stream_hd_lt : forall h t x,
    h ≤ x -> stream_ub t x -> stream_ub (Cons h t) x.

Class CPO (T : Type) `{Preord T} :=
  { lub : (Stream T) -> T;
    le_lub : forall (c : Stream T), stream_ub c (lub c);
    lub_le : forall (c : Stream T) x, stream_ub c x -> lub c ≤ x
  }.

Definition flat := option.

Inductive flat_ord {A : Type} : flat A -> flat A -> Prop :=
| flatNone : forall x, flat_ord None x
| flatSome : forall a, flat_ord (Some a) (Some a).

Instance Flat_Preord (A : Type) : Preord (flat A) :=
  { ord := flat_ord }.
- destruct x; constructor.
- inversion 1; inversion 1; subst; constructor.
Qed.

Definition flat_lub {A : Type} (c : Stream (flat A)) : flat A.
Abort.

Reset stream_ub.

(** * A different representation of chains *)

Class Hom (A B : Type) `{Preord A} `{Preord B} :=
  { map : A -> B;
    map_axiom : forall (x y : A),
        x ≤ y -> map x ≤ map y }.

Arguments map {A} {B} {_} {_}.
Coercion map : Hom >-> Funclass.

Instance Hom_Preord (A B : Type) `{Preord A} `{Preord B} : Preord (Hom A B) :=
  { ord x y := forall a, x a ≤ y a }.
- intros. destruct H0. apply ord_refl0.
- intros. destruct H0. eapply ord_trans0. apply H1. apply H2.
Qed.

Class CPO (T : Type) `{Preord T} :=
  { lub : (Hom nat T) -> T;
    le_lub : forall (c : Hom nat T) n, c n ≤ lub c;
    lub_le : forall (c : Hom nat T) x, (forall n, c n ≤ x) -> lub c ≤ x
  }.

(** Recall a flat domain is a domain with a bottom elements ⊥.
    a ≤ b if and only if either a = ⊥ or a = b. *)

Definition flat := option.

Inductive flat_ord {A : Type} : flat A -> flat A -> Prop :=
| flatNone : forall x, flat_ord None x
| flatSome : forall a, flat_ord (Some a) (Some a).

Instance Flat_Preord (A : Type) : Preord (flat A) :=
  { ord := flat_ord }.
- destruct x; constructor.
- inversion 1; inversion 1; subst; constructor.
Qed.

Definition flat_lub {A : Type} (c : Hom nat (flat A)) : flat A.
Abort.

Reset flat.

(** * The Paulin-Mohring approach

    See: Christine Paulin-Mohring. A constructive denotational
    semantics for Kahn networks in Coq. From Semantics to Computer
    Science, Cambridge University Press, pp.383-413, 2009,
    9780521518253. *)

CoInductive flat (A : Type) :=
| Eps : flat A -> flat A
| Val : A -> flat A.

Arguments Eps {_}.
Arguments Val {_}.

Fixpoint idx {A : Type} (f : flat A) (n : nat) : flat A :=
  match f with
  | Val a => Val a
  | Eps x =>
    match n with
    | O => Eps x
    | S n' => idx x n'
    end
  end.

CoInductive flat_ord {A : Type} : flat A -> flat A -> Prop :=
| flatEps  : forall x y, flat_ord x y -> flat_ord (Eps x) (Eps y)
| flatValR : forall x a, flat_ord x (Val a) -> flat_ord (Eps x) (Val a)
| flatValL : forall a y n, idx y n = Val a -> flat_ord (Val a) y.

Lemma ord_idx : forall {A : Type} n (x y : flat A) a,
    idx x n = Val a ->
    flat_ord x y ->
    exists m, idx y m = Val a.
Proof.
  induction n.
  - intros. inversion H0; subst.
    + simpl in H; discriminate.
    + simpl in H; discriminate.
    + simpl in H; inversion H; subst. exists n. assumption.
  - intros. inversion H0; subst.
    + simpl in H. apply (IHn _ _ _ H) in H1.
      destruct H1 as [m ?]. exists (S m). simpl; assumption.
    + simpl in H. apply (IHn _ _ _ H) in H1. assumption.
    + simpl in H; inversion H; subst. exists n0. assumption.
Qed.

Instance Flat_Preord (A : Type) : Preord (flat A) :=
  { ord := flat_ord }.
- cofix. destruct x.
  + apply flatEps. apply Flat_Preord.
  + apply flatValL with (n:=0). reflexivity.
- cofix. inversion 2; subst.
  + inversion H; subst.
    * constructor. eauto.
    * apply (ord_idx _ _ _ _ H2) in H0.
      destruct H0 as [m ?]. apply flatValL with (n0:=m). assumption.
  + inversion H; subst.
    * constructor; eauto.
    * apply (ord_idx _ _ _ _ H2) in H0.
      destruct H0 as [m ?]. apply flatValL with (n0:=m). assumption.
  + generalize dependent x.
    generalize dependent z. induction n; intros.
    * simpl in H1. destruct z; try discriminate.
      inversion H1; subst. assumption.
    * simpl in H1. destruct z.
      -- destruct x.
         ++ constructor. apply IHn; auto.
            ** inversion H0; subst.
               destruct n0; simpl in H3; try discriminate.
               econstructor; eassumption.
            ** inversion H; assumption.
         ++ inversion H; subst.
            destruct n0; simpl in H3; inversion H3; subst; assumption.
      -- inversion H1; subst. assumption.
Qed.

CoFixpoint flat_lub {A : Type} (c : Hom nat (flat A)) (m n : nat) : flat A :=
  match idx (c m) n with
  | Val a => Val a
  | Eps _ =>
    match m with
    | O => Eps (flat_lub c (n + 1) (n + 1))
    | S n' => Eps (flat_lub c (m - 1) n)
    end
  end.

Instance Flat_CPO (A : Type) : CPO (flat A) :=
  { lub c := flat_lub c 0 0 }.
Admitted.


Require Export CatSem.CAT.orders.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Instance Rel_Trans (A : PO_obj) : Transitive (Rel (T:=A)).
Proof.
  intros;
  apply POprf.
Qed.

Lemma Rel_refl (V : PO_obj) (x : V) : x << x.
Proof.
  reflexivity.
Qed.

Lemma Rel_eq (V : PO_obj) (x y : V) : x = y -> x << y.
Proof.
  intros;
  subst;
  reflexivity.
Qed.

Lemma Rel_eq_r (V : PO_obj) (x y z : V) :
    x << y -> y = z -> x << z.
Proof.
  intros;
  subst;
  auto.
Qed.

Lemma IRel_eq_l (V : PO_obj) (x y z : V) :
    x << z -> x = y -> y << z.
Proof.
  intros; subst; auto.
Qed.

Lemma Rel_trans (V : PO_obj) (x y z : V) :
       x << y -> y << z -> x << z.
Proof.
  intros;
  etransitivity;
  eauto.
Qed.

Lemma Rel_trans_2 (V : PO_obj) (x y z : V) :
       x << z -> y << x -> y << z.
Proof.
  intros;
  etransitivity;
  eauto.
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Export ZArith.
Local Open Scope Z_scope.

Coercion Zpos : positive >-> Z.
Coercion Z_of_N : N >-> Z.

Lemma Zpos_plus : forall p q, Zpos (p + q) = p + q.
Proof. intros;trivial. Qed.

Lemma Zpos_mult : forall p q, Zpos (p * q) = p * q.
Proof. intros;trivial. Qed.

Lemma Zpos_xI_add : forall p, Zpos (xI p) = Zpos p + Zpos p + Zpos 1.
Proof. intros p;rewrite Zpos_xI;ring. Qed.

Lemma Zpos_xO_add : forall p, Zpos (xO p) = Zpos p + Zpos p.
Proof. intros p;rewrite Zpos_xO;ring. Qed.

Lemma Psucc_Zplus : forall p, Zpos (Psucc p) = p + 1.
Proof. intros p;rewrite Zpos_succ_morphism;unfold Zsucc;trivial. Qed.

Hint Rewrite Zpos_xI_add Zpos_xO_add Pplus_carry_spec
 Psucc_Zplus Zpos_plus : zmisc.

Lemma Zlt_0_pos : forall p, 0 < Zpos p.
Proof. unfold Zlt;trivial. Qed.

Lemma Pminus_mask_carry_spec : forall p q,
  Pminus_mask_carry p q = Pminus_mask p (Psucc q).
Proof.
 intros p q;generalize q p;clear q p.
 induction q;destruct p;simpl;try rewrite IHq;trivial.
 destruct p;trivial.  destruct p;trivial.
Qed.

Hint Rewrite Pminus_mask_carry_spec : zmisc.

Ltac zsimpl := autorewrite with zmisc.
Ltac CaseEq t := generalize (refl_equal t);pattern t at -1;case t.
Ltac generalizeclear H := generalize H;clear H.

Lemma Pminus_mask_spec :
   forall p q,
    match Pminus_mask p q with
    | IsNul    => Zpos p =  Zpos q
    | IsPos k => Zpos p = q + k
    | IsNeq   => p < q
    end.
Proof with zsimpl;auto with zarith.
 induction p;destruct q;simpl;zsimpl;
  match goal with
  | [|- context [(Pminus_mask ?p1 ?q1)]] =>
    assert (H1 := IHp q1);destruct (Pminus_mask p1 q1)
  | _ => idtac
  end;simpl ...
 inversion H1 ...   inversion H1 ...
 rewrite Psucc_Zplus in H1 ...
 clear IHp;induction p;simpl ...
  rewrite IHp;destruct (Pdouble_minus_one p) ...
 assert (H:= Zlt_0_pos q) ...   assert (H:= Zlt_0_pos q) ...
Qed.

Definition PminusN x y :=
  match Pminus_mask x y with
  | IsPos k => Npos k
  | _ => N0
  end.

Lemma PminusN_le : forall x y:positive, x <= y -> Z_of_N (PminusN y x) = y - x.
Proof.
 intros x y Hle;unfold PminusN.
 assert (H := Pminus_mask_spec y x);destruct (Pminus_mask y x).
 rewrite H;unfold Z_of_N;auto with zarith.
 rewrite H;unfold Z_of_N;auto with zarith.
 elimtype False;omega.
Qed.

Lemma Ppred_Zminus : forall p, 1< Zpos p ->  (p-1)%Z = Ppred p.
Proof. destruct p;simpl;trivial. intros;elimtype False;omega. Qed.

Local Open Scope positive_scope.

Delimit Scope P_scope with P.
Local Open Scope P_scope.

Definition is_lt (n m : positive) :=
  match (n ?= m) with
  | Lt => true
  | _ => false
  end.
Infix "?<" := is_lt (at level 70, no associativity) : P_scope.

Lemma is_lt_spec : forall n m, if n ?< m then (n < m)%Z else (m <= n)%Z.
Proof.
intros n m; unfold is_lt, Zlt, Zle, Zcompare.
rewrite Pos.compare_antisym.
case (m ?= n); simpl; auto; intros HH; discriminate HH.
Qed.

Definition is_eq a b :=
  match (a ?= b) with
  | Eq => true
  | _ => false
  end.
Infix "?=" := is_eq (at level 70, no associativity) : P_scope.

Lemma is_eq_refl : forall n, n ?= n = true.
Proof. intros n;unfold is_eq;rewrite Pos.compare_refl;trivial. Qed.

Lemma is_eq_eq : forall n m, n ?= m = true -> n = m.
Proof.
 unfold is_eq;intros n m H; apply Pos.compare_eq.
destruct (n ?= m)%positive;trivial;try discriminate.
Qed.

Lemma is_eq_spec_pos : forall n m, if n ?= m then  n = m else  m <> n.
Proof.
 intros n m; CaseEq (n ?= m);intro H.
 rewrite (is_eq_eq _ _ H);trivial.
 intro H1;rewrite H1 in H;rewrite is_eq_refl in H;discriminate H.
Qed.

Lemma is_eq_spec : forall n m, if n ?= m then Zpos n = m else Zpos m <> n.
Proof.
 intros n m; CaseEq (n ?= m);intro H.
 rewrite (is_eq_eq _ _ H);trivial.
 intro H1;inversion H1.
 rewrite H2 in H;rewrite is_eq_refl in H;discriminate H.
Qed.

Definition is_Eq a b :=
  match a, b with
  | N0, N0 => true
  | Npos a', Npos b' => a' ?= b'
  | _, _ => false
  end.

Lemma is_Eq_spec :
 forall n m, if is_Eq n m then Z_of_N n = m else Z_of_N m <> n.
Proof.
 destruct n;destruct m;simpl;trivial;try (intro;discriminate).
 apply is_eq_spec.
Qed.

(* [times x y] return [x * y], a litle bit more efficiant *)
Fixpoint times (x y : positive) {struct y} : positive :=
  match x, y with
  | xH, _ => y
  | _, xH => x
  | xO x', xO y' => xO (xO (times x' y'))
  | xO x', xI y' => xO (x' + xO (times x' y'))
  | xI x', xO y' => xO (y' + xO (times x' y'))
  | xI x', xI y' => xI (x' + y' + xO (times x' y'))
  end.

Infix "*" := times : P_scope.

Lemma times_Zmult : forall p q, Zpos (p * q)%P = (p * q)%Z.
Proof.
 intros p q;generalize q p;clear p q.
 induction q;destruct p; unfold times; try fold (times p q);
   autorewrite with zmisc; try rewrite IHq; ring.
Qed.

Fixpoint square (x:positive) : positive :=
 match x with
 | xH => xH
 | xO x => xO (xO (square x))
 | xI x => xI (xO (square x + x))
 end.

Lemma square_Zmult : forall x, Zpos (square x) = (x * x) %Z.
Proof.
 induction x as [x IHx|x IHx |];unfold square;try (fold (square x));
   autorewrite with zmisc; try rewrite IHx; ring.
Qed.


Require Export Utf8.
Require Export LibVar.
Require Export LibListSorted.

(*** Definitions ***)

(*
Types in IS5 system:
  * base type
  * arrow type for functions
  * box type for universally true terms (= in all the worlds)
  * diamond type for existentially true terms (= in some of the worlds)
*)
Inductive ty :=
| tvar: ty
| tarrow: ty -> ty -> ty
| tbox: ty -> ty
.
Notation " A '--->' B " := (tarrow A B)
  (at level 30, right associativity) : is5_scope.
Notation " '[*]' A " := (tbox A)
  (at level 30) : is5_scope.

(*
Variables for worlds - bound and free
  We are using locally nameless representation for world variables.
*)
Inductive vwo :=
| bwo: nat -> vwo
| fwo: var -> vwo
.

(*
Variables for terms - bound and free
  We are using locally nameless representation for term variables.
*)
Inductive vte :=
| bte: nat -> vte
| fte: var -> vte
.

(* Free variable extraction *)

Definition var_from_vwo (w: vwo) :=
match w with
| fwo w0 => \{w0}
| bwo _ => \{}
end.

Definition var_from_vte (v: vte) :=
match v with
| fte v0 => \{v0}
| bte _ => \{}
end.

(* "shift by one" for bound variable *)

Definition shift_vwo (w: vwo) : vwo :=
match w with
  | fwo _ => w
  | bwo n => bwo (S n)
end.

Definition shift_vte (v: vte) : vte :=
match v with
| fte _ => v
| bte n => bte (S n)
end.

(*** Properties ***)

(* Decidability *)

(*
Decidability for var is not expressed in the library, so we need to
add an axiom for it.
*)
Axiom eq_var_dec:
  forall v1 v2: var, {v1 = v2} + {v1 <> v2}.

Theorem eq_ty_dec:
forall a b: ty, {a = b} + {a <> b}.
  decide equality.
Qed.

Theorem eq_vwo_dec:
forall w1 w2: vwo, {w1 = w2} + {w1 <> w2}.
  decide equality;
  [ decide equality |
    apply eq_var_dec].
Qed.

Theorem eq_vte_dec:
forall v1 v2: vte, {v1 = v2} + {v1 <> v2}.
  decide equality;
  [ decide equality |
    apply eq_var_dec].
Qed.

(* Generating new variable produces fresh variable *)
Lemma generate_fresh:
forall L w
  (HIn: w \in L),
  var_gen L <> w.
intros;
intro; subst;
absurd (var_gen L \in L);
[apply var_gen_spec | assumption].
Qed.

(* For every set of variables, we can generate a variable that is
   not within that set *)
Lemma Fresh:
forall (L: fset var), {w0 : var | w0 \notin L}.
intro;
exists (var_gen L);
apply var_gen_spec.
Qed.

(*** Shared definitions ***)

(* Background and context for hybrid language *)
Definition ctx_Hyb := prod var (list (prod var ty)).
Definition bg_Hyb := list ctx_Hyb.

(* Context for labeled language *)
Definition ctx_L := list (prod var (prod var ty)).

(* Background and context for label-free language *)
Definition ctx_LF := list (var * ty).
Definition bg_LF := list ctx_LF.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  rename.v                                                                *)
(*                                                                          *)
(*  This file contains the definition of renaming a                         *)
(*  variable in an expression, along with a related                         *)
(*  property.                                                               *)
(*                                                                          *)
(*                                                                          *)
(*  Jill Seaman                                                             *)
(*  Coq V5.8                                                                *)
(*  November  1993                                                          *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                 rename.v                                 *)
(****************************************************************************)

Require Import syntax.
Require Import freevars.

(********************************************************)
(* 							*)
(*  rename                                              *)
(* 							*)
(*  Inductively defines a relation between terms where  *)
(*  one variable is renamed by another. 		*)
(*							*)
(*   (rename nv v e1 e2)  <-->  e2 = e1[nv/v]		*)
(*							*)
(*							*)
(********************************************************)

Inductive rename : vari -> vari -> tm -> tm -> Prop :=
  | ren_o : forall nv v : vari, rename nv v o o
  | ren_ttt : forall nv v : vari, rename nv v ttt ttt
  | ren_fff : forall nv v : vari, rename nv v fff fff
  | ren_abs1 :
      forall (nv v : vari) (t : ty) (e : tm),
      rename nv v (abs v t e) (abs v t e)
  | ren_abs2 :
      forall (nv v x nx : vari) (t : ty) (e1 e2 e3 : tm),
      nv = x ->
      ~ FV nx e1 ->
      nx <> v ->
      nx <> nv ->
      rename nx x e1 e2 ->
      rename nv v e2 e3 -> rename nv v (abs x t e1) (abs nx t e3)
  | ren_abs3 :
      forall (nv v x : vari) (t : ty) (e ne : tm),
      v <> x ->
      nv <> x -> rename nv v e ne -> rename nv v (abs x t e) (abs x t ne)
  | ren_appl :
      forall (nv v : vari) (e1 e2 ne1 ne2 : tm),
      rename nv v e1 ne1 ->
      rename nv v e2 ne2 -> rename nv v (appl e1 e2) (appl ne1 ne2)
  | ren_cond :
      forall (nv v : vari) (e1 ne1 e2 ne2 e3 ne3 : tm),
      rename nv v e1 ne1 ->
      rename nv v e2 ne2 ->
      rename nv v e3 ne3 -> rename nv v (cond e1 e2 e3) (cond ne1 ne2 ne3)
  | ren_var_eq : forall nv v : vari, rename nv v (var v) (var nv)
  | ren_var_not_eq :
      forall nv v x : vari, v <> x -> rename nv v (var x) (var x)
  | ren_succ :
      forall (nv v : vari) (e ne : tm),
      rename nv v e ne -> rename nv v (succ e) (succ ne)
  | ren_prd :
      forall (nv v : vari) (e ne : tm),
      rename nv v e ne -> rename nv v (prd e) (prd ne)
  | ren_is_o :
      forall (nv v : vari) (e ne : tm),
      rename nv v e ne -> rename nv v (is_o e) (is_o ne)
  | ren_fix1 :
      forall (nv v : vari) (t : ty) (e : tm),
      rename nv v (Fix v t e) (Fix v t e)
  | ren_fix2 :
      forall (nv v x nx : vari) (t : ty) (e1 e2 e3 : tm),
      nv = x ->
      ~ FV nx e1 ->
      nx <> v ->
      nx <> nv ->
      rename nx x e1 e2 ->
      rename nv v e2 e3 -> rename nv v (Fix x t e1) (Fix nx t e3)
  | ren_fix3 :
      forall (nv v x : vari) (t : ty) (e ne : tm),
      v <> x ->
      nv <> x -> rename nv v e ne -> rename nv v (Fix x t e) (Fix x t ne)
  | ren_clos1 :
      forall (nv v : vari) (t : ty) (e a na : tm),
      rename nv v a na -> rename nv v (clos e v t a) (clos e v t na)
  | ren_clos2 :
      forall (nv v x nx : vari) (t : ty) (e e' ne a na : tm),
      nv = x ->
      ~ FV nx e ->
      nx <> v ->
      nx <> nv ->
      rename nx x e e' ->
      rename nv v e' ne ->
      rename nv v a na -> rename nv v (clos e x t a) (clos ne nx t na)
  | ren_clos3 :
      forall (nv v x : vari) (t : ty) (e ne a na : tm),
      v <> x ->
      nv <> x ->
      rename nv v e ne ->
      rename nv v a na -> rename nv v (clos e x t a) (clos ne x t na).

(************************)
(*  RenNotFree		*)
(*    [nx/x]e=ne --->	*)
(*    ~nx=x	--->	*)
(*    x not in FV(ne)	*)
(************************)

Goal
forall (nx x : vari) (e ne : tm), rename nx x e ne -> nx <> x -> ~ FV x ne.

   simple induction 1; simpl in |- *; intros.
   apply inv_FV_o.
   apply inv_FV_ttt.
   apply inv_FV_fff.
   red in |- *; intro F; specialize inv_FV_abs with (1 := F);
    simple induction 1; intros Fe N.
   apply N; reflexivity.
   red in |- *; intro F; specialize inv_FV_abs with (1 := F).
   simple induction 1; intros Fe3 N.
   red in H7; apply H7; assumption.
   red in |- *; intro F; specialize inv_FV_abs with (1 := F).
   simple induction 1; intros Fe N.
   red in H3; apply H3; assumption.
   red in |- *; intro F; specialize inv_FV_appl with (1 := F);
    simple induction 1.
   apply H1; assumption.
   apply H3; assumption.
   red in |- *; intro F; specialize inv_FV_cond with (1 := F);
    simple induction 1. apply H1; assumption.
   simple induction 1.
   apply H3; assumption.
   apply H5; assumption.
   red in |- *; intro F; specialize inv_FV_var with (1 := F).
   intro; apply H0; symmetry  in |- *; assumption.
   red in |- *; intro F; specialize inv_FV_var with (1 := F).  assumption.
   red in |- *; intro F; specialize inv_FV_succ with (1 := F).
   apply H1; assumption.
   red in |- *; intro F; specialize inv_FV_prd with (1 := F); apply H1;
    assumption.
   red in |- *; intro F; specialize inv_FV_is_o with (1 := F); apply H1;
    assumption.
   red in |- *; intro F; specialize inv_FV_fix with (1 := F);
    simple induction 1; intros Fe N.
   apply N; reflexivity.
   red in |- *; intro F; specialize inv_FV_fix with (1 := F).
   simple induction 1; intros Fe3 N.
   red in H7; apply H7; assumption.
   red in |- *; intro F; specialize inv_FV_fix with (1 := F).
   simple induction 1; intros Fe N.
   red in H3; apply H3; assumption.
   red in |- *; intro F; specialize inv_FV_clos with (1 := F).
   simple induction 1. apply H1; assumption.
   simple induction 1; intros Fe N.
   apply N; reflexivity.
   red in |- *; intro F; specialize inv_FV_clos with (1 := F).
   simple induction 1.  apply H9; assumption.
   simple induction 1; intros Fe3 N.
   red in H7; apply H7; assumption.
   red in |- *; intro F; specialize inv_FV_clos with (1 := F).
   simple induction 1.  apply H5; assumption.
   simple induction 1; intros Fe N.
   red in H3; apply H3; assumption.
Save RenNotFree.