Require Import Util EqDec LengthEq AllInRel Map Envs IL AutoIndTac MoreList Sawtooth.
Require Export DecSolve BlockType.

Set Implicit Arguments.

Inductive mutual_block {A} {B} `{BlockType B} {C} `{BlockType C} (R:A->B->C->Prop)
: nat -> list A -> list B -> list C -> Prop :=
  | CS_nil n : mutual_block R n nil nil nil
  | CS_cons a b c n AL L L' :
      mutual_block R (S n) AL L L'
      -> n = block_n b
      -> n = block_n c
      -> R a b c
      -> mutual_block R n (a::AL) (b::L) (c::L').

Lemma mutual_block_zero {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C) n b i
: mutual_block R i AL L L' -> get L n b -> block_n b = (n+i).
Proof.
  intros. general induction H2. inv H1; eauto.
  inv H1; eauto. erewrite IHget; eauto. omega.
Qed.

Lemma mutual_block_zero' {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C) n b i
: mutual_block R i AL L L' -> get L' n b -> block_n b = (n+i).
Proof.
  intros. general induction H2. inv H1; eauto.
  inv H1; eauto. erewrite (IHget _ _ _ _ _ _ _ _ H5); eauto. omega.
Qed.

Lemma mutual_block_length {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C) i
: mutual_block R i AL L L' -> length AL = length L /\ length L = length L'.
Proof.
  intros. general induction H1; dcr; simpl; eauto.
Qed.

Lemma mutual_block_get {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C) i n b
: mutual_block R i AL L L' -> get L n b ->
  exists a c, get AL n a /\ get L' n c /\ R a b c.
Proof.
  intros. general induction H2; inv H1; eauto using get.
  edestruct IHget as [? [? [? []]]]; try do 2 eexists; eauto using get.
Qed.

Lemma mutual_approx_impl {A} {B} `{BlockType B} {C} `{BlockType C}
      (R: list A -> list B -> list C -> A -> B -> C -> Prop)
      (AL:list A) DL F1 F2 AL' F1' F2' i L1 L2
  : length AL = length F1
    -> length F1 = length F2
    -> F1' = drop i F1
    -> F2' = drop i F2
    -> AL' = drop i AL
    -> (forall n a b b', get AL n a -> get F1 n b -> get F2 n b' -> R DL L1 L2 a b b')
    -> (forall i b, get F1 i b -> i = block_n b)
    -> (forall i b, get F2 i b -> i = block_n b)
    -> mutual_block (R DL L1 L2) i AL' F1' F2'.
Proof.
  intros LenEq1 LenEq2 LenF1' LenF2' LenAL' GET I1 I2.
  assert (LenAL1:length_eq AL' F1'). subst; eauto using drop_length_stable with len.
  assert (LenAL2:length_eq AL' F2'). subst; eauto using drop_length_stable with len.
  general induction LenAL1; eauto using @mutual_block.
  - econstructor; eauto using drop_eq.
    eapply IHLenAL1; eauto using drop_shift_1.
Qed.

Lemma mutual_approx {A} {B} `{BlockType B} {C} `{BlockType C}
      (R: list A -> list B -> list C -> A -> B -> C -> Prop)
      (AL:list A) DL F1 F2 L1 L2
  : length AL = length F1
    -> length F1 = length F2
    -> (forall n a b b', get AL n a -> get F1 n b -> get F2 n b' -> R DL L1 L2 a b b')
    -> (forall i b, get F1 i b -> i = block_n b)
    -> (forall i b, get F2 i b -> i = block_n b)
    -> mutual_block (R DL L1 L2) 0 AL F1 F2.
Proof.
  intros. eapply mutual_approx_impl; eauto.
Qed.

Lemma mutual_block_mon A B (H : BlockType B) (C : Type)
          (H0 : BlockType C)
          (R R': A -> B -> C -> Prop) AL L1 L2 n
:  mutual_block R n AL L1 L2
  -> (forall a b c, R a b c -> R' a b c)
  ->  mutual_block R' n AL L1 L2.
Proof.
  intros. general induction H1.
  - econstructor.
  - econstructor; eauto.
Qed.

Inductive inRel {A} {B} `{BlockType B} {C} `{BlockType C}
          (R:list A -> list B -> list C -> A -> B -> C -> Prop)
: list A -> list B -> list C -> Prop :=
  | LPM_nil : inRel R nil nil nil
  | LPM_app AL AL' L1 L2 L1' L2' :
      inRel R AL L1 L2
      -> mutual_block (R (AL'++AL) (L1'++L1) (L2'++L2)) 0 AL' L1' L2'
      -> inRel R (AL'++AL) (L1'++L1) (L2'++L2).

Lemma inRel_length {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C)
: inRel R AL L L' -> length AL = length L /\ length L = length L'.
Proof.
  intros. general induction H1; dcr; simpl; eauto.
  repeat rewrite app_length.
  exploit (mutual_block_length H2); eauto; dcr; omega.
Qed.

Lemma inRel_less {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C) n b
: inRel R AL L L' -> get L n b -> block_n b <= n.
Proof.
  intros. general induction H1.
  eapply get_app_cases in H3; destruct H3; dcr.
  erewrite mutual_block_zero; eauto. omega.
  rewrite IHinRel; try eapply H4. omega.
Qed.

Lemma inRel_drop {A} {B} `{BlockType B} {C} `{BlockType C} R
      (LT:list A) (L:list B) (L':list C) n b
: inRel R LT L L'
  -> get L n b
  -> inRel R
           (drop (n - block_n b) LT)
           (drop (n - block_n b) L)
           (drop (n - block_n b) L').
Proof.
  intros. general induction H1; simpl; eauto.
  - eapply get_app_cases in H3; destruct H3; dcr.
    + exploit (mutual_block_zero H2 H3); eauto.
      rewrite H4. orewrite (n - (n + 0)= 0). simpl; econstructor; eauto.
    + exploit (inRel_less H1 H4); eauto.
      specialize (IHinRel _ _ H4).
      assert (length L1' + (n - length L1') = n) by omega.
      rewrite <- H6.
      orewrite (length L1' + (n - length L1') - block_n b
                = length L1' + (n - length L1' - block_n b)).
      exploit (mutual_block_length H2). dcr.
      Typeclasses eauto := 5.
      rewrite <- H8 at 1.
      rewrite H9 at 4.
      repeat rewrite drop_app. eauto.
Qed.

Lemma inRel_nth {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C) n b
: inRel R AL L L' -> get L n b ->
  exists a:A, exists c:C,
    get AL n a /\ get L' n c /\ R (drop (n - block_n b) AL) (drop (n - block_n b) L) (drop (n - block_n b) L') a b c.
Proof.
  intros. general induction H1; isabsurd.
  eapply get_app_cases in H3; destruct H3; dcr.
  - exploit (mutual_block_zero H2 H3); eauto. rewrite H4.
    orewrite (n - (n + 0) = 0). simpl.
    edestruct (mutual_block_get H2 H3) as [? [? [? []]]].
    do 2 eexists. repeat split; eauto using get_app.
  - edestruct IHinRel; eauto; dcr. do 2 eexists.
    pose proof (mutual_block_length H2); dcr.
    repeat split; try (eapply get_app_right; eauto; omega).
    orewrite (n = length L1' + (n - length L1')).
    exploit (inRel_less H1 H4).
    orewrite (length L1' + (n - length L1') - block_n b
              = length L1' + (n - length L1' - block_n b)).
    Typeclasses eauto :=10.
    rewrite <- H8 at 1. repeat rewrite drop_app. rewrite H10. rewrite drop_app.
    rewrite <- H10. eauto.
Qed.

Lemma inRel_nthA {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C) n a
: inRel R AL L L' -> get AL n a ->
  exists b:B, exists c:C,
    get L n b /\ get L' n c /\ R (drop (n - block_n b) AL) (drop (n - block_n b) L) (drop (n - block_n b) L') a b c.
Proof.
  intros.
  exploit (inRel_length H1); eauto; dcr.
  edestruct (get_length_eq _ H2 H4); eauto.
  edestruct (inRel_nth H1 H3); eauto; dcr.
  get_functional; subst.
  do 2 eexists; split; eauto.
Qed.

Lemma inRel_nthC {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C) n c
: inRel R AL L L' -> get L' n c ->
  exists a:A, exists b:B,
    get AL n a /\ get L n b /\ R (drop (n - block_n b) AL) (drop (n - block_n b) L) (drop (n - block_n b) L') a b c.
Proof.
  intros.
  exploit (inRel_length H1); eauto; dcr.
  edestruct (get_length_eq _ H2 (eq_sym H5)); eauto.
  edestruct (inRel_nth H1 H3); eauto; dcr.
  get_functional; subst.
  do 2 eexists; split; eauto.
Qed.

Lemma inRel_mon A B (H : BlockType B) (C : Type)
          (H0 : BlockType C)
          (R R': list A -> list B -> list C -> A -> B -> C -> Prop) AL L1 L2
:  inRel R AL L1 L2
  -> (forall AL L1 L2 a b c, R AL L1 L2 a b c -> R' AL L1 L2 a b c)
  ->  inRel R' AL L1 L2.
Proof.
  intros. general induction H1.
  - econstructor.
  - econstructor; eauto using mutual_block_mon.
Qed.

Tactic Notation "inRel_invs" :=
match goal with
  | [ H : inRel ?R ?A ?B ?C, H' : get ?B ?n ?b |- _ ] =>
    let InR := fresh "InR" in let G := fresh "G" in
    edestruct (inRel_nth H H') as [? [? [? [G InR]]]]; (try eassumption); dcr; inversion InR; try subst;
    let X'' := fresh "H" in pose proof (inRel_drop H H') as X'';
    repeat get_functional; (try subst)
    (*match goal with
      | [ H' : get ?A ?n ?b, H'' : ?x :: ?DL = drop ?n ?Lv |- _ ] =>
         (try rewrite <- H'' in X'');
          let X' := fresh H in
         pose proof (get_drop_eq H' H'') as X'; inversion X'; try subst; try clear X'
    end *)
  | [ H : inRel ?R ?A ?B ?C, H' : get ?A ?n ?a |- _ ] =>
    let InR := fresh "InR" in let G := fresh "G" in
    edestruct (inRel_nthA H H') as [? [? [? [G InR]]]]; (try eassumption); dcr; inversion InR; try subst;
    repeat get_functional; (try subst)
    (*match goal with
      | [ H' : get ?A ?n ?b, H'' : ?x :: ?DL = drop ?n ?Lv |- _ ] =>
         (try rewrite <- H'' in X'');
          let X' := fresh H in
         pose proof (get_drop_eq H' H'') as X'; inversion X'; try subst; try clear X'
    end *)
  | [ H : inRel ?R ?A ?B ?C, H' : get ?C ?n ?c |- _ ] =>
    let InR := fresh "InR" in let G := fresh "G" in
    edestruct (inRel_nthC H H') as [? [? [? [G InR]]]]; (try eassumption); dcr; inversion InR; try subst;
    repeat get_functional; (try subst)
end.

Lemma mutual_block_tooth {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C) n
  : mutual_block R n AL L L'
    -> tooth n L /\ tooth n L'.
Proof.
  intros. general induction H1; eauto using @tooth.
Qed.

Lemma inRel_sawtooth {A} {B} `{BlockType B} {C} `{BlockType C} R
      (AL:list A) (L:list B) (L':list C)
  : inRel R AL L L'
    -> sawtooth L /\ sawtooth L'.
Proof.
  intros. general induction H1; eauto using @sawtooth.
  - eapply mutual_block_tooth in H2.
    split; econstructor; eauto.
Qed.


Generalizable All Variables.
Set Implicit Arguments.
Unset Strict Implicit.
Require Export setoid.

Declare Scope monoid_scope.
Delimit Scope monoid_scope with mnd.
Open Scope setoid_scope.
Open Scope monoid_scope.

Class IsMonoid `(mul : Binop supp) e :=
{
  assocm :> Associative mul;
  identm :> Identical mul e;
}.
#[global] Existing Instances assocm identm.

Structure Monoid := {
  mcarrier :> Setoid;
  mulm : Binop mcarrier;
  idm : mcarrier;

  monoidsprf : IsMonoid mulm idm
}.
#[global] Existing Instance monoidsprf.

Arguments mulm {_}.
Arguments idm {_}.

Notation "[ A | *: op , 1: id ]" :=
  (@Build_Monoid A op id _)
  (at level 0, A, op, id at level 99) : monoid_scope.
Notation "[ *: op , 1: id ]" := [ _ | *: op, 1: id]
  (at level 0, op, id at level 99) : monoid_scope.
Notation "(  * 'in' M  )" := (@mulm M) : monoid_scope.
Notation "( * )" := ( * in _ ) : monoid_scope.
Notation "g * h 'in' M" := (@mulm M g h)
  (at level 40, h at next level, left associativity)
  : monoid_scope.
Notation "g * h" := (g * h in _) : monoid_scope.
Notation "1 'in' M" := (@idm M)
  (at level 0, M at level 99, no associativity) : monoid_scope.
Notation "1" := (1 in _) : monoid_scope.

Section MonoidTheory.
  Context {M : Monoid}.
  Implicit Types x y g : M.

  Lemma mulmA : forall {x y z}, x * (y * z) == (x * y) * z.
  Proof. now destruct M as [a b c [[e] f]]. Qed.

  Lemma mulm1 : forall {x}, x * 1 == x.
  Proof. now destruct M as [a b c [[e] [f [g]]]]. Qed.

  Lemma mul1m : forall {x}, 1 * x == x.
  Proof. now destruct M as [a b c [[e] [[f] g]]]. Qed.
End MonoidTheory.

Ltac existsS T :=
  let H := fresh "H" in
  apply sigS_exists; exists T; simpl;
  match goal with
  | |- exists _ : ?P, _ => assert P as H
  end; [intuition |exists H].

Program Canonical Structure ensmulM {M : Monoid} :=
  [ {ens M} | *: imens2 ( * in M ), 1: [ == 1] ].
Next Obligation.
  split; split.
  - intros A B C. split.
  + intros [a [[m [b [c E]]] E0]].
    existsS (a * b); [now exists a, b | exists c].
    now rewrite <-assoc, <-E, <-E0.
  + intros [[m [a [b E]]] [c E0]].
    exists a. existsS (b * c). now exists b, c.
    now rewrite assoc, <-E, <-E0.
  - split. intros A. split.
  + intros [[i I] [[a Aa] E]]. simpl in *.
    now rewrite <-H, E, I, mul1m.
  + intros Ay. existsS (1 in M).
    existsS y. now rewrite mul1m.
  - split. intros A. split.
  + intros [[a Aa] [[i I] E]]. simpl in *.
    now rewrite <-H, E, I, mulm1.
  + intros Ay. existsS y.
    existsS (1 in M). now rewrite identr.
Defined.

Close Scope monoid_scope.
Close Scope setoid_scope.


Require Import
  HoTT.Classes.implementations.peano_naturals
  HoTT.Classes.implementations.natpair_integers
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.rationals
  HoTT.Classes.interfaces.orders
  HoTT.Classes.theory.groups
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.dec_fields
  HoTT.Classes.orders.sum
  HoTT.Classes.orders.dec_fields
  HoTT.Classes.orders.lattices
  HoTT.Classes.theory.additional_operations
  HoTT.Classes.tactics.ring_quote
  HoTT.Classes.tactics.ring_tac.

Import Quoting.Instances.
Import NatPair.Instances.
Local Set Universe Minimization ToSet.

Section contents.
Context `{Funext} `{Univalence}.
Universe UQ.
Context {Q : Type@{UQ} } {Qap : Apart@{UQ UQ} Q}
  {Qplus : Plus Q} {Qmult : Mult Q}
  {Qzero : Zero Q} {Qone : One Q} {Qneg : Negate Q} {Qrecip : DecRecip Q}
  {Qle : Le@{UQ UQ} Q} {Qlt : Lt@{UQ UQ} Q}
  {QtoField : RationalsToField@{UQ UQ UQ UQ} Q}
  {Qrats : Rationals@{UQ UQ UQ UQ UQ UQ UQ UQ UQ UQ} Q}
  {Qtrivialapart : TrivialApart Q} {Qdec : DecidablePaths Q}
  {Qmeet : Meet Q} {Qjoin : Join Q} {Qlattice : LatticeOrder Qle}
  {Qle_total : TotalRelation (@le Q _)}
  {Qabs : Abs Q}.

Global Instance rational_1_neq_0 : PropHolds (@apart Q _ 1 0).
Proof.
red. apply trivial_apart. solve_propholds.
Qed.

Record Qpos@{} : Type@{UQ} := mkQpos { pos : Q; is_pos : 0 < pos }.
Notation "Q+" := Qpos.

Global Instance Qpos_Q@{} : Cast Qpos Q := pos.
Arguments Qpos_Q /.

Lemma Qpos_plus_pr@{} : forall a b : Qpos, 0 < 'a + 'b.
Proof.
intros.
apply semirings.pos_plus_compat;apply is_pos.
Qed.

Global Instance Qpos_plus@{} : Plus Qpos := fun a b => mkQpos _ (Qpos_plus_pr a b).

Global Instance pos_is_pos@{} : forall q : Q+, PropHolds (0 < ' q)
  := is_pos.

Lemma pos_eq@{} : forall a b : Q+, @paths Q (' a) (' b) -> a = b.
Proof.
intros [a Ea] [b Eb] E.
change (a = b) in E.
destruct E;apply ap;apply path_ishprop.
Qed.

Global Instance Qpos_isset : IsHSet Q+.
Proof.
apply (@HSet.ishset_hrel_subpaths _ (fun e d => ' e = ' d)).
- intros e; reflexivity.
- apply _.
- exact pos_eq.
Qed.

Global Instance Qpos_one@{} : One Q+.
Proof.
exists 1. apply lt_0_1.
Defined.

Global Instance Qpos_mult@{} : Mult Q+.
Proof.
intros a b;exists (' a * ' b).
solve_propholds.
Defined.

Global Instance qpos_plus_comm@{} : Commutative (@plus Q+ _).
Proof.
hnf. intros.
apply pos_eq. change (' x + ' y = ' y + ' x).
apply plus_comm.
Qed.

Global Instance qpos_mult_comm@{} : Commutative (@mult Q+ _).
Proof.
hnf;intros;apply pos_eq,mult_comm.
Qed.

Global Instance pos_recip@{} : DecRecip Q+.
Proof.
intros e. exists (/ ' e).
apply pos_dec_recip_compat.
solve_propholds.
Defined.

Global Instance pos_of_nat@{} : Cast nat Q+.
Proof.
intros n. destruct n as [|k].
- exists 1;apply lt_0_1.
- exists (naturals_to_semiring nat Q (S k)).
  induction k as [|k Ik].
  + change (0 < 1). apply lt_0_1.
  + change (0 < 1 + naturals_to_semiring nat Q (S k)).
    set (K := naturals_to_semiring nat Q (S k)) in *;clearbody K.
    apply pos_plus_compat.
    * apply lt_0_1.
    * trivial.
Defined.

Lemma pos_recip_r@{} : forall e : Q+, e / e = 1.
Proof.
intros;apply pos_eq.
unfold dec_recip,cast,pos_recip;simpl.
change (' e / ' e = 1). apply dec_recip_inverse.
apply lt_ne_flip. solve_propholds.
Qed.

Lemma pos_recip_r'@{} : forall e : Q+, @paths Q (' e / ' e) 1.
Proof.
intros. change (' (e / e) = 1). rewrite pos_recip_r. reflexivity.
Qed.

Lemma pos_mult_1_r@{} : forall e : Q+, e * 1 = e.
Proof.
intros;apply pos_eq. apply mult_1_r.
Qed.

Lemma pos_split2@{} : forall e : Q+, e = e / 2 + e / 2.
Proof.
intros.
path_via (e * (2 / 2)).
- rewrite pos_recip_r,pos_mult_1_r;reflexivity.
- apply pos_eq. change (' e * (2 / 2) = ' e / 2 + ' e / 2).
  ring_tac.ring_with_nat.
Qed.

Lemma pos_split3@{} : forall e : Q+, e = e / 3 + e / 3 + e / 3.
Proof.
intros.
path_via (e * (3 / 3)).
- rewrite pos_recip_r,pos_mult_1_r;reflexivity.
- apply pos_eq. change (' e * (3 / 3) = ' e / 3 + ' e / 3 + ' e / 3).
  ring_tac.ring_with_nat.
Qed.

Global Instance Qpos_mult_assoc@{} : Associative (@mult Q+ _).
Proof.
hnf.
intros;apply pos_eq.
apply mult_assoc.
Qed.

Global Instance Qpos_plus_assoc@{} : Associative (@plus Q+ _).
Proof.
hnf.
intros;apply pos_eq.
apply plus_assoc.
Qed.

Global Instance Qpos_mult_1_l@{} : LeftIdentity (@mult Q+ _) 1.
Proof.
hnf;intros;apply pos_eq;apply mult_1_l.
Qed.

Global Instance Qpos_mult_1_r@{} : RightIdentity (@mult Q+ _) 1.
Proof.
hnf;intros;apply pos_eq;apply mult_1_r.
Qed.

Lemma pos_recip_through_plus@{} : forall a b c : Q+,
  a + b = c * (a / c + b / c).
Proof.
intros. path_via ((a + b) * (c / c)).
- rewrite pos_recip_r;apply pos_eq,symmetry,mult_1_r.
- apply pos_eq;ring_tac.ring_with_nat.
Qed.

Lemma pos_unconjugate@{} : forall a b : Q+, a * b / a = b.
Proof.
intros. path_via (a / a * b).
- apply pos_eq;ring_tac.ring_with_nat.
- rewrite pos_recip_r;apply Qpos_mult_1_l.
Qed.

Lemma Qpos_recip_1 : / 1 = 1 :> Q+.
Proof.
apply pos_eq. exact dec_recip_1.
Qed.

Lemma Qpos_plus_mult_distr_l : @LeftDistribute Q+ mult plus.
Proof.
hnf. intros;apply pos_eq,plus_mult_distr_l.
Qed.

Global Instance Qpos_meet@{} : Meet Q+.
Proof.
intros a b. exists (meet (' a) (' b)).
apply not_le_lt_flip. intros E.
destruct (total_meet_either (' a) (' b)) as [E1|E1];
rewrite E1 in E;(eapply le_iff_not_lt_flip;[exact E|]);
solve_propholds.
Defined.

Global Instance Qpos_join@{} : Join Q+.
Proof.
intros a b. exists (join (' a) (' b)).
apply not_le_lt_flip. intros E.
destruct (total_join_either (' a) (' b)) as [E1|E1];
rewrite E1 in E;(eapply le_iff_not_lt_flip;[exact E|]);
solve_propholds.
Defined.

Lemma Q_sum_eq_join_meet@{} : forall a b c d : Q, a + b = c + d ->
  a + b = join a c + meet b d.
Proof.
intros ???? E.
destruct (total le a c) as [E1|E1].
- rewrite (join_r _ _ E1). rewrite meet_r;trivial.
  apply (order_preserving (+ b)) in E1.
  rewrite E in E1. apply (order_reflecting (c +)). trivial.
- rewrite (join_l _ _ E1).
  rewrite meet_l;trivial.
  apply (order_reflecting (a +)). rewrite E. apply (order_preserving (+ d)).
  trivial.
Qed.

Lemma Qpos_sum_eq_join_meet@{} : forall a b c d : Q+, a + b = c + d ->
  a + b = join a c + meet b d.
Proof.
intros ???? E.
apply pos_eq;apply Q_sum_eq_join_meet.
change (' a + ' b) with (' (a + b)). rewrite E;reflexivity.
Qed.

Lemma Qpos_le_lt_min : forall a b : Q+, ' a <= ' b ->
  exists c ca cb, a = c + ca /\ b = c + cb.
Proof.
intros a b E. exists (a/2),(a/2).
simple refine (exist _ _ _);simpl.
- exists (' (a / 2) + (' b - ' a)).
  apply nonneg_plus_lt_compat_r.
  + apply (snd (flip_nonneg_minus _ _)). trivial.
  + solve_propholds.
- split.
  + apply pos_split2.
  + apply pos_eq. unfold cast at 2;simpl.
    unfold cast at 3;simpl.
    set (a':=a/2);rewrite (pos_split2 a);unfold a';clear a'.
    ring_tac.ring_with_integers (NatPair.Z nat).
Qed.

Lemma Qpos_lt_min@{} : forall a b : Q+, exists c ca cb : Q+,
  a = c + ca /\ b = c + cb.
Proof.
intros.
destruct (total le (' a) (' b)) as [E|E].
- apply Qpos_le_lt_min;trivial.
- apply Qpos_le_lt_min in E. destruct E as [c [cb [ca [E1 E2]]]].
  exists c,ca,cb;auto.
Qed.

Definition Qpos_diff : forall q r : Q, q < r -> Q+.
Proof.
intros q r E;exists (r-q).
apply (snd (flip_pos_minus _ _) E).
Defined.

Lemma Qpos_diff_pr@{} : forall q r E, r = q + ' (Qpos_diff q r E).
Proof.
intros q r E. change (r = q + (r - q)).
abstract ring_tac.ring_with_integers (NatPair.Z nat).
Qed.

Lemma Qmeet_plus_l : forall a b c : Q, meet (a + b) (a + c) = a + meet b c.
Proof.
intros. destruct (total le b c) as [E|E].
- rewrite (meet_l _ _ E). apply meet_l.
  apply (order_preserving (a +)),E.
- rewrite (meet_r _ _ E). apply meet_r.
  apply (order_preserving (a +)),E.
Qed.

Lemma Qabs_nonneg@{} : forall q : Q, 0 <= abs q.
Proof.
intros q;destruct (total_abs_either q) as [E|E];destruct E as [E1 E2];rewrite E2.
- trivial.
- apply flip_nonneg_negate.
 rewrite involutive;trivial.
Qed.

Lemma Qabs_nonpos_0@{} : forall q : Q, abs q <= 0 -> q = 0.
Proof.
intros q E. pose proof (antisymmetry le _ _ E (Qabs_nonneg _)) as E1.
destruct (total_abs_either q) as [[E2 E3]|[E2 E3]];rewrite E3 in E1.
- trivial.
- apply (injective (-)). rewrite negate_0. trivial.
Qed.

Lemma Qabs_0_or_pos : forall q : Q, q = 0 |_| 0 < abs q.
Proof.
intros q. destruct (le_or_lt (abs q) 0) as [E|E].
- left. apply Qabs_nonpos_0. trivial.
- right. trivial.
Qed.

Lemma Qabs_of_nonneg@{} : forall q : Q, 0 <= q -> abs q = q.
Proof.
intro;apply ((abs_sig _).2).
Qed.

Lemma Qabs_of_nonpos : forall q : Q, q <= 0 -> abs q = - q.
Proof.
intro;apply ((abs_sig _).2).
Qed.

Lemma Qabs_le_raw@{} : forall x : Q, x <= abs x.
Proof.
intros x;destruct (total_abs_either x) as [[E1 E2]|[E1 E2]].
- rewrite E2;reflexivity.
- transitivity (0:Q);trivial.
  rewrite E2. apply flip_nonpos_negate. trivial.
Qed.

Lemma Qabs_neg@{} : forall x : Q, abs (- x) = abs x.
Proof.
intros x. destruct (total_abs_either x) as [[E1 E2]|[E1 E2]].
- rewrite E2. path_via (- - x);[|rewrite involutive;trivial].
  apply ((abs_sig (- x)).2). apply flip_nonneg_negate;trivial.
- rewrite E2. apply ((abs_sig (- x)).2). apply flip_nonpos_negate;trivial.
Qed.

Lemma Qabs_le_neg_raw : forall x : Q, - x <= abs x.
Proof.
intros x. rewrite <-Qabs_neg. apply Qabs_le_raw.
Qed.

Lemma Q_abs_le_pr@{} : forall x y : Q, abs x <= y <-> - y <= x /\ x <= y.
Proof.
intros x y;split.
- intros E. split.
  + apply flip_le_negate. rewrite involutive. transitivity (abs x);trivial.
    apply Qabs_le_neg_raw.
  + transitivity (abs x);trivial.
    apply Qabs_le_raw.
- intros [E1 E2].
  destruct (total_abs_either x) as [[E3 E4]|[E3 E4]];rewrite E4.
  + trivial.
  + apply flip_le_negate;rewrite involutive;trivial.
Qed.

Lemma Qabs_is_join@{} : forall q : Q, abs q = join (- q) q.
Proof.
intros q. symmetry.
destruct (total_abs_either q) as [[E1 E2]|[E1 E2]];rewrite E2.
- apply join_r. transitivity (0:Q);trivial.
  apply flip_nonneg_negate;trivial.
- apply join_l. transitivity (0:Q);trivial.
  apply flip_nonpos_negate;trivial.
Qed.

Lemma Qlt_join : forall a b c : Q, a < c -> b < c ->
  join a b < c.
Proof.
intros a b c E1 E2.
destruct (total le a b) as [E3|E3];rewrite ?(join_r _ _ E3),?(join_l _ _ E3);
trivial.
Qed.

Lemma Q_average_between@{} : forall q r : Q, q < r -> q < (q + r) / 2 < r.
Proof.
intros q r E.
split.
- apply flip_pos_minus.
  assert (Hrw : (q + r) / 2 - q = (r - q) / 2);[|rewrite Hrw;clear Hrw].
  { path_via ((q + r) / 2 - 2 / 2 * q).
    { rewrite dec_recip_inverse;[|solve_propholds].
      rewrite mult_1_l;trivial.
    }
    ring_tac.ring_with_integers (NatPair.Z nat).
  }
  apply pos_mult_compat;[|apply _].
  red. apply (snd (flip_pos_minus _ _)). trivial.
- apply flip_pos_minus.
  assert (Hrw : r - (q + r) / 2 = (r - q) / 2);[|rewrite Hrw;clear Hrw].
  { path_via (2 / 2 * r - (q + r) / 2).
    { rewrite dec_recip_inverse;[|solve_propholds].
      rewrite mult_1_l;trivial.
    }
    ring_tac.ring_with_integers (NatPair.Z nat).
  }
  apply pos_mult_compat;[|apply _].
  red. apply (snd (flip_pos_minus _ _)). trivial.
Qed.

Lemma path_avg_split_diff_l (q r : Q) : q + ((r - q) / 2) = (r + q) / 2.
Proof.
  pattern q at 1.
  rewrite <- (mult_1_r q).
  pattern (1 : Q) at 1.
  rewrite <- (dec_recip_inverse 2) by solve_propholds.
  rewrite (associativity q 2 (/2)).
  rewrite <- (distribute_r (q*2) (r-q) (/2)).
  rewrite (distribute_l q 1 1).
  rewrite (mult_1_r q).
  rewrite (commutativity (q+q) (r-q)).
  rewrite <- (associativity r (-q) (q+q)).
  rewrite (associativity (-q) q q).
  rewrite (plus_negate_l q).
  rewrite (plus_0_l q).
  reflexivity.
Qed.

Lemma path_avg_split_diff_r (q r : Q) : r - ((r - q) / 2) = (r + q) / 2.
Proof.
  pattern r at 1.
  rewrite <- (mult_1_r r).
  pattern (1 : Q) at 1.
  rewrite <- (dec_recip_inverse 2) by solve_propholds.
  rewrite (associativity r 2 (/2)).
  rewrite negate_mult_distr_l.
  rewrite <- (distribute_r (r*2) (-(r-q)) (/2)).
  rewrite (distribute_l r 1 1).
  rewrite (mult_1_r r).
  rewrite (commutativity (r+r) (-(r-q))).
  rewrite <- negate_swap_r.
  rewrite <- (associativity q (-r) (r+r)).
  rewrite (associativity (-r) r r).
  rewrite (plus_negate_l r).
  rewrite (plus_0_l r).
  rewrite (plus_comm q r).
  reflexivity.
Qed.

Lemma pos_gt_both : forall a b : Q, forall e, a < ' e -> b < ' e ->
  exists d d', a < ' d /\ b < ' d /\ e = d + d'.
Proof.
assert (Haux : forall a b : Q, a <= b -> forall e, a < ' e -> b < ' e ->
  exists d d', a < ' d /\ b < ' d /\ e = d + d').
{ intros a b E e E1 E2.
  pose proof (Q_average_between _ _ (Qlt_join _ 0 _ E2 prop_holds)) as [E3 E4].
  exists (mkQpos _ (le_lt_trans _ _ _ (join_ub_r _ _) E3)).
  unfold cast at 1 4;simpl.
  exists (Qpos_diff _ _ E4).
  repeat split.
  - apply le_lt_trans with b;trivial.
    apply le_lt_trans with (join b 0);trivial.
    apply join_ub_l.
  - apply le_lt_trans with (join b 0);trivial. apply join_ub_l.
  - apply pos_eq. unfold cast at 2;simpl. unfold cast at 2;simpl.
    unfold cast at 3;simpl.
    abstract ring_tac.ring_with_integers (NatPair.Z nat).
}
intros a b e E1 E2. destruct (total le a b) as [E|E];auto.
destruct (Haux _ _ E e) as [d [d' [E3 [E4 E5]]]];trivial.
eauto.
Qed.

Lemma two_fourth_is_one_half@{} : 2/4 =  1/2 :> Q+.
Proof.
assert (Hrw : 4 = 2 * 2 :> Q) by ring_tac.ring_with_nat.
apply pos_eq. repeat (unfold cast;simpl).
rewrite Hrw;clear Hrw.
rewrite dec_recip_distr.
rewrite mult_assoc. rewrite dec_recip_inverse;[|solve_propholds].
reflexivity.
Unshelve. exact (fun _ => 1). (* <- wtf *)
Qed.

Lemma Q_triangle_le : forall q r : Q, abs (q + r) <= abs q + abs r.
Proof.
intros. rewrite (Qabs_is_join (q + r)).
apply join_le.
- rewrite negate_plus_distr.
  apply plus_le_compat;apply Qabs_le_neg_raw.
- apply plus_le_compat;apply Qabs_le_raw.
Qed.

Lemma Qabs_triangle_alt_aux : forall x y : Q, abs x - abs y <= abs (x - y).
Proof.
intros q r.
apply (order_reflecting (+ (abs r))).
assert (Hrw : abs q - abs r + abs r = abs q)
  by ring_tac.ring_with_integers (NatPair.Z nat);
rewrite Hrw;clear Hrw.
etransitivity;[|apply Q_triangle_le].
assert (Hrw : q - r + r = q)
  by ring_tac.ring_with_integers (NatPair.Z nat);
rewrite Hrw;clear Hrw.
reflexivity.
Qed.

Lemma Qabs_triangle_alt : forall x y : Q, abs (abs x - abs y) <= abs (x - y).
Proof.
intros q r.
rewrite (Qabs_is_join (abs q - abs r)).
apply join_le.
- rewrite <-(Qabs_neg (q - r)),<-!negate_swap_r.
  apply Qabs_triangle_alt_aux.
- apply Qabs_triangle_alt_aux.
Qed.

Lemma Q_dense@{} : forall q r : Q, q < r -> exists s, q < s < r.
Proof.
intros q r E;econstructor;apply Q_average_between,E.
Qed.

Lemma Qabs_neg_flip@{} : forall a b : Q, abs (a - b) = abs (b - a).
Proof.
intros a b.
rewrite <-Qabs_neg. rewrite <-negate_swap_r. trivial.
Qed.

Definition pos_of_Q : Q -> Q+
  := fun q => {| pos := abs q + 1;
    is_pos := le_lt_trans _ _ _ (Qabs_nonneg q)
                (fst (pos_plus_lt_compat_r _ _) lt_0_1) |}.

Lemma Q_abs_plus_1_bounds@{} : forall q : Q,
  - ' (pos_of_Q q) ≤ q
  ≤ ' (pos_of_Q q).
Proof.
intros. change (- (abs q + 1) ≤ q ≤ (abs q + 1)). split.
- apply flip_le_negate. rewrite involutive.
  transitivity (abs q).
  + apply Qabs_le_neg_raw.
  + apply nonneg_plus_le_compat_r. solve_propholds.
- transitivity (abs q).
  + apply Qabs_le_raw.
  + apply nonneg_plus_le_compat_r. solve_propholds.
Qed.

Lemma Qabs_mult@{} : forall a b : Q, abs (a * b) = abs a * abs b.
Proof.
intros a b.
destruct (total_abs_either a) as [Ea|Ea];destruct Ea as [Ea1 Ea2];rewrite Ea2;
destruct (total_abs_either b) as [Eb|Eb];destruct Eb as [Eb1 Eb2];rewrite Eb2.
- apply ((abs_sig (a*b)).2). apply nonneg_mult_compat;trivial.
- rewrite <-negate_mult_distr_r.
  apply ((abs_sig (a*b)).2). apply nonneg_nonpos_mult;trivial.
- rewrite <-negate_mult_distr_l.
  apply ((abs_sig (a*b)).2). apply nonpos_nonneg_mult;trivial.
- rewrite negate_mult_negate. apply ((abs_sig (a*b)).2).
  apply nonpos_mult;trivial.
Qed.

Lemma Qpos_neg_le@{} : forall a : Q+, - ' a <= ' a.
Proof.
intros a;apply between_nonneg;solve_propholds.
Qed.

Definition Qpos_upper (e : Q+) := exists x : Q, ' e <= x.

Definition Qpos_upper_inject e : Q -> Qpos_upper e.
Proof.
intros x. exists (join x (' e)). apply join_ub_r.
Defined.

Global Instance QLe_dec : forall q r : Q, Decidable (q <= r).
Proof.
intros q r;destruct (le_or_lt q r).
- left;trivial.
- right;intros ?. apply (irreflexivity lt q).
  apply le_lt_trans with r;trivial.
Qed.

Global Instance QLt_dec : forall q r : Q, Decidable (q < r).
Proof.
intros q r;destruct (le_or_lt r q).
- right;intros ?. apply (irreflexivity lt q).
  apply lt_le_trans with r;trivial.
- left;trivial.
Qed.

Section enumerable.
Context `{Enumerable Q}.

Definition Qpos_enumerator : nat -> Q+.
Proof.
intros n.
destruct (le_or_lt (enumerator Q n) 0) as [E|E].
- exact 1.
- exists (enumerator Q n);trivial.
Defined.

Lemma Qpos_is_enumerator :
  IsSurjection@{UQ} Qpos_enumerator.
Proof.
apply BuildIsSurjection.
unfold hfiber.
intros e;generalize (@center _ (enumerator_issurj Q (' e))). apply (Trunc_ind _).
intros [n E]. apply tr;exists n.
unfold Qpos_enumerator. destruct (le_or_lt (enumerator Q n) 0) as [E1|E1].
- destruct (irreflexivity lt 0). apply lt_le_trans with (enumerator Q n);trivial.
  rewrite E;solve_propholds.
- apply pos_eq,E.
Qed.

Global Instance Qpos_enumerable : Enumerable Q+.
Proof.
  exists Qpos_enumerator.
  first [exact Qpos_is_enumerator@{Uhuge Ularge}|
         exact Qpos_is_enumerator@{}].
Qed.

End enumerable.

End contents.

Arguments Qpos Q {_ _}.


Require Import Gappa_common.

Theorem neg_nzr :
  forall x : R,
  NZR x ->
  NZR (-x).
Proof.
unfold NZR.
intros x Hx.
contradict Hx.
rewrite <- (Ropp_involutive x), Hx.
apply Ropp_0.
Qed.

Theorem mul_nzr :
  forall x y : R,
  NZR x -> NZR y ->
  NZR (x * y).
Proof.
intros x y Hx Hy.
apply Rmult_integral_contrapositive.
now split.
Qed.

Theorem div_nzr :
  forall x y : R,
  NZR x -> NZR y ->
  NZR (x / y).
Proof.
intros x y Hx Hy.
apply Rmult_integral_contrapositive.
split.
exact Hx.
now apply Rinv_neq_0_compat.
Qed.

Theorem nzr_of_abs :
  forall z : R, forall zi : FF,
  ABS z zi ->
  Fpos (lower zi) = true ->
  NZR z.
Proof.
intros z zi Hz Hb.
generalize (Fpos_correct _ Hb). clear Hb. intro H.
case (Rcase_abs z) ; intro.
apply Rlt_not_eq with (1 := r).
rewrite <- (Rabs_right z r).
unfold NZR.
apply Rgt_not_eq.
apply Rlt_le_trans with (1 := H) (2 := proj1 (proj2 Hz)).
Qed.

Theorem nzr_of_nzr_rel :
  forall z zr : R, forall zi : FF,
  NZR zr ->
  REL z zr zi ->
  Flt2_m1 (lower zi) = true ->
  NZR z.
Proof.
intros z zr zi Hn (ze,(Hz1,Hz2)) H1.
apply Flt2_m1_correct in H1.
rewrite Hz2.
apply prod_neq_R0.
exact Hn.
apply Rgt_not_eq.
apply Rlt_le_trans with (1 + lower zi)%R.
rewrite <- (Rplus_opp_r 1).
apply Rplus_lt_compat_l.
exact H1.
apply Rplus_le_compat_l.
apply Hz1.
Qed.

Theorem nzr_of_nzr_rel_rev :
  forall z zr : R, forall zi : FF,
  NZR z ->
  REL z zr zi ->
  NZR zr.
Proof.
intros z zr zi Hn (ze,(Hz1,Hz2)) H1.
apply Hn.
rewrite Hz2, H1.
apply Rmult_0_l.
Qed.


Require Import cliqueColorable.
Require Import colorVarsToClique.
Require Import colorConvStack.
Require Import colorImpliesSAT.

(*tacitic for solving set membership goals*)
Ltac inSet :=
  match goal with
      |H:Ensembles.In _ (Add _ ?x ?y) ?z |- _ => inv H
      |H:Ensembles.In _ (Singleton _ ?x) ?y |- _ => inv H
  end.

Theorem KColorNPC : forall Gamma Delta F C eta G eta' U,
                      reduce Gamma Delta F G ->
                      valid Gamma C F eta' eta -> unique U Delta ->
                      (SAT' eta F <-> coloring eta' G C).
Proof.
  intros. inv H. split; intros.
  {constructor.
   {inv H0. eapply convStackColorable in H2; eauto. rewrite mult_comm. auto. }
   {constructor.
    {inv H0. eapply colorWeakening. eapply cliqueColorable; eauto. }
    {inv H0. apply colorWeakening. eapply varsToCliqueColorable; eauto. }
   }
  }
  {inv H0. inv H. inv H11. eapply colorImpliesSAT. eauto. eauto. eapply H9.
   auto. eauto. rewrite mult_comm. eauto. }
Qed.

Theorem buildCtxtUnique : forall i Gamma Delta U,
                            buildCtxt i = (Gamma, Delta) ->
                            (forall x, Ensembles.In vvar U x -> S x > i) ->
                            unique U Delta.
Proof.
  induction i; intros.
  {inv H. constructor. }
  {simpl in *. destruct (buildCtxt i). inv H. constructor. eapply IHi.
   reflexivity. intros. inv H. apply H0 in H1. omega. inv H1. omega.
   intro. apply H0 in H. omega. }
Qed.

(*TODO: we need to somehow relate n to the number of unique variables in F*)
Theorem KColorNPCTopLevel : forall Gamma Delta F n G eta eta',
                              buildCtxt n = (Gamma, Delta) ->
                              reduce Gamma Delta F G -> valid Gamma (n+1) F eta' eta ->
                              (SAT' eta F <-> coloring eta' G (n+1)).
Proof.
  intros. apply buildCtxtUnique with (U:=Empty_set _) in H. Focus 2. intros.
  inv H2. eapply KColorNPC in H0; eauto.
Qed.


Require Import CoqStock.Invs.
Require Import CoqStock.List.
Require Import CoqStock.Listerine.
Require Import CoqStock.Untie.
Require Import CoqStock.WreckIt.

Require Import Brzozowski.Alphabet.
Require Import Brzozowski.ConcatLang.
Require Import Brzozowski.Language.
Require Import Brzozowski.LogicOp.
Require Import Brzozowski.Regex.

(*
The introduction of arbitrary Boolean functions enriches the language of regular expressions.
For example, suppose we desire to represent the set of all sequences having three consecutive 1's
but not those ending in 01 or consisting of 1's only.
The desired expression is easily seen to be:

R = (I.1.1.1.I)\&(I.0.1+1.1^{*})'.
*)
Definition x1 := symbol A1.
Definition x0 := symbol A0.
Definition xI111I := concat I (concat x1 (concat x1 (concat x1 I))).
Definition xI01 := concat I (concat x0 x1).
Definition x11star := concat x1 (star x1).
Definition exampleR := and xI111I (neg (or xI01 x11star)).

Theorem notelem_emptyset: forall (s: str),
  s \notin emptyset_lang.
Proof.
intros.
untie.
Qed.

Lemma test_elem_xI01_101:
  ([A1] ++ [A0] ++ [A1]) \in {{xI01}}.
Proof.
unfold xI01.
destruct_concat_lang.
exists [A1].
exists ([A0] ++ [A1]).
assert ([A1] ++ [A0] ++ [A1] = [A1; A0; A1]). reflexivity.
exists H.
constructor.
- constructor.
  apply notelem_emptyset.
- destruct_concat_lang.
  exists [A0].
  exists [A1].
  exists eq_refl.
  wreckit.
Qed.

Lemma test_notelem_xI01_101_false:
  ([A1] ++ [A0] ++ [A1]) \notin {{xI01}}  -> False.
Proof.
unfold not.
intros.
apply H.
apply test_elem_xI01_101.
Qed.

Lemma test_notleme_xI01_empty:
    [] \notin {{xI01}}.
Proof.
unfold not.
intros.
wreckit.
listerine.
Qed.

Lemma test_notelem_xI01_10:
  ([A1] ++ [A0]) \notin {{xI01}}.
Proof.
unfold not.
intros.
wreckit.
listerine.
Qed.

Lemma test_notelem_xI01_1110:
  ([A1] ++ [A1] ++ [A1] ++ [A0]) \notin {{xI01}}.
Proof.
unfold not.
intros.
wreckit.
listerine.
Qed.

Lemma test_notelem_x11star_0:
  [A0] \notin {{ x11star }}.
Proof.
unfold not.
intros.
wreckit.
listerine.
Qed.

Lemma test_notelem_starx1_0:
  [A0] \notin {{star x1}}.
Proof.
untie.
invs H.
- listerine.
  + apply H1.
    reflexivity.
  + inversion H2.
Qed.

Lemma test_notelem_starx1_10:
  [A1; A0] \notin {{star x1}}.
Proof.
untie.
invs H.
- listerine.
  + contradiction.
  + invs H3.
    wreckit.
    listerine.
  + wreckit.
Qed.

Lemma test_notelem_starx1_110:
  [A1; A1; A0] \notin {{star x1}}.
Proof.
untie.
invs H.
wreckit.
listerine.
apply test_notelem_starx1_10.
assumption.
Qed.

Lemma test_notelem_x11star_1110:
  ([A1] ++ [A1] ++ [A1] ++ [A0]) \notin {{x11star}}.
Proof.
untie.
invs H.
wreckit.
listerine; wreckit.
- apply test_notelem_starx1_110.
  assumption.
Qed.

Lemma test_elem_xI111I_1110:
    ([A1] ++ [A1] ++ [A1] ++ [A0]) \in {{xI111I}}.
Proof.
destruct_concat_lang.
exists [].
exists ([A1] ++ [A1] ++ [A1] ++ [A0]).
exists eq_refl.
wreckit.
- constructor.
  untie.
- destruct_concat_lang.
  exists [A1].
  exists ([A1] ++ [A1] ++ [A0]).
  exists eq_refl.
  wreckit.
  destruct_concat_lang.
  exists [A1].
  exists ([A1] ++ [A0]).
  exists eq_refl.
  wreckit.
  destruct_concat_lang.
  exists [A1].
  exists [A0].
  exists eq_refl.
  wreckit.
  constructor.
  untie.
Qed.

Theorem test_exampleR_1110_elem:
    ([A1] ++ [A1] ++ [A1] ++ [A0]) \in {{exampleR}}.
Proof.
constructor.
untie.
wreckit.
- invs H.
  apply H5.
  apply test_elem_xI111I_1110.
- invs H.
  apply H5.
  constructor.
  untie.
  invs H.
  destruct H0.
  + apply  test_notelem_xI01_1110.
    assumption.
  + apply test_notelem_x11star_1110.
    assumption.
Qed.

Theorem test_exampleR_111_notelem:
    [A1; A1; A1] \notin {{exampleR}}.
Proof.
untie.
invs H.
apply H0.
constructor.
right.
constructor.
untie.
invs H.
apply H1.
constructor.
right.
unfold x11star.
destruct_concat_lang.
exists [A1].
exists [A1; A1].
assert ([A1] ++ [A1; A1] = [A1; A1; A1]). listerine; reflexivity.
exists H.
split.
- constructor.
- apply mk_star_more with (p := [A1]) (q := [A1]).
  + listerine. reflexivity.
  + listerine.
  + constructor.
  + apply mk_star_more with (p := [A1]) (q := []).
    * listerine. reflexivity.
    * listerine.
    * constructor.
    * constructor.
Qed.


Require Import List.
Require Import MyTactics. (* TEMPORARY *)
Require Import Autosubst.Autosubst.
Require Import Autosubst_EOS. (* [eos_var] *)

(* Environments are sometimes represented as finite lists. This file
   provides a few notions that helps deal with this representation. *)

Section Env.

Context {A} `{Ids A, Rename A, Subst A, SubstLemmas A}.

(* -------------------------------------------------------------------------- *)

(* The function [env2subst default], where [default] is a default value,
   converts an environment (a finite list) to a substitution (a total
   function). *)

Definition env2subst (default : A) (e : list A) (x : var) : A :=
  nth x e default.

(* -------------------------------------------------------------------------- *)

(* [env_ren_comp e xi e'] means (roughly) that the environment [e] is equal to
   the composition of the renaming [xi] and the environment [e'], that is,
   [e = xi >>> e']. We also explicitly require the environments [e] and [e']
   to have matching lengths, up to [xi], as this is *not* a consequence of
   the other premise. *)

Inductive env_ren_comp : list A -> (var -> var) -> list A -> Prop :=
| EnvRenComp:
    forall e xi e',
    (forall x, x < length e -> xi x < length e') ->
    (forall x default, nth x e default = nth (xi x) e' default) ->
    env_ren_comp e xi e'.

(* A reformulation of the second premise in the above definition. *)

Lemma env_ren_comp_eq:
  forall e xi e',
  (forall default, env2subst default e = xi >>> env2subst default e') <->
  (forall x default, nth x e default = nth (xi x) e' default).
Proof.
  unfold env2subst. split; intros h; intros.
  { change (nth x e default) with ((fun x => nth x e default) x).
    rewrite h. reflexivity. }
  { f_ext; intro x. eauto. }
Qed.

(* -------------------------------------------------------------------------- *)

(* Initialization: [e = id >>> e]. *)

Lemma env_ren_comp_id:
  forall e,
  env_ren_comp e (fun x => x) e.
Proof.
  econstructor; eauto.
Qed.

(* -------------------------------------------------------------------------- *)

(* The relation [e = xi >>> e'] can be taken under a binder, as follows. *)

Lemma env_ren_comp_up:
  forall e xi e' v,
  env_ren_comp e xi e' ->
  env_ren_comp (v :: e) (upren xi) (v :: e').
Proof.
  inversion 1; intros; subst; econstructor;
  intros [|x]; intros; simpl in *; eauto with lia.
Qed.

(* -------------------------------------------------------------------------- *)

(* One element can be prepended to [e'], provided [xi] is adjusted. *)

Lemma env_ren_comp_prepend:
  forall e xi e' v,
  env_ren_comp e xi e' ->
  env_ren_comp e (xi >>> (+1)) (v :: e').
Proof.
  inversion 1; intros; subst.
  econstructor; intros; simpl; eauto with lia.
Qed.

(* -------------------------------------------------------------------------- *)

(* A consequence of [env_ren_comp_id] and [env_ren_comp_prepend]. The renaming
   (+1) will eat away the first entry in [v :: e]. *)

Lemma env_ren_comp_plus1:
  forall e v,
  env_ren_comp e (+1) (v :: e).
Proof.
  econstructor; intros; simpl; eauto with lia.
Qed.

(* -------------------------------------------------------------------------- *)

(* More generally, the renaming [eos_var x], which means that [x] goes out of
   scope, will eat away the entry at index [x] in [e1 ++ v :: e2]. *)

Lemma env_ren_comp_eos_var:
  forall x e1 v e2,
  x = length e1 ->
  env_ren_comp (e1 ++ e2) (eos_var x) (e1 ++ v :: e2).
Proof.
  rewrite eos_var_eq_lift_var. unfold lift_var.
  econstructor; intros y; dblib_by_cases.
  { rewrite app_length in *. simpl. lia. }
  { rewrite app_length in *. simpl. lia. }
  { do 2 (rewrite app_nth2 by lia).
    replace (1 + y - length e1) with (1 + (y - length e1)) by lia.
    reflexivity. }
  { do 2 (rewrite app_nth1 by lia).
    reflexivity. }
Qed.

(* -------------------------------------------------------------------------- *)

End Env.

Global Hint Resolve
  env_ren_comp_id
  env_ren_comp_up
  env_ren_comp_prepend
  env_ren_comp_plus1
  env_ren_comp_eos_var
: env_ren_comp.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************
    UList.v

    Definition of list with distinct elements

    Definition: ulist

                                    Laurent.Thery@inria.fr (2003)
  **********************************************************************)
Require Import List.
Require Import Arith.
Require Import Permutation.
Require Import ListSet.

Section UniqueList.
Variable A : Set.
Variable eqA_dec : forall (a b : A),  ({ a = b }) + ({ a <> b }).
(* A list is unique if there is not twice the same element in the list *)

Inductive ulist : list A ->  Prop :=
  ulist_nil: ulist nil
 | ulist_cons: forall a l, ~ In a l -> ulist l ->  ulist (a :: l) .
Hint Constructors ulist .
(* Inversion theorem *)

Theorem ulist_inv: forall a l, ulist (a :: l) ->  ulist l.
intros a l H; inversion H; auto.
Qed.
(* The append of two unique list is unique if the list are distinct *)

Theorem ulist_app:
 forall l1 l2,
 ulist l1 ->
 ulist l2 -> (forall (a : A), In a l1 -> In a l2 ->  False) ->  ulist (l1 ++ l2).
intros L1; elim L1; simpl; auto.
intros a l H l2 H0 H1 H2; apply ulist_cons; simpl; auto.
red; intros H3; case in_app_or with ( 1 := H3 ); auto; intros H4.
inversion H0; auto.
apply H2 with a; auto.
apply H; auto.
apply ulist_inv with ( 1 := H0 ); auto.
intros a0 H3 H4; apply (H2 a0); auto.
Qed.
(* Iinversion theorem the appended list *)

Theorem ulist_app_inv:
 forall l1 l2 (a : A), ulist (l1 ++ l2) -> In a l1 -> In a l2 ->  False.
intros l1; elim l1; simpl; auto.
intros a l H l2 a0 H0 [H1|H1] H2.
inversion H0 as [|a1 l0 H3 H4 H5]; auto.
case H3; rewrite H1; auto with datatypes.
apply (H l2 a0); auto.
apply ulist_inv with ( 1 := H0 ); auto.
Qed.
(* Iinversion theorem the appended list *)

Theorem ulist_app_inv_l: forall (l1 l2 : list A), ulist (l1 ++ l2) ->  ulist l1.
intros l1; elim l1; simpl; auto.
intros a l H l2 H0.
inversion H0 as [|il1 iH1 iH2 il2 [iH4 iH5]]; apply ulist_cons; auto.
intros H5; case iH2; auto with datatypes.
apply H with l2; auto.
Qed.
(* Iinversion theorem the appended list *)

Theorem ulist_app_inv_r: forall (l1 l2 : list A), ulist (l1 ++ l2) ->  ulist l2.
intros l1; elim l1; simpl; auto.
intros a l H l2 H0; inversion H0; auto.
Qed.
(* Uniqueness is decidable *)

Definition ulist_dec: forall l,  ({ ulist l }) + ({ ~ ulist l }).
intros l; elim l; auto.
intros a l1 [H|H]; auto.
case (In_dec eqA_dec a l1); intros H2; auto.
right; red; intros H1; inversion H1; auto.
right; intros H1; case H; apply ulist_inv with ( 1 := H1 ).
Defined.
(* Uniqueness is compatible with permutation *)

Theorem ulist_perm:
 forall (l1 l2 : list A), permutation l1 l2 -> ulist l1 ->  ulist l2.
intros l1 l2 H; elim H; clear H l1 l2; simpl; auto.
intros a l1 l2 H0 H1 H2; apply ulist_cons; auto.
inversion_clear H2 as [|ia il iH1 iH2 [iH3 iH4]]; auto.
intros H3; case iH1;
 apply permutation_in with ( 1 := permutation_sym _ _ _ H0 ); auto.
inversion H2; auto.
intros a b L H0; apply ulist_cons; auto.
inversion_clear H0 as [|ia il iH1 iH2]; auto.
inversion_clear iH2 as [|ia il iH3 iH4]; auto.
intros H; case H; auto.
intros H1; case iH1; rewrite H1; simpl; auto.
apply ulist_cons; auto.
inversion_clear H0 as [|ia il iH1 iH2]; auto.
intros H; case iH1; simpl; auto.
inversion_clear H0 as [|ia il iH1 iH2]; auto.
inversion iH2; auto.
Qed.

Theorem ulist_def:
 forall l a,
 In a l -> ulist l ->  ~ (exists l1 , permutation l (a :: (a :: l1)) ).
intros l a H H0 [l1 H1].
absurd (ulist (a :: (a :: l1))); auto.
intros H2; inversion_clear H2; simpl; auto with datatypes.
apply ulist_perm with ( 1 := H1 ); auto.
Qed.

Theorem ulist_incl_permutation:
 forall (l1 l2 : list A),
 ulist l1 -> incl l1 l2 ->  (exists l3 , permutation l2 (l1 ++ l3) ).
intros l1; elim l1; simpl; auto.
intros l2 H H0; exists l2; simpl; auto.
intros a l H l2 H0 H1; auto.
case (in_permutation_ex _ a l2); auto with datatypes.
intros l3 Hl3.
case (H l3); auto.
apply ulist_inv with ( 1 := H0 ); auto.
intros b Hb.
assert (H2: In b (a :: l3)).
apply permutation_in with ( 1 := permutation_sym _ _ _ Hl3 );
 auto with datatypes.
simpl in H2 |-; case H2; intros H3; simpl; auto.
inversion_clear H0 as [|c lc Hk1]; auto.
case Hk1; subst a; auto.
intros l4 H4; exists l4.
apply permutation_trans with (a :: l3); auto.
apply permutation_sym; auto.
Qed.

Theorem ulist_eq_permutation:
 forall (l1 l2 : list A),
 ulist l1 -> incl l1 l2 -> length l1 = length l2 ->  permutation l1 l2.
intros l1 l2 H1 H2 H3.
case (ulist_incl_permutation l1 l2); auto.
intros l3 H4.
assert (H5: l3 = @nil A).
generalize (permutation_length _ _ _ H4); rewrite length_app; rewrite H3.
rewrite plus_comm; case l3; simpl; auto.
intros a l H5; absurd (lt (length l2) (length l2)); auto with arith.
pattern (length l2) at 2; rewrite H5; auto with arith.
replace l1 with (app l1 l3); auto.
apply permutation_sym; auto.
rewrite H5; rewrite app_nil_end; auto.
Qed.

Theorem ulist_incl_length:
 forall (l1 l2 : list A), ulist l1 -> incl l1 l2 ->  le (length l1) (length l2).
intros l1 l2 H1 Hi; case ulist_incl_permutation with ( 2 := Hi ); auto.
intros l3 Hl3; rewrite permutation_length with ( 1 := Hl3 ); auto.
rewrite length_app; simpl; auto with arith.
Qed.

Theorem ulist_incl_length_strict:
 forall (l1 l2 : list A),
 ulist l1 -> incl l1 l2 -> ~ incl l2 l1 ->  lt (length l1) (length l2).
intros l1 l2 H1 Hi Hi0; case ulist_incl_permutation with ( 2 := Hi ); auto.
intros l3 Hl3; rewrite permutation_length with ( 1 := Hl3 ); auto.
rewrite length_app; simpl; auto with arith.
generalize Hl3; case l3; simpl; auto with arith.
rewrite <- app_nil_end; auto.
intros H2; case Hi0; auto.
intros a HH; apply permutation_in with ( 1 := H2 ); auto.
intros a l Hl0; (rewrite plus_comm; simpl; rewrite plus_comm; auto with arith).
Qed.

Theorem in_inv_dec:
 forall (a b : A) l, In a (cons b l) ->  a = b \/ ~ a = b /\ In a l.
intros a b l H; case (eqA_dec a b); auto; intros H1.
right; split; auto; inversion H; auto.
case H1; auto.
Qed.

Theorem in_ex_app_first:
 forall (a : A) (l : list A),
 In a l ->
  (exists l1 : list A , exists l2 : list A , l = l1 ++ (a :: l2) /\ ~ In a l1  ).
intros a l; elim l; clear l; auto.
intros H; case H.
intros a1 l H H1; auto.
generalize (in_inv_dec _ _ _ H1); intros [H2|[H2 H3]].
exists (nil (A:=A)); exists l; simpl; split; auto.
apply f_equal2 with ( f := cons (A:=A) ); auto.
case H; auto; intros l1 [l2 [Hl2 Hl3]]; exists (a1 :: l1); exists l2; simpl;
 split; auto.
apply f_equal2 with ( f := cons (A:=A) ); auto.
intros H4; case H4; auto.
Qed.

Theorem ulist_inv_ulist:
 forall (l : list A),
 ~ ulist l ->
  (exists a ,
   exists l1 ,
   exists l2 ,
   exists l3 , l = l1 ++ ((a :: l2) ++ (a :: l3)) /\ ulist (l1 ++ (a :: l2))    ).
intros l; elim l  using list_length_ind; clear l.
intros l; case l; simpl; auto; clear l.
intros Rec H0; case H0; auto.
intros a l H H0.
case (In_dec eqA_dec a l); intros H1; auto.
case in_ex_app_first with ( 1 := H1 ); intros l1 [l2 [Hl1 Hl2]]; subst l.
case (ulist_dec l1); intros H2.
exists a; exists (@nil A); exists l1; exists l2; split; auto.
simpl; apply ulist_cons; auto.
case (H l1); auto.
rewrite length_app; auto with arith.
intros b [l3 [l4 [l5 [Hl3 Hl4]]]]; subst l1.
exists b; exists (a :: l3); exists l4; exists (l5 ++ (a :: l2)); split; simpl;
 auto.
(repeat (rewrite <- ass_app; simpl)); auto.
apply ulist_cons; auto.
contradict Hl2; auto.
replace (l3 ++ (b :: (l4 ++ (b :: l5)))) with ((l3 ++ (b :: l4)) ++ (b :: l5));
 auto with datatypes.
(repeat (rewrite <- ass_app; simpl)); auto.
case (H l); auto; intros a1 [l1 [l2 [l3 [Hl3 Hl4]]]]; subst l.
exists a1; exists (a :: l1); exists l2; exists l3; split; auto.
simpl; apply ulist_cons; auto.
contradict H1.
replace (l1 ++ (a1 :: (l2 ++ (a1 :: l3))))
     with ((l1 ++ (a1 :: l2)) ++ (a1 :: l3)); auto with datatypes.
(repeat (rewrite <- ass_app; simpl)); auto.
Qed.

Theorem incl_length_repetition:
 forall (l1 l2 : list A),
 incl l1 l2 ->
 lt (length l2) (length l1) ->
  (exists a ,
   exists ll1 ,
   exists ll2 ,
   exists ll3 ,
   l1 = ll1 ++ ((a :: ll2) ++ (a :: ll3)) /\ ulist (ll1 ++ (a :: ll2))    ).
intros l1 l2 H H0; apply ulist_inv_ulist.
intros H1; absurd (le (length l1) (length l2)); auto with arith.
apply ulist_incl_length; auto.
Qed.

End UniqueList.
Implicit Arguments ulist [A].
Hint Constructors ulist .

Theorem ulist_map:
 forall (A B : Set) (f : A ->  B) l,
 (forall x y, f x = f y ->  x = y) -> ulist l ->  ulist (map f l).
intros a b f l Hf Hl; elim Hl; auto.
simpl; auto.
intros a1 l1 H1 H2 H3; simpl.
apply ulist_cons; auto.
contradict H1.
case in_map_inv with ( 1 := H1 ); auto with zarith.
intros b1 [Hb1 Hb2].
replace a1 with b1; auto.
Qed.

Theorem ulist_list_prod:
 forall (A : Set) (l1 l2 : list A),
 ulist l1 -> ulist l2 ->  ulist (list_prod l1 l2).
intros A l1 l2 Hl1 Hl2; elim Hl1; simpl; auto.
intros a l H1 H2 H3; apply ulist_app; auto.
apply ulist_map; auto.
intros x y H; inversion H; auto.
intros p Hp1 Hp2; case H1.
case in_map_inv with ( 1 := Hp1 ); intros a1 [Ha1 Ha2]; auto.
case in_list_prod_inv with ( 1 := Hp2 ); intros b1 [c1 [Hb1 [Hb2 Hb3]]]; auto.
replace a with b1; auto.
rewrite Ha2 in Hb1; injection Hb1; auto.
Qed.


From iris.bi Require Export derived_laws.
From iris.algebra Require Import monoid.
From iris Require Import options.

Module bi.
Import interface.bi.
Import derived_laws.bi.

Section later_derived.
Context {PROP : bi}.
Implicit Types φ : Prop.
Implicit Types P Q R : PROP.
Implicit Types Ps : list PROP.
Implicit Types A : Type.

(* Force implicit argument PROP *)
Notation "P ⊢ Q" := (P ⊢@{PROP} Q).
Notation "P ⊣⊢ Q" := (P ⊣⊢@{PROP} Q).

Hint Resolve or_elim or_intro_l' or_intro_r' True_intro False_elim : core.
Hint Resolve and_elim_l' and_elim_r' and_intro forall_intro : core.

Global Instance later_proper :
  Proper ((⊣⊢) ==> (⊣⊢)) (@bi_later PROP) := ne_proper _.

(* Later derived *)
Hint Resolve later_mono : core.
Global Instance later_mono' : Proper ((⊢) ==> (⊢)) (@bi_later PROP).
Proof. intros P Q; apply later_mono. Qed.
Global Instance later_flip_mono' :
  Proper (flip (⊢) ==> flip (⊢)) (@bi_later PROP).
Proof. intros P Q; apply later_mono. Qed.

Lemma later_True : ▷ True ⊣⊢ True.
Proof. apply (anti_symm (⊢)); auto using later_intro. Qed.
Lemma later_emp `{!BiAffine PROP} : ▷ emp ⊣⊢ emp.
Proof. by rewrite -True_emp later_True. Qed.
Lemma later_forall {A} (Φ : A → PROP) : (▷ ∀ a, Φ a) ⊣⊢ (∀ a, ▷ Φ a).
Proof.
  apply (anti_symm _); auto using later_forall_2.
  apply forall_intro=> x. by rewrite (forall_elim x).
Qed.
Lemma later_exist_2 {A} (Φ : A → PROP) : (∃ a, ▷ Φ a) ⊢ ▷ (∃ a, Φ a).
Proof. apply exist_elim; eauto using exist_intro. Qed.
Lemma later_exist_except_0 {A} (Φ : A → PROP) : ▷ (∃ a, Φ a) ⊢ ◇ (∃ a, ▷ Φ a).
Proof. apply later_exist_false. Qed.
Lemma later_exist `{Inhabited A} (Φ : A → PROP) : ▷ (∃ a, Φ a) ⊣⊢ (∃ a, ▷ Φ a).
Proof.
  apply: anti_symm; [|apply later_exist_2].
  rewrite later_exist_false. apply or_elim; last done.
  rewrite -(exist_intro inhabitant); auto.
Qed.
Lemma later_and P Q : ▷ (P ∧ Q) ⊣⊢ ▷ P ∧ ▷ Q.
Proof. rewrite !and_alt later_forall. by apply forall_proper=> -[]. Qed.
Lemma later_or P Q : ▷ (P ∨ Q) ⊣⊢ ▷ P ∨ ▷ Q.
Proof. rewrite !or_alt later_exist. by apply exist_proper=> -[]. Qed.
Lemma later_impl P Q : ▷ (P → Q) ⊢ ▷ P → ▷ Q.
Proof. apply impl_intro_l. by rewrite -later_and impl_elim_r. Qed.
Lemma later_sep P Q : ▷ (P ∗ Q) ⊣⊢ ▷ P ∗ ▷ Q.
Proof. apply (anti_symm _); auto using later_sep_1, later_sep_2. Qed.
Lemma later_wand P Q : ▷ (P -∗ Q) ⊢ ▷ P -∗ ▷ Q.
Proof. apply wand_intro_l. by rewrite -later_sep wand_elim_r. Qed.
Lemma later_iff P Q : ▷ (P ↔ Q) ⊢ ▷ P ↔ ▷ Q.
Proof. by rewrite /bi_iff later_and !later_impl. Qed.
Lemma later_persistently P : ▷ <pers> P ⊣⊢ <pers> ▷ P.
Proof. apply (anti_symm _); auto using later_persistently_1, later_persistently_2. Qed.
Lemma later_affinely_2 P : <affine> ▷ P ⊢ ▷ <affine> P.
Proof. rewrite /bi_affinely later_and. auto using later_intro. Qed.
Lemma later_intuitionistically_2 P : □ ▷ P ⊢ ▷ □ P.
Proof. by rewrite /bi_intuitionistically -later_persistently later_affinely_2. Qed.
Lemma later_intuitionistically_if_2 p P : □?p ▷ P ⊢ ▷ □?p P.
Proof. destruct p; simpl; auto using later_intuitionistically_2. Qed.
Lemma later_absorbingly P : ▷ <absorb> P ⊣⊢ <absorb> ▷ P.
Proof. by rewrite /bi_absorbingly later_sep later_True. Qed.

Lemma later_affinely `{!BiAffine PROP} P : ▷ <affine> P ⊣⊢ <affine> ▷ P.
Proof. by rewrite !affine_affinely. Qed.
Lemma later_intuitionistically `{!BiAffine PROP} P : ▷ □ P ⊣⊢ □ ▷ P.
Proof. by rewrite !intuitionistically_into_persistently later_persistently. Qed.
Lemma later_intuitionistically_if `{!BiAffine PROP} p P : ▷ □?p P ⊣⊢ □?p ▷ P.
Proof. destruct p; simpl; auto using later_intuitionistically. Qed.

Global Instance later_persistent P : Persistent P → Persistent (▷ P).
Proof. intros. by rewrite /Persistent -later_persistently {1}(persistent P). Qed.
Global Instance later_absorbing P : Absorbing P → Absorbing (▷ P).
Proof. intros ?. by rewrite /Absorbing -later_absorbingly absorbing. Qed.

(** * Alternatives to Löb induction *)
(** We prove relations between the following statements:

1. [Contractive (▷)], later is contractive as expressed by [BiLaterContractive].
2. [(▷ P ⊢ P) → (True ⊢ P)], the external/"weak" of Löb as expressed by [BiLöb].
3. [(▷ P → P) ⊢ P], the internal version/"strong" of Löb.
4. [□ (□ ▷ P -∗ P) ⊢ P], an internal version of Löb with magic wand instead of
   implication.
5. [□ (▷ P -∗ P) ⊢ P], a weaker version of the former statement, which does not
   make the induction hypothesis intuitionistic.

We prove that:

- (1) implies (2) in all BI logics (lemma [later_contractive_bi_löb]).
- (2) and (3) are logically equivalent in all BI logics (lemma [löb_alt_strong]).
- (2) implies (4) and (5) in all BI logics (lemmas [löb_wand_intuitionistically]
  and [löb_wand]).
- (5) and (2) are logically equivalent in affine BI logics (lemma [löb_alt_wand]).

In particular, this gives that (2), (3), (4) and (5) are logically equivalent in
affine BI logics such as Iris. *)

Lemma löb `{!BiLöb PROP} P : (▷ P → P) ⊢ P.
Proof.
  apply entails_impl_True, löb_weak. apply impl_intro_r.
  rewrite -{2}(idemp (∧) (▷ P → P))%I.
  rewrite {2}(later_intro (▷ P → P))%I.
  rewrite later_impl.
  rewrite assoc impl_elim_l.
  rewrite impl_elim_r. done.
Qed.

Lemma löb_alt_strong : BiLöb PROP ↔ ∀ P, (▷ P → P) ⊢ P.
Proof. split; intros HLöb P. apply löb. by intros ->%entails_impl_True. Qed.

(** Proof following https://en.wikipedia.org/wiki/L%C3%B6b's_theorem#Proof_of_L%C3%B6b's_theorem.
Their [Ψ] is called [Q] in our proof. *)
Global Instance later_contractive_bi_löb : BiLaterContractive PROP → BiLöb PROP.
Proof.
  intros=> P.
  pose (flöb_pre (P Q : PROP) := (▷ Q → P)%I).
  assert (∀ P, Contractive (flöb_pre P)) by solve_contractive.
  set (Q := fixpoint (flöb_pre P)).
  assert (Q ⊣⊢ (▷ Q → P)) as HQ by (exact: fixpoint_unfold).
  intros HP. rewrite -HP.
  assert (▷ Q ⊢ P) as HQP.
  { rewrite -HP. rewrite -(idemp (∧) (▷ Q))%I {2}(later_intro (▷ Q))%I.
    by rewrite {1}HQ {1}later_impl impl_elim_l. }
  rewrite -HQP HQ -2!later_intro.
  apply (entails_impl_True _ P). done.
Qed.

Lemma löb_wand_intuitionistically `{!BiLöb PROP} P : □ (□ ▷ P -∗ P) ⊢ P.
Proof.
  rewrite -{3}(intuitionistically_elim P) -(löb (□ P)%I). apply impl_intro_l.
  rewrite {1}intuitionistically_into_persistently_1 later_persistently.
  rewrite persistently_and_intuitionistically_sep_l.
  rewrite -{1}(intuitionistically_idemp (▷ P)%I) intuitionistically_sep_2.
  by rewrite wand_elim_r.
Qed.
Lemma löb_wand `{!BiLöb PROP} P : □ (▷ P -∗ P) ⊢ P.
Proof.
  by rewrite -(intuitionistically_elim (▷ P)%I) löb_wand_intuitionistically.
Qed.

(** The proof of the right-to-left direction relies on the BI being affine. It
is unclear how to generalize the lemma or proof to support non-affine BIs. *)
Lemma löb_alt_wand `{!BiAffine PROP} : BiLöb PROP ↔ ∀ P, □ (▷ P -∗ P) ⊢ P.
Proof.
  split; intros Hlöb; [by apply löb_wand|].
  apply löb_alt_strong=> P.
  rewrite bi.impl_alt. apply bi.exist_elim=> R. apply impl_elim_r'.
  rewrite -(Hlöb (R → P)%I) -intuitionistically_into_persistently.
  apply intuitionistically_intro', wand_intro_l, impl_intro_l.
  rewrite -persistently_and_intuitionistically_sep_r assoc
    persistently_and_intuitionistically_sep_r intuitionistically_elim.
  rewrite -{1}(idemp bi_and R) -(assoc _ R) {2}(later_intro R).
  by rewrite -later_and impl_elim_r (comm _ R) wand_elim_r.
Qed.

(** A funny consequence of Löb induction.
This shows that Löb induction is incompatible with classical logic.
See [lib/counterexamples.v] for a fully worked-out proof of that fact. *)
Lemma not_not_later_False `{!BiLöb PROP} : ⊢@{PROP} ¬ ¬ ▷ False.
Proof. apply entails_impl, löb. Qed.

(* Iterated later modality *)
Global Instance laterN_ne m : NonExpansive (@bi_laterN PROP m).
Proof. induction m; simpl. by intros ???. solve_proper. Qed.
Global Instance laterN_proper m :
  Proper ((⊣⊢) ==> (⊣⊢)) (@bi_laterN PROP m) := ne_proper _.

Lemma laterN_0 P : ▷^0 P ⊣⊢ P.
Proof. done. Qed.
Lemma later_laterN n P : ▷^(S n) P ⊣⊢ ▷ ▷^n P.
Proof. done. Qed.
Lemma laterN_later n P : ▷^(S n) P ⊣⊢ ▷^n ▷ P.
Proof. induction n; f_equiv/=; auto. Qed.
Lemma laterN_plus n1 n2 P : ▷^(n1 + n2) P ⊣⊢ ▷^n1 ▷^n2 P.
Proof. induction n1; f_equiv/=; auto. Qed.
Lemma laterN_le n1 n2 P : n1 ≤ n2 → ▷^n1 P ⊢ ▷^n2 P.
Proof. induction 1; simpl; by rewrite -?later_intro. Qed.

Lemma laterN_iter n P : (▷^n P)%I = Nat.iter n bi_later P.
Proof. induction n; f_equal/=; auto. Qed.

Lemma laterN_mono n P Q : (P ⊢ Q) → ▷^n P ⊢ ▷^n Q.
Proof. induction n; simpl; auto. Qed.
Global Instance laterN_mono' n : Proper ((⊢) ==> (⊢)) (@bi_laterN PROP n).
Proof. intros P Q; apply laterN_mono. Qed.
Global Instance laterN_flip_mono' n :
  Proper (flip (⊢) ==> flip (⊢)) (@bi_laterN PROP n).
Proof. intros P Q; apply laterN_mono. Qed.

Lemma laterN_intro n P : P ⊢ ▷^n P.
Proof. induction n as [|n IH]; simpl; by rewrite -?later_intro. Qed.

Lemma laterN_True n : ▷^n True ⊣⊢ True.
Proof. apply (anti_symm (⊢)); auto using laterN_intro, True_intro. Qed.
Lemma laterN_emp `{!BiAffine PROP} n : ▷^n emp ⊣⊢ emp.
Proof. by rewrite -True_emp laterN_True. Qed.
Lemma laterN_forall {A} n (Φ : A → PROP) : (▷^n ∀ a, Φ a) ⊣⊢ (∀ a, ▷^n Φ a).
Proof. induction n as [|n IH]; simpl; rewrite -?later_forall ?IH; auto. Qed.
Lemma laterN_exist_2 {A} n (Φ : A → PROP) : (∃ a, ▷^n Φ a) ⊢ ▷^n (∃ a, Φ a).
Proof. apply exist_elim; eauto using exist_intro, laterN_mono. Qed.
Lemma laterN_exist `{Inhabited A} n (Φ : A → PROP) :
  (▷^n ∃ a, Φ a) ⊣⊢ ∃ a, ▷^n Φ a.
Proof. induction n as [|n IH]; simpl; rewrite -?later_exist ?IH; auto. Qed.
Lemma laterN_and n P Q : ▷^n (P ∧ Q) ⊣⊢ ▷^n P ∧ ▷^n Q.
Proof. induction n as [|n IH]; simpl; rewrite -?later_and ?IH; auto. Qed.
Lemma laterN_or n P Q : ▷^n (P ∨ Q) ⊣⊢ ▷^n P ∨ ▷^n Q.
Proof. induction n as [|n IH]; simpl; rewrite -?later_or ?IH; auto. Qed.
Lemma laterN_impl n P Q : ▷^n (P → Q) ⊢ ▷^n P → ▷^n Q.
Proof. apply impl_intro_l. by rewrite -laterN_and impl_elim_r. Qed.
Lemma laterN_sep n P Q : ▷^n (P ∗ Q) ⊣⊢ ▷^n P ∗ ▷^n Q.
Proof. induction n as [|n IH]; simpl; rewrite -?later_sep ?IH; auto. Qed.
Lemma laterN_wand n P Q : ▷^n (P -∗ Q) ⊢ ▷^n P -∗ ▷^n Q.
Proof. apply wand_intro_l. by rewrite -laterN_sep wand_elim_r. Qed.
Lemma laterN_iff n P Q : ▷^n (P ↔ Q) ⊢ ▷^n P ↔ ▷^n Q.
Proof. by rewrite /bi_iff laterN_and !laterN_impl. Qed.
Lemma laterN_persistently n P : ▷^n <pers> P ⊣⊢ <pers> ▷^n P.
Proof. induction n as [|n IH]; simpl; auto. by rewrite IH later_persistently. Qed.
Lemma laterN_affinely_2 n P : <affine> ▷^n P ⊢ ▷^n <affine> P.
Proof. rewrite /bi_affinely laterN_and. auto using laterN_intro. Qed.
Lemma laterN_intuitionistically_2 n P : □ ▷^n P ⊢ ▷^n □ P.
Proof. by rewrite /bi_intuitionistically -laterN_persistently laterN_affinely_2. Qed.
Lemma laterN_intuitionistically_if_2 n p P : □?p ▷^n P ⊢ ▷^n □?p P.
Proof. destruct p; simpl; auto using laterN_intuitionistically_2. Qed.
Lemma laterN_absorbingly n P : ▷^n <absorb> P ⊣⊢ <absorb> ▷^n P.
Proof. by rewrite /bi_absorbingly laterN_sep laterN_True. Qed.

Global Instance laterN_persistent n P : Persistent P → Persistent (▷^n P).
Proof. induction n; apply _. Qed.
Global Instance laterN_absorbing n P : Absorbing P → Absorbing (▷^n P).
Proof. induction n; apply _. Qed.

(* Except-0 *)
Global Instance except_0_ne : NonExpansive (@bi_except_0 PROP).
Proof. solve_proper. Qed.
Global Instance except_0_proper : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_except_0 PROP).
Proof. solve_proper. Qed.
Global Instance except_0_mono' : Proper ((⊢) ==> (⊢)) (@bi_except_0 PROP).
Proof. solve_proper. Qed.
Global Instance except_0_flip_mono' :
  Proper (flip (⊢) ==> flip (⊢)) (@bi_except_0 PROP).
Proof. solve_proper. Qed.

Lemma except_0_intro P : P ⊢ ◇ P.
Proof. rewrite /bi_except_0; auto. Qed.
Lemma except_0_mono P Q : (P ⊢ Q) → ◇ P ⊢ ◇ Q.
Proof. by intros ->. Qed.
Lemma except_0_idemp P : ◇ ◇ P ⊣⊢ ◇ P.
Proof. apply (anti_symm _); rewrite /bi_except_0; auto. Qed.

Lemma except_0_True : ◇ True ⊣⊢ True.
Proof. rewrite /bi_except_0. apply (anti_symm _); auto. Qed.
Lemma except_0_emp `{!BiAffine PROP} : ◇ emp ⊣⊢ emp.
Proof. by rewrite -True_emp except_0_True. Qed.
Lemma except_0_or P Q : ◇ (P ∨ Q) ⊣⊢ ◇ P ∨ ◇ Q.
Proof. rewrite /bi_except_0. apply (anti_symm _); auto. Qed.
Lemma except_0_and P Q : ◇ (P ∧ Q) ⊣⊢ ◇ P ∧ ◇ Q.
Proof. by rewrite /bi_except_0 or_and_l. Qed.
Lemma except_0_sep P Q : ◇ (P ∗ Q) ⊣⊢ ◇ P ∗ ◇ Q.
Proof.
  rewrite /bi_except_0. apply (anti_symm _).
  - apply or_elim; last by auto using sep_mono.
    by rewrite -!or_intro_l -persistently_pure -later_sep -persistently_sep_dup.
  - rewrite sep_or_r !sep_or_l {1}(later_intro P) {1}(later_intro Q).
    rewrite -!later_sep !left_absorb right_absorb. auto.
Qed.
Lemma except_0_forall {A} (Φ : A → PROP) : ◇ (∀ a, Φ a) ⊣⊢ ∀ a, ◇ Φ a.
Proof.
  apply (anti_symm _).
  { apply forall_intro=> a. by rewrite (forall_elim a). }
  trans (▷ (∀ a : A, Φ a) ∧ (∀ a : A, ◇ Φ a))%I.
  { apply and_intro, reflexivity. rewrite later_forall. apply forall_mono=> a.
    apply or_elim; auto using later_intro. }
  rewrite later_false_em and_or_r. apply or_elim.
  { rewrite and_elim_l. apply or_intro_l. }
  apply or_intro_r', forall_intro=> a. rewrite !(forall_elim a).
  by rewrite and_or_l impl_elim_l and_elim_r idemp.
Qed.
Lemma except_0_exist_2 {A} (Φ : A → PROP) : (∃ a, ◇ Φ a) ⊢ ◇ ∃ a, Φ a.
Proof. apply exist_elim=> a. by rewrite (exist_intro a). Qed.
Lemma except_0_exist `{Inhabited A} (Φ : A → PROP) :
  ◇ (∃ a, Φ a) ⊣⊢ (∃ a, ◇ Φ a).
Proof.
  apply (anti_symm _); [|by apply except_0_exist_2]. apply or_elim.
  - rewrite -(exist_intro inhabitant). by apply or_intro_l.
  - apply exist_mono=> a. apply except_0_intro.
Qed.
Lemma except_0_later P : ◇ ▷ P ⊢ ▷ P.
Proof. by rewrite /bi_except_0 -later_or False_or. Qed.
Lemma except_0_laterN n P : ◇ ▷^n P ⊢ ▷^n ◇ P.
Proof. by destruct n as [|n]; rewrite //= ?except_0_later -except_0_intro. Qed.
Lemma except_0_into_later P : ◇ P ⊢ ▷ P.
Proof. by rewrite -except_0_later -later_intro. Qed.
Lemma except_0_persistently P : ◇ <pers> P ⊣⊢ <pers> ◇ P.
Proof.
  by rewrite /bi_except_0 persistently_or -later_persistently persistently_pure.
Qed.
Lemma except_0_affinely_2 P : <affine> ◇ P ⊢ ◇ <affine> P.
Proof. rewrite /bi_affinely except_0_and. auto using except_0_intro. Qed.
Lemma except_0_intuitionistically_2 P : □ ◇ P ⊢ ◇ □ P.
Proof. by rewrite /bi_intuitionistically -except_0_persistently except_0_affinely_2. Qed.
Lemma except_0_intuitionistically_if_2 p P : □?p ◇ P ⊢ ◇ □?p P.
Proof. destruct p; simpl; auto using except_0_intuitionistically_2. Qed.
Lemma except_0_absorbingly P : ◇ <absorb> P ⊣⊢ <absorb> ◇ P.
Proof. by rewrite /bi_absorbingly except_0_sep except_0_True. Qed.

Lemma except_0_frame_l P Q : P ∗ ◇ Q ⊢ ◇ (P ∗ Q).
Proof. by rewrite {1}(except_0_intro P) except_0_sep. Qed.
Lemma except_0_frame_r P Q : ◇ P ∗ Q ⊢ ◇ (P ∗ Q).
Proof. by rewrite {1}(except_0_intro Q) except_0_sep. Qed.

Lemma later_affinely_1 `{!Timeless (PROP:=PROP) emp} P : ▷ <affine> P ⊢ ◇ <affine> ▷ P.
Proof.
  rewrite /bi_affinely later_and (timeless emp%I) except_0_and.
  by apply and_mono, except_0_intro.
Qed.

Global Instance except_0_persistent P : Persistent P → Persistent (◇ P).
Proof. rewrite /bi_except_0; apply _. Qed.
Global Instance except_0_absorbing P : Absorbing P → Absorbing (◇ P).
Proof. rewrite /bi_except_0; apply _. Qed.

(* Timeless instances *)
Global Instance Timeless_proper : Proper ((≡) ==> iff) (@Timeless PROP).
Proof. solve_proper. Qed.

Global Instance pure_timeless φ : Timeless (PROP:=PROP) ⌜φ⌝.
Proof.
  rewrite /Timeless /bi_except_0 pure_alt later_exist_false.
  apply or_elim, exist_elim; [auto|]=> Hφ. rewrite -(exist_intro Hφ). auto.
Qed.
Global Instance emp_timeless `{BiAffine PROP} : Timeless (PROP:=PROP) emp.
Proof. rewrite -True_emp. apply _. Qed.

Global Instance and_timeless P Q : Timeless P → Timeless Q → Timeless (P ∧ Q).
Proof. intros; rewrite /Timeless except_0_and later_and; auto. Qed.
Global Instance or_timeless P Q : Timeless P → Timeless Q → Timeless (P ∨ Q).
Proof. intros; rewrite /Timeless except_0_or later_or; auto. Qed.

Global Instance impl_timeless `{!BiLöb PROP} P Q : Timeless Q → Timeless (P → Q).
Proof.
  rewrite /Timeless=> HQ. rewrite later_false_em.
  apply or_mono, impl_intro_l; first done.
  rewrite -{2}(löb Q). apply impl_intro_l.
  rewrite HQ /bi_except_0 !and_or_r. apply or_elim; last auto.
  by rewrite assoc (comm _ _ P) -assoc !impl_elim_r.
Qed.
Global Instance sep_timeless P Q: Timeless P → Timeless Q → Timeless (P ∗ Q).
Proof.
  intros; rewrite /Timeless except_0_sep later_sep; auto using sep_mono.
Qed.

Global Instance wand_timeless `{!BiLöb PROP} P Q : Timeless Q → Timeless (P -∗ Q).
Proof.
  rewrite /Timeless=> HQ. rewrite later_false_em.
  apply or_mono, wand_intro_l; first done.
  rewrite -{2}(löb Q); apply impl_intro_l.
  rewrite HQ /bi_except_0 !and_or_r. apply or_elim; last auto.
  by rewrite (comm _ P) persistent_and_sep_assoc impl_elim_r wand_elim_l.
Qed.
Global Instance forall_timeless {A} (Ψ : A → PROP) :
  (∀ x, Timeless (Ψ x)) → Timeless (∀ x, Ψ x).
Proof.
  rewrite /Timeless=> HQ. rewrite except_0_forall later_forall.
  apply forall_mono; auto.
Qed.
Global Instance exist_timeless {A} (Ψ : A → PROP) :
  (∀ x, Timeless (Ψ x)) → Timeless (∃ x, Ψ x).
Proof.
  rewrite /Timeless=> ?. rewrite later_exist_false. apply or_elim.
  - rewrite /bi_except_0; auto.
  - apply exist_elim=> x. rewrite -(exist_intro x); auto.
Qed.
Global Instance persistently_timeless P : Timeless P → Timeless (<pers> P).
Proof.
  intros. rewrite /Timeless /bi_except_0 later_persistently_1.
  by rewrite (timeless P) /bi_except_0 persistently_or {1}persistently_elim.
Qed.

Global Instance affinely_timeless P :
  Timeless (PROP:=PROP) emp → Timeless P → Timeless (<affine> P).
Proof. rewrite /bi_affinely; apply _. Qed.
Global Instance absorbingly_timeless P : Timeless P → Timeless (<absorb> P).
Proof. rewrite /bi_absorbingly; apply _. Qed.

Global Instance intuitionistically_timeless P :
  Timeless (PROP:=PROP) emp → Timeless P → Timeless (□ P).
Proof. rewrite /bi_intuitionistically; apply _. Qed.

Global Instance from_option_timeless {A} P (Ψ : A → PROP) (mx : option A) :
  (∀ x, Timeless (Ψ x)) → Timeless P → Timeless (from_option Ψ P mx).
Proof. destruct mx; apply _. Qed.

(* Big op stuff *)
Global Instance bi_later_monoid_and_homomorphism :
  MonoidHomomorphism bi_and bi_and (≡) (@bi_later PROP).
Proof. split; [split|]; try apply _. apply later_and. apply later_True. Qed.
Global Instance bi_laterN_and_homomorphism n :
  MonoidHomomorphism bi_and bi_and (≡) (@bi_laterN PROP n).
Proof. split; [split|]; try apply _. apply laterN_and. apply laterN_True. Qed.
Global Instance bi_except_0_and_homomorphism :
  MonoidHomomorphism bi_and bi_and (≡) (@bi_except_0 PROP).
Proof. split; [split|]; try apply _. apply except_0_and. apply except_0_True. Qed.

Global Instance bi_later_monoid_or_homomorphism :
  WeakMonoidHomomorphism bi_or bi_or (≡) (@bi_later PROP).
Proof. split; try apply _. apply later_or. Qed.
Global Instance bi_laterN_or_homomorphism n :
  WeakMonoidHomomorphism bi_or bi_or (≡) (@bi_laterN PROP n).
Proof. split; try apply _. apply laterN_or. Qed.
Global Instance bi_except_0_or_homomorphism :
  WeakMonoidHomomorphism bi_or bi_or (≡) (@bi_except_0 PROP).
Proof. split; try apply _. apply except_0_or. Qed.

Global Instance bi_later_monoid_sep_weak_homomorphism :
  WeakMonoidHomomorphism bi_sep bi_sep (≡) (@bi_later PROP).
Proof. split; try apply _. apply later_sep. Qed.
Global Instance bi_laterN_sep_weak_homomorphism n :
  WeakMonoidHomomorphism bi_sep bi_sep (≡) (@bi_laterN PROP n).
Proof. split; try apply _. apply laterN_sep. Qed.
Global Instance bi_except_0_sep_weak_homomorphism :
  WeakMonoidHomomorphism bi_sep bi_sep (≡) (@bi_except_0 PROP).
Proof. split; try apply _. apply except_0_sep. Qed.

Global Instance bi_later_monoid_sep_homomorphism `{!BiAffine PROP} :
  MonoidHomomorphism bi_sep bi_sep (≡) (@bi_later PROP).
Proof. split; try apply _. apply later_emp. Qed.
Global Instance bi_laterN_sep_homomorphism `{!BiAffine PROP} n :
  MonoidHomomorphism bi_sep bi_sep (≡) (@bi_laterN PROP n).
Proof. split; try apply _. apply laterN_emp. Qed.
Global Instance bi_except_0_sep_homomorphism `{!BiAffine PROP} :
  MonoidHomomorphism bi_sep bi_sep (≡) (@bi_except_0 PROP).
Proof. split; try apply _. apply except_0_emp. Qed.

Global Instance bi_later_monoid_sep_entails_weak_homomorphism :
  WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_later PROP).
Proof. split; try apply _. intros P Q. by rewrite later_sep. Qed.
Global Instance bi_laterN_sep_entails_weak_homomorphism n :
  WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_laterN PROP n).
Proof. split; try apply _. intros P Q. by rewrite laterN_sep. Qed.
Global Instance bi_except_0_sep_entails_weak_homomorphism :
  WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_except_0 PROP).
Proof. split; try apply _. intros P Q. by rewrite except_0_sep. Qed.

Global Instance bi_later_monoid_sep_entails_homomorphism :
  MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_later PROP).
Proof. split; try apply _. apply later_intro. Qed.
Global Instance bi_laterN_sep_entails_homomorphism n :
  MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_laterN PROP n).
Proof. split; try apply _. apply laterN_intro. Qed.
Global Instance bi_except_0_sep_entails_homomorphism :
  MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_except_0 PROP).
Proof. split; try apply _. apply except_0_intro. Qed.
End later_derived.
End bi.


(*
 - The precategory `TYPE2` of types with a point and two endomorphisms, corresponding with zero, successor and predecessor.
 - An attempt to add the path constructor 'sec' to this. Only the data are added.
*)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.categories.Type.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.

Require Import Integers.Categories.disp_precat.
Require Import Integers.Categories.total_precat.
Require Import Integers.Categories.point_constructors.

Local Open Scope cat.
Local Open Scope mor_disp.

(** Precategory with an added point and two endomorphisms *)
Definition disp2 : disp_precat type_precat.
Proof.
  apply dirprod_disp_precat.
  - exact disp_point_end.
  - exact disp_end.
Defined.

Definition TYPE2 : precategory := total_precategory disp2.

(** An attempt to add the type of 'sec' as displayed objects. **)
Definition disp_sec_h_data : disp_cat_data TYPE2.
Proof.
  use tpair.
  - use make_disp_cat_ob_mor.
    + cbn.
      intro XX.
      exact (∏ z : (pr1 XX), pr22 XX (pr212 XX z) = z).
    + cbn.
      intros XX YY ε η ff.
      exact (∏ z : (pr1 XX), pr22 ff (pr212 XX z) @ maponpaths (pr22 YY) ((pr212 ff z)) @ η (pr1 ff z) = maponpaths (pr1 ff) (ε z)).
  - split.
    + cbn. intros XX ε z.
      unfold idfun.
      exact (!maponpathsidfun (ε z)).
    + cbn. intros XX YY ZZ ff gg ε η θ fff ggg z.
      refine (_ @ _ @ _ @ _ @ _ @ _ @ _ @ _ @ _ @ _ @ _ @ _ @ _).
      * apply maponpaths.
        apply maponpaths_2.
        apply maponpathscomp0.
      * apply maponpaths.
        apply maponpaths_2.
        apply maponpaths_2.
        apply (maponpathscomp (pr1 gg)).
      * apply (!path_assoc _ _ _).
      * apply maponpaths.
        apply maponpaths.
        apply (!path_assoc _ _ _).
      * apply maponpaths.
        apply path_assoc.
      * apply maponpaths.
        apply maponpaths_2.
        exact (!homotsec_natural (pr22 gg) (pr212 ff z)).
      * apply maponpaths.
        apply (!path_assoc _ _ _).
      * apply maponpaths.
        apply maponpaths.
        exact (ggg (pr1 ff z)).
      * apply maponpaths.
        apply maponpaths_2.
        apply (!maponpathscomp _ _ _).
      * apply maponpaths.
        apply (!maponpathscomp0 (pr1 gg) _ _).
      * apply (!maponpathscomp0 (pr1 gg) _ _).
      * apply maponpaths.
        exact (fff z).
      * apply (maponpathscomp (pr1 ff)).
Defined.


From stdpp Require Export tactics.
From stdpp Require Import options.

Declare Scope stream_scope.
Delimit Scope stream_scope with stream.
Open Scope stream_scope.

CoInductive stream (A : Type) : Type := scons : A → stream A → stream A.
Arguments scons {_} _ _ : assert.
Infix ":.:" := scons (at level 60, right associativity) : stream_scope.
Bind Scope stream_scope with stream.

Definition shead {A} (s : stream A) : A := match s with x :.: _ => x end.
Definition stail {A} (s : stream A) : stream A := match s with _ :.: s => s end.

CoInductive stream_equiv' {A} (s1 s2 : stream A) : Prop :=
  scons_equiv' :
    shead s1 = shead s2 → stream_equiv' (stail s1) (stail s2) →
    stream_equiv' s1 s2.
Instance stream_equiv {A} : Equiv (stream A) := stream_equiv'.

Reserved Infix "!.!" (at level 20).
Fixpoint slookup {A} (i : nat) (s : stream A) : A :=
  match i with O => shead s | S i => stail s !.! i end
where "s !.! i" := (slookup i s).

Global Instance stream_fmap : FMap stream := λ A B f,
  cofix go s := f (shead s) :.: go (stail s).

Fixpoint stake {A} (n : nat) (s : stream A) :=
  match n with 0 => [] | S n => shead s :: stake n (stail s) end.
CoFixpoint srepeat {A} (x : A) : stream A := x :.: srepeat x.

Section stream_properties.
Context {A : Type}.
Implicit Types x y : A.
Implicit Types s t : stream A.

Lemma scons_equiv s1 s2 : shead s1 = shead s2 → stail s1 ≡ stail s2 → s1 ≡ s2.
Proof. by constructor. Qed.
Global Instance equal_equivalence : Equivalence (≡@{stream A}).
Proof.
  split.
  - now cofix FIX; intros ?; constructor.
  - now cofix FIX; intros ?? [??]; constructor.
  - cofix FIX; intros ??? [??] [??]; constructor; etrans; eauto.
Qed.
Global Instance scons_proper x : Proper ((≡) ==> (≡)) (scons x).
Proof. by constructor. Qed.
Global Instance shead_proper : Proper ((≡) ==> (=@{A})) shead.
Proof. by intros ?? [??]. Qed.
Global Instance stail_proper : Proper ((≡) ==> (≡@{stream A})) stail.
Proof. by intros ?? [??]. Qed.
Global Instance slookup_proper i : Proper ((≡@{stream A}) ==> (=)) (slookup i).
Proof. by induction i as [|i IH]; intros s1 s2 Hs; simpl; rewrite Hs. Qed.
End stream_properties.


Require Import syntax.
Require Import judgments.
Require Import Coq.Bool.Bool.

Theorem progress :
  forall e1 t,
  hasType cempty e1 t ->
  (exists e2, step e1 e2) \/
  value e1.
Proof.
  intros e1 t H1.
  remember cempty as c eqn:H in H1.
  induction H1 as [
    c                           (* tUnit *)
  | c x t H1                    (* tVar  *)
  | c x e t1 t2 H1 IH           (* tAbs  *)
  | c e1 e2 t1 t2 H1 IH1 H2 IH2 (* tApp  *)
  ].
  (* tUnit *)
  - right.
    apply valUnit.
  (* tVar *)
  - rewrite H in H1.
    simpl in H1.
    discriminate H1.
  (* tAbs *)
  - right.
    apply valAbs.
  (* tApp *)
  - left.
    elim (IH1 H).
    + intros H3.
      elim H3.
      intros e3 H4.
      exists (eapp e3 e1).
      apply stApp1.
      assumption.
    + intros H3.
      elim (IH2 H).
      * intros H4.
        elim H4.
        intros e3 H5.
        exists (eapp e2 e3).
        apply stApp2; auto.
      * {
        intros H4.
        destruct H3.
        (* eunit *)
        - inversion H1.
        (* eabs x t e *)
        - exists (subst e0 x e1).
          apply stAppAbs.
          assumption.
        }
Qed.

Lemma contextInvariance :
  forall c1 c2 e t1,
  hasType c1 e t1 -> (
    forall x,
    freeVar x e ->
    lookupEvar c1 x = lookupEvar c2 x
  ) ->
  hasType c2 e t1.
Proof.
  intros c1 c2 e t1 H1.
  generalize c2.
  clear c2.
  induction H1 as [
    c1                           (* tUnit *)
  | c1 x1 t1 H1                  (* tVar  *)
  | c1 x1 e1 t1 t2 H1 IH         (* tAbs  *)
  | c1 e1 e2 t1 t2 H1 IH1 H2 IH2 (* tApp  *)
  ].
  (* tUnit *)
  - intros.
    apply tUnit.
  (* tVar *)
  - intros c2 H2.
    apply tVar.
    rewrite <-H1.
    symmetry.
    apply H2.
    apply freeEvar.
    reflexivity.
  (* tAbs *)
  - intros c2 H2.
    apply tAbs.
    apply IH.
    simpl.
    intros x2 H3.
    destruct (eqId idTerm x2 x1) as [ H4 | H4 ].
    (* eqId idTerm x2 x1 = left e *)
    + reflexivity.
    (* eqId idTerm x2 x1 = right n *)
    + apply H2.
      apply freeAbs; assumption.
  (* tApp *)
  - intros c2 H3.
    apply tApp with (t1 := t1).
    (* hastype c2 e2 (tarrow t1 t2) *)
    + apply IH1.
      intros x1 H4.
      apply H3.
      apply freeApp2.
      assumption.
    (* hasType c2 e1 t1 *)
    + apply IH2.
      intros x1 H4.
      apply H3.
      apply freeApp1.
      assumption.
Qed.

Lemma freeVarsAppearInContext :
  forall c e x t1,
  hasType c e t1 ->
  freeVar x e ->
  exists t2,
  lookupEvar c x = Some t2.
Proof.
  intros c1 e1 x1 t1 H1 H2.
  induction H1 as [
    c1                           (* tUnit *)
  | c1 x2 t1 H1                  (* tVar  *)
  | c1 x2 e1 t1 t2 H1 IH         (* tAbs  *)
  | c1 e1 e2 t1 t2 H1 IH1 H3 IH2 (* tApp  *)
  ].
    (* tUnit *)
  - inversion H2.
    (* tVar *)
  - exists t1.
    inversion H2 as [
      x3 H3 H4 (* freeEvar *)
    |          (* freeAbs  *)
    |          (* freeApp1 *)
    |          (* freeApp2 *)
    ].
    congruence.
    (* tAbs *)
  - inversion H2 as [
                        (* freeEvar *)
    | x4 t3 e2 H3 H4 H5 (* freeAbs  *)
    |                   (* freeApp1 *)
    |                   (* freeApp2 *)
    ].
    apply IH in H4.
    destruct H4 as [ t4 ].
    exists t4.
    simpl in H4.
    destruct (eqId idTerm x1 x2) as [ Eq | Neq ].
    (* x1 = x2 *)
    + contradiction.
    (* x1 <> x2 *)
    + assumption.
    (* tApp *)
  - inversion H2 as [
                        (* freeEvar *)
    |                   (* freeAbs  *)
    | e3 e4 H4 H5       (* freeApp1 *)
    | e3 e4 H4 H5       (* freeApp2 *)
    ].
    (* freeApp1 *)
    + apply IH2.
      assumption.
    (* freeApp2 *)
    + apply IH1.
      assumption.
Qed.

Lemma swapVarsInContext :
  forall c1 x1 x2 x3 t1 t2,
  x1 <> x2 ->
  lookupEvar (cextend (cextend c1 x1 t1) x2 t2) x3 =
  lookupEvar (cextend (cextend c1 x2 t2) x1 t1) x3.
Proof.
  intros c1 x1 x2 x3 t1 t2 H1.
  simpl.
  destruct (eqId idTerm x3 x2) as [ Eq1 | Neq1 ].
  (* x3 = x2 *)
  - destruct (eqId idTerm x3 x1) as [ Eq2 | Neq2 ].
    (* x3 = x1 *)
    + rewrite Eq2 in Eq1.
      contradiction.
    (* x3 <> x1 *)
    + reflexivity.
  (* x3 <> x2 *)
  - destruct (eqId idTerm x3 x1); reflexivity.
Qed.

Lemma substPreservesType :
  forall c1 e1 e2 x1 t1 t2,
  hasType (cextend c1 x1 t2) e1 t1 ->
  hasType cempty e2 t2 ->
  hasType c1 (subst e1 x1 e2) t1.
Proof.
  intros c1 e1 e2 x1.
  generalize c1.
  clear c1.
  induction e1 as [
                  (* eunit *)
  | x2            (* evar  *)
  | x2 t3 e1 IH   (* eabs  *)
  | e1 IH1 e3 IH2 (* eapp  *)
  ].
  (* eunit *)
  - simpl.
    intros c1 t1 t2 H1 H2.
    inversion H1.
    apply tUnit.
  (* evar *)
  - intros c1 t1 t2 H1 H2.
    simpl.
    destruct (eqId idTerm x1 x2) eqn:H3.
    (* x1 = x2 *)
    + rewrite e in H1.
      inversion H1 as [
                    (* tUnit *)
      | c2 x3 t3 H4 (* tVar  *)
      |             (* tAbs  *)
      |             (* tApp  *)
      ].
      apply contextInvariance with (c1 := cempty).
      (* hasType cempty e2 t1 *)
      * simpl in H4.
        rewrite e in H3.
        rewrite H3 in H4.
        congruence.
      (* free variables occur in both contexts *)
      * {
        intros x4 H6.
        apply freeVarsAppearInContext with (c := cempty) (t1 := t2) in H6.
        (* lookupEvar cempty x4 = lookupEvar c1 x4 *)
        - destruct H6.
          inversion H6.
        (* hasType cempty e2 t2 *)
        - assumption.
        }
    (* hasType c1 (evar x2) t1 *)
    + apply tVar.
      inversion H1 as [
                             (* tUnit *)
      | c2 x3 t3 H4 H5 H6 H7 (* tVar  *)
      |                      (* tAbs  *)
      |                      (* tApp  *)
      ].
      simpl in H4.
      destruct (eqId idTerm x2 x1) as [ Eq | Neq ].
      (* x1 = x2 *)
      * contradiction n.
        congruence.
      (* x1 <> x2 *)
      * assumption.
  (* eabs *)
  - intros c1 t1 t2 H1 H2.
    simpl.
    inversion H1 as [
                                 (* tUnit *)
    |                            (* tVar  *)
    | c2 x3 e3 t4 t5 H4 H5 H6 H7 (* tAbs  *)
    |                            (* tApp  *)
    ].
    destruct (eqId idTerm x1 x2) eqn:H8.
    (* x1 = x2 *)
    + apply tAbs.
      rewrite e in H4.
      apply contextInvariance with (c1 := cextend (cextend c1 x2 t2) x2 t3).
      * assumption.
      * intros x4 H9.
        simpl.
        destruct (eqId idTerm x4 x2); congruence.
    (* x1 <> x2 *)
    + apply tAbs.
      apply IH with (t2 := t2).
      (* hasType (cextend (cextend c1 x2 t3) x1 t2) e1 t4 *)
      * {
        apply contextInvariance with (c1 := cextend (cextend c1 x1 t2) x2 t3).
        - congruence.
        - intros.
          apply swapVarsInContext.
          assumption.
        }
      (* hasType cempty e2 t2 *)
      * assumption.
  (* eapp *)
  - intros c1 t1 t2 H1 H2.
    simpl.
    inversion H1 as [
                                    (* tUnit *)
    |                               (* tVar  *)
    |                               (* tAbs  *)
    | c2 e4 e5 t3 t4 H4 H5 H6 H7 H8 (* tApp  *)
    ].
    apply tApp with (t1 := t3).
    (* hasType c1 (subst e1 x1 e2) (tarrow t3 t1) *)
    + apply IH1 with (t2 := t2); assumption.
    (* hasType c1 (subst e3 x1 e2) t3 *)
    + apply IH2 with (t2 := t2); assumption.
Qed.

Theorem preservation :
  forall e1 e2 t,
  hasType cempty e1 t ->
  step e1 e2 ->
  hasType cempty e2 t.
Proof.
  intros e1 e2 t H1.
  generalize e2.
  clear e2.
  remember cempty as c eqn:H2 in H1.
  induction H1 as [
                                (* tUnit *)
  | c x t H1                    (* tVar  *)
  | c x e t1 t2 H1 IH           (* tAbs  *)
  | c e1 e3 t1 t2 H1 IH1 H3 IH2 (* tApp  *)
  ].
  (* tUnit *)
  - intros e2 H1.
    inversion H1.
  (* tVar *)
  - intros e2 H3.
    inversion H3.
  (* tAbs *)
  - intros e2 H3.
    inversion H3.
  (* tApp *)
  - intros e2 H4.
    inversion H4 as [
      x e4 e5 t3 H5 H6 H7  (* stAppAbs *)
    | e4 e5 e6 H5 H6 H7    (* stApp1   *)
    | e4 e5 e6 H5 H6 H7 H8 (* stApp2   *)
    ].
    (* stAppAbs *)
    + clear IH1 IH2.
      apply substPreservesType with (t2 := t1).
      (* hasType (cextend cempty x t1) e4 t2 *)
      * rewrite <-H6 in H1.
        inversion H1.
        congruence.
      (* hasType cempty e1 t1 *)
      * congruence.
    (* stApp1 *)
    + set (H8 := IH1 H2 e5 H5).
      rewrite H2 in H3.
      set (H9 := tApp cempty e1 e5 t1 t2 H8 H3).
      assumption.
    (* stApp2 *)
    + set (H9 := IH2 H2 e6 H6).
      rewrite H2 in H1.
      set (H10 := tApp cempty e6 e3 t1 t2 H1 H9).
      assumption.
Qed.

Lemma bigstepPreservation :
  forall e1 e2 t1,
  hasType cempty e1 t1 ->
  bigstep e1 e2 ->
  hasType cempty e2 t1.
Proof.
  intros e1 e2 t1 H1 H2.
  induction H2 as [
                      (* bigRefl *)
  | e1 e2 e3 H2 IH H3 (* bigInd  *)
  ].
  - assumption.
  - apply preservation with (e1 := e2).
    + apply IH.
      assumption.
    + assumption.
Qed.

(* No well-typed program will get stuck. *)
Theorem soundness :
  forall e1 e2 t1,
  hasType cempty e1 t1 ->
  bigstep e1 e2 ->
  (exists e3, step e2 e3) \/
  value e2.
Proof.
  intros e1 e2 t1 H1 H2.
  induction H2 as [
                      (* bigRefl *)
  | e1 e2 e3 H2 IH H3 (* bigInd  *)
  ].
  - apply progress with (t := t1).
    assumption.
  - apply progress with (t := t1).
    apply bigstepPreservation with (e1 := e1).
    + assumption.
    + apply bigInd with (e2 := e2); assumption.
Qed.

(* Optional: determinism *)


Set Implicit Arguments.
Unset Automatic Introduction.

Require Import Setoid.
Require Import util.
Require vec.
Require List.
Require Vector.

Section contents.

  Variable T: Set.

  Inductive L: Set := one: T -> L | cons: T -> L -> L.

  Fixpoint to_plain (l: L): List.list T :=
    match l with one x => List.cons x List.nil | cons x y => List.cons x (to_plain y) end.

  Coercion to_plain: L >-> List.list.

  Fixpoint from_plain (x: T) (l: List.list T): L:=
    match l with
    | List.nil => one x
    | List.cons h t => cons x (from_plain h t)
    end.

  Lemma round_trip l x: (to_plain (from_plain x l)) = List.cons x l.
  Proof with auto. induction l... simpl. rewrite IHl... Qed.

  Fixpoint app (a b: L) {struct a}: L :=
    match a with
    | one x => cons x b
    | cons x y => cons x (app y b)
    end.

  Variable l: L.

  Definition head := match l with one x => x | cons x _ => x end.
  Definition tail := match l with one _ => List.nil | cons _ x => to_plain x end.

  Lemma head_in_self: List.In head l.
  Proof with auto. unfold head. destruct l; left... Qed.

  Lemma In_sound x: List.In x l -> (head = x \/ List.In x tail).
  Proof with auto. unfold head. unfold tail. destruct l... Qed.

  Lemma In_cons_head (x: T) y: List.In x (cons x y). left; reflexivity. Qed.
  Lemma In_one (x: T): List.In x (one x). left; reflexivity. Qed.

  Lemma coerced_cons_eq (h: T): List.cons h l = cons h l.
  Proof. auto. Qed.

End contents.

Definition map (A B: Set) (f: A -> B): L A -> L B :=
  fix r (l: L A): L B :=
    match l with
    | one x => one (f x)
    | cons h t => cons (f h) (r t)
    end.

Lemma plain_map (A B: Set) (f: A -> B) (l: L A): to_plain (map f l) = List.map f (to_plain l).
Proof with auto.
  induction l...
  simpl.
  rewrite IHl...
Qed.

Add Parametric Morphism (A B: Set): (@map A B)
  with signature (@ext_eq A B) ==> (@ext_eq (L A) (L B))
  as ne_list_map_ext_eq_morph.
Proof with try reflexivity.
  unfold ext_eq.
  intros.
  induction x0; simpl; rewrite H...
  rewrite IHx0...
Qed.

Lemma map_ext (T U: Set) (f g: T -> U): ext_eq f g -> forall l, map f l = map g l.
Proof. intros T U f g e. fold (ext_eq (map f) (map g)). rewrite e. reflexivity. Qed.

Lemma In_map_inv (T U: Set) (f: T -> U) (l: L T) (y: U): List.In y (map f l) -> exists x, f x = y /\ List.In x l.
Proof. induction l; simpl; intros; destruct H; firstorder. Qed.

Lemma length_ne_0 (A: Set) (l: L A): List.length l <> 0.
Proof with auto with arith. destruct l; simpl... Qed.

Lemma map_length (A B: Set) (f: A -> B) (l: L A): List.length (map f l) = List.length l.
Proof with auto. induction l... simpl. rewrite IHl... Qed.

Lemma map_map (A B C: Set) (g: A -> B) (f: B -> C) (l: L A):
  map f (map g l) = map (f ∘ g) l.
Proof with auto. induction l... simpl. rewrite IHl... Qed.

Lemma In_round_tripped_head (T: Set) (x: T) l: List.In x (from_plain x l).
Proof with auto. intros. rewrite round_trip. left... Qed.

Hint Immediate In_one.
Hint Immediate In_cons_head.
Hint Immediate head_in_self.
Hint Immediate In_round_tripped_head.

Fixpoint from_vec (A: Set) n: Vector.t A (S n) -> L A :=
  match n return Vector.t A (S n) -> L A with
  | 0 => fun v => one (vec.head v)
  | _ => fun v => cons (vec.head v) (from_vec (vec.tail v))
  end.

Lemma from_vec_to_plain (A: Set) n (v: Vector.t A (S n)): to_plain (from_vec v) = vec.to_list v.
Proof with reflexivity.
  induction n; intros.
    rewrite (vec.eq_cons v).
    simpl.
    rewrite (vec.eq_nil (vec.tail v))...
  rewrite (vec.eq_cons v).
  simpl.
  rewrite IHn...
Qed.


Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms Coq.Program.Basics.

Local Coercion is_true : bool >-> Sortclass.

Add Parametric Morphism {A: Type} :
  (fun (P: A -> Prop) => exists x, P x)
    with signature (pointwise_relation A iff ==> iff)
      as exists_eq_iff_morphism.
Proof.
  intros * equiv;
  split; intro H; destruct H as [x0 H']; exists x0;
  apply equiv in H'; assumption.
Qed.

Lemma impl_iff_Proper
: Proper (iff ==> iff ==> iff) impl.
Proof. lazy; tauto. Qed.
Lemma impl_impl_Proper
: Proper (Basics.flip impl ==> impl ==> impl) impl.
Proof. lazy; tauto. Qed.
Lemma ex_iff_Proper {A}
: Proper (pointwise_relation _ iff ==> iff) (@ex A).
Proof.
  lazy.
  intros ?? H;
    repeat (intros [] || intro || esplit);
    apply H; eassumption.
Defined.
Lemma ex_impl_Proper {A}
: Proper (pointwise_relation _ impl ==> impl) (@ex A).
Proof.
  lazy.
  intros ?? H;
    repeat (intros [] || intro || esplit);
    apply H; eassumption.
Defined.
Lemma and_iff_Proper
: Proper (iff ==> iff ==> iff) and.
Proof. lazy; tauto. Qed.
Lemma and_impl_Proper
: Proper (impl ==> impl ==> impl) and.
Proof. lazy; tauto. Qed.
Global Instance and_flip_impl_Proper
: Proper (flip impl ==> flip impl ==> flip impl) and.
Proof. lazy; tauto. Qed.
Global Instance pair_Proper {A B}
  : Proper (eq ==> eq ==> eq) (@pair A B).
Proof.
  lazy; intros; congruence.
Qed.
Global Instance andb_implb_Proper
  : Proper (flip implb ==> flip implb ==> flip implb) andb.
Proof.
  unfold flip, implb, andb.
  intros [] [] ? [] [] ?; trivial.
Qed.

Global Instance or_iff_iff_impl_Proper : Proper (iff ==> iff ==> impl) or | 2.
Proof. lazy; tauto. Qed.
Global Instance and_iff_iff_impl_Proper : Proper (iff ==> iff ==> impl) and | 2.
Proof. lazy; tauto. Qed.