Module MineSweeper.

Require Import Arith Omega.

Set Implicit Arguments.

Section vector.
Variable A: Type.
Inductive vector : nat -> Type :=
  | vnil : vector 0
  | vcons : forall (a:A) (n:nat), vector n -> vector (S n)
.
End vector.
Implicit Arguments vnil [A].
Delimit Scope vector_scope with vec.
Open Scope vector_scope.
Infix "::" := vcons
              (at level 60, right associativity)
              : vector_scope.
Notation "[]" := vnil: vector_scope.
Notation "[ x , .. , z ]" :=
         (x :: .. (z :: []) ..)
         (at level 0)
         : vector_scope.
Section vmap.
Variables X Y: Type.
Variable f: X -> Y.
Fixpoint vmap {n} (v: vector X n): vector Y n :=
 match v with
 | vnil => vnil
 | vcons a _ v' => vcons (f a) (vmap v')
 end.
End vmap.
Section vzip.
Variables X Y Z: Type.
Variable f: X -> Y -> Z.

Fixpoint vzip {n} (v1: vector X n) (v2: vector Y n): vector Z n.
 destruct v1.
  constructor.
 inversion v2.
  constructor.
   apply f. exact a. exact a0.
   apply vzip. exact v1. exact X0.
Defined.
End vzip.

Definition vi0 {m}: 0 < S m := lt_0_Sn m.
Definition viS {n m}: n < m -> S n < S m := lt_n_S n m.

Notation "!0" := vi0.
Notation "!+ i" := (viS i)
                   (at level 5, right associativity).

Section viget.
Variable A: Type.
Lemma lt_0_False: forall n, n < 0 -> False. intros. omega. Qed.
Fixpoint viget {n} (v: vector A n) m (H: m < n): A.
 destruct v.
 (* vnil *)
  apply lt_0_False in H. destruct H.
 destruct m.
 (* 0 *)
  exact a.
 (* (S _) *)
  apply viget with (n:=n) (m:=m).
  exact v. apply lt_S_n. exact H.
Defined.
End viget.
Notation "v '_[' i ]" := (viget v i)
                      (at level 7, left associativity)
                      : vector_scope.
Section viset.
Variable A: Type.
Fixpoint viset {n} (v: vector A n) m (H: m < n) (b:A) {struct v}: vector A n.
 destruct v as [|a n' v'].
 (* vnil => False *)
  apply lt_0_False in H. destruct H.
 destruct m.
 (* 0 *)
  exact (b::v').
 (* S _ *)
  apply (fun v''=> a::v'').
  apply viset with m; try assumption.
   apply lt_S_n. assumption.
Defined.
End viset.
Notation "v '_[' i ] / b" := (viset v i b)
                          (at level 7, b at level 50, left associativity)
                          : vector_scope.
Delimit Scope matrix_scope with mat.
Open Scope matrix_scope.
Notation "'mlengths'" := (vector nat)
                         (at level 0)
                         : matrix_scope.
Section matrix.
Variable A: Type.
Inductive matrix: forall n, mlengths n -> Type :=
  | mscalar: A -> matrix []
  | mvector: forall n m v,
             vector (@matrix n v) m ->
             @matrix (S n) (m::v)
.
End matrix.
Notation "''{}'" := (mvector []%vec): matrix_scope.
Notation "'#{' x , .. , z }" :=
         (mvector (x :: .. (z :: []) ..)%vec)
         (at level 0)
         : matrix_scope.
Notation "''{' x , .. , z }" :=
         (mvector (mscalar x :: .. (mscalar z :: []) ..)%vec)
         (at level 0)
         : matrix_scope.
Section fillvec.
Variable A: Type.
Variable a: A.
Fixpoint fillvec n: vector A n :=
 match n with
 | O => vnil
 | S n' => a :: fillvec n'
 end.
End fillvec.

Section fillmat.
Variable A: Type.
Variable a: A.
Fixpoint fillmat n (v: mlengths n): matrix A v.
 destruct n as [|n'].
 (* n = O *)
  dependent inversion v. constructor. assumption.
 (* n = S n' *)
 dependent inversion v; subst.
  constructor.
  apply fillvec.
  apply fillmat.
Defined.
End fillmat.

Section mmap.
Variables A B: Type.
Variable f: A -> B.
Fixpoint mmap n (v: mlengths n) (m: matrix A v): matrix B v.
 destruct n as [|n'].
 (* n = O *)
  dependent inversion v; subst.
  inversion m; subst.
  apply mscalar. apply f. assumption.
 (* n = S n' *)
 inversion m as [|l'' m'' v'']; subst. clear H.
 constructor.
 specialize (mmap n' v'').
 apply (vmap mmap).
 exact X.
Defined.
End mmap.

Require Import Eqdep_dec.

Section mzip.
Variables A B C: Type.
Variable f: A -> B -> C.
Fixpoint mzip n (v: mlengths n)
              (m1: matrix A v) (m2: matrix B v): matrix C v.
 destruct n as [|n'].
 (* n = 0 *)
  inversion m1. inversion m2.
  apply mscalar; apply f; assumption.
 (* n = S n' *)
  inversion m1 as [|? m1' l1 v1 H1 Heq1]; subst.
  inversion m2 as [|? m2' l2 v2 H2 Heq2]; subst.
  apply (inj_pair2_eq_dec _ eq_nat_dec _ _ _) in Heq1.
  apply (inj_pair2_eq_dec _ eq_nat_dec _ _ _) in Heq2.
  assert (Heq: m1' :: l1 = m2' :: l2).
   eapply eq_trans. apply Heq1. symmetry. exact Heq2.
   clear Heq1. clear Heq2.
  assert (Heqm: m1' = m2') by (inversion Heq; reflexivity).
  assert (Heql: l1 = l2).
   inversion Heq.
   apply (Eqdep_dec.inj_pair2_eq_dec _ eq_nat_dec _ _ _) in H1.
   exact H1.
  clear Heq. rename l2 into l. rename m2' into m'. subst.
  apply mvector.
  specialize (mzip n' l).
  apply (vzip mzip); assumption.
Defined.
End mzip.

Example mzip_ex1: mzip plus '{1,2} '{3,4} = '{4,6}.
Proof.
 simpl.
 (*
1 subgoal
______________________________________(1/1)
eq_rect_r
  (fun l1 : mlengths 0 => vector (matrix nat l1) 2 -> matrix nat (2 :: l1))
  (fun v1 : vector (matrix nat []) 2 =>
   eq_rect_r
     (fun m1' : nat => vector (matrix nat []) m1' -> matrix nat [m1'])
     (fun v0 : vector (matrix nat []) 2 =>
      mvector
......
*)
 Abort.


Module MyOption.

Inductive option (A:Type) : Type :=
  | Some : A -> option A
  | None : option A.

End MyOption.

Definition hd_opt {A : Type} (lst : list A) : option A :=
  match lst with
  | nil => None
  | x :: xs => Some x
  end.

Compute hd_opt [1].

Compute @hd_opt nat [].


Require Import ssreflect Arith.
Require Import Arith.EqNat.
Require Import Arith.Compare_dec.
Require Import List.
Require Import Omega.
Require Import untypedLambda.

Set Printing Universes.

(*Krivine Abstract Machine*)

(*Syntax*)

Inductive inst :=
| Access: nat -> inst
| Grab: inst
| Push: code -> inst
with code: Type :=
| cnil:   code
| cCons:  inst -> code -> code.

Inductive environment : Type :=
| nul: environment
| cons: code -> environment -> environment -> environment.

Definition state := prod (prod code environment) environment.

Check inst->code.
Check Set.
Check code.
Check Set -> Type.
Check environment.
Check environment_ind.

Check prod_curry cons (cnil,nul) nul.

(*Semantics*)

Fixpoint exec_inst (s: state): state:=
  match s with
    | (cCons (Access 0) c, cons c0 e0 e, stack) => (c0, e0, stack)
    | (cCons (Access n) c, cons c0 e0 e, stack) => (cCons (Access (n-1)) c, e, stack)
    | (cCons (Push c) c0, e, stack) => (c0, e, cons  c e stack)
    | (cCons Grab c, e, cons c0 e0 stack) => (c, cons  c0 e0 e, stack)
    | s => s
  end.

(*Compiling*)

Fixpoint compile (t: term): code :=
  match t with
      | Var n => cCons (Access n) cnil
      | Lambda t1 => cCons Grab (compile t1)
      | App t1 t2 => cCons (Push (compile t2)) (compile t1)
  end.

Fixpoint tau_code (c: code): term :=
  match c with
    | cnil => Var 0
    | (cCons (Access n) _ ) => Var n
    | (cCons (Push c1) c0) => App (tau_code c0) (tau_code c1)
    | (cCons Grab c0) => Lambda (tau_code c0)
  end.

Check multiple_substitution.

Fixpoint tau_env (e: environment): list term :=
  match e with
    | nul => nil
    | cons c0 e0 e1 =>
      (multiple_substitution 0 (tau_code c0) (tau_env e0)) :: tau_env e1
  end.

Check state.

Fixpoint transform_stk (stk: environment): list term :=
  match stk with
      | cons c0 e0 nul => multiple_substitution 0 (tau_code c0) (tau_env e0) :: nil
      | cons c0 e0 e1 => (multiple_substitution 0 (tau_code c0) (tau_env e0) :: (transform_stk e1))
      | nul => nil
  end.

Check fold_left.

Fixpoint tau (s: state): term :=
  match s with
    | (c, e, stk) =>
      match stk with
        | nul => multiple_substitution 0 (tau_code c) (tau_env e)
        | stk => fold_left (fun t1 t2 => App t1 t2) (transform_stk stk) (multiple_substitution 0 (tau_code c) (tau_env e))
      end
  end.

(*Compiling results*)

Lemma tau_nil_env: forall t: term, tau (compile t, nul, nul) = tau_code (compile t).
Proof.
  induction t.
  simpl.
  have: beq_nat v v = true.
  apply beq_nat_true_iff.
  reflexivity.
  intro h0.
  rewrite h0.
  rewrite -minus_n_O.
  have: leb v 0 = false \/ leb v 0 = true.
  apply dic.
  intro h1.
  case:h1.
  intro h1.
  rewrite h1.
  trivial.
  intro h1.
  rewrite h1.
  move:h1.
  case v.
  done.
  done.
  simpl.
  rewrite -lambda_equivalence.
  apply id_substitution.
  simpl.
  rewrite app_equivalence.
  split.
  apply id_substitution.
  apply id_substitution.
Qed.

Theorem invert_comp: forall (t: term), tau (compile t, nul, nul) = t.
Proof.
  induction t.
  simpl.
  have: beq_nat v v = true.
  apply beq_nat_true_iff.
  reflexivity.
  intro h0.
  rewrite h0.
  rewrite -minus_n_O.
  have: leb v 0 = false \/ leb v 0 = true.
  apply dic.
  intro h1.
  case:h1.
  intro h1.
  rewrite h1.
  trivial.
  intro h1.
  rewrite h1.
  move:h1.
  case v.
  done.
  done.
  simpl.
  rewrite -lambda_equivalence.
  rewrite tau_nil_env in IHt.
  rewrite IHt.
  apply id_substitution.
  simpl.
  rewrite app_equivalence.
  rewrite tau_nil_env in IHt1.
  rewrite tau_nil_env in IHt2.
  split.
  rewrite IHt1.
  apply id_substitution.
  rewrite IHt2.
  apply id_substitution.
Qed.

(*Correct state*)

Fixpoint length (e: environment): nat :=
  match e with
    | nul => 0
    | cons c0 e0 e1 => 1 + (length e1)
  end.

Lemma length_inv: forall e:environment, length e = Datatypes.length (tau_env e).
Proof.
  intros.
  induction e.
  done.
  simpl.
  omega.
Qed.

Inductive correct_stk : environment -> Prop :=
|Corr_stk_nul: correct_stk nul
|Corr_stk: forall (e e0:environment) (c0:code),  (C (length e0) (tau_code c0)) -> correct_stk e0 ->
  correct_stk e -> correct_stk (cons c0 e0 e).

Fixpoint corr_stk (stk: environment): Prop:=
  match stk with
    | nul => True
    | cons c0 e0 e => ((correct_stk e0) /\ (correct_stk e) /\ (C (length e0) (tau_code c0)))
  end.

Inductive correc_state: state -> Prop:=
|Corr_state: forall (c:code) (e stk:environment), (correct_stk e) -> (correct_stk stk) -> (C (length e) (tau_code c)) -> correc_state (c,e,stk).

Fixpoint correct_state (s:state):Prop:=
  match s with
   | (c, e, stk) => (correct_stk e) /\ (correct_stk stk) /\ (C (length e) (tau_code c))
  end.

Definition c_list_i (i:nat) (lu: list term) : Prop :=
  forall k: nat, k < Datatypes.length lu -> C i (nth k lu (Var 0)).

Fixpoint closed_list (i:nat) (lu: list term): Prop :=
  match lu with
    | nil => True
    | x :: xs => C i x /\ closed_list i xs
  end.

Lemma closed_list_eq: forall (lu: list term) (i: nat), closed_list i lu <-> c_list_i i lu.
Proof.
  induction lu.
  simpl.
  unfold c_list_i.
  split.
  simpl.
  intros.
  omega.
  trivial.
  simpl.
  split.
  intros.
  unfold c_list_i.
  intro.
  case k.
  simpl.
  intros.
  tauto.
  simpl.
  intros.
  apply IHlu.
  tauto.
  omega.
  intro.
  split.
  unfold c_list_i in H.
  apply (H 0).
  simpl.
  omega.
  apply IHlu.
  unfold c_list_i.
  intro.
  case k.
  intro.
  apply (H 1).
  simpl.
  omega.
  intros.
  apply (H (S (S n))).
  simpl.
  omega.
Qed.

Lemma lift_len_inv: forall (lu: list term) (i k: nat), Datatypes.length lu = Datatypes.length (lift_all i k lu).
Proof.
  admit.
Qed.

Lemma list_lift_free: forall (lu : list term) (i k : nat), c_list_i i lu -> c_list_i (i + 1) (lift_all 1 k lu).
Proof.
  admit.
Qed.

Lemma mult_sub_clos: forall (t: term) (u: list term) (i: nat), closed_list i u -> C (i+Datatypes.length u) t -> C i (multiple_substitution i t u).
Proof.
  induction t.
  simpl.
  intros.
  have: beq_nat v v = true.
  apply beq_nat_true_iff.
  done.
  intro.
  rewrite x.
  have:leb v (i + Datatypes.length u - 1) = true.
  apply leb_iff.
  omega.
  intro.
  rewrite x0.
  rewrite Bool.andb_true_r.
  have:leb i v = false \/ leb i v = true.
  apply dic.
  intro.
  case x1.
  intro.
  rewrite H1.
  simpl.
  apply leb_iff_conv in H1.
  trivial.
  intro.
  rewrite H1.
  apply leb_iff in x0.
  apply leb_iff in H1.
  apply closed_list_eq in H.
  unfold c_list_i in H.
  apply H.
  omega.
  simpl.
  intros.
  apply (IHt (lift_all 1 0 u) (i+1)).
  apply closed_list_eq.
  apply closed_list_eq in H.
  apply list_lift_free.
  done.
  rewrite -(lift_len_inv _ 1 0).
  have: i + Datatypes.length u + 1 = i + 1 + Datatypes.length u.
  omega.
  intro.
  rewrite -x.
  trivial.
  simpl.
  intros.
  split.
  apply IHt1.
  done.
  tauto.
  apply IHt2.
  done.
  tauto.
Qed.

(*Lemma mult_sub_clos: forall (t: term) (u: list term) (i: nat), c_list_i i u -> C (i+Datatypes.length u) t -> C i (multiple_substitution t u i (Datatypes.length u)).
Proof.
  induction t.
  simpl.
  intros.
  have: beq_nat v v = true.
  apply beq_nat_true_iff.
  done.
  intro.
  rewrite x.
  have:leb v (i + Datatypes.length u - 1) = true.
  apply leb_iff.
  omega.
  intro.
  rewrite x0.
  rewrite Bool.andb_true_r.
  have:leb i v = false \/ leb i v = true.
  apply dic.
  intro.
  case x1.
  intro.
  rewrite H1.
  simpl.
  apply leb_iff_conv in H1.
  trivial.
  intro.
  rewrite H1.
  apply H.
  apply leb_iff in H1.
  omega.
  simpl.
  intros.
  rewrite (lift_len_inv _ 1 0).
  apply (IHt (lift_all 1 0 u) (i+1)).
  apply list_lift_free.
  done.
  rewrite -(lift_len_inv _ 1 0).
  have: i + Datatypes.length u + 1 = i + 1 + Datatypes.length u.
  omega.
  intro.
  rewrite -x.
  trivial.
  simpl.
  intros.
  split.
  apply IHt1.
  done.
  tauto.
  apply IHt2.
  done.
  tauto.
Qed.*)

Lemma closed_env: forall e:environment, correct_stk e -> closed_list 0 (tau_env e).
Proof.
  induction e.
  simpl.
  trivial.

  intros.
  inversion H.
  simpl.
  split.
  apply mult_sub_clos.
  apply IHe1.
  trivial.
  simpl.
  rewrite -length_inv.
  trivial.
  apply IHe2.
  trivial.
Qed.

Theorem transition_inv_1: forall (c c0: code) (e e0 stack: environment),
  correct_state ((cCons (Access 0) c, cons c0 e0 e, stack)) -> correct_state  (c0, e0, stack).
Proof.
  simpl.
  intros.
  destruct H.
  inversion H.
  tauto.
Qed.

Theorem transition_inv_2: forall (c c0: code) (e e0 stack: environment) (n: nat), (n > 0) -> correct_state (cCons (Access n) c, cons c0 e0 e, stack) -> correct_state (cCons (Access (n-1)) c, e, stack).
Proof.
  simpl.
  intros.
  destruct H0.
  destruct H1.
  inversion H0.
  split.
  trivial.
  split.
  trivial.
  omega.
Qed.

Theorem transition_inv_3: forall (c c0: code) (e stack: environment), correct_state (cCons (Push c) c0, e, stack) -> correct_state (c0, e, cons c e stack).
Proof.
  simpl.
  intros.
  destruct H.
  destruct H0.
  destruct H1.
  split.
  trivial.
  split.
  apply Corr_stk.
  trivial.
  trivial.
  trivial.
  trivial.
Qed.

Theorem transition_inv_4: forall (c c0: code) (e e0 stack: environment),
correct_state (cCons Grab c, e, cons c0 e0 stack) -> correct_state (c, cons c0 e0 e, stack).
Proof.
  simpl.
  intros.
  destruct H as [H0 [H1 H2]].
  inversion H1.
  split.
  apply Corr_stk.
  trivial.
  trivial.
  trivial.
  split.
  trivial.
  rewrite plus_comm in H2.
  trivial.
Qed.

Theorem correct_invariance: forall s: state, correct_state s -> correct_state (exec_inst s).
Proof.
  intro.
  destruct s.
  destruct p.
  move: e e0.
  induction c.
  trivial.
  case i.
  intros n e e0.
  case e0.
  case n.
  trivial.
  trivial.
  intros p e1.
  unfold exec_inst.
  case n.
  intro.
  Search "transition_inv_1".
  apply transition_inv_1.
  intros n0 e2.
  apply transition_inv_2.
  omega.
  unfold exec_inst.
  intros e e0.
  case e.
  trivial.
  intros c0 e1 e2.
  apply transition_inv_4.
  intros c0 e e0.
  apply transition_inv_3.
Qed.

Lemma correct_reduction_1: forall (c c0: code) (e s: environment), correct_state (cCons (Push c0) c,e,s) -> reduces (tau (cCons (Push c0) c,e,s)) (tau (c, e, cons c0 e s)).
Proof.
  intros.
  simpl.
  case s.
  simpl.
  apply sym.
  intros.
  simpl in H.
  simpl.
  apply sym.
Qed.

Lemma correct_reduction_2: forall (c c0: code) (e e0 s: environment),
  correct_state ((cCons (Access 0) c, cons c0 e0 e, s)) -> reduces (tau (cCons (Access 0) c, cons c0 e0 e, s)) (tau (c0, e0, s)).
Proof.
  simpl.
  intros.
  case s.
  apply sym.
  intros.
  apply sym.
Qed.

Lemma correct_reduction_3: forall (c c0: code) (e e0 s: environment) (n: nat), (n > 0) -> correct_state (cCons (Access n) c, cons c0 e0 e, s) -> reduces (tau (cCons (Access n) c, cons c0 e0 e, s)) (tau (exec_inst (cCons (Access n) c, cons c0 e0 e, s))).
Proof.
  intros.
  unfold exec_inst.
  move:H H0.
  case n.
  intros.
  omega.
  intros.
  inversion H0.

  move : H0.

  case s.
  case e.
  simpl.

  intros.
  destruct H0.
  destruct H1.
  omega.

  intros.
  destruct H3.
  omega.

  unfold tau.
  rewrite NPeano.Nat.sub_succ.
  rewrite -minus_n_O.

  unfold tau_code.
  intros.
  simpl in H0.
  destruct H0 as [h1 [h2 h3]].
  have: closed_list 0 (tau_env (cons c0 e0 (cons c1 e1 e2))).
  apply closed_env.
  trivial.
  intro.

  unfold tau_env.
  case n0.
  simpl.
  apply sym.
  intros.
  simpl.
  rewrite mult_sub_clos.
  simpl in H0.
  destruct H0 as [[h1 [h2 h3]] [h4 h5]].
  have: n0 <= length e - 1.
  omega.
  intro.
  rewrite ?plus_O_n.
  have: S n0 <= length (cons (c0,e0) e) - 1.
  simpl.
  omega.
  intro.
  apply leb_iff in x.
  rewrite ?x.
  apply leb_iff in x0.
  rewrite x0.
  have: 0 <= n0.
  omega.
  intro.
  apply leb_iff in x1.
  rewrite x1.
  Search "andb".
  have: 0 <= S n0.
  omega.
  intro.
  apply leb_iff in x2.
  rewrite x2.
  simpl.
  rewrite ?h0.
  rewrite -minus_n_O.
  apply sym.
Qed.

Lemma correct_reduction_4: forall (c c0: code) (e e0 s: environment), correct_state (cCons Grab c, e, cons (c0,e0) s) -> reduces (tau (cCons Grab c, e, cons (c0,e0) s)) (tau (c, cons (c0,e0) e, s)).
Proof.
  intros.
  simpl in H.
  destruct H as [h0 [h1 h2]].
  destruct h1.
  destruct H0.
  case s.
  unfold tau.
  unfold transform_stk.
  unfold fold_left.
  unfold tau_code.
  fold tau_code.
  simpl.
  apply (ind _  (substitution 0 (multiple_substitution 1 (tau_code c) (lift_all 1 0 (tau_env e)))
                                (multiple_substitution 0 (tau_code c0) (tau_env e0)))  _).
  apply removeLamb.
  rewrite mult_sub_inv.
  rewrite -?length_inv.
  simpl.
  unfold correct_stk in h0.
  induction e.
  simpl.
  intros.
  admit.
  admit.
  admit.
  admit.
Qed.

Theorem correct_confluence: forall s: state, correct_state s -> reduces (tau s) (tau (exec_inst s)).
Proof.
  intro s.
  destruct s as ((c, e), s).
  move: e s.
  induction c.
  intros.
  apply sym.
  case i.
  intros n e s.
  case n.
  intros.
  unfold exec_inst.
  move:H.
  case e.
  intro.
  apply sym.
  intros.
  rewrite (surjective_pairing p).
  apply correct_reduction_2.
  rewrite -(surjective_pairing p).
  done.

  case e.
  intros.
  unfold exec_inst.
  apply sym.
  intros p e0 n0.
  rewrite (surjective_pairing p).
  intro.
  apply correct_reduction_3.
  omega.
  done.

  unfold exec_inst.
  intros.
  move:H.
  case s.
  intro.
  apply sym.
  intros.
  rewrite (surjective_pairing p).
  apply correct_reduction_4.
  rewrite -(surjective_pairing p).
  done.

  unfold exec_inst.
  intros.
  apply correct_reduction_1.
  done.
Qed.

  (*Unify every transition*)


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  An attempt at a variable module in a context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.

Add LoadPath "/home/milnes/Desktop/Research/Cyclone/CycloneCoq/3".
Require Export BoolEqualitySigDef.
Require Export EVarModuleDef.
Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.

Module PathModule <: BoolEqualitySig.
  Module E := EVarModule.

Inductive IPE: Type :=
 | zero_pe
 | one_pe.

Inductive PE : Type :=
 | i_pe      : IPE -> PE
 | u_pe      : PE.

Definition P : Type := list PE.
Definition T := P.

Function beq_ipe (i i' : IPE) : bool :=
  match i, i' with
    | zero_pe, zero_pe => true
    | one_pe, one_pe => true
    | _, _ => false
  end.
Hint Resolve beq_ipe.

Lemma beq_ipe_refl:
  forall i, beq_ipe i i = true.
Proof.
  destruct i; crush.
Qed.
Hint Resolve beq_ipe_refl.

Lemma beq_ipe_sym:
  forall i i', beq_ipe i i' = beq_ipe i' i.
Proof.
  destruct i; destruct i'; crush.
Qed.
Hint Immediate beq_ipe_sym.

Lemma beq_ipe_trans:
  forall p p0 p1,
    beq_ipe p p0 = true ->
    beq_ipe p0 p1 = true ->
    beq_ipe p p1 = true.
Proof.
  induction p; induction p0; induction p1; try solve[crush].
Qed.
Hint Resolve beq_ipe_trans.

Lemma beq_ipe_eq:
  forall i i', beq_ipe i i' = true -> i = i'.
Proof.
  destruct i; destruct i'; crush.
Qed.
Hint Immediate beq_ipe_eq.

Lemma beq_ipe_neq:
  forall i i', beq_ipe i i' = false -> i <> i'.
Proof.
  destruct i; destruct i'; crush.
Qed.
Hint Immediate beq_ipe_neq.

Function beq_pe (p p' : PE) : bool :=
  match p, p' with
    | i_pe x, i_pe y => beq_ipe x y
    | u_pe, u_pe => true
    | _, _ => false
  end.
Hint Resolve beq_pe.

Lemma beq_pe_refl:
  forall p, beq_pe p p = true.
Proof.
  destruct p; crush.
Qed.
Hint Resolve beq_pe_refl.

Lemma beq_pe_sym:
  forall p p', beq_pe p p' = beq_pe p' p.
Proof.
  destruct p; destruct p'; crush.
Qed.
Hint Immediate beq_pe_sym.

Lemma beq_pe_trans:
  forall p p0 p1,
    beq_pe p p0 = true ->
    beq_pe p0 p1 = true ->
    beq_pe p p1 = true.
Proof.
  induction p; induction p0; induction p1; try solve[crush].
  crush.
  apply beq_ipe_trans with (p:= i) (p0:= i0) (p1:= i1) in H; try assumption.
Qed.
Hint Resolve beq_pe_trans.

Lemma beq_pe_eq:
  forall p p', beq_pe p p' = true -> p = p'.
Proof.
  destruct p; destruct p'; try solve [crush].
  intros.
  unfold beq_pe in H.
  apply beq_ipe_eq in H.
  subst.
  reflexivity.
Qed.
Hint Immediate beq_pe_eq.

Lemma beq_pe_neq:
  forall p p', beq_pe p p' = false -> p <> p'.
Proof.
  destruct p; destruct p'; try solve [crush].
  intros.
  unfold beq_pe in H.
  apply beq_ipe_neq in H.
  subst.
  crush.
Qed.
Hint Immediate beq_pe_neq.

Function beq_path (p q : P) : bool :=
  match p, q with
    | [], [] => true
    | x :: p', y :: q' => andb (beq_pe x y) (beq_path p' q')
    | _  , _ => false
  end.
Hint Resolve beq_pe.
Definition beq_t := beq_path.

Lemma beq_path_refl:
 forall (p : P),
   beq_path p p = true.
Proof.
  induction p; crush.
Qed.
Hint Resolve beq_path_refl.

Lemma beq_path_sym : forall p p', beq_path p p' = beq_path p' p.
Proof.
  induction p; induction p'; try solve[crush].
  unfold beq_path.
  fold beq_path.
  specialize (IHp p').
  rewrite IHp.
  rewrite beq_pe_sym.
  reflexivity.
Qed.
Hint Immediate beq_path_sym.

Lemma beq_path_eq:
  forall p p',
    beq_path p p' = true ->
    p = p'.
Proof.
  induction p; induction p'; try solve [crush].
  unfold beq_path.
  fold beq_path.
  intros.
  apply andb_true_iff in H.
  inversion H.
  apply beq_pe_eq in H0.
  subst.
  apply IHp in H1.
  subst.
  reflexivity.
Qed.
Hint Resolve beq_path_eq.

Lemma beq_path_trans:
  forall p p0 p1,
    beq_path p p0 = true ->
    beq_path p0 p1 = true ->
    beq_path p p1 = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply beq_path_eq in H.
  apply beq_path_eq in H0.
  subst.
  apply beq_path_refl.
Qed.

Lemma beq_path_neq:
  forall p p',
    beq_path p p' = false ->
    p <> p'.
Proof.
  induction p; induction p'; try solve [crush].
  unfold beq_path.
  fold beq_path.
  intros.
  apply andb_false_iff in H.
  inversion H.
  apply beq_pe_neq in H0.
  crush.
  apply IHp in H0.
  crush.
Qed.
Hint Resolve beq_path_eq.

Definition beq_t_refl := beq_path_refl.
Definition beq_t_sym := beq_path_sym.
Definition beq_t_trans := beq_path_trans.

Definition beq_t_eq := beq_path_eq.
Definition beq_t_neq := beq_path_neq.
End PathModule.


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

(*i $Id: Wf_Z.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import BinInt.
Require Import Zcompare.
Require Import Zorder.
Require Import Znat.
Require Import Zmisc.
Require Import Wf_nat.
Open Local Scope Z_scope.

(** Our purpose is to write an induction shema for {0,1,2,...}
  similar to the [nat] schema (Theorem [Natlike_rec]). For that the
  following implications will be used :
<<
 (n:nat)(Q n)==(n:nat)(P (inject_nat n)) ===> (x:Z)`x > 0) -> (P x)

       	     /\
             ||
             ||

  (Q O) (n:nat)(Q n)->(Q (S n)) <=== (P 0) (x:Z) (P x) -> (P (Zs x))

      	       	       	       	<=== (inject_nat (S n))=(Zs (inject_nat n))

      	       	       	       	<=== inject_nat_complete
>>
  Then the  diagram will be closed and the theorem proved. *)

Lemma Z_of_nat_complete :
  forall x:Z, 0 <= x ->  exists n : nat, x = Z_of_nat n.
Proof.
  intro x; destruct x; intros;
    [ exists 0%nat; auto with arith
      | specialize (ZL4 p); intros Hp; elim Hp; intros; exists (S x); intros;
	simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x);
	  intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
	    apply nat_of_P_inj; auto with arith
      | absurd (0 <= Zneg p);
	[ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
	  auto with arith
	  | assumption ] ].
Qed.

Lemma ZL4_inf : forall y:positive, {h : nat | nat_of_P y = S h}.
Proof.
  intro y; induction y as [p H| p H1| ];
    [ elim H; intros x H1; exists (S x + S x)%nat; unfold nat_of_P in |- *;
      simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
	unfold nat_of_P in H1; rewrite H1; auto with arith
      | elim H1; intros x H2; exists (x + S x)%nat; unfold nat_of_P in |- *;
	simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
	  unfold nat_of_P in H2; rewrite H2; auto with arith
      | exists 0%nat; auto with arith ].
Qed.

Lemma Z_of_nat_complete_inf :
 forall x:Z, 0 <= x -> {n : nat | x = Z_of_nat n}.
Proof.
  intro x; destruct x; intros;
    [ exists 0%nat; auto with arith
      | specialize (ZL4_inf p); intros Hp; elim Hp; intros x0 H0; exists (S x0);
	intros; simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x0);
	  intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
	    apply nat_of_P_inj; auto with arith
      | absurd (0 <= Zneg p);
	[ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
	  auto with arith
	  | assumption ] ].
Qed.

Lemma Z_of_nat_prop :
  forall P:Z -> Prop,
    (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x.
Proof.
  intros P H x H0.
  specialize (Z_of_nat_complete x H0).
  intros Hn; elim Hn; intros.
  rewrite H1; apply H.
Qed.

Lemma Z_of_nat_set :
 forall P:Z -> Set,
   (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x.
Proof.
  intros P H x H0.
  specialize (Z_of_nat_complete_inf x H0).
  intros Hn; elim Hn; intros.
  rewrite p; apply H.
Qed.

Lemma natlike_ind :
 forall P:Z -> Prop,
   P 0 ->
   (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x.
Proof.
  intros P H H0 x H1; apply Z_of_nat_prop;
    [ simple induction n;
      [ simpl in |- *; assumption
	| intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
      | assumption ].
Qed.

Lemma natlike_rec :
 forall P:Z -> Set,
   P 0 ->
   (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x.
Proof.
  intros P H H0 x H1; apply Z_of_nat_set;
    [ simple induction n;
      [ simpl in |- *; assumption
	| intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
      | assumption ].
Qed.

Section Efficient_Rec.

  (** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed
      to give a better extracted term. *)

  Let R (a b:Z) := 0 <= a /\ a < b.

  Let R_wf : well_founded R.
  Proof.
    set
      (f :=
	fun z =>
	  match z with
	    | Zpos p => nat_of_P p
	    | Z0 => 0%nat
	    | Zneg _ => 0%nat
	  end) in *.
    apply well_founded_lt_compat with f.
    unfold R, f in |- *; clear f R.
    intros x y; case x; intros; elim H; clear H.
    case y; intros; apply lt_O_nat_of_P || inversion H0.
    case y; intros; apply nat_of_P_lt_Lt_compare_morphism || inversion H0; auto.
    intros; elim H; auto.
  Qed.

  Lemma natlike_rec2 :
    forall P:Z -> Type,
      P 0 ->
      (forall z:Z, 0 <= z -> P z -> P (Zsucc z)) -> forall z:Z, 0 <= z -> P z.
  Proof.
    intros P Ho Hrec z; pattern z in |- *;
      apply (well_founded_induction_type R_wf).
    intro x; case x.
    trivial.
    intros.
    assert (0 <= Zpred (Zpos p)).
    apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
    rewrite Zsucc_pred.
    apply Hrec.
    auto.
    apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
    intros; elim H; simpl in |- *; trivial.
  Qed.

  (** A variant of the previous using [Zpred] instead of [Zs]. *)

  Lemma natlike_rec3 :
    forall P:Z -> Type,
      P 0 ->
      (forall z:Z, 0 < z -> P (Zpred z) -> P z) -> forall z:Z, 0 <= z -> P z.
  Proof.
    intros P Ho Hrec z; pattern z in |- *;
      apply (well_founded_induction_type R_wf).
    intro x; case x.
    trivial.
    intros; apply Hrec.
    unfold Zlt in |- *; trivial.
    assert (0 <= Zpred (Zpos p)).
    apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
    apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
    intros; elim H; simpl in |- *; trivial.
  Qed.

  (** A more general induction principle on non-negative numbers using [Zlt]. *)

  Lemma Zlt_0_rec :
    forall P:Z -> Type,
      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
      forall x:Z, 0 <= x -> P x.
  Proof.
    intros P Hrec z; pattern z in |- *; apply (well_founded_induction_type R_wf).
    intro x; case x; intros.
    apply Hrec; intros.
    assert (H2 : 0 < 0).
    apply Zle_lt_trans with y; intuition.
    inversion H2.
    assumption.
    firstorder.
    unfold Zle, Zcompare in H; elim H; auto.
  Defined.

  Lemma Zlt_0_ind :
    forall P:Z -> Prop,
      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
      forall x:Z, 0 <= x -> P x.
  Proof.
    exact Zlt_0_rec.
  Qed.

  (** Obsolete version of [Zlt] induction principle on non-negative numbers *)

  Lemma Z_lt_rec :
    forall P:Z -> Type,
      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
      forall x:Z, 0 <= x -> P x.
  Proof.
    intros P Hrec; apply Zlt_0_rec; auto.
  Qed.

  Lemma Z_lt_induction :
    forall P:Z -> Prop,
      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
      forall x:Z, 0 <= x -> P x.
  Proof.
    exact Z_lt_rec.
  Qed.

  (** An even more general induction principle using [Zlt]. *)

  Lemma Zlt_lower_bound_rec :
    forall P:Z -> Type, forall z:Z,
      (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
      forall x:Z, z <= x -> P x.
  Proof.
    intros P z Hrec x.
    assert (Hexpand : forall x, x = x - z + z).
    intro; unfold Zminus; rewrite <- Zplus_assoc; rewrite Zplus_opp_l;
      rewrite Zplus_0_r; trivial.
    intro Hz.
    rewrite (Hexpand x); pattern (x - z) in |- *; apply Zlt_0_rec.
    2: apply Zplus_le_reg_r with z; rewrite <- Hexpand; assumption.
    intros x0 Hlt_x0 H.
    apply Hrec.
    2: change z with (0+z); apply Zplus_le_compat_r; assumption.
    intro y; rewrite (Hexpand y); intros.
    destruct H0.
    apply Hlt_x0.
    split.
    apply Zplus_le_reg_r with z; assumption.
    apply Zplus_lt_reg_r with z; assumption.
  Qed.

  Lemma Zlt_lower_bound_ind :
    forall P:Z -> Prop, forall z:Z,
      (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
      forall x:Z, z <= x -> P x.
  Proof.
    exact Zlt_lower_bound_rec.
  Qed.

End Efficient_Rec.


Require Import List FunctionalExtensionality.
Import ListNotations.

(* decidable sets *)
Definition pred T := T -> bool.

Notation "x \in L" := (L x) (at level 30, L at next level, only parsing) : bool_scope.
Notation "[$ x | B ]" := (fun x => B) (at level 0, x ident, only parsing) : bool_scope.
Notation "[$ x : T | B ]" := (fun x : T => B) (at level 0, x ident, only parsing) : bool_scope.

Open Scope bool_scope.

Theorem pred_eq_intro {X} (B1 B2 : X -> bool) :
  (forall x, B1 x = true <-> B2 x = true) -> [$ x | B1 x ] = [$ x | B2 x ].
Proof.
  intro H.
  extensionality x.
  assert (H0 := H x); clear H.
  case_eq(B1 x); case_eq(B2 x); intros H1 H2; intuition; congruence.
Qed.

Definition injective {A B} (f : A -> B) :=
  forall x y : A, f x = f y -> x = y.

Definition surjective {A B} (f : A -> B) :=
  forall y : B, exists x : A, f x = y.

Inductive bijective {A B} (f: A -> B) :=
  is_bijective : injective f -> surjective f -> bijective f.

Hint Constructors bijective.

Lemma rev_eq_nil {X} {xs : list X} : rev xs = [] -> xs = [].
Proof.
  intro H. destruct xs. reflexivity.
  assert(length (@nil X) = length (x::xs)). rewrite <- H. apply rev_length.
  inversion H0.
Qed.

Lemma rev_eq_singleton {X} {xs : list X} {x} : rev xs = [x] -> xs = [x].
Proof.
  intro H. destruct xs as [ |y[ |z xs]]. inversion H. simpl in H. assumption.
  assert(length ([x]) = length (y::z::xs)). rewrite <- H. apply rev_length.
  inversion H0.
Qed.


From Tealeaves Require Export
  Classes.Kleisli.DT.Monad
  Backends.LN
  Examples.STLC.Syntax.

Export STLC.Syntax.Notations.

(** * Inversion lemmas *)
(******************************************************************************)
Lemma inversion11 : forall (A : typ) (x : atom) (Γ : ctx),
    Γ ⊢ (tvar (Fr x)) : A -> (x, A) ∈ Γ.
Proof.
  inversion 1; auto.
Qed.

Lemma inversion12 : forall (A : typ) (n : nat) (Γ : ctx),
    Γ ⊢ (tvar (Bd n)) : A -> False.
Proof.
  inversion 1; auto.
Qed.

(* This is somewhat weak because L should really be (dom Γ) *)
Lemma inversion21 : forall (A B : typ) (e : term LN) (Γ : ctx),
    (Γ ⊢ λ A e : B) ->
    exists C, B = A ⟹ C /\ exists L, forall (x : atom), ~ AtomSet.In x L -> Γ ++ x ~ A ⊢ e '(tvar (Fr x)) : C.
Proof.
  introv J.
  inversion J; subst.
  exists τ2. split; auto; exists L; auto.
Qed.

(** Inversion principle for [abs] where we may assume the abstraction has arrow type *)
Lemma inversion22 : forall (A B : typ) (e : term LN) (Γ : ctx),
    (Γ ⊢ λ A e : A ⟹ B) ->
    exists L, forall (x : atom), ~ AtomSet.In x L -> Γ ++ x ~ A ⊢ e '(tvar (Fr x)) : B.
Proof.
  introv J. apply inversion21 in J.
  destruct J as [C [H1 H2]].
  assert (B = C) by (inversion H1; auto); subst.
  assumption.
Qed.

Lemma inversion3 : forall (A : typ) (Γ : ctx) (t1 t2 : term LN),
    (Γ ⊢ [t1]@[t2] : A) ->
    exists B, (Γ ⊢ t1 : B ⟹ A) /\ (Γ ⊢ t2 : B).
Proof.
  introv J; inversion J; subst.
  exists A0. split; auto.
Qed.

(** * Misc lemmas *)
(******************************************************************************)
Theorem j_ctx_wf : forall Γ (t : term LN) (A : typ),
    Γ ⊢ t : A -> uniq Γ.
Proof.
  introv J. induction J.
  - assumption.
  - specialize_freshly H0.
    now autorewrite with tea_rw_uniq in H0.
  - assumption.
Qed.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun s : AtomSet.t => s) in
  let B := gather_atoms_with (fun x : atom => {{ x }}) in
  let C := gather_atoms_with (fun t : term LN => freeset term t) in
  let D := gather_atoms_with (fun Γ : alist typ => domset Γ) in
  constr:(A ∪ B ∪ C ∪ D).

Theorem j_wf : forall Γ (t : term LN) (A : typ),
    Γ ⊢ t : A -> scoped term t (domset Γ).
Proof.
  introv J. induction J.
  - unfold scoped. rewrite term_freeset12.
    intro y. rewrite AtomSet.singleton_spec. intro; subst.
    rewrite in_domset_iff. eauto.
  - rename H0 into IH; rename H into premise.
    specialize_freshly IH. unfold scoped in *.
    rewrite term_freeset2.
    assert (step1 : freeset term t ⊆ freeset term (t '(tvar (Fr e))))
      by apply freeset_open_lower.
    assert (step2 : forall x, x ∈@ (freeset term t) -> x ∈@ (domset (Γ ++ e ~ τ1)))
      by fsetdec.
    intros x xin. assert (x <> e) by fsetdec.
    specialize (step2 x xin). rewrite domset_app in step2.
    cbn in step2. fsetdec.
  - unfold scoped in *. rewrite term_freeset3. fsetdec.
Qed.

Theorem is_bound_or_free_monotone : forall (k w1 w2 : nat) (l : LN),
    w1 < w2 ->
    is_bound_or_free k (w1, l) ->
    is_bound_or_free k (w2, l).
Proof.
  cbn. unfold_ops @Monoid_op_plus.
  introv Hlt Hyp. destruct l.
  + easy.
  + cbn in *. lia.
Qed.

Theorem lc_lam : forall (L : AtomSet.t) (t : term LN) (X : typ),
    (forall x : atom, ~ x ∈@ L -> locally_closed term (t '(tvar (Fr x)))) ->
    locally_closed term (λ X t).
Proof.
  introv hyp1. unfold locally_closed in *.
  rewrite term_lc_gap2. specialize_freshly hyp1.
  rewrite (open_lc_gap_eq_var_1). eauto.
Qed.

Theorem j_lc : forall Γ t A,
    Γ ⊢ t : A -> locally_closed term t.
Proof.
  introv J. induction J.
  - cbv. introv hyp. now inversion hyp.
  - pick fresh y excluding L and apply lc_lam; auto.
  - now rewrite term_lc3.
Qed.

Theorem weakening : forall Γ1 Γ2 Γ' (t : term LN) (A : typ),
    uniq Γ' ->
    disjoint Γ' (Γ1 ++ Γ2) ->
    (Γ1 ++ Γ2 ⊢ t : A) ->
    (Γ1 ++ Γ' ++ Γ2 ⊢ t : A).
Proof.
  introv Huq Hdj J.
  remember (Γ1 ++ Γ2) as Γrem.
  generalize dependent Γ2.
  induction J; intros; subst.
  - apply j_var. autorewrite with tea_rw_uniq tea_rw_disj in *.
    rewrite disjoint_sym. preprocess. intuition.
    simpl_list in *. intuition.
  - rename H0 into IH. pick fresh y and apply j_abs.
    specialize_cof IH y. simpl_alist in *.
    apply IH; auto. autorewrite with tea_rw_disj in *.
    splits; try easy. fsetdec.
  - eauto using j_app.
Qed.

Corollary weakening_r : forall Γ1 (t : term LN) (A : typ),
    (Γ1 ⊢ t : A) ->
    forall Γ2, uniq Γ2 -> disjoint Γ1 Γ2 -> Γ1 ++ Γ2 ⊢ t : A.
Proof.
  intros.
  rewrite <- (List.app_nil_r Γ1) in H.
  rewrite <- (List.app_nil_r (Γ1 ++ Γ2)).
  rewrite <- List.app_assoc.
  apply weakening; auto. List.simpl_list.
  eauto with tea_alist.
Qed.

Theorem substitution : forall Γ1 Γ2 (x : atom) (t u : term LN) (A B : typ),
    (Γ1 ++ x ~ A ++ Γ2 ⊢ t : B) ->
    (Γ1 ⊢ u : A) ->
    (Γ1 ++ Γ2 ⊢ t '{x ~> u} : B).
Proof.
  introv Jt Ju.
  specialize (j_ctx_wf (Γ1 ++ x~A ++ Γ2)); intro Hwf.
  assert (locally_closed term u) by (eauto using j_lc).
  remember (Γ1 ++ x ~ A ++ Γ2) as Γrem. generalize dependent Γ2.
  induction Jt; intros.
  - cbn. compare values x and x0.
    + assert (A0 = A) by eauto using binds_mid_eq; subst.
      autorewrite with tea_rw_uniq tea_rw_disj in *.
      apply weakening_r.
      * easy.
      * easy.
      * intuition (auto with tea_alist).
    + constructor; eauto using uniq_remove_mid, binds_remove_mid.
  - cbn. apply j_abs with (L := L ∪ domset Γ ∪ {{x}}).
    intros_cof H1.
    unfold preincr. reassociate ->. rewrite (extract_incr).
    change (binddt term (fun A0 : Type => A0) (subst_loc x u ∘ extract (prod nat)) t)
      with (t '{x ~> u}).
    change (@tvar) with (@ret term _).
    rewrite <- subst_open_var.
    + simpl_alist in *. eapply H1.
      * eauto using j_ctx_wf.
      * subst. now simpl_alist.
    + fsetdec.
    + auto.
  - cbn. eauto using j_app.
Qed.

Corollary substitution_r : forall Γ (x : atom) (t u : term LN) (A B : typ),
    (Γ ++ x ~ A ⊢ t : B) ->
    (Γ ⊢ u : A) ->
    (Γ ⊢ t '{x ~> u} : B).
Proof.
  introv Jt Ju.
  change_alist (Γ ++ x ~ A ++ nil) in Jt.
  change_alist (Γ ++ nil).
  eapply substitution; eauto.
Qed.

Inductive value : term LN -> Prop :=
  | value_abs : forall X t, value (λ X t).

Inductive beta_step : term LN -> term LN -> Prop :=
| beta_app_l : forall (t1 t2 t1' : term LN),
    beta_step t1 t1' ->
    beta_step ([t1]@[t2]) ([t1']@[t2])
| beta_app_r : forall (t1 t2 t2' : term LN),
    beta_step t2 t2' ->
    beta_step ([t1]@[t2]) ([t1]@[t2'])
| beta_beta : forall (X : typ) (t u : term LN),
    beta_step ([λ X t]@[u]) (t '(u)).

Theorem subject_reduction_step : forall (t t' : term LN) Γ A,
    Γ ⊢ t : A -> beta_step t t' -> Γ ⊢ t' : A.
Proof.
  intros t t' Γ A J step.
  generalize dependent t'.
  induction J.
  - intros; inversion step.
  - intros; inversion step.
  - intros; inversion step.
    + subst. apply j_app with (A := A); auto.
    + subst. apply j_app with (A := A); auto.
    + subst. apply inversion21 in J1.
      destruct J1 as [C [hyp1 [L hyp2]]].
      inversion hyp1; subst.
      specialize_freshly hyp2.
      assert (rw : t '(t2) = t '(tvar (Fr e)) '{e ~> t2}).
      { erewrite open_spec_eq. reflexivity.
        fsetdec. }
      rewrite rw. eapply substitution_r.
      exact hyp2. assumption.
Qed.

Theorem progress : forall (t : term LN) A,
    nil ⊢ t : A -> value t \/ (exists t', beta_step t t').
Proof.
  intros. remember [] as ctx.
  induction H.
  - subst. inversion H0.
  - left; constructor.
  - rename IHJudgment1 into IH1.
    rename IHJudgment2 into IH2.
    specialize (IH1 Heqctx); specialize (IH2 Heqctx).
    destruct IH1.
    + inversion H1; subst.
      right. exists (t '(t2)). constructor.
    + right. destruct H1. eexists.
      apply beta_app_l. eauto.
Qed.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
Require Program.Wf.
From mathcomp Require Import all_ssreflect ssralg fingroup finalg perm zmodp.
From mathcomp Require Import matrix.
Require Import ssr_ext ssralg_ext num_occ f2 ssrR hamming tanner linearcode.

(******************************************************************************)
(*                   Sum-Product Decoder over the BEC                         *)
(*                                                                            *)
(* This file provides an implementation of the Sum-Product algorithm over the *)
(* binary erasure channel as a recursive function (SP_BEC0_rec).              *)
(******************************************************************************)

(* OUTLINE
- Section letter.
- Section Sum_Prod_def.
- Section Sum_prop.
- Section Prod_prop.
- Section starletter_prop
- Section SumProd_algo_mxStar.
- Section mat_approx.
- Section mxSumProd_def : contains the definitions of rowVnextD1, etc.
- Section SumProdBEC_algo.
*)

Declare Scope letter_scope.
Declare Scope bec_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope num_occ_scope.
Local Open Scope ring_scope.
Import GRing.Theory.

Local Open Scope vec_ext_scope.

Section letter.

Inductive letter := Bit of 'F_2 | Star | Blank.

Definition eql (a b : letter) :=
  match a, b with
  | Bit a', Bit b' => a' == b'
  | Star, Star => true
  | Blank, Blank => true
  | _, _ => false
  end.

Lemma eqlP : Equality.axiom eql.
Proof.
move=> a b; apply: (iffP idP) => [|<-]; last first.
  case: a => // a'; by rewrite /= eqxx.
case: a b; [|by case|by case].
by move=> a'; case => //= b' /eqP ->.
Qed.

Canonical letter_eqMixin := EqMixin eqlP.
Canonical letter_eqType := Eval hnf in EqType letter letter_eqMixin.

CoInductive letter_spec : letter -> bool -> bool -> bool -> bool -> Prop :=
| letter_spec0 : letter_spec (Bit 0) true false false false
| letter_spec1 : letter_spec (Bit 1) false true false false
| letter_specstar : letter_spec Blank false false true  false
| letter_specblank : letter_spec Star false false false true.

Lemma letterP l : letter_spec l (l == Bit 0) (l == Bit 1) (l == Blank) (l == Star).
Proof.
case: l; [|by constructor|by constructor].
case/F2P; by constructor.
Qed.

Definition letter_pickle (l : letter) :=
  match l with
  | Bit a => if a == (Zp0 : 'F_2) then O else 1%N
  | Star => 2%N
  | Blank => 3%N
  end.

Definition letter_unpickle (n : nat) :=
  match n with
  | O => Some (Bit 0)
  | 1 => Some (Bit 1)
  | 2 => Some Star
  | 3 => Some Blank
  | _ => None
  end.

Lemma letter_count : pcancel letter_pickle letter_unpickle.
Proof. by case/letterP. Qed.

Definition letter_choiceMixin := PcanChoiceMixin letter_count.
Canonical letter_choiceType := Eval hnf in ChoiceType letter letter_choiceMixin.

Definition letter_countMixin := PcanCountMixin letter_count.
Canonical letter_countType := Eval hnf in CountType letter letter_countMixin.

Lemma letter_enumP : Finite.axiom [::Bit 0; Bit 1; Star; Blank].
Proof. by case => //; case/F2P. Qed.

Definition letter_finMixin := Eval hnf in FinMixin letter_enumP.
Canonical letter_finType := Eval hnf in FinType letter letter_finMixin.

Definition F2_of_letter (l : letter) : 'F_2 := if l is Bit a then a else 0.

Definition lel (a b : letter) :=
  (a == b) || if a is Bit _ then b == Star else false.

Local Notation "A '<=l' B" := (lel A B) (at level 20).

Lemma lell x : x <=l x.
Proof. by rewrite /lel eqxx orTb. Qed.

Lemma lel_Bit a b : (a <=l Bit b) = (a == Bit b).
Proof.
apply/idP/idP => [|/eqP ->]; last by rewrite lell.
case/letterP : a b => //; by case/F2P.
Qed.

Lemma lel_Star l : Star <=l l -> l = Star.
Proof. by case/letterP : l. Qed.

Lemma lel_Blank l : Blank <=l l -> l = Blank.
Proof. by case/letterP : l. Qed.

Lemma lel_trans : transitive lel.
Proof. by do 3 case/letterP. Qed.

(* lel lifted to matrices *)
Definition mxlel m n (A B : 'M[letter]_(m, n)) := [forall m, [forall n, A m n <=l B m n]].

Local Notation "A '<=m' B" := (mxlel A B) (at level 20).

Lemma lell_mat m0 n0 (A : 'M[letter]_(m0, n0)) : A <=m A.
Proof. rewrite /mxlel; apply/'forall_forallP => i j; exact: lell. Qed.

Lemma lel_trans_mat m0 n0 : transitive (@mxlel m0 n0).
Proof.
move=> A B C /'forall_forallP /= H1 /'forall_forallP H2.
apply/'forall_forallP => m1 n1; by apply: (lel_trans (H1 _ _) (H2 _ _)).
Qed.

Definition sum_letter (t : seq letter) := \sum_(l <- t) F2_of_letter l.

Definition is_Bit (l : letter) := if l is Bit _ then true else false.

Definition starblank l := ~~ is_Bit l.

Lemma starblankP x : reflect (starblank x) ((x == Star) || (x == Blank)).
Proof. apply/(iffP idP); by [case/orP => /eqP -> | case/letterP : x]. Qed.

Lemma letter_split (l : letter) : [exists b, l == Bit b] || (starblank l).
Proof.
case/letterP : l; rewrite ?orbT //.
by apply/orP; left; apply/existsP; exists 0.
by apply/orP; left; apply/existsP; exists 1.
Qed.

End letter.

Notation "A '<=l' B" := (lel A B) (at level 20) : letter_scope.
Notation "A '<=m' B" := (mxlel A B) (at level 20) : letter_scope.
Local Open Scope letter_scope.
Local Open Scope num_occ_scope.

Section Sum_Prod_def.

Definition Sum (s : seq letter) :=
  if has starblank s then Star
  else Bit (sum_letter (filter is_Bit s)).

Definition Prod (s : seq letter) :=
  if N(Bit 0 | s) > N(Bit 1 | s) then Bit 0
  else if N(Bit 0 | s) < N(Bit 1 | s) then Bit 1
  else Star.

End Sum_Prod_def.

Section Sum_prop.

Lemma Sum_blank_inv s : Sum s != Blank.
Proof. rewrite /Sum; by case: ifP. Qed.

Lemma le_Sum_Star s : Sum s <=l Star.
Proof. rewrite /Sum; by case: ifPn. Qed.

End Sum_prop.

Section Prod_prop.

Lemma Prod_filter_Star m n (A : 'M[letter]_(m, n)) n0 (s : {set 'I_m}) :
  Prod [seq A m0 n0 | m0 in s]  =
  Prod [seq A m0 n0 | m0 <- enum s & A m0 n0 != Star].
Proof.
rewrite /Prod; case: ifPn => [H|];
  do 2 rewrite (num_occ_map_filter [pred x | x != Star]) //.
- by rewrite H.
- rewrite -leqNgt leq_eqVlt => /orP[/eqP|] H;
    by [rewrite H ltnn | rewrite H ltnNge (ltnW H)].
Qed.

Lemma Prod1 l : l != Blank -> Prod [:: l] = l.
Proof. by case/letterP : l. Qed.

Lemma Prod_cons_Star s : Prod (Star :: s) = Prod s.
Proof. by []. Qed.

Lemma Prod_starblank_is_Star s : all starblank s -> Prod s = Star.
Proof.
move=> K.
rewrite /Prod.
suff : forall x : 'F_2, N(Bit x | s) = O by move=> X; rewrite 2!X.
move=> x.
apply/eqP; rewrite -notin_num_occ_0.
move/allP : K => /(_ (Bit x))/contra; exact.
Qed.

Lemma Prod_nseq_not_blank n x : n != O -> x != Blank -> Prod (nseq n x) = x.
Proof.
elim: n x => //= n IH x _ xblank; rewrite /Prod /=.
case/letterP : x xblank => //= _.
- rewrite add0n add1n (_ : N(Bit 1 | _) = O) //.
  apply/eqP; rewrite -notin_num_occ_0; apply/nseqP; by case.
- rewrite (_ : N(Bit 0 | _) = O) //.
  apply/eqP; rewrite -notin_num_occ_0; apply/nseqP; by case.
- rewrite !add0n (_ : N(Bit 1 | _) = O); last first.
    apply/eqP; rewrite -notin_num_occ_0; apply/nseqP; by case.
  rewrite (_ : N(Bit 0 | _) = O) //.
  apply/eqP; rewrite -notin_num_occ_0; apply/nseqP; by case.
Qed.

Lemma Prod_Bit (b : 'F_2) s : Prod s = Bit b -> Bit b \in s.
Proof.
rewrite /Prod.
case: ifPn => [H [<-] | H]; first by rewrite mem_num_occ_gt0 (leq_trans _ H).
case: ifPn => // H' [<-]; by rewrite mem_num_occ_gt0 (leq_trans _ H').
Qed.

Lemma Prod_cons (x : letter) h t :
  Prod [:: h] = x /\ (Prod t = x \/ Prod t = Star) ->
  Prod (h :: t) = x.
Proof.
case=> H1 H2.
rewrite /Prod /=.
case/letterP : h H1 => /=; rewrite {1}/Prod /= => ?; subst x; rewrite ?(addn0,addn1,add0n).
- case: H2; rewrite {1}/Prod.
    case: ifPn => [H3 _|].
      by rewrite ltnS leq_eqVlt H3 orbT.
    rewrite -leqNgt leq_eqVlt.
    case/orP => [/eqP ->|->//].
    by rewrite ltnn.
  case: ifPn => //; rewrite -leqNgt leq_eqVlt.
  case/orP => [/eqP|] -> //.
  rewrite ltnn => _ /=; by rewrite ltnS leqnn.
- case: H2; rewrite {1}/Prod.
    case: ifPn => [//|].
    rewrite -leqNgt leq_eqVlt.
    case/orP => [/eqP ->|H3].
      by rewrite ltnn.
    rewrite H3 => _.
    rewrite {1}add1n (leq_trans _ (leqnSn _)) // ltnNge ltnW //.
    by apply/leq_trans: H3.
  case: ifPn => //.
  rewrite -leqNgt leq_eqVlt.
  case/orP => [/eqP|] -> //.
  rewrite ltnn => _.
  by rewrite add1n ltnSn /= ltnNge leqnSn.
- by case: H2.
- by case: H2.
Qed.

Lemma Prod_StarE (s : seq letter) :
  (Prod s == Star) = [forall b, N(Bit (F2_of_bool b) | s) == N(Bit (F2_of_bool (~~ b)) | s)].
Proof.
apply/idP/idP => [| /forallP H0].
  rewrite /Prod.
  case: ifP => //.
  move/negbT.
  rewrite -leqNgt leq_eqVlt.
  case/orP => [/eqP H1|H1].
    rewrite H1 ltnn => _; apply/forallP; case; by apply/eqP.
  by rewrite H1.
by rewrite /Prod (eqP (H0 true)) ltnn.
Qed.

Lemma Prod_map_not_Star m n (A : 'M_(m, n)) n0 (s : {set 'I_m}) :
  Prod [seq A m1 n0 | m1 in s] != Star ->
  exists b m1, m1 \in s /\ A m1 n0 = Bit b.
Proof.
rewrite Prod_StarE negb_forall => /existsP[b Hb].
case/boolP : (N(Bit (F2_of_bool (b : bool)) | [seq A m1 n0 | m1 in s]) == O) => [H0|].
  have : 0 < N(Bit (F2_of_bool (~~ b)) | [seq A m1 n0 | m1 in s]).
    by rewrite lt0n; apply: contra Hb => /eqP ->.
  rewrite lt0n -notin_num_occ_0 negbK => /mapP[i Hi].
  exists (F2_of_bool (~~ b)), i; by rewrite mem_enum in Hi.
rewrite -notin_num_occ_0 negbK => /mapP[i Hi] H1.
exists (F2_of_bool b), i; by rewrite mem_enum in Hi.
Qed.

End Prod_prop.

Section starletter_prop.

Definition starletter x y := (x == Star) || (x == Bit y).

Lemma starletter_letter x : starletter (Bit x) x.
Proof. by rewrite /starletter eqxx orbC. Qed.

Lemma Prod_starletter m n (A : 'M_(m, n)) n0 (b : 'F_2) (s : {set 'I_m}):
  all [pred i | starletter (A i n0) b] (enum s) ->
  (exists2 i, i \in s & A i n0 != Star) ->
  Prod [seq A i n0 | i <- enum s] = Bit b.
Proof.
move=> H0 IH.
rewrite (Prod_filter_Star A n0 s).
set tmp := [seq _ | _ <- _ & _].
rewrite (_ : tmp = nseq (size tmp) (Bit b)); last first.
  apply: all_pred1P.
  apply/allP => /= x0.
  case/mapP => /= m1 Hm1 x0m1.
  rewrite x0m1.
  rewrite mem_filter in Hm1.
  case/andP : Hm1 => m1star Hm1.
  move/allP : H0 => /(_ m1); rewrite mem_enum => H0.
  have /H0 : m1 \in s by move: Hm1; rewrite mem_enum.
  by rewrite /= /starletter (negbTE m1star).
rewrite Prod_nseq_not_blank // /tmp size_map size_filter -lt0n -has_count.
apply/hasP.
case: IH => i H1 H2.
exists i => //; by rewrite mem_enum.
Qed.

Lemma Prod_cons_starletter m n (b : 'F_2) n0 (s : {set 'I_m}) (M : 'M[letter]_(m, n)):
  all [pred i | starletter (M i n0) b] (enum s) ->
  Prod (Bit b :: [seq M i n0 | i in s]) = Bit b.
Proof.
move=> /= H1.
apply/Prod_cons.
rewrite Prod1 //; split => //.
set l := [seq _ | _ in _].
case/boolP : (Bit b \in l) => Hl.
  left.
  transitivity (Prod [seq M m0 n0 | m0 <- (enum s)]) => //.
  apply (Prod_starletter H1).
  case/mapP : Hl => m1 H2 H3.
  exists m1; rewrite -?H3 //; by rewrite mem_enum in H2.
right.
rewrite (_ : l = nseq (size l) Star); last first.
  apply/all_pred1P/allP => /= x.
  case/mapP => m1 Hm1 Hx.
  move: H1 => /allP H1.
  case/orP: (H1 _ Hm1) => [|abs].
    by rewrite Hx.
  exfalso.
  move/negP : Hl; apply.
  apply/mapP; exists m1 => //.
  by rewrite (eqP abs).
apply/Prod_starblank_is_Star; by rewrite all_nseq orbT.
Qed.

Lemma Kop_proof x1 x2 x3 y1 y2 y3 :
  (x3 <= x2) && ((x3 == x2) ==> x1) ->
  (y3 <= y2) && ((y3 == y2) ==> y1) ->
  (x3 + y3 <= x2 + y2) && ((x3 + y3 == x2 + y2)%nat ==> x1 && y1).
Proof.
move=> /andP [Hx Hx1] /andP [Hy Hy1].
rewrite (@leq_trans (x3+y2)) ?leq_add2r //=.
  apply/implyP=> H3.
  move/implyP: Hx1 => ->.
    move/implyP: Hy1 => -> //.
    rewrite -(leq_add2r y3) (eqP H3) leq_add2l in Hx.
    by rewrite eqn_leq Hy Hx.
  rewrite -(leq_add2l x3) (eqP H3) leq_add2r in Hy.
  by rewrite eqn_leq Hx Hy.
by rewrite leq_add2l Hy.
Qed.

Definition num_stars m n (A : 'M[letter]_(m, n)) : nat :=
  \sum_(m0 < m) \sum_(n0 < n) (A m0 n0 == Star).

Lemma lmat_le_decr m n (A B : 'M_(m, n)) :
  A <=m B -> (A == B) || (num_stars A < num_stars B).
Proof.
move=> Hle.
suff : (num_stars A <= num_stars B) && ((num_stars A == num_stars B) ==>
       \big[andb/true]_(i < m) (row i A == row i B)).
  case/andP => A_le_B.
  case/boolP : (_ == _) => [A_eq_B|A_not_B _] /=.
    rewrite big_all => Hall.
    apply/orP; left.
    apply/eqP/row_matrixP => i.
    move/allP/(_ i) : Hall.
    by rewrite mem_index_enum => /(_ isT)/eqP.
  by rewrite ltn_neqAle A_le_B A_not_B orbT.
rewrite /num_stars.
elim/big_ind3 : _ => //.
  by apply Kop_proof.
move=> i _.
set lft := (_ <= _).
set rgt := (_ == _).
suff : lft && (rgt ==> \big[andb/true]_(j < n) (A i j == B i j)).
  rewrite /lft /rgt.
  case/andP => ->.
  case/boolP : (_ == _) => ? //=.
  rewrite big_all => Hall.
  apply/eqP/rowP => j.
  move/allP/(_ j): Hall.
  by rewrite mem_index_enum !mxE => /(_ isT)/eqP.
rewrite /lft /rgt.
elim/big_ind3 : _ => //.
  apply Kop_proof.
move=> j _.
move/'forall_forallP : Hle => /(_ i j).
by case/letterP : (A i j); case/letterP : (B i j).
Qed.

End starletter_prop.

Section SumProd_algo_mxStar.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''F'" := (Fnext H).

Definition mxStar := \matrix_(i < m, j < n) if i \in 'F j then Star else Blank.

Lemma mxStarE i j : i \in 'F j -> mxStar i j = Star.
Proof. rewrite /mxStar => ij; by rewrite mxE ij. Qed.

Lemma all_mxStar n0 : all [pred i | mxStar i n0 == Star] (enum ('F n0)).
Proof.
apply/allP => m0 Hm0; by rewrite inE mxStarE // -mem_enum.
Qed.

Lemma Prod_mxStar_col_Star n0 (s : {set 'I_m}) : Prod [seq (col n0 mxStar) m0 ord0 | m0 in s] = Star.
Proof.
rewrite Prod_starblank_is_Star //=; apply/allP => y' /mapP [x Hx ->].
rewrite 2!mxE; by case: ifPn.
Qed.

End SumProd_algo_mxStar.

Section mat_approx.

Variable (m n : nat).

Definition blank_to_star a := if a == Blank then Star else a.

Lemma Bit_col l b (bl : Bit b <=l l) (A : 'cV[letter]_m) (s : {set 'I_m}) :
  (forall i : 'I_m, Bit b <=l blank_to_star (A i ord0)) ->
  forall b' : 'F_2, Bit b' \in l :: [seq A m0 ord0 | m0 in s] -> b' = b.
Proof.
move=> Ha b'.
rewrite in_cons => /orP [Hy|].
  by move: bl; rewrite -(eqP Hy) lel_Bit => /eqP[].
move/mapP => [x Hx Hf].
by move: (Ha x); rewrite -Hf lel_Bit => /eqP[].
Qed.

Lemma Prod_cons_Bit l b (bl : Bit b <=l l) (A : 'cV[letter]_m) (s : {set 'I_m}) :
  (forall i, Bit b <=l blank_to_star (A i ord0)) ->
  has is_Bit (l :: [seq A m0 ord0 | m0 in s]) ->
  Prod (l :: [seq A m0 ord0 | m0 in s]) = Bit b .
Proof.
move=> Ha.
rewrite /Prod.
set lst := l :: _ => Hb.
case/boolP : (Bit 0 \in lst) => Hin0.
  case/boolP : (Bit 1 \in lst) => Hin1.
    move: (Bit_col bl Ha Hin0).
    by rewrite -(Bit_col bl Ha Hin1).
  move: Hin1; rewrite notin_num_occ_0 => /eqP ->.
  by rewrite -(Bit_col bl Ha Hin0) ltn0 lt0n -notin_num_occ_0 Hin0.
move: (Hin0); rewrite notin_num_occ_0 => /eqP ->.
case/boolP : (Bit 1 \in lst) => Hin1.
  by rewrite -(Bit_col bl Ha Hin1) ltn0 lt0n -notin_num_occ_0 Hin1.
case/hasP : Hb.
case/letterP => //; by [rewrite (negbTE Hin0) | rewrite (negbTE Hin1)].
Qed.

Definition approx (c : 'rV['F_2]_n) (M : 'M[letter]_(m, n)) :=
  [forall i, map_mx Bit c <=m map_mx blank_to_star (row i M)].

Local Notation "c <=* M" := (approx c M) (at level 20).

Lemma approx_mxStar H y : y <=* mxStar H.
Proof.
apply/'forall_forallP => /= m0 ord1.
apply/forallP => /= n0; rewrite !mxE; by case: ifP => [|] _.
Qed.

End mat_approx.

Notation "y <=* A" := (approx y A) (at level 20) : letter_scope.

Section mxSumProd_def.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).

Section rowVnext.

Definition rowVnextD1 (r : 'rV[letter]_n) n0 m0 : seq letter :=
  [seq r ``_ i | i in 'V n0 :\ m0].

Lemma sum_rowVnextD1 (c : 'rV['F_2]_n) (r : 'rV[letter]_n) m0 n0 :
  (forall j : 'I_n, j \in 'V m0 :\ n0 -> r ``_ j = Bit (c ``_ j)) ->
  sum_letter (filter is_Bit (rowVnextD1 r m0 n0)) = \sum_(i0 in 'V m0 :\ n0) c ``_ i0.
Proof.
move=> H0.
rewrite /sum_letter big_filter big_map big_mkcond /= big_filter.
apply eq_bigr => n1 Hn1; by rewrite H0.
Qed.

Section rowVnext_codeword.

Variables (c : 'rV['F_2]_n) (Hc : syndrome H c = 0).

Lemma sum_rowVnextD1_nostars m0 n0 (r : 'rV[letter]_n) :
  (forall j, j \in 'V m0 :\ n0 -> r ``_ j = Bit (c ``_ j)) ->
  m0 \in 'F n0 ->
  let s := rowVnextD1 r m0 n0 in
  ~~ has starblank s ->
  sum_letter (filter is_Bit s) = c ``_ n0.
Proof.
move=> H0 m0n0 s starblank.
move/matrixP/(_ ord0 m0) : Hc.
rewrite !mxE (bigD1 n0) //= => Hc'.
set rhs := \sum_(_ < _ | _) _ in Hc'.
have Hrhs : rhs = \sum_(i0 < _ | i0 \in 'V m0 :\ n0) c ``_ i0.
  rewrite /rhs.
  transitivity (\sum_(H0 < n | (H0 != n0) && (m0 \in 'F H0)) H m0 H0 * c^T H0 ord0).
    rewrite (bigID (fun j => m0 \in 'F j)) /=.
    rewrite (_ : \sum_(i0 < n | (i0 != n0) && (m0 \notin 'F i0)) H m0 i0 * c^T i0 ord0 = 0).
      by rewrite addr0.
    rewrite (eq_bigr (fun=> 0)).
      by rewrite big_const /= iter_addr0.
    move=> /= i0 /andP[] i0j.
    rewrite FnextE VnextE tanner_relE -F2_eq0 => /eqP ->; by rewrite mul0r.
  apply eq_big.
    by move=> j0 /=; rewrite in_setD1 FnextE.
  move=> i0 /andP[] H1.
  rewrite FnextE VnextE tanner_relE => /eqP ->; by rewrite mul1r mxE.
rewrite Hrhs (_ : H _ _ = 1) ?mul1r ?mxE in Hc'; last first.
  move: m0n0; by rewrite FnextE VnextE tanner_relE => /eqP.
move/eqP : Hc'.
rewrite addr_eq0 => /eqP ->.
rewrite (@sum_rowVnextD1 c) ?oppr_char2 // => *; by rewrite mxE H0.
Qed.

Lemma sum_rowVnextD1_Bit m0 n0 (m0n0 : m0 \in 'F n0) (r : 'rV[letter]_n) :
  (forall n1, n1 \in 'V m0 :\ n0 -> r ``_ n1 = Bit c ``_ n1) ->
  Sum (rowVnextD1 r m0 n0) = Bit c ``_ n0.
Proof.
move=> H0.
rewrite /Sum.
case: ifPn => [|Hx].
  case/hasP => /= x.
  case/mapP => /= n1.
  by rewrite mem_enum => /H0 -> ->.
rewrite sum_rowVnextD1_nostars // => *; by rewrite mxE H0.
Qed.

End rowVnext_codeword.

End rowVnext.

Section colFnext.

Definition ColFnext (l : letter) (c : 'cV[letter]_m) (s : {set 'I_m}) :=
  l :: [seq c m0 ord0 | m0 in s].

Lemma Prod_colFnext_Bit (b : 'F_2) (c : 'cV[letter]_m) (s : {set 'I_m}) :
  all [pred i | starletter (c i ord0) b] (enum s) ->
  Prod (ColFnext (Bit b) c s) = Bit b.
Proof.
move=> /= H1.
apply/Prod_cons.
rewrite Prod1 //; split => //.
set l := [seq _ | _ in _].
case/boolP : (Bit b \in l) => Hlst.
- left.
  apply Prod_starletter.
    apply/allP => x xFn0m0.
    by move: H1 => /allP/(_ x) /(_ xFn0m0).
  case/mapP : Hlst => m1 H2 H3.
  exists m1; rewrite -?H3 //; by rewrite mem_enum in H2.
- right.
  rewrite (_ : l = nseq (size l) Star); last first.
    apply/all_pred1P/allP => /= x.
    case/mapP => m1 Hm1 Hx.
    move: H1 => /allP/(_ _ Hm1).
    rewrite /= /starletter -Hx.
    case/orP => // xBitb.
    exfalso.
    move: Hlst; rewrite /l => /mapP; apply.
    exists m1 => //.
    by rewrite -Hx (eqP xBitb).
  apply/Prod_starblank_is_Star; by rewrite all_nseq orbT.
Qed.

Local Notation "'`F'" := (Fnext H).

Definition colFnext l (c : 'cV[letter]_m) n0 := ColFnext l c (`F n0).

Definition colFnextD1 l (c : 'cV[letter]_m) n0 m0 : seq letter :=
  ColFnext l c (`F n0 :\ m0).

End colFnext.

Definition mxSum M := \matrix_(i < m, j < n)
  if i \in 'F j then Sum (rowVnextD1 (row i M) i j) else M i j.

Definition mxProd (y : 'rV[letter]_n) M := \matrix_(i < m, j < n)
  if i \in 'F j then Prod (colFnextD1 (y ``_ j) (col j M) j i) else M i j.

Lemma has_starblank_rowVnextD1 (A B : 'M_(m, n)) y m0 n0 :
  mxProd y A <=m mxProd y B ->
  has starblank (rowVnextD1 (row m0 (mxProd y A)) m0 n0) ->
  has starblank (rowVnextD1 (row m0 (mxProd y B)) m0 n0).
Proof.
move=> AB /hasP[l l_row Hl]; move: l_row => /mapP[n1 Hn1 ln1].
apply/hasP => /=; exists l => //.
apply/mapP; exists n1 => //.
move/'forall_forallP/(_ m0 n1) : AB.
move: Hl.
rewrite {}ln1 {l} // mxE [(row _ _) _ _]mxE.
move/starblankP => /orP[/eqP ->|/eqP ->]; by [move/lel_Star | move/lel_Blank].
Qed.

Definition mxSumProd (y : 'rV[letter]_n) := mxSum \o mxProd y.

Lemma mxProd_Bit (y : 'rV[letter]_n) n0 (c : 'F_2) (cy : Bit c <=l y ``_ n0) (A : 'M[letter]_(m, n)) :
  (forall i, Bit c <=l blank_to_star (A i n0)) -> forall m0 b, mxProd y A m0 n0 = Bit b -> b = c.
Proof.
move=> Ha m0 b.
rewrite /mxProd mxE.
case: ifP => m0n0.
  move/Prod_Bit => mem_b.
  have Ha' : forall i : 'I_m, Bit c <=l blank_to_star ((col n0 A) i ord0).
    move=> i; move: Ha => /(_ i); by rewrite !mxE.
  apply: (@Bit_col _ _ _ cy _ ('F n0 :\ m0) Ha').
  move: mem_b; rewrite inE; case/orP => [/eqP <-|mem_b].
    by rewrite eqxx.
  apply/orP; right.
  case/mapP : mem_b => x Hx Hx'.
  apply/mapP; by exists x.
by move=> Hf; move: Ha => /(_ m0); rewrite Hf lel_Bit => /eqP[].
Qed.

Lemma mxProd_monotone y c (c_le_y : map_mx Bit c <=m y) A B : c <=* A -> c <=* B ->
  A <=m B -> mxProd y A <=m mxProd y B.
Proof.
move=> y'A y'B AB.
apply/'forall_forallP => m0 n0.
move Hpa' : (mxProd y B m0 n0) => b.
case/orP : (letter_split b) Hpa' => [/existsP[b' /eqP -> Hpa']|].
  move/'forall_forallP : c_le_y => /(_ ord0 n0); rewrite mxE => c_le_y'.
  have y'B' : forall i : 'I_m, Bit c ``_ n0 <=l blank_to_star (B i n0).
    move=> i.
    by move/'forall_forallP : y'B => /(_ i ord0)/forallP/(_ n0); rewrite !mxE.
  rewrite (mxProd_Bit c_le_y' y'B' Hpa').
  have y'A' : forall i : 'I_m, Bit c ``_ n0 <=l blank_to_star (A i n0).
    move=> i.
    by move/'forall_forallP : y'A => /(_ i ord0)/forallP/(_ n0); rewrite !mxE.
  move Hpa : (mxProd y A m0 n0) => c'.
  case/orP : (letter_split c') Hpa => [/existsP[c'' /eqP -> Hpa]|Hc' Hpa].
    by rewrite (mxProd_Bit c_le_y' y'A' Hpa) lell.
  rewrite /mxProd !mxE in Hpa Hpa'.
  case: ifP => Hi in Hpa Hpa'.
    rewrite (Prod_cons_Bit c_le_y') in Hpa => //.
      by rewrite -Hpa lell.
      move=> i.
      move/'forall_forallP : y'A => /(_ i ord0)/forallP/(_ n0).
      by rewrite !mxE.
    apply/hasP; exists (Bit b') => //.
    move/Prod_Bit: Hpa'.
    rewrite in_cons => /orP [|].
      by rewrite in_cons => ->.
    move/mapP=> [k Hk Hk'].
    move/'forall_forallP/(_ k n0): AB.
    move: Hk'; rewrite mxE => <-; rewrite lel_Bit => /eqP <-.
    rewrite in_cons; apply/orP; right.
    apply/mapP; exists k => //; by rewrite mxE.
  move/'forall_forallP/(_ m0 n0) : AB Hc'.
  by rewrite Hpa Hpa' lel_Bit => /eqP ->.
move=> Hb Hpa'.
move: Hpa' Hb.
rewrite /mxProd !mxE.
case: ifPn => [Hi|Hi <-].
  rewrite /Prod.
  case: ifPn => // H1 <- //; case: ifPn => //; case: ifPn => //; by case: ifPn.
by move/'forall_forallP/(_ m0 n0) : AB.
Qed.

Lemma mxSumProd_monotone A B y (c : 'rV['F_2]_n) (c_le_y : map_mx Bit c <=m y) :
  c <=* A -> c <=* B ->
  A <=m B -> mxSumProd y A <=m mxSumProd y B.
Proof.
move => Ha Ha' Haa'.
apply/'forall_forallP => m0 n0.
rewrite /mxSumProd !mxE.
case: ifP => Hi.
  rewrite /Sum.
  case: ifPn => [Hn1 | _].
    case: ifPn => // /negP Hn2.
    exfalso; apply Hn2; move: Hn1.
    exact/has_starblank_rowVnextD1/(mxProd_monotone c_le_y).
  case: ifPn => // Hn2.
  apply/orP; left.
  apply/eqP; congr Bit.
  rewrite /sum_letter 2!big_filter 2!big_map [in LHS]big_mkcond /=.
  rewrite [in RHS]big_mkcond /= 2!big_filter; apply eq_bigr => i Hi'.
  rewrite 2![(row _ _) _ _]mxE.
  move/forallP/(_ m0)/forallP/(_ i): (mxProd_monotone c_le_y Ha Ha' Haa') => /orP [/eqP -> //|].
  move: Hn2.
  move HB : (mxProd y A m0 i) => a.
  case/letterP : a HB => //= _ Hn2 /eqP.
    by move=> -> /=.
  move=> abs.
  exfalso.
  move/negP : Hn2; apply.
  apply/hasP; exists Star => //.
  apply/mapP; exists i => //.
  by rewrite mem_enum.
  by rewrite mxE.
rewrite Hi.
move/'forall_forallP : Haa'; by apply.
Qed.

Section mxSumProd_codeword.

Variables (c : 'rV['F_2]_n) (Hc : syndrome H c = 0).
Variables (y : 'rV[letter]_n) (c_le_y : map_mx Bit c <=m y).

Lemma approx_mxSumProd M : c <=* M -> c <=* mxSumProd y M.
Proof.
move=> cA.
apply/'forall_forallP => /= m0 k; rewrite {k}(ord1 k).
apply/forallP=> /= j.
rewrite 4!mxE.
case: ifPn => m0Fj; last first.
  rewrite mxE (negbTE m0Fj).
  move/'forall_forallP/(_ m0 ord0) : cA => /forallP/(_ j).
  by rewrite 3!mxE.
rewrite /Sum.
case: ifPn => // nostars.
apply/orP; left; apply/eqP; congr Bit.
rewrite (sum_rowVnextD1_nostars Hc) //= => n1 Hn1.
rewrite mxE.
move Hia : (mxProd y M m0 n1) => b.
case/orP : (letter_split b) Hia => [/existsP[/= b' /eqP -> Hia]|Hb Hia].
  move/'forall_forallP : c_le_y => /(_ ord0 n1); rewrite !mxE => c_le_y'.
  have Ha' : forall i : 'I_m, Bit c ``_ n1 <=l blank_to_star (M i n1).
    move=> i.
    by move/'forall_forallP : cA => /(_ i ord0)/forallP/(_ n1); rewrite !mxE.
  by rewrite (mxProd_Bit c_le_y' Ha' Hia).
move: nostars.
rewrite -all_predC.
move/allP => /=.
move/(_ b).
have X : b \in rowVnextD1 (row m0 (mxProd y M)) m0 j.
  rewrite -Hia.
  apply/mapP => /=.
  exists n1 => //; by rewrite ?(mxE, mem_enum).
move/(_ X).
by rewrite Hb.
Qed.

Lemma mxSumProd_invariant A : c <=* A -> mxSumProd y A <=m A ->
  c <=* mxSumProd y (mxSumProd y A) && mxSumProd y (mxSumProd y A) <=m mxSumProd y A.
Proof.
move=> Hap Halpha.
have Hap' := approx_mxSumProd Hap.
have Hap'' := approx_mxSumProd Hap'.
rewrite Hap'' /=.
by apply (mxSumProd_monotone c_le_y).
Qed.

End mxSumProd_codeword.

End mxSumProd_def.

Definition BEC_IO m n (H : 'M['F_2]_(m, n)) c y :=
  syndrome H c = 0 /\ map_mx Bit c <=m y.

Notation "x 'BEC(' H ')' y" := (BEC_IO H x y) (at level 20, format "x  'BEC('  H  ')'  y") : bec_scope.
Local Open Scope bec_scope.

Definition approx_BEC_input m n (H : 'M['F_2]_(m, n)) (y : 'rV[letter]_n) (M : 'M[letter]_(m, n)) :=
  exists2 c, c BEC( H ) y & c <=* M.

Section SumProdBEC_algo.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''F'" := (Fnext H).

Obligation Tactic := idtac.

Program Fixpoint SP_BEC0_rec y M
  (_ : approx_BEC_input H y M) (_ : mxSumProd H y M <=m M)
  { measure (num_stars M) } :
  {M' | mxSumProd H y M' = M' /\ M' <=m M /\ exists k, M' = iter k (mxSumProd H y) M} :=
  let M0 := mxSumProd H y M in
  match Bool.bool_dec (M == M0) true with
  | left H => M
  | right H => @SP_BEC0_rec y M0 _ _ _
  end.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: BEC_y => y' [Hy'1 Hy'2] y'a.
move/eqP : {Heq_anonymous} H0.
rewrite /M0 => <-; split => //.
split; [exact: lell_mat | by exists O].
Qed.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: BEC_y => y' [Hy'1 Hy'2] y'a.
exists y' => //; by apply approx_mxSumProd.
Qed.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: BEC_y => y' [Hy'1 Hy'2] y'a.
by case/andP: (mxSumProd_invariant Hy'1 Hy'2 y'a lelM).
Qed.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: BEC_y => y' [Hy'1 Hy'2] y'a.
move/andP: (mxSumProd_invariant Hy'1 Hy'2 y'a lelM) => [Ha' Hle'].
move: (lmat_le_decr lelM) => /orP [Heq|/leP] //.
elim H0.
by rewrite /M0 (eqP Heq) eqxx.
Qed.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: (SP_BEC0_rec _ _ _ _) => H' [H'fix [H'app [k Htmp]]].
split => //=.
split; first by apply: (lel_trans_mat H'app).
exists k.+1; by rewrite -addn1 iterD.
Qed.
Next Obligation. exact/Wf.measure_wf/Wf_nat.lt_wf. Defined.

Variable (y : 'rV[letter]_n).
Hypothesis BEC_y : exists c : 'rV['F_2]_n, c BEC( H ) y.

Lemma approx_BEC_input_mxStar : approx_BEC_input H y (mxStar H).
Proof. case: BEC_y => c cy; exists c => //; exact: approx_mxStar. Qed.

Lemma lelmxStar : mxSumProd H y (mxStar H) <=m mxStar H.
Proof.
apply/'forall_forallP => m0 n0; rewrite !mxE.
case: ifP => m0n0 /=; first exact: le_Sum_Star.
by rewrite m0n0 /= lell.
Qed.

Definition SP_BEC0 := projT1 (SP_BEC0_rec approx_BEC_input_mxStar lelmxStar).

Lemma SP_BEC0_is_a_fixpoint : SP_BEC0 = mxSum H (mxProd H y SP_BEC0).
Proof. rewrite /SP_BEC0; by case: SP_BEC0_rec => H' []. Qed.

Lemma SP_BEC0_is_mxlel : SP_BEC0 <=m mxStar H.
Proof. by rewrite /SP_BEC0; case: SP_BEC0_rec => H' [? []]. Qed.

Definition iSP_BEC0 k := iter k (mxSumProd H y) (mxStar H).

Lemma SP_BEC0_is_iter : exists k, SP_BEC0 = iSP_BEC0 k.
Proof. by rewrite /SP_BEC0; case: SP_BEC0_rec => H' [? []]. Qed.

Lemma iSP_BEC0_Blank : forall l m0 n0, m0 \notin 'F n0 ->
  (iSP_BEC0 l) m0 n0 = Blank.
Proof.
elim=> [m0 n0 m0n0 | l IH m0 n0 m0n0]; by rewrite /= !mxE (negbTE m0n0) ?IH.
Qed.

(* nth iteration + Product step *)
Definition PiSP_BEC0 l := mxProd H y (iSP_BEC0 l).

Definition Esti (M : 'M[letter]_(m, n)) : 'rV[letter]_n :=
  \row_i Prod (colFnext H (y ``_ i) (col i M) i).

Definition SP_BEC := Esti SP_BEC0.

End SumProdBEC_algo.

(*
Check bp_erasure.
Extraction "bp_erasure.ml" bp_erasure.
*)


(** This file is part of CoqEAL, the Coq Effective Algebra Library.
(c) Copyright INRIA and University of Gothenburg, see LICENSE *)
Require Import ZArith Ncring Ncring_tac.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype.
From mathcomp Require Import div finfun bigop prime binomial ssralg finset fingroup finalg.
From mathcomp Require Import perm zmodp matrix.

Require Import ssralg_ring_tac.

(** This file describes a formally verified implementation of Strassen's
algorithm (Winograd's variant). *)

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

Local Open Scope ring_scope.

Section Strassen.
Variable (R : ringType) (K : positive).

Local Coercion nat_of_pos : positive >-> nat.

Lemma addpp p : xO p = (p + p)%N :> nat.
Proof. by rewrite /= NatTrec.trecE addnn. Qed.

Lemma addSpp p : xI p = (p + p).+1%N :> nat.
Proof. by rewrite /= NatTrec.trecE addnn. Qed.

Lemma addp1 p : xI p = (xO p + 1)%N :> nat.
Proof. by rewrite addn1. Qed.

Lemma add1pp p : xI p = (1 + (p + p))%N :> nat.
Proof. by rewrite /= NatTrec.trecE addnn. Qed.

Lemma lt0p : forall p : positive, 0 < p.
Proof.
by elim=> // p IHp /=; rewrite NatTrec.doubleE -addnn; exact:ltn_addl.
Qed.

Local Open Scope ring_scope.

Definition Strassen_step {p : positive} (A B : 'M[R]_(p + p, p + p))
  (f : 'M[R]_(p, p) -> 'M_(p, p) -> 'M[R]_(p, p)) : 'M_(p + p, p + p) :=
  let A11 := ulsubmx A in
  let A12 := ursubmx A in
  let A21 := dlsubmx A in
  let A22 := drsubmx A in
  let B11 := ulsubmx B in
  let B12 := ursubmx B in
  let B21 := dlsubmx B in
  let B22 := drsubmx B in
  let X := A11 - A21 in
  let Y := B22 - B12 in
  let C21 := f X Y in
  let X := A21 + A22 in
  let Y := B12 - B11 in
  let C22 := f X Y in
  let X := X - A11 in
  let Y := B22 - Y in
  let C12 := f X Y in
  let X := A12 - X in
  let C11 := f X B22 in
  let X := f A11 B11 in
  let C12 := X + C12 in
  let C21 := C12 + C21 in
  let C12 := C12 + C22 in
  let C22 := C21 + C22 in
  let C12 := C12 + C11 in
  let Y := Y - B21 in
  let C11 := f A22 Y in
  let C21 := C21 - C11 in
  let C11 := f A12 B21 in
  let C11 := X + C11 in
  block_mx C11 C12 C21 C22.

Definition Strassen_xO {p : positive} Strassen_p :=
  fun A B =>
    if p <= K then A *m B else
    let A := castmx (addpp p,addpp p) A in
    let B := castmx (addpp p,addpp p) B in
    castmx (esym (addpp p), esym (addpp p)) (Strassen_step A B Strassen_p).

Definition Strassen_xI {p : positive} Strassen_p :=
   fun M N =>
    if p <= K then M *m N else
    let M := castmx (add1pp p, add1pp p) M in
    let N := castmx (add1pp p, add1pp p) N in
    let M11 := ulsubmx M in
    let M12 := ursubmx M in
    let M21 := dlsubmx M in
    let M22 := drsubmx M in
    let N11 := ulsubmx N in
    let N12 := ursubmx N in
    let N21 := dlsubmx N in
    let N22 := drsubmx N in
    let R11 := (M11 *m N11) + (M12 *m N21) in
    let R12 := (M11 *m N12) + (M12 *m N22) in
    let R21 := (M21 *m N11) + (M22 *m N21) in
    let R22 := (M21 *m N12) + (Strassen_step M22 N22 Strassen_p) in
    castmx (esym (add1pp p), esym (add1pp p)) (block_mx R11 R12 R21 R22).

Definition Strassen :=
  positive_rect (fun p => ('M_(p, p) -> 'M_(p, p) -> 'M_(p, p)))
                (@Strassen_xI) (@Strassen_xO) (fun M N => M *m N).

Lemma Strassen_stepP (p : positive) (A B : 'M[R]_(p + p)) f :
  f =2 mulmx -> Strassen_step A B f = A *m B.
Proof.
move=> Hf; rewrite -{2}[A]submxK -{2}[B]submxK mulmx_block /Strassen_step !Hf.
rewrite /GRing.add /= /GRing.opp /=.
by congr block_mx; non_commutative_ring.
Qed.

Lemma mulmx_cast {R' : ringType} {m n p m' n' p'} {M:'M[R']_(m,p)} {N:'M_(p,n)}
  {eqm : m = m'} (eqp : p = p') {eqn : n = n'} :
  matrix.castmx (eqm,eqn) (M *m N) = matrix.castmx (eqm,eqp) M *m matrix.castmx (eqp,eqn) N.
Proof. by case eqm; case eqn; case eqp. Qed.

Lemma StrassenP p : mulmx =2 (Strassen (p := p)).
Proof.
elim: p => // [p IHp|p IHp] M N.
  rewrite /= /Strassen_xI; case:ifP=> // _.
  by rewrite Strassen_stepP // -mulmx_block !submxK -mulmx_cast castmxK.
rewrite /= /Strassen_xO; case:ifP=> // _.
by rewrite Strassen_stepP // -mulmx_cast castmxK.
Qed.

End Strassen.


Require Import McExamples.Tauto.Tauto.

Module Demo.
  Ltac prep := unfold
    mkBigTerm, mkTerm, mkForalls, mkForalls_aux, mkImpls, mkAnds.

  Ltac run := the_tac.
  Ltac cleanup := idtac.

  Definition goal := fun n => ILogic.lentails ILogic.ltrue (mkBigTerm 2 n).
End Demo.