Require Import msl.msl_direct.
Require Import overlapping.
Require Import heap_model.
Require Import graph.
Require Import msl_ext.
Require Import ramify_tactics.
Require Import FunctionalExtensionality.
Require Import NPeano.
Require Import List.
Require Import utilities.

Local Open Scope pred.

Instance natEqDec : EqDec nat := { t_eq_dec := eq_nat_dec }.

Definition trinode x d l r := !!(3 | x) && (mapsto x d) * (mapsto (x+1) l) * (mapsto (x+2) r).

Section PointwiseGraph.

  Variable pg : @PreGraph nat nat natEqDec.
  Variable bi : BiGraph pg.

  Axiom valid_not_zero: forall x, @valid nat nat natEqDec pg x -> x <> 0.

  Definition gValid (x : adr) : Prop := @valid nat nat natEqDec pg x.

  Definition graph_fun (Q: adr -> pred world) (x: adr) :=
    (!!(x = 0) && emp) ||
    (EX d:adr, EX l:adr, EX r:adr, !!(gamma bi x = (d, l, r) /\ gValid x) && trinode x d l r ⊗ (Q l) ⊗ (Q r)).

  Lemma graph_fun_covariant : covariant graph_fun.
  Proof.
    unfold graph_fun. apply covariant_orp.
    apply covariant_const.
    apply covariant_exp; intro d.
    apply covariant_exp; intro l.
    apply covariant_exp; intro r.
    repeat apply covariant_ocon.
    apply covariant_andp. apply covariant_const.
    repeat apply covariant_sepcon; apply covariant_const.
    apply covariant_const'. apply covariant_const'.
  Qed.

  Definition graph := corec graph_fun.

  Lemma graph_unfold:
    forall x,
      graph x = (!!(x = 0) && emp) ||
                (EX d:adr, EX l:adr, EX r:adr, !!(gamma bi x = (d, l, r) /\ gValid x) && trinode x d l r ⊗
                                                 (graph l) ⊗ (graph r)).
  Proof.
    intros. unfold graph at 1. rewrite corec_fold_unfold. trivial. apply graph_fun_covariant.
  Qed.

  Definition dag_fun (Q: adr -> pred world) (x: adr) :=
    (!!(x = 0) && emp) ||
    (EX d:adr, EX l:adr, EX r:adr, !!(gamma bi x = (d, l, r) /\ gValid x) && trinode x d l r * ((Q l) ⊗ (Q r))).

  Lemma dag_fun_covariant : covariant dag_fun.
  Proof.
    unfold dag_fun.
    apply covariant_orp. apply covariant_const.
    apply covariant_exp. intro d. apply covariant_exp. intro l. apply covariant_exp. intro r.
    apply covariant_sepcon. apply covariant_const.
    apply covariant_ocon; apply covariant_const'.
  Qed.

  Definition dag := corec dag_fun.

  Lemma dag_unfold:
    forall x,
      dag x = (!!(x = 0) && emp) ||
              (EX d:adr, EX l:adr, EX r:adr, !!(gamma bi x = (d, l, r) /\ gValid x) && trinode x d l r * ((dag l) ⊗ (dag r))).
  Proof.
    intros. unfold dag at 1. rewrite corec_fold_unfold. trivial. apply dag_fun_covariant.
  Qed.

  (* Lemma dag_eq_graph: forall x, dag x |-- graph x && !!(graph_is_acyclic (reachable_subgraph pg (x :: nil))). *)

  Fixpoint graphs (l : list adr) :=
    match l with
      | nil => emp
      | v :: l' => graph v ⊗ graphs l'
    end.

  Fixpoint dags (l : list adr) :=
    match l with
      | nil => emp
      | v :: l' => dag v ⊗ dags l'
    end.

  Definition graph_maps (v : adr) : pred world := let (dl, r) := gamma bi v in let (d, l) := dl in trinode v d l r.

  Lemma precise_graph_maps: forall v, precise (graph_maps v).
  Proof.
    intro. unfold graph_maps. destruct (gamma bi v) as [dl r]. destruct dl as [d l]. unfold trinode. apply precise_sepcon.
    apply precise_mapsto. apply precise_sepcon. apply precise_mapsto. apply precise_andp_right. apply precise_mapsto.
  Qed.

  Lemma joinable_mapsto:
    forall w x y a b, x <> y -> (mapsto x a * TT)%pred w -> (mapsto y b * TT)%pred w -> (mapsto x a * mapsto y b * TT)%pred w.
  Proof.
    intros. destruct H0 as [p [q [? [? ?]]]]. generalize H2; intro Hmap1. destruct p as [fp xp] eqn:? .
    destruct H1 as [m [n [? [? ?]]]]. generalize H4; intro Hmap2. destruct m as [fm xm] eqn:? .  hnf in H2. simpl in H2.
    hnf in H4. simpl in H4. destruct H2 as [? [? ?]]. destruct H4 as [? [? ?]].
    remember (fun xx : adr => if eq_nat_dec xx x then Some a else (if eq_nat_dec xx y then Some b else None)) as f.
    assert (finMap f). exists (x :: y :: nil). intro z. intros. rewrite Heqf. destruct (eq_nat_dec z x). rewrite e in *.
    exfalso. apply H10. apply in_eq. destruct (eq_nat_dec z y). rewrite e in *. exfalso. apply H10. apply in_cons. apply in_eq.
    trivial. remember (exist (finMap (B:=adr)) f H10) as ff. assert (join p m ff). rewrite Heqw0, Heqw1, Heqff.
    hnf; simpl. intro z. destruct (eq_nat_dec z x). rewrite e in *. rewrite H7. generalize (H8 x H); intro HS. rewrite HS.
    rewrite Heqf. destruct (eq_nat_dec x x). apply lower_None2. exfalso; auto. destruct (eq_nat_dec z y). rewrite e in *.
    rewrite H9. generalize (H6 y n0); intro HS. rewrite HS. rewrite Heqf. destruct (eq_nat_dec y x). intuition.
    destruct (eq_nat_dec y y). apply lower_None1. intuition. specialize (H6 z n0). specialize (H8 z n1). rewrite H6, H8.
    rewrite Heqf. destruct (eq_nat_dec z x). intuition. destruct (eq_nat_dec z y). intuition. apply lower_None1.
    rewrite <- Heqw0 in *. rewrite <- Heqw1 in *. destruct (join_together H0 H1 H11) as [qn ?]. exists ff, qn.
    repeat split; auto. exists p, m. split; auto.
  Qed.

  Lemma graph_path_tri_in: forall p x y P, pg |= p is x ~o~> y satisfying P -> graph x |-- graph_maps y * TT.
  Proof.
    induction p; intros; destruct H as [[? ?] [? ?]]. inversion H. simpl in H; inversion H; subst. clear H. destruct p.
    simpl in H0; inversion H0; subst; clear H0. repeat intro. rewrite graph_unfold in H. destruct H as [[? ?] | ?].
    hnf in H; apply valid_not_zero in H1; intuition. destruct H as [d [l [r ?]]]. destruct_ocon H h. destruct_ocon H4 i.
    destruct H8 as [[? ?] ?]. try_join i3 h3 i3h3. exists i12, i3h3. split; auto. split; auto. hnf.
    destruct (gamma bi y) as [dl rr].
    destruct dl as [dd ll]. inversion H8; auto. assert (pg |= n :: p is n ~o~> y satisfying P).
    split; [split; [simpl; auto | auto] | split; [destruct H1; auto | repeat intro; apply H2; apply in_cons; auto]].

    repeat intro. rewrite graph_unfold in H3. destruct H3 as [[? ?] | [d [l [r ?]]]]. hnf in H3. destruct H1 as [[? ?] ?].
    apply valid_not_zero in H1.
    intuition. destruct_ocon H3 h. destruct_ocon H6 i. destruct H10 as [[? ?] ?]. unfold gamma in H10. destruct_sepcon H13 j.
    destruct_sepcon H14 k. destruct H1 as [[? [? ?]] ?]. revert H10. case_eq (biEdge bi x); intros. inversion H21; subst.
    generalize (biEdge_only2 bi _ _ _ _ H10 H19); intros. destruct H22; subst. specialize (IHp _ _ _ H _ H11).
    destruct IHp as [l1 [l2 [? [? ?]]]]. try_join i2 i3 i23'. equate_join i23 i23'. try_join l2 i1 l2i1.
    try_join l2i1 h3 l2i1h3. exists l1, l2i1h3. split; auto. specialize (IHp _ _ _ H _ H7). destruct IHp as [l1 [l2 [? [? ?]]]].
    try_join h2 h3 h23'. equate_join h23 h23'. try_join l2 h1 l2h1. exists l1, l2h1. split; auto.
  Qed.

  Lemma graph_reachable_tri_in: forall x y, reachable pg x y -> graph x |-- graph_maps y * TT.
  Proof. intros; destruct H; apply graph_path_tri_in in H; trivial. Qed.

  Lemma graph_path_in: forall p x y P, pg |= p is x ~o~> y satisfying P -> graph x |-- EX v : adr, (mapsto y v * TT).
  Proof.
    intros. generalize (graph_path_tri_in _ _ _ _ H). intros. repeat intro. specialize (H0 a H1). destruct_sepcon H0 i.
    hnf in H2. destruct (gamma bi y) as [dl r] in H2. destruct dl as [d l]. destruct_sepcon H2 j. destruct_sepcon H4 k.
    destruct H6. try_join k2 j2 k2j2. try_join k2j2 i2 k2j2i2. exists d, k1, k2j2i2. split; auto.
  Qed.

  Lemma graph_reachable_in: forall x y, reachable pg x y -> graph x |-- EX v : adr, (mapsto y v * TT).
  Proof. intros; destruct H; apply graph_path_in in H; trivial. Qed.

  Section ConstructReachable.

    Definition explode (x : adr) (w : world) (H : (graph x * TT)%pred w) :
      {l : adr & {r : adr | biEdge bi x = (l, r) /\ gValid x /\ (graph l * TT)%pred w /\ (graph r * TT)%pred w}} + {x = 0}.
      destruct (eq_nat_dec x 0). right; auto. left.
      rewrite graph_unfold in H.
      assert (((EX  d : adr, (EX  l : adr, (EX  r : adr,
                                                    !!(gamma bi x = (d, l, r) /\ gValid x) && trinode x d l r
                                                      ⊗ graph l ⊗ graph r))) * TT)%pred w) as S.
      destruct_sepcon H h. hnf in H0. destruct H0. destruct H0. hnf in H0. exfalso; auto.
      exists h1, h2; split; auto. clear H. remember (gamma bi x). destruct p as [[d l] r]. exists l, r.
      destruct_sepcon S h. destruct H0 as [dd [ll [rr ?]]]. destruct_ocon H0 i. destruct_ocon H4 j.
      destruct H8 as [[? ?] ?]. injection H8; intros; subst; clear H8. unfold gamma in Heqp. destruct (biEdge bi x).
      injection Heqp; intros; subst; clear Heqp. repeat split; auto. apply valid_not_zero in H10. try_join j2 j3 j23'.
      equate_join j23 j23'. try_join j1 i3 j1i3. try_join j1i3 h2 j1i3h2. exists j23, j1i3h2. repeat split; auto.
      try_join i2 i3 i23'; equate_join i23 i23'. try_join i1 h2 i1h2. exists i23, i1h2. repeat split; auto.
    Defined.

    Definition twoSubTrees (x : adr) (w : world)
               (m : {l : adr & {r : adr | biEdge bi x = (l, r) /\ gValid x /\ (graph l * TT)%pred w /\
                                          (graph r * TT)%pred w}}) : list {t : adr | (graph t * TT)%pred w }.
      destruct m as [l [r [? [? [? ?]]]]].
      remember (exist (fun t => (graph t * TT)%pred w) l H1) as sl.
      remember (exist (fun t => (graph t * TT)%pred w) r H2) as sr.
      remember (sl :: sr :: nil) as lt; apply lt.
    Defined.

    Definition graph_sig_fun (w : world) := fun f => (graph f * TT)%pred w.

    Definition fetch (w : world) := proj1_sig (P := graph_sig_fun w).

    Fixpoint removeTree (w : world) (x : adr) (l : list {t : adr | (graph t * TT)%pred w}) :=
      match l with
        | nil => nil
        | y :: ttl => if eq_nat_dec x (proj1_sig y) then removeTree w x ttl else y :: removeTree w x ttl
      end.

    Lemma remove_tree_len_le: forall w x l, length (removeTree w x l) <= length l.
    Proof. induction l; simpl. trivial. destruct (eq_nat_dec x (proj1_sig a)); simpl; omega. Qed.

    Lemma remove_tree_sublist: forall w x l, Sublist (removeTree w x l) l.
    Proof.
      induction l; hnf; intros; simpl in *; auto. destruct a as [t Ht]; simpl in H. destruct (eq_nat_dec x t).
      subst. right. apply IHl; auto. destruct (in_inv H); [left | right]. auto. apply IHl; auto.
    Qed.

    Lemma remove_tree_not_in: forall w x l, ~ In x (map (fetch w) (removeTree w x l)).
    Proof.
      induction l; intro; simpl in * |-. apply H. destruct (eq_nat_dec x (proj1_sig a)). subst.
      apply IHl; auto. simpl in H. destruct H. intuition. apply IHl; auto.
    Qed.

    Lemma remove_tree_in: forall w x l y, y <> x -> In y (map (fetch w) l) -> In y (map (fetch w) (removeTree w x l)).
    Proof.
      induction l; intros; simpl in *. apply H0. destruct a as [a ?]. simpl in *. destruct (eq_nat_dec x a).
      destruct H0. subst. exfalso; apply H; auto. apply IHl; auto. simpl in *. destruct H0. left; auto.
      right. apply IHl; auto.
    Qed.

    Definition dup_input (w : world) := list {t : adr | (graph t * TT)%pred w}.

    Definition dupLength (w : world) (i : dup_input w) := length i.

    Definition dupOrder (w : world) (i1 i2 : dup_input w) := dupLength w i1 < dupLength w i2.

    Lemma dupOrder_wf': forall w len i, dupLength w i <= len -> Acc (dupOrder w) i.
    Proof.
      induction len; intros; constructor; intros; unfold dupOrder in * |-; [exfalso | apply IHlen]; intuition.
    Qed.

    Lemma dupOrder_wf (w : world) : well_founded (dupOrder w).
    Proof. red; intro; eapply dupOrder_wf'; eauto. Defined.

    Definition removeDup (w : world) : dup_input w -> dup_input w.
      refine (
            Fix (dupOrder_wf w) (fun _ => dup_input w)
                (fun (inp : dup_input w) =>
                   match inp return ((forall inp2 : dup_input w, (dupOrder w) inp2 inp -> (dup_input w)) -> dup_input w) with
                     | nil => fun _ => nil
                     | x :: l => fun f => x :: (f (removeTree w (proj1_sig x) l) _)
                   end)).
        apply le_lt_trans with (dupLength w l). apply remove_tree_len_le. simpl; apply lt_n_Sn.
    Defined.

    Lemma removeDup_unfold:
      forall w i,
        removeDup w i = match i with
                          | nil => nil
                          | x :: l => x :: removeDup w (removeTree w (proj1_sig x) l)
                        end.
    Proof.
      intros. unfold removeDup at 1; rewrite Fix_eq. destruct i; auto. intros.
      assert (f = g) by (extensionality y; extensionality p; auto); subst; auto.
    Qed.

    Lemma remove_dup_len_le: forall w l, length (removeDup w l) <= length l.
    Proof.
      intros w l. remember (length l). assert (length l <= n) by omega. clear Heqn. revert H. revert l.
      induction n; intros; rewrite removeDup_unfold; destruct l; auto. inversion H.
      simpl. apply le_n_S. apply IHn. simpl in H; apply le_S_n in H. apply le_trans with (length l).
      apply remove_tree_len_le. auto.
    Qed.

    Lemma remove_dup_sublist: forall w l1 l2, Sublist l1 l2 -> Sublist (removeDup w l1) l2.
    Proof.
      intros w l1. remember (length l1). assert (length l1 <= n) by omega. clear Heqn. revert H. revert l1.
      induction n; intros; rewrite removeDup_unfold; destruct l1. apply Sublist_nil. inversion H. apply Sublist_nil.
      rewrite <- (app_nil_l (removeDup w (removeTree w (proj1_sig s) l1))). rewrite app_comm_cons. apply Sublist_app_2.
      repeat intro. apply in_inv in H1. destruct H1. subst. specialize (H0 a). apply H0. apply in_eq. inversion H1.
      apply IHn. simpl in H. apply le_trans with (length l1). apply remove_tree_len_le. apply le_S_n. apply H.
      apply Sublist_trans with l1. apply remove_tree_sublist. repeat intro. apply H0. apply in_cons. apply H1.
    Qed.

    Lemma remove_dup_in_inv: forall w x l, In x (map (fetch w) l) -> In x (map (fetch w) (removeDup w l)).
    Proof.
      intros w x l. remember (length l). assert (length l <= n) by omega. clear Heqn. revert l H.
      induction n; intros; rewrite removeDup_unfold; destruct l; auto. simpl in H. omega. destruct s as [s ?].
      simpl in *. destruct (eq_nat_dec x s); destruct H0. left; auto. left; auto. exfalso; apply n0; auto.
      right. apply IHn. apply le_trans with (length l). apply remove_tree_len_le. omega. apply remove_tree_in; auto.
    Qed.

    Lemma remove_dup_nodup: forall w l, NoDup (map (fetch w) (removeDup w l)).
    Proof.
      intros w l. remember (length l). assert (length l <= n) by omega. clear Heqn. revert H. revert l.
      induction n; intros; rewrite removeDup_unfold; destruct l; simpl. apply NoDup_nil. inversion H. apply NoDup_nil.
      apply NoDup_cons. generalize (remove_tree_not_in w (proj1_sig s) l); intro. intro; apply H0; clear H0.
      apply (map_sublist _ _ (fetch w)
                         (removeDup w (removeTree w (proj1_sig s) l)) (removeTree w (proj1_sig s) l)).
      apply remove_dup_sublist. apply Sublist_refl. auto.
      apply IHn. simpl in H. apply le_trans with (length l). apply remove_tree_len_le. apply le_S_n. apply H.
    Qed.

    Fixpoint appRemoveList (w : world) (lc la : list {t : adr | (graph t * TT)%pred w}) (lb : list adr) :=
      match lb with
        | nil => removeDup w (lc ++ la)
        | x :: l => appRemoveList w lc (removeTree w x la) l
      end.

    Lemma remove_list_len_le: forall w lb lc la, length (appRemoveList w lc la lb) <= length lc + length la.
    Proof.
      induction lb; intros; simpl. apply le_trans with (length (lc ++ la)). apply remove_dup_len_le.
      rewrite app_length; trivial.
      apply le_trans with (length lc + length (removeTree w a la)). apply IHlb.
      apply plus_le_compat_l, remove_tree_len_le.
    Qed.

    Lemma remove_list_sublist: forall w lb lc la, Sublist (appRemoveList w lc la lb) (lc ++ la).
    Proof.
      induction lb; intros; hnf; intros; simpl in *; auto. apply (remove_dup_sublist w (lc ++ la) (lc ++ la)).
      apply Sublist_refl. apply H. specialize (IHlb lc (removeTree w a la) a0 H).
      destruct (in_app_or _ _ _ IHlb); apply in_or_app; [left | right]. auto.
      generalize (remove_tree_sublist w a la); intro Hr; hnf in Hr; apply Hr; auto.
    Qed.

    Lemma remove_list_no_dup: forall w lb lc la, NoDup (map (fetch w) (appRemoveList w lc la lb)).
    Proof. induction lb; intros; simpl. apply remove_dup_nodup. apply IHlb. Qed.

    Lemma remove_list_not_in: forall w lb lc la, exists ld, (appRemoveList w lc la lb = removeDup w (lc ++ ld)) /\
                                                            Sublist ld la /\ forall x, In x lb -> ~ In x (map (fetch w) ld).
    Proof.
      induction lb; intros; simpl. exists la. repeat split. apply Sublist_refl. intros. auto.
      destruct (IHlb lc (removeTree w a la)) as [ld [? [? ?]]]. exists ld. repeat split; auto.
      apply Sublist_trans with (removeTree w a la). auto. apply remove_tree_sublist. intro y; intros.
      destruct H2; auto. subst. apply map_sublist with (f := fetch w) in H0. intro.
      specialize (H0 y H2). apply remove_tree_not_in in H0. auto.
    Qed.

    Lemma remove_list_in: forall w lb lc la a x, x <> a -> (~ In x lb) -> In x (map (fetch w) la) ->
                                                 In x (map (fetch w) (appRemoveList w lc (removeTree w a la) lb)).
    Proof.
      induction lb; intros; simpl. assert (In x (map (fetch w) (lc ++ removeTree w a la))). rewrite map_app.
      apply in_or_app; right. apply remove_tree_in; auto. apply remove_dup_in_inv. auto. apply IHlb.
      intro; apply H0; subst; apply in_eq. intro; apply H0; apply in_cons; auto. apply remove_tree_in; auto.
    Qed.

    Lemma remove_list_in_2: forall w lb lc la x, In x (map (fetch w) lc) -> In x (map (fetch w) (appRemoveList w lc la lb)).
    Proof.
      induction lb; intros; simpl. apply remove_dup_in_inv. rewrite map_app. apply in_or_app. left; auto. apply IHlb. auto.
    Qed.

    Definition graph_zero : forall (w : world), (graph 0 * TT)%pred w.
      intros. exists (core w), w; repeat split. apply core_unit. rewrite graph_unfold.
      left; hnf. split; auto. apply core_identity.
    Defined.

    Definition reach_input (w : world) := (nat * list {t : adr | (graph t * TT)%pred w} * list adr )%type.

    Definition lengthInput (w : world) (i : reach_input w) :=
      match i with
        | (len, pr, re) => 2 * len + length pr - 2 * length re
      end.

    Definition inputOrder (w : world) (i1 i2 : reach_input w) := lengthInput w i1 < lengthInput w i2.

    Lemma inputOrder_wf': forall w len i, lengthInput w i <= len -> Acc (inputOrder w) i.
    Proof.
      induction len; intros; constructor; intros; unfold inputOrder in * |-; [exfalso | apply IHlen]; intuition.
    Qed.

    Lemma inputOrder_wf (w : world) : well_founded (inputOrder w).
    Proof. red; intro; eapply (inputOrder_wf' w); eauto. Defined.

    Definition extractReach (w : world) : reach_input w -> list adr.
      refine (
          Fix (inputOrder_wf w) (fun _ => list adr)
              (fun (inp : reach_input w) =>
                 match inp return ((forall inp2, inputOrder w inp2 inp -> list adr) -> list adr) with
                   | (_, nil, r) => fun _ => r
                   | (len, g :: l, r) => fun f =>
                                           if le_dec len (length r)
                                           then r
                                           else match explode (proj1_sig g) w (proj2_sig g) with
                                                  | inleft hasNodes =>
                                                    let subT := twoSubTrees (proj1_sig g) w hasNodes in let m := (proj1_sig g) :: r in let newL := appRemoveList w l subT m in f (len, newL, m) _
                                                  | inright _ => f (len, l, r) _
                                                end
                 end)).
      destruct hasNodes as [leftT [rightT [? [? [? ?]]]]]. destruct g as [x ?]. simpl in subT.
      unfold newL, inputOrder, lengthInput. generalize (remove_list_len_le w m l subT); intro.
      apply le_lt_trans with (len + len + length l + length subT - S (length r + S (length r))).
      unfold m at 2. simpl length at 2. omega. simpl. omega.
      unfold inputOrder, lengthInput; simpl; repeat rewrite <- plus_n_O. omega.
    Defined.

    Lemma extractReach_unfold:
      forall w i,
        extractReach w i = match i with
                             | (_, nil, r) => r
                             | (len, g :: l, r) =>
                               if le_dec len (length r)
                               then r
                               else match explode (proj1_sig g) w (proj2_sig g) with
                                      | inleft hasNodes => let subT := twoSubTrees (proj1_sig g) w hasNodes in
                                                           let newL := appRemoveList w l subT (proj1_sig g :: r) in
                                                           extractReach w (len, newL, (proj1_sig g) :: r)
                                      | inright _ => extractReach w (len, l, r)
                                    end
                           end.
    Proof.
      intros. destruct i as [[n prs] rslt]. unfold extractReach at 1; rewrite Fix_eq.
      destruct prs; simpl. auto. destruct (le_dec n (length rslt)). auto.
      destruct (explode (proj1_sig s) w (proj2_sig s)); unfold extractReach; auto.
      intros; assert (f = g) by (extensionality y; extensionality p; auto); subst; auto.
    Qed.

    Definition rch1 w (i : reach_input w) := match i with (n, _, _) => n end.

    Definition rch2 w (i : reach_input w) := match i with (_, l, _) => l end.

    Definition rch3 w (i: reach_input w) := match i with (_, _, result) => result end.

    Lemma extractReach_reachable:
      forall w (i : reach_input w) (x : adr),
        Forall (reachable pg x) (rch3 w i) ->
        Forall (fun y => reachable pg x y \/ y = 0) (map (fetch w) (rch2 w i)) ->
        Forall (reachable pg x) (extractReach w i).
    Proof.
      intros w i x; remember (lengthInput w i); assert (lengthInput w i <= n) by omega; clear Heqn; revert H x; revert i.
      induction n; intros; remember (extractReach w i) as result;
      rename Heqresult into H3; destruct i as [[len pr] rslt]; unfold rch2, rch3, lengthInput in *;
      simpl in *; rewrite extractReach_unfold in H3; destruct pr; simpl in H3. subst; apply H0; auto.
      destruct (le_dec len (length rslt)). subst; apply H0; auto. exfalso; omega.

      subst; apply H0; auto. destruct (le_dec len (length rslt)). subst; apply H0; auto.
      destruct s as [t Ht]; simpl in *. destruct (explode t w Ht). remember (twoSubTrees t w s) as subT.
      destruct s as [l [r [? [? [Gl Gr]]]]]. simpl in HeqsubT. assert (reachable pg x t) as HRt.
      destruct (Forall_inv H1); auto. apply valid_not_zero in g; exfalso; auto. rewrite H3; apply IHn; simpl.
      apply le_trans with (len + (len + 0) + length pr + length (removeTree w t subT) - S (length rslt + S (length rslt + 0))).
      generalize (remove_list_len_le w rslt pr (removeTree w t subT)); intros. omega.
      generalize (remove_tree_len_le w t subT); intros. rewrite HeqsubT in H2 at 2. simpl in H2. omega.
      apply Forall_cons; auto.
      assert (Sublist (appRemoveList w pr (removeTree w t subT) rslt) (pr ++ subT)).
      apply Sublist_trans with (pr ++ (removeTree w t subT)). apply remove_list_sublist.
      apply Sublist_app. apply Sublist_refl. apply remove_tree_sublist.
      generalize (map_sublist _ _ (fetch w) _ _ H2); intros; clear H2. rewrite map_app in H4.
      apply (Forall_sublist _ _ _ H4); clear H4. apply Forall_app. apply Forall_tl in H1; auto.
      rewrite HeqsubT; simpl. rewrite Forall_forall. intro y; intros.

      destruct (in_inv H2). subst. destruct Gl as [wl [_ [_ [? _]]]]. rewrite graph_unfold in H3.
      destruct H3 as [[? ?] | [dd [ll [rr ?]]]]; [right; auto| left]. destruct_ocon H3 h. destruct_ocon H6 j.
      destruct H10 as [[? ?] ?]. apply reachable_by_merge with t. auto. exists (t :: y :: nil). hnf.
      split; split; simpl; auto. split. unfold biEdge in e. split. apply reachable_foot_valid in HRt. auto. split.
      apply H12. destruct (@only_two_neighbours nat nat natEqDec pg bi t) as [v1 [v2 HHH]]. inversion e; subst; clear e.
      rewrite HHH. apply in_eq. auto. repeat intro. hnf. auto. clear H2.

      destruct (in_inv H4). subst. destruct Gr as [wr [_ [_ [? _]]]]. rewrite graph_unfold in H2.
      destruct H2 as [[? ?] | [dd [ll [rr ?]]]]; [right; auto| left]. destruct_ocon H2 h. destruct_ocon H6 j.
      destruct H10 as [[? ?] ?]. apply reachable_by_merge with t. auto. exists (t :: y :: nil). hnf.
      split; split; simpl; auto. split. unfold biEdge in e. split. apply reachable_foot_valid in HRt. auto. split.
      apply H12. destruct (@only_two_neighbours nat nat natEqDec pg bi t) as [v1 [v2 HHH]]. inversion e; subst; clear e.
      rewrite HHH. apply in_cons, in_eq. auto. repeat intro. hnf. auto. inversion H2.

      rewrite H3; apply IHn; simpl; clear IHn H3 result; auto. omega. rewrite Forall_forall in H1. rewrite Forall_forall.
      intros. apply H1. apply in_cons; auto.
    Qed.

    Lemma extractReach_nodup: forall w i, NoDup ((map (fetch w) (rch2 w i)) ++ (rch3 w i)) -> NoDup (extractReach w i).
    Proof.
      intros w i; remember (lengthInput w i); assert (lengthInput w i <= n) by omega; clear Heqn; revert H. revert i.
      induction n; intros; remember (extractReach w i) as result; rename Heqresult into H1;
      destruct i as [[len pr] rslt]; unfold rch3, lengthInput in *;
      simpl in *; rewrite extractReach_unfold in H1; destruct pr; simpl in H1. subst; auto.
      destruct (le_dec len (length rslt)). subst; apply NoDup_app_r in H0; auto. simpl in H; exfalso; omega. subst; auto.
      destruct (le_dec len (length rslt)). subst; apply NoDup_app_r in H0; auto. destruct s as [t Ht]. simpl in *.
      destruct (explode t w Ht). subst; apply IHn. simpl. repeat rewrite <- plus_n_O.
      apply le_trans with (len + len + length pr + length (twoSubTrees t w s) - S (length rslt + S (length rslt))).
      generalize (remove_list_len_le w rslt pr (removeTree w t (twoSubTrees t w s))); intro;
      generalize (remove_tree_len_le w t (twoSubTrees t w s)); intro; omega.
      destruct s as [leftT [rightT [? [? [? ?]]]]]; simpl; omega. simpl. generalize (NoDup_cons_1 _ _ _ H0); intro.
      apply NoDup_cons_2 in H0. rewrite NoDup_app_eq in H1. destruct H1 as [? [? ?]]. apply NoDup_app_inv.
      apply remove_list_no_dup. apply NoDup_cons. intro; apply H0. apply in_or_app. right; auto. auto.
      intros. destruct (remove_list_not_in w rslt pr (removeTree w t (twoSubTrees t w s))) as [la [? [? ?]]].
      rewrite H5 in H4; clear H5. assert (Sublist (removeDup w (pr ++ la)) (pr ++ la)). apply remove_dup_sublist.
      apply Sublist_refl. apply map_sublist with (f := fetch w) in H5. specialize (H5 x H4). clear H4. rewrite map_app in H5.
      apply in_app_or in H5. intro. apply in_inv in H4. destruct H5, H4. subst. apply H0. apply in_or_app. left; auto.
      specialize (H3 x H5). apply H3; auto. subst. apply map_sublist with (f := fetch w) in H6. specialize (H6 x H5).
      generalize (remove_tree_not_in w x (twoSubTrees x w s)); intro. apply H4; auto. specialize (H7 x H4). auto.
      subst; apply IHn. omega. simpl. rewrite <- (app_nil_l ((map (fetch w) pr) ++ rslt)) in H0. rewrite app_comm_cons in H0.
      apply NoDup_app_r in H0. auto.
    Qed.

    Definition NotNone (w : world) (e : adr) : Prop := lookup_fpm w e <> None.

    Lemma extractReach_all_not_none: forall w i, Forall (NotNone w) (rch3 w i) -> Forall (NotNone w) (extractReach w i).
    Proof.
      intros w i; remember (lengthInput w i); assert (lengthInput w i <= n) by omega; clear Heqn; revert H. revert i.
      induction n; intros; remember (extractReach w i) as result;
      rename Heqresult into H3; destruct i as [[len pr] rslt]; unfold rch2, rch3, lengthInput in *;
      simpl in *; rewrite extractReach_unfold in H3; destruct pr; simpl in H3. subst; apply H0; auto.
      destruct (le_dec len (length rslt)). subst; auto. exfalso; omega. subst; auto.
      destruct (le_dec len (length rslt)). subst; auto. destruct s as [t Ht]. simpl in *.
      destruct (explode t w Ht). rewrite H3. apply IHn. repeat rewrite <- plus_n_O. simpl.
      apply le_trans with (len + len + length pr + length (twoSubTrees t w s) - S (length rslt + S (length rslt))).
      generalize (remove_list_len_le w rslt pr (removeTree w t (twoSubTrees t w s))); intro;
      generalize (remove_tree_len_le w t (twoSubTrees t w s)); intro; omega.
      destruct s as [leftT [rightT [? [? [? ?]]]]]; simpl; omega. constructor. clear H3.
      destruct s as [leftT [rightT [? [? [? ?]]]]]. generalize (valid_not_zero _ H2); intro. destruct_sepcon Ht w.
      rewrite graph_unfold in H7.
      destruct H7 as [[? ?] | [dd [ll [rr ?]]]]. exfalso; intuition. destruct_ocon H7 h. destruct_ocon H11 j.
      destruct H15. destruct_sepcon H17 k. destruct_sepcon H18 l. destruct H20 as [Hd [? [? ?]]].
      apply lookup_fpm_join_sub with l1. try_join l2 k2 l2k2. try_join l2k2 j3 l2k2j3. try_join l2k2j3 h3 l2k2j3h3.
      try_join l2k2j3h3 w2 l2k2j3h3w2. exists l2k2j3h3w2. auto. rewrite H23. intro S; inversion S. auto.
      rewrite H3. apply IHn. omega. auto.
    Qed.

    Lemma extractReach_length_bound: forall w i, length (rch3 w i) <= rch1 w i -> length (extractReach w i) <= rch1 w i.
    Proof.
      intros w i; remember (lengthInput w i); assert (lengthInput w i <= n) by omega; clear Heqn; revert H. revert i.
      induction n; intros; remember (extractReach w i) as result;
      rename Heqresult into H3; destruct i as [[len pr] rslt]; unfold rch3, lengthInput in *;
      simpl in *; rewrite extractReach_unfold in H3; destruct pr; simpl in H3. subst; auto. simpl in H; exfalso; omega.
      subst; auto. destruct (le_dec len (length rslt)). subst; auto. destruct s as [t Ht]. simpl in *.
      destruct (explode t w Ht).
      specialize (IHn (len, appRemoveList w pr (removeTree w t (twoSubTrees t w s)) rslt, t :: rslt)). simpl in IHn.
      rewrite H3. apply IHn. repeat rewrite <- plus_n_O in *.
      apply le_trans with (len + len + length pr + length (twoSubTrees t w s) - S (length rslt + S (length rslt))).
      generalize (remove_list_len_le w rslt pr (removeTree w t (twoSubTrees t w s))); intro;
      generalize (remove_tree_len_le w t (twoSubTrees t w s)); intro; omega.
      destruct s as [leftT [rightT [? [? [? ?]]]]]; simpl; omega. omega. rewrite H3; apply IHn. omega. unfold rch1. omega.
    Qed.

    Lemma extractReach_sublist: forall w i, Sublist (rch3 w i) (extractReach w i).
    Proof.
      intros w i; remember (lengthInput w i); assert (lengthInput w i <= n) by omega; clear Heqn; revert H. revert i.
      induction n; intros; remember (extractReach w i) as result;
      rename Heqresult into H3; destruct i as [[len pr] rslt]; unfold rch3, lengthInput in *;
      simpl in *; rewrite extractReach_unfold in H3; destruct pr; simpl in H3. subst; apply Sublist_refl.
      destruct (le_dec len (length rslt)). subst. apply Sublist_refl. simpl in H; omega. subst; apply Sublist_refl.
      destruct (le_dec len (length rslt)). subst. apply Sublist_refl. destruct s as [t Ht]; simpl in *.
      destruct (explode t w Ht).
      specialize (IHn (len, appRemoveList w pr (removeTree w t (twoSubTrees t w s)) rslt, t :: rslt)). simpl in IHn.
      assert (Sublist (t :: rslt) (extractReach w (len, appRemoveList w pr (removeTree w t (twoSubTrees t w s)) rslt,
                                                   t :: rslt))).
      apply IHn. repeat rewrite <- plus_n_O in *.
      apply le_trans with (len + len + length pr + length (twoSubTrees t w s) - S (length rslt + S (length rslt))).
      generalize (remove_list_len_le w rslt pr (removeTree w t (twoSubTrees t w s))); intro;
      generalize (remove_tree_len_le w t (twoSubTrees t w s)); intro; omega.
      destruct s as [leftT [rightT [? [? [? ?]]]]]; simpl; omega. rewrite <- H3 in H0. intro y; intros.
      apply (H0 y). apply in_cons; auto. specialize (IHn (len, pr, rslt)); simpl in IHn. rewrite H3. apply IHn.
      simpl in H; omega.
    Qed.

    Definition ProcessingInResult (l1 l2 : list adr) : Prop := forall x y, In x l1 -> reachable pg x y -> In y l2.

    Lemma PIR_cons: forall a l1 l2, (forall y, reachable pg a y -> In y l2) -> ProcessingInResult l1 l2 ->
                                    ProcessingInResult (a :: l1) l2.
    Proof. repeat intro; apply in_inv in H1; destruct H1. subst. apply H; auto. apply (H0 x); auto. Qed.

    Lemma PIR_sublist: forall l1 l2 l3, Sublist l1 l2 -> ProcessingInResult l2 l3 -> ProcessingInResult l1 l3.
    Proof. repeat intro. specialize (H x H1). apply (H0 x y); auto. Qed.

    Definition ResultInProcessing (l1 l2 : list adr) : Prop := forall x y, In x l1 -> edge pg x y -> In y l1 \/ In y l2.

    Lemma neg_eq_in_neq_nin: forall a (l : list adr) x, ~ (a = x \/ In x l) -> x <> a /\ ~ In x l.
    Proof. intros; split. destruct (eq_nat_dec x a); auto. destruct (in_dec eq_nat_dec x l); auto. Qed.

    Fixpoint findNotIn (l1 l2 l3: list adr) : (option adr * (list adr * list adr)) :=
      match l1 with
        | nil => (None, (nil, nil))
        | x :: l => if (in_dec eq_nat_dec x l2) then findNotIn l l2 (x :: l3) else (Some x, (rev l3, l))
      end.

    Lemma find_not_in_none: forall l1 l2 l3, fst (findNotIn l1 l2 l3) = None -> Forall (fun m => In m l2) l1.
    Proof.
      induction l1; intros. apply Forall_nil. simpl in H. destruct (in_dec eq_nat_dec a l2).
      apply Forall_cons. auto. apply IHl1 with (a :: l3); auto. inversion H.
    Qed.

    Lemma find_not_in_some_explicit:
      forall l1 l2 l3 x li1 li2,
        findNotIn l1 l2 l3 = (Some x, (li1, li2)) -> (Forall (fun m => In m l2) l3) ->
        (~ In x li1) /\ (~ In x l2) /\ exists l4, li1 = rev l3 ++ l4 /\ Forall (fun m => In m l2) l4 /\ l1 = l4 ++ x :: li2.
    Proof.
      induction l1; intros; simpl in H. inversion H. destruct (in_dec eq_nat_dec a l2).
      assert (Forall (fun m : adr => In m l2) (a :: l3)) by (apply Forall_cons; auto).
      specialize (IHl1 l2 (a :: l3) x li1 li2 H H1). destruct IHl1 as [? [? [l4 [? [? ?]]]]]. split; auto. split; auto.
      exists (a :: l4). repeat split; auto. simpl in H4. rewrite <- app_assoc in H4. rewrite <- app_comm_cons in H4.
      rewrite app_nil_l in H4. auto. rewrite H6; apply app_comm_cons. inversion H. split. intro; apply n.
      rewrite Forall_forall in H0. apply (H0 a). rewrite H2. rewrite in_rev. auto. split. rewrite <- H2. auto.
      exists nil. repeat split; auto. rewrite app_nil_r. auto.
    Qed.

    Lemma find_not_in_some:
      forall l1 l2 x li1 li2,
        findNotIn l1 l2 nil = (Some x, (li1, li2)) ->
        Forall (fun m => In m l2) li1 /\ l1 = li1 ++ x :: li2 /\ ~ In x li1 /\ ~ In x l2.
    Proof.
      intros. assert (Forall (fun m : adr => In m l2) nil) by apply Forall_nil.
      destruct (find_not_in_some_explicit l1 l2 nil x li1 li2 H H0). destruct H2 as [? [l4 [? [? ?]]]].
      simpl in H3. rewrite H3 in *. repeat split; auto.
    Qed.

    Lemma foot_none_nil: forall (l : list adr), foot l = None -> l = nil.
    Proof. induction l; intros; auto. simpl in H. destruct l. inversion H. specialize (IHl H). inversion IHl. Qed.

    Lemma reachable_by_path_split_dec:
      forall p a b P rslt,
        pg |= p is a ~o~> b satisfying P -> {Forall (fun m => In m (a :: rslt)) p} +
                                            {exists l1 l2 e1 s2, Forall (fun m => In m (a :: rslt)) l1 /\
                                                                 pg |= l1 is a ~o~> e1 satisfying P /\
                                                                 pg |= l2 is s2 ~o~> b satisfying P /\
                                                                 edge pg e1 s2 /\ ~ In s2 (a::rslt) /\ p = l1 ++ l2 /\
                                                                 ~ In s2 l1}.
    Proof.
      intros. remember (findNotIn p (a :: rslt) nil) as f. destruct f as [n [l1 l2]]. destruct n. right.
      apply eq_sym in Heqf. destruct (find_not_in_some _ _ _ _ _ Heqf) as [? [? [? ?]]]. exists l1, (a0 :: l2).
      rewrite Forall_forall in H0. destruct l1. rewrite app_nil_l in H1.
      generalize (reachable_by_path_head _ _ _ _ _ _ _ _ H); intro. rewrite H1 in *. simpl in H4. inversion H4.
      rewrite H6 in *. exfalso; apply H3; apply in_eq.
      generalize (reachable_by_path_head _ _ _ _ _ _ _ _ H); intro.
      rewrite <- app_comm_cons in H1. rewrite H1 in H4. simpl in H4. inversion H4. rewrite H6 in *. clear H4 H6 a1.
      remember (foot (a :: l1)). destruct o. exists n, a0. split. rewrite Forall_forall; auto.
      assert (paths_meet_at adr (a :: l1) (n :: a0 :: l2) n) by (repeat split; auto).
      assert (pg |= path_glue adr (a :: l1) (n :: a0 :: l2) is a ~o~> b satisfying P). unfold path_glue. simpl.
      rewrite <- H1. auto. destruct (reachable_by_path_split_glue _ _ _ _ _ _ _ _ _ _ H4 H5). clear H4 H5. split; auto.
      assert (paths_meet_at adr (n :: a0 :: nil) (a0 :: l2) a0) by repeat split.
      assert (pg |= path_glue adr (n :: a0 :: nil) (a0 :: l2) is n ~o~> b satisfying P). unfold path_glue. simpl. auto.
      destruct (reachable_by_path_split_glue _ _ _ _ _ _ _ _ _ _ H4 H5). clear H4 H5 H6 H7. split; auto.
      split. destruct H8. destruct H5. destruct H5. auto. split. auto. split; simpl; auto.
      apply eq_sym in Heqo. generalize (foot_none_nil (a :: l1) Heqo); intros. inversion H4.
      assert (fst (findNotIn p (a :: rslt) nil) = None) by (rewrite <- Heqf; simpl; auto). left.
      apply find_not_in_none with nil. auto.
    Qed.

    Lemma extractReach_contains_all:
      forall w i, ResultInProcessing (rch3 w i) (map (fetch w) (rch2 w i)) -> length (extractReach w i) < rch1 w i ->
                  ProcessingInResult (map (fetch w) (rch2 w i)) (extractReach w i).
    Proof.
      intros w i; remember (lengthInput w i); assert (lengthInput w i <= n) by omega; clear Heqn; revert H. revert i.
      induction n; intros; remember (extractReach w i) as result; rename Heqresult into H3;
      destruct i as [[len pr] rslt]; unfold rch1, rch2, rch3, lengthInput in *; simpl in *; rewrite extractReach_unfold in H3;
      destruct pr; simpl in *. subst; omega. destruct (le_dec len (length rslt)). subst; omega. omega.
      repeat intro; inversion H2. destruct (le_dec len (length rslt)). subst. omega. destruct s as [t Ht]. simpl in *.
      destruct (explode t w Ht).
      assert (ProcessingInResult (map (fetch w) (appRemoveList w pr (removeTree w t (twoSubTrees t w s)) rslt)) result).
      specialize (IHn (len, appRemoveList w pr (removeTree w t (twoSubTrees t w s)) rslt, t :: rslt)). simpl in IHn.
      rewrite H3; apply IHn; clear IHn.
      apply le_trans with (len + len + length pr + length (twoSubTrees t w s) - S (length rslt + S (length rslt))).
      generalize (remove_list_len_le w rslt pr (removeTree w t (twoSubTrees t w s))); intro;
      generalize (remove_tree_len_le w t (twoSubTrees t w s)); intro; omega.
      destruct s as [leftT [rightT [? [? [? ?]]]]]; simpl; omega. repeat intro; destruct (in_dec eq_nat_dec y (t :: rslt)).
      left; auto. right. remember (twoSubTrees t w s) as subT. apply neg_eq_in_neq_nin in n1. destruct n1.
      apply in_inv in H2. destruct H2. rewrite <- H2 in *. clear H2.
      destruct H4 as [? [? ?]]. destruct s as [lT [rT [? [? [? ?]]]]]. simpl in *. unfold biEdge in e.
      destruct (@only_two_neighbours nat nat natEqDec pg bi t) as [v1 [v2 HHH]]. inversion e. rewrite H9 in *.
      rewrite H10 in *. clear H9 H10 v1 v2. rewrite HHH in H7.
      assert (In y (map (fetch w) subT)) by (rewrite HeqsubT; simpl in *; apply H7). apply remove_list_in; auto.
      specialize (H0 x y H2 H4). destruct H0. exfalso; apply H6; auto. apply in_inv in H0. destruct H0. exfalso.
      apply H5; auto. apply remove_list_in_2. auto. rewrite H3 in H1; auto.

      apply PIR_cons. intros. unfold reachable in H4. destruct H4 as [p ?].
      destruct (reachable_by_path_split_dec _ _ _ _ rslt H4). rewrite Forall_forall in f. apply reachable_by_path_foot in H4.
      apply foot_in in H4. specialize (f _ H4). rewrite H3. apply (extractReach_sublist _ _ y). simpl. simpl in f. auto.
      destruct e as [l1 [l2 [e1 [s1 [? [? [? [? [? [? ?]]]]]]]]]]. rewrite Forall_forall in H5.
      destruct (eq_nat_dec e1 t). rewrite e in *; clear e e1. destruct H8 as [? [? ?]]. remember (twoSubTrees t w s) as subT.
      destruct s as [lT [rT [? [? [? ?]]]]]. simpl in *. unfold biEdge in e.
      destruct (@only_two_neighbours nat nat natEqDec pg bi t) as [v1 [v2 HHH]]. inversion e. rewrite H15 in *.
      rewrite H16 in *. clear H15 H16 v1 v2. rewrite HHH in H13. assert (In s1 (map (fetch w) subT)). rewrite HeqsubT.
      simpl map. auto. apply (H2 s1 y). apply neg_eq_in_neq_nin in H9. destruct H9. apply remove_list_in; auto.
      exists l2. auto. apply reachable_by_path_foot in H6. apply foot_in in H6. specialize (H5 e1 H6). apply in_inv in H5.
      destruct H5. exfalso; auto. specialize (H0 e1 s1 H5 H8). simpl in H9. apply neg_eq_in_neq_nin in H9; destruct H9.
      destruct H0. exfalso; auto. apply in_inv in H0. destruct H0. exfalso; auto. apply (H2 s1 y). apply remove_list_in_2.
      auto. exists l2. auto.
      apply PIR_sublist with (map (fetch w) (appRemoveList w pr (removeTree w t (twoSubTrees t w s)) rslt)); auto.
      intro y; intros. apply remove_list_in_2; auto. apply PIR_cons. intros. apply reachable_is_valid in H2.
      apply valid_not_zero in H2. omega. rewrite H3. specialize (IHn (len, pr, rslt)). simpl in IHn. apply IHn. omega.
      repeat intro. specialize (H0 x y H2 H4). destruct H0; [left | right]. auto. apply in_inv in H0. destruct H0.
      subst. destruct H4 as [? [? ?]]. apply valid_not_zero in H3. omega. auto. rewrite H3 in H1. auto.
    Qed.

  End ConstructReachable.

  Lemma graph_reachable_finite:
    forall x w, graph x w -> exists (l : list adr), NoDup l /\ forall y, (In y l -> reachable pg x y) /\
                                                                         (~ In y l -> ~ reachable pg x y).
  Proof.
    intros. hnf. destruct (world_finite w) as [l ?].
    generalize (core_unit w); intros. unfold unit_for in H1. apply join_comm in H1.
    assert ((graph x * TT)%pred w) by (exists w, (core w); repeat split; auto).
    remember (exist (graph_sig_fun w) x H2) as g. remember (length l, (g::nil), nil : list adr) as s.
    assert (Forall (reachable pg x) (extractReach w s)). apply extractReach_reachable.
    unfold rch3; rewrite Heqs; simpl; apply Forall_nil. unfold rch2; rewrite Heqs; rewrite Heqg; simpl.
    apply Forall_forall; intros. apply in_inv in H3; destruct H3. subst. assert (graph x0 w) by auto.
    rewrite graph_unfold in H. destruct H as [[? ?] | [dd [ll [rr ?]]]]. hnf in H; right; auto. left.
    apply reachable_by_reflexive. split. destruct_ocon H h. destruct_ocon H6 j. destruct H10 as [[? ?] ?].
    apply H12. hnf; auto. inversion H3. exists (extractReach w s). assert (NoDup (extractReach w s)) as Hn.
    apply extractReach_nodup. rewrite Heqs. simpl. apply NoDup_cons. auto. apply NoDup_nil. split. auto.
    intros y; split; intros. rewrite Forall_forall in H3. apply H3. auto.

    intro. assert (Sublist (extractReach w s) l) as Hs. assert (Forall (NotNone w) (extractReach w s)).
    apply extractReach_all_not_none; rewrite Heqs; simpl; apply Forall_nil. rewrite Forall_forall in H6.
    unfold NotNone in H6. intro z; intros. rewrite H0. apply H6. auto. assert (In y l) as Hy.
    generalize (graph_reachable_in _ _ H5). intros. specialize (H6 w H). hnf in H6. destruct H6 as [b ?].
    destruct_sepcon H6 h. destruct H7 as [? [? ?]]. assert (lookup_fpm w y <> None). apply lookup_fpm_join_sub with h1.
    exists h2; auto. rewrite H10. intro S; inversion S. rewrite <- H0 in H11. auto. apply H4.
    generalize (extractReach_length_bound w s); intro. rewrite Heqs in H6 at 1 2; simpl in H6.
    assert (0 <= length l) as S by omega; specialize (H6 S); clear S. apply le_lt_eq_dec in H6. destruct H6.
    assert (ResultInProcessing (rch3 w s) (map (fetch w) (rch2 w s))). rewrite Heqs; simpl. repeat intro. inversion H6.
    generalize (extractReach_contains_all w s H6 l0); intro. rewrite Heqs in H7 at 1. rewrite Heqg in H7. simpl in H7.
    apply (H7 x y); auto. apply in_eq. rewrite Heqs in e at 2; simpl in e.
    apply (sublist_reverse eq_nat_dec (extractReach w s) l Hn e Hs y Hy).
  Qed.

End PointwiseGraph.


(* Check that "dependent inversion" behaves correctly w.r.t to universes *)

Require Import Eqdep.

Set Implicit Arguments.

Inductive illist(A:Type) : nat -> Type :=
  illistn : illist A 0
| illistc : forall n:nat, A -> illist A n -> illist A (S n).

Inductive isig (A:Type)(P:A -> Type) : Type :=
  iexists : forall x : A, P x -> isig P.

Lemma inv : forall (A:Type)(n n':nat)(ts':illist A n'), n' = S n ->
  isig (fun t => isig (fun ts =>
    eq_dep nat (fun n => illist A n) n' ts' (S n) (illistc t ts))).
Proof.
intros.
dependent inversion ts'.


Require Import ZProperty Confluence LambdaES lx CompositionProblemLemmas OpenPoints Lia.

Require Import Arith MSetList Setoid Lia.

Lemma open_rec_swap_term: forall t t' x i j, i <> j -> term t' -> {j ~> pterm_fvar x} ({i ~> t'} t) = {i ~> t'}({j ~> pterm_fvar x} t).
Proof.
  intro t; induction t.
  - intros t' x i j Hneq Hterm.
    simpl.
    destruct (i =? n) eqn: Hni.
    + destruct (j =? n) eqn: Hnj.
      * admit. (* ok *)
      * admit. (* ok *)
    + destruct (j =? n) eqn: Hnj.
      * simpl.
        rewrite Hnj.
        reflexivity.
      * simpl.
        rewrite Hni.
        rewrite Hnj.
        reflexivity.
  - intros t' x i j Hneq Hterm.
    reflexivity.
  - intros t' x i j Hneq Hterm.
     simpl.
     rewrite IHt1.
     + rewrite IHt2.
       * reflexivity.
       * assumption.
       * assumption.
     + assumption.
     + assumption.
  - intros t' x i j Hneq Hterm.
    simpl.
    rewrite IHt.
    + reflexivity.
    + lia.
    + assumption.
  - intros t' x i j Hneq Hterm.
    simpl.
    rewrite IHt1.
    + rewrite IHt2.
      * reflexivity.
      * assumption.
      * assumption.
    + lia.
    + assumption.
Admitted.

Lemma open_rec_swap_eq: forall t t' x n, {n ~> pterm_fvar x} ({n ~> t'} t) = { n ~> { n ~> pterm_fvar x} t'} t.
Proof.
  intro t; induction t.
  - intros t x n'.
    simpl.
    destruct (n' =? n) eqn:H.
    + reflexivity.
    + simpl.
      rewrite H; reflexivity.
  - intros t x n.
    reflexivity.
  - intros t x n.
    simpl.
    rewrite IHt1.
    rewrite IHt2.
    reflexivity.
  - intros.
    simpl.
    rewrite IHt.
Admitted.  (* problema da composicionalidade *)

Lemma open_rec_swap_neq': forall t t' x i j, i <> j -> {j ~> pterm_fvar x} ({i ~> t'} t) = {i ~> {j ~> pterm_fvar x} t'}({S j ~> pterm_fvar x} t).
Proof.
  intro t; induction t.
  - intros.
    simpl.
    destruct (i =? n) eqn:Hni.
    + destruct (j =? n) eqn:Hnj.
      * admit.
      * admit.
    + destruct (j =? n) eqn:Hnj.
      * admit.
      * admit.
  - intros.
    simpl.
    reflexivity.
  - intros.
    simpl.
    rewrite IHt1.
    + rewrite IHt2.
      * reflexivity.
      * assumption.
    + assumption.
  - intros.
    simpl.
    rewrite IHt.
    + admit.
    + lia.
Admitted.

Lemma open_rec_swap_neq: forall t t' x i j, i <> j -> {j ~> pterm_fvar x} ({i ~> t'} t) = {i ~> {j ~> pterm_fvar x} t'}({j ~> pterm_fvar x} t).
Proof.
  intro t; induction t.
  - intros t' x i j Hneq.
    simpl.
    destruct (i =? n) eqn:Hni.
    + destruct (j =? n) eqn:Hnj.
      * apply beq_nat_true in Hni.
        apply beq_nat_true in Hnj.
        subst.
        contradiction.
      * apply beq_nat_true in Hni.
        subst.
        simpl.
        rewrite <- beq_nat_refl.
        reflexivity.
    + destruct (j =? n) eqn:Hnj.
      * simpl.
        rewrite Hnj.
        reflexivity.
      * simpl.
        rewrite Hni.
        rewrite Hnj.
        reflexivity.
  - intros t x i j Hneq.
    simpl.
    reflexivity.
  - intros t x i j Hneq.
    simpl.
    rewrite IHt1.
    + rewrite IHt2.
      * reflexivity.
      * assumption.
    + assumption.
  - intros t0 x i j Hneq.
    simpl.
    rewrite IHt.
    + admit. (* problema com composicionalidade. *)
    + lia.
  - intros t0 x i j Hneq.
    simpl.
    rewrite IHt1.
    + rewrite IHt2.
      * admit. (* problema composicionalidade *)
      * assumption.
    + lia.
Admitted.

(**
i = 0
j = 1

x = j

t = S i
t'= j

{j ~> pterm_fvar x} ({i ~> j} t)

{i ~> {j ~> pterm_fvar x} t'}({j ~> pterm_fvar x} \ S i)

*)


(** * Call by value semantics **)
Require Import Arith Compare_dec Max List Omega.
Import List.ListNotations.
Require Import Cecoa.Lib Cecoa.Syntax.

Set Implicit Arguments.
Unset Strict Implicit.

Section CBV.

Variables variable function constructor : Type.
Variable max_arity : nat.

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

(** Definition of a proof tree *)

Inductive cbv : Type :=
| cbv_constr : list cbv -> term -> value -> cbv
| cbv_split : list cbv -> cbv -> term -> value -> cbv
| cbv_function : nat -> (variable -> value) -> cbv -> term -> value -> cbv.

(** Smarter induction principle than the one automatically generated *)

Lemma cbv_ind2_gen :
  forall (P : cbv -> Set)(Q : list cbv -> Set),
  Q nil ->
  (forall p lp, P p -> Q lp -> Q (p :: lp)) ->
  (forall lp t v, Q lp -> P (cbv_constr lp t v)) ->
  (forall lp p t v, Q lp -> P p -> P (cbv_split lp p t v)) ->
  (forall n s p t v, P p -> P (cbv_function n s p t v)) ->
  forall p, P p.
Proof.
fix H1 8; intros P Q H2 H3 H4 H5 H6 [ lp t v | lp p t v | n s p t v ].

- apply H4; revert lp; fix H7 1; intros [ | p lp].

  + exact H2.

  + apply H3.

    * { apply H1 with (Q:=Q).

      - exact H2.

      - exact H3.

      - exact H4.

      - exact H5.

      - exact H6. }

    * apply H7.

- apply H5; revert lp; fix H7 1; intros [ | p' lp].

  + exact H2.

  + apply  H3.

    * { apply H1 with (Q:=Q).

      - exact H2.

      - exact H3.

      - exact H4.

      - exact H5.

      - exact H6. }

    * apply H7.

  + apply H1 with (Q:=Q).

    * exact H2.

    * exact H3.

    * exact H4.

    * exact H5.

    * exact H6.

  + apply H1 with (Q:=Q).

    * exact H2.

    * exact H3.

    * exact H4.

    * exact H5.

    * exact H6.

- apply H6.
  apply H1 with (Q:=Q).

  + exact H2.

  + exact H3.

  + exact H4.

  + exact H5.

  + exact H6.

Qed.

Lemma cbv_ind2 :
  forall (P : cbv -> Prop),
  (forall lp t v, (forall p, In p lp -> P p) -> P (cbv_constr lp t v)) ->
  (forall lp p t v, (forall p, In p lp -> P p) -> P p -> P (cbv_split lp p t v)) ->
  (forall n s p t v, P p -> P (cbv_function n s p t v)) ->
  forall p, P p.
Proof.
intros P H1 H2 H3 p.
apply cbv_ind2_gen with (Q := fun lp => forall p, In p lp -> P p); simpl; try tauto.
intuition; subst; trivial.
Qed.

(** Being a subtree of *)

Fixpoint InCBV p π : Prop :=
  p = π \/
  match π with
      | cbv_constr lp _ _ => orl (map (InCBV p) lp)
      | cbv_split lp p' _ _ => InCBV p p' \/ orl (map (InCBV p) lp)
      | cbv_function _ _ p' _ _ => InCBV p p'
  end.

Lemma InCBV_refl p : InCBV p p.
Proof.
induction p as [lp t v IH_lp | lp p t v IH_lp IH_p | i s p t v IH_p] using cbv_ind2;
simpl; tauto.
Qed.

Lemma InCBV_trans p p' p'': InCBV p p' -> InCBV p' p'' -> InCBV p p''.
Proof.
revert p p'.
induction p'' as [lp t v IH_lp | lp p1 t v IH_lp IH_p' | i s p1 t v IH_p'] using cbv_ind2;
intros p p' H1 [H2 | H2]; simpl; subst; trivial.

- right.
  rewrite orl_map in *.
  destruct H2 as (p1 & H2 & H3).
  exists p1.
  split; trivial.
  apply IH_lp with p'; trivial.

- destruct H2 as [H2 | H2].

  + right.
    left.
    apply IH_p' with p'; trivial.

  + right.
    right.
    rewrite orl_map in *.
    destruct H2 as (p2 & H2 & H3).
    exists p2.
    split; trivial.
    apply IH_lp with p'; trivial.

- right.
  apply IH_p' with p'; trivial.
Qed.

(** Reverse induction on proof trees *)

Lemma cbv_reverse_induction :
  forall (P : cbv -> Prop) π,
  P π ->
  (forall lp t v, InCBV (cbv_constr lp t v) π -> P (cbv_constr lp t v) -> forall p, In p lp -> P p) ->
  (forall lp p t v, InCBV (cbv_split lp p t v) π -> P (cbv_split lp p t v) -> forall p', (p' = p \/ In p' lp) -> P p') ->
  (forall i s p t v, InCBV (cbv_function i s p t v) π -> P (cbv_function i s p t v) -> P p) ->
  forall p, InCBV p π -> P p.
Proof.
intros P π H_π H_constr H_split H_function p H_p.
induction π as [lp t v IH_lp | lp p' t v IH_lp IH_p' | i s p' t v IH_p'] using cbv_ind2;
simpl in H_p.

- destruct H_p as [H_p | H_p].

  + congruence.

  + apply orl_map in H_p.
    destruct H_p as [p' [H1 H2] ].
    apply IH_lp with p'; trivial.

    * { eapply H_constr.

      - apply InCBV_refl.

      - exact H_π.

      - exact H1. }

    * intros lp' t' v' H3 H4 p'' H5.
      apply H_constr with lp' t' v'; trivial.
      simpl.
      right.
      apply orl_map.
      exists p'.
      tauto.

    * intros lp' p'' t' v' H3 H4 p''' H5.
      apply H_split with lp' p'' t' v'; trivial.
      simpl.
      right.
      apply orl_map.
      exists p'.
      tauto.

    * intros i s p'' t' v' H3 H4.
      apply H_function with i s t' v'; trivial.
      simpl.
      right.
      apply orl_map.
      exists p'.
      tauto.

- destruct H_p as [H_p | [H_p | H_p] ].

  + congruence.

  + apply IH_p'.

    * { eapply H_split.

      - apply InCBV_refl.

      - exact H_π.

      - left; reflexivity. }

    * intros lp' t' v' H3 H4 p'' H5.
      apply H_constr with lp' t' v'; trivial.
      simpl; tauto.

    * intros lp' p'' t' v' H3 H4 p''' H5.
      apply H_split with lp' p'' t' v'; trivial.
      simpl; tauto.

    * intros i s p'' t' v' H3 H4.
      apply H_function with i s t' v'; trivial.
      simpl; tauto.

    * exact H_p.

  + apply orl_map in H_p.
    destruct H_p as [p'' [H1 H2] ].
    apply IH_lp with p''; trivial.
    eapply H_split.

    * apply InCBV_refl.

    * exact H_π.

    *  right; exact H1.

    * intros lp' t' v' H3 H4 p''' H5.
      apply H_constr with lp' t' v'; trivial.
      simpl.
      right; right.
      apply orl_map.
      exists p''.
      tauto.

    * intros lp' p''' t' v' H3 H4 p'''' H5.
      apply H_split with lp' p''' t' v'; trivial.
      simpl.
      right; right.
      apply orl_map.
      exists p''.
      tauto.

    * intros i s p''' t' v' H3 H4.
      apply H_function with i s t' v'; trivial.
      simpl.
      right; right.
      apply orl_map.
      exists p''.
      tauto.

- destruct H_p as [H_p | H_p].

  + congruence.

  + apply IH_p'.

    * { eapply H_function.

      - apply InCBV_refl.

      - exact H_π. }

    * intros lp' t' v' H3 H4 p'' H5.
      apply H_constr with lp' t' v'; trivial.
      simpl; tauto.

    * intros lp' p'' t' v' H3 H4 p''' H5.
      apply H_split with lp' p'' t' v'; trivial.
      simpl; tauto.

    * intros i' s' p'' t' v' H3 H4.
      apply H_function with i' s' t' v'; trivial.
      simpl; tauto.

    * exact H_p.
Qed.

Variable subst_default : variable -> value.

Definition rule_subst_of_cbv_function (π : cbv) : nat * (variable -> value) :=
  match π with
  | cbv_function i s _ _ _ => (i, s)
  | _ => (0, subst_default) (* impossible case *)
  end.

(** Term of a tree *)
Definition proj_left (π : cbv) : term :=
  match π with
    | cbv_constr _ t _ => t
    | cbv_split _ _ t _ => t
    | cbv_function _ _ _ t _ => t
  end.

(** value of a tree *)
Definition proj_right (π : cbv) : value :=
  match π with
    | cbv_constr _ _ v => v
    | cbv_split _ _ _ v => v
    | cbv_function _ _ _ _ v => v
  end.

Variable prog : list rule.

Variable rule_default : rule.

(** Well-founded trees *)
Fixpoint wf (π : cbv) : Prop :=
  match π with
    | cbv_constr l (capply c lt) (c_capply c' lv) =>
        c = c' /\
        lt = map proj_left l /\ lv = map proj_right l /\ (* Permutations would also be acceptable *)
        andl (map wf l)
    | cbv_split l ((cbv_function _ _ _ (fapply f lv) v) as p) (fapply f' lt) v' =>
        lt = map proj_left l /\ lv = map (@term_from_value _ _ _)(map proj_right l) /\
        andl (map wf l) /\
        f = f' /\ v = v' /\
        wf p
    | cbv_function i s p (fapply f lv) v =>
        exists lp t,
        i < length prog /\
        nth i prog rule_default = rule_intro f lp t /\
        lv = map (@term_from_value _ _ _) (map (psubst s) lp) /\
        proj_left p = subst s t /\ proj_right p = v /\
        wf p
    | _ => False
  end.

Lemma wf_cbv_function i s p t v : wf (cbv_function i s p t v) -> wf p.
Proof.
destruct t; simpl; try tauto.
intros (lp & t & H); tauto.
Qed.

Lemma wf_InCBV_wf p π: wf π -> InCBV p π -> wf p.
Proof.
intro H_π_wf.
apply cbv_reverse_induction.

- apply H_π_wf.

- intros lp t v _.
  simpl.
  destruct t; try (intro H_false; destruct H_false).
  destruct v.
  intros [ _ [ _ [ _ H_map_wf ] ] ] p' H_in_p'_lp.
  apply andl_in with (map wf lp).

  + apply H_map_wf.

  + apply in_map.
    apply H_in_p'_lp.

- intros lp p' t v _.
  simpl.
  destruct p'; try (intro H_false; destruct H_false).
  destruct t0; try (intro H_false; destruct H_false).
  destruct t; try (intro H_false; destruct H_false).
  generalize H0.
  clear.
  intros [ _ [ H_wf_lp [ _ [ _ H_wf_p' ] ] ] ] p'' H_p''.
  destruct H_p'' as [ H_p'' | H_p'' ].

  + (* case p'' = p' *)
    rewrite H_p''.
    apply H_wf_p'.

  + (* case p'' in lp *)
    apply andl_in with (map wf lp).

    * apply H_wf_lp.

    * apply in_map.
      apply H_p''.

- intros i s p' t v _.
  simpl.
  destruct t; try (intro H_false; destruct H_false).
  generalize H.
  clear.
  intros [ _ [ _ [ _ [ _ [ _ [ _ H_wf ] ] ] ] ] ].
  apply H_wf.
Qed.

(** Sizes *)

Fixpoint size (π : cbv) : nat :=
  match π with
  | cbv_constr l t v => ╎t╎ + value_size v + suml (map size l)
  | cbv_split l p t v => ╎t╎ + value_size v + size p + suml (map size l)
  | cbv_function _ _ p t v => size p + ╎t╎ + value_size v
  end.

Fixpoint max_active_size (π : cbv) : nat :=
  match π with
  | cbv_constr lp _ _ => maxl (map max_active_size lp)
  | cbv_split lp p _ _ => max (max_active_size p) (maxl (map max_active_size lp))
  | cbv_function _ _ p t v => max (╎t╎ + value_size v) (max_active_size p)
  end.

Fixpoint max_judgement_size (π : cbv) : nat :=
  match π with
  | cbv_constr lp t v => max (╎t╎ + value_size v) (maxl (map max_judgement_size lp))
  | cbv_split lp p t v => max (╎t╎ + value_size v) (max (max_judgement_size p) (maxl (map max_judgement_size lp)))
  | cbv_function _ _ p t v => max (╎t╎ + value_size v) (max_judgement_size p)
  end.

(** Judgments (sub-trees) *)

Fixpoint ℐ (π : cbv) : list cbv :=
  π :: (
    match π with
    | cbv_constr lp _ _ => flat_map ℐ lp
    | cbv_split lp p _ _ => flat_map ℐ (p :: lp)
    | cbv_function _ _ p _ _ => ℐ p
    end ).

Lemma ℐ_neq_nil : forall p, ℐ p <> [].
Proof.
destruct p; simpl; congruence.
Qed.

Lemma InCBV_In_ℐ p p' : InCBV p p' <-> In p (ℐ p').
Proof.
split.

- induction p' as [ lp t v IH_lp | lp p' t v IH_lp IH_p | i s p' t v IH_p ] using cbv_ind2; simpl.

  + intros [H1 | H1].

    * left.
      congruence.

    * right.
      rewrite in_flat_map.
      rewrite orl_map in H1.
      firstorder.

  + intros [H1 | [ H1 | H1 ] ].

    * left.
      congruence.

    * right.
      rewrite in_app_iff.
      left.
      apply IH_p.
      exact H1.

    * right.
      rewrite in_app_iff.
      right.
      rewrite in_flat_map.
      rewrite orl_map in H1.
      firstorder.

  + intros [H1 | H1].

    * left.
      congruence.

    * right.
      apply IH_p.
      exact H1.

- induction p' as [ lp t v IH_lp | lp p' t v IH_lp IH_p | i s p' t v IH_p ] using cbv_ind2;
  simpl; (intros [H1 | H1]; [left; congruence | right] ).

  + rewrite orl_map.
    rewrite in_flat_map in H1.
    firstorder.

  + rewrite in_app_iff in H1.
    destruct H1 as [H1 | H1]; [left; tauto | right].
    rewrite orl_map.
    rewrite in_flat_map in H1.
    firstorder.

  + tauto.
Qed.

(** Returns the proof tree of the list with the largest proj_left *)
Fixpoint proj_left_max_size_list (default : cbv) (proof_trees : list cbv) : cbv :=
  match proof_trees with
    | [] => default
    | [p] => p
    | p :: ps =>
      let p' := proj_left_max_size_list default ps in
      if leb (╎proj_left p╎) (╎proj_left p'╎) then p' else p
  end.

Lemma In_proj_left_max_size_list p lp : lp <> [] -> In (proj_left_max_size_list p lp) lp.
Proof.
induction lp as [ | p1 [ | p2 lp] IH]; simpl; try tauto.
intros _.
match goal with |- context [leb ?x ?y] => case_eq (leb x y); intro H_leb end.

- auto with *.

- tauto.
Qed.

Lemma proj_left_size_le_max_gen default proof_trees π:
  In π proof_trees ->
  ╎proj_left π╎ <= ╎proj_left (proj_left_max_size_list default proof_trees)╎.
Proof.
induction proof_trees as [ | p1 [ | p2 proof_trees ] IH]; simpl.

- tauto.

- intros [H1 | H1].

  + subst.
    trivial.

  + tauto.

- intros [H1 | [H1 | H1] ].

  + subst.
    match goal with |- context [leb ?x ?y] => case_eq (leb x y); intro H_leb end.

    * rewrite leb_iff in H_leb.
      exact H_leb.

    * trivial.

  + subst.
    match goal with |- context [leb ?x ?y] => case_eq (leb x y); intro H_leb end.

    * apply IH.
      simpl; tauto.

    * rewrite leb_iff_conv in H_leb.
      unfold lt in H_leb.
      { etransitivity.

        - apply IH.
          simpl; tauto.

        - simpl. omega.

      }

  + match goal with |- context [leb ?x ?y] => case_eq (leb x y); intro H_leb end.

    * apply IH.
      simpl; tauto.

    * { etransitivity.

        - apply IH.
          simpl; tauto.

        - rewrite leb_iff_conv in H_leb.
          simpl; omega.
      }
Qed.

Definition proj_left_max_size (π : cbv) : cbv :=
  proj_left_max_size_list π (ℐ π).

Lemma proj_left_size_le_max π:
  forall p, InCBV p π ->
  ╎proj_left p╎ <= ╎proj_left (proj_left_max_size π)╎.
Proof.
intros p H_InCBV.
apply proj_left_size_le_max_gen.
apply InCBV_In_ℐ.
trivial.
Qed.

Lemma InCBV_proj_left_max_size p : InCBV (proj_left_max_size p) p.
Proof.
unfold proj_left_max_size.
apply InCBV_In_ℐ.
apply In_proj_left_max_size_list.
apply ℐ_neq_nil.
Qed.

Fixpoint max_proj_right_size (π : cbv) : nat :=
  match π with
  | cbv_constr lp t v => max (value_size v) (maxl (map max_proj_right_size lp))
  | cbv_split lp p t v => max (value_size v) (max (max_proj_right_size p) (maxl (map max_proj_right_size lp)))
  | cbv_function _ _ p t v => max (value_size v) (max_proj_right_size p)
  end.

Lemma judgement_size_le_projs_size p :
  max_judgement_size p <= ╎proj_left (proj_left_max_size p)╎ + max_proj_right_size p.
Proof.
induction p as [ lp t v IH_lp | lp p t v IH_lp IH_p | i s p t v IH_p ] using cbv_ind2; simpl.

- destruct (max_dec (╎t╎ + value_size v) (maxl (map max_judgement_size lp))) as [ H | H ];
  rewrite H.

  + apply plus_le_compat.

    * change t with (proj_left (cbv_constr lp t v)) at 1.
      apply proj_left_size_le_max.
      apply InCBV_refl.

    * apply le_max_l.

  + apply maxl_le_maxl in IH_lp.
    etransitivity.

    * apply IH_lp.

    * { etransitivity.

      - apply maxl_map_plus_le.

      - apply plus_le_compat.

        + apply all_max_le.
          intros size H1.
          rewrite in_map_iff in H1.
          destruct H1 as (p & H1 & H2).
          subst size.
          apply proj_left_size_le_max.
          eapply InCBV_trans.
          apply InCBV_proj_left_max_size.
          apply InCBV_In_ℐ.
          simpl.
          right.
          rewrite in_flat_map.
          exists p.
          split; trivial.
          apply InCBV_In_ℐ.
          apply InCBV_refl.

        + apply le_max_r.

      }

- destruct (max_dec (╎t╎ + value_size v) (max (max_judgement_size p) (maxl (map max_judgement_size lp)))) as [ H1 | H1 ];
  rewrite H1.

  + apply plus_le_compat.

    * change t with (proj_left ((cbv_split lp p t v))) at 1.
      apply proj_left_size_le_max.
      apply InCBV_refl.

    * apply le_max_l.

  + destruct (max_dec (max_judgement_size p) (maxl (map max_judgement_size lp))) as [ H2 | H2 ];
    rewrite H2.

    * { etransitivity.

        - apply IH_p.

        - apply plus_le_compat.

          + apply proj_left_size_le_max.
            simpl.
            right.
            left.
            apply InCBV_proj_left_max_size.

          + etransitivity; [idtac | apply le_max_r]; apply le_max_l.

      }

    * { apply maxl_le_maxl in IH_lp.
        etransitivity.

        - apply IH_lp.

        - etransitivity.

          + apply maxl_map_plus_le.

          + apply plus_le_compat.

            * apply all_max_le.
              intros size H3.
              rewrite in_map_iff in H3.
              destruct H3 as (p' & H3 & H4).
              subst size.
              apply proj_left_size_le_max.
              eapply InCBV_trans.
              apply InCBV_proj_left_max_size.
              apply InCBV_In_ℐ.
              simpl.
              right.
              rewrite in_app_iff.
              right.
              rewrite in_flat_map.
              exists p'.
              split; trivial.
              apply InCBV_In_ℐ.
              apply InCBV_refl.

            * etransitivity; [idtac | apply le_max_r]; apply le_max_r.

      }

- destruct (max_dec (╎t╎ + value_size v) (max_judgement_size p)) as [ H | H ];
  rewrite H.

  + apply plus_le_compat.

    * change t with (proj_left ((cbv_function i s p t v))) at 1.
      apply proj_left_size_le_max.
      apply InCBV_refl.

    * apply le_max_l.

  + etransitivity.

    * apply IH_p.

    * { apply plus_le_compat.

        - apply proj_left_size_le_max.
          simpl.
          right.
          apply InCBV_proj_left_max_size.

        - apply le_max_r.
      }

Qed.

(** Activations (ℐᵃ) *)
Fixpoint ℐᵃ (π : cbv) : list cbv :=
  match π with
  | cbv_constr lp _ _ => flat_map ℐᵃ lp
  | cbv_split lp p _ _ => ℐᵃ p ++ flat_map ℐᵃ lp
  | cbv_function _ _ p _ _ as p' => p' :: ℐᵃ p
  end.

Lemma activation_is_function :
  forall π p,
  In p (ℐᵃ π) -> exists i s p' t v, p = cbv_function i s p' t v.
Proof.
intros π p H.
induction π as [ lp t v IH | lp p' t v IH_lp IH_p' | i s p' t v IH ] using cbv_ind2.

- (* cbv_constr *)
  simpl in H.
  apply in_flat_map in H.
  destruct H as [ x H ].
  destruct H as [ H_x_in H_p_in_x ].
  generalize (IH x H_x_in H_p_in_x).
  trivial.

- (* cbv_split *)
  simpl in H.
  apply in_app_or in H.
  destruct H as [ H_p' | H_lp ].

  + refine (IH_p' H_p').

  + apply in_flat_map in H_lp.
    destruct H_lp as [ x H ].
    destruct H as [ H_x_in H_p_in_x ].
    generalize (IH_lp x H_x_in H_p_in_x).
    trivial.

- (* cbv_function *)
  simpl in H.
  destruct H as [ H_base | H_ind ].

  + repeat eexists.
    symmetry.
    apply H_base.

  + generalize (IH H_ind).
    trivial.
Qed.

Lemma cbv_function_in_ℐᵃ_InCBV π sub_proof_tree i s p t v:
  sub_proof_tree = cbv_function i s p t v ->
  InCBV sub_proof_tree π ->
  In sub_proof_tree (ℐᵃ π).
Proof.
intros H0 H1.
subst.
induction π as [ lp t' v' IH | lp p' t' v' IH1 IH2 | i' s' p' t' v' IH ] using cbv_ind2; simpl in *.

- destruct H1 as [H1 | H1]; try discriminate H1.
  rewrite in_flat_map.
  rewrite orl_map in H1.
  firstorder.

- destruct H1 as [H1 | [H1 | H1] ]; try discriminate.

  + firstorder.

  + rewrite in_app_iff, in_flat_map.
    rewrite orl_map in H1.
    firstorder.

- firstorder.
Qed.

Lemma ℐᵃ_wf : forall π p, wf π -> In p (ℐᵃ π) -> wf p.
Proof.
intros π p H1; revert p; induction π as [ lp t v IH | lp p' t v IH1 IH2 | i s p' t v IH ] using cbv_ind2; intros p H2; simpl in * |-.

- destruct t as [ x | c lt | f lt ]; try tauto.
  destruct v as [ c' lv ].
  destruct H1 as (H1 & H3 & H4 & H5).
  subst c' lt lv.
  rewrite in_flat_map in H2.
  destruct H2 as (p' & H2 & H3).
  apply IH with p'; trivial.
  apply andl_in with (P := wf p') in H5; trivial.
  apply in_map_iff.
  firstorder.

- destruct p' as [ lp' t' v' | lp' p' t' v' | i s p' t' v' ]; try tauto.
  destruct t' as [ x | c lt | f lt ]; try tauto.
  destruct t as [ x | c lt' | f' lt' ]; try tauto.
  destruct H1 as (H1 & H3 & H4 & H5 & H6 & H7).
  subst lt lt' f' v'.
  rewrite in_app_iff in H2.
  destruct H2 as [ H2 | H2 ]; auto.
  rewrite in_flat_map in H2.
  destruct H2 as (p'' & H2 & H5).
  apply (IH1 _ H2); trivial.
  apply (andl_in _ _ H4); rewrite in_map_iff; exists p''; tauto.

- destruct t as [ x | c lt | f lt ]; try tauto.
  destruct H1 as (lp & t & H0 & H1 & H3 & H4 & H5 & H6).
  destruct H2 as [ H2 | H2 ]; auto.
  subst lt v p.
  destruct p' as [ lp' t' v | lp' p t' v | j s' p t' v ]; firstorder.
Qed.

Lemma le_max_active_size π p :
  In p (ℐᵃ π) -> ╎proj_left p╎ + value_size (proj_right p) <= max_active_size π.
Proof.
intro H.
induction π as [ lp t v IH | lp p' t v IH_lp IH_p' | i s p' t v IH ] using cbv_ind2; simpl in *.

- rewrite in_flat_map in H.
  destruct H as (p' & H1 & H2).
  etransitivity.

  + apply IH.
    eexact H1.
    exact H2.

  + apply maxl_is_max.
    rewrite in_map_iff.
    exists p'; split; trivial.

- rewrite in_app_iff in H.
  destruct H as [H | H].

  + etransitivity.

    * apply IH_p'.
      exact H.

    * apply le_max_l.

  + rewrite in_flat_map in H.
    destruct H as (p'' & H1 & H2).
    etransitivity.

    * apply IH_lp.
      eexact H1.
      exact H2.

    * etransitivity; [idtac | apply le_max_r].
      apply maxl_is_max.
      apply in_map_iff.
      exists p''.
      tauto.

- destruct H as [H | H].

  + subst p.
    simpl in *.
    etransitivity; [idtac | apply le_max_l].
    trivial.

  + etransitivity; [idtac | apply le_max_r].
    apply IH.
    exact H.
Qed.

Hypothesis prog_is_wf : wf_prog max_arity prog.

Lemma 𝓡_spec :
  forall π, wf π -> forall p, In p (ℐᵃ π) ->
  let (i, s) := rule_subst_of_cbv_function p in
  ╎subst s (rhs_of_rule (nth i prog rule_default))╎ <= 𝓡 prog (╎proj_left p╎).
Proof.
intros π H_wf_π p H_p_activation.
case_eq (rule_subst_of_cbv_function p).
intros i s H_p_fun.
unfold 𝓡.
set (rule_i := nth i prog rule_default);
set (l := lhs_of_rule rule_i);
set (r := rhs_of_rule rule_i);
set (t := proj_left p).
rewrite step_one.
apply mult_le_compat.

- apply maxl_is_max; rewrite map_map, in_map_iff; exists rule_i; split.

  + reflexivity.

  + apply nth_In.
    generalize (ℐᵃ_wf H_wf_π H_p_activation); intro H_wf_p.
    generalize (activation_is_function H_p_activation); intros (i' & s' & p' & t' & v & H_p_is_function).
    subst p.
    simpl in H_p_fun.
    injection H_p_fun; clear H_p_fun; intros; subst i' s'.
    simpl in H_wf_p.
    destruct t'; try tauto.
    destruct H_wf_p as (lp & t' & H); tauto.

- apply plus_le_compat_l.
  transitivity (max_size_image_subst l s).

  + apply incl_le_max_size_image_subst.
    assert (rule_vars_defined rule_i) as H_wf_rule_i.
    * { eapply andl_in.

      - destruct prog_is_wf as [ Hwfrule _ ].
        exact Hwfrule.

      - rewrite in_map_iff.
        exists rule_i.
        split; trivial.
        apply nth_In.
        generalize (ℐᵃ_wf H_wf_π H_p_activation); intro H_wf_p.
        generalize (activation_is_function H_p_activation); intros (i' & s' & p' & t' & v & H_p_is_function).
        subst p.
        simpl in H_p_fun.
        injection H_p_fun; clear H_p_fun; intros; subst i' s'.
        simpl in H_wf_p.
        destruct t'; try tauto.
        destruct H_wf_p as (lp & t' & H); tauto. }

    * { destruct rule_i as [f lp t'].
        simpl in H_wf_rule_i.
        unfold l, r.
        simpl.
        replace (flat_map (@vars_of_term _ _ _) (map (@term_from_pattern _ _ _) lp)) with (flat_map (@vars_of_pattern _ _) lp).

          - exact H_wf_rule_i.

          - apply flat_map_comp; intros; apply vars_of_pattern_term. }

  + assert (subst s l = t) as H_t_matches_lhs.

    * generalize (ℐᵃ_wf H_wf_π H_p_activation); intro H_wf_p.
      generalize (activation_is_function H_p_activation); intros (i' & s' & p' & t' & v & H_p_is_function).
      unfold t; clear t.
      subst p.
      simpl.
      simpl in H_p_fun.
      injection H_p_fun; clear H_p_fun; intros; subst i' s'.
      simpl in H_wf_p.
      destruct t' as [ | | f lt]; try tauto.
      destruct H_wf_p as (lp & t' & H1 & H2 & H3 & H4 & H5 & H6).
      unfold l, r, rule_i in *; clear l r rule_i.
      rewrite H2.
      subst lt v.
      simpl.
      f_equal.
      do 2 rewrite map_map.
      clear.
      induction lp as [ | p lp IH]; simpl; trivial.
      rewrite IH.
      f_equal.
      apply subst_psubst.

    * replace t with (subst s l).
      apply max_size_image_subst_bounded.
Qed.

(** Number of judgements *)
Fixpoint nb_judgements (π : cbv) : nat :=
  match π with
  | cbv_constr lp _ _ => 1 + suml (map nb_judgements lp)
  | cbv_split lp p _ _ => 1 + nb_judgements p + suml (map nb_judgements lp)
  | cbv_function _ _ p _ _ => 1 + nb_judgements p
  end.

(** Number of passive judgements *)
Fixpoint nb_judgements_sub_rec (π : cbv) : nat :=
  match π with
  | cbv_constr lp _ _ => 1 + suml (map nb_judgements_sub_rec lp)
  | cbv_split lp p _ _ => 1 + nb_judgements_sub_rec p + suml (map nb_judgements_sub_rec lp)
  | cbv_function _ _ _ _ _ => 0
  end.

Definition nb_judgements_sub (π : cbv) : nat :=
  match π with
  | cbv_constr _ _ _ => 0
  | cbv_split _ _ _ _ => 0
  | cbv_function _ _ p _ _ => nb_judgements_sub_rec p
  end.

Lemma nb_judgements_bound i s p' t v :
  let p := cbv_function i s p' t v in
  nb_judgements p <= suml (map nb_judgements_sub (ℐᵃ p)) + length (ℐᵃ p).
Proof.
induction p' as [ lp t' v' IH1 | lp p t' v' IH1 IH2 | i' s' p t' v' IH ] using cbv_ind2; simpl in *.

- apply le_n_S.
  rewrite length_flat_map.
  induction lp as [ | p lp IH2]; trivial.
  simpl.
  repeat match goal with |- context [ S (?m + ?n) ] => replace (S (m + n)) with (m + S n) by ring end.
  etransitivity.

  + apply plus_le_compat.

    * { apply le_S_n.
        etransitivity.

        - apply IH1; simpl; tauto.

        - match goal with |- ?m + S ?n <= _ => instantiate (1 := m + n) end.
          omega. }

    * apply IH2.
      intros p' Hp'; apply IH1; simpl; tauto.

  + rewrite map_app, suml_app.
    omega.

- apply le_n_S.
  rewrite map_app, suml_app, app_length, length_flat_map.
  induction lp as [ | p' lp IH3]; simpl; try omega.
  repeat match goal with |- context [ S (?m + (?n + ?p)) ] => replace (S (m + (n + p))) with (n + S (m + p)) by ring end.
  etransitivity.

  + apply plus_le_compat.

    * { apply le_S_n.
        etransitivity.

        - apply IH1; simpl; tauto.

        - match goal with |- ?m + S ?n <= _ => instantiate (1 := m + n) end.
          omega. }

    * apply IH3.
      intros p'' Hp''; apply IH1; simpl; tauto.

  + rewrite map_app, suml_app.
    omega.

- omega.
Qed.

Lemma nb_judgements_sub_rec_bound p :
  wf p -> nb_judgements_sub_rec p <= ╎proj_left p╎.
Proof.
intros H_wf_p.
induction p as [ lp t v IH | lp p t v IH _ | n s p t v _ ] using cbv_ind2; simpl in *.

- destruct t as [ | c lt | ]; try tauto.
  destruct v as [ c' lv ].
  simpl.
  apply le_n_S.
  destruct H_wf_p as (_ & H_lt & _ & H_wf); clear c'.
  subst lt.
  rewrite map_map.
  apply suml_map_le.
  intros p H_p.
  apply IH.
  trivial.
  apply andl_in with (map wf lp).
  trivial.
  rewrite in_map_iff.
  exists p.
  tauto.

- destruct p as [ | | i s p t' v']; try tauto.
  destruct t' as [ | | f lt]; try tauto.
  destruct t as [ | | f' lt']; try tauto.
  simpl in *.
  apply le_n_S.
  destruct H_wf_p as (H1 & H2 & H3 & H4 & H5 & lp' & t & H6 & H7 & H8 & H9 & H10 & H11); subst; subst.
  rewrite map_map.
  apply suml_map_le.
  intros p' H_p'.
  apply IH.
  trivial.
  apply andl_in with (map wf lp).
  trivial.
  rewrite in_map_iff.
  exists p'.
  tauto.

- apply le_0_n.
Qed.

Lemma nb_judgements_sub_bound i s p t v :
  wf (cbv_function i s p t v) ->
  nb_judgements_sub (cbv_function i s p t v) <= 𝓡 prog (╎t╎).
Proof.
intros H_wf_proof_tree.
assert (In (cbv_function i s p t v) (ℐᵃ (cbv_function i s p t v))) as H_p_activation.

- simpl; tauto.

- generalize (ℐᵃ_wf H_wf_proof_tree H_p_activation); intro H_wf_p.
  generalize (𝓡_spec H_wf_proof_tree H_p_activation).
  simpl; intro H.
  transitivity (╎subst s (rhs_of_rule (nth i prog rule_default))╎); [clear H | trivial].
  transitivity (╎proj_left p╎).

  + apply nb_judgements_sub_rec_bound; trivial.
    apply (wf_cbv_function H_wf_p).

  + simpl in H_wf_p.
    destruct t; try tauto.
    destruct H_wf_p as (lp & t & _ & H_rule & _ & H_proj & _).
    rewrite H_rule, H_proj; simpl.
    trivial.
Qed.

Lemma value_size_bounded_by_nb_judgements p :
  wf p -> value_size (proj_right p) <= nb_judgements p.
Proof.
intro H.
induction p as [ lp t v IH | lp p t v _ IH | n s p t v IH ] using cbv_ind2; simpl in *.

- destruct t as [ | c lt | ]; try tauto.
  destruct v as [ c' lv ].
  destruct H as (H1 & H2 & H3 & H4).
  subst c' lt lv.
  simpl.
  apply le_n_S.
  rewrite map_map.
  apply suml_map_le.
  intros p H1; apply IH; trivial.
  apply andl_in with (map wf lp); trivial.
  apply in_map_iff.
  exists p.
  tauto.

- destruct p as [ | | n s p t' v']; try tauto.
  destruct t' as [ | | f lv]; try tauto.
  destruct t as [ | | f' lt]; try tauto.
  destruct H as (H1 & H2 & H3 & H4 & H5 & H6).
  subst lt lv f' v'.
  simpl in *.
  apply IH in H6; clear IH.
  etransitivity.

  + eexact H6.

  + omega.

- destruct t as [ | | f lv]; try tauto.
  destruct H as (lp & t & H1 & H2 & H3 & H4 & H5 & H6).
  subst lv v.
  apply le_S.
  tauto.
Qed.

Lemma term_size_bound_constr lp t v :
  wf (cbv_constr lp t v) ->
  andl (map (fun p => ╎t╎ >= ╎proj_left p╎) lp).
Proof.
simpl; intro H.
destruct t as [ | c lt | ]; try tauto.
destruct v as [ c' lv ].
destruct H as (H1 & H2 & H3 & H4).
subst c' lt lv.
eapply andl_map.

- eexact H4.

- intros p H1 H2.
  simpl.
  unfold ge.
  apply le_S.
  apply in_le_suml.
  apply in_map_iff.
  exists (proj_left p).
  split; trivial.
  apply in_map_iff.
  exists p.
  tauto.
Qed.

Lemma term_size_bound_split lp p t v :
  wf (cbv_split lp p t v) ->
  andl (map (fun p => ╎t╎ >= ╎proj_left p╎) lp).
Proof.
simpl; intro H.
destruct p as [ | | i s p t' v']; try tauto.
destruct t' as [ | | f lv]; try tauto.
destruct t as [ | | f' lt]; try tauto.
destruct H as (H1 & H2 & H3 & H4 & H5 & H6).
subst lt lv f' v'.
simpl in *.
destruct H6 as (lp' & t & H1 & H2 & H4 & H5 & H6 & H7).
subst v.
eapply andl_map.

- eexact H3.

- intros p' H6 H8.
  unfold ge.
  apply le_S.
  apply in_le_suml.
  apply in_map_iff.
  exists (proj_left p').
  split; trivial.
  apply in_map_iff.
  exists p'.
  tauto.
Qed.

Lemma size_bounded_nb_size_judgements p :
  size p <= nb_judgements p * max_judgement_size p.
Proof.
induction p as [ lp t v IH_lp | lp p t v IH_lp IH_p | i s p t v IH_p] using cbv_ind2; simpl.

- etransitivity.

  + apply plus_le_compat_l.
    apply suml_map_le in IH_lp.
    apply IH_lp.

  + set (a := ╎t╎ + value_size v).
    set (f := nb_judgements).
    set (g := max_judgement_size).
    apply plus_le_compat.

    * apply le_max_l.

    * { etransitivity.

        - apply suml_map_mult_le_suml_mult_maxl.

        - apply mult_le_compat_l.
          apply le_max_r.
      }

- etransitivity.

  + rewrite <- plus_assoc.
    apply plus_le_compat_l.
    apply plus_le_compat.

    * apply IH_p.

    * apply suml_map_le in IH_lp.
      apply IH_lp.

  + set (a := ╎t╎ + value_size v).
    set (f := nb_judgements).
    set (g := max_judgement_size).
    apply plus_le_compat.

    * apply le_max_l.

    * { etransitivity.

        - apply plus_le_compat_l.
          apply suml_map_mult_le_suml_mult_maxl.

        - ring_simplify.
          apply plus_le_compat.

          + apply mult_le_compat_l.
            etransitivity; [idtac | apply le_max_r]; apply le_max_l.

          + apply mult_le_compat_l.
            etransitivity; [idtac | apply le_max_r]; apply le_max_r.
      }

- etransitivity.

  + do 2 apply plus_le_compat_r.
    apply IH_p.

  + set (a := nb_judgements p).
    set (b := max_judgement_size p).
    rewrite <- plus_assoc.
    set (c := ╎t╎ + value_size v).
    rewrite plus_comm.
    apply plus_le_compat.

    * apply le_max_l.

    * apply mult_le_compat_l.
      apply le_max_r.
Qed.

Lemma nb_judgements_sub_bound_gen : forall p p',
  let S := max_active_size p in
  wf p ->
  In p' (ℐᵃ p) -> nb_judgements_sub p' <= 𝓡 prog S.
Proof.
intros p p' S H_wf_p Hp'.
assert (wf p') as H1. {
  apply ℐᵃ_wf with p.
  exact H_wf_p.
  assumption.
}
generalize Hp'; intro H2p'.
apply activation_is_function in Hp'.
apply le_max_active_size in H2p'.
destruct Hp' as (i' & s' & p'' & t' & v' & Hp').
subst p'.
etransitivity.

- apply nb_judgements_sub_bound.
  assumption.

- simpl in H1.
  destruct t' as [ | | f lv]; try omega.
  destruct H1 as (lp & t' & H1 & H2 & H3 & H4 & H5 & H6).
  subst lv v'.
  simpl in H2p'.
  apply 𝓡_monotone.
  etransitivity; [idtac | apply H2p'].
  simpl; omega.
Qed.

Lemma nb_judgements_bound_gen : forall i s p' t v,
  let p := cbv_function i s p' t v in
  let A := length (ℐᵃ p) in
  let S := max_active_size p in
  wf p ->
  nb_judgements p <= A * 𝓡 prog S + A.
Proof.
intros i s p' t v p A S H_wf_p.
etransitivity.
apply nb_judgements_bound.
unfold A, p.
apply plus_le_compat_r.
set (list_activ := ℐᵃ (cbv_function i s p' t v)).
etransitivity.

- apply suml_le_len_times_bound.
  instantiate (1 := 𝓡 prog S).
  intros x H_x.
  apply in_map_iff in H_x.
  destruct H_x as [ p'' [ H_x1 H_x2 ]].
  subst x.
  apply nb_judgements_sub_bound_gen; trivial.

- apply mult_le_compat_r.
  rewrite map_length.
  trivial.
Qed.

(** Bound on the size of the term *)
Lemma term_size_proj_left_bound : forall i s p' t v,
  let p := cbv_function i s p' t v in
  let S := max_active_size p in
  wf p ->
  forall p',
  InCBV p' p -> ╎proj_left p'╎ <= 𝓡 prog S + S.
Proof.
(** we use cbv_reverse_induction to prove ≤ activation S + S
   - base case: as a cbv_function it is bounded by S
   - inductive case:
     - the sub-tree of a cbv_function is bounded by act S,
     - the sub-trees of a cbv_constr are bounded by the cbv_constr itself,
     - the subtrees in the lp of a cbv_split are bounded by the cbv_split itself,
     - the subtree p of a cbv_split is a cbv_function, thus bounded by S *)

intros i s p0 t v p S H_wf_p.
apply cbv_reverse_induction.

- (* Base case *)
  transitivity S.

  + unfold p, S.
    simpl.
    transitivity (╎t╎ + value_size v).

    * apply le_plus_l.

    * apply le_max_l.

      + apply le_plus_r.

- (* cbv_constr *)
  intros lp t' v' H_p'_in_p IH p'' H_p''_in_lp.
  transitivity (╎proj_left (cbv_constr lp t' v')╎).

  + generalize (wf_InCBV_wf H_wf_p H_p'_in_p).
    simpl.
    destruct t'; try (intro H_false; destruct H_false).
    destruct v'.
    intros [ H_c0 [ H_l_lp [ _ H_wf_lp ] ] ].
    rewrite <- H_c0 in *; clear H_c0.

    simpl.
    rewrite H_l_lp.
    apply le_S.
    apply in_le_suml.
    apply in_map.
    apply in_map.
    apply H_p''_in_lp.

    + apply IH.

- (* cbv_split *)
  intros lp p' t' v' H_in_p IH p'' H_p''_in.
  destruct H_p''_in as [ H_p''_in | H_p''_in ].

  + (* if p'' = p', then p' is a cbv_function *)
  { rewrite H_p''_in.
    transitivity S.
    transitivity (╎proj_left p'╎ + value_size (proj_right p')).

    - apply le_plus_l.

    - apply le_max_active_size.
      generalize (wf_InCBV_wf H_wf_p H_in_p).
      intro H_wf_split.
      simpl in H_wf_split.
      destruct p'; try tauto.
      apply cbv_function_in_ℐᵃ_InCBV with n v0 p' t0 v1; try auto.
      apply InCBV_trans with (cbv_split lp (cbv_function n v0 p' t0 v1) t' v').

      * simpl.
        tauto.

      * apply H_in_p.

    - apply le_plus_r.
  }

  + (* if p'' ∈ lp, then similarly as the cbv_constr case *)
    transitivity (╎proj_left (cbv_split lp p' t' v')╎).

    * generalize (wf_InCBV_wf H_wf_p H_in_p).
      simpl.
      destruct p'; try tauto.
      destruct t0; try tauto.
      destruct t' as [ | | f' lt ]; try tauto.
      intros [ H_lt_lp [ _ [ _ [ H_f [ H_v _ ] ] ] ] ].
      rewrite <- H_f in *; clear H_f.
      rewrite H_v in *; clear H_v.
      rewrite H_lt_lp in *; clear H_lt_lp.
      simpl.
      apply le_S.
      apply in_le_suml.
      apply in_map.
      apply in_map.
      assumption.

    * assumption.

- (* cbv_function *)
  intros i' s' p' t' v' H_in_p IH.
  transitivity (𝓡 prog (╎t'╎)).

  + change t' with (proj_left (cbv_function i' s' p' t' v')).
    replace (proj_left p') with (subst s' (rhs_of_rule (nth i' prog rule_default))).

    * generalize (@𝓡_spec p H_wf_p (cbv_function i' s' p' t' v')).
      simpl.
      intro H.
      apply H.
      simpl in H_in_p.
      {
        destruct H_in_p as [ H_in_p | H_in_p ].

        - left.
          symmetry.
          assumption.

        - right.
          apply (@cbv_function_in_ℐᵃ_InCBV p0 (cbv_function i' s' p' t' v') i' s' p' t' v'); trivial.
      }

    * generalize (wf_InCBV_wf H_wf_p H_in_p).
      simpl.
      destruct t'; try tauto.
      intros [ lp [ t' [ _ [ H_nth_rule [ _ [ H_proj_subst _ ] ] ] ] ] ].
      rewrite H_proj_subst.
      f_equal.
      rewrite H_nth_rule.
      simpl.
      trivial.

  + apply le_plus_trans.
    apply 𝓡_monotone.
    transitivity (╎proj_left (cbv_function i' s' p' t' v')╎ + value_size (proj_right (cbv_function i' s' p' t' v'))).

    * apply le_plus_trans.
      simpl.
      trivial.

    * apply le_max_active_size.
      apply cbv_function_in_ℐᵃ_InCBV with i' s' p' t' v'; trivial.
Qed.

(** Bound on the size of judgements *)
Lemma size_judgement : forall i s p' t v,
  let p := cbv_function i s p' t v in
  let A := length (ℐᵃ p) in
  let S := max_active_size p in
  wf p ->
  max_judgement_size p <= 𝓡 prog S + S + A * 𝓡 prog S + A.
Proof.
  (* We bound the size of terms in judgements *)
  (* terms in ℐᵃ are bounded by S by definition.
     For passive judgements, we do a case analysis on the next judgement:
     - if it is an activation, we apply activaction_bound_spec.
     - otherwise, the size is bounded by the proj_left of the next judgement, so
        we use term_size_bound *)

  (* Then we bound the size of values in judgements with value_size_bounded_by_nb_judgements *)

  intros i s p0 t v p A S H_wf_p.
  etransitivity.
  apply judgement_size_le_projs_size.
  rewrite <- plus_assoc.
  apply plus_le_compat.

  + apply term_size_proj_left_bound; trivial.
    apply InCBV_proj_left_max_size.

  + transitivity (nb_judgements p).

    * { (*wa apply value_size_bounded_by_nb_judgements. *)
        generalize H_wf_p.
        clear H_wf_p.
        intro H_wf_p.
        induction p as [ lp t' v' IH | lp p' t' v' IH_lp IH_p' | i' s' p' t' v' IH ] using cbv_ind2.

        - simpl max_proj_right_size.
          destruct (max_dec (value_size v') (maxl (map max_proj_right_size lp))) as [ H_max | H_max ]; rewrite H_max.

          + change v' with (proj_right (cbv_constr lp t' v')) at 1.
            apply value_size_bounded_by_nb_judgements.
            assumption.

          + simpl.
            apply le_S.
            transitivity (maxl (map nb_judgements lp)).

            * apply maxl_le_maxl.
              intros p' H_in_lp.
              apply IH.
              assumption.
              apply (wf_InCBV_wf H_wf_p).
              simpl.
              right.
              apply orl_map.
              exists p'.

              split.
              trivial.
              apply InCBV_refl.

            * apply maxl_le_suml.

        - simpl max_proj_right_size.
          destruct (max_dec (value_size v') (max (max_proj_right_size p') (maxl (map max_proj_right_size lp)))) as [H_max | H_max ]; rewrite H_max; clear H_max.

          + change v' with (proj_right (cbv_split lp p' t' v')).
            apply value_size_bounded_by_nb_judgements.
            assumption.

          + simpl.
            apply le_S.
            destruct (max_dec (max_proj_right_size p') (maxl (map max_proj_right_size lp))) as [ H_max | H_max ]; rewrite H_max; clear H_max.

            * apply le_plus_trans.
              apply IH_p'.
              apply (wf_InCBV_wf H_wf_p).
              simpl; right; left; apply InCBV_refl.

            * rewrite plus_comm.
              apply le_plus_trans.

              { transitivity (maxl (map nb_judgements lp)).

                + apply maxl_le_maxl.
                  intros p'' H_in_lp.
                  apply IH_lp.
                  assumption.
                  apply (wf_InCBV_wf H_wf_p).
                  simpl.
                  right; right.
                  apply orl_map.
                  exists p''.

                  split.
                  trivial.
                  apply InCBV_refl.

                + apply maxl_le_suml.
              }

        - simpl max_proj_right_size.
          destruct (max_dec (value_size v') (max_proj_right_size p')) as [H_max | H_max ]; rewrite H_max; clear H_max.

          + change v' with (proj_right (cbv_function i' s' p' t' v')).
            apply value_size_bounded_by_nb_judgements.
            assumption.

          + simpl.
            apply le_S.
            apply IH.
            apply (wf_InCBV_wf H_wf_p).
            simpl; right; apply InCBV_refl.
      }

    * apply nb_judgements_bound_gen; trivial.
Qed.

Theorem size_bound : forall i s p' t v,
  let p := cbv_function i s p' t v in
  let A := length (ℐᵃ p) in
  let S := max_active_size p in
 wf p ->
  size p <=
  (A * 𝓡 prog S + A) * (𝓡 prog S + S + A * 𝓡 prog S + A).
Proof.
intros i s p0 t v p A S H_wf_p.
etransitivity.
- apply size_bounded_nb_size_judgements.
- apply mult_le_compat.

  + apply nb_judgements_bound_gen; trivial.

  + apply size_judgement; trivial.
Qed.

End CBV.