Require Import FunctionalExtensionality.
Require Import Arith Bool Omega Psatz Cecoa.Rationals.Lib Cecoa.Rationals.Syntax List Cecoa.Rationals.CBV_cache Cecoa.Rationals.Ordering.
Import List.ListNotations.

Section Bounds.

Variables variable function constructor : Type.

Variable variable_eq_dec : forall (x1 x2 : variable), {x1=x2}+{x1<>x2}.
Variable function_eq_dec : forall (x1 x2 : function), {x1=x2}+{x1<>x2}.
Variable constructor_eq_dec : forall (x1 x2 : constructor), {x1=x2}+{x1<>x2}.

Variable max_arity : nat.

Notation rule := (Syntax.rule variable function constructor).
Notation term := (Syntax.term variable function constructor).
Notation value := (Syntax.value constructor).
Notation cbv := (CBV_cache.cbv variable function constructor).
Notation "'╎' t '╎'" := (@term_size variable function constructor t) (at level 10).

Variable prog : list rule.
Variable rule_default : rule.
Variable subst_default : variable -> value.

Notation assoc_cache := (assoc (term_beq variable_eq_dec function_eq_dec constructor_eq_dec)).

Notation wf :=
  (CBV_cache.wf variable_eq_dec function_eq_dec constructor_eq_dec rule_default prog max_arity).

Variable rank: function -> nat.

Variable max_rank : nat.

Hypothesis pos_max_rank : 0 < max_rank.

Hypothesis max_rank_is_max_rank : forall f, rank f <= max_rank.

Notation PPO_prog := (Ordering.PPO_prog prog rank).

(** There are no duplicates in ℐᵃ *)
Lemma NoDup_left_ℐᵃ_cache_order i s p c1 t c2 v:
  PPO_prog ->
  wf (cbv_update i s p c1 t c2 v) ->
  NoDup (map (@proj_left _ _ _) (ℐᵃ_cache_order (cbv_update i s p c1 t c2 v))).
Proof.
  intros Hppoprg Hwf;
  assert (Hgeneralized:
            forall (p: cbv),
              let act_lefts := map (@proj_left _ _ _) (ℐᵃ_cache_order p) in
              wf p ->
              NoDup act_lefts /\
              (forall t, In t act_lefts -> ~ In t (map (@fst term value) (cache_left p))));
  [ idtac | apply Hgeneralized; assumption ].

  clear i s p c1 t c2 v Hwf.
  intros p.

  induction p as [ lp c1 t c2 v IHlp | lp p' c1 t c2 v IHlp IHp | i s p' c1 t c2 v IHp | c t v ]
                   using cbv_ind2;
    intros act_lefts Hwf.

  - (* cbv_constr *)
    simpl; simpl in act_lefts.
    assert (Hwf' : andl (map wf lp)
                   /\ @cache_path _ _ _ variable_eq_dec function_eq_dec constructor_eq_dec c1 c2 lp = true).
    { simpl in Hwf.
      repeat match goal with
               | _ : match ?x with _ => _ end |- _ => destruct x; try tauto
             end.
    }
    clear t v Hwf.
    destruct Hwf' as [ Hwflp Hcachepath ].
    revert c1 c2 Hcachepath;
      induction lp as [ | p' lp' IH ];
      intros c1 c2 Hcachepath.

    + simpl in act_lefts.
      unfold act_lefts.
      split; [ solve[apply NoDup_nil] | idtac ].
      intros t' Hin_nil;
        exfalso;
        revert Hin_nil.
      apply in_nil.

    + split.

      * simpl in act_lefts;
        unfold act_lefts.

        rewrite map_app.
        { apply NoDup_app.

          - intros t Hin.
            eapply cache_path_proj_left_in_tail_not_in_head; eauto.

          - apply cache_path_cons in Hcachepath;
            try assumption;
            destruct Hcachepath as ( Hcache1 & Hcachepath ).
            destruct Hwflp.
            eapply IH; [ idtac | assumption | exact Hcachepath ].
            intros;
              apply IHlp;
              [ apply in_cons | idtac ];
              assumption.

          - destruct Hwflp.
            apply IHlp; [ apply in_eq | assumption ].
        }

      * intros t.
        eapply cache_path_proj_left_not_in_init with (c2 := c2); eauto.

  - (* cbv_split *)
    simpl.
    simpl in Hwf, act_lefts.
    assert (Hwf' : wf p' /\ andl (map wf lp)
            /\ @cache_path _ _ _ variable_eq_dec function_eq_dec constructor_eq_dec c1 (cache_left p') lp = true).
    {
      simpl in Hwf.
      repeat match goal with
      | _ : match ?x with _ => _ end |- _ => destruct x; try tauto
      end.
    }
     clear t v Hwf.
     destruct Hwf' as ( Hwfp' & Hwflp & Hcachepath ).
     revert c1 c2 Hcachepath;
     induction lp as [ | p'' lp'' IH ];
     intros c1 c2 Hcachepath.
     + simpl in act_lefts.
        unfold act_lefts.
        repeat rewrite app_nil_r.
       split.
       * apply IHp; assumption.

       * intros t' Hin_nil.
          replace c1 with (cache_left p') by
            (simpl in Hcachepath; apply cache_beq_eq in Hcachepath;
              symmetry; try assumption).
          apply IHp; assumption.

      + destruct Hwflp.
         split.
        * simpl in act_lefts;
           unfold act_lefts.
           do 2 rewrite map_app.
          { apply NoDup_app.
            - intros t Hin.
                apply cache_path_cons in Hcachepath; try assumption.
                destruct Hcachepath as ( Hcacheeq & Hcachepath ).
                rewrite in_app_iff.
                intro Hf; destruct Hf as [Hflp'' | Hfp''].
              + assert (HND : NoDup  (map (proj_left (constructor:=constructor)) (ℐᵃ_cache_order p' ++ revflatten (map (ℐᵃ_cache_order (constructor:=constructor)) lp'')))).
                {
                    eapply IH with (c1 := cache_right p''); try trivial.
                    intros; apply IHlp; auto with *.
                }
                  rewrite map_app in HND.
                  apply NoDup_app_in_l with (x := t) in HND; tauto.

              + simpl in Hcacheeq.
                  apply IH with (t := t) ( c1 := cache_right p''); try tauto.
                * intros.
                    apply IHlp; auto with *.

                * rewrite map_app, in_app_iff; tauto.

                * erewrite cache_content; eauto.
                    rewrite map_app, in_app_iff, map_map.
                    simpl.
                    tauto.

            - apply IHp; assumption.

            - apply NoDup_app.
              + intros x Hx.
                  eapply cache_path_proj_left_in_tail_not_in_head; eauto.
                  split; eassumption.

              + simpl in Hcachepath.
                  rewrite andb_true_iff in Hcachepath.
                  destruct Hcachepath as [Hcacheeq Hcachepath].
                  apply IH in Hcachepath; try assumption.
                * destruct Hcachepath as [HH _].
                    rewrite map_app in HH.
                    apply NoDup_split_right in HH.
                    exact HH.

                * intros.
                    apply IHlp; [right |]; assumption.

              + apply IHlp; [ left | ]; trivial.
          }

        * replace c1 with (cache_left p'') by
            (simpl in Hcachepath; rewrite andb_true_iff in Hcachepath;
            rewrite cache_beq_eq in Hcachepath; symmetry; tauto).
           intros t Ht.
           unfold act_lefts in Ht.
           rewrite map_app in Ht.
           apply in_app_iff in Ht.
          {
             simpl in Hcachepath.
             rewrite andb_true_iff in Hcachepath;
             rewrite cache_beq_eq in Hcachepath; try tauto.
             destruct Hcachepath as [Heq Hcachepath].
             destruct Ht as [Ht | Ht].
            - assert (Hnin : ~ t ∈ map (@fst _ _) (cache_left p')).
              + apply IHp; assumption.

              + intro HH; apply Hnin.
                  eapply cache_path_incl in Hcachepath; eauto.
                  assert (HC2 : cache_path variable_eq_dec function_eq_dec constructor_eq_dec (cache_left p'') (cache_right p'') [p''] = true) by
                    (simpl; rewrite andb_true_iff;
                    repeat rewrite cache_beq_eq; tauto).
                  eapply cache_path_incl in HC2; simpl; eauto.
                  apply map_incl with (l1 :=  (cache_left p'')); try assumption.
                  eapply incl_tran; eauto.

            - simpl in Ht.
                rewrite map_app, in_app_iff in Ht.
                destruct Ht as [Ht | Ht].
              + assert (~ t ∈ map (@fst _ _) (cache_right p'')).
                * apply IH; try tauto.
                    intros; apply IHlp; [auto with * | assumption].
                    rewrite map_app, in_app_iff. tauto.

                * intro Hf; apply H1.
                    apply map_incl with (l1 :=  (cache_left p'')); try assumption.
                    eapply cache_path_incl with (c1 := cache_left p'') (lp := [p'']); simpl;
                    try rewrite andb_true_iff, cache_beq_eq, cache_beq_eq; eauto.

              + apply IHlp; [ left | | ]; trivial.
          }

  - (* cbv_update *)
    unfold act_lefts.
    split.
    + simpl.
       apply NoDup_cons.
      * intro Hfalse.
         apply in_map_iff in Hfalse.
         destruct Hfalse as (p0 & Hp0eq & Hp0act).
         eapply Permutation.Permutation_in in Hp0act;
           [| symmetry; apply ℐᵃ_cache_order_are_ℐᵃ].
         pose (π := cbv_update i s p' c1 t c2 v).
         apply PPO_ℐᵃ with (rank := rank) (p' := p0) in Hwf; simpl; try tauto.
         destruct Hwf.
            subst p0.
            clear Hp0eq.
            apply ℐᵃ_inCBV,
                  InCBV_In_ℐ,
                ℐ_size_rec_le,
                  le_not_lt in Hp0act.

            apply Hp0act.
            simpl.
            assert (0 < value_size v) by
             (destruct v; simpl; omega).
            omega.

            rewrite Hp0eq in *.
            simpl in H.
            subst.
            apply PPO_irrefl in H.
            exact H.

      * simpl in Hwf.
         destruct t; try tauto.
         destruct Hwf as (Hassoc & lp & t & _ & _ & Hl & Hpl & Hpr & Hcl & _ & Hc2 & Hwf & _).
         apply IHp; assumption.

    + simpl in *.
      destruct t; try tauto.
      decompose record Hwf.
      clear Hwf.
      intros t Ht.
      destruct Ht as [Ht | Ht].
      * subst t.
        apply assoc_None_not_in in H; [ | apply term_beq_eq]; assumption.

      * replace c1 with (cache_left p').
        apply IHp; assumption.

  - (* cbv_read *)
    unfold act_lefts; simpl.
    split.
    + apply NoDup_nil.

    + tauto.
Qed.

Lemma NoDup_left_ℐᵃ i s p c1 t c2 v:
  PPO_prog ->
  wf (cbv_update i s p c1 t c2 v) ->
  NoDup (map (@proj_left _ _ _) (ℐᵃ (cbv_update i s p c1 t c2 v))).
Proof.
  intros HPPO Hwf.
  eapply NoDup_Permutation_NoDup. (* 8.5 : Permutation.Permutation_NoDup *)
  - apply NoDup_left_ℐᵃ_cache_order.
    +  exact HPPO.

    + exact Hwf.

  - apply Permutation.Permutation_map.
    apply Permutation.Permutation_sym.
    apply ℐᵃ_cache_order_are_ℐᵃ.
Qed.

Definition ℐᵃ_at_rank (rk: nat) (p : cbv) : list cbv :=
  filter (fun p => beq_nat rk (activation_rank rank p)) (ℐᵃ p).

Lemma ℐᵃ_at_rank_incl_ℐᵃ (rk: nat) (p: cbv) :
  incl (ℐᵃ_at_rank rk p) (ℐᵃ p).
Proof.
unfold ℐᵃ_at_rank.
apply incl_filter.
Qed.

Lemma ℐᵃ_at_rank_wf (rk: nat) (p p': cbv) :
  wf p ->
  In p' (ℐᵃ_at_rank rk p) ->
  wf p'.
Proof.
intros Hwf Hin.
apply ℐᵃ_at_rank_incl_ℐᵃ in Hin.
eapply ℐᵃ_wf.
- eexact Hwf.
- assumption.
Qed.

(* Computes A_T, with a given maximal *)
Definition A_T (π: cbv) : nat :=
  maxl (map (fun p => length (ℐᵃ_at_rank (activation_rank rank p) p)) (ℐᵃ π)).

(* B_i, with i = rank *)
Definition ℐᵃ_at_rank_bound (A_T: nat) (rank: nat) :=
  Nat.pow max_rank (max_rank - rank) *
  Nat.pow (max 1 (max_nb_rhs_functions prog)) (max_rank - rank) *
  Nat.pow A_T (S (max_rank - rank)).

Definition gary_seven_poly (A_T:nat) :=
  suml (map (ℐᵃ_at_rank_bound A_T) (seq 0 (S max_rank))).

Lemma PPO_activation_rank_decreasing i s p c1 f lt c2 v:
  let π := cbv_update i s p c1 (fapply f lt) c2 v in
  PPO_prog ->
  wf π ->
  forall p, In p (ℐᵃ π) ->
  activation_rank rank p <= rank f.
Proof.
  intros π HPPO Hwf p' Hp'.
  assert (p' = π \/ PPO rank (proj_left p') (proj_left π)) as H by
         (eapply PPO_ℐᵃ; eauto).
  destruct H as [H | H].
  - rewrite H; trivial.

  - simpl in H.
    apply activation_is_function in Hp'.
    destruct Hp' as (x1 & x2 & x3 & x4 & t & x6 & v0 & Hp').
    rewrite Hp'.
    simpl.
    destruct t; try apply le_0_n.
    rewrite Hp' in H.
    simpl in H.
    subst p'.
    simpl in Hwf.
    decompose record Hwf.
    rewrite H3 in H.
    now apply PPO_activation_le_rank in H.
Qed.

Hint Resolve lt_0_pow.

Hint Rewrite mult_1_l.

Fixpoint first_activations_at_given_rank (rk: nat) (π : cbv) : list cbv :=
  match π with
  | cbv_constr lp _ _ _ _ => flat_map (first_activations_at_given_rank rk) lp
  | cbv_split lp p _ _ _ _ => first_activations_at_given_rank rk p ++ flat_map (first_activations_at_given_rank rk) lp
  | cbv_update _ _ p _ (fapply f _) _ _ as p' => if eq_nat_dec rk (rank f)
                                                then [ p' ]
                                                else first_activations_at_given_rank rk p
  | _ => [] (* cbv_read and ill-formed cbv_update *)
  end.

Definition activation_function (function_default : function) (p: cbv) :=
  match p with
    | cbv_update _ _ _ _ (fapply f _) _ _ => f
    | _                                   => function_default
  end.

Lemma first_activations_at_given_rank_rank rk p p' :
  In p' (first_activations_at_given_rank rk p) ->
  rk = activation_rank rank p'.
Proof.
  induction p using cbv_ind2; intro Hp'; simpl in *.
  - apply in_flat_map in Hp'.
    destruct Hp' as (p0 & Hp0in & Hp'in).
    apply H with p0; assumption.
  - apply in_app_iff in Hp'.
    rewrite in_flat_map in Hp'.
    destruct Hp' as [ Hin | (p0 & Hinp0 & Hfirst)].
    + tauto.
    + apply H with p0; assumption.
  - destruct t; try (inversion Hp').
    destruct (eq_nat_dec rk (rank f)).
    + destruct Hp'.
      * subst p'.
        assumption.
      * inversion H.
    + tauto.
  - tauto.
Qed.

Lemma first_activations_at_given_rank_sublist_ℐᵃ rk p :
  sublist (first_activations_at_given_rank rk p) (ℐᵃ p).
Proof.
induction p using cbv_ind2; simpl.
- apply sublist_flatmap_in_ext; assumption.
- apply sublist_app_compat.
  + assumption.
  + apply sublist_flatmap_in_ext; assumption.
- destruct t; try tauto; try (apply sublist_nil).
  case eq_nat_dec; intro Heq.
  + apply sublist_cons, sublist_nil.
  + apply sublist_skip. assumption.
- apply sublist_refl.
Qed.

Lemma NoDup_ℐᵃ i s p c1 t c2 v :
  PPO_prog ->
  wf (cbv_update i s p c1 t c2 v) ->
  NoDup (ℐᵃ (cbv_update i s p c1 t c2 v)).
Proof.
intros HPPO Hwf.
eapply NoDup_map_inv.
  apply NoDup_left_ℐᵃ; assumption.
Qed.

Lemma NoDup_first_activations_at_given_rank rk i s p c1 t c2 v :
  PPO_prog ->
  wf (cbv_update i s p c1 t c2 v) ->
  NoDup (first_activations_at_given_rank rk (cbv_update i s p c1 t c2 v)).
Proof.
intros.
eapply NoDup_sublist.
- apply first_activations_at_given_rank_sublist_ℐᵃ.

- apply NoDup_ℐᵃ; assumption.
Qed.

Lemma first_activations_at_given_rank_ℐᵃ rk p:
  incl (first_activations_at_given_rank rk p) (ℐᵃ p).
Proof.
  induction p using cbv_ind2; intros p' Hin; simpl in *.
  - apply in_flat_map in Hin.
    destruct Hin as (p0 & Hinp0 & Hfirst).
    apply in_flat_map.
    exists p0.
    split.
    + assumption.

    + apply H; assumption.

  - apply in_app_iff in Hin.
    rewrite in_flat_map in Hin.
    destruct Hin as [ Hin | (p0 & Hinp0 & Hfirst)].
    + auto with *.

    + apply in_app_iff.
      right.
      apply in_flat_map.
      exists p0.
      split.
      * assumption.

      * apply H; assumption.

  - destruct t; try inversion Hin.
    destruct (eq_nat_dec rk (rank f)).
    + subst.
      destruct Hin.
      * tauto.

      * inversion H.

    + right.
      auto.

  - assumption.
Qed.

Lemma A_T_activation_rank (p p' : cbv) :
  In p' (first_activations_at_given_rank (activation_rank rank p') p) ->
    length (ℐᵃ_at_rank (activation_rank rank p') p') <= A_T p.
Proof.
  intro Hin.
  unfold ℐᵃ_at_rank.
  unfold A_T.
  unfold ℐᵃ_at_rank.
  apply maxl_is_max.
  apply in_map_iff.
  exists p'.
  split.
  - trivial.
  - apply first_activations_at_given_rank_ℐᵃ in Hin.
    assumption.
Qed.

Lemma activation_eq_dec p i s p0 c1 t c2 v:
  let π := cbv_update i s p0 c1 t c2 v in
  PPO_prog ->
  wf π ->
  In p (ℐᵃ π) -> p = π \/ p <> π.
Proof.
intros π HPPO H1 H2.
unfold π in H2.
rewrite ℐᵃ_first_activations in H2.
simpl in H2.
destruct H2 as [ | H2]; [ subst; tauto | ].
right.
intro Heq.
apply NoDup_app_in_l with (l := [cbv_update i s p0 c1 t c2 v]) (l' := flat_map (ℐᵃ (constructor:=constructor)) (first_activations_rec p0)) (x := cbv_update i s p0 c1 t c2 v).
- simpl.
  erewrite <- ℐᵃ_first_activations.
  apply NoDup_ℐᵃ; assumption.

- auto with *.

- subst; assumption.
Qed.

Lemma ℐᵃ_trans p p' p'' : wf p'' ->
  In p (ℐᵃ p') -> In p' (ℐᵃ p'') -> In p (ℐᵃ p'').
Proof.
intros Hwf Hin1 Hin2.
generalize Hin1.
intro Hin1'.
apply activation_is_function in Hin1.
destruct Hin1 as (i & s & p0 & c1 & t & c2 & v & Heq).
apply cbv_update_in_ℐᵃ_InCBV with i s p0 c1 t c2 v; try tauto.
eapply InCBV_trans; apply ℐᵃ_inCBV; eauto.
Qed.

Lemma first_activation_down p i s p0 c1 t c2 v:
  let π := cbv_update i s p0 c1 t c2 v in
  PPO_prog ->
  wf π -> p <> π ->
  In p (ℐᵃ π) ->
  exists p', In p' (ℐᵃ π) /\ In p (first_activations p').
Proof.
intros π PPO_prog.
apply cbv_big_induction.
clear π i s c1 t c2 v.
intros.
rewrite ℐᵃ_first_activations in H2.
destruct H2 as [ | H2]; [ subst; tauto | ].
apply in_flat_map in H2.
destruct H2 as (p' & Hin1 & Hin2).
generalize Hin2.
intro Hin2'.
edestruct activation_is_function with (p:= p');
  [(apply first_activations_incl_ℐᵃ; exact Hin1) |] .
destruct H2 as (s' & p'0 & c1' & t' & c2' & v' & Heq).
subst p'.
assert (Hwf' : wf (cbv_update x s' p'0 c1' t' c2' v')) by
  (eapply wf_InCBV_wf; try eauto;
  apply ℐᵃ_inCBV;
  apply first_activations_incl_ℐᵃ;
  exact Hin1).
edestruct activation_eq_dec with (p:=p); eauto.
- exists (cbv_update i s p1 c1 t c2 v); simpl ℐᵃ.
  split; [auto with * | subst; assumption].

- generalize Hin1.
  intro Hin1'.
  apply H in Hin1'; try tauto.
  destruct Hin1' as (p'' & Hp'').
  exists p''.
  split.
  + eapply ℐᵃ_trans.
    * assumption.

    * destruct Hp''; eauto.

    * apply first_activations_incl_ℐᵃ; assumption.

  + tauto.
Qed.

Fixpoint FA_path p p' (lp : list cbv) := match lp with
 | [] => p = p'
 | h :: t => In p (first_activations h) /\ FA_path h p' t
end.

Lemma FA_path_app p p' p'' lp1 lp2 :
  FA_path p p' lp1 /\ FA_path p' p'' lp2 -> FA_path p p'' (lp1 ++ lp2).
Proof.
revert p p' p''.
induction lp1; simpl; intros p p' p'' (Heq & Hpath).
- subst; assumption.

- split; try tauto.
  eapply IHlp1 with p'.
  tauto.
Qed.

Lemma FA_path_right p p' p'' lp :
  FA_path p p' lp ->
  (In p' (first_activations p'') <->
   FA_path p p'' (lp ++ [p''])).
Proof.
revert p p' p''.
induction lp; intros p p' p'' Hpath; (split; [intro Hin | intro Hpath2]).
- simpl in *.
  subst p'.
  tauto.

- simpl in *.
  subst.
  tauto.

- simpl in *.
  split; intuition.
  apply IHlp with p'; assumption.

- simpl in *.
  rewrite <- IHlp with (p' := p') in Hpath2; tauto.
Qed.

Lemma FA_path_end p p' x lp : FA_path p p' (lp++[x]) -> x = p'.
Proof.
revert p p' x.
induction lp; intros p p' x Hpath.
- simpl in Hpath; tauto.

- simpl in Hpath.
  destruct Hpath as (Hin & Hpath).
  apply IHlp in Hpath.
  trivial.
Qed.

Lemma first_activations_at_given_rank_caract rk i s p0 c1 f l c2 v :
  let p := cbv_update i s p0 c1 (fapply f l) c2 v in
  first_activations_at_given_rank rk p =
  if eq_nat_dec rk (activation_rank rank p) then [p] else
    flat_map (first_activations_at_given_rank rk) (first_activations_rec p0).
Proof.
intros p.
unfold p; simpl.
induction p0 using cbv_ind2; simpl; case eq_nat_dec; intro Heq; try omega; trivial.
- apply comp_flat_map.
  intros p' Hp'.
  apply H in Hp'.
  case eq_nat_dec in Hp'; tauto.

- case eq_nat_dec in IHp0; try tauto.
  rewrite flat_map_app, IHp0.
  apply app_eq_compat_l.
  apply comp_flat_map.
  intros p' Hp';
  apply H in Hp'.
  case eq_nat_dec in Hp'; tauto.

- destruct t; try tauto.
  case eq_nat_dec; try tauto.
  intro HH; clear HH.
  auto with *.
Qed.

Lemma first_activations_at_given_rank_path p p' i s p0 c1 t c2 v :
  let π := cbv_update i s p0 c1 t c2 v in
  In p' (ℐᵃ π) ->
  In p (ℐᵃ p') ->
  exists lp, FA_path p p' lp.
Proof.
intro π.
revert p p'.
unfold π.
apply cbv_big_induction.
clear i s p0 c1 t c2 v π.
intros i s p0 c1 t c2 v Hind p' p'' Hp'' Hp'.
rewrite ℐᵃ_first_activations in Hp''.
destruct Hp'' as [Heq | Hin].
- subst.
  rewrite ℐᵃ_first_activations in Hp'.
  destruct Hp' as [Heq | Hin].
  + subst.
    exists []; simpl; trivial.

  + apply in_flat_map in Hin; destruct Hin as (p'' & Hp''1 & Hp''2).
     assert (Hlp : exists lp : list cbv, FA_path p' p'' lp).
     {
       eapply (Hind p'' Hp''1).
       apply first_activations_incl_ℐᵃ, activation_is_function in Hp''1.
       destruct Hp''1 as (a1 & a2 & a3 & a4 & a5 & a6 & a7 & H).
       subst; simpl;tauto.
       assumption.
     }
    destruct Hlp as (lp & Hlp).
    exists (lp ++ [cbv_update i s p0 c1 t c2 v]).
    apply FA_path_app with p''.
    split; [assumption | simpl; tauto].

- apply in_flat_map in Hin.
  destruct Hin as (p''' & Hp''1 & Hp''2).
  eapply Hind; eauto.
Qed.

Lemma FA_path_activation p p' i s p0 c1 t c2 v lp :
  let π := cbv_update i s p0 c1 t c2 v in
  wf π ->
  In p' (ℐᵃ π) ->
  FA_path p p' lp -> In p (ℐᵃ p').
Proof.
revert p p'.
induction lp; intros p p' π Hwf Ha Hpath.
- simpl in Hpath.
  subst.
  apply activation_is_function in Ha.
  destruct Ha as (ii & ss & pp & cc & tt & ccc & vv & Ha).
  subst; left; trivial.

- simpl in Hpath.
  apply ℐᵃ_trans with a.
  + eapply ℐᵃ_wf; eauto.

  + apply first_activations_incl_ℐᵃ; tauto.

  + apply IHlp; tauto.
Qed.

Lemma first_activations_strict p :
  PPO_prog ->
  wf p ->
 ~ p ∈ first_activations p.
Proof.
intros HPPO Hwf.
intro Hin.
generalize Hin; intro Hfa.
apply first_activations_incl_ℐᵃ, activation_is_function in Hfa.
destruct Hfa as (i & s & p0 & c1 & t & c2 & v & Heq); subst p.
apply NoDup_ℐᵃ in Hwf; try assumption.
rewrite ℐᵃ_first_activations in Hwf.
apply In_prefix_suffix in Hin.
destruct Hin as (l1 & l2 & H12).
rewrite H12 in Hwf; clear H12.
rewrite flat_map_app, app_comm_cons in Hwf.
simpl in Hwf.
rewrite app_comm_cons in Hwf.
apply NoDup_remove_2 in Hwf.
auto with *.
Qed.

Lemma first_activations_irrefl i s p0 c1 t c2 v p:
  PPO_prog ->
  wf (cbv_update i s p0 c1 t c2 v) ->
   (cbv_update i s p0 c1 t c2 v) ∈ ℐᵃ p ->
   ~ In p (first_activations  (cbv_update i s p0 c1 t c2 v)).
Proof.
intros PPO_prog.
revert p.
apply cbv_big_induction.
clear i s p0 c1 t c2 v.
intros i s p0 c1 t c2 v H p Hwf Ha Hfa.
assert (Hact : In p (ℐᵃ (cbv_update i s p0 c1 t c2 v)))
  by (apply first_activations_incl_ℐᵃ; assumption).
apply activation_is_function in Hact.
destruct Hact as (ii & ss & pp & cc1 & tt & cc2 & vv & Heq).
subst.
rewrite ℐᵃ_first_activations in Ha.
destruct Ha as [Heq | Hflat].
- rewrite Heq in Hfa; apply first_activations_strict in Hfa; assumption.

- apply in_flat_map in Hflat.
  destruct Hflat as (p' & Hin' & Ha').
  simpl in H.
  eapply H; try eauto.
  + apply ℐᵃ_wf with (cbv_update i s p0 c1 t c2 v).
     * assumption.

     * apply first_activations_incl_ℐᵃ; assumption.

  + eapply ℐᵃ_trans.
    * eapply ℐᵃ_wf; [apply Hwf|].
       apply ℐᵃ_trans with (cbv_update ii ss pp cc1 tt cc2 vv).
        assumption.

        apply first_activations_incl_ℐᵃ; assumption.

        apply first_activations_incl_ℐᵃ; assumption.

    * apply first_activations_incl_ℐᵃ.
      exact Hfa.

    * assumption.
Qed.

Lemma FA_path_refl p p' lp : PPO_prog -> wf p' -> FA_path p p' lp -> In p' (ℐᵃ p) -> lp = [].
Proof.
revert p p'.
induction lp; intros p p' PPO_prog Hwf Hpath Hin.
- trivial.

- simpl in Hpath.
  destruct Hpath as (Hfa & Hpath).
  assert (Hnil : lp = []).
  + eapply IHlp; eauto.
    eapply ℐᵃ_trans; [| exact Hin| apply first_activations_incl_ℐᵃ; assumption].
    apply ℐᵃ_wf with p'; try assumption.
    apply activation_is_function in Hin.
    destruct Hin as (i & s & p0 & c1 & t & c2 & v & Heq).
    subst p'.
    eapply FA_path_activation; [ exact Hwf| left; trivial| exact Hpath].

  + subst lp.
     simpl in Hpath.
     subst p'.
     contradict Hfa.
     generalize Hin; intro Heq.
     apply activation_is_function in Heq.
     destruct Heq as (i & s & p0 & c1 & t & c2 & v & Heq).
     subst a.
     apply first_activations_irrefl; assumption.
Qed.

Lemma FA_path_app_destruct p p' lp1 lp2 : FA_path p p' (lp1 ++ lp2) ->
  exists p'', FA_path p p'' lp1 /\ FA_path p'' p' lp2.
Proof.
revert p lp2.
induction lp1; intros p lp2 Hpath.
- exists p; simpl in *; auto.

- destruct Hpath as (Hfa & Hpath).
  apply IHlp1 in Hpath.
  destruct Hpath as (p'' & Hp''1 & Hp''2).
  exists p''.
  split; simpl; auto.
Qed.

Lemma FA_path_uniqueness p i s p0 c1 t c2 v lp1 lp2 : PPO_prog ->
  let p' := (cbv_update i s p0 c1 t c2 v) in
  wf p' ->
  FA_path p p' lp1 -> FA_path p p' lp2 -> lp1 = lp2.
Proof.
revert p i s p0 c1 t c2 v lp2.
induction lp1 using rev_ind; intros p i s p0 c1 t c2 v lp2 HPPO p' Hwf Hpath1 Hpath2.
- simpl in Hpath1; subst.
  destruct lp2.
  + trivial.

  + destruct Hpath2 as (Hin & Hpath2).
    destruct lp2 using rev_ind.
    * intros; simpl in Hpath2; subst c.
       contradict Hin.
       apply first_activations_strict; assumption.

    * assert( Hwfc : wf c). {
         eapply ℐᵃ_wf; [eauto|].
         eapply FA_path_activation; eauto; left; trivial.
      }
       assert (In c (ℐᵃ c)). {
        eapply FA_path_activation, activation_is_function in Hpath2; try left; eauto.
        destruct Hpath2 as (i' & s' & p0' & c1' & t' & c2' & v' & Heq'); subst c.
        left; trivial.
      }
       eapply FA_path_right with (p'' := c) in Hin; eauto.
       apply FA_path_refl in Hin; try assumption.
       assert (H0 : length((lp2 ++ [x]) ++ [c]) = 0) by (rewrite Hin; trivial).
       do 2 rewrite app_length in H0.
       simpl in H0.
       omega.

- assert (Heqx : x = p') by (eapply FA_path_end; eauto).
  subst x.
  revert p Hwf Hpath2 Hpath1.
  destruct lp2 using rev_ind; intros p Hwf Hpath2 Hpath.
  + simpl in Hpath2; subst.
    eapply FA_path_refl; eauto.
    subst p'; left; trivial.

  + assert (Heqx : x = p') by (eapply FA_path_end; eauto).
    subst x.
    apply FA_path_app_destruct in Hpath.
    apply FA_path_app_destruct in Hpath2.
    destruct Hpath as (p1 & Hp1 & Hp1').
    destruct Hpath2 as (p2 & Hp2 & Hp2').
    replace lp1 with lp2; trivial.
    symmetry.
    destruct Hp1' as (Hp1' & _).
    destruct Hp2' as (Hp2' & _).
    pose (H := In_In_list_decompose p1 p2 _ Hp1' Hp2').
    destruct H as [Heq | (l1 & l2 & l3 & [Hl | Hl])].
    * subst p1.
      generalize Hp1'; intro Heq.
      apply first_activations_incl_ℐᵃ, activation_is_function in Heq.
      destruct Heq as  (i' & s' & p0' & c1' & t' & c2' & v' & Heq'); subst p2.
       eapply (IHlp1 p _); [trivial |
                            apply ℐᵃ_wf with p', first_activations_incl_ℐᵃ; trivial|
                            eauto |
                            eauto ]; trivial.
    * assert (H : NoDup (ℐᵃ p')) by (apply NoDup_ℐᵃ; subst p'; trivial).
       subst p'.
       rewrite ℐᵃ_first_activations in H.
       rewrite Hl in H.
       repeat (rewrite flat_map_app in H; simpl in H).
       eapply FA_path_activation in Hp1; [ | exact Hwf | apply first_activations_incl_ℐᵃ; trivial].
       eapply FA_path_activation in Hp2; [ | exact Hwf | apply first_activations_incl_ℐᵃ; trivial].
       apply in_split in Hp1; apply in_split in Hp2.
       destruct Hp1 as (ll1 & ll1' & Hll1).
       destruct Hp2 as (ll2 & ll2' & Hll2).
       rewrite Hll1, Hll2 in H.
       replace ((cbv_update i s p0 c1 t c2 v :: flat_map (ℐᵃ (constructor:=constructor)) l1 ++
          (ll1 ++ p :: ll1') ++ flat_map (ℐᵃ (constructor:=constructor)) l2 ++
          (ll2 ++ p :: ll2') ++ flat_map (ℐᵃ (constructor:=constructor)) l3)) with
          ((cbv_update i s p0 c1 t c2 v :: flat_map (ℐᵃ (constructor:=constructor)) l1 ++
          (ll1 ++ p :: ll1')) ++
          (flat_map (ℐᵃ (constructor:=constructor)) l2 ++
          (ll2 ++ p :: ll2') ++ flat_map (ℐᵃ (constructor:=constructor)) l3)) in H by
          (repeat rewrite app_assoc; trivial).
       eapply NoDup_app_in_l with (x := p) in H; [contradict H | right];
              repeat rewrite in_app_iff; auto with *.

    * assert (H : NoDup (ℐᵃ p')) by (apply NoDup_ℐᵃ; subst p'; trivial).
       subst p'.
       rewrite ℐᵃ_first_activations in H.
       rewrite Hl in H.
       repeat (rewrite flat_map_app in H; simpl in H).
       eapply FA_path_activation in Hp1; [ | exact Hwf | apply first_activations_incl_ℐᵃ; trivial].
       eapply FA_path_activation in Hp2; [ | exact Hwf | apply first_activations_incl_ℐᵃ; trivial].
       apply in_split in Hp1; apply in_split in Hp2.
       destruct Hp1 as (ll1 & ll1' & Hll1).
       destruct Hp2 as (ll2 & ll2' & Hll2).
       rewrite Hll1, Hll2 in H.
       replace ((cbv_update i s p0 c1 t c2 v :: flat_map (ℐᵃ (constructor:=constructor)) l1 ++
          (ll2 ++ p :: ll2') ++ flat_map (ℐᵃ (constructor:=constructor)) l2 ++
          (ll1 ++ p :: ll1') ++ flat_map (ℐᵃ (constructor:=constructor)) l3)) with
          ((cbv_update i s p0 c1 t c2 v :: flat_map (ℐᵃ (constructor:=constructor)) l1 ++
          (ll2 ++ p :: ll2')) ++
          (flat_map (ℐᵃ (constructor:=constructor)) l2 ++
          (ll1 ++ p :: ll1') ++ flat_map (ℐᵃ (constructor:=constructor)) l3)) in H by
          (repeat rewrite app_assoc; trivial).
       eapply NoDup_app_in_l with (x := p) in H; [contradict H | right];
              repeat rewrite in_app_iff; auto with *.
Qed.

Lemma ℐᵃ_strict i s p0 c1 t c2 v :
  wf (cbv_update i s p0 c1 t c2 v) ->
  ~ cbv_update i s p0 c1 t c2 v ∈ ℐᵃ p0.
Proof.
intros Hwf Hin.
assert (size_rec (cbv_update i s p0 c1 t c2 v) <= size_rec p0).
  apply ℐ_size_rec_le.
  apply ℐᵃ_are_subtrees; assumption.
destruct t; simpl in H; omega.
Qed.

Lemma first_activation_down_rank_lt p p' i s p0 c1 t c2 v:
  let π := cbv_update i s p0 c1 t c2 v in
  PPO_prog ->
  wf π ->
  In p' (ℐᵃ π) -> In p (first_activations p') ->
  In p (first_activations_at_given_rank (activation_rank rank p) π) ->
  activation_rank rank p < activation_rank rank p'.
Proof.
intros π HPPO.
unfold π in *.
revert p p'.
apply cbv_big_induction.
clear i s p0 c1 t c2 v π.
intros i s p0 c1 t c2 v H p p'.
intros Hwf Ha Hfa Hfagr.
destruct t; try tauto; try inversion Hfagr.
rewrite first_activations_at_given_rank_caract in Hfagr.
destruct eq_nat_dec as [Heq | Hneq] in Hfagr.
- simpl in Hfagr; destruct Hfagr ; try tauto.
  subst p.
  clear Heq.
  rewrite ℐᵃ_first_activations in Ha.
  destruct Ha as [Hroot | Htail].
  +  subst p'.
     contradict Hfa.
     apply first_activations_strict; assumption.

  +  apply in_flat_map in Htail.
     destruct Htail as (p'' & Hin'' & Hp'').
     apply first_activations_irrefl in Hin''; try tauto.
     apply ℐᵃ_trans with p'; try assumption.
     * eapply ℐᵃ_wf; [exact Hwf|].
        apply first_activations_incl_ℐᵃ; assumption.

     * apply first_activations_incl_ℐᵃ; assumption.

- destruct Ha as [Heqp' | Hneqp'].
  + subst p'.
    simpl in Hfa.
    simpl.
    assert (activation_rank rank p <= rank f).
    * eapply PPO_activation_rank_decreasing; eauto.
       apply first_activations_incl_ℐᵃ.
       assumption.

    * simpl in Hneq.
       omega.

  + apply in_flat_map in Hfagr.
     destruct Hfagr as (p'' & Hin'' & Hp'').
     simpl in H.
     apply H with p''; try tauto.
     * eapply ℐᵃ_wf; [exact Hwf |].
        apply first_activations_incl_ℐᵃ.
        assumption.

     * apply first_activations_at_given_rank_ℐᵃ in Hp''.
        generalize Hp''; intro Hpp''.
        eapply (first_activations_at_given_rank_path _ _ i s p0 c1 (fapply f l) c2 v)  in Hp'';
          [| apply first_activations_incl_ℐᵃ; simpl; assumption].
        destruct Hp'' as (lp1 & Hpath1).
        assert( Hpath2 :FA_path p (cbv_update i s p0 c1 (fapply f l) c2 v) (lp1 ++ [(cbv_update i s p0 c1 (fapply f l) c2 v)] )) by (apply FA_path_right with p''; assumption).

        assert (Hpath3 : In p' (ℐᵃ (cbv_update i s p0 c1 (fapply f l) c2 v))) by (right; assumption).
        eapply first_activations_at_given_rank_path in  Hpath3;  [| left; trivial].
        destruct Hpath3 as (lp2 & Hlp2).
        assert(Hpath4 : FA_path p (cbv_update i s p0 c1 (fapply f l) c2 v) (p' :: lp2)) by (simpl; tauto).

        assert (Heq : lp1 ++ [cbv_update i s p0 c1 (fapply f l) c2 v]= p' :: lp2) by
          (eapply FA_path_uniqueness; eauto).
        {
          destruct lp1; destruct lp2; simpl in Heq; try tauto.
          - inversion Heq; subst.
              contradict Hneqp'.
              apply ℐᵃ_strict; assumption.

          - inversion Heq.

          - destruct lp1; inversion Heq.

          - inversion Heq; subst.
              eapply FA_path_activation with (lp := lp1) ; [exact Hwf | | simpl in *; tauto].
              apply first_activations_incl_ℐᵃ; assumption.
        }
Qed.

Lemma first_activations_at_given_rank_lt_previous i s p c1 t c2 v p':
  let π := cbv_update i s p c1 t c2 v in
  PPO_prog ->
  wf π ->
  In p' (first_activations_at_given_rank (activation_rank rank p') π) ->
  activation_rank rank p' < activation_rank rank π ->
  exists p'', In p'' (ℐᵃ π) /\
         In p' (first_activations p'') /\
         activation_rank rank p' < activation_rank rank p''.
Proof.
intros π HPPO Hwf Hp' Hlt.
destruct (first_activation_down p' i s p c1 t c2 v) as (p'' & H); trivial.

- contradict Hlt.
  subst.
  simpl; omega.

- apply first_activations_at_given_rank_ℐᵃ in Hp'.
  assumption.

- exists p''.
  repeat split; try tauto.
  unfold π in Hwf.
  eapply first_activation_down_rank_lt with i s p c1 t c2 v; try tauto.
Qed.

Lemma length_fapplies_le_functions s t : length (fapplies_in_term (@subst variable function constructor s t)) <= length (functions_of_term t).
Proof.
induction t using term_ind2; simpl.
 - rewrite fapplies_in_value_nil.
   trivial.

  - do 2 rewrite length_flat_map.
    repeat rewrite map_map.
    apply suml_map_le.
    intros x Hx.
    apply H; assumption.

  - apply le_n_S.
    do 2 rewrite length_flat_map.
    repeat rewrite map_map.
    apply suml_map_le.
    intros x Hx.
    apply H; assumption.
Qed.

Lemma first_activations_length_le_first_and_semi_ℐᵃ n s p c1 f l c2 v : length (first_activations (cbv_update n s p c1 (@fapply variable function constructor f l) c2 v)) <=
length (first_activations_and_semi (cbv_update n s p c1 (fapply f l) c2 v)).
Proof.
simpl.
induction p using cbv_ind2; simpl.
- do 2 rewrite length_flat_map.
  repeat rewrite map_map.
  apply suml_map_le.
  apply H.

- do 2 rewrite app_length.
  apply plus_le_compat.
  + assumption.

  + do 2 rewrite length_flat_map.
    repeat rewrite map_map.
    apply suml_map_le.
    apply H.

- trivial.

- apply le_S, le_n.
Qed.

Lemma degree_bounded p :
  wf p -> length (first_activations p) <= max_nb_rhs_functions prog.
Proof.
  intro Wfp.
  assert( H : forall p0 : cbv,
  InCBV p0 p -> length (first_activations p0) <= max_nb_rhs_functions prog);
  [| apply H; apply InCBV_refl].
  induction p using cbv_ind2; intros p0 Hin; simpl in Hin.
  - destruct Hin as [Heq | Hneq].
    + subst p0; apply le_0_n.

    + apply orl_map in Hneq.
      destruct Hneq as (p' & Hp'  & Hin').
      apply H in Hin'; try assumption.
      simpl in Wfp.
      destruct t; try tauto; destruct v; try tauto.
      destruct Wfp as (_ & _ & _ & _ & Hwf & _).
      apply andl_in_map with lp; assumption.

  - destruct Hin as [Heq | [Hin | Hor]].
    + subst p0; apply le_0_n.

    + apply IHp.
      * simpl in Wfp.
            repeat match goal with
        | _ : match ?x with _ => _ end |- _ => destruct x; try tauto
      end.

      * assumption.

    + apply orl_map in Hor.
      destruct Hor as (p' & Hp'1 & Hp'2).
      apply H with p'; try assumption.
      simpl in Wfp.
            repeat match goal with
        | _ : match ?x with _ => _ end |- _ => destruct x; try tauto
      end; destruct Wfp as (_ & _ & _ & _ & Hwf & _); apply andl_in_map with lp; assumption.

  - destruct Hin as [Heq | Hneq].
    + subst p0.
      assert (Hres := Wfp).
      eapply first_activations_residues_activation in Hres; eauto.
      simpl in Wfp.
      repeat match goal with
        | _ : match ?x with _ => _ end |- _ => destruct x; try tauto
      end.
      destruct Wfp as (_ & lp & t & Hn & Hrule & Hl & Ht & Hrem).
      transitivity (nb_rhs_functions (rule_intro f lp t)).
      * apply Forall2_length in Hres.
        rewrite Ht in Hres.
        simpl in Hres.
        { transitivity (length (fapplies_in_term (subst s t))).
          - rewrite <- Hres.
            replace (first_activations_and_semi_rec p) with (first_activations_and_semi (cbv_update n s p c1 (fapply f l) c2 v)) by trivial.
            apply first_activations_length_le_first_and_semi_ℐᵃ.

          - apply length_fapplies_le_functions.
        }

      * unfold max_nb_rhs_functions.
        apply maxl_is_max.
        apply in_map_iff.
        exists (rule_intro f lp t).
        split; try trivial.
        rewrite <- Hrule.
        apply nth_In.
        assumption.

    + apply IHp.
      * simpl in Wfp.
        repeat match goal with
         | _ : match ?x with _ => _ end |- _ => destruct x; try tauto
        end.
        decompose record Wfp.
        assumption.

      * assumption.

  - destruct Hin as [Heq | Hneq].
    + subst p0; apply le_0_n.

    + tauto.
Qed.

Lemma split_ℐᵃ_by_first_activations_at_rank rk p :
  wf p ->
  ℐᵃ_at_rank rk p = flat_map (ℐᵃ_at_rank rk) (first_activations_at_given_rank rk p).
Proof.
intro Hwf.
unfold ℐᵃ_at_rank.
induction p as [ lp c1 t c2 v IHlp | lp p' c1 t c2 v IHlp IHp | i s p' c1 t c2 v IHp | c t v ]
 using cbv_ind2; simpl; trivial.

- etransitivity.

  + rewrite filter_flat_map.
    apply flat_map_in_ext.
    intros p Hp.
    apply IHlp; trivial.
    apply wf_InCBV_wf with (π := cbv_constr lp c1 t c2 v); trivial.
    simpl.
    right.
    apply orl_map.
    exists p.
    split; trivial.
    apply InCBV_refl.

  + clear IHlp Hwf.
    induction lp as [ | p lp IH ]; trivial.
    simpl.
    rewrite IH.
    symmetry; apply flat_map_app.

- etransitivity.

  + rewrite filter_app, filter_flat_map.
    apply app_eq_compat_l.
    apply flat_map_in_ext.
    intros p Hp.
    apply IHlp; trivial.
    apply wf_InCBV_wf with (π := cbv_split lp p' c1 t c2 v); trivial.
    simpl.
    right.
    right.
    apply orl_map.
    exists p.
    split; trivial.
    apply InCBV_refl.

  + rewrite IHp.

    * clear IHlp IHp Hwf.
      rewrite flat_map_app.
      induction lp as [ | p lp IH ]; trivial.
      simpl.
      rewrite flat_map_app.
      apply app_insert_r; [ exact IH | ].
      do 2 rewrite length_flat_map.
      clear.
      induction lp as [ | p lp IH]; trivial.
      simpl.
      rewrite IH.
      do 2 rewrite map_app.
      rewrite length_flat_map, suml_app.
      trivial.

    * apply wf_InCBV_wf with (π := cbv_split lp p' c1 t c2 v); trivial.
      simpl.
      right.
      left.
      apply InCBV_refl.

- destruct t as [ | | f lv ]; try (simpl in Hwf; tauto).
  destruct (eq_nat_dec rk (rank f)) as [ Heq | Hneq ].

  + simpl.
    apply app_nil_end.

  + case_eq (beq_nat rk (rank f)).

    * intro Heq.
      contradict Hneq.
      apply beq_nat_true; assumption.

    * intros _.
      apply IHp.
      apply wf_InCBV_wf with (π := cbv_update i s p' c1 (fapply f lv) c2 v); trivial.
      simpl.
      right.
      apply InCBV_refl.
Qed.

Lemma notin_nil (A: Type) (xs: list A):
  (forall x, ~ In x xs) -> [] = xs.
Proof.
 intro Hnin.
 destruct xs.
 - trivial.

 - elim (Hnin a).
   apply in_eq.
Qed.

Lemma ℐᵃ_at_rank_activation_rank π p:
  In p (ℐᵃ π) ->
  In p (ℐᵃ_at_rank (activation_rank rank p) π).
Proof.
unfold ℐᵃ_at_rank.
induction (ℐᵃ π) as [ | p' lp IH]; trivial.
simpl.
intros [ H | H ].

- subst p'.
  rewrite <- beq_nat_refl.
  simpl.
  tauto.

- case_eq (beq_nat (activation_rank rank p) (activation_rank rank p')); simpl; tauto.
Qed.

Lemma first_activations_at_given_rank_incl i s p c1 t c2 v r :
  let π := cbv_update i s p c1 t c2 v in
  PPO_prog ->
  wf π ->
  r < activation_rank rank π ->
  incl (first_activations_at_given_rank r π)
       (flat_map (@first_activations _ _ _)
                 (flat_map (fun r' => ℐᵃ_at_rank r' π)
                           (seq (1 + r) (max_rank - r)))).
Proof.
intros π PPO_prog Hwf Hlt p' Hp'.
assert (Hr: r = activation_rank rank p').
{
  eapply first_activations_at_given_rank_rank.
  eexact Hp'.
}
subst r.
apply first_activations_at_given_rank_lt_previous in Hp'; trivial.
destruct Hp' as (p'' & Hp'' & Hp' & Hlt').
apply in_flat_map.
exists p''.
split; trivial.
apply in_flat_map.
exists (activation_rank rank p'').
split.

- apply in_seq.
  split; trivial.
  assert (Hrank: activation_rank rank p'' < S max_rank).
  {
    apply activation_is_function in Hp''.
    destruct Hp'' as (i' & s' & p''' & c1' & t' & c2' & v' & Hp'').
    subst p''.
    simpl.
    destruct t'; auto with *.
  }
  omega.

- apply ℐᵃ_at_rank_activation_rank; trivial.
Qed.

Definition compatible_rule (r:rule) : Prop :=
  match r with
    | rule_intro f _ t => forall f', In f' (functions_of_term t) -> rank f' <= rank f
  end.

Definition compatible_prog : Prop :=
  forall r, In r prog -> compatible_rule r.

Lemma PPO_is_compatible_rule:
  forall r, PPO_rule rank r -> compatible_rule r.
Proof.
intros [f l t]; simpl.
induction t using term_ind2; intros HPPO g Hg; simpl in Hg.
- inversion HPPO; subst; inversion Hg.

- apply in_flat_map in Hg; destruct Hg as (t0 & Hin0 & Hg).
  apply H with t0; trivial.
  apply PPO_trans with (capply c l0); trivial.
  now apply ppo_constr_in.

- destruct Hg as [Heq| Hin].
  + subst.
    now apply PPO_pattern_le_rank in HPPO.

  + apply in_flat_map in Hin; destruct Hin as (t0 & Hin0 & Hg).
    apply H with t0; trivial.
    apply PPO_trans with (fapply f0 l0); trivial.
    now apply ppo_fun_in.
Qed.

Lemma PPO_is_compatible_prog:
  PPO_prog -> compatible_prog.
Proof.
unfold PPO_prog;unfold compatible_prog.
intros.
apply PPO_is_compatible_rule;auto.
Qed.

Lemma gary_seven i s p c1 f lt c2 v:
  let π := cbv_update i s p c1 (fapply f lt) c2 v in
  compatible_prog ->
  wf π ->
  PPO_prog ->
  𝓐 π <= gary_seven_poly (A_T π).
Proof.
intros π Hcompat Hwf Hppoprog.
assert (H :
  forall r, r <= max_rank ->
  length(ℐᵃ_at_rank r π) <=
  ℐᵃ_at_rank_bound (A_T π) r
). {
  intro r.
  remember (max_rank - r) as n.
  revert i s p c1 f lt c2 v π Hwf r Heqn.
  induction n as [ n IH ] using lt_wf_ind; intros i s p c1 f lt c2 v π Hwf r Heqn Hr.
  case(eq_nat_dec r (activation_rank rank π)) as [Heq | Hneq].
  - transitivity (A_T π).
    + subst r.
      apply A_T_activation_rank.
      simpl.
      destruct (eq_nat_dec (rank f) (rank f)) as [Heq | Hneq];
      [ apply in_eq | tauto].

    + unfold ℐᵃ_at_rank_bound.
      transitivity (A_T π ^ S (max_rank - r)).
      * simpl.
        case (eq_nat_dec 0 (A_T π)).
          intro He; rewrite <- He.
          trivial.

          intro Hneq.
          rewrite <- (mult_1_r (A_T π)) at 1.
          apply mult_le_compat_l.
          destruct (A_T π); try tauto.
          simpl.
          apply lt_0_pow; omega.

      * rewrite <- mult_1_l at 1.
        apply mult_le_compat_r.
        rewrite <- mult_1_l at 1.
        apply mult_le_compat; auto using (pos_max_rank) with * .

  - destruct (lt_eq_lt_dec r (activation_rank rank π)) as [ [ Hlt | Heq ] | Hgt ].

    + clear Hneq.
      fold (ℐᵃ_at_rank r π).
      rewrite split_ℐᵃ_by_first_activations_at_rank; [ | trivial ].
      rewrite length_flat_map.
      rewrite map_map.
      transitivity (length (map (fun x => length (ℐᵃ_at_rank r x)) (first_activations_at_given_rank r π)) * A_T π).

      * apply suml_le_len_times_bound.
        intros x Hin.
        apply in_map_iff in Hin.
        destruct Hin as ( p' & Heq & Hin ).
        subst x.
        assert( Hreq : r = activation_rank rank p') by
        (apply first_activations_at_given_rank_rank with π; assumption).
        subst r.
        apply A_T_activation_rank.
        assumption.

      * unfold ℐᵃ_at_rank_bound.
        simpl Nat.pow at 3.
        ring_simplify.
        rewrite mult_comm.
        repeat rewrite <- mult_assoc.
        apply mult_le_compat_l.
        rewrite map_length.
        { etransitivity; [
            eapply NoDup_incl_le_length; [
              apply NoDup_first_activations_at_given_rank; assumption | ] |].

          - apply first_activations_at_given_rank_incl; assumption.

          - rewrite length_flat_map, map_map.
            etransitivity.

            + apply suml_le_len_times_bound.
               intros len Hin.
               apply in_map_iff in Hin.
               destruct Hin as ( p' & Heq & Hin ).
               subst len.
               apply degree_bounded.
               apply in_flat_map in Hin.
               destruct Hin as ( r' & _ & Hin ).
               apply ℐᵃ_at_rank_wf with (rk := r') (p := π);
               assumption.

            + rewrite map_length, length_flat_map, map_map.
              fold π.
              transitivity (suml
                              (map (fun x : nat => ℐᵃ_at_rank_bound (A_T π) x)
                                   (seq (1 + r) (max_rank - r))) * max_nb_rhs_functions prog).

              * apply mult_le_compat_r.
                apply suml_map_le.
                intros r' Hin.
                apply in_seq in Hin; destruct Hin as ( Hltr & Hler ).
                assert ( Hle_max: r < max_rank ).
                { apply lt_le_trans with (m := activation_rank rank π); simpl; trivial. }
                apply IH with (m := max_rank - r'); trivial; omega.

              * unfold ℐᵃ_at_rank_bound.
                assert (H_A_T: A_T π <> 0).
                {
                  unfold A_T.
                  apply all_maxl; [simpl; congruence | ].
                  intros r0 Hr0.
                  apply in_map_iff in Hr0.
                  destruct Hr0 as (p' & Hp'1 & Hp'2).
                  subst r0.
                  apply activation_is_function in Hp'2.
                  destruct Hp'2 as (i' & s' & p'' & c1' & t & c2' & v' & Hp'2).
                  subst p'.
                  simpl.
                  destruct t as [ | | f' lv]; simpl; try congruence.
                  unfold ℐᵃ_at_rank.
                  simpl.
                  rewrite <- beq_nat_refl.
                  simpl.
                  congruence.
                }
                { transitivity (suml
                                  (map
                                     (fun x : nat =>
                                        Nat.pow max_rank (max_rank - (1+r)) *
                                        Nat.pow (max 1 (max_nb_rhs_functions prog)) (max_rank - (1+r)) *
                                        Nat.pow (A_T π) (max_rank - r))
                                     (seq (1 + r) (max_rank - r))) * max_nb_rhs_functions prog).
                  - apply mult_le_compat_r.
                    apply suml_map_le.
                    intros r' Hin.
                    apply in_seq in Hin as ( Hler & Hltr ).
                    apply mult_le_compat; [ apply mult_le_compat | ].

                    + apply Nat.pow_le_mono_r; omega.
                    + apply Nat.pow_le_mono_r; [ lia | omega].
                    + apply Nat.pow_le_mono_r; [trivial | omega].

                  - rewrite suml_map_const, seq_length.
                    replace (Nat.pow max_rank (max_rank - (1 + r)) *
                             Nat.pow (max 1 (max_nb_rhs_functions prog)) (max_rank - (1 + r)) *
                             Nat.pow (A_T π) (max_rank - r) *
                             (max_rank - r) * max_nb_rhs_functions prog)
                            with
                            ((Nat.pow max_rank (max_rank - (1 + r)) * (max_rank - r))
                             * ((Nat.pow (max 1 (max_nb_rhs_functions prog)) (max_rank - (1 + r)) * max_nb_rhs_functions prog)
                                * Nat.pow (A_T π) (max_rank - r)));
                      [ | ring ].
                    apply mult_le_compat; [ | apply mult_le_compat ]; trivial.

                    + apply Nat.le_lteq in Hr.
                      destruct Hr as [ Hr | Hr ]; [ | nia].
                      apply Nat.le_lteq in Hr.
                      destruct Hr as [ Hr | Hr ].

                      * transitivity (Nat.pow max_rank (S (max_rank - (1 + r)))); [ simpl; nia | ].
                        apply Nat.pow_le_mono_r; omega.

                      * simpl.
                        rewrite <- Hr, minus_diag.
                        replace (S r - r) with 1 by omega.
                        simpl; omega.

                    + destruct (O_or_S (max_nb_rhs_functions prog)) as [ H | H ]; [ | nia ].
                      destruct H as [m Hm].
                      rewrite <- Hm.
                      simpl.
                      apply Nat.le_lteq in Hr.
                      destruct Hr as [ Hr | Hr ].
                      * apply Nat.le_lteq in Hr.
                        {destruct Hr as [ Hr | Hr ].
                        - rewrite mult_comm, <- Nat.pow_succ_r; [ | omega].
                          apply Nat.pow_le_mono_r; [congruence | omega].

                        - subst max_rank.
                          rewrite minus_diag.
                          replace (S r - r) with 1 by omega.
                          simpl; omega.
                        }

                      * subst r.
                        change (activation_rank rank π) with (rank f) in Hlt.
                        contradict Hlt.
                        apply le_not_lt.
                        apply max_rank_is_max_rank.
            }
        }

    + contradiction.

    + replace (ℐᵃ_at_rank r π) with ([]: list cbv);
      [ apply le_0_n | ].
      apply notin_nil.
      intros r' Hin.
      unfold ℐᵃ_at_rank in Hin.
      apply filter_In in Hin.
      destruct Hin as [ Hin Heq ].
      apply beq_nat_true_iff in Heq; subst r.
      apply PPO_activation_rank_decreasing in Hin; try trivial.
      change (rank f) with (activation_rank rank π) in Hin.
      omega.
}
unfold 𝓐.
replace (length(ℐᵃ π)) with
  (suml (map (fun r => length(ℐᵃ_at_rank r π)) (seq 0 (S max_rank)))).
- unfold gary_seven_poly.
  apply suml_map_le.
  intros r Hr.
  rewrite In_seq in Hr.
  auto with *.

- unfold ℐᵃ_at_rank.
  transitivity (
    suml (map
     (fun r : nat => length (filter (beq_nat r) (map (activation_rank rank) (ℐᵃ π))))
     (seq 0 (S max_rank)))
  ). {
    do 2 f_equal.
    extensionality r.
    apply length_filter.
  }
  rewrite <- map_length with (f := activation_rank rank).
  apply length_suml_filter.
  intros x Hinx.
  split; [ apply le_0_n | ].
  apply in_map_iff in Hinx.
  destruct Hinx as (p0 & Hrank & Hin).
  subst x.
  apply activation_is_function in Hin.
  destruct Hin as (ii & ss & pp & cc & tt & ccc & vv & Heq).
  subst p0.
  simpl.
  destruct tt; auto with *.
Qed.

(* Proposition 8 *)

Lemma all_functions_in_prog (function_default : function) (π: cbv) :
  wf π ->
  forall p, In p (ℐᵃ π) ->
       In (activation_function function_default p) (functions_of_prog prog).
Proof.
  induction π using cbv_ind2; intros Hwf p Hp.
    - simpl in Hp. apply in_flat_map in Hp.
      destruct Hp as [y [Hy Hp]].
      apply H with y; try auto.
      eapply wf_InCBV_wf.
      + eauto.
      + right; apply orl_map; eauto.
         exists y; split; trivial.
         apply InCBV_refl.

    - assert (wf π);[eapply wf_InCBV_wf; [eauto |  right; left; apply InCBV_refl]|].
       apply in_app_or in Hp; destruct Hp.
        + auto.

        + simpl in H1. apply in_flat_map in H1.
          destruct H1 as [y [Hy Hp]].
          apply H with y; try auto.
          eapply wf_InCBV_wf.
          * apply Hwf.
          * right; right; apply orl_map; eauto using InCBV_refl.

    - assert (wf π);[eapply wf_InCBV_wf; [ apply Hwf | right; auto using InCBV_refl]|].
      destruct Hp.
      + rewrite <- H0 in *.
        destruct t; intros.
        * inversion Hwf.

        * inversion Hwf.

        * destruct Hwf as [_ [ll [t [Hlen [Hin _]]]]].
          apply in_map_iff.
          exists (rule_intro f ll t).
          split.
            auto.

            rewrite <- Hin.
            apply nth_In; trivial.

      + auto.

    - inversion Hp.
Qed.

(* Links between PPO and sub-term *)

Fixpoint sub_terms (t: term) : list term :=
  t :: match t with
         | var _ => []
         | capply _ lt => flat_map sub_terms lt
         | fapply _ lt => flat_map sub_terms lt
       end.

Definition sub_terms_strict (t: term) : list term :=
  match t with
    | var _ => []
    | capply _ lt => flat_map sub_terms lt
    | fapply _ lt => flat_map sub_terms lt
  end.

Lemma sub_term_strict_incl (t: term) :
  incl (sub_terms_strict t) (sub_terms t).
Proof.
  destruct t;
    simpl;
    intros t' Hin;
    apply in_cons;
    assumption.
Qed.

Lemma sub_term_eq_or_strict (t1 t2: term) :
  In t1 (sub_terms t2) <-> t1 = t2 \/ In t1 (sub_terms_strict t2).
Proof.
  split.

  - (* -> *)
    intros Hin.
    destruct t2 as [ v | c lt | f lt ];
      simpl in *;
      ( destruct Hin;
        [left; symmetry | right ];
        assumption ).

  - (* <- *)
    intros H; destruct H as [ Heq | Hin ].

    + subst t2; destruct t1; simpl; left; trivial.

    + apply sub_term_strict_incl; assumption.
Qed.

Lemma sub_term_le_size (t1 t2: term) :
  In t1 (sub_terms t2) -> t2 = t1 \/ term_size t1 < term_size t2.
Proof.
  clear.
  revert t1;
  induction t2 as [ v2 | c2 lt2 IH | f2 lt2 IH ]  using term_ind2;
  intros t1 Hin;
  simpl in Hin.

  - destruct Hin as [ Heq | Hin ]; tauto.

  - destruct Hin as [ Heq | Hin ]; [ tauto | idtac ].
    right.
    apply in_flat_map in Hin.
    destruct Hin as ( t & Hinlt2 & Hint1 ).
    apply le_lt_trans with (m := term_size t).
    + destruct (IH t Hinlt2 t1 Hint1) as [ Heq | Hlt ].
      * subst t; apply le_refl.
      * apply lt_le_weak; assumption.
    + simpl.
      apply le_lt_n_Sm.
      apply in_le_suml.
      apply in_map.
      assumption.

  - destruct Hin as [ Heq | Hin ]; [ tauto | idtac ].
    right.
    apply in_flat_map in Hin.
    destruct Hin as ( t & Hinlt2 & Hint1 ).
    apply le_lt_trans with (m := term_size t).
    + destruct (IH t Hinlt2 t1 Hint1) as [ Heq | Hlt ].
      * subst t; apply le_refl.
      * apply lt_le_weak; assumption.
    + simpl.
      apply le_lt_n_Sm.
      apply in_le_suml.
      apply in_map.
      assumption.
Qed.

Lemma sub_terms_strict_strict (t: term) :
  ~ In t (sub_terms_strict t).
Proof.
  clear.
  destruct t as [ | c lt | f lt ];
  try (simpl; tauto).

  - assert (Hobv: Forall (fun t => term_size t < ╎capply c lt╎) lt).
    {
      simpl.
      induction lt as [ | t lt IH ];
        [ intros; constructor | idtac ].
      constructor.
      - simpl; omega.
      - rewrite Forall_forall in IH.
        rewrite Forall_forall.
        intros t' Hin.
        apply lt_le_trans with (m := S (suml (map (@term_size _ _ _) lt))).
        + apply IH; assumption.
        + simpl; omega.
    }
    intros Hin.
    generalize Hin; simpl; intros Hsub.
    apply in_flat_map in Hsub.
    destruct Hsub as ( t & Hinlt & Hint ).
    apply (Forall_In_l _ Hobv) in Hinlt.
    apply sub_term_le_size in Hint.
    destruct Hint as [ Heq | Hlt ].
    + subst t.
      revert Hinlt.
      apply lt_irrefl.
    + generalize (lt_trans _ _ _ Hinlt Hlt).
      apply lt_irrefl.

  - assert (Hobv: Forall (fun t => term_size t < ╎fapply f lt╎) lt).
    {
      simpl.
      induction lt as [ | t lt IH ];
        [ intros; constructor | idtac ].
      constructor.
      - simpl; omega.
      - rewrite Forall_forall in IH.
        rewrite Forall_forall.
        intros t' Hin.
        apply lt_le_trans with (m := S (suml (map (@term_size _ _ _) lt))).
        + apply IH; assumption.
        + simpl; omega.
    }
    intros Hin.
    generalize Hin; simpl; intros Hsub.
    apply in_flat_map in Hsub.
    destruct Hsub as ( t & Hinlt & Hint ).
    apply (Forall_In_l _ Hobv) in Hinlt.
    apply sub_term_le_size in Hint.
    destruct Hint as [ Heq | Hlt ].
    + subst t.
      revert Hinlt.
      apply lt_irrefl.
    + generalize (lt_trans _ _ _ Hinlt Hlt).
      apply lt_irrefl.
Qed.

Lemma sub_term_strict_lt_size (t1 t2: term) :
   In t1 (sub_terms_strict t2) -> term_size t1 < term_size t2.
Proof.
  clear.
  intros Hin.
  generalize Hin; intros Hsize.
  apply sub_term_strict_incl, sub_term_le_size in Hsize.
  destruct Hsize as [ Heq | Hlt ]; [ idtac | assumption ].

  exfalso.
  subst t2.
  revert Hin.
  apply sub_terms_strict_strict.
Qed.

Lemma PPO_value_is_sub_term (t v: term) :
  @term_value _ _ _ v ->
  (PPO rank t v <-> In t (sub_terms_strict v)).
Proof.
  clear.
  intros Hval.
  split.

  - (* -> *)
    revert t Hval.
    induction v as [ | c lt IH | ] using term_ind2;
      try (simpl; intros; exfalso; assumption).
    intros t Hval Hppo.
    inversion Hppo as [ aa ab ac Hin ae af | | aa t' ac ad Hin Hppo2 ag ah | | | | ]; subst; simpl.

    + apply in_flat_map.
      exists t; split; try assumption.
      destruct t; simpl; tauto.

    + apply in_flat_map.
      exists t'.
      split; [ assumption | idtac ].
      apply sub_term_strict_incl.
      apply IH; try assumption.
      apply andl_in with (l := map (@term_value _ _ _) lt); [ assumption | idtac ].
      apply in_map.
      assumption.

  - (* <- *)
    revert t Hval.
    induction v as [ | c lt IH | ] using term_ind2;
      intros t Hval Hin; try (simpl in Hval; exfalso; assumption).
    simpl in Hin.
    apply in_flat_map in Hin.
    destruct Hin as ( t' & Hint' & Hin ).
    apply sub_term_eq_or_strict in Hin.
    destruct Hin as [ Heq | Hin ];
      [ subst; constructor; assumption | idtac ].
    apply ppo_constr_sub with (t := t'); [ assumption | idtac ].
    apply IH; try assumption.
    apply andl_in with (l := map (@term_value _ _ _) lt); [ assumption | idtac ].
    apply in_map.
    assumption.
Qed.

Lemma PPO_value_lt_size (v v': value) :
  PPO rank (@term_from_value variable function constructor v) (@term_from_value _ _ _ v') ->
  value_size v < value_size v'.
Proof.
  clear.
  do 2 rewrite <- (compatible_sizes variable function).
  set (t := @term_from_value _ _ _ v).
  set (t' := @term_from_value _ _ _ v').
  intros Hppo.
  apply sub_term_strict_lt_size.
  apply PPO_value_is_sub_term; [ | assumption ].
  apply term_value_eqv.
  exists v'; trivial.
Qed.

Fixpoint all_possible_subarguments (args: list term) : list (list term) :=
  match args with
    | [] => [[]]
    | (x::xs) => let psa := all_possible_subarguments xs in
                let pst := sub_terms x in
                flat_map (fun st => map (fun sa => st::sa) psa) pst
  end.

Lemma length_sub_terms a : length (sub_terms a) = term_size a.
Proof.
  induction a using term_ind2;
    try(simpl;
      rewrite length_flat_map;
      replace (map (length (A:=term)) (map sub_terms l)) with (map (term_size (constructor:=constructor)) l);
        [trivial |

        rewrite map_map;
        apply map_in_ext;
        intros; rewrite H ]) ; auto.
Qed.

Lemma all_possible_subarguments_length (args: list term) :
  length (all_possible_subarguments args) = prodl (map (@term_size _ _ _) args).
Proof.
  induction args.
  - trivial.

  - simpl prodl.
    rewrite <- IHargs.
    simpl all_possible_subarguments.
    rewrite length_flat_map.
    rewrite map_map.
    erewrite map_ext.
    + rewrite <- length_sub_terms.
      rewrite suml_map_const; apply mult_comm.

    + intro. apply map_length.
Qed.

Definition all_possible_sub_activation_same_rank (f: function) (lv: list term) : list term :=
  let psa := all_possible_subarguments lv in
  flat_map (fun g => map (fun sa => fapply g sa) psa) (functions_of_prog prog).

Lemma all_possible_sub_activation_same_rank_bound (f: function) (lv: list term) :
  length (all_possible_sub_activation_same_rank f lv)
  <= length (functions_of_prog prog) * prodl (map (@term_size _ _ _) lv).
Proof.
  unfold all_possible_sub_activation_same_rank.
  rewrite length_flat_map.
  erewrite <- map_length.
  rewrite map_map.
  apply suml_le_len_times_bound.
  intros n Hn.
  apply in_map_iff in Hn.
  destruct Hn as (g & Hgn & Hg).
  rewrite <- Hgn.
  rewrite map_length.
  rewrite all_possible_subarguments_length.
  apply le_n.
Qed.

Lemma all_possible_subarguments_self lt : lt ∈ all_possible_subarguments lt.
Proof.
induction lt; simpl.
- tauto.

- apply in_flat_map; exists a.
  split.
  + case a; simpl; tauto.

  + apply in_map_iff; exists lt; tauto.
Qed.

Lemma sub_terms_self a : In a (sub_terms a).
Proof.
clear subst_default.
destruct a; simpl; tauto.
Qed.

Lemma PPO_value_all_possible_subarguments l lv:
  (forall x, In x lv -> term_value x) ->
  Forall2 (clos_refl (PPO rank)) l lv ->  l ∈ all_possible_subarguments lv.
Proof.
intros Hvalue HPPO.
induction HPPO.
- simpl; tauto.

- simpl.
  apply in_flat_map; exists x.
  split.
  + destruct H.
    * apply sub_term_strict_incl, PPO_value_is_sub_term; [apply Hvalue|]; simpl; tauto.

    * subst x; apply sub_terms_self; trivial.

  + apply in_map.
     auto with *.
Qed.

  (* Every activation at same rank must be sub-term *)
Lemma  all_possible_sub_activation_same_rank_spec p' i s p c1 f lt c2 v:
  PPO_prog ->
  let π := cbv_update i s p c1 (fapply f lt) c2 v in
  wf π ->
  In p' (ℐᵃ π) ->
  activation_rank rank p' = rank f ->
  In (proj_left p') (all_possible_sub_activation_same_rank f lt).
Proof.
intros HPPO π Hwf Hin Hrank.
unfold all_possible_sub_activation_same_rank.
assert (Hwf' : wf p') by (apply (ℐᵃ_wf Hwf) ; trivial).
generalize Hin; intro Hpact.
assert (Hppo : p' = π \/ PPO rank (proj_left p') (proj_left π)) by
  (unfold π; eapply PPO_ℐᵃ; eauto).
apply activation_is_function in Hpact.
destruct Hpact as (i' & s' & p'' & c1' & t'' & c2' & v'' & Heq).
subst p'.
simpl in *.
destruct t''; try tauto.
apply in_flat_map; exists f0.
split.
- replace f0 with (activation_function f0 (cbv_update i' s' p'' c1' (fapply f0 l) c2' v'')) by trivial.
  apply all_functions_in_prog with π; assumption.

- apply in_map_iff; exists l.
  split; trivial.
  destruct Hppo as [Heq | Hppo].
  + inversion Heq; subst.
    apply all_possible_subarguments_self.

  + destruct Hwf as (_ & l' & tt & _ & _ & Hl' & _); subst lt.
    inversion Hppo; subst.
    * apply in_map_iff in H1.
       destruct H1 as (v' & Heqv' & Hinv').
       destruct v'.
       inversion Heqv'.

    *  apply in_map_iff in H2.
       destruct H2 as (v' & Heqv' & Hinv').
       subst t.
       contradict H3.
       apply fapply_not_PPO_value.
       apply term_value_eqv; eauto.

    * omega.

    * { (* main case *)
        apply PPO_value_all_possible_subarguments.
        - intros x Hx.
           apply in_map_iff in Hx.
           destruct Hx as (xx & Heq & Hxx).
           subst x.
           apply term_value_eqv.
           eauto.

        - apply product_Forall2; trivial.
      }
Qed.

Definition bobby_eight_poly x := length (functions_of_prog prog) * Nat.pow x max_arity.

Lemma bobby_eight i s p c1 f lt c2 v:
  let π := cbv_update i s p c1 (fapply f lt) c2 v in
  PPO_prog -> wf π ->
  length (ℐᵃ_at_rank (rank f) π) <=
  bobby_eight_poly (╎proj_left π╎).
Proof.
intros π HPPO Hwf.

unfold ℐᵃ_at_rank.

transitivity (length (all_possible_sub_activation_same_rank f lt)).
- replace (length (filter (fun g : cbv => rank f =? activation_rank rank g) (ℐᵃ π))) with
  (length (filter (fun t => rank f =? match t with
    | fapply g _ => rank g
    | _ => 0 end) (map (fun p => proj_left p) (ℐᵃ π)))).
  + apply NoDup_incl_le_length.
    apply NoDup_filter.
    * apply NoDup_left_ℐᵃ; trivial.

    * intros t Ht.
       apply filter_In in Ht; destruct Ht as (Hin & Hrank).
       apply in_map_iff in Hin; destruct Hin as (p' & Hp' & Hpact).
       subst t.
       eapply all_possible_sub_activation_same_rank_spec; eauto.
       assert (Hwf' : wf p') by (apply (ℐᵃ_wf Hwf) ; trivial).
       apply activation_is_function in Hpact.
       destruct Hpact as (i' & s' & p'' & c1' & t'' & c2' & v'' & Heq).
       subst p'.
       simpl in *.
       destruct t''; try tauto.
       clear Hwf'.
       apply beq_nat_true in Hrank; symmetry; assumption.

  + rewrite <- length_filter.
    erewrite filter_ext_In; [reflexivity|].
    intros p' Hin.
    simpl.
    assert (Hwf' : wf p') by (apply (ℐᵃ_wf Hwf) ; trivial).
    apply activation_is_function in Hin.
   destruct Hin as (i' & s' & p'' & c1' & t'' & c2' & v'' & Heq).
   subst; simpl; trivial.

- transitivity (length (functions_of_prog prog) * prodl (map (@term_size _ _ _) lt));
    [(apply all_possible_sub_activation_same_rank_bound)|].
  unfold bobby_eight_poly.
  apply mult_le_compat_l.
  transitivity (╎proj_left π╎ ^ (length (map (term_size (constructor:=constructor)) lt))).
  + apply prodl_bound.
    intros x Hx.
    unfold π; simpl.
    apply le_S, in_le_suml; trivial.

  + apply Nat.pow_le_mono_r.
    * pose (gt_term_size_O (proj_left π)); omega.

    * rewrite map_length.
       unfold π in Hwf.
       simpl in Hwf.
       decompose record Hwf.
       assumption.
Qed.

Lemma bobby_increase:
  forall x y, x <= y -> (bobby_eight_poly x) <= (bobby_eight_poly y).
Proof.
intros.
unfold bobby_eight_poly.
apply Mult.mult_le_compat_l.
apply pow_le_compat;trivial.
Qed.

(** Theorem 7 *)
Theorem A_T_bound i s p c1 f lt c2 v:
  let π := cbv_update i s p c1 (fapply f lt) c2 v in
  PPO_prog -> wf π ->
  A_T π <= bobby_eight_poly (𝓢 π).
Proof.
intros.
unfold A_T.
apply le_trans with (m:=maxl (map (fun pi => bobby_eight_poly (╎proj_left pi╎)) (ℐᵃ π))).
- apply maxl_le_maxl.
  intros.
  assert (wf x).
  + apply ℐᵃ_wf with (π := π);trivial.
  + apply activation_is_function in H1.
    destruct H1 as (i0 & s0 & p' & c0 & t & c3 & v0 & x_is_upd).
    unfold activation_rank.
    destruct x;try discriminate.
    simpl in H2.
    destruct t0.
    * exfalso;trivial.
    * exfalso;trivial.
    * apply bobby_eight;trivial.
- apply all_max_le.
  intros.
  apply in_map_iff in H1.
  destruct H1 as (x0 & bob & act).
  subst x.
  apply bobby_increase.
  apply le_trans with (m:= (╎proj_left x0╎) + (value_size (proj_right x0))).
  + apply Plus.le_plus_l.
  + apply le_𝓢;trivial.
Qed.

End Bounds.


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.BinEncoders.Env.BinLib.Core
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.WordFacts
        Fiat.BinEncoders.Env.Common.ComposeCheckSum
        Fiat.BinEncoders.Env.Common.ComposeIf
        Fiat.BinEncoders.Env.Common.ComposeOpt
        Fiat.BinEncoders.Env.Automation.Solver
        Fiat.BinEncoders.Env.Lib2.FixListOpt
        Fiat.BinEncoders.Env.Lib2.NoCache
        Fiat.BinEncoders.Env.Lib2.WordOpt
        Fiat.BinEncoders.Env.Lib2.NatOpt
        Fiat.BinEncoders.Env.Lib2.Vector
        Fiat.BinEncoders.Env.Lib2.EnumOpt
        Fiat.BinEncoders.Env.Lib2.SumTypeOpt
        Fiat.BinEncoders.Env.Lib2.IPChecksum.

Require Import Bedrock.Word.

Import Vectors.VectorDef.VectorNotations.
Open Scope string_scope.
Open Scope Tuple_scope.

(* Start Example Derivation. *)

Section UDP_Decoder.

  (* These values are provided by the IP header for checksum calculation.*)
  Variable srcAddr : word 32.
  Variable destAddr : word 32.
  Variable udpLength : word 16.

Definition UDP_Packet :=
  @Tuple <"SourcePort" :: word 16,
          "DestPort" :: word 16,
          "Payload" :: list char >.

Definition UDP_Checksum_Valid
           (srcAddr : word 32)
           (destAddr : word 32)
           (udpLength : word 16)
           (n : nat)
           (b : ByteString)
  := IPChecksum_Valid (96 + n)
                (transform (transform (encode_word srcAddr)
                (transform (encode_word destAddr)
                (transform (encode_word (wzero 8))
                (transform (encode_word (natToWord 8 17))
                           (encode_word udpLength)))))
                b).

Definition encode_UDP_Packet_Spec
           (udp : UDP_Packet) :=
          (encode_word_Spec (udp!"SourcePort")
    ThenC encode_word_Spec (udp!"DestPort")
    ThenC encode_nat_Spec 16 (8 + |udp!"Payload"|) DoneC)
    ThenChecksum (UDP_Checksum_Valid srcAddr destAddr udpLength) OfSize 16
    ThenCarryOn (encode_list_Spec encode_word_Spec udp!"Payload" DoneC).

Definition UDP_Packet_OK (udp : UDP_Packet) :=
lt (|udp!"Payload"|) (pow2 16 - 8).

Definition UDP_Packet_encoded_measure (udp_b : ByteString)
  : nat :=
  match (`(u, b') <- decode_unused_word' 16 udp_b;
         `(u, b') <- decode_unused_word' 16 b';
           decode_word' 16 b') with
  | Some n => 8 * wordToNat (fst n)
  | None => 0
  end.

Arguments NPeano.modulo : simpl never.

Opaque pow2.

Lemma UDP_Packet_Header_Len_OK
  : forall (a : UDP_Packet) (ctx ctx' ctx'' : CacheEncode) (c : word 16) (b b'' ext : ByteString),
    (encode_word_Spec (a!"SourcePort")
                      ThenC encode_word_Spec (a!"DestPort")
                      ThenC encode_nat_Spec 16 (8 + |a!"Payload"|) DoneC) ctx ↝
                                                                            (b, ctx') ->
    (encode_list_Spec encode_word_Spec a!"Payload" DoneC) ctx' ↝ (b'', ctx'') ->
    (lt (|a!"Payload"|) (pow2 16 - 8))%nat ->
    (fun _ : UDP_Packet => 16 + (16 + (16 + length_ByteString ByteString_id))) a +
    (fun a0 : UDP_Packet => (|a0!"Payload" |) * 8 + length_ByteString ByteString_id) a + 16 =
    UDP_Packet_encoded_measure
      (transform (transform b (transform (encode_checksum ByteString transformer ByteString_QueueTransformerOpt 16 c) b'')) ext).
Proof.
  unfold UDP_Packet_encoded_measure.
  intros; rewrite <- !transform_assoc.
  simpl in H0.
  eapply computes_to_compose_decode_unused_word in H;
    let H' := fresh in
    destruct H as [? [? [? H'] ] ]; rewrite H'.
  unfold DecodeBindOpt, If_Opt_Then_Else.
  eapply computes_to_compose_decode_unused_word in H;
    let H' := fresh in
    destruct H as [? [? [? H'] ] ]; rewrite H'.
  unfold DecodeBindOpt, If_Opt_Then_Else.
  eapply computes_to_compose_decode_word in H;
    let H' := fresh in
    destruct H as [? [? [? H'] ] ]; rewrite H'.
  unfold fst.
  rewrite wordToNat_natToWord_idempotent; try reflexivity.
  rewrite !Plus.plus_assoc.
  clear.
  rewrite length_ByteString_id.
  omega.
  rewrite <- BinNat.N.compare_lt_iff.
  rewrite Nnat.N2Nat.inj_compare.
  rewrite Nnat.Nat2N.id.
  rewrite <- Compare_dec.nat_compare_lt.
  rewrite Npow2_nat.
  omega.
Qed.

Definition UDP_Packet_decoder
  : CorrectDecoderFor UDP_Packet_OK encode_UDP_Packet_Spec.
Proof.
  start_synthesizing_decoder.
  normalize_compose transformer.
  apply_IPChecksum_dep UDP_Packet_Header_Len_OK.

  unfold UDP_Packet_OK; clear; intros ? H'; simpl; intuition eauto using lt_minus_plus.
  eapply lt_minus_plus with (m := 8); eauto.

  decode_step idtac.
  decode_step idtac.
  decode_step idtac.
  simpl; intros; intuition.
  decompose_pair_hyp.
  instantiate (1 := fst (snd (snd proj)) - 8);
    rewrite <- H4.
  auto with arith.
  decode_step idtac.
  decode_step idtac.

  synthesize_cache_invariant.
  repeat optimize_decoder_impl.

Defined.

Definition UDP_Packet_decoder_impl :=
  Eval simpl in (fst (projT1 UDP_Packet_decoder)).

End UDP_Decoder.

Print UDP_Packet_decoder_impl.


Require Import Coq.ZArith.ZArith. Open Scope Z_scope.
Require Import coqutil.Z.Lia.
Require Import riscv.Spec.Decode.
Require Import riscv.Utility.Encode.

Record InstructionSet' := {
  supports_64bit: bool;
  (* supports_I: bool; always true *)
  supports_M: bool;
  supports_A: bool;
  supports_F: bool;
}.

Definition toInstructionSet(i: InstructionSet'): InstructionSet :=
  match i.(supports_64bit), i.(supports_M), i.(supports_A), i.(supports_F) with
  | false, false, false, false => RV32I
  | false, false, false, true  => RV32IF
  | false, false, true , false => RV32IA
  | false, false, true , true  => RV32IAF
  | false, true , false, false => RV32IM
  | false, true , false, true  => RV32IMF
  | false, true , true , false => RV32IMA
  | false, true , true , true  => RV32IMAF
  | true , false, false, false => RV64I
  | true , false, false, true  => RV64IF
  | true , false, true , false => RV64IA
  | true , false, true , true  => RV64IAF
  | true , true , false, false => RV64IM
  | true , true , false, true  => RV64IMF
  | true , true , true , false => RV64IMA
  | true , true , true , true  => RV64IMAF
  end.

Definition fromInstructionSet(i: InstructionSet): InstructionSet' :=
  match i with
  | RV32I    => Build_InstructionSet' false false false false
  | RV32IF   => Build_InstructionSet' false false false true
  | RV32IA   => Build_InstructionSet' false false true  false
  | RV32IAF  => Build_InstructionSet' false false true  true
  | RV32IM   => Build_InstructionSet' false true  false false
  | RV32IMF  => Build_InstructionSet' false true  false true
  | RV32IMA  => Build_InstructionSet' false true  true  false
  | RV32IMAF => Build_InstructionSet' false true  true  true
  | RV64I    => Build_InstructionSet' true  false false false
  | RV64IF   => Build_InstructionSet' true  false false true
  | RV64IA   => Build_InstructionSet' true  false true  false
  | RV64IAF  => Build_InstructionSet' true  false true  true
  | RV64IM   => Build_InstructionSet' true  true  false false
  | RV64IMF  => Build_InstructionSet' true  true  false true
  | RV64IMA  => Build_InstructionSet' true  true  true  false
  | RV64IMAF => Build_InstructionSet' true  true  true  true
  end.

Lemma from_toInstructionSet: forall i, fromInstructionSet (toInstructionSet i) = i.
Proof. destruct i as [[|] [|] [|] [|]]; reflexivity. Qed.

Lemma to_fromInstructionSet: forall i, toInstructionSet (fromInstructionSet i) = i.
Proof. destruct i; reflexivity. Qed.

Definition InstructionSet'_le(i1 i2: InstructionSet'): Prop :=
  Bool.le (supports_64bit i1) (supports_64bit i2) /\
  Bool.le (supports_M i1) (supports_M i2) /\
  Bool.le (supports_A i1) (supports_A i2) /\
  Bool.le (supports_F i1) (supports_F i2).

Lemma bitwidth_monotone: forall iset1 iset2,
    InstructionSet'_le (fromInstructionSet iset1) (fromInstructionSet iset2) ->
    bitwidth iset1 <= bitwidth iset2.
Proof. intros. destruct iset1; destruct iset2; cbv in *; intuition congruence. Qed.

Lemma bitwidth_cases: forall iset, bitwidth iset = 2 ^ 5 \/ bitwidth iset = 2 ^ 6.
Proof. destruct iset; cbn; auto. Qed.

Lemma verify_I_shift_66_monotone: forall iset1 iset2 opcode rd rs1 shamt6 funct3 funct6,
    InstructionSet'_le (fromInstructionSet iset1) (fromInstructionSet iset2) ->
    verify_I_shift_66 (bitwidth iset1) opcode rd rs1 shamt6 funct3 funct6 ->
    verify_I_shift_66 (bitwidth iset2) opcode rd rs1 shamt6 funct3 funct6.
Proof.
  unfold verify_I_shift_66. intros. apply bitwidth_monotone in H.
  pose proof bitwidth_cases iset2. intuition blia.
Qed.

Lemma respects_bounds_monotone: forall iset1 iset2 inst,
    InstructionSet'_le (fromInstructionSet iset1) (fromInstructionSet iset2) ->
    respects_bounds (bitwidth iset1) inst ->
    respects_bounds (bitwidth iset2) inst.
Proof.
  destruct inst; intros; try assumption.
  destruct iInstruction; try assumption.
  all: cbn in *.
  all: eauto using verify_I_shift_66_monotone.
Qed.

Lemma verify_iset_monotone: forall iset1 iset2 inst,
    InstructionSet'_le (fromInstructionSet iset1) (fromInstructionSet iset2) ->
    supportsF iset2 = false -> (* because verify_inst/decode_encode proofs don't support it yet *)
    verify_iset inst iset1 ->
    verify_iset inst iset2.
Proof.
  unfold verify_iset, InstructionSet'_le, Bool.le. destruct inst; auto.
  all: intros (L1 & L2 & L3 & L4) SF C.
  all: repeat match type of C with
              | _ \/ _ => destruct C as [? | C]
              end;
    subst; cbn in *.
  all: destruct iset2; cbn in *; try intuition congruence.
Qed.

Lemma verify_monotone: forall iset1 iset2 inst,
    InstructionSet'_le (fromInstructionSet iset1) (fromInstructionSet iset2) ->
    supportsF iset2 = false -> (* because verify_inst/decode_encode proofs don't support it yet *)
    verify inst iset1 ->
    verify inst iset2.
Proof.
  unfold verify. intuition eauto using verify_iset_monotone, respects_bounds_monotone.
Qed.

Lemma verify_iset_I_swap_extensions: forall iset1 iset2 inst,
    verify_iset (IInstruction inst) iset1 ->
    verify_iset (IInstruction inst) iset2.
Proof. unfold verify_iset. auto. Qed.

(* if verify_I holds for one set of extensions, it also holds for any other, because I is always included *)
Lemma verify_I_swap_extensions: forall iset1 iset2 inst,
    verify (IInstruction inst) iset1 ->
    bitwidth iset1 = bitwidth iset2 ->
    verify (IInstruction inst) iset2.
Proof.
  unfold verify.
  intros *. intros (R1 & R2) E. rewrite <- E. eauto using verify_iset_I_swap_extensions.
Qed.

(* if verify_CSR holds for one set of extensions, it also holds for any other, because CSR is always included *)
Lemma verify_CSR_swap_extensions: forall iset1 iset2 inst,
    verify (CSRInstruction inst) iset1 ->
    verify (CSRInstruction inst) iset2.
Proof.
  unfold verify. intros *. cbn. exact id.
Qed.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Definitions from Section 3.5.1 *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Type_Substitution TLC.LibLN.

(* Problems:
    2) term variables
    3) type variables
    4) Using lists instead of LibEnv env.
    7) As I change any rule, is it corrected for the thesis and LN?
   10) five rules to type check.
*)

Inductive S : Heap -> St -> Heap -> St -> Prop :=
(*
 | S_let_3_1 : forall (x : var) (v : E) (h : Heap) (s: St),
                 Value v ->
                 get h x = None ->
                 S h (letx v s) (H.ctxt x v h) s
*)
 | S_seq_3_2 : forall (v : E) (h : Heap) (s: St),
                  Value v ->
                  S h (seq (e_s v) s) h s

 | S_return_3_3: forall (v : E) (h : Heap) (s: St),
                    Value v ->
                    S h (seq (retn v) s) h (retn v)

 | S_if0_3_4: forall (h : Heap) (s1 s2: St),
                 S h (if_s (i_e (i_i 0)) s1 s2)
                   h s1

 | S_if_ne_0_3_5: forall (h : Heap) (z : nat) (s1 s2: St),
                     z <> 0 ->
                     S h (if_s (i_e (i_i z)) s1 s2)
                       h s2

 | S_while_3_6: forall (h : Heap) (e : E) (s : St),
                     S h (while e s)
                       h (if_s e (seq s (while e s)) (e_s (i_e (i_i 0))))

(*

| S_open_3_7:  forall (tau tau' : Tau) (v : E) (p : Phi) (k : Kappa) (alpha : TVar) (x x': EVar) (h : Heap) (s : St),
                  Value v ->
                  S h (open (pack tau' v (etype p alpha k tau)) alpha x s)
                    h (letx x' v (subst_St s tau alpha))

| S_openstar_3_8: forall (tau tau' : Tau) (v v' : E) (q : Phi) (k : Kappa) (alpha : TVar) (x x': EVar) (h : Heap) (s : St) (p : Path),
                    Value v ->
                    x <> x' ->
                    get v' p (pack tau' v (etype q alpha k tau)) ->
                    (* S is part of the context not the heap, overloading ; in DS3.8 *)
                    (* x' is right, openstar uses *x' but I am eliding it in the syntax. *)
                    H.map h x = Some v' ->
                    S h (openstar (p_e x p) alpha x' s)
                      h (letx x'  (amp (p_e x (p ++ [u_pe])))
                                     (subst_St s tau alpha))
*)
| S_exp_3_9_1: forall (h h' : Heap) (e e' : E),
                   R h (e_s e) h' (e_s e') ->
                   S h (e_s e) h' (e_s e')

| S_ret_3_9_2: forall (h h' : Heap) (e e' : E),
                   R h (e_s e) h' (e_s e') ->
                   S h (retn e) h' (retn e')

| S_if_3_9_3: forall (h h' : Heap) (e e' : E) (s1 s2 : St),
                   R h (e_s e) h' (e_s e') ->
                   S h (if_s e s1 s2) h' (if_s e' s1 s2)

| S_letx_3_9_4: forall (h h' : Heap) (e e' : E) (s : St),
                   R h (e_s e) h' (e_s e') ->
                   S h (letx e s) h' (letx e' s)

| S_open_3_9_5: forall (h h' : Heap) (e e' : E) (s : St),
                   R h (e_s e) h' (e_s e') ->
                   S h  (open e  s)
                     h' (open e' s)

| S_seq_3_10:  forall (h h' : Heap) (s s' s2: St),
                    S h s h' s' ->
                    S h  (seq s  s2) h' (seq s' s2)

| S_openstar_3_11: forall (h h' : Heap) (e e' : E) (s : St),
                        L h  (e_s e) h' (e_s e') ->
                        S h  (openstar e  s)
                          h' (openstar e' s)
with R : Heap -> St -> Heap -> St -> Prop :=
(*
 | R_get_3_1 : forall (h  : Heap) (x : EVar) (p : Path) (v v' : E),
                    H.map h x = Some v' ->
                    get v' p v ->
                    Value v ->
                    Value v' ->
                    R h (e_s (p_e x p))
                      h (e_s v)

 | R_assign_3_2:
     forall (h' h : Heap) (v v' v'' : E) (x : EVar) (p : Path),
       H.map h x = Some v' ->
       set v' p v v'' ->
       H.add h x v'' = h' ->
       Value v   ->
       Value v'  ->
       Value v'' ->
       R h  (e_s (assign (p_e x p) v))
         h' (e_s v)

 | R_initial_assign_3_2:
     forall (h' h : Heap) (v : E) (x : EVar),
       H.map h x = None ->
       H.add h x v = h' ->
       Value v   ->
       R h  (e_s (assign (p_e x []) v))
         h' (e_s v)
*)

 | R_star_amp_3_3:
                 forall (h : Heap) (v : var) (p : Path),
                   R h (e_s (star (amp (p_e (fevar v)  p))))
                     h (e_s (p_e (fevar v) p))

 (* Split on 0 or 1. *)
 | R_dot_3_4_0:  forall (h : Heap) (v0 v1 : E),
                    R h (e_s (dot (cpair v0 v1) zero_pe))
                      h (e_s v0)

 | R_dot_3_4_1:  forall (h : Heap) (v0 v1 : E),
                    R h (e_s (dot (cpair v0 v1) one_pe))
                      h (e_s v1)

 | R_appl_3_5:   forall (h : Heap) (tau tau' : Tau) (v : E) (s : St),
                    Value v ->
                    R h (e_s (appl (f_e (dfun tau tau' s)) v))
                      h (e_s (call (letx v s)))

 | R_call_3_6:    forall (h : Heap) (v : E),
                    Value v ->
                    R h (e_s (call (retn v)))
                      h (e_s v)

 | R_inst_3_7:  forall (h : Heap) (alpha : var) (k : Kappa) (f : F) (tau : Tau),
                  R h (e_s (inst (f_e (ufun k f)) tau))
                    h (e_s (f_e (subst_Tau_F f tau alpha)))

 | R_call_3_8:  forall (h h': Heap) (s s': St),
                  S h s h' s' ->
                  R h (e_s (call s)) h' (e_s (call s'))

 | R_amp_3_9_1: forall (h h' : Heap) (e e' : E),
                   L h (e_s e)       h' (e_s e') ->
                   R h (e_s (amp e)) h' (e_s (amp e'))

 | R_assign_3_9_2: forall (h h' : Heap) (e e' e2: E),
                   L h (e_s e)             h' (e_s e') ->
                   R h (e_s (assign e e2)) h' (e_s (assign e' e2))

 | R_star_3_10_1: forall (h h' : Heap) (e e' : E),
                    R h (e_s e)        h' (e_s e') ->
                    R h (e_s (star e)) h' (e_s (star e'))

 | R_dot_3_10_2: forall (h h' : Heap) (e e' : E) (ipe : IPE),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (dot e  ipe))
                      h' (e_s (dot e' ipe))

 | R_assign_3_10_3: forall (h h' : Heap) (e e' : E) (x : V) (p : Path),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (assign (p_e x p) e))
                      h' (e_s (assign (p_e x p) e'))

 | R_inst_3_10_4:  forall (h h' : Heap) (e e' : E) (tau : Tau),
                 R h (e_s e) h' (e_s e') ->
                 R h  (e_s (inst e tau))
                   h' (e_s (inst e' tau))

 | R_pack_3_10_5:  forall (h h' : Heap) (e e' : E) (tau tau' : Tau) (p : Phi) (k : Kappa) (alpha : var),
                    R h (e_s e)        h' (e_s e') ->
                    R h  (e_s (pack tau' e  (etype p k tau)))
                      h' (e_s (pack tau' e' (etype p k tau)))

 | R_cpair_3_10_6:  forall (h h' : Heap) (e e' e2 : E),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (cpair e e2))
                      h' (e_s (cpair e' e2))

 | R_cpair_3_10_7:  forall (h h' : Heap) (e e' v : E),
                    Value v ->
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (cpair v e))
                      h' (e_s (cpair v e'))

 | R_cpair_3_10_8:  forall (h h' : Heap) (e e' e2 : E),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (cpair e e2))
                      h' (e_s (cpair e' e2))

 | R_appl_3_10_9:  forall (h h' : Heap) (e e' e2 : E),
                    R h  (e_s e) h' (e_s e') ->
                    R h  (e_s (appl e e2))
                      h' (e_s (appl e' e2))

 | R_appl_3_10_10: forall (h h' : Heap) (v e e': E),
                     Value v ->
                     R h  (e_s e) h' (e_s e') ->
                     R h  (e_s (appl v e))
                       h' (e_s (appl v e'))

with L : Heap -> St -> Heap -> St -> Prop :=

(*
 | L_xpi_3_1: forall (h : Heap) (x : EVar) (p : Path) (ipe : IPE),
                L h (e_s (dot (p_e x p) ipe))
                  h (e_s (p_e x (p ++ [i_pe ipe])))
*)

 | L_staramp_3_2: forall (h : Heap) (x : V) (p : Path),
                    L h (e_s (star (amp (p_e x p))))
                      h (e_s (p_e x p))

 | L_star_3_3: forall (h h' : Heap) (e e': E),
                 R h (e_s e)        h' (e_s e') ->
                 L h (e_s (star e)) h' (e_s (star e'))

 | L_ei_3_4: forall (h h' : Heap) (e e': E) (ipe : IPE),
               L h (e_s e)                h' (e_s e') ->
               L h (e_s (dot e ipe))  h' (e_s (dot e' ipe)).

Scheme R_ind_mutual := Induction for R Sort Prop
with   S_ind_mutual := Induction for S Sort Prop
with   L_ind_mutual := Induction for L Sort Prop.
Combined Scheme SLR_ind_mutual
         from S_ind_mutual, L_ind_mutual, R_ind_mutual.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.

Local Open Scope logic_base.
Local Open Scope kripke_model.
Import KripkeModelFamilyNotation.

Section Lindenbaum_Kripke.

Context {L: Language}
        {minL: MinimumLanguage L}
        {Gamma: Derivable L}
        {bSC: BasicSequentCalculus L Gamma}
        {fwSC: FiniteWitnessedSequentCalculus L Gamma}.

Lemma Lindenbaum_preserves_cannot_derive: forall x, Lindenbaum_preserves (cannot_derive x).
Proof.
  intros.
  apply Lindenbaum_preserves_by_finiteness.
  - apply cannot_derive_finite_captured.
  - apply cannot_derive_subset_preserved.
Qed.

Lemma Lindenbaum_cannot_derive_ensures_derivable_closed: forall x, Lindenbaum_ensures (cannot_derive x) derivable_closed.
Proof.
  intros.
  apply Lindenbaum_for_derivable_closed.
  - apply Lindenbaum_preserves_cannot_derive.
  - apply cannot_derive_derivable_subset_preserved.
Qed.

End Lindenbaum_Kripke.


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

(************************************************************************)
(*                                                                      *)
(*                       Process.v                                      *)
(*                                                                      *)
(*    Laurent.Thery @sophia.inria.fr        March 2002                  *)
(************************************************************************)
Require Import List.
Require Import Normal.
Require Import Nat.
Require Import ArithRing ZArithRing.
Require Import sTactic.
Require Import ReduceEq.
Require Import ReduceCong.

Fixpoint maxL (l : list Z) (l1 : list (nat * form)) {struct l1} : Z :=
  match l1 with
  | nil => 0%Z
  | (n1, Neg (Form.Eq a b)) :: l2 =>
      Zmax (maxL l l2) (Zsucc (exp2Z l a - exp2Z l b))
  | _ => 0%Z
  end.

Theorem maxPos : forall l l1, (0 <= maxL l l1)%Z.
intros l l1; elim l1; simpl in |- *; auto with zarith.
intros a; case a; simpl in |- *; auto with arith.
intros n; intros f; case f; simpl in |- *; auto with zarith.
intros f0; case f0; simpl in |- *; auto with zarith.
intros; apply Zle_trans with (maxL l l0); auto.
apply Zmax1; auto.
Qed.

Theorem onlyNeg_correct_aux :
 forall l l1,
 listNEqP l1 -> forall a, (maxL l l1 <= a)%Z -> formL2Prop a l l1.
intros l l1 H; elim H; simpl in |- *; auto.
intros n a b l0 H0 H1 H2 a0 H3; split; auto.
2: apply H2.
2: apply Zle_trans with (2 := H3).
2: apply Zmax1.
red in |- *; intros H4;
 absurd (Zmax (maxL l l0) (Zsucc (exp2Z l a - exp2Z l b)) <= a0)%Z;
 auto.
apply Zlt_not_le.
replace (Zsucc (a0 * Z_of_nat n + exp2Z l b - exp2Z l b)) with
 (Zsucc (a0 * Z_of_nat n)); [ idtac | unfold Zsucc in |- *; ring ].
apply Zlt_le_trans with (Zsucc (a0 * Z_of_nat n)).
apply Zle_lt_succ.
pattern a0 at 1 in |- *; replace a0 with (a0 * Z_of_nat 1)%Z;
 [ idtac | simpl in |- *; ring ].
apply Zmult_le_compat_l; auto with zarith arith.
apply Znat.inj_le; auto with arith.
apply Zle_trans with (maxL l l0).
apply maxPos.
apply Zle_trans with (2 := H3).
apply Zmax1.
replace (exp2Z l a - exp2Z l b)%Z with (a0 * Z_of_nat n)%Z.
apply Zmax2.
rewrite H4; ring.
Qed.

Theorem onlyNeg_correct :
 forall l l1, listNEqP l1 -> exists a : _, formL2Prop a l l1.
intros l l1 H; exists (maxL l l1).
apply onlyNeg_correct_aux; auto with zarith.
Qed.

Fixpoint maxC (l1 : list (nat * form)) : nat :=
  match l1 with
  | nil => 1
  | (n1, Cong i a b) :: l2 => lcm i (maxC l2)
  | _ => 1
  end.

Theorem maxCPos : forall l, listCongP l -> 1 <= maxC l.
intros l H; elim H; simpl in |- *; auto.
intros n i a b l0 H0 H1 H2 H3; (apply le_trans with i; auto with arith).
case (divides_lcm1 i (maxC l0)); auto with arith.
intros m1 H4; rewrite H4; pattern i at 1 in |- *; replace i with (i * 1);
 [ idtac | ring ].
cut (0 < lcm i (maxC l0)).
rewrite H4; case m1; auto with arith.
intros H5; Contradict H5; rewrite mult_comm; simpl in |- *; auto with arith.
apply lcm_lt_O; auto.
Qed.

Theorem onlyNeg_correct_aux1 :
 forall a b l l1,
 listCongP l1 ->
 formL2Prop a l l1 -> formL2Prop (a + b * Z_of_nat (maxC l1)) l l1.
intros a b l l1 H; generalize a b; elim H; simpl in |- *; clear H a b l1;
 auto.
intros n i a b l0 H H0 H1 H2 a0 b0 ((m3, H3), H4).
split.
exists (m3 - Z_of_nat n * (b0 * Z_of_nat (div (lcm i (maxC l0)) i)))%Z.
rewrite H3.
cut
 (forall a b c d e,
  ((a - e * (b * Z_of_nat c)) * d)%Z = (a * d - e * (d * Z_of_nat c * b))%Z);
 [ intros H5; rewrite H5 | intros; ring ].
rewrite <- Znat.inj_mult; rewrite <- divides_div; auto.
ring.
apply divides_lcm1; auto.
generalize (maxCPos _ H1); auto with arith.
replace (b0 * Z_of_nat (lcm i (maxC l0)))%Z with
 (b0 * Z_of_nat (div (lcm i (maxC l0)) (maxC l0)) * Z_of_nat (maxC l0))%Z;
 auto.
cut (forall a b c, (a * b * c)%Z = (c * b * a)%Z);
 [ intros H5; rewrite H5 | intros; ring ].
rewrite <- Znat.inj_mult; rewrite <- divides_div; auto.
ring.
generalize (maxCPos _ H1); auto with arith.
apply divides_lcm2; auto.
generalize (maxCPos _ H1); auto with arith.
Qed.

Theorem onlyNeg_correct_aux2 :
 forall a b l l1,
 listCongP l1 ->
 formL2Prop a l l1 -> exists c : _, (b <= c)%Z /\ formL2Prop c l l1.
intros a b l l1 H H0; (case (Zle_or_lt b a); intros H1).
exists a; auto with zarith.
exists (a + (b - a) * Z_of_nat (maxC l1))%Z.
split.
pattern b at 1 in |- *; replace b with (a + (b - a) * Z_of_nat 1)%Z;
 [ idtac | simpl in |- *; ring ].
apply Zplus_le_compat_l.
apply Zmult_le_compat_l.
apply Znat.inj_le; apply maxCPos; auto.
apply Zlt_le_weak; unfold Zminus in |- *; apply Zlt_left_lt; auto.
apply onlyNeg_correct_aux1; auto.
Qed.

Theorem oneCongNeq_correct :
 forall l l1 l2,
 listNEqP l1 ->
 listCongP l2 ->
 ((exists c : _, formL2Prop c l l1 /\ formL2Prop c l l2) <->
  (exists c : _, formL2Prop c l l2)).
intros l l1 l2 H H1; split.
intros (c, (H2, H3)); exists c; auto.
intros (d, H2).
case (onlyNeg_correct_aux2 d (maxL l l1) l l2); auto.
intros c (H3, H4); exists c; split; auto.
apply onlyNeg_correct_aux; auto.
Qed.

(** Process the list produced by Sort and generate the appropriate reduction *)
Definition processList
  (ls : list form *
        (list (nat * form) * (list (nat * form) * list (nat * form)))) :
  list form :=
  match ls with
  | (l1, ((m1, Form.Eq a1 b1) :: l2, (l3, l4))) =>
      Cong m1 a1 b1
      :: l1 ++
         reduceEqEq m1 a1 b1 l2 ++
         reduceEqNEq m1 a1 b1 l3 ++ reduceEqCong m1 a1 b1 l4
  | (l1, (nil, (l3, (m1, Cong i1 a1 b1) :: l4))) =>
      match reduceCongCong i1 m1 a1 b1 l4 with
      | (i2, (m2, (a2, (b2, l5)))) => Cong (gcd i2 m2) a2 b2 :: l1 ++ l5
      end
  | (l1, (l2, (l3, l4))) => l1
  end.

Theorem processList_correct :
 forall l l1 l2 l3 l4,
 Cnf1 (buildConj l1) ->
 listEqP l2 ->
 listNEqP l3 ->
 listCongP l4 ->
 ((exists a : _,
     form2Prop l (buildConj l1) /\
     formL2Prop a l l2 /\ formL2Prop a l l3 /\ formL2Prop a l l4) <->
  form2Prop l (buildConj (processList (l1, (l2, (l3, l4)))))) /\
 Cnf1 (buildConj (processList (l1, (l2, (l3, l4))))).
intros l l1 l2 l3 l4 H H0 H1 H2; inversion H0.
inversion H2; simpl in |- *.
split; auto; split.
intros (m5, (H5, H6)); auto.
case (onlyNeg_correct l l3); auto with arith.
intros a H5 H6; exists a; auto.
split.
split.
intros (c, (H8, (H9, (H10, (H11, H12))))).
generalize (reduceCongCong_correct i n a b (c :: l) l0 H4 H5 H6);
 case (reduceCongCong i n a b l0).
intros n1 p; case p; clear p.
intros n2 p; case p; clear p.
intros a1 p; case p; clear p.
intros b1 ll.
intros (H13, (H14, (H'14, H''14))); simpl in H13, H14.
case H13; clear H13; intros H13 H15; case H13; clear H13 H15; auto.
intros H15 H16; apply form2Prop_cons; auto.
case H15; intros m17 H17.
simpl in |- *;
 exists
  (c * Z_of_nat (div n2 (gcd n1 n2)) + m17 * Z_of_nat (div n1 (gcd n1 n2)))%Z.
rewrite H17.
cut
 (forall a b c d e, ((a * b + c * d) * e)%Z = (a * (e * b) + c * (e * d))%Z);
 [ intros H18; rewrite H18 | intros; ring ].
repeat rewrite <- Znat.inj_mult; repeat rewrite <- divides_div; auto.
ring.
apply gcd_lt_zero; auto.
apply divides_gcd1; auto.
apply gcd_lt_zero; auto.
apply divides_gcd2; auto.
CaseEq (reduceCongCong i n a b l0).
intros n1 p; case p; clear p.
intros n2 p; case p; clear p.
intros a1 p; case p; clear p.
intros b1 ll.
intros H8 H9.
generalize (form2Prop_cons_inv _ _ _ H9); intros ((m10, H10), H11).
case (gcd_bezout n1 n2); intros z1 (z2, H12).
rewrite <- H12 in H10.
generalize (reduceCongCong_correct i n a b ((m10 * z2)%Z :: l) l0 H4 H5 H6).
rewrite H8; simpl in |- *.
intros ((H13, H14), (H15, (H16, H17))); case H14; clear H13 H14.
split.
exists (m10 * z1)%Z; rewrite H10; ring.
case (form2Prop_app_inv _ _ _ H11); auto.
intros H13 H14.
case (oneCongNeq_correct l l3 ((n, Cong i a b) :: l0)); auto.
intros H18 H19; case H19; clear H18 H19; auto.
exists (m10 * z2)%Z; simpl in |- *; auto.
simpl in |- *; intros m5 (H18, (H19, H20)); exists m5; repeat split; auto.
case (form2Prop_app_inv _ _ _ H11); auto.
CaseEq (reduceCongCong i n a b l0).
intros n1 p; case p; clear p.
intros n2 p; case p; clear p.
intros a1 p; case p; clear p.
intros b1 ll.
intros H8; apply Cnf1_cons; auto.
apply Cnf1_app; auto.
generalize (reduceCongCong_correct i n a b (0%Z :: l) l0 H4 H5 H6).
rewrite H8; intuition.
unfold processList in |- *; lazy beta in |- *.
split.
split.
intros (m6, (H6, (H7, (H8, H'8)))).
simpl in H7; case H7; intros H9 H10.
apply form2Prop_cons.
simpl in |- *; exists m6; rewrite H9; ring.
apply form2Prop_app; auto.
apply form2Prop_app; auto.
case (reduceEqEq_correct n a b (m6 :: l) l0); simpl in |- *; auto.
intuition.
apply form2Prop_app; auto.
case (reduceEqNEq_correct n a b (m6 :: l) l3); simpl in |- *; auto.
intuition.
case (reduceEqCong_correct n a b (m6 :: l) l4); simpl in |- *; auto.
intuition.
intros H6.
case (form2Prop_cons_inv _ _ _ H6); auto.
intros H7 H8.
simpl in H7; case H7; clear H7; intros m7 H7.
exists m7; repeat split; auto.
case (form2Prop_app_inv _ _ _ H8); auto.
rewrite H7; ring.
case (reduceEqEq_correct n a b (m7 :: l) l0); simpl in |- *; auto.
case (form2Prop_app_inv _ _ _ H8); auto.
intros H9 H10.
case (form2Prop_app_inv _ _ _ H10); auto.
rewrite Zplus_comm; intuition.
case (reduceEqNEq_correct n a b (m7 :: l) l3); simpl in |- *; auto.
case (form2Prop_app_inv _ _ _ H8); auto.
intros H9 H10.
case (form2Prop_app_inv _ _ _ H10); auto.
intros H11 H12.
case (form2Prop_app_inv _ _ _ H12); auto.
rewrite Zplus_comm; intuition.
case (reduceEqCong_correct n a b (m7 :: l) l4); simpl in |- *; auto.
case (form2Prop_app_inv _ _ _ H8); auto.
intros H9 H10.
case (form2Prop_app_inv _ _ _ H10); auto.
intros H11 H12.
case (form2Prop_app_inv _ _ _ H12); auto.
rewrite Zplus_comm; intuition.
case (reduceEqEq_correct n a b l l0); auto.
case (reduceEqNEq_correct n a b l l3); auto.
case (reduceEqCong_correct n a b l l4); auto.
Qed.
Require Import GroundN.

Theorem processList_groundN :
 forall n l1 l2 l3 l4,
 listEqP l2 ->
 listNEqP l3 ->
 listCongP l4 ->
 groundNL n l1 ->
 groundNL2 n l2 ->
 groundNL2 n l3 ->
 groundNL2 n l4 -> groundNL n (processList (l1, (l2, (l3, l4)))).
intros n l1 l2 l3 l4 H; inversion H; simpl in |- *.
intros H1 H2; inversion H2; auto.
intros H7 H8 H9 H10; inversion H10.
inversion H14.
cut (groundNExp n a);
 [ intros H25 | apply groundNExp_le with (n := n2); auto ].
cut (groundNExp n b);
 [ intros H26 | apply groundNExp_le with (n := m0); auto ].
generalize (reduceCongCong_groundN i n n0 a b l H5 H16 H25 H26);
 case (reduceCongCong i n0 a b l).
intros i3 p0; case p0; clear p0.
intros m3 p0; case p0; clear p0.
intros a3 p0; case p0; clear p0.
intros b3 l5 (H27, (H28, H29)).
apply GNVCons; auto.
apply GNCong with (n := n) (m := n); auto.
intros H3 H4 H5 H6 H7 H8.
inversion H6.
inversion H12.
apply GNVCons; auto.
apply GNCong with (n := n2) (m := m0); auto.
apply groundNL_app; auto.
apply groundNL_app; auto.
apply reduceEqEq_groundN; auto.
apply groundNExp_le with (n := n2); auto.
apply groundNExp_le with (n := m0); auto.
apply groundNL_app; auto.
apply reduceEqNEq_groundN; auto.
apply groundNExp_le with (n := n2); auto.
apply groundNExp_le with (n := m0); auto.
apply reduceEqCong_groundN; auto.
apply groundNExp_le with (n := n2); auto.
apply groundNExp_le with (n := m0); auto.
Qed.