(*|
============================
Delayed head of [ctree]s
============================
It is sometimes useful to compute the set of transition that a process
can perform.
From the traditional perspective of a LTS, this corresponds
to computing all possible finite trees justifying a transition.
From the perspective of [ctree]s, it corresponds to prefix of the
tree only made of invisible br nodes.
We develop in this file the [head] function to compute this prefix.

.. coq:: none
|*)

From CTree Require Import
	CTree Eq.

Import CTree.
Import CTreeNotations.
Open Scope ctree_scope.

Set Implicit Arguments.
Set Contextual Implicit.

(*|
The [head] computation is itself a tree. The values it computes is
the set of possible transition, i.e. enough data to recover the next label
and process.
The [haction] data structure captures trivially this data.
.. coq::
|*)

Variant haction {E R} :=
	| ARet    (r : R)
	| ABr (n : nat) (k : Fin.t n -> ctree E R)
	| AVis    (X : Type) (e : E X) (k : X -> ctree E R).

(*|
The [head] computation simply scrolls the tree until it reaches
a none invisible br node.
Notice that this computation may loop if the original computation
admits a infinite branch of invisible brs.
|*)
Definition head {E X} : ctree E X -> ctree E (@haction E X) :=
  cofix head (t : ctree E X) :=
    match observe t with
    | RetF x            => Ret (ARet x)
    | VisF e k          => Ret (AVis e k)
    | BrSF n k      => Ret (ABr k)
    | BrDF n k      => Br false n (fun i => head (k i))
    end.

Notation head_ t :=
  match observe t with
  | RetF x            => Ret (ARet x)
  | VisF e k          => Ret (AVis e k)
  | BrSF n k      => Ret (ABr k)
  | BrDF n k      => Br false n (fun i => head (k i))
  end.

Lemma unfold_head {E X} : forall (t : ctree E X),
    head t ≅ head_ t.
Proof.
  intros.
	now step.
Qed.

(*|
Transitions in a tree can always be reflected in their head-tree.
The exact shape of the lemma depends on the nature of the transition.
We wrap them together in [trans_head].
|*)
Lemma trans_head_obs {E X} : forall (t u : ctree E X) Y (e : E Y) v,
    trans (obs e v) t u ->
    exists (k : Y -> ctree E X),
      trans (val (AVis e k)) (head t) stuckD /\
        u ≅ k v.
Proof.
  intros * TR.
  unfold transR in *.
  remember (obs e v) as ob.
  setoid_rewrite (ctree_eta u).
  setoid_rewrite unfold_head.
  induction TR; try now inv Heqob.
  - destruct IHTR as (kf & IHTR & EQ); auto.
    exists kf; split; [| exact EQ].
    rename x into y.
    rewrite <- unfold_head in IHTR.
    eapply trans_brD with (x := y).
    apply IHTR.
    reflexivity.
  - dependent induction Heqob.
    exists k; split.
    constructor.
    rewrite <- ctree_eta; symmetry; assumption.
Qed.

Lemma trans_head_tau {E X} : forall (t u : ctree E X),
    trans tau t u ->
    exists n (k : Fin.t n -> ctree E X) x,
      trans (val (ABr k)) (head t) stuckD /\
        u ≅ k x.
Proof.
  intros * TR.
  unfold trans in *.
  remember tau as ob.
  setoid_rewrite (ctree_eta u).
  setoid_rewrite unfold_head.
  induction TR; try now inv Heqob; subst.
  - destruct IHTR as (m & kf & z & IHTR & EQ); auto.
    exists m, kf, z; split; [| exact EQ].
    rename x into y.
    rewrite <- unfold_head in IHTR.
    eapply trans_brD with (x := y).
    apply IHTR.
    reflexivity.
  - exists n,k,x; split.
    constructor.
    rewrite <- ctree_eta; symmetry; assumption.
Qed.

Lemma trans_head_ret {E X} : forall (t u : ctree E X) (v : X),
    trans (val v) t u ->
    trans (val (@ARet E X v)) (head t) stuckD /\
      u ≅ stuckD.
Proof.
  intros * TR.
  unfold trans in *.
  remember (val v) as ob.
  setoid_rewrite (ctree_eta u).
  setoid_rewrite unfold_head.
  induction TR; try now inv Heqob; subst.
  - destruct IHTR as (IHTR & EQ); auto.
    split; [| exact EQ].
    rewrite <- unfold_head in IHTR.
    rename x into y.
    eapply trans_brD with (x := y).
    apply IHTR.
    reflexivity.
  - dependent induction Heqob.
    split.
    constructor.
    symmetry; rewrite brD0_always_stuck; reflexivity.
Qed.

Lemma trans_head : forall {E X} (t u : ctree E X) l,
    trans l t u ->
    match l with
    | tau => exists n (k : Fin.t n -> ctree E X) x,
        trans (val (ABr k)) (head t) stuckD /\ u ≅ k x
    | obs e v => exists (k : _ -> ctree E X),
        trans (val (AVis e k)) (head t) stuckD /\ u ≅ k v
    | val v => trans (val (@ARet E _ v)) (head t) stuckD /\ u ≅ stuckD
    end.
Proof.
  intros *; destruct l.
  apply trans_head_tau.
  apply trans_head_obs.
  intros A.
  pose proof (trans_val_invT A); subst; apply trans_head_ret; assumption.
Qed.

(*|
The only transitions that the head-tree can take are value ones.
|*)
Lemma trans_head_inv {E X} : forall (P : ctree E X) l u,
    trans l (head P) u ->
    is_val l.
Proof.
  intros * TR.
  remember (head P) as AP.
  eq2equ HeqAP.
  rewrite ctree_eta in EQ.
  revert P EQ.
  induction TR; intros; subst.
  - rewrite unfold_head in EQ.
    desobs P; try now (step in EQ; inv EQ).
    destruct vis.
    + step in EQ; inv EQ.
    + step in EQ; destruct (equb_br_invT _ _ EQ) as [-> _].
      eapply equb_br_invE in EQ.
      setoid_rewrite <- ctree_eta in IHTR.
      eapply IHTR; eauto.
  - exfalso.
    rewrite unfold_head in EQ.
    desobs P; try now (step in EQ; inv EQ).
    destruct vis.
    + step in EQ; inv EQ.
    + step in EQ; apply equb_br_invT in EQ as [_ abs]; inv abs.
  - exfalso.
    rewrite unfold_head in EQ.
    desobs P; try now (step in EQ; inv EQ).
    destruct vis; step in EQ; inv EQ.
  - constructor.
Qed.

Lemma trans_ARet :
  forall {E X} r (p: ctree E X) q,
    trans (val (@ARet E X r)) (head p) q ->
    trans (val r) p stuckD.
Proof.
  intros * TR.
  remember (head p) as Ap.
  remember (val (ARet r)) as l.
  eq2equ HeqAp.
  rewrite ctree_eta in EQ.
  revert p EQ r Heql.
  induction TR; intros; subst; try now inv Heql.
  - rewrite unfold_head in EQ.
    unfold trans.
    cbn; red.
    desobs p; try now (step in EQ; inv EQ).
    destruct vis.
    + step in EQ; inv EQ.
    + step in EQ; destruct (equb_br_invT _ _ EQ) as [-> _].
      eapply equb_br_invE in EQ.
      setoid_rewrite <- ctree_eta in IHTR.
      econstructor.
      apply IHTR; eauto.
  - unfold trans.
    apply val_eq_inv in Heql; inv Heql.
    rewrite unfold_head in EQ.
    cbn; red.
    desobs p; try now (step in EQ; inv EQ).
    step in EQ; inv EQ. inv REL; constructor.
    destruct vis.
    + step in EQ. inv EQ. inv REL.
    + step in EQ; inv EQ.
Qed.

Lemma trans_ABr :
  forall {E X} n k (p: ctree E X) q,
    trans (val (ABr (n := n) k)) (head p) q ->
    forall i, trans tau p (k i).
Proof.
  intros * TR.
  remember (head p) as Ap.
  remember (val (ABr k)) as l.
  eq2equ HeqAp.
  rewrite ctree_eta in EQ.
  revert p EQ k Heql.
  induction TR; intros; subst; try now inv Heql.
  - rewrite unfold_head in EQ.
    unfold trans.
    cbn; red.
    desobs p; try now (step in EQ; inv EQ).
    destruct vis.
    + step in EQ; inv EQ.
    + step in EQ; destruct (equb_br_invT _ _ EQ) as [-> _].
      eapply equb_br_invE in EQ.
      setoid_rewrite <- ctree_eta in IHTR.
      econstructor.
      apply IHTR; eauto.
  - apply val_eq_inv in Heql; inv Heql.
    rewrite unfold_head in EQ.
    unfold trans.
    cbn; red.
    desobs p; try now (step in EQ; inv EQ).
    destruct vis.
    + step in EQ; inv EQ.
      dependent induction REL.
      apply trans_brS.
    + step in EQ; inv EQ.
Qed.

Lemma trans_AVis :
  forall {E X Y} (e : E Y) (p: ctree E X) (k : Y -> ctree E X) q,
    trans (val (AVis e k)) (head p) q ->
    forall i, trans (obs e i) p (k i).
Proof.
  intros * TR.
  remember (head p) as Ap.
  remember (val (AVis e k)) as l.
  eq2equ HeqAp.
  rewrite ctree_eta in EQ.
  revert p EQ k Heql.
  induction TR; intros; subst; try now inv Heql.
  - rewrite unfold_head in EQ.
    unfold trans.
    cbn; red.
    desobs p; try now (step in EQ; inv EQ).
    destruct vis.
    + step in EQ; inv EQ.
    + step in EQ; destruct (equb_br_invT _ _ EQ) as [-> _].
      eapply equb_br_invE in EQ.
      setoid_rewrite <- ctree_eta in IHTR.
      econstructor.
      apply IHTR; eauto.
  - apply val_eq_inv in Heql; inv Heql.
    rewrite unfold_head in EQ.
    unfold trans.
    cbn; red.
    desobs p; try now (step in EQ; inv EQ).
    + step in EQ; inv EQ.
      dependent induction REL.
      constructor; reflexivity.
    + destruct vis; step in EQ; inv EQ.
      inv REL.
Qed.

(*|
[head] is a computation computing computations. It's therefore not as
well-behaved w.r.t. to [equ] as usual: rewriting [equ eq] leads to [equ eq_haction]
computations, where [eq_haction] propagates [equ] to the computations contained in the
actions.
|*)
Variant eq_haction {E R} : @haction E R -> haction -> Prop :=
| eq_haction_ret : forall r, eq_haction (ARet r) (ARet r)
| eq_haction_br : forall n (k1 k2 : fin n -> _),
    (forall i, k1 i ≅ k2 i) ->
    eq_haction (ABr k1) (ABr k2)
| eq_haction_vis : forall X (e : E X) k1 k2,
    (forall x, k1 x ≅ k2 x) ->
    eq_haction (AVis e k1) (AVis e k2).

#[global] Instance eq_haction_equiv {E R} : Equivalence (@eq_haction E R).
Proof.
  split.
  - intros []; constructor; auto.
  - intros x y xy.
    dependent destruction xy; constructor; intros; symmetry; auto.
  - intros x y z xy yz.
    dependent destruction xy;
      dependent destruction yz.
    constructor.
    constructor; intros; rewrite H; auto.
    constructor; intros; rewrite H; auto.
Qed.

#[global] Instance head_equ {E X} :
  Proper (equ eq ==> equ (eq_haction)) (@head E X).
Proof.
  unfold Proper, respectful.
  unfold equ; coinduction S CIH.
  intros.
  rewrite 2 unfold_head.
  step in H.
  inv H.
  - do 2 constructor.
  - do 2 constructor; auto.
  - destruct b.
    + do 2 constructor; auto.
    + constructor; intros ?; auto.
Qed.

Definition run_haction {E X} (hd : @haction E X) : ctree E X :=
  match hd with
  | ARet r => Ret r
  | @ABr _ _ n k => BrS n k
  | AVis e k => Vis e k
  end.

Lemma get_run_haction {E X} : forall (t : ctree E X),
    t ≅ head t >>= run_haction.
Proof.
  coinduction r cih.
  intros t.
  rewrite (ctree_eta t) at 1.
  rewrite unfold_head.
  desobs t.
  - rewrite bind_ret_l; reflexivity.
  - rewrite bind_ret_l; reflexivity.
  - destruct vis.
    + rewrite bind_ret_l; reflexivity.
    + rewrite bind_br; constructor; intros.
      apply cih.
Qed.


Require Import Ascii List Program Ascii.
Require Import Util ListUtil.
Require Charset.

Module Make(C : Charset.Sig).

Definition encode_ (r: nat) bs :=
  bs |> concat_map bits_of_byte
     |> (fun bits => bits ++ repeat false (C.char_size - r))
     |> ntake C.char_size
     |> map C.of_bits
.

Definition decode_ (r: nat) cs :=
  cs |> concat_map C.to_bits
     |> drop_right (C.char_size - r)
     |> ntake byte_size
     |> map byte_of_bits
.

Definition modulo_charsize n := modulo n C.char_size C.char_size_positive.

Definition encode bs :=
  let r := byte_size * List.length bs |> modulo_charsize in
  encode_ r bs ++ [C.of_nat r].

Definition decode (cs: list C.char) :=
  let '(cs, lastchar) := split_last C.dummy cs in
  let r := lastchar |> C.to_nat in
  decode_ r cs.

End Make.


Require Import compcert.common.Memory.

Inductive permjoin : option permission -> option permission -> option permission -> Prop :=
  | permjoin_None_l x : permjoin None x x
  | permjoin_None_r x : permjoin x None x
  (* NE + NE = NE *)
  | permjoin_NNN : permjoin (Some Nonempty) (Some Nonempty) (Some Nonempty)
  (* NE + R = R *)
  | permjoin_NRR : permjoin (Some Nonempty) (Some Readable) (Some Readable)
  | permjoin_RNR : permjoin (Some Readable) (Some Nonempty) (Some Readable)
  (* NE + W = W or F *)
  | permjoin_NWW : permjoin (Some Nonempty) (Some Writable) (Some Writable)
  | permjoin_NWF : permjoin (Some Nonempty) (Some Writable) (Some Freeable)
  | permjoin_WNW : permjoin (Some Writable) (Some Nonempty) (Some Writable)
  | permjoin_WNF : permjoin (Some Writable) (Some Nonempty) (Some Freeable)
  (* R + R = R or W or F *)
  | permjoin_RRR : permjoin (Some Readable) (Some Readable) (Some Readable)
  | permjoin_RRW : permjoin (Some Readable) (Some Readable) (Some Writable)
  | permjoin_RRF : permjoin (Some Readable) (Some Readable) (Some Freeable)
  (* R + W = W or F *)
  | permjoin_RWW : permjoin (Some Readable) (Some Writable) (Some Writable)
  | permjoin_WRW : permjoin (Some Writable) (Some Readable) (Some Writable)
  | permjoin_RWF : permjoin (Some Readable) (Some Writable) (Some Freeable)
  | permjoin_WRF : permjoin (Some Writable) (Some Readable) (Some Freeable).

  Lemma permjoin_comm:
    forall p1 p2 p3,
      permjoin p1 p2 p3 <-> permjoin p2 p1 p3.
  Proof.
    intros.
    split; intros;
      inversion H; subst;
        eauto using permjoin.
  Qed.

  Lemma permjoin_readable_if:
    forall p1 p2 p3
      (Hjoin: permjoin p1 p2 p3)
      (Hp1: Mem.perm_order' p1 Readable),
      Mem.perm_order' p3 Readable.
  Proof.
    intros.
    destruct p1 as [p1|]; simpl in Hp1; try (exfalso; now eauto);
      destruct p1; inversion Hp1; subst;
      inversion Hjoin; subst;
      simpl;
      now eauto using perm_order.
  Qed.

  Lemma permjoin_readable_iff:
    forall p1 p2 p3
      (Hjoin: permjoin p1 p2 p3),
      Mem.perm_order' p3 Readable <-> Mem.perm_order' p1 Readable \/ Mem.perm_order' p2 Readable.
  Proof.
    intros.
    split; intros Hreadable.
    - destruct p3 as [p3|]; simpl in Hreadable; try (exfalso; now eauto);
        destruct p3; inversion Hreadable; subst;
          inversion Hjoin; subst; simpl;
            eauto using perm_order.
    - destruct Hreadable;
        [| apply permjoin_comm in Hjoin];
        eauto using permjoin_readable_if.
  Qed.

   Lemma permjoin_order:
    forall p1 p2 p3
      (Hjoin: permjoin p1 p2 p3),
      Mem.perm_order'' p3 p1 /\ Mem.perm_order'' p3 p2.
  Proof.
    intros.
    destruct p1 as [p1|];
      destruct p2 as [p2|];
      inversion Hjoin; simpl;
      split; constructor.
  Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteTask.

  Import SporadicTaskset.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_task :=
    {
      task_id: nat; (* for uniqueness *)
      task_cost: nat;
      task_period: nat;
      task_deadline: nat;
      task_jitter: nat
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete tasks. *)
    Definition task_eqdef (t1 t2: concrete_task) :=
      (task_id t1 == task_id t2) &&
      (task_cost t1 == task_cost t2) &&
      (task_period t1 == task_period t2) &&
      (task_deadline t1 == task_deadline t2) &&
      (task_jitter t1 == task_jitter t2).

    (* Next, we prove that task_eqdef is indeed an equality, ... *)
    Lemma eqn_task : Equality.axiom task_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (task_eqdef x y) eqn:EQ.
      {
        apply ReflectT.
        unfold task_eqdef in *.
        move: EQ => /andP [/andP [/andP [/andP [/eqP ID /eqP COST] /eqP PERIOD] /eqP DL] /eqP JIT].
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold task_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [/orP [EQ | /eqP DL] | /eqP JIT]; last by apply JIT; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP DL]; last by apply DL; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP PERIOD]; last by apply PERIOD; inversion BUG.
        by apply ID; inversion BUG.
        by apply DL; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_task_eqMixin := EqMixin eqn_task.
    Canonical concrete_task_eqType := Eval hnf in EqType concrete_task concrete_task_eqMixin.

  End Defs.

  Section ConcreteTaskset.

    Definition concrete_taskset :=
      taskset_of concrete_task_eqType.

  End ConcreteTaskset.

End ConcreteTask.


From Undecidability.FOL Require Export Semantics Kripke Deduction.

(* Definitions concerning first-order logic *)

(* On Synthetic Undecidability in Coq, with an Application to the Entscheidungsproblem. Yannick Forster, Dominik Kirst, and Gert Smolka. CPP '19. https://www.ps.uni-saarland.de/extras/fol-undec *)

About prv_min.   (* Minimal provability *)
About prv_into.  (* Intuitionistic provability *)
About prv_class. (* Classical provability *)

About valid.  (* Tarski validity *)
About kvalid. (* Kripke validity *)

About satis.  (* Tarksi satisfiability *)
About ksatis. (* Kripke satisfiability *)


From Coq Require Import Program.Equality.
From Coq Require Import Lia.
From Coq Require Import ClassicalChoice.

Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Export Families.
Require Export FiniteTypes.
Require Export IndexedFamilies.
Require Export CountableTypes.
Require Import Proj1SigInjective.
Require Export Powerset_facts.

Inductive finite_intersections {X:Type} (S:Family X) : Family X :=
  | intro_full: In (finite_intersections S) Full_set
  | intro_S: forall U:Ensemble X, In S U -> In (finite_intersections S) U
  | intro_intersection: forall U V:Ensemble X,
    In (finite_intersections S) U -> In (finite_intersections S) V ->
    In (finite_intersections S) (Intersection U V).

Lemma finite_intersection_is_finite_indexed_intersection:
  forall {X:Type} (S:Family X) (U:Ensemble X),
  In (finite_intersections S) U -> exists J:Type, FiniteT J /\
  exists V:J->Ensemble X,
  (forall j:J, In S (V j)) /\ U = IndexedIntersection V.
Proof.
intros.
induction H.
exists False.
split.
constructor.
exists (False_rect _).
split.
destruct j.
symmetry; apply empty_indexed_intersection.

exists True.
split.
exact True_finite.
exists (True_rect U).
split.
destruct j.
simpl.
trivial.
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct a; simpl.
trivial.
destruct H0.
exact (H0 I).
destruct IHfinite_intersections as [J0 [? [W []]]].
destruct IHfinite_intersections0 as [J1 [? [W' []]]].
exists ((J0+J1)%type).
split.
apply finite_sum; trivial.
exists (fun s:J0+J1 => match s with
  | inl j => W j
  | inr j => W' j
end).
split.
destruct j; auto.
apply Extensionality_Ensembles; split; red; intros.
destruct H7.
rewrite H3 in H7; destruct H7.
rewrite H6 in H8; destruct H8.
constructor.
destruct a as [j|j]; auto.
destruct H7.
constructor.
rewrite H3; constructor.
intro j.
exact (H7 (inl _ j)).
rewrite H6; constructor.
intro j.
exact (H7 (inr _ j)).
Qed.

Lemma finite_indexed_intersection_is_finite_intersection:
  forall {X:Type} (S:Family X) (J:Type) (V:J->Ensemble X),
  FiniteT J -> (forall j:J, In S (V j)) ->
  In (finite_intersections S) (IndexedIntersection V).
Proof.
intros.
induction H.
rewrite empty_indexed_intersection.
constructor.

assert (IndexedIntersection V = Intersection
  (IndexedIntersection (fun j:T => V (Some j)))
  (V None)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
constructor.
constructor.
trivial.
trivial.
destruct H1.
constructor.
destruct H1.
destruct a as [j|]; trivial.
rewrite H1.
constructor 3; auto.
constructor 2; trivial.

destruct H1 as [g].
assert (IndexedIntersection V =
  IndexedIntersection (fun x:X0 => V (f x))).
apply Extensionality_Ensembles; split; red; intros.
destruct H3.
constructor.
trivial.
destruct H3.
constructor.
intro.
rewrite <- (H2 a).
trivial.
rewrite H3; auto.
Qed.

Section Lemmas.
Open Scope nat.

Inductive finite_intersections_len {X : Type} (F : Family X) : IndexedFamily nat (Ensemble X) :=
  | intro_fi_len_full : In (finite_intersections_len F 0) Full_set
  | intro_fi_len_S : forall U : Ensemble X, In F U -> In (finite_intersections_len F 1) U
  | intro_fi_len_intersection : forall (U V : Ensemble X) (m k : nat),
                         In (finite_intersections_len F m) U ->
                         In (finite_intersections_len F k) V ->
                         In (finite_intersections_len F (m + k)) (Intersection U V).

Lemma finite_intersections_len_0_full_set
  {X : Type}
  {F : Family X}
  {U : Ensemble X} :
  In (finite_intersections_len F 0) U -> U = Full_set.
Proof.
intro H.
red in H.
dependent induction H.
{ reflexivity. }
rewrite IHfinite_intersections_len.
2: { lia. }
rewrite Intersection_Full_set.
rewrite IHfinite_intersections_len0.
{ reflexivity. }
lia.
Qed.

Lemma finite_intersections_len_1_in
  {X : Type}
  {F : Family X}
  {U : Ensemble X} :
  In (finite_intersections_len F 1) U -> In F U.
Proof.
intro H.
red in H.
dependent induction H.
- assumption.
- destruct m, k;
    discriminate + injection x as x;
    subst.
  + rewrite (finite_intersections_len_0_full_set H), Intersection_Full_set.
    now apply IHfinite_intersections_len0.
  + rewrite (finite_intersections_len_0_full_set H0), Intersection_commutative, Intersection_Full_set.
    apply IHfinite_intersections_len.
    lia.
  + lia.
Qed.

Lemma finite_intersections_len_SS_intersection
  {X : Type}
  {F : Family X}
  {U : Ensemble X}
  (n : nat) :
  In (finite_intersections_len F (S (S n))) U ->
  exists m k V W,
    In (finite_intersections_len F (S m)) V /\
    In (finite_intersections_len F (S k)) W /\
    U = Intersection V W /\
    n = m + k.
Proof.
intro H.
red in H.
dependent induction H.
- destruct m, k;
    discriminate + injection x as x;
    subst.
  + rewrite (finite_intersections_len_0_full_set H), Intersection_Full_set.
    now apply IHfinite_intersections_len0.
  + rewrite (finite_intersections_len_0_full_set H0), Intersection_commutative, Intersection_Full_set.
    apply IHfinite_intersections_len.
    lia.
  + exists m, k, U, V.
    repeat split;
      lia + assumption.
Qed.

Lemma finite_intersections_len_S_exists
  {X : Type}
  {F : Family X}
  {U : Ensemble X}
  {n : nat} :
  In (finite_intersections_len F (S n)) U ->
  exists V W,
    In (finite_intersections_len F n) V /\
    In (finite_intersections_len F 1) W /\
    U = Intersection V W.
Proof.
generalize dependent U.
generalize dependent n.
apply (well_founded_ind lt_wf (fun n =>
  forall U,
    In (finite_intersections_len F (S n)) U ->
  exists V W,
    In (finite_intersections_len F n) V /\
    In (finite_intersections_len F 1) W /\
    U = Intersection V W)).
intros [|n] IH U H.
- apply finite_intersections_len_1_in in H.
  exists Full_set, U.
  now repeat split;
    constructor + rewrite Intersection_Full_set.
- apply finite_intersections_len_SS_intersection in H.
  destruct H as [m [[|k] [V [W [HV [HW [eq1 eq2]]]]]]].
  + rewrite Nat.add_0_r in eq2.
    subst.
    now exists V, W.
  + apply IH in HV; [|lia].
    destruct HV as [V1 [V2 [HV1 [HV2 eq3]]]].
    rewrite eq2, plus_n_Sm.
    exists (Intersection V1 W), V2.
    repeat (constructor; try easy).
    subst.
    now rewrite (Intersection_associative V1 W),
                (Intersection_commutative _ W),
             <- (Intersection_associative V1).
Qed.

Lemma finite_intersections_len_S_choice
  {X : Type}
  (F : Family X)
  (n : nat) :
  exists f : {U : Ensemble X | In (finite_intersections_len F (S n)) U} ->
             {U : Ensemble X | In (finite_intersections_len F n) U} *
             {U : Ensemble X | In (finite_intersections_len F 1) U},
  forall U, proj1_sig U = Intersection (proj1_sig (fst (f U))) (proj1_sig (snd (f U))).
Proof.
apply choice with (R :=
  fun U : {U : Ensemble X | In (finite_intersections_len F (S n)) U} =>
  fun y : {U : Ensemble X | In (finite_intersections_len F n) U} *
          {U : Ensemble X | In (finite_intersections_len F 1) U} =>
    proj1_sig U = Intersection (proj1_sig (fst y)) (proj1_sig (snd y))).
intros [? HU].
destruct (finite_intersections_len_S_exists HU) as [V [W [HV [HW ?]]]].
now exists (exist _ V HV, exist _ W HW).
Qed.

Lemma finite_intersections_len_union
  {X : Type}
  (F : Family X) :
  IndexedUnion (finite_intersections_len F) = finite_intersections F.
Proof.
apply Extensionality_Ensembles.
split.
- intros ? [n U HU].
  red in HU.
  dependent induction HU.
  + apply intro_full.
  + now apply intro_S.
  + now apply intro_intersection.
- intros ? HU.
  red in HU.
  dependent induction HU;
    try destruct IHHU, IHHU0;
    econstructor.
  + constructor.
  + now apply intro_fi_len_S.
  + apply intro_fi_len_intersection.
    exact H1.
    exact H2.
Qed.

Lemma finite_intersections_countable
  {X : Type}
  (F : Family X) :
  Countable F -> Countable (finite_intersections F).
Proof.
intros [f Hf].
rewrite <- finite_intersections_len_union.
apply countable_union.
- apply nat_countable.
- intro n.
  induction n.
  + apply intro_nat_injection with (fun x => 0).
    intros [U HU] [V HV] eq.
    apply proj1_sig_injective.
    simpl.
    now rewrite (finite_intersections_len_0_full_set HU),
                (finite_intersections_len_0_full_set HV).
  + destruct (finite_intersections_len_S_choice F n) as [g Hg],
             IHn as [fn Hfn].
    refine (inj_countable (fun U =>
      (fn (fst (g U)),
       f (exist _ (proj1_sig (snd (g U))) _)))
      countable_nat_product _).
    intros [U HU] [V HV] eq.
  injection eq as eq1 eq2.
  apply Hfn, proj1_sig_eq in eq1.
  apply Hf, proj1_sig_eq in eq2.
  apply Proj1SigInjective.proj1_sig_injective.
  now rewrite Hg, Hg, eq1, eq2.
  Unshelve.
  destruct (snd (g U)).
  now apply finite_intersections_len_1_in.
Qed.

End Lemmas.


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

Require Import Lia.
Require Import Arith.
Require Import Setoid.
Require Import Morphisms.
Require Import Relations.
Require Import Local.Prelude.
Require Import Local.Syntax.
Require Import Local.Metatheory.
Require Import Local.AbstractRewriting.
Require Import Local.Context.

(** ** Axiomatic semantics *)

Definition RECJMP (R: relation pseudoterm): Prop :=
  forall xs ts c,
  length xs = length ts ->
  R (bind (jump 0 xs) ts c)
    (bind (apply_parameters xs 0 (lift 1 (length ts) c)) ts c).

Global Hint Unfold RECJMP: cps.

(* My first intuition was to make the redex as [jump (length ts + k) _], by
   using a bound var (that is not a parameter), but this is too restrictive for
   our "high-order" definition of pseudoterms; lifting k instead solves this,
   and it properly captures the notion of (ETA) for actual terms. *)

Definition ETA (R: relation pseudoterm): Prop :=
  forall b ts k,
  R (bind b ts (jump (lift (length ts) 0 k) (low_sequence (length ts))))
    (subst k 0 b).

Global Hint Unfold ETA: cps.

Definition DISTR (R: relation pseudoterm): Prop :=
  forall b ms m ns n,
  not_free_list 0 ms ->
  R (bind (bind b ms m) ns n)
    (bind (bind
      (switch_bindings 0 b)
      (traverse_list (lift 1) 0 ns)
        (lift 1 (length ns) n))
      (traverse_list remove_binding 0 ms) (bind
        (right_cycle (length ms) 0 m)
        (traverse_list (lift (length ms)) 0 ns)
          (lift (length ms) (length ns) n))).

Global Hint Unfold DISTR: cps.

Definition CONTR (R: relation pseudoterm): Prop :=
  forall b ts c,
  R (bind (bind b (traverse_list (lift 1) 0 ts) (lift 1 (length ts) c)) ts c)
    (bind (remove_binding 0 b) ts c).

Global Hint Unfold CONTR: cps.

Definition GC (R: relation pseudoterm): Prop :=
  forall b ts c,
  not_free 0 b ->
  R (bind b ts c) (remove_binding 0 b).

Global Hint Unfold GC: cps.

(* Float left: L { M } { N } == L { N } { M } if n doesn't appear in M. *)

Definition FLOAT_LEFT (R: relation pseudoterm): Prop :=
  forall b ms m ns n,
  not_free (length ms) m ->
  not_free_list 0 ms ->
  R (bind (bind b ms m) ns n)
    (bind (bind
      (switch_bindings 0 b)
      (traverse_list (lift 1) 0 ns)
        (lift 1 (length ns) n))
      (traverse_list remove_binding 0 ms)
        (remove_binding (length ms) m)).

(* Float right: L { M } { N } == L { M { N } } if n doesn't appear in L. *)

Definition FLOAT_RIGHT (R: relation pseudoterm): Prop :=
  forall b ms m ns n,
  not_free 1 b ->
  not_free_list 0 ms ->
  R (bind (bind b ms m) ns n)
    (bind
      (* Is this the same as remove_binding 1 b? *)
      (remove_binding 0 (switch_bindings 0 b))
      (traverse_list remove_binding 0 ms)
        (bind
          (right_cycle (length ms) 0 m)
          (traverse_list (lift (length ms)) 0 ns)
            (lift (length ms) (length ns) n))).

(* As of now, I'm still unsure whether we'll need a directed, one-step struct
   relation or just it's congruence version. Just to be sure, we'll define it
   anyway. Note that we do not add contraction here as it is derivable in the
   equivalence closure of this relation. *)

Inductive struct: relation pseudoterm :=
  | struct_recjmp:
    RECJMP struct
  | struct_distr:
    DISTR struct
  | struct_eta:
    ETA struct
  | struct_gc:
    GC struct
  | struct_bind_left:
    LEFT struct
  | struct_bind_right:
    RIGHT struct.

Global Hint Constructors struct: cps.

(* We'll just define the structural congruence, representing the axiomatic
   semantics, as the smallest equivalence relation closed under the [struct]
   rules above. *)

Notation sema := rst(struct).
Notation "[ a == b ]" := (sema a b)
  (at level 0, a, b at level 200): type_scope.

Lemma sema_eq:
  forall a b,
  a = b -> [a == b].
Proof.
  intros.
  destruct H.
  auto with cps.
Qed.

Lemma sema_refl:
  forall e,
  [e == e].
Proof.
  auto with cps.
Qed.

Global Hint Resolve sema_refl: cps.

Lemma sema_sym:
  forall a b,
  [a == b] -> [b == a].
Proof.
  auto with cps.
Qed.

Global Hint Resolve sema_sym: cps.

Lemma sema_trans:
  forall a b c,
  [a == b] -> [b == c] -> [a == c].
Proof.
  eauto with cps.
Qed.

Global Hint Resolve sema_trans: cps.

Lemma sema_struct:
  forall a b,
  struct a b -> [a == b].
Proof.
  auto with cps.
Qed.

Global Hint Resolve sema_struct: cps.

Lemma sema_recjmp:
  RECJMP sema.
Proof.
  auto with cps.
Qed.

Global Hint Resolve sema_recjmp: cps.

Lemma sema_distr:
  DISTR sema.
Proof.
  auto with cps.
Qed.

Global Hint Resolve sema_distr: cps.

Lemma sema_eta:
  ETA sema.
Proof.
  auto with cps.
Qed.

Global Hint Resolve sema_eta: cps.

Lemma sema_gc:
  GC sema.
Proof.
  auto with cps.
Qed.

Global Hint Resolve sema_gc: cps.

Lemma sema_bind_left:
  LEFT sema.
Proof.
  induction 1; eauto with cps.
Qed.

Global Hint Resolve sema_bind_left: cps.

Lemma sema_bind_right:
  RIGHT sema.
Proof.
  induction 1; eauto with cps.
Qed.

Global Hint Resolve sema_bind_right: cps.

Global Instance sema_is_a_congruence: Congruence sema.
Proof.
  split.
  - split.
    + exact sema_refl.
    + exact sema_sym.
    + exact sema_trans.
  - exact sema_bind_left.
  - exact sema_bind_right.
Defined.

(* Our (DISTR) rule is particularly annoying to do with de Bruijn indexes and it
   did take some time to approach correctly. Take the following as an example,
   moving from our [ex1] into [ex2].

                                         \j.\x.\y.\z.
    \j.\x.\y.\z.                           h@0<y@3, k@1, x@4>
      h@1<y@3, k@0, x@4>                   { h<c, d, e> =
      { k<a, b> =                 ==           d@1<e@0, z@4> }
          h@2<b@0, j@6, a@1> }             { k<a, b> =
      { h<c, d, e> =                           h@0<b@1, j@6, a@2>
          d@1<e@0, z@3> }                      { h<c, d, e> =
                                                 d@1<e@0, z@5> } }

    We can now show that this equivalence holds. *)

Example ex2: pseudoterm :=
  (bind (bind
    (jump 0 [bound 4; bound 1; bound 3])
    [base; negation [base; base]; base]
      (jump 1 [bound 4; bound 0]))
    [base; base]
      (bind
        (jump 0 [bound 2; bound 6; bound 1])
        [base; negation [base; base]; base]
          (jump 1 [bound 5; bound 0]))).

Goal [ex1 == ex2].
Proof.
  apply sema_distr.
  do 3 constructor.
Qed.

Local Lemma struct_recjmp_helper:
  forall xs ts c x1 x2 x3,
  x1 = apply_parameters xs 0 (lift 1 (length xs) c) ->
  x2 = ts ->
  x3 = c ->
  length xs = length ts ->
  struct (bind (jump 0 xs) ts c) (bind x1 x2 x3).
Proof.
  intros.
  rewrite H, H0, H1, H2.
  apply struct_recjmp; auto.
Qed.

Local Lemma struct_distr_helper:
  forall b ms m ns n x1 x2 x3 x4 x5 x6 x7,
  x1 = switch_bindings 0 b ->
  x2 = lift 1 (length ns) n ->
  x3 = right_cycle (length ms) 0 m ->
  x4 = lift (length ms) (length ns) n ->
  x5 = traverse_list (lift 1) 0 ns ->
  x6 = traverse_list (lift (length ms)) 0 ns ->
  x7 = traverse_list remove_binding 0 ms ->
  not_free_list 0 ms ->
  struct (bind (bind b ms m) ns n) (bind (bind x1 x5 x2) x7 (bind x3 x6 x4)).
Proof.
  intros.
  rewrite H, H0, H1, H2, H3, H4, H5.
  apply struct_distr; auto.
Qed.

Local Lemma struct_eta_helper:
  forall b ts k x1 x2,
  x1 = jump (lift (length ts) 0 k) (low_sequence (length ts)) ->
  x2 = subst k 0 b ->
  struct (bind b ts x1) x2.
Proof.
  intros.
  rewrite H, H0.
  apply struct_eta.
Qed.

Local Lemma struct_gc_helper:
  forall b ts c x1,
  x1 = remove_binding 0 b ->
  not_free 0 b ->
  struct (bind b ts c) x1.
Proof.
  intros.
  rewrite H.
  apply struct_gc; auto.
Qed.

Lemma struct_lift:
  forall a b,
  struct a b ->
  forall i k,
  struct (lift i k a) (lift i k b).
Proof.
  induction 1; intros.
  (* Case: struct_recjmp. *)
  - do 2 rewrite lift_distributes_over_bind.
    rewrite lift_distributes_over_jump.
    apply struct_recjmp_helper.
    + rewrite lift_distributes_over_apply_parameters.
      f_equal.
      rewrite map_length.
      symmetry.
      rewrite lift_lift_permutation; try lia.
      rewrite H; f_equal.
      lia.
    + reflexivity.
    + reflexivity.
    + rewrite map_length.
      rewrite traverse_list_length.
      assumption.
  (* Case: struct_distr. *)
  - do 5 rewrite lift_distributes_over_bind.
    apply struct_distr_helper.
    + apply lift_and_switch_bindings_commute.
    + symmetry.
      do 2 rewrite traverse_list_length.
      rewrite lift_lift_permutation.
      * reflexivity.
      * lia.
    + do 2 rewrite traverse_list_length.
      apply lift_and_right_cycle_commute with (p := 0).
      lia.
    + do 4 rewrite traverse_list_length.
      symmetry.
      rewrite lift_lift_permutation.
      * f_equal; lia.
      * lia.
    + induction ns; simpl.
      * reflexivity.
      * f_equal; auto.
        do 4 rewrite traverse_list_length.
        symmetry.
        rewrite lift_lift_permutation; try lia.
        f_equal; lia.
    + do 2 rewrite traverse_list_length.
      induction ns; simpl.
      * reflexivity.
      * f_equal; auto.
        do 4 rewrite traverse_list_length.
        symmetry.
        rewrite lift_lift_permutation; auto with arith.
        f_equal; lia.
    + induction ms; auto; intros.
      inversion_clear H.
      rewrite Nat.add_0_r in H0.
      simpl; f_equal; auto.
      do 4 rewrite traverse_list_length.
      rewrite Nat.add_0_r.
      apply lift_preserved_by_useless_subst.
      assumption.
    + induction ms; simpl; auto.
      inversion_clear H.
      constructor; auto.
      rewrite traverse_list_length.
      rewrite Nat.add_0_r in H0 |- *.
      apply lifting_over_n_preserves_not_free_n; auto.
      lia.
  (* Case: struct_eta. *)
  - rename k into j, k0 into k.
    rewrite lift_distributes_over_bind.
    rewrite lift_distributes_over_jump.
    eapply struct_eta_helper.
    + replace (k + length ts) with (length ts + k); auto with arith.
      rewrite traverse_list_length; f_equal.
      * symmetry.
        apply lift_lift_permutation; auto with arith.
      * apply lifting_over_n_doesnt_change_low_sequence_n.
        lia.
    + apply lift_distributes_over_subst.
  (* Case: struct_gc. *)
  - rewrite lift_distributes_over_bind.
    rewrite remove_closest_binding_and_lift_commute; auto.
    apply struct_gc.
    apply lifting_over_n_preserves_not_free_n; auto with arith.
  (* Case: struct_bind_left. *)
  - do 2 rewrite lift_distributes_over_bind.
    auto with cps.
  (* Case: struct_bind_right. *)
  - do 2 rewrite lift_distributes_over_bind.
    auto with cps.
Qed.

Global Hint Resolve struct_lift: cps.

Lemma sema_lift:
  forall a b,
  [a == b] ->
  forall i k,
  [lift i k a == lift i k b].
Proof.
  induction 1; eauto with cps.
Qed.

Global Hint Resolve sema_lift: cps.

Lemma struct_subst:
  forall a b,
  struct a b ->
  forall c k,
  struct (subst c k a) (subst c k b).
Proof.
  induction 1; intros.
  (* Case: struct_recjmp. *)
  - do 2 rewrite subst_distributes_over_bind.
    rewrite subst_distributes_over_jump.
    apply struct_recjmp_helper.
    + rewrite subst_distributes_over_apply_parameters.
      f_equal.
      rewrite map_length.
      rewrite lift_and_subst_commute; try lia.
      rewrite H; f_equal.
      lia.
    + reflexivity.
    + reflexivity.
    + rewrite map_length; auto.
      rewrite traverse_list_length; auto.
  (* Case: struct_distr. *)
  - do 5 rewrite subst_distributes_over_bind.
    apply struct_distr_helper.
    + apply subst_and_switch_bindings_commute.
    + do 2 rewrite traverse_list_length.
      rewrite lift_and_subst_commute.
      * reflexivity.
      * lia.
    + do 2 rewrite traverse_list_length.
      apply subst_and_right_cycle_commute with (p := 0).
      lia.
    + do 4 rewrite traverse_list_length.
      rewrite lift_and_subst_commute.
      * f_equal; lia.
      * lia.
    + induction ns; simpl.
      * reflexivity.
      * f_equal; auto.
        do 4 rewrite traverse_list_length.
        rewrite lift_and_subst_commute; auto with arith.
        f_equal; lia.
    + do 2 rewrite traverse_list_length.
      induction ns; simpl.
      * reflexivity.
      * f_equal; auto.
        do 4 rewrite traverse_list_length.
        rewrite lift_and_subst_commute; auto with arith.
        f_equal; lia.
    + induction ms; auto; intros.
      inversion_clear H.
      rewrite Nat.add_0_r in H0.
      simpl; f_equal; auto.
      do 4 rewrite traverse_list_length.
      rewrite Nat.add_0_r.
      apply subst_preserved_by_useless_subst.
      assumption.
    + induction ms; simpl; auto.
      inversion_clear H.
      constructor; auto.
      rewrite traverse_list_length.
      rewrite Nat.add_0_r in H0 |- *.
      apply substing_over_n_preserves_not_free_n; auto.
      lia.
  (* Case: struct_eta. *)
  - rename k into j, k0 into k.
    rewrite subst_distributes_over_bind.
    rewrite subst_distributes_over_jump.
    eapply struct_eta_helper.
    + replace (k + length ts) with (length ts + k); auto with arith.
      rewrite traverse_list_length; f_equal.
      * symmetry.
        apply lift_and_subst_commute; auto with arith.
      * apply substing_over_n_doesnt_change_low_sequence_n; lia.
    + apply subst_distributes_over_itself.
  (* Case: struct_gc. *)
  - rewrite subst_distributes_over_bind.
    rewrite remove_closest_binding_and_subst_commute; auto.
    apply struct_gc.
    apply substing_over_n_preserves_not_free_n; auto with arith.
  (* Case: struct_bind_left. *)
  - do 2 rewrite subst_distributes_over_bind.
    auto with cps.
  (* Case: struct_bind_right. *)
  - do 2 rewrite subst_distributes_over_bind.
    auto with cps.
Qed.

Global Hint Resolve struct_subst: cps.

Lemma sema_subst:
  forall a b,
  [a == b] ->
  forall x k,
  [subst x k a == subst x k b].
Proof.
  induction 1; eauto with cps.
Qed.

Global Hint Resolve sema_subst: cps.

Lemma sema_apply_parameters:
  forall xs k a b,
  [a == b] ->
  [apply_parameters xs k a == apply_parameters xs k b].
Proof.
  induction xs; eauto with cps.
Qed.

Global Hint Resolve sema_apply_parameters: cps.

Lemma sema_right_cycle:
  forall a b,
  [a == b] ->
  forall n k,
  [right_cycle n k a == right_cycle n k b].
Proof.
  unfold right_cycle; auto with cps.
Qed.

Global Hint Resolve sema_right_cycle: cps.

Goal
  forall m a k,
  not_free (k + a) m ->
  remove_binding (k + a) m =
    remove_binding k (right_cycle a k m).
Proof.
  (* This theorem is true, we'll need it in the following. *)
  admit.
Admitted.

Lemma sema_float_left:
  FLOAT_LEFT sema.
Proof.
  unfold FLOAT_LEFT; intros.
  eapply sema_trans.
  - apply sema_distr; auto.
  - apply sema_bind_right.
    apply sema_struct; apply struct_gc_helper.
    + admit.
    + admit.
Admitted.

Lemma sema_float_right:
  FLOAT_RIGHT sema.
Proof.
  unfold FLOAT_RIGHT; intros.
  eapply sema_trans.
  - apply sema_distr; auto.
  - apply sema_bind_left.
    apply sema_gc.
    admit.
Admitted.

(* TODO: you know what to do here. *)

Goal
  forall b k,
  not_free (1 + k) b ->
  remove_binding k (switch_bindings k b) = remove_binding (1 + k) b.
Proof.
  unfold remove_binding.
  unfold switch_bindings.
  induction b using pseudoterm_deepind; intros.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - destruct (lt_eq_lt_dec (1 + k) n) as [ [ ? | ? ] | ? ].
    + rewrite subst_bound_gt; auto.
      rewrite lift_bound_ge; try lia.
      rewrite subst_bound_gt; try lia.
      rewrite subst_bound_gt; try lia.
      f_equal; lia.
    + exfalso.
      inversion_clear H; auto.
    + rewrite subst_bound_lt; auto.
      rewrite lift_bound_lt; try lia.
      destruct (le_gt_dec k n).
      * rewrite subst_bound_eq; try lia.
        rewrite lift_bound_ge; auto.
        rewrite subst_bound_gt; try lia.
        f_equal; lia.
      * rewrite subst_bound_lt; auto.
        rewrite subst_bound_lt; auto.
  - rewrite lift_distributes_over_negation.
    do 3 rewrite subst_distributes_over_negation.
    f_equal.
    induction H; auto.
    inversion_clear H0.
    inversion_clear H2.
    simpl; f_equal.
    + do 4 rewrite traverse_list_length.
      replace (length l + S (S k)) with (2 + (length l + k)); try lia.
      replace (length l + S k) with (1 + (length l + k)); try lia.
      apply H.
      replace (1 + (length l + k)) with (length l + (1 + k)); try lia.
      assumption.
    + apply IHForall.
      constructor.
      assumption.
  - rewrite lift_distributes_over_jump.
    do 3 rewrite subst_distributes_over_jump.
    inversion_clear H0.
    f_equal.
    + apply IHb.
      assumption.
    + induction H; auto.
      inversion_clear H2.
      simpl; f_equal; auto.
      apply H; auto.
  - rewrite lift_distributes_over_bind.
    do 3 rewrite subst_distributes_over_bind.
    do 2 rewrite traverse_list_length.
    inversion_clear H0.
    f_equal.
    + apply IHb1; auto.
    + clear IHb1 IHb2 H1 H3.
      induction H; auto.
      inversion_clear H2.
      simpl; f_equal; auto.
      do 4 rewrite traverse_list_length.
      replace (length l + S (S k)) with (2 + (length l + k)); try lia.
      replace (length l + S k) with (1 + (length l + k)); try lia.
      apply H.
      replace (1 + (length l + k)) with (length l + (1 + k)); try lia.
      assumption.
    + apply IHb2.
      replace (1 + (k + length ts)) with (length ts + (1 + k)); try lia.
      assumption.
Qed.

Local Lemma technical1:
  forall n k c: nat,
  c < k ->
  (apply_parameters (high_sequence n) k
    (lift (1 + n) (k + n) c)) = lift 1 k c.
Proof.
  intros.
  rewrite lift_bound_lt; try lia.
  rewrite lift_bound_lt; try lia.
  induction n; simpl.
  - reflexivity.
  - rewrite sequence_length.
    rewrite subst_bound_lt; try lia.
    assumption.
Qed.

Local Lemma technical2:
  forall c n k,
  c >= n + k ->
  apply_parameters (high_sequence n) k (1 + n + c) = 1 + c.
Proof.
  intros.
  replace (1 + c) with ((1 + n + c) - n); try lia.
  cut (1 + n + c > k + n); try lia.
  generalize (1 + n + c) as m.
  induction n; simpl; intros.
  - f_equal; lia.
  - rewrite sequence_length.
    rewrite subst_bound_gt; try lia.
    replace (m - S n) with (pred m - n); try lia.
    apply IHn; lia.
Qed.

Local Lemma technical3:
  forall n k c: nat,
  c >= n + k ->
  (apply_parameters (high_sequence n) k
    (lift (1 + n) (k + n) c)) = lift 1 k c.
Proof.
  intros.
  rewrite lift_bound_ge; try lia.
  rewrite lift_bound_ge; try lia.
  apply technical2; auto.
Qed.

Local Lemma technical4:
  forall n k c: nat,
  c >= k ->
  c < n + k ->
  (apply_parameters (high_sequence n) k
    (lift (1 + n) (k + n) c)) = lift 1 k c.
Proof.
  intros.
  rewrite lift_bound_lt; try lia.
  rewrite lift_bound_ge; try lia.
  (* So here, we'll actually replace c with something! *)
  induction n.
  - exfalso.
    lia.
  - (* Are we there yet...? *)
    simpl; rewrite sequence_length.
    destruct (le_gt_dec (n + k) c).
    + clear IHn.
      rewrite subst_bound_eq; try lia.
      rewrite lift_bound_ge; try lia.
      replace c with (n + k); try lia.
      replace (n + k + S n) with (1 + n + (n + k)); try lia.
      apply technical2; auto.
    + rewrite subst_bound_lt; try lia.
      apply IHn; lia.
Qed.

Local Lemma technical5:
  forall c n k,
  apply_parameters (high_sequence n) k (lift (1 + n) (k + n) c) =
    lift 1 k c.
Proof.
  induction c using pseudoterm_deepind; intros.
  - induction n; simpl; auto.
  - induction n; simpl; auto.
  - induction n; simpl; auto.
  - induction n; simpl; auto.
  - rename n0 into m.
    destruct (le_gt_dec k n).
    + destruct (le_gt_dec (m + k) n).
      * apply technical3; auto.
      * apply technical4; auto.
    + apply technical1; auto.
  - do 2 rewrite lift_distributes_over_negation.
    rewrite apply_parameters_distributes_over_negation.
    f_equal.
    induction H; auto.
    simpl; f_equal; auto.
    do 3 rewrite traverse_list_length.
    rewrite Nat.add_assoc.
    apply H.
  - do 2 rewrite lift_distributes_over_jump.
    rewrite apply_parameters_distributes_over_jump.
    f_equal.
    + apply IHc.
    + list induction over H.
  - do 2 rewrite lift_distributes_over_bind.
    rewrite apply_parameters_distributes_over_bind.
    rewrite traverse_list_length.
    f_equal.
    + apply IHc1.
    + clear IHc1 IHc2.
      induction H; auto.
      simpl; f_equal; auto.
      do 3 rewrite traverse_list_length.
      rewrite Nat.add_assoc.
      apply H.
    + replace (k + n + length ts) with (k + length ts + n); try lia.
      apply IHc2.
Qed.

(*
  Turns out the rule (CONTR) is derivable!
  To show that L { m<x> = M } { m'<x> = M } == L[m/m'] { m<x> = M }...

  In a named version of the calculus, start with symmetry... then:

    1)                           L[m/m'] { m<x> = M } ==      (by LEFT, ETA-1)
    2)                L { m'<y> = m<y> } { m<x> = M } ==      (by DISTR)
    3)   L { m<x> = M } { m'<y> = m<y> { m<x> = M } } ==      (by RIGHT, RECJMP)
    4) L { m<x> = M } { m'<y> = M[y/x] { m<x> = M } } ==      (by RIGHT, GC)
    5)              L { m<x> = M } { m'<y> = M[y/x] } ==      (by ALPHA)
    6)                   L { m<x> = M } { m'<x> = M }

  This is a bit bureaucratic when using de Bruijn indexes; we of course don't
  need an alpha conversion, but we'll need a (FLOAT-LEFT) in the end to fix the
  bindings' positions, "undoing" the (DISTR) we did, but it should still work.
*)

Theorem sema_contr:
  CONTR sema.
Proof.
  unfold CONTR; intros.
  apply sema_sym.
  (* Is there a more elegant way? *)
  eapply sema_trans;
    [| eapply sema_trans;
      [| eapply sema_trans;
        [| eapply sema_trans;
          [| eapply sema_trans ] ] ] ].
  - apply sema_bind_left.
    apply sema_sym.
    apply sema_eta with (ts := traverse_list (lift 1) 0 ts).
  - apply sema_distr.
    induction ts; simpl.
    + constructor.
    + constructor; auto.
      rewrite traverse_list_length.
      apply lifting_more_than_n_makes_not_free_n; lia.
  - apply sema_bind_right.
    rewrite traverse_list_length.
    rewrite lift_bound_ge; auto.
    rewrite Nat.add_0_r.
    rewrite right_cycle_distributes_over_jump.
    rewrite right_cycle_bound_eq; auto.
    apply sema_recjmp.
    rewrite map_length.
    rewrite traverse_list_length.
    apply sequence_length.
  - apply sema_bind_right.
    apply sema_gc.
    rewrite right_cycle_low_sequence_n_equals_high_sequence_n; auto.
    rewrite traverse_list_length.
    rewrite lift_lift_simplification; try lia.
    (* This was annoying to show, but it's true! *)
    rewrite technical5.
    apply lifting_more_than_n_makes_not_free_n; lia.
  - (* The term is in the form [(switch_bindings 0 b) { M } { N }] now, as we
       have changed [b] with the (DISTR) call above. Note that when applying
       (FLOAT-LEFT) here we will change the term into [b { M } { N }]: only [b]
       will actually change, as [M] is already equal to [lift 1 0 N] here (thus
       moving [N] left makes it equal to [M], and moving [M] right makes it
       equal to [N]). *)
    apply sema_float_left.
    + rewrite traverse_list_length.
      apply lifting_more_than_n_makes_not_free_n; lia.
    + induction ts; auto with cps.
      simpl; constructor; auto.
      rewrite traverse_list_length.
      rewrite Nat.add_0_r.
      apply lifting_more_than_n_makes_not_free_n; lia.
  - (* The term is finally in the form [b { M } { N }], which is what we want,
       but we still need to prove that as the term form is a bit different. *)
    apply sema_eq; f_equal.
    + f_equal.
      * apply switch_bindings_is_involutive.
      * induction ts; auto.
        simpl; f_equal; auto.
        do 3 rewrite traverse_list_length.
        rewrite Nat.add_0_r.
        unfold remove_binding.
        rewrite subst_lift_simplification; auto.
        rewrite lift_zero_e_equals_e; auto.
      * do 3 rewrite traverse_list_length.
        rewrite right_cycle_low_sequence_n_equals_high_sequence_n; auto.
        rewrite lift_lift_simplification; try lia.
        (* Here's that annoying thing again! *)
        rewrite technical5.
        unfold remove_binding.
        rewrite subst_lift_simplification; auto.
        rewrite lift_zero_e_equals_e.
        reflexivity.
    + induction ts; auto.
      simpl; f_equal; auto.
      do 2 rewrite traverse_list_length.
      rewrite Nat.add_0_r.
      unfold remove_binding.
      rewrite subst_lift_simplification; auto.
      apply lift_zero_e_equals_e.
    + rewrite traverse_list_length.
      unfold remove_binding.
      rewrite subst_lift_simplification; auto.
      apply lift_zero_e_equals_e.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func_Prop.
Require Import Functor.Functor_Extender.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
Require Import Adjunction.Adjunction Adjunction.Duality Adjunction.Adj_Facts.
Require Import KanExt.Global.

(** In this module we establish the dualit of kan extensions.
That is, the left kan extension along p is just the right kan extension along
pᵒᵖ and vice versa.
 *)
Section GlobalDuality.
  Context {C C' : Category} (p : (C –≻ C')%functor) (D : Category).

  (** We establish this duality though hom functor definition of adjunction. *)

  Local Obligation Tactic := idtac.

  Section Left_to_Right.
    Context (lke : Left_KanExt p D).

    (** The natural Isomorphism underlying the right kan extension which is to
        be shown.
        Hom_{Func_Cat Cᵒᵖ Dᵒᵖ}(– ∘ p, –) ≃ Hom_{Func_Cat C'ᵒᵖ Dᵒᵖ}(–, lkeᵒᵖ)
    *)
    Local Definition KanExt_Left_to_Right_NIso :=
      (
        (
          (
            ((Hom_Func_Cat_Iso (Func_Cat_Op_Iso C' D))
               ∘_h (NatTrans_id_Iso
                      (Prod_Functor
                         (Functor_id ((Func_Cat C' D) ^op) ^op) (lke^op)))
            )
              ∘ (Hom_Adjunct_Duality (Adj_to_Hom_Adj (left_kan_ext_adj lke)))
          )
            ∘ (((Hom_Func_Cat_Iso (Func_Cat_Op_Iso C D))⁻¹)
                 ∘_h (NatTrans_id_Iso
                        (Prod_Functor
                           (Left_Functor_Extender p D)
                           (Functor_id (Func_Cat C D) ^op))))
        )
          ∘_h (NatTrans_id_Iso
                 (Prod_Functor
                    ((inverse_morphism (Func_Cat_Op_Iso C' D))^op)
                    (inverse_morphism (Func_Cat_Op_Iso C D))
                 )
              )
      )%natiso
    .

    (** If we give the trans formations (e.g., function given in the first
        obligation) explicitly "Program" generates obligations for
        equalities that are definitional! *)

    Program Definition KanExt_Left_to_Right :
      Right_KanExt  (p^op) (D^op) :=
      {|
        right_kan_ext :=
          ((Op_Func_Cat_to_Func_Cat_Op C' D) ∘
          (lke^op ∘ (Func_Cat_Op_to_Op_Func_Cat C D)))%functor;
        right_kan_ext_adj :=
          Hom_Adj_to_Adj
            {|
              iso_morphism :=
                {|
                  Trans := _
                |};
              inverse_morphism :=
                {|
                  Trans := _
                |}
            |}
      |}.

    Next Obligation.
    Proof.
      exact (fun c => Trans (iso_morphism KanExt_Left_to_Right_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h.
      set (w := Trans_com (iso_morphism KanExt_Left_to_Right_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      rewrite NatTrans_hor_comp_Op.
      repeat rewrite <- NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply KanExt_Left_to_Right_obligation_2.
    Qed.

    Next Obligation.
    Proof.
      exact (fun c => Trans (inverse_morphism KanExt_Left_to_Right_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h.
      set (w := Trans_com (inverse_morphism KanExt_Left_to_Right_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      rewrite NatTrans_hor_comp_Op.
      repeat rewrite <- NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply KanExt_Left_to_Right_obligation_5.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      match goal with
        [|- _ = ?A] =>
        let w := constr:(
                   ((KanExt_Left_to_Right_NIso ⁻¹)
                      ∘ KanExt_Left_to_Right_NIso)%morphism)%nattrans
        in
        change (
            Trans w = A
          )
      end.
      rewrite (left_inverse KanExt_Left_to_Right_NIso); trivial.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      match goal with
        [|- _ = ?A] =>
        let w := constr:(
                   (KanExt_Left_to_Right_NIso
                      ∘ KanExt_Left_to_Right_NIso⁻¹)%morphism)%nattrans
        in
        change (
            Trans w = A
          )
      end.
      rewrite (right_inverse KanExt_Left_to_Right_NIso); trivial.
    Qed.

  End Left_to_Right.

  Section Right_to_Left.
    Context (rke : Right_KanExt p D).

    (** The natural Isomorphism underlying the right kan extension which is
        to be shown.

        Hom_{Func_Cat C'ᵒᵖ Dᵒᵖ}(rke, –) ≃ Hom_{Func_Cat Cᵒᵖ Dᵒᵖ}(–, – ∘ p)
     *)
    Local Definition KanExt_Right_to_Left_NIso :=
      (
        (
          (
            (
              (Hom_Func_Cat_Iso (Func_Cat_Op_Iso C D))
                ∘_h (
                  NatTrans_id_Iso
                    (Prod_Functor
                       (Functor_id ((Func_Cat C D) ^op) ^op)
                       ((Left_Functor_Extender p D)^op)
                ))
            )
              ∘ (Hom_Adjunct_Duality (Adj_to_Hom_Adj (right_kan_ext_adj rke)))
          )
            ∘ (
              ((Hom_Func_Cat_Iso (Func_Cat_Op_Iso C' D))⁻¹)
                ∘_h (NatTrans_id_Iso
                       (Prod_Functor rke (Functor_id (Func_Cat C' D) ^op))))
        )
          ∘_h
          (NatTrans_id_Iso
             (Prod_Functor
                ((inverse_morphism (Func_Cat_Op_Iso C D))^op)
                (inverse_morphism (Func_Cat_Op_Iso C' D))
             )
          )
      )%natiso
    .

    Program Definition KanExt_Right_to_Left :
      Left_KanExt  (p^op) (D^op) :=
      {|
        left_kan_ext :=
          (
            (Op_Func_Cat_to_Func_Cat_Op C' D)
              ∘ (rke^op ∘ (Func_Cat_Op_to_Op_Func_Cat C D))
          )%functor;
        left_kan_ext_adj :=
          Hom_Adj_to_Adj
            {|
              iso_morphism :=
                {|
                  Trans := _
                |};
              inverse_morphism :=
                {|
                  Trans := _
                |}
            |}
      |}.

    Next Obligation.
    Proof.
      exact (fun c => Trans (iso_morphism KanExt_Right_to_Left_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h.
      set (w := Trans_com (iso_morphism KanExt_Right_to_Left_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      repeat rewrite NatTrans_hor_comp_Op.
      repeat rewrite NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply KanExt_Right_to_Left_obligation_2.
    Qed.

    Next Obligation.
    Proof.
      exact (fun c => Trans (inverse_morphism KanExt_Right_to_Left_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h.
      set (w := Trans_com (inverse_morphism KanExt_Right_to_Left_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      repeat rewrite NatTrans_hor_comp_Op.
      repeat rewrite NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply KanExt_Right_to_Left_obligation_5.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      match goal with
        [|- _ = ?A] =>
        let w := constr:(
                   ((KanExt_Right_to_Left_NIso ⁻¹)
                      ∘ KanExt_Right_to_Left_NIso)%morphism)%nattrans
        in
        change (
            Trans w = A
          )
      end.
      rewrite (left_inverse KanExt_Right_to_Left_NIso); trivial.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      match goal with
        [|- _ = ?A] =>
        let w := constr:(
                   (KanExt_Right_to_Left_NIso
                      ∘ KanExt_Right_to_Left_NIso⁻¹)%morphism)%nattrans
        in
        change (
            Trans w = A
          )
      end.
      rewrite (right_inverse KanExt_Right_to_Left_NIso); trivial.
    Qed.

  End Right_to_Left.

End GlobalDuality.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.ModalLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.ModalLogic.ProofTheory.ModalLogic.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import ModalLanguageNotation.

Section RewriteClass.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {mL: ModalLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {KmAX: SystemK L Gamma}.

Instance boxp_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) boxp.
Proof.
  hnf; intros x y ?.
  apply rule_N in H.
  eapply modus_ponens; eauto.
  apply axiom_K.
Qed.

Instance boxp_proper_iffp: Proper ((fun x y => |-- iffp x y) ==> (fun x y => |-- iffp x y)) boxp.
Proof.
  hnf; intros x y ?.
  apply solve_andp_intros; apply boxp_proper_impp.
  + eapply solve_andp_elim1; eauto.
  + eapply solve_andp_elim2; eauto.
Qed.

Instance diamondp_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) diamondp.
Proof.
  hnf; intros x y ?.
  unfold diamondp.
  rewrite H.
  apply provable_impp_refl.
Qed.

Instance diamondp_proper_iffp: Proper ((fun x y => |-- iffp x y) ==> (fun x y => |-- iffp x y)) diamondp.
Proof.
  hnf; intros x y ?.
  unfold diamondp.
  rewrite H.
  apply provable_iffp_refl.
Qed.

End RewriteClass.

Existing Instances boxp_proper_impp boxp_proper_iffp diamondp_proper_impp diamondp_proper_iffp.


(* BEGIN FIX *)
From Coq Require Import Strings.String.

Inductive exp : Type :=
  | lit : nat -> exp
  | var : string -> exp
  | sub : exp -> exp -> exp
  | plus : exp -> exp -> exp.

Definition state : Type := string -> nat.

Fixpoint eval (e : exp)(s : state) : nat :=
  match e with
  | lit n => n
  | var x => s x
  | sub e1 e2 => eval e1 s - eval e2 s
  | plus e1 e2 => eval e1 s + eval e2 s
  end.

Definition empty : state := fun x => 0.

Definition W : string := "W".
Definition X : string := "X".

Fixpoint replace (e : exp)(x : string)(e' : exp) : exp :=
  match e with
  | lit n => lit n
  | var x' => if eqb x x' then e' else var x'
  | sub e1 e2 => sub (replace e1 x e') (replace e2 x e')
  | plus e1 e2 => plus (replace e1 x e') (replace e2 x e')
  end.

(* Ugy add meg e-t, hogy etest-et be tudd bizonyitani! *)
Definition e : exp :=
(* END FIX *)
   (plus (lit 5) (var W)).
(* BEGIN FIX *)
Lemma etest :
  eval
    (plus
       (replace e W (lit 3))
       (replace e X (lit 4)))
    empty = 13.
(* END FIX *)
Proof.
 simpl.
 reflexivity.
Qed.


From Coq Require Import List.

(** Some results about [map] *)

Lemma map_nil_iff {A B} (f : A -> B) l :
  List.map f l = nil <-> l = nil.
Proof.
  destruct l; simpl; split; congruence.
Qed.

Lemma nth_error_map {A B} (f : A -> B) (n : nat) (l : list A) (b : B) :
  nth_error (List.map f l) n = Some b ->
  exists a, nth_error l n = Some a /\ b = f a.
Proof.
  revert n; induction l; intros [ | n ] Hb.
  - discriminate.
  - discriminate.
  - injection Hb as <-. exists a; firstorder.
  - firstorder.
Qed.

(** Refinement on in_dec *)

Lemma in_dec_refined {A} (a : A) (l : list A) :
  (forall x, { x = a } + { x <> a }) ->
  {In a l} + {~ In a l}.
Proof.
  induction l; firstorder.
Qed.

(** One result about [list_prod] *)

Lemma list_prod_nil_iff {A B} (xs : list A) (ys : list B) :
  list_prod xs ys = nil <-> xs = nil \/ ys = nil.
Proof.
  revert ys.
  induction xs; intros [ | y ys]; simpl; split; firstorder; congruence.
Qed.

(** Some results about Forall2 *)

Lemma Forall2_length {A B} (R : A -> B -> Prop) l1 l2 :
  Forall2 R l1 l2 ->
  Datatypes.length l1 = Datatypes.length l2.
Proof.
  revert l2; induction l1; intros l2 F; inversion F; subst; simpl; firstorder.
Qed.

Lemma Forall2_swap {A B} (R : A -> B -> Prop) l1 l2 :
  Forall2 R l1 l2 ->
  Forall2 (fun b a => R a b) l2 l1.
Proof.
  revert l2; induction l1; intros l2 F; inversion F; firstorder.
Qed.

Lemma Forall2_swap_iff {A B} (R : A -> B -> Prop) l1 l2 :
  Forall2 R l1 l2 <->
  Forall2 (fun b a => R a b) l2 l1.
Proof.
  split; revert l2; induction l1; intros l2 F; inversion F; firstorder.
Qed.

Lemma In_Forall2 {A B} (R : A -> B -> Prop) l1 l2 :
  Forall2 R l1 l2 ->
  forall a, In a l1 -> exists b, In b l2 /\ R a b.
Proof.
  revert l2; induction l1; intros l2 F; inversion F; simpl; subst; firstorder.
  subst; firstorder.
Qed.

Lemma Forall2_In {A B} (R : A -> B -> Prop) l1 l2 :
  Forall2 R l1 l2 ->
  forall b, In b l2 -> exists a, In a l1 /\ R a b.
Proof.
  revert l2; induction l1; intros l2 F; inversion F; simpl; subst; firstorder.
  subst; firstorder.
Qed.

Lemma nth_Forall2 {A B} (R : A -> B -> Prop) l1 l2 :
  Forall2 R l1 l2 ->
  forall i a, nth_error l1 i = Some a ->
         exists b, nth_error l2 i = Some b /\ R a b.
Proof.
  revert l2; induction l1; intros l2 F i a' Ea; inversion F; subst.
  - destruct i; discriminate.
  - destruct i; simpl in *; firstorder.
    injection Ea as <-; firstorder.
Qed.

Lemma Forall2_nth {A B} (R : A -> B -> Prop) l1 l2 :
  Forall2 R l1 l2 ->
  forall i b, nth_error l2 i = Some b ->
         exists a, nth_error l1 i = Some a /\ R a b.
Proof.
  revert l2; induction l1; intros l2 F i a' Ea; inversion F; subst.
  - destruct i; discriminate.
  - destruct i; simpl in *; firstorder.
    injection Ea as <-; firstorder.
Qed.

Lemma Forall2_cons_l_iff {A B} (R : A -> B -> Prop) l1 l2 a :
  Forall2 R (a :: l1) l2 <->
  exists b l2', l2 = b :: l2' /\ R a b /\ Forall2 R l1 l2'.
Proof.
  destruct l2 as [ | b l2'].
  - split. now inversion 1. now firstorder discriminate.
  - split.
    + inversion 1. subst; firstorder.
    + intros (? & ? & H & ? & ?). injection H as <- <-. constructor; auto.
Qed.

Lemma Forall2_cons_r_iff {A B} (R : A -> B -> Prop) l1 l2 b :
  Forall2 R l1 (b :: l2) <->
  exists a l1', l1 = a :: l1' /\ R a b /\ Forall2 R l1' l2.
Proof.
  destruct l1 as [ | a l1'].
  - split. now inversion 1. now firstorder discriminate.
  - split.
    + inversion 1. subst; firstorder.
    + intros (? & ? & H & ? & ?). injection H as <- <-. constructor; auto.
Qed.

Lemma Forall2_map {A B C} (R : A -> B -> Prop) (S : A -> C -> Prop) (f : B -> C) l1 l2 :
  (forall a b, In a l1 -> R a b -> S a (f b)) ->
  Forall2 R l1 l2 ->
  Forall2 S l1 (List.map f l2).
Proof.
  revert l2; induction l1 as [| a l IHl1]; intros l2 RS H.
  - inversion H; destruct l2; subst. constructor. discriminate.
  - inversion H as [ | a_ b l_ l2' ]. subst. simpl.
    constructor; firstorder; apply IHl1; firstorder.
Qed.

Lemma Forall2_map_inv {A B C} (R : A -> B -> Prop) (S : A -> C -> Prop) (f : C -> B) l1 l2 :
  (forall a c, In c l2 -> R a (f c) -> S a c) ->
  Forall2 R l1 (List.map f l2) ->
  Forall2 S l1 l2.
Proof.
  revert l2; induction l1; intros l2 RS H.
  - inversion H; destruct l2; subst. constructor. discriminate.
  - inversion H as [ |  a_ b l l' ]. subst.
    destruct l2 as [ | c l2 ]. discriminate. simpl in *.
    assert (b = f c) by congruence. subst.
    constructor. now firstorder.
    apply IHl1. now firstorder.
    inversion H; subst. firstorder.
Qed.

(** New function [list_list_prod], which is the iteration of [list_prod] *)

Fixpoint list_list_prod {A} (xss : list (list A)) : list (list A) :=
  match xss with
  | nil => nil :: nil
  | xs :: xss =>
    List.map (fun p => fst p :: snd p) (List.list_prod xs (list_list_prod xss))
  end.

Lemma list_list_prod_nil {A} (xss : list (list A)) :
  List.In nil xss <-> list_list_prod xss = nil.
Proof.
  induction xss as [| xs xss IHxss]; simpl; split.
  - tauto.
  - congruence.
  - intros [-> | Hxss].
    + reflexivity.
    + destruct IHxss as [-> _]; simpl; auto.
      destruct (list_prod_nil_iff xs (@nil (list A))) as [_ ->]; auto.
  - intros H. apply map_nil_iff in H.
    apply list_prod_nil_iff in H. tauto.
Qed.

Lemma list_list_prod_in {A} (xss : list (list A)) i x :
  (exists l, List.In l (list_list_prod xss) /\ nth_error l i = Some x) <->
  (~List.In nil xss /\ exists xs, nth_error xss i = Some xs /\ List.In x xs).
Proof.
  revert i x.
  induction xss as [| xs xss IHxss]; intros [ | i] x;
    (split; [intros (l & Hl & Hx) | intros (Hnil & xs' & Hxs' & Hx)]).
  - destruct l; firstorder; simpl in *; congruence.
  - simpl in *; congruence.
  - destruct l; firstorder; simpl in *; congruence.
  - simpl in *; congruence.
  - simpl list_list_prod in Hl.
    rewrite in_map_iff in Hl. destruct Hl as ((x_, l') & <- & Hi).
    simpl in Hx. injection Hx as ->.
    rewrite in_prod_iff in Hi. split. 2: firstorder.
    intros [ | H ]. subst. tauto.
    apply list_list_prod_nil in H. rewrite H in Hi. tauto.
  - simpl in Hxs'. injection Hxs' as <-.
    simpl list_list_prod.
    destruct (list_list_prod xss) as [ | ys yss] eqn:Eys.
    + rewrite <-list_list_prod_nil in Eys. simpl in *; tauto.
    + exists (x :: ys).
      rewrite in_map_iff. split; auto. exists (x, ys). split; auto.
      rewrite in_prod_iff. split; auto.
      now left.
  - split.
    + intros H. apply list_list_prod_nil in H. rewrite H in Hl. tauto.
    + apply IHxss. simpl in Hl.
      rewrite in_map_iff in Hl. destruct Hl as ((x_, l') & <- & Hi).
      simpl in Hx. rewrite in_prod_iff in Hi. firstorder.
  - destruct (IHxss i x) as (_, IH).
    destruct IH as (l & Hl & Hix). now firstorder.
    destruct xs as [|x'' xs'']. now simpl in Hnil; tauto.
    exists (x'' :: l). split; auto.
    apply in_map_iff.
    eexists (_, _); split; [ reflexivity | ].
    apply in_prod_iff.
    split; firstorder.
Qed.

Lemma list_list_prod_in' {A} (L : list (list A)) (l : list A) :
  In l (list_list_prod L) <->
  Forall2 (fun x l' => In x l') l L.
Proof.
  revert l. induction L as [| m L IHL]; intros l.
  - simpl; split. intros [<- | H]. constructor. tauto.
    inversion 1. tauto.
  - simpl. rewrite in_map_iff. rewrite Forall2_cons_r_iff.
    split.
    + intros ((b, l1') & <- & Hi). simpl.
      rewrite in_prod_iff in Hi. destruct Hi as (Hb, Hl1').
      firstorder.
    + intros (b & l1' & -> & Hb & Hl1').
      exists (b, l1'). rewrite in_prod_iff. firstorder.
Qed.