  (***************************************************************)
  (*   This file is part of the static analyses developement -   *)
  (*   specification of kildall's algorithm, and proof it is a   *)
  (*   bytecode verifier -                                       *)
  (*						  	         *)
  (*   File : machine_shapes.v		  		         *)
  (*   Authors : S. Coupet-Grimal, W. Delobel 		         *)
  (*   Content : shape verification                              *)
  (***************************************************************)

Section machine_shapes.

  Require Export fresh_variables.

  Notation configuration := (list (frame)).
  Notation Get_function := (get_function_by_name functions).
  Notation Get_constr := (get_constr_by_name constructors).
  Notation Frm := (mkframe).
  Notation Substitution := (list subst_elem).
  Notation Expression := (tree Name Name).

  (* initial shape for function fcn : *)
  Definition Sss_init (fcn : function) :=
    (constant_list (fcn_size fcn) Bot_S)[0<-(Shapes nil (init_vars fcn))].

  (* result of the shape analysis algorithm : *)
  Definition Kildall_Shapes (fcn : function) (Hin : In fcn functions) :=
    Kildall_shapes fcn (lrs_functions fcn Hin) (Sss_init fcn).

  Definition Hvars (n : nat) (ss : vector Sigma_S n) : Prop :=
    forall (p : nat) (C : p < n) (ls : Substitution) (le : list Expression),
      ss[p|C] = Shapes ls le ->
      (forall (e : Expression), In e le -> (forall (h p' : nat), p' > p -> var_not_in_tree e p' h))
      /\
      (forall (s : subst_elem), In s ls -> (forall (h p' : nat), p' > p -> ~var_in_subst_elem s p' h)).

  Hypothesis fwd_jmp : forall (fcn : function) (Hin : In fcn functions) (p : nat) (C : p < fcn_size fcn)
    (cnm : name) (j: nat) (Cj : j < fcn_size fcn),
    (fcn_bytecode fcn)[p|C] = i_branch (fcn_size fcn) cnm j Cj -> j > p.

  Definition ss_init (fcn : function) :=
    (constant_list (fcn_size fcn) Bot_T)[0<-(Types (rev (fcn_args fcn)))].

  Hypothesis Passed_Kildall_Types : forall (fcn : function) (Hin : In fcn functions),
    ~ Top_T INv (machine_types.Kildall_Types fcn Hin).

  Hypothesis Passed_Kildall : forall (fcn : function) (Hin : In fcn functions),
    ~ Top_S INv (Kildall_Shapes fcn Hin).

  Hypothesis Pattern_branch : forall (fcn : function) (Hin : In fcn functions)
    (p : nat) (C : p < fcn_size fcn) (cnm : name)
    (j: nat) (Cj : j < fcn_size fcn)
    (s : Substitution) (e : Expression) (le : list Expression),
    (fcn_bytecode fcn)[p|C] = i_branch (fcn_size fcn) cnm j Cj ->
    (Kildall_Shapes fcn Hin)[p|C] = Shapes s (e::le) ->
    tree_is_pattern e.

  Definition wellshaped_plus_frame (f : frame) : Prop :=
    forall (fcn : function) (Hget : Get_function (frm_fun f) = Some fcn)
      (C : (frm_pc f) < (fcn_size fcn)),
      ex (fun (s : Substitution) => (ex (fun (lexpr : list Expression) => ex (fun (rho : Substitution) =>
        (Kildall_Shapes fcn (get_some_in_functions fcn (frm_fun f) functions Hget))[(frm_pc f)|C] = Shapes s lexpr /\
        stack_shaping (map (apply s) (init_vars fcn)) (frm_args f) rho /\
        (forall (j : nat) (e : Expression) (v : value),
          lexpr[j] = Some e -> (frm_stack f)[j] = Some v -> tree_is_pattern e ->
          tree_name_to_tree_Name v = apply rho e) /\ length lexpr = length (frm_stack f))))).

  Inductive wellshaped_configuration : configuration -> Prop :=
    wellshaped_conf : forall (M : configuration) , welltyped_configuration M ->
      ( (* top frame well shaped *)
        (forall (f : frame), element_at_list M 0 = Some f -> wellshaped_plus_frame f)
        /\
      (* stack i @ args i-1 wellshaped *)
        (forall (i : nat) (fi fpi : frame), M[i] = Some fi -> M[S i] = Some fpi ->
          wellshaped_plus_frame (mkframe ((frm_fun fpi)) ((frm_pc fpi)) ((frm_args fi)++(frm_stack fpi)) (frm_args fpi)))) ->
      wellshaped_configuration M.

  Lemma Wshi_Kildall : forall (fcn : function) (Hin : In fcn functions) (p : nat) (C : p < (fcn_size fcn)),
    Wshi fcn (Kildall_Shapes fcn Hin) p C.
  Proof.
    intros fcn Hin p C.
    cut (Is_data_flow_analyser Sigma_S ((fcn_size fcn))
      (Succs ((fcn_size fcn)) ((fcn_bytecode fcn)) (lrs_functions fcn Hin))
      (Step_S fcn) r_S
      (Step_S_Succs_same_length fcn (lrs_functions fcn Hin))
      (Kildall_shapes fcn (lrs_functions fcn Hin))).
    unfold Is_data_flow_analyser; unfold Kildall_Shapes.
    intro is_dfa; generalize (is_dfa (Sss_init fcn)); clear is_dfa; intro is_dfa.
    elim is_dfa; clear is_dfa; intros dfa1 H.
    elim H; clear H; intros dfa2 H.
    apply (stable_imp_Wshi fcn (lrs_functions fcn Hin)).
    apply (Passed_Kildall fcn Hin).
    apply dfa1.
    apply (monotone_step_imp_kildall_dfa Sigma_S (fcn_size fcn) (Succs (fcn_size fcn) (fcn_bytecode fcn) (lrs_functions fcn Hin))
      (Step_S fcn) r_S sup_S (Step_S_Succs_same_length fcn (lrs_functions fcn Hin)) eq_Sigma_S_dec  r_S_is_semilattice  wfr_S).
    apply Succs_equiv.
    apply Step_S_equiv.
    apply monotone_Step_S.
  Qed.

  Lemma Kildall_Shapes_0 : forall (fcn : function) (Hin : In fcn functions),
    (Kildall_Shapes fcn Hin)[0|nonvoidfcn fcn Hin] = (Sss_init fcn)[0|nonvoidfcn fcn Hin].
  Proof.
    intros fcn Hin.
    cut (Is_data_flow_analyser Sigma_S ((fcn_size fcn))
      (Succs ((fcn_size fcn)) ((fcn_bytecode fcn)) (lrs_functions fcn Hin))
      (Step_S fcn) r_S
      (Step_S_Succs_same_length fcn (lrs_functions fcn Hin))
      (Kildall_shapes fcn (lrs_functions fcn Hin))).
    unfold Is_data_flow_analyser.
    intro is_dfa; generalize (is_dfa (Sss_init fcn)); clear is_dfa; intro is_dfa.
    elim is_dfa; clear is_dfa; intros dfa1 H.
    elim H; clear H; intros dfa2 dfa3.
    cut (r_S (element_at (Sss_init fcn) 0 (nonvoidfcn fcn Hin)) (element_at (Kildall_Shapes fcn Hin) 0 (nonvoidfcn fcn Hin))).
    intro Hr.
    CaseEq (element_at (Kildall_Shapes fcn Hin) 0 (nonvoidfcn fcn Hin)).
    intro case; generalize Hr; clear Hr; rewrite case.
    intro Hr; destruct (element_at (Sss_init fcn) 0 (nonvoidfcn fcn Hin)); inversion Hr.
    trivial.
    intro case; elim (Passed_Kildall fcn Hin); rewrite <- case; apply element_at_belong.
    intros l lexpr case.
    generalize Hr; clear Hr; rewrite case.
    unfold Sss_init.
    rewrite element_at_in_replaced.
    intro Hr; inversion Hr.
    trivial.
    unfold Kildall_Shapes; generalize dfa2; unfold Vector_pointwise; apply vector_pointwise_to_element.
    apply (monotone_step_imp_kildall_dfa Sigma_S ((fcn_size fcn)) (Succs ((fcn_size fcn)) ((fcn_bytecode fcn)) (lrs_functions fcn Hin))
      (Step_S fcn) r_S (sup_S ) (Step_S_Succs_same_length fcn (lrs_functions fcn Hin)) eq_Sigma_S_dec r_S_is_semilattice wfr_S).
    apply Succs_equiv.
    apply Step_S_equiv.
    apply monotone_Step_S.
  Qed.

  Lemma reduction_keeps_wellshaped : Invariant (fun (M : configuration) => wellshaped_configuration M /\ frames_args_length M).
  Proof.
    intros M M' PM Hred.
    elim PM; intros Hws Hfal; clear PM; split.
    InversionRed Hred.
    Focus 1.
  (* return *)
    cut (frm_pc f < fcn_size fcn).
    inversion Hws; subst; generalize H; elim H0; clear H H0; intros Hwstop Hwsvirtual.
    cut (element_at_list (f :: g :: M0) 0 = Some f); [intro Hf | trivial].
    intros Hwt C; elim (Hwstop f Hf fcn Hfcn C); intros s h.
    elim h; clear Hwstop h; intros lexpr h.
    elim h; clear h; intros rho h.
    elim h; clear h; intros case_shapes_f h.
    elim h; clear h; intros Hshapingf h.
    elim h; clear h; intros Hpattern Hlengthf.
    generalize (Wshi_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn) (frm_pc f) C).
    unfold Wshi.
    rewrite case_shapes_f.
    replace (element_at (fcn_bytecode fcn) (frm_pc f) C) with (i_return (fcn_size fcn)).
    intro Hnotnil.
    destruct lexpr.
    elim Hnotnil; trivial.
    clear Hnotnil.
    constructor.
    generalize Hred; apply reduction_keeps_welltyped; trivial.
    split.
    intros f' Hf' gcn Hgetg Cg.
    simpl in Hf'; inversion Hf'; subst f'; (clear Hf').
    cut (frm_pc g < fcn_size gcn); [intro Cg' | generalize Cg; simpl; auto with arith].
    generalize (Wshi_Kildall gcn (get_some_in_functions  gcn (frm_fun g) functions Hgetg) (frm_pc g) Cg').
    unfold Wshi.
    CaseEq (element_at (Kildall_Shapes gcn (get_some_in_functions  gcn (frm_fun g) functions Hgetg)) (frm_pc g) Cg').
    intro case_shapes_g; cut False; [intro F; inversion F | generalize (Hwsvirtual 0 f g)].
    simpl.
    clear Hf; cut (Some f = Some f); [intro Hf | trivial].
    cut (Some g = Some g); [intro Hg | trivial].
    intro h; generalize (h Hf Hg gcn); clear h; intro h.
    generalize (h Hgetg Cg'); clear h Hf Hg; intro wspf1.
    inversion_clear wspf1 as [s1 h].
    inversion_clear h as [lexpr1 h1].
    inversion_clear h1 as [rho1 h].
    elim h; clear h; simpl.
    intros case_shapes_f1 h; rewrite case_shapes_f1 in case_shapes_g; inversion case_shapes_g.
    intros dd F; inversion F.
    intros l0 l1 case_shapes_g.
    cut (element_at (fcn_bytecode gcn) (frm_pc g) Cg' = i_call (fcn_size gcn) (frm_fun f) (length (frm_args f))).
    intro case_instr_g; rewrite case_instr_g.
    CaseEq (split_k_elements (length (frm_args f)) l1).
    intros p case_split_l1; destruct p.
    CaseEq (element_at_unsafe (Kildall_Shapes gcn (get_some_in_functions  gcn (frm_fun g) functions Hgetg)) (S (frm_pc g))).
    intros s0 case_shapes_g_s; destruct s0.
    intro F; inversion F.
    intro F; inversion F.
    intro h; elim h; clear h; intros h1 h2; subst.
    exists l0.
    exists (Node (symbol (frm_fun f)) (rev_lin l2) :: l3).

    clear Hf; cut (Some f = Some f); [intro Hf | trivial].
    cut (Some g = Some g); [intro Hg | trivial].
    generalize (Hwsvirtual 0 f g Hf Hg gcn); intro Hh; simpl in Hh.
    generalize (Hh Hgetg Cg'); clear Hh.
    intro Hh; inversion_clear Hh as [sg h].
    inversion_clear h as [lexprg h1].
    inversion_clear h1 as [rhog h2].
    exists rhog.
    simpl in h2.
    clear Hf Hg.

    CaseEq (frm_stack f).
    intro h; rewrite h in Hlengthf; simpl in Hlengthf; inversion Hlengthf.
    intros v l4 Hstackf.
    elim h2; clear h2; intros h2 h3.
    elim h3; clear h3; intros h3 h4.
    elim h4; clear h4; intros h4 h5.
    rewrite case_shapes_g in h2; inversion h2.

    subst; repeat split.
    simpl; simpl in Cg; simpl in Hgetg; simpl in case_shapes_g_s.
    generalize case_shapes_g_s; apply element_at_unsafe_to_safe.
    simpl; assumption.
    intros j ej vj Hej Hvj.
    destruct j.
    inversion Hej; inversion Hvj.
    subst ej vj.
    clear Hej Hvj h2.
    unfold tree_is_pattern.
    simpl; rewrite Hfcn.
    simpl; intro h; inversion h.
    simpl in Hej; simpl in Hvj.
    generalize (h4 (length l2 + j) ej vj); clear h4; intro h4.
    cut (element_at_list (l2 ++ l3) (length l2 + j) = element_at_list l3 j); [intro Hlej | apply element_at_list_concat].
    cut (length l2 = length (frm_args f)); [intro h6 | generalize case_split_l1; apply split_k_elements_length].
    apply h4.
    replace lexprg with (l2 ++ l3).
    rewrite Hlej; generalize Hej; destruct (element_at_list l3 j); trivial.
    symmetry; generalize case_split_l1; apply split_k_elements_ok.
    replace (element_at_list (frm_args f ++ frm_stack g) (length l2 + j)) with (element_at_list (frm_stack g) j).
    generalize Hvj; destruct (element_at_list (frm_stack g) j); trivial.
    symmetry; rewrite h6; apply element_at_list_concat.
    simpl.
    cut (length l3 = length (frm_stack g)); [auto with arith | idtac].
    rewrite concat_length in h5.
    replace lexprg with (l2 ++ l3) in h5.
    rewrite concat_length in h5.
    generalize h5; replace (length (frm_args f)) with (length l2); [apply plus_reg_l | generalize case_split_l1; apply split_k_elements_length].
    symmetry; generalize case_split_l1; apply split_k_elements_ok.
    intros dd F; inversion F.
    intros dd F; inversion F.
    inversion Hwt; subst.
    elim (H 0 f g fcn gcn); simpl; trivial.
    intros dd h; elim h; clear dd h.
    intros dd h; cut (Some g = Some g); [intro hg | trivial].
    simpl in Hgetg; generalize (h hg Hgetg); apply element_at_unsafe_to_safe.
    assumption.

  (* part 2 *)
    intros i fi fpi Hfi Hfpi.
    destruct i.
    inversion Hfi; subst.
    simpl; apply (Hwsvirtual 1 g fpi); simpl; trivial.
    apply (Hwsvirtual (S (S i))).
    simpl; simpl in Hfi; rewrite Hfi; trivial.
    simpl; simpl in Hfpi; rewrite Hfpi; trivial.
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
    generalize case_instr; apply element_at_unsafe_some.

  (* stop *)
    constructor.
    constructor.
    apply wellformed_epsilon.
    split.
    intros dd F; inversion F.
    intros i fi fpi F; inversion F.
    split.
    intros dd F; inversion F.
    intros i fi fpi F; inversion F.

  (* load *)
    Focus 1.
    inversion Hws; subst.
    generalize H; elim H0; intros Hwstop Hwsvirtual Hwt.
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | trivial].
    generalize (Hwstop f Hf); clear Hwstop H H0; intro Hwstop.
    inversion Hwt; subst.
    generalize H; elim H0; intros Hwttop Hwtvirtual Hwf.
    generalize (Hwttop f Hf); clear Hwttop H H0 Hf; intro Hwttop.
    constructor.
    generalize Hwt Hred ; apply reduction_keeps_welltyped; trivial.
    cut (frm_pc f < fcn_size fcn).
    intro C.
    split.
    intros f' Hf' fcn' Hfcn' C'; inversion Hf'; subst f'; (clear Hf').
    simpl in C'; simpl in Hfcn'; cut (fcn' = fcn); [intro ; subst | rewrite Hfcn' in Hfcn; inversion Hfcn; trivial].
    elim (Hwstop fcn Hfcn' C); intros s h.
    elim h; clear Hwstop h; intros lexpr h.
    elim h; clear h; intros rho h.
    elim h; clear h; intros case_shapes_f h.
    elim h; clear h; intros Hshapingf h.
    elim h; clear h; intros Hpattern Hlengthf.
    generalize (Wshi_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn') (frm_pc f) C).
    unfold Wshi.
    rewrite case_shapes_f.
    replace (element_at (fcn_bytecode fcn) (frm_pc f) C) with (i_load  (fcn_size fcn) j).
    CaseEq (element_at_unsafe (Kildall_Shapes fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn')) (S (frm_pc f))).
    intros s' case_shapes_f_s; destruct s'.
    intro F; inversion F.
    intro F; inversion F.
    CaseEq (element_at_list (rev_lin lexpr) j).
    intros ej case_ej h; elim h; clear h; intros h hh; subst.
    exists s; exists (ej :: lexpr); exists rho.
    repeat split; simpl; trivial.
    generalize case_shapes_f_s; apply element_at_unsafe_to_safe.
    intros j' ej' vj' Hej' Hvj'; destruct j'.
    inversion Hej'; inversion Hvj'; subst.
    cut (j < length (rev lexpr)).
    intro Cj.
    apply (Hpattern (length (rev lexpr) - S j) ej' vj').
    cut (element_at_list (rev (rev lexpr)) (length (rev lexpr) - S j) = Some ej'); [rewrite rev_involutive; trivial | rewrite <- case_ej].
    symmetry; rewrite rev_lin_is_rev; apply element_at_list_rev; trivial.
    generalize Cj; rewrite rev_length; rewrite Hlengthf; rewrite <- rev_length; clear Cj; intro Cj.
    replace (Some vj') with (element_at_list (rev (rev (frm_stack f))) (length (rev (frm_stack f)) - S j)).
    rewrite rev_involutive; trivial.
    rewrite <- Hvj; symmetry; rewrite rev_lin_is_rev; apply element_at_list_rev; trivial.
    generalize case_ej; rewrite rev_lin_is_rev; apply element_at_list_some.
    apply (Hpattern j').
    generalize Hej'; destruct (element_at_list lexpr j'); trivial.
    generalize Hvj'; destruct (element_at_list (frm_stack f) j'); trivial.
    generalize Hlengthf; auto with arith.
    intros dd F; inversion F.
    intros dd F; inversion F.
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
  (* part 2 *)
    intros i fi fpi Hfi Hfpi; destruct i.
    inversion Hfi; subst; simpl.
    apply (Hwsvirtual 0 f fpi); trivial.
    simpl in Hfi; simpl in Hfpi; apply (Hwsvirtual (S i) fi fpi); simpl; trivial.
    generalize case_instr; apply element_at_unsafe_some.

  (* call *)
    Focus 1.
    inversion Hws; subst.
    generalize H; elim H0; intros Hwstop Hwsvirtual Hwt.
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | trivial].
    generalize (Hwstop f Hf); clear Hwstop H H0; intro Hwstop.
    inversion Hwt; subst.
    generalize H; elim H0; intros Hwttop Hwtvirtual Hwf.
    generalize (Hwttop f Hf); clear Hwttop H H0 Hf; intro Hwttop.
    constructor.
    generalize Hwt Hred ; apply reduction_keeps_welltyped; trivial.
    split.
    intros g' Hg' gcn' Hgcn' Cg; simpl.
    inversion Hg'; subst g'; (clear Hg').
    simpl; rewrite (element_at_irrel Sigma_S (fcn_size gcn') (Kildall_Shapes gcn' (get_some_in_functions  gcn' gnm functions Hgcn')) 0 Cg (nonvoidfcn gcn' (get_some_in_functions  gcn' gnm functions Hgcn'))).
    rewrite Kildall_Shapes_0; unfold Sss_init; rewrite element_at_in_replaced.
    exists (nil (A := subst_elem)); exists (init_vars gcn').
    cut (length (init_vars gcn') = length vargs).
    intro Hlengthg.
    CaseEq (init_subst (rev_lin vargs)).
    intros l0 case_init_subst.
    exists l0.
    repeat split; trivial.
    simpl; rewrite map_id.

    unfold stack_shaping; unfold init_vars.
    rewrite <- (rev_involutive vargs).
    rewrite <- rev_lin_is_rev.
    apply (init_stack_shaping (length (fcn_args gcn')) 0 (rev vargs) l0); trivial.
    generalize case_init_subst; unfold init_subst; rewrite rev_lin_is_rev.
    rewrite rev_length; rewrite <- Hlengthg; rewrite init_vars_length; trivial.

    unfold init_vars; intros j ej vj Hej Hvj Hpattern.
    generalize (element_at_init_vars  (length (fcn_args gcn')) 0 0 j ej Hej); intro Hejeq.
    rewrite plus_comm in Hejeq; simpl in Hejeq.
    cut ((rev vargs)[(length vargs) - (S j)] = Some vj); [clear Hvj; intro Hvj |  rewrite <- element_at_list_rev; trivial].
    rewrite rev_lin_is_rev in case_init_subst; unfold init_subst in case_init_subst.
    rewrite rev_length in case_init_subst; rewrite <- Hlengthg in case_init_subst.
    rewrite init_vars_length in case_init_subst.
    rewrite <- (init_subst_apply (length (fcn_args gcn')) 0 (length vargs - S j) l0 (rev vargs) vj Hvj case_init_subst).
    simpl; subst; rewrite <- Hlengthg.
    rewrite init_vars_length; trivial.
    generalize Hvj; apply element_at_list_some.
    intro F; elim (subst_length (length (fcn_args gcn')) 0 (rev vargs)).
    rewrite rev_length; rewrite <- (init_vars_length gcn'); symmetry; assumption.
    rewrite <- F; unfold init_subst; rewrite rev_lin_is_rev.
    rewrite rev_length; rewrite <- Hlengthg; rewrite init_vars_length; trivial.

    symmetry; replace vargs with (frm_args (Frm gnm 0 vargs vargs)).
    rewrite (init_vars_length gcn').
    cut (frames_args_length (mkframe gnm 0 vargs vargs :: mkframe (frm_fun f) (frm_pc f) l (frm_args f) :: M0)).
    intro Hfal'; apply Hfal'; trivial.
    left; trivial.
    cut (welltyped_configuration (mkframe gnm 0 vargs vargs :: mkframe (frm_fun f) (frm_pc f) l (frm_args f) :: M0) /\ frames_args_length (mkframe gnm 0 vargs vargs :: mkframe (frm_fun f) (frm_pc f) l (frm_args f) :: M0)).
    intro H; elim H; trivial.
    generalize Hred; apply reduction_length; trivial.
    split; trivial.
    simpl; trivial.

  (* part 2 *)
    intros i fi fpi Hfi Hfpi.
    destruct i; simpl.
    inversion Hfi; inversion Hfpi; subst.
    simpl.
    replace (vargs ++ l) with (frm_stack f).
    apply Hwstop.
    generalize case_split_stack; apply split_k_elements_ok.
    destruct i.
    inversion Hfi.
    simpl.
    apply (Hwsvirtual 0 f fpi); simpl; trivial.
    apply (Hwsvirtual (S i) fi fpi); simpl; trivial.

  (* build *)
    Focus 1.
    inversion Hws; subst.
    generalize H; elim H0; intros Hwstop Hwsvirtual Hwt.
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | trivial].
    generalize (Hwstop f Hf); clear Hwstop H H0; intro Hwstop.
    inversion Hwt; subst.
    generalize H; elim H0; intros Hwttop Hwtvirtual Hwf.
    generalize (Hwttop f Hf); clear Hwttop H H0 Hf; intro Hwttop.
    constructor.
    generalize Hwt Hred ; apply reduction_keeps_welltyped; trivial.
    split.

    intros g' Hg' gcn Hgcn Cg; simpl.
    inversion Hg'; subst g'; (clear Hg').
    cut (fcn = gcn).
    intro; subst fcn; simpl; simpl in Hgcn; simpl in Cg.
    cut (frm_pc f < fcn_size gcn).
    intro C.
    elim (Hwstop gcn Hgcn C).
    intros s h; elim h; clear h.
    intros lexpr h; elim h; clear h.
    intros rho h; elim h; clear h.
    intros h1 h; elim h; clear h.
    intros h2 h; elim h; clear h; intros h3 h4.
    generalize (Wshi_Kildall gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn) (frm_pc f) C).
    unfold Wshi.
    replace (element_at (fcn_bytecode gcn) (frm_pc f) C) with (i_build (fcn_size gcn) cnm car).
    rewrite h1.
    CaseEq (split_k_elements car lexpr).
    intros p case_split_lexpr; destruct p as [sargs slexpr].
    CaseEq (element_at_unsafe (Kildall_Shapes gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn)) (S (frm_pc f))).
    intros s0 case_shapes_f_s.
    destruct s0.
    intro F; inversion F.
    intro F; inversion F.
    intro h; elim h; clear h; intros h5 h6; subst l0 l1.
    exists s; exists (Node (symbol cnm) (rev_lin sargs) :: slexpr).
    cut ((Kildall_Shapes gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn))[S (frm_pc f)|Cg] = Shapes s (Node (symbol cnm) (rev_lin sargs) :: slexpr)); [intro case_shapes_f_s'; rewrite case_shapes_f_s' | generalize case_shapes_f_s; apply element_at_unsafe_to_safe].
    exists rho.
    repeat split.
    assumption.
    intros j ej vj Hej Hvj Hpattern; destruct j.
    inversion Hej; inversion Hvj; subst.
    rewrite (apply_cons cnm rho (rev vargs) (rev_lin sargs)).
    simpl; trivial.
    rewrite rev_length; rewrite rev_lin_is_rev; rewrite rev_length.
    replace (length sargs) with car.
    generalize case_split_stack; apply split_k_elements_length.
    symmetry; generalize case_split_lexpr; apply split_k_elements_length.
    intros vj ej j Hvj2 Hej2; symmetry; apply (h3 (length sargs - S j) ej vj).
    replace lexpr with (sargs ++ slexpr).
    rewrite <- (element_at_list_concat').
    replace sargs with (rev (rev sargs)).
    rewrite rev_length.
    generalize Hej2; rewrite rev_lin_is_rev; rewrite (element_at_list_rev _ (rev sargs) j); trivial.
    generalize Hej2; rewrite rev_lin_is_rev; apply element_at_list_some.
    apply rev_involutive.
    (* SHOULD BE A LEMMA *)
    cut (0 < length sargs); [generalize (length sargs); intro k | destruct sargs; simpl].
    generalize j; induction k.
    intros dd F; inversion F.
    intros j0 Ck.
    destruct j0.
    simpl.
    rewrite <- minus_n_O.
    auto with arith.
    simpl.
    destruct k.
    simpl; trivial.
    apply lt_trans with (S k).
    apply IHk; trivial.
    auto with arith.
    auto with arith.
    simpl in Hej2.
    inversion Hej2.
    auto with arith.
    (* END LEMMA *)
    symmetry; generalize case_split_lexpr; apply split_k_elements_ok.
    replace (frm_stack f) with (vargs ++ l).
    rewrite <- (element_at_list_concat').
    replace (length sargs) with (length vargs).
    replace vargs with (rev (rev vargs)).
    rewrite rev_length.
    rewrite <- (element_at_list_rev _ (rev vargs) j).
    assumption.
    generalize Hvj2; apply element_at_list_some.
    apply rev_involutive.
    replace (length vargs) with car; symmetry.
    generalize case_split_lexpr; apply split_k_elements_length.
    generalize case_split_stack; apply split_k_elements_length.
    replace (length vargs) with (length sargs).
    cut (0 < length sargs); [generalize (length sargs); intro k | destruct sargs; simpl].
    generalize j; induction k.
    intros dd F; inversion F.
    intros j0 Ck.
    destruct j0.
    simpl.
    rewrite <- minus_n_O.
    auto with arith.
    simpl.
    destruct k.
    simpl; trivial.
    apply lt_trans with (S k).
    apply IHk; trivial.
    auto with arith.
    auto with arith.
    simpl in Hej2.
    inversion Hej2.
    auto with arith.
    replace (length sargs) with car; symmetry.
    generalize case_split_stack; apply split_k_elements_length.
    generalize case_split_lexpr; apply split_k_elements_length.
    symmetry; generalize case_split_stack; apply split_k_elements_ok.
    rewrite rev_lin_is_rev in Hpattern; rewrite rev_lin_is_rev in Hej2; apply (sub_pattern cnm (rev sargs) Hpattern j ej Hej2).
    apply (h3 (car+j) ej vj).
    replace car with (length sargs).
    replace lexpr with (sargs++slexpr).
    rewrite element_at_list_concat.
    generalize Hej; simpl; destruct (element_at_list slexpr j); trivial.
    symmetry; generalize case_split_lexpr; apply split_k_elements_ok.
    generalize case_split_lexpr; apply split_k_elements_length.
    replace car with (length vargs).
    replace (frm_stack f) with (vargs ++ l).
    rewrite element_at_list_concat.
    generalize Hvj; simpl; destruct (element_at_list l j); trivial.
    symmetry; generalize case_split_stack; apply split_k_elements_ok.
    generalize case_split_stack; apply split_k_elements_length.
    assumption.
    simpl; cut (length slexpr = length l); [auto with arith | idtac].
    generalize h4; replace lexpr with (sargs ++ slexpr).
    rewrite concat_length.
    replace (frm_stack f) with (vargs++l).
    rewrite concat_length.
    replace (length sargs) with car.
    replace (length vargs) with car.
    apply plus_reg_l.
    symmetry; generalize case_split_stack; apply split_k_elements_length.
    symmetry; generalize case_split_lexpr; apply split_k_elements_length.
    symmetry; generalize case_split_stack; apply split_k_elements_ok.
    symmetry; generalize case_split_lexpr; apply split_k_elements_ok.
    intros dd F; inversion F.
    intros dd F; inversion F.
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
    generalize case_instr; apply element_at_unsafe_some.
    simpl in Hgcn; rewrite Hgcn in Hfcn; inversion Hfcn; trivial.
  (* part 2 *)
    subst; intros i fi fpi Hfi Hfpi; destruct i.
    inversion Hfi; subst; simpl.
    apply (Hwsvirtual 0 f fpi).
    simpl; trivial.
    simpl; simpl in Hfpi; trivial.
    simpl in Hfi; simpl in Hfpi; apply (Hwsvirtual (S i) fi fpi); simpl; trivial.

  (* branch then *)
    Focus 1.
    cut (frm_pc f < fcn_size fcn).
    intro C.
    inversion Hws; subst.
    generalize H; elim H0; intros Hwstop Hwsvirtual Hwt.
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | trivial].
    generalize (Hwstop f Hf); clear Hwstop H H0; intro Hwstop.
    inversion Hwt; subst.
    generalize H; elim H0; intros Hwttop Hwtvirtual Hwf.
    generalize (Hwttop f Hf); clear Hwttop H H0 Hf; intro Hwttop.
    constructor.
    generalize Hwt Hred ; apply reduction_keeps_welltyped; trivial.
    split.
    intros g' Hg'; inversion Hg'; subst g'; (clear Hg').
    intros gcn Hgcn Cg; simpl; simpl in Hgcn; simpl in Cg.
    cut (fcn = gcn).
    intro; subst.
    elim (Hwstop gcn Hgcn C); intros s h.
    elim h; clear h; intros lexpr h.
    elim h; clear h; intros rho h.
    elim h; clear h; intros h1 h.
    elim h; clear h; intros h2 h.
    elim h; clear h; intros h3 h4.
    generalize (Wshi_Kildall gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn) (frm_pc f) C).
    unfold Wshi.
    replace (element_at (fcn_bytecode gcn) (frm_pc f) C) with (i_branch (fcn_size gcn) cnm j Cj).
    rewrite h1.
    destruct lexpr.
    intro F; inversion F.
    destruct t.
    intro F; inversion F.
    destruct n.

  (* n is a variable*)
    destruct l0; [idtac| intro F; inversion F].
    CaseEq (Get_constr cnm).
    intros c case_c.
    CaseEq (element_at_unsafe (Kildall_Shapes gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn)) (S (frm_pc f))).
    intros s0 case_f_s; destruct s0.
    intro F; elim F; clear F; intros dd F; inversion F.
    intro F; elim F; clear F; intros dd F; inversion F.
    intro h; elim h; intro dd; clear dd h. (* part wshi j cleared *)
    intro h; elim h; clear h; intros h h'; subst.
    exists (mksubst n n0 (Node (symbol cnm) (fresh (S (frm_pc f)) (S (length lexpr)) (length (cons_args c)))) :: s).
    exists (push_list (fresh (S (frm_pc f)) (S (length lexpr)) (length (cons_args c)))
     (map (apply_elem_tree (mksubst n n0 (Node (symbol cnm) (fresh (S (frm_pc f)) (S (length lexpr)) (length (cons_args c)))))) lexpr)).
    cut (tree_name_to_tree_Name (Node cnm vf) = apply  rho (Node (x  n n0) nil)); [intro Hrho_head | apply (h3 0); simpl; trivial].
    cut (length vf = length (cons_args c)); [intro Hlenvf | idtac].
    CaseEq (make_substitution (fresh (S (frm_pc f)) (S (length lexpr)) (length (cons_args c))) vf).
    intros svf case_svf.
    exists (rho ++ svf).
    repeat split.
    generalize case_f_s; apply element_at_unsafe_to_safe.
    unfold stack_shaping; rewrite (map_apply_substitution_concat).
    rewrite (map_apply_substitution_cons).
    generalize h2; unfold stack_shaping.
    cut (forall (e : Expression) (j : nat), In e (map (apply s) (init_vars gcn)) -> var_not_in_tree e (S (frm_pc f)) ((S (length lexpr))+j)).
    generalize (frm_args f) (map (apply s) (init_vars gcn)); intros lv le.
  (* MAKE IT A LEMMA *)
    generalize case_svf; generalize (S (frm_pc f)) (S (length lexpr)) (length (cons_args c)) Hrho_head.
    intros p h m.
    generalize lv; clear lv; induction le; simpl; intro lv; trivial.
    destruct lv; simpl; trivial.
    intros dd ddd dddd F; inversion F.
    intros.
    rewrite <- IHle; trivial.
    simpl.
    rewrite <- (make_substitution_simpl_in_branch_then_elem cnm n n0 m p h svf rho vf a v nil); trivial.
    intro j0; apply (H a j0).
    left; trivial.
    inversion h0; trivial.
    intros e j0 He; apply (H e j0).
    right; assumption.
    inversion h0; trivial.
    intros e j0 Hine; generalize (really_fresh_alt fwd_jmp gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn) (frm_pc f) C s (Node (x n n0) nil :: lexpr) h1 e Hine (S (length lexpr) + j0)); simpl; trivial.

    intros j0 e v; elim (le_gt_dec (length (cons_args c)) j0); intro case_elem.
    rewrite (le_plus_minus (length (cons_args c)) j0 case_elem).
    rewrite push_list_is_app_rev.
    cut (length (rev (fresh (S (frm_pc f)) (S (length lexpr)) (length (cons_args c)))) + (j0 - length (cons_args c)) = length (cons_args c) + (j0 - length (cons_args c))).
    intros Hlene He; rewrite <- Hlene in He.
    rewrite (element_at_list_concat) in He.
    rewrite push_list_is_app_rev.
    cut (length (rev vf) + (j0 - length (cons_args c)) = length (cons_args c) + (j0 - length (cons_args c))).
    intros Hlenv Hv; rewrite <- Hlenv in Hv.
    rewrite element_at_list_concat in Hv.
    generalize (h3 (S (j0 - length (cons_args c)))); intro h3j0.
    elim (element_at_list_map' _ _ _ _ _ e He).
    intros ae Hae; elim Hae; clear Hae; intros Hae1 Hae2.
    rewrite Hstack in h3j0.
    intro Hpate.
    symmetry.
    rewrite apply_substitution_concat.
    rewrite Hae2.
    generalize (make_substitution_simpl_in_branch_then_elem cnm n n0 (length (cons_args c)) (S (frm_pc f)) (S (length lexpr)) svf rho vf ae v nil).
    intro h; apply h; clear h; trivial.
    elim (Really_fresh fwd_jmp gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn) (frm_pc f) C s (Node (x n n0) nil :: lexpr) h1); intros rf1 rf2.
    simpl in rf1.
    cut (Node (x n n0) nil = ae \/ In ae lexpr); [intro Hinae | right].
    intro j1; apply (rf1 ae Hinae (S (length lexpr + j1))).
    generalize Hae1; apply element_at_list_in.
    symmetry; apply (h3j0 ae v); simpl; trivial.

    generalize Hpate; rewrite Hae2; apply apply_elem_pattern.
    replace (length (rev vf)) with (length (cons_args c)); trivial.
    rewrite rev_length; symmetry; trivial.
    replace (length (rev (fresh  (S (frm_pc f)) (S (length lexpr)) (length (cons_args c))))) with (length (cons_args c)); trivial.
    rewrite rev_length; rewrite aux_init_vars_length; trivial.

    cut (j0 < length (cons_args c)); [clear case_elem; intro case_elem | generalize case_elem; auto with arith].
    rewrite push_list_is_app_rev; rewrite push_list_is_app_rev.
    rewrite <- (element_at_list_concat' _ (rev (fresh (S (frm_pc f)) (S (length lexpr)) (length (cons_args c))))).
    rewrite <- (element_at_list_concat' _ (rev  vf)).
    intros He Hv Hpate.
    symmetry.
    rewrite apply_substitution_concat.
    rewrite (make_substitution_apply _ _ _ _ _ ((length (rev (cons_args c))) - S j0) e v case_svf); trivial.
    apply apply_unchanged.
    replace (length (rev (cons_args c))) with (length (fresh (S (frm_pc f)) (S (length lexpr)) (length (cons_args c)))).
    rewrite element_at_list_rev; simpl.
    replace (length (fresh (S (frm_pc f)) (S (length lexpr)) (length (cons_args c))) -
      S (length (fresh (S (frm_pc f)) (S (length lexpr)) (length (cons_args c))) - S j0)) with j0; trivial.
    rewrite aux_init_vars_length; trivial.
    apply plus_minus.
    cut (S j0 <= length (cons_args c)); [intro Hj0 | generalize case_elem; auto with arith].
    rewrite minus_Sn_m; trivial.
    rewrite plus_comm.
    simpl.
    rewrite <- le_plus_minus; trivial.
    generalize Hj0; auto with arith.
    rewrite aux_init_vars_length; trivial.
    auto with arith.
    rewrite aux_init_vars_length; trivial.
    symmetry; apply rev_length.
    rewrite element_at_list_rev.

    replace j0 with (length vf - S (length (rev (cons_args c)) - S j0)) in Hv; trivial.
    rewrite rev_length.
    rewrite <- Hlenvf.
    symmetry; apply plus_minus.
    cut (S j0 <= length vf); [intro Hj0 | generalize case_elem; auto with arith].
    rewrite minus_Sn_m; trivial.
    rewrite plus_comm.
    simpl.
    rewrite <- le_plus_minus; trivial.
    generalize Hj0; auto with arith.
    rewrite <- Hlenvf; auto with arith.
    rewrite rev_length.
    generalize case_elem; rewrite <- Hlenvf; auto with arith.
    rewrite rev_length; rewrite Hlenvf; trivial.
    rewrite rev_length; rewrite aux_init_vars_length; trivial.
    rewrite push_list_is_app_rev.
    rewrite concat_length.
    rewrite push_list_is_app_rev.
    rewrite concat_length.
    rewrite <- lists.map_length.
    rewrite Hstack in h4.
    simpl in h4.
    rewrite rev_length.
    rewrite aux_init_vars_length.
    rewrite rev_length; rewrite  Hlenvf.
    replace (length lexpr) with (length l).
    trivial.
    symmetry; generalize h4; auto with arith.
    intro F; elim (make_substitution_some (length (cons_args c)) (S (frm_pc f)) (S (length lexpr)) vf); trivial.
    clear Hrho_head case_f_s h1 h2 h3 h4.
    generalize (Hwttop gcn Hgcn C); clear Hwttop; intro Hwttop.
    rewrite Hstack in Hwttop.
    destruct (element_at (Kildall_Types gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn)) (frm_pc f) C).
    inversion Hwttop.
    inversion Hwttop.
    destruct l0.
    inversion Hwttop.
    unfold stack_typing in Hwttop; inversion Hwttop; subst.
    apply tree_typing_args_length with (cnm := cnm) (t := cons_ret const); trivial.
    generalize H6; apply args_to_tree_typing; trivial.
    rewrite Hstack; simpl; trivial.
    unfold tree_is_pattern; simpl; trivial.
    intros dd Hd; elim Hd; intros ddd F; inversion F.
    intros dd F; inversion F.

  (* n is of the form d(e1,  ,em)*)

    elim (eq_name_dec cnm n); intro case_eq.

  (* constructors c and  d  are equal*)

    CaseEq (element_at_unsafe (Kildall_Shapes gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn)) (S (frm_pc f))).
    intros s0 case_f_s; destruct s0.
    intro F; inversion F.
    intro F; inversion F.
    intro h; elim h; clear h; intros h h'; subst n; subst.
    exists s.
    exists (push_list l0 lexpr).
    exists rho.
    cut (length l0 = length vf).

  (* it is assumed that lengths are equal *)

     (* THERE *)
    intro Hlenvf.
    repeat split.
    generalize case_f_s; apply element_at_unsafe_to_safe.
    assumption.
    intros j0 e v.
    rewrite push_list_is_app_rev; rewrite push_list_is_app_rev.
    elim (le_gt_dec (length (rev l0)) j0); intro case_j0.
    rewrite (le_plus_minus (length (rev l0)) j0 case_j0).
    rewrite element_at_list_concat.
    cut (length (rev l0) + (j0 - length (rev l0)) = length (rev vf) + (j0 - length (rev l0))); [intro dd; rewrite dd; clear dd | rewrite rev_length;rewrite rev_length; rewrite <- Hlenvf; trivial].
    rewrite element_at_list_concat.
    intros He Hv; apply (h3 (S (j0 - length l0))).
    simpl; rewrite <- rev_length; rewrite He; trivial.
    rewrite Hstack; simpl; rewrite <- rev_length; rewrite <- Hv.
    CaseEq (l[j0 - length (rev l0)]); symmetry; trivial.
    cut (j0 < length (rev l0)); [clear case_j0; intro case_j0 | generalize case_j0; auto with arith].
    rewrite <- (element_at_list_concat' _ (rev l0)); trivial.
    rewrite <- (element_at_list_concat' _ (rev vf)); trivial.
    intros He Hv Hpat.
    rewrite Hstack in h3.
    cut ((Node (symbol cnm) l0 :: lexpr)[0] = Some (Node (symbol cnm) l0)); [intro He' | simpl; trivial].
    cut ((Node cnm vf :: l)[0] = Some (Node cnm vf)); [intro Hv' | simpl; trivial].
    cut (tree_is_pattern (Node (symbol cnm) l0)); [intro Hpat' | idtac].
    generalize (h3 0 (Node (symbol cnm) l0) (Node cnm vf) He' Hv' Hpat').
    generalize (apply_to_forest cnm rho l0).
    intro dd; inversion dd as [Heq]; clear dd He' Hv' Hpat' Hpat.
    rewrite Heq; intro H.
    inversion H.
    assert (H' : map tree_name_to_tree_Name (rev vf) = map (apply rho) (rev l0)).
    rewrite map_rev_commut; rewrite map_rev_commut.
    rewrite <- H1; trivial.
    cut (Some (tree_name_to_tree_Name v) = Some (apply rho e)).
    intro dd; inversion dd; trivial.
    rewrite <- (element_at_list_map _ _ (rev vf) tree_name_to_tree_Name j0 v Hv).
    rewrite <- (element_at_list_map _ _ (rev l0) (apply rho) j0 e He).
    rewrite <- H'; trivial.
    cut ((fcn_bytecode gcn)[frm_pc f|C] = i_branch (fcn_size gcn) cnm j Cj); [intro Hinstr | generalize case_instr; apply element_at_unsafe_to_safe].
    apply (Pattern_branch gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn) (frm_pc f) C cnm j Cj _ _ _ Hinstr h1).
    rewrite rev_length; rewrite <- Hlenvf; trivial.
    rewrite <- rev_length; trivial.
    rewrite push_list_is_app_rev; rewrite push_list_is_app_rev.
    rewrite concat_length; rewrite concat_length.
    rewrite rev_length; rewrite rev_length; rewrite Hlenvf; replace (length lexpr) with (length l); trivial.
    symmetry; rewrite Hstack in h4; simpl in h4; generalize h4; auto with arith.

  (* proving that lengths are equal*)

    rewrite Hstack in h3.
    cut (tree_name_to_tree_Name (Node cnm vf) = apply rho (Node (symbol cnm) l0)); [idtac | apply (h3 0); trivial].
    rewrite apply_to_forest.
    simpl.
    intro Heq; inversion Heq.
    rewrite (lists.map_length _ _ (apply rho) l0).
    rewrite <- H0; symmetry; apply lists.map_length.
    cut ((fcn_bytecode gcn)[frm_pc f|C] = i_branch (fcn_size gcn) cnm j Cj); [intro Hinstr | generalize case_instr; apply element_at_unsafe_to_safe].
    apply (Pattern_branch gcn (get_some_in_functions  gcn (frm_fun f)
    functions Hgcn) (frm_pc f) C cnm j Cj _ _ _ Hinstr h1).

    intros dd F; inversion F.
    cut False; [intro F; inversion F | trivial].
    rewrite Hstack in h3.
    cut (tree_name_to_tree_Name (Node cnm vf) = apply rho (Node (symbol n) l0)); [idtac | apply (h3 0); trivial].
    rewrite apply_to_forest.
    simpl.
    intro Heq; inversion Heq; subst; elim case_eq; trivial.
    cut ((fcn_bytecode gcn)[frm_pc f|C] = i_branch (fcn_size gcn) cnm j Cj); [intro Hinstr | generalize case_instr; apply element_at_unsafe_to_safe].
    apply (Pattern_branch gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn) (frm_pc f) C cnm j Cj _ _ _ Hinstr h1).
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
    rewrite Hfcn in Hgcn; inversion Hgcn; trivial.
  (* part 2 *)
    intros i fi fpi Hfi Hfpi.
    destruct i; simpl.
    inversion Hfi; inversion Hfpi; subst.
    simpl.
    apply (Hwsvirtual 0 f fpi); simpl; trivial.
    apply (Hwsvirtual (S i) fi fpi); simpl; trivial.
    generalize case_instr; apply element_at_unsafe_some; trivial.

  (* branch else *)
    cut (frm_pc f < fcn_size fcn).
    intro C.
    inversion Hws; subst.
    generalize H; elim H0; intros Hwstop Hwsvirtual Hwt.
    cut ((f :: M0)[0] = Some f); [intro Hf | trivial].
    generalize (Hwstop f Hf); clear Hwstop H H0; intro Hwstop.
    inversion Hwt; subst.
    generalize H; elim H0; intros Hwttop Hwtvirtual Hwf.
    generalize (Hwttop f Hf); clear Hwttop H H0 Hf; intro Hwttop.
    constructor.
    generalize Hwt Hred ; apply reduction_keeps_welltyped; trivial.
    split.
    intros g' Hg' gcn Hgcn Cg; simpl; simpl in Hgcn; simpl in Cg.
    inversion Hg'; subst g'; clear Hg'; simpl in Hgcn.
    cut (fcn = gcn);[intro; subst | rewrite Hgcn in Hfcn; inversion Hfcn; trivial].
    elim (Hwstop gcn Hgcn C); intros s h.
    elim h; clear h; intros lexpr h.
    elim h; clear h; intros rho h.
    elim h; clear h; intros h1 h.
    elim h; clear h; intros h2 h.
    elim h; clear h; intros h3 h4.
    generalize (Wshi_Kildall gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn) (frm_pc f) C).
    unfold Wshi.
    replace ((fcn_bytecode gcn)[frm_pc f|C]) with (i_branch (fcn_size gcn) cnm j Cj).
    rewrite h1.
    destruct lexpr.
    intro F; inversion F.
    destruct t.
    intro F; inversion F.
    destruct n.
    destruct l0.
    CaseEq (Get_constr cnm).
    intros c case_c.
    CaseEq (element_at (Kildall_Shapes gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn)) j Cj).
    intros case_f_j HF; elim HF; intro F; inversion F.
    intros case_f_j HF; elim HF; intro F; inversion F.
    intros l0 l1 case_f_j h; elim h; clear h; intros h dd; clear dd.
    exists l0; exists l1.
    exists rho; elim h; clear h; intros; subst.
    repeat split; trivial.
    rewrite <- case_f_j; apply element_at_irrel.
    intros dd F; inversion F.
    intro F; inversion F.

    elim (eq_name_dec cnm n); intro case_eq.
    subst.
    elim neq_cnm_dnm; rewrite Hstack in h3.
    cut (tree_name_to_tree_Name (Node dnm vf) = apply rho (Node (symbol n) l0)); [idtac | apply (h3 0); trivial].
    rewrite apply_to_forest.
    simpl; intro Heq; inversion Heq; trivial.
    cut (element_at (fcn_bytecode gcn) (frm_pc f) C = i_branch (fcn_size gcn) n j Cj);
      [intro Hinstr | generalize case_instr; apply element_at_unsafe_to_safe].
    apply (Pattern_branch gcn
      (get_some_in_functions  gcn (frm_fun f) functions Hgcn)
      (frm_pc f)
      C n j Cj _ _ _ Hinstr h1).

    CaseEq (element_at (Kildall_Shapes gcn (get_some_in_functions  gcn (frm_fun f) functions Hgcn)) j Cj).
    intros dd F; inversion F.
    intros dd F; inversion F.
    intros l1 l2 case_shapes_j Hshapesj.
    exists l1; exists l2; exists rho.
    elim Hshapesj; intros; subst.
    repeat split; trivial.
    rewrite <- case_shapes_j; apply element_at_irrel.
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
  (* part 2 *)
    intros i fi fpi Hfi Hfpi.
    destruct i; simpl.
    inversion Hfi; inversion Hfpi; subst.
    simpl.
    apply (Hwsvirtual 0 f fpi); simpl; trivial.
    apply (Hwsvirtual (S i) fi fpi); simpl; trivial.
    generalize case_instr; apply element_at_unsafe_some.
    cut (welltyped_configuration M' /\ frames_args_length M'); [intro H; elim H; trivial | generalize Hred; apply reduction_length; trivial].
    split.
    inversion Hws; trivial.
    assumption.
  Qed.

  Lemma wellshaped_init_configuration : forall (fexec : name) (argsexec : list value) (fcnexec : function),
    Get_function fexec = Some fcnexec ->
    tree_list_typing argsexec (rev (fcn_args fcnexec)) ->
    wellshaped_configuration (Init_configuration fexec argsexec).
  Proof.
    intros fexec argsexec fcnexec Hfexec Htyping.
    constructor.
    apply welltyped_init_configuration with fcnexec; trivial.
    rewrite rev_lin_is_rev; trivial.
    split.
    intros f Hf; inversion Hf; subst f; clear Hf.
    exists (nil (A := subst_elem)).
    exists (init_vars fcnexec).
    simpl in Hget; rewrite Hget in Hfexec; inversion Hfexec; subst fcn.
    cut (length argsexec = length (rev (fcn_args fcnexec))); [intro Hlen; rewrite rev_length in Hlen| apply (list_typing_length argsexec (rev (fcn_args fcnexec)))].
    CaseEq (init_subst (rev argsexec)).
    intros rho case_rho.
    exists rho.
    simpl; repeat split.
    rewrite (element_at_irrel _ _ (Kildall_Shapes fcnexec (get_some_in_functions  fcnexec fexec functions Hget)) 0 C (nonvoidfcn fcnexec (get_some_in_functions  fcnexec fexec functions Hget))).
    rewrite Kildall_Shapes_0.
    unfold Sss_init; rewrite element_at_in_replaced; trivial.
    rewrite map_id.
    unfold init_vars; simpl.
    rewrite <- (rev_involutive argsexec).
    rewrite <- rev_lin_is_rev.
    apply init_stack_shaping.
    rewrite <- Hlen ; trivial.
    rewrite <- case_rho; unfold init_subst.
    rewrite rev_length; trivial.
    intros j e v He Hv Hpat.
    unfold init_vars in He.
    rewrite (element_at_init_vars (length (fcn_args fcnexec)) 0 0 j e He).
    symmetry; rewrite <- (init_subst_apply (length (fcn_args fcnexec)) 0 (length argsexec - S j) rho (rev argsexec) v); trivial.
    rewrite plus_comm; simpl; trivial.
    rewrite <- Hlen; trivial.
    rewrite <- element_at_list_rev; trivial.
    generalize Hv; apply element_at_list_some.
    rewrite <- Hlen; trivial.
    rewrite <- case_rho; unfold init_subst.
    rewrite rev_length; trivial.
    rewrite Hlen; apply init_vars_length.
    intro F.
    elim (subst_length (length argsexec) 0 (rev argsexec)); trivial.
    apply rev_length.
    rewrite <- F; unfold init_subst; rewrite rev_length; trivial.
    assumption.
    intros i fi fpi Hfi Hfpi; inversion Hfpi.
  Qed.

  Lemma wellshaped_execution : forall (fexec : name) (argsexec : list value) (fcnexec : function) (L : list configuration),
    Get_function fexec = Some fcnexec ->
    tree_list_typing argsexec (rev (fcn_args fcnexec)) ->
    execution fexec argsexec L ->
    forall  (M : configuration), In M L -> wellshaped_configuration M /\ frames_args_length M.
  Proof.
    intros fexec argsexec fcnexec L Hget Htyping; apply (reduction_to_execution (fun (M : configuration) => wellshaped_configuration M /\ frames_args_length M)).
    split.
    apply wellshaped_init_configuration with fcnexec; trivial.
    intros f fcn Hin Hfcn.
    elim Hin; clear Hin; intro Hin.
    subst f; (simpl in *).
    rewrite Hget in Hfcn; inversion Hfcn; subst fcn.
    rewrite <- (lists.rev_length _ (fcn_args fcnexec)).
    generalize Htyping; apply list_typing_length.
    inversion Hin.
    apply reduction_keeps_wellshaped.
  Qed.

End machine_shapes.


From Undecidability.L Require Import LTactics Datatypes.Lists Datatypes.LNat Datatypes.LBool.
From Undecidability.TM Require TM ProgrammingTools CaseList CaseBool ListTM.

From Undecidability.TM Require Import TM_facts SizeBounds L.Transcode.BoollistEnc Hoare.

From Undecidability.L.Complexity  Require Import UpToCNary.

From Undecidability.L.AbstractMachines Require Import FlatPro.Programs.

Unset Printing Coercions.

From Undecidability.TM.L Require Alphabets.

From Coq Require Import Lia Ring Arith.

From Undecidability Require Import TM.Code.List.Concat_Repeat.

Set Default Proof Using "Type".

Module BoollistToEnc.
  Section M.
    Import ProgrammingTools Combinators App CaseList CaseBool.
    Import Alphabets.

    Variable (sig : finType).
    (* Hypothesis (defX: inhabitedC sigX). *)

    (* We use the FinType instance of bool, as it has a Case-machine *)

    Context `{retr__list : Retract (sigList bool) sig}
            `{retr__Pro : Retract Alphabets.sigPro sig}.

    Local Instance retr__nat : Retract sigNat sig := ComposeRetract retr__Pro _.
    Local Instance retr__bool : Retract bool sig := ComposeRetract retr__list (Retract_sigList_X _).

    (* Check _ : codable sig (list bool). *)
    (* Check _ : codable sig bool. *)

    (* Tapes:
       0: bs (input)
       1: result
       2: intern (constant for ConcatRepeat [0])
       3: intern (length of bs for concatReepat [1])
     *)

    Definition Rel : pRel sig^+ unit 4 :=
      ignoreParam
        (fun tin 'tout =>
           forall (bs : list bool),
             tin[@Fin0] ≃ bs
             -> isVoid tin[@Fin1]
             -> isVoid tin[@Fin2]
             -> isVoid tin[@Fin3]
             -> isVoid tout[@Fin0]
               /\ tout[@Fin1]  ≃ compile (Computable.enc (rev bs))
               /\ isVoid tout[@Fin2]
               /\ isVoid tout[@Fin3]).

    (* für step (prepend the bs-dependent symbols)
               Tapes:
       0: bs (input)
       1: result
       2: head of bs
       3: intern (length of bs for concatReepat [1])
     *)

    Definition M__step : pTM sig^+ (option unit) 4 :=
      If (LiftTapes (ChangeAlphabet (CaseList.CaseList _) retr__list) [|Fin0;Fin2|])
         (Switch (LiftTapes (ChangeAlphabet CaseBool retr__bool) [|Fin2|])
                 (fun b => LiftTapes (ChangeAlphabet (WriteValue ( (enc_bool_perElem b))) _) [| Fin2|];;
                                  LiftTapes (ChangeAlphabet (App' _) _) [|Fin2;Fin1|];;
                                  Return (LiftTapes (Reset _) [|Fin2|]) None))
         (Return (LiftTapes (Reset _) [|Fin0|]) (Some tt)).

    Definition Rel__step : pRel sig^+ (option unit) 4 :=
      (fun tin '(yout,tout) =>
         forall (bs : list bool) (res : Pro),
           tin[@Fin0] ≃ bs
           -> tin[@Fin1] ≃ res
           -> isVoid tin[@Fin2]
           -> match bs,yout with
               [],  Some _ => isVoid tout[@Fin0] /\ tout[@Fin1] = tin[@Fin1]
             | (b::bs),None => tout[@Fin0] ≃ bs /\ tout[@Fin1] ≃ enc_bool_perElem b++res
             | _,_ => False
             end
             /\ isVoid tout[@Fin2]
             /\ tout[@Fin3] = tin[@Fin3]).

    Lemma Realise__step : M__step ⊨ Rel__step .
    Proof.
      eapply Realise_monotone.
      {unfold M__step. TM_Correct_noSwitchAuto. TM_Correct.
       intros b. TM_Correct.
       now apply App'_Realise. }
      intros t (y,t') H. cbn.
      intros bs res Hbs Hres Ht2.
      destruct H as [H|H].
      -cbn in H. TMSimp. modpon H;[]. destruct bs. now exfalso.
       TMSimp. modpon H0;[]. modpon H2;[]. modpon H4;[]. modpon H7;[]. TMSimp.
       repeat (simple apply conj). all:try contains_ext. 2:reflexivity. now isVoid_mono.
      -cbn in H. TMSimp. modpon H;[]. destruct bs. 2:easy. TMSimp.
       modpon H0;[]. modpon H1; [].
       repeat (simple apply conj). all:try now isVoid_mono. all:reflexivity.
    Qed.

    Definition Ter' time: tRel sig^+ 4 :=
      (fun tin k =>
         exists (bs : list bool) (res : Pro),
           tin[@Fin0] ≃ bs
           /\ tin[@Fin1] ≃ res
           /\ isVoid tin[@Fin2]
           /\ time (length bs) <= k ).

    Import MoreList.
    Lemma _Terminates__step :
      { time : UpToC (fun l => 1) &
               projT1 M__step ↓ (Ter' time)}.
    Proof.
      evar (c1 : nat). evar (c0 : nat).
      exists_UpToC (fun k => max c0 c1).
      eapply TerminatesIn_monotone.
      { unfold M__step. TM_Correct_noSwitchAuto. TM_Correct.
        intros b. TM_Correct. all: eauto 1 using App'_Terminates,App'_Realise.
        all: now (notypeclasses refine (@Reset_Terminates _ _ _ _ _);shelve).
      }
      intros tin k H. hnf in H. destruct H as (bs&res&Hbs&Hres&Htin2&Hl).
      cbn -[plus]. eexists _,( match bs with [] => _ | _ => _ end).
      split. 1:{ eexists bs;split. 2:split. all:simpl_surject. now contains_ext. now simpl_surject. reflexivity. }
      split.
      2:{ intros tout b (H&Hrem). TMSimp. modpon H.
          destruct b,bs. all:try now (exfalso;assumption).
          all:TMSimp;simpl_surject.
          2:{ do 2 eexists. now contains_ext. unfold Reset_steps. cbv -[mult plus]. reflexivity. }
          infTer 4. intros ? ? H1. modpon H1. TMSimp.
          infTer 4. intros ? ? H2. modpon H2. TMSimp.
          unfold App'_T. cbn.
          infTer 6. 1,2:now simpl_surject;contains_ext.
          1:now rewrite (correct__leUpToC (App'_steps_nice _)).
          intros ? ? H4. modpon H4. TMSimp.
          eexists. split. now contains_ext.
          unfold Reset_steps. rewrite (correct__leUpToC enc_bool_perElem_size). reflexivity.
      }
      2:now smpl_upToC_solve.
      { rewrite <- Hl. destruct bs.
        -rewrite <- Nat.le_max_l. unfold c0. reflexivity.
        -rewrite <- Nat.le_max_r. unfold c1.
         change (encode_list Encode_Com (enc_bool_perElem b)) with (encode (enc_bool_perElem b)).
         setoid_rewrite (correct__leUpToC enc_bool_perElem_size) at 1 2.
         unfold CaseList_steps,CaseList_steps_cons. rewrite Encode_bool_hasSize.
         rewrite (correct__leUpToC enc_bool_perElem_size).
          reflexivity.
      }
    Qed.

    Definition Terminates__step := projT2 _Terminates__step.

    Definition M__loop : pTM sig^+ unit 4 := While M__step.

    Definition Rel__loop : pRel sig^+ (unit) 4 :=
      (fun tin '(yout,tout) =>
         forall (bs : list bool) (res : Pro),
           tin[@Fin0] ≃ bs
           -> tin[@Fin1] ≃ res
           -> isVoid tin[@Fin2]
           -> isVoid tout[@Fin0]
             /\ tout[@Fin1] ≃ flat_map enc_bool_perElem (rev bs)++res
             /\ isVoid tout[@Fin2]
             /\ tout[@Fin3] = tin[@Fin3]).

    Lemma Realise__loop : M__loop ⊨ Rel__loop .
    Proof.
      eapply Realise_monotone.
      {unfold M__loop. TM_Correct_noSwitchAuto. TM_Correct. apply Realise__step. }
      eapply WhileInduction;intros;hnf;intros bs res Hbs Hres Ht2.
      -hnf in HLastStep. modpon HLastStep. destruct bs. 2:easy.
       TMSimp. easy.
      -hnf in HStar. modpon HStar. destruct bs. easy. TMSimp. modpon HLastStep. TMSimp.
       repeat (simple apply conj). 1,3:now isVoid_mono. 2:reflexivity.
       {setoid_rewrite flat_map_concat_map. setoid_rewrite flat_map_concat_map in HLastStep0.
        rewrite map_app,concat_app. cbn. autorewrite with list. cbn. contains_ext. }
    Qed.

    Import MoreList.
    Lemma _Terminates__loop :
      { time : UpToC (fun l => l + 1) &
               projT1 M__loop ↓ (Ter' time)}.
    Proof.
      evar (c1 : nat). evar (c2 : nat).
      exists_UpToC (fun l => l * c1 + c2). 2:now smpl_upToC_solve.
      eapply TerminatesIn_monotone.
      -unfold M__loop. TM_Correct. now apply Realise__step. now apply Terminates__step.
      -apply WhileCoInduction. unfold Ter'.
       intros tin k (bs&res&Hbs&Hres&Hxtin2&Hk).
       eexists. split.
       { exists bs,res. repeat simple apply conj. 1-3:eassumption. rewrite UpToC_le. reflexivity. }
       unfold Rel__step. intros ymid tmid Hstep. modpon Hstep.
       destruct ymid as [[]| ],bs. all:try now exfalso;eassumption.
       +cbn [length]. rewrite <- Hk, Nat.mul_0_l, Nat.mul_1_r,!Nat.add_0_l. unfold c2. reflexivity.
       +TMSimp.
        eexists. split.
        *repeat simple eapply ex_intro. repeat simple apply conj. 1-2:now contains_ext. now isVoid_mono. reflexivity.
        *rewrite <- Hk. ring_simplify. set (c' := c__leUpToC).
         replace c1 with (c'+1). 2:now unfold c',c1. nia.
    Qed.

    Definition Terminates__loop := projT2 _Terminates__loop.

    Import ListTM.

    Definition M : pTM sig^+ unit 4 :=
      LiftTapes (Length retr__list retr__nat) [|Fin0;Fin3;Fin1;Fin2|];; (*0: still bs, 3:length bs, 1,2:right *)
                LiftTapes (ChangeAlphabet (WriteValue ( ([] : Pro))) retr__Pro) [|Fin1|];; (* 1:res *)
                LiftTapes (ChangeAlphabet (WriteValue ( (enc_bool_closing))) retr__Pro) [|Fin2|];; (* 2:const for repeat *)
                LiftTapes (ConcatRepeat.M retr__Pro retr__nat) [|Fin2;Fin3;Fin1|];; (* 2:cnst for repeat, 3:length/empty, 1:res *)
                LiftTapes (Reset _) [|Fin2|];;(*2: empty*)
                LiftTapes (ChangeAlphabet (WriteValue (  (enc_bool_nil))) retr__Pro ) [|Fin2|];;(*2:nil*)
                LiftTapes (ChangeAlphabet (App' _) retr__Pro) [|Fin2;Fin1|];;(* 1 : res with nil part *)
                LiftTapes (Reset _) [|Fin2|];;(*2: empty*)
                M__loop.

    Lemma Realise : M ⊨ M.Rel.
    Proof.
      eapply Realise_monotone.
      {unfold M. TM_Correct_noSwitchAuto. TM_Correct.
       all:eauto 1 using Length_Computes, ConcatRepeat.Realise,  App'_Realise,Realise__loop, Realise__step.
      }
      intros tin (yout,tout) H. hnf. intros bs Hbs Htin1 Htin2 Htin3.
      hnf in H. cbn in H. TMSimp. modpon H;[]. modpon H0;[].
      modpon H2;[]. modpon H4;[]. modpon H6;[].  modpon H8;[]. modpon H10;[]. modpon H12;[].
      modpon H14;[]. TMSimp.  repeat (simple apply conj). 1,3,4:now isVoid_mono.
      { rewrite enc_bool_explicit,rev_length. autorewrite with list in H13. contains_ext. }
    Qed.

    Definition Ter time: tRel sig^+ 4 :=
      (fun tin k =>
         exists (bs : list bool),
           tin[@Fin0] ≃ bs
           /\ isVoid tin[@Fin1]
           /\ isVoid tin[@Fin2]
           /\ isVoid tin[@Fin3]
           /\ time (length bs) <= k ).

    Lemma _Terminates :
      { time : UpToC (fun l => l + 1) &
               projT1 M ↓ Ter time}.
    Proof.
      eexists_UpToC time.
      eapply TerminatesIn_monotone.
      { unfold M. TM_Correct.
        all: eauto 2 using App'_Terminates,App'_Realise,Length_Computes,ConcatRepeat.Realise,ConcatRepeat.Terminates,Length_Terminates,Realise__loop.
        simple apply Terminates__loop. }
      intros tin k H. hnf in H. destruct H as (bs&Hbs&Hres&Htin2&Htin3&Hl).
      cbn -[plus]. infTer 3.
      {
        unfold Length_T. cbn. eexists. repeat simple apply conj. now contains_ext. 1-3:now isVoid_mono.
        rewrite (correct__leUpToC (Length_steps_nice _) bs),(correct__leUpToC boollist_size).  reflexivity.
      }
      2:{ intros tout _ (H&Hrem). TMSimp. modpon H.
          infTer 5. intros t1_ _ (Ht1&Ht1Rem). TMSimp. modpon Ht1;[].
          infTer 5. intros t2_ _ (Ht2&Ht2Rem). TMSimp. modpon Ht2;[].
          unfold ConcatRepeat.Ter. cbn.
          infTer 5. 1:{ repeat simple apply conj. 1,2,3:now contains_ext.  rewrite UpToC_le. reflexivity. }
          intros t3_ _ (Ht3&Ht3Rem). TMSimp. modpon Ht3;[]. rewrite app_nil_r in Ht4.
          infTer 4. 1-2:easy.
          intros t4 _ (Htp4&Ht4Rem). TMSimp. modpon Htp4;[].
          infTer 5. intros t5 _ (Htp5&Ht5Rem). TMSimp. modpon Htp5;[].
          infTer 5.
          1:{
            unfold App'_T. cbn. eexists _,_.  repeat simple apply conj. 1,2:simpl_surject;now contains_ext.
            rewrite (correct__leUpToC (App'_steps_nice _)). reflexivity.
          }
          intros t6_ _ Ht6. modpon Ht6;[]. TMSimp.
          infTer 4. now contains_ext.
          { unfold Reset_steps. reflexivity. }
          intros t7 _ Htp7. modpon Htp7;[]. hnf. TMSimp.
          do 2 eexists. repeat simple apply conj. 1,2:now contains_ext. now isVoid_mono.
          rewrite UpToC_le. reflexivity.
      }
      - rewrite <- Hl.  set (l:=length bs). [time]:intros l.  unfold time. reflexivity.
      -unfold time. solve [smpl_upToC_solve].
    Qed.

    Definition Terminates := projT2 _Terminates.

    Lemma SpecT  :
    { f : UpToC (fun bs => length bs + 1) &
      forall (bs : list bool),
      TripleT
        (≃≃([],[| Contains _ bs;Void;Void; Void|]) )
        (f bs)
        M
        (fun _ => ≃≃([],[|Void; Contains _ (compile (Computable.enc (rev bs)));Void;Void|])) }.
    Proof.
      evar (f: list bool -> nat).
      exists_UpToC f.
      intros.
      unfold withSpace in *.
      eapply Realise_TripleT. now apply Realise. now apply Terminates.
      - intros tin yout tout H [_ HEnc]%tspecE. cbn in *.
        specializeFin HEnc. simpl_vector in *; cbn in *. modpon H. tspec_solve.
      - intros tin k [_ HEnc]%tspecE Hk. cbn in *.
        specializeFin HEnc. simpl_vector in *; cbn in *. eexists. repeat split. contains_ext. 1-3:isVoid_mono.
        rewrite <- Hk. [f]:intro. now unfold f.
      - subst f. setoid_rewrite UpToC_le. smpl_upToC_solve.
    Qed.

  End M.

End BoollistToEnc.
Arguments BoollistToEnc.M : clear implicits.
Arguments BoollistToEnc.M {_} _ _.


(** * Tools and lemma used to prove Lemma 4.26 and 4.44 more easily *)
Require Import Rpos.
Require Import riesz_logic_List_more.
Require Import RL.hmr.term.
Require Import RL.hmr.semantic.
Require Import RL.hmr.hseq.
Require Import RL.hmr.hmr.

Require Import CMorphisms.
Require Import Lra.
Require Import Lia.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Local Open Scope R_scope.

(** Basic operation concerning Option Rpos (the None constructor corresponds to 0) *)
Definition oadd_Rpos o1 o2 :=
  match o1, o2 with
  | None, o2 => o2
  | o1, None => o1
  | Some r1, Some r2 => Some (plus_pos r1 r2)
  end.

Definition mul_Rpos_oRpos r o :=
  match o with
  | None => None
  | Some r1 => Some (time_pos r r1)
  end.

(** Conversion from nat to Option Rpos *)
Definition nat_oRpos n :=
  match n with
  | 0 => None
  | S n => Some (INRpos n)
  end.

(** The hypersequent obtained by multiplying (or copying) every sequent by the corresponding element of L and then using the S rule until only one sequent remain *)
Fixpoint concat_with_coeff_mul G L :=
  match G, L with
  | _, nil => nil
  | nil, _ => nil
  | T :: G , (Some r) :: L => seq_mul r T ++ concat_with_coeff_mul G L
  | T :: G , None :: L => concat_with_coeff_mul G L
  end.

Fixpoint concat_with_coeff_copy G L :=
  match G, L with
  | _, nil => nil
  | nil, _ => nil
  | T :: G , n :: L => copy_seq n T ++ concat_with_coeff_copy G L
  end.

Lemma concat_with_coeff_mul_only_diamond : forall G L,
    concat_with_coeff_mul (only_diamond_hseq G) L = only_diamond_seq (concat_with_coeff_mul G L).
Proof.
  induction G; intros L; destruct L; auto.
  destruct o; simpl; rewrite IHG; auto.
  rewrite only_diamond_seq_app.
  rewrite only_diamond_seq_mul; reflexivity.
Qed.

Lemma concat_with_coeff_mul_all_0 : forall G L,
    Forall_inf (fun x => x = None) L ->
    concat_with_coeff_mul G L = nil.
Proof.
  intros G L; revert G; induction L; intros G Ha0; destruct G; simpl; auto.
  inversion Ha0; subst.
  apply IHL; assumption.
Qed.

(* TODO MOVE to hseq *)
Lemma only_diamond_seq_decomp :
  forall T,
    {' (r , s, D) : _ & prod
                       (Permutation_Type
                          (only_diamond_seq T)
                          (vec s MRS_coone ++ vec r MRS_one ++ D))
                       (sum_vec r - sum_vec s = sum_weight_one_seq T)}.
Proof.
  induction T; [split with (nil, nil, nil); split; try reflexivity; simpl; lra | ].
  destruct IHT as [[[r s] D] [Hperm Heq]]; try (destruct a; simpl in * ;lia).
  destruct a as [a A].
  destruct A;
    try (esplit with (r, s, D); split; assumption);
    try (simpl max_diamond_term in Hnd; exfalso; lia);
    [ split with (a :: r , s, D) | split with (r , a :: s, D) | split with (r, s, (a,A) :: D)];
    simpl; split; try Permutation_Type_solve; try lra.
Qed.

Lemma only_diamond_seq_decomp_no_diamond :
  forall T,
    modal_complexity_seq T = 0%nat ->
    {' (r , s) : _ & prod
                       (Permutation_Type
                          (only_diamond_seq T)
                          (vec s MRS_coone ++ vec r MRS_one))
                       (sum_vec r - sum_vec s = sum_weight_one_seq T)}.
Proof.
  induction T; intros Hnd; [split with (nil, nil); split; try reflexivity; simpl; lra | ].
  simpl in Hnd.
  destruct IHT as [[r s] [Hperm Heq]]; try (destruct a; simpl in * ;lia).
  destruct a as [a A].
  destruct A;
    try (esplit with (r, s); split; assumption);
    try (simpl modal_complexity_term in Hnd; exfalso; lia);
    [ split with (a :: r , s) | split with (r , a :: s)];
    simpl; split; try Permutation_Type_solve; try lra.
Qed.

(** point-wise operation on list of (Option Rpos) or nat *)
Fixpoint oadd_Rpos_list L1 L2 :=
  match L1,L2 with
  | nil, _ => nil
  | _, nil => nil
  | o1 :: L1 , o2 :: L2 => (oadd_Rpos o1 o2) :: (oadd_Rpos_list L1 L2)
  end.

Fixpoint add_nat_list L1 L2 :=
  match L1,L2 with
  | nil, _ => nil
  | _, nil => nil
  | n1 :: L1 , n2 :: L2 => ((n1 + n2)%nat) :: (add_nat_list L1 L2)
  end.

Lemma oadd_Rpos_list_length : forall L1 L2,
    length L1 = length L2 ->
    length (oadd_Rpos_list L1 L2) = (length L1).
Proof.
  induction L1; intros L2; try reflexivity.
  intros Heq.
  destruct L2; inversion Heq.
  specialize (IHL1 L2 H0).
  destruct a; destruct o; simpl; rewrite IHL1; reflexivity.
Qed.

Lemma add_nat_list_length : forall L1 L2,
    length L1 = length L2 ->
    length (add_nat_list L1 L2) = (length L1).
Proof.
  induction L1; intros L2; try reflexivity.
  intros Heq.
  destruct L2; inversion Heq.
  specialize (IHL1 L2 H0).
  simpl; rewrite IHL1; reflexivity.
Qed.

Lemma concat_with_coeff_mul_omul_Rpos_list : forall G L1 r,
    concat_with_coeff_mul G (map (mul_Rpos_oRpos r) L1) = seq_mul r (concat_with_coeff_mul G L1).
Proof.
  induction G; intros L1 r; [ destruct L1; try destruct o; reflexivity | ].
  destruct L1 ; [ reflexivity | ].
  specialize (IHG L1 r).
  destruct o; simpl; rewrite IHG; try reflexivity.
  rewrite <- seq_mul_twice; rewrite seq_mul_app.
  reflexivity.
Qed.

Lemma concat_with_coeff_copy_add_nat_list_perm : forall G L1 L2,
    length L1 = length L2 ->
    Permutation_Type (concat_with_coeff_copy G (add_nat_list L1 L2)) (concat_with_coeff_copy G L1 ++ concat_with_coeff_copy G L2).
Proof.
  intros G L1; revert G; induction L1; intros G L2 Hlen; destruct L2; inversion Hlen ; [ destruct G; simpl; apply Permutation_Type_nil_nil | ].
  destruct G ; [ apply Permutation_Type_nil_nil | ].
  simpl add_nat_list; simpl concat_with_coeff_copy.
  transitivity ((copy_seq a s ++ copy_seq n s) ++ (concat_with_coeff_copy G L1 ++ concat_with_coeff_copy G L2)) ; [ | Permutation_Type_solve].
  apply Permutation_Type_app ; [ | apply IHL1]; try assumption.
  rewrite copy_seq_plus; reflexivity.
Qed.

Lemma concat_with_coeff_copy_mul_nat_list : forall G L1 n,
    Permutation_Type (concat_with_coeff_copy G (map (Nat.mul n) L1)) (copy_seq n (concat_with_coeff_copy G L1)).
Proof.
  induction G; intros L1 n.
  - destruct L1; simpl; rewrite copy_seq_nil; apply Permutation_Type_nil_nil.
  - destruct L1; simpl ; [ rewrite copy_seq_nil; apply Permutation_Type_nil_nil | ].
    etransitivity ; [ | symmetry; apply copy_seq_app].
    apply Permutation_Type_app ; [ | apply IHG].
    rewrite copy_seq_twice; reflexivity.
Qed.

(** Sufficient conditions for derivability of a basic hypersequent *)
Lemma basic_proof_all_eq P : forall H T,
    seq_is_basic T ->
    hseq_is_basic H ->
    (forall n, sum_weight_var n (T :: H) = 0) ->
    (0 <= sum_weight_one (T :: H)) ->
    HMR P ((flat_map only_diamond_seq (T :: H)) :: nil) ->
    HMR P (T :: H).
Proof.
  induction H; intros T.
  - intros Hb _; revert Hb.
    remember (length T).
    revert T Heqn.
    apply (lt_wf_rect n (fun n => forall T : sequent,
                             n = length T ->
                             seq_is_basic T ->
                             (forall n0 : term.V, sum_weight_var n0 (T :: nil) = 0) ->
                             0 <= sum_weight_one (T :: nil) ->
                             HMR P (flat_map only_diamond_seq (T :: nil) :: nil) ->
                             HMR P (T :: nil))).
    clear n.
    intros n IHn T Hlen Hat Hsum Hone Hstep.
    destruct (seq_basic_decomp_decr T Hat) as [[[[[n0 r] s] D] [Hr [Hperm Hdlen]]] | Hnil].
    + eapply hmrr_ex_seq ; [ symmetry; apply Hperm | ].
      apply hmrr_ID.
      { specialize (Hsum n0); simpl in Hsum.
        nra. }
      apply IHn with (length D).
      * lia.
      * reflexivity.
      * apply seq_basic_perm with _ (vec s (MRS_covar n0) ++ vec r (MRS_var n0) ++ D) in Hat; try assumption.
        apply seq_basic_app_inv_r in Hat.
        apply seq_basic_app_inv_r in Hat.
        apply Hat.
      * intros n1.
        specialize (Hsum n0) as Hrs.
        specialize (Hsum n1).
        simpl in Hsum; rewrite (sum_weight_var_seq_perm _ _ _ Hperm) in Hsum.
        rewrite ? sum_weight_var_seq_app in Hsum.
        simpl.
        case_eq (term.V_eq n0 n1); intros H01 He.
        -- subst.
           rewrite sum_weight_var_seq_vec_covar_eq in Hsum; rewrite sum_weight_var_seq_vec_var_eq in Hsum.
           simpl in Hrs.
           nra.
        -- rewrite sum_weight_var_seq_vec_neq in Hsum; [ | intros H'; inversion H'; now auto | intros H'; inversion H'; now auto].
           rewrite sum_weight_var_seq_vec_neq in Hsum; [ | intros H'; inversion H'; now auto | intros H'; inversion H'; now auto].
           nra.
      * simpl in Hone; rewrite (sum_weight_one_seq_perm _ _ Hperm) in Hone.
        rewrite ? sum_weight_one_seq_app in Hone; rewrite ? sum_weight_seq_coone_app in Hone.
        simpl.
        rewrite ? sum_weight_one_seq_vec_neq in Hone; try now auto.
        nra.
      * simpl; simpl in Hstep.
        eapply hmrr_ex_seq; [ | apply Hstep].
        rewrite 2 app_nil_r.
        replace (only_diamond_seq D) with (only_diamond_seq (vec s (MRS_covar n0) ++ vec r (MRS_var n0) ++ D)) by (rewrite ? only_diamond_seq_app; rewrite only_diamond_seq_vec_covar; now rewrite only_diamond_seq_vec_var).
        apply only_diamond_seq_perm; apply Hperm.
    + simpl in Hstep; rewrite app_nil_r in Hstep.
      destruct (seq_basic_no_atom T Hat Hnil) as [[[r s] D] Hperm].
      apply hmrr_ex_seq with (vec s MRS_coone ++ vec r MRS_one ++ seq_diamond D); [ apply Permutation_Type_sym; apply Hperm | ].
      apply hmrr_diamond.
      { simpl in Hone.
        rewrite (sum_weight_one_seq_perm _ _ Hperm) in Hone.
        rewrite ? sum_weight_one_seq_app in Hone.
        rewrite sum_weight_one_seq_vec_one_eq in Hone; rewrite sum_weight_one_seq_vec_coone_eq in Hone.
        rewrite sum_weight_one_seq_seq_diamond in Hone.
        nra. }
      replace (vec s MRS_coone ++ vec r MRS_one ++ D) with (only_diamond_seq (vec s MRS_coone ++ vec r MRS_one ++ seq_diamond D)) by (rewrite ? only_diamond_seq_app; rewrite only_diamond_seq_vec_coone; rewrite only_diamond_seq_vec_one; now rewrite only_diamond_seq_only_diamond).
      eapply hmrr_ex_seq ; [ | apply Hstep].
      apply only_diamond_seq_perm; apply Hperm.
  - intros HatT HatH Hsum Hone Hstep.
    apply hmrr_S.
    apply IHlist.
    + inversion HatH; subst.
      apply seq_basic_app; assumption.
    + inversion HatH; assumption.
    + intros n.
      specialize (Hsum n).
      simpl in *.
      rewrite sum_weight_var_seq_app.
      nra.
    + simpl in *.
      rewrite sum_weight_one_seq_app.
      nra.
    + simpl in *.
      rewrite only_diamond_seq_app; rewrite <- app_assoc.
      apply Hstep.
Qed.

(** ** sum_weight_(co)var_with_coeff and co(one) *)
Fixpoint sum_weight_var_with_coeff n G (L : list (option Rpos)) :=
  match G, L with
  | _, nil => 0
  | nil, _ => 0
  | T :: G , None :: L => sum_weight_var_with_coeff n G L
  | T :: G , (Some r) :: L => ((projT1 r) * sum_weight_var_seq n T) + sum_weight_var_with_coeff n G L
  end.

(*
Lemma sum_weight_var_with_coeff_lt_max_var : forall n G L,
    (max_var_hseq G < n)%nat ->
    sum_weight_var_with_coeff n G L = 0.
Proof.
  intros n; induction G; intros L Hlt; destruct L; auto.
  simpl in *.
  rewrite sum_weight_var_seq_lt_max_var; try lia.
  rewrite IHG; try lia.
  destruct o;lra.
Qed.
 *)

Lemma sum_weight_var_with_coeff_app1 : forall n G1 G2 L,
    (length L <= length G1)%nat ->
    sum_weight_var_with_coeff n (G1 ++ G2) L = sum_weight_var_with_coeff n G1 L.
Proof.
  intros n; induction G1; intros G2 L Hlen; destruct L; try (now inversion Hlen); [destruct G2 | ]; auto.
  simpl; rewrite IHG1; auto.
  simpl in Hlen; lia.
Qed.

Lemma sum_weight_var_with_coeff_app2 : forall n G1 G2 L1 L2,
    (length L1 = length G1) ->
    sum_weight_var_with_coeff n (G1 ++ G2) (L1 ++ L2) = sum_weight_var_with_coeff n G1 L1 + sum_weight_var_with_coeff n G2 L2.
Proof.
  intros n; induction G1; intros G2 L1 L2 Hlen; destruct L1; try (now inversion Hlen); [destruct L2 ; destruct G2 | ]; simpl; try lra.
  simpl in *; rewrite IHG1; auto.
  destruct o ; lra.
Qed.

Lemma sum_weight_var_with_coeff_app3 : forall n G L1 L2,
    (length G <= length L1)%nat ->
    sum_weight_var_with_coeff n G (L1 ++ L2) = sum_weight_var_with_coeff n G L1.
Proof.
  intros n; induction G; intros L1 L2 Hlen; destruct L1; try (now inversion Hlen); [now destruct L2 | ].
  simpl; rewrite IHG; auto.
  simpl in Hlen; lia.
Qed.

Fixpoint sum_weight_one_with_coeff G (L : list (option Rpos)) :=
  match G, L with
  | _, nil => 0
  | nil, _ => 0
  | T :: G , None :: L => sum_weight_one_with_coeff G L
  | T :: G , (Some r) :: L => ((projT1 r) * sum_weight_one_seq T) + sum_weight_one_with_coeff G L
  end.

Lemma sum_weight_one_with_coeff_app1 : forall G1 G2 L,
    (length L <= length G1)%nat ->
    sum_weight_one_with_coeff (G1 ++ G2) L = sum_weight_one_with_coeff G1 L.
Proof.
  induction G1; intros G2 L Hlen; destruct L; try (now inversion Hlen); [destruct G2 | ]; auto.
  simpl; rewrite IHG1; auto.
  simpl in Hlen; lia.
Qed.

Lemma sum_weight_one_with_coeff_app2 : forall G1 G2 L1 L2,
    (length L1 = length G1) ->
    sum_weight_one_with_coeff (G1 ++ G2) (L1 ++ L2) = sum_weight_one_with_coeff G1 L1 + sum_weight_one_with_coeff G2 L2.
Proof.
  induction G1; intros G2 L1 L2 Hlen; destruct L1; try (now inversion Hlen); [destruct L2 ; destruct G2 | ]; simpl; try lra.
  simpl in *; rewrite IHG1; auto.
  destruct o ; lra.
Qed.

Lemma sum_weight_one_with_coeff_app3 : forall G L1 L2,
    (length G <= length L1)%nat ->
    sum_weight_one_with_coeff G (L1 ++ L2) = sum_weight_one_with_coeff G L1.
Proof.
  induction G; intros L1 L2 Hlen; destruct L1; try (now inversion Hlen); [now destruct L2 | ].
  simpl; rewrite IHG; auto.
  simpl in Hlen; lia.
Qed.

Lemma sum_weight_one_with_coeff_atomic : forall G L,
    hseq_is_atomic G ->
    sum_weight_one_with_coeff G L = 0.
Proof.
  induction G; intros [ | r L] Hat; inversion Hat; simpl; try reflexivity.
  subst.
  rewrite IHG; try assumption.
  rewrite sum_weight_one_seq_atomic; try assumption.
  destruct r; simpl; lra.
Qed.

Lemma concat_with_coeff_mul_only_diamond_decomp :
  forall G L,
    {' (r , s, T) : _ & prod
                       (Permutation_Type
                          (only_diamond_seq (concat_with_coeff_mul G L))
                          (vec s MRS_coone ++ vec r MRS_one ++ T))
                       (sum_vec r - sum_vec s = sum_weight_one_with_coeff G L) }.
Proof.
  induction G; intros [ | o L]; simpl; try (split with ((nil, nil), nil); split; try reflexivity; lra).
  destruct (IHG L) as [[[r s] T] [Hperm Heq]]; try lia.
  destruct o; simpl; [ | split with (r ,s, T); split; auto ].
  destruct (only_diamond_seq_decomp a) as [[[ra sa] Ta] [Hperma Heqa]].
  split with ((mul_vec r0 ra) ++ r, (mul_vec r0 sa) ++ s, seq_mul r0 Ta ++ T).
  rewrite ?vec_app; rewrite ? sum_vec_app.
  rewrite only_diamond_seq_app.
  rewrite <- ? seq_mul_vec_mul_vec.
  rewrite ? sum_mul_vec.
  split; try nra.
  rewrite <- only_diamond_seq_mul.
  apply seq_mul_perm with _ _ r0 in Hperma.
  rewrite ? seq_mul_app in Hperma.
  Permutation_Type_solve.
Qed.

Lemma concat_with_coeff_mul_only_diamond_decomp_no_diamond :
  forall G L,
    modal_complexity_hseq G = 0%nat ->
    {' (r , s) : _ & prod
                       (Permutation_Type
                          (only_diamond_seq (concat_with_coeff_mul G L))
                          (vec s MRS_coone ++ vec r MRS_one))
                       (sum_vec r - sum_vec s = sum_weight_one_with_coeff G L) }.
Proof.
  induction G; intros [ | o L] Hnd; simpl; try (split with (nil, nil); split; try reflexivity; lra).
  destruct (IHG L) as [[r s] [Hperm Heq]]; try (simpl in Hnd ; lia).
  destruct o; simpl; [ | split with (r ,s); split; auto ].
  destruct (only_diamond_seq_decomp_no_diamond a) as [[ra sa] [Hperma Heqa]]; try (simpl in Hnd ; lia).
  split with ((mul_vec r0 ra) ++ r, (mul_vec r0 sa) ++ s).
  rewrite ?vec_app; rewrite ? sum_vec_app.
  rewrite only_diamond_seq_app.
  rewrite <- ? seq_mul_vec_mul_vec.
  rewrite ? sum_mul_vec.
  split; try nra.
  rewrite <- only_diamond_seq_mul.
  apply seq_mul_perm with _ _ r0 in Hperma.
  rewrite ? seq_mul_app in Hperma.
  Permutation_Type_solve.
Qed.

Lemma concat_with_coeff_copy_only_diamond : forall G L,
    concat_with_coeff_copy (only_diamond_hseq G) L = only_diamond_seq (concat_with_coeff_copy G L).
Proof.
  induction G; intros L; destruct L; auto.
  simpl; rewrite IHG; auto.
  rewrite ? only_diamond_seq_app.
  rewrite only_diamond_seq_copy; reflexivity.
Qed.

Lemma concat_with_coeff_copy_all_0 : forall G L,
    Forall_inf (fun x => x = 0%nat) L ->
    concat_with_coeff_copy G L = nil.
Proof.
  intros G L; revert G; induction L; intros G Ha0; destruct G; simpl; auto.
  inversion Ha0; subst.
  apply IHL; assumption.
Qed.

Lemma sum_weight_var_with_coeff_oadd_Rpos_list : forall n G L1 L2,
    length L1 = length L2 ->
    sum_weight_var_with_coeff n G (oadd_Rpos_list L1 L2) = sum_weight_var_with_coeff n G L1 + sum_weight_var_with_coeff n G L2.
Proof.
  intros n G L1; revert G; induction L1; intros G L2 Hlen; destruct L2; try (now inversion Hlen); [ destruct G; simpl; nra | ].
  destruct G; [ simpl ; nra | ].
  inversion Hlen.
  specialize (IHL1 G L2 H0).
  destruct a; destruct o; try destruct r; try destruct r0; simpl; nra.
Qed.

Lemma sum_weight_var_with_coeff_omul_Rpos_list : forall n G L1 r,
    sum_weight_var_with_coeff n G (map (mul_Rpos_oRpos r) L1) = (projT1 r) * sum_weight_var_with_coeff n G L1.
Proof.
  intros n G L1; revert G; induction L1; intros G r ; [ destruct G; simpl; nra | ].
  destruct G; [ destruct a; simpl ; nra | ].
  specialize (IHL1 G r).
  destruct a; try destruct r; try destruct r0; simpl in *; nra.
Qed.

Lemma sum_weight_var_with_coeff_add_nat_list : forall n G L1 L2,
    length L1 = length L2 ->
    sum_weight_var_with_coeff n G (map nat_oRpos (add_nat_list L1 L2)) = sum_weight_var_with_coeff n G (map nat_oRpos L1) + sum_weight_var_with_coeff n G (map nat_oRpos L2).
Proof.
  intros n G L1; revert G; induction L1; intros G L2 Hlen; destruct L2; try (now inversion Hlen); [ destruct G; simpl; nra | ].
  destruct G; [ simpl ; nra | ].
  inversion Hlen.
  specialize (IHL1 G L2 H0).
  simpl add_nat_list.
  destruct a; destruct n0; simpl map; simpl sum_weight_var_with_coeff; try nra.
  - change (match (a + 0)%nat with
             | 0%nat => 1
             | S _ => INR (a + 0) + 1
            end) with (INR (S a + 0)).
    change (match a with
            | 0%nat => 1
            | S _ => INR a + 1
            end) with (INR (S a)).
    rewrite Nat.add_0_r; nra.
  - change (match (a + S n0)%nat with
             | 0%nat => 1
             | S _ => INR (a + S n0) + 1
            end) with (INR (S a + S n0)).
    change (match a with
            | 0%nat => 1
            | S _ => INR a + 1
            end) with (INR (S a)).
    change (match n0 with
            | 0%nat => 1
            | S _ => INR n0 + 1
            end) with (INR (S n0)).
    rewrite plus_INR; nra.
Qed.

Lemma sum_weight_var_with_coeff_mul_nat_list : forall n G L1 n',
    sum_weight_var_with_coeff n G (map nat_oRpos (map (Nat.mul (S n')) L1)) = (INR (S n')) * sum_weight_var_with_coeff n G (map nat_oRpos L1).
Proof.
  intros n G L1; revert G; induction L1; intros G n' ; [ destruct G; simpl; nra | ].
  destruct G; [ destruct a; simpl ; nra | ].
  specialize (IHL1 G n').
  destruct a; simpl map.
  - rewrite Nat.mul_0_r; apply IHL1.
  - simpl sum_weight_var_with_coeff.
    change (match (a + n' * S a)%nat with
           | 0%nat => 1
           | S _ => INR (a + n' * S a) + 1
            end) with (INR (S n' * S a)).
    change (match a with
            | 0%nat => 1
            | S _ => INR a + 1
            end) with (INR (S a)).
    change (fun m : nat => (m + n' * m)%nat) with (Nat.mul (S n')).
    rewrite mult_INR; nra.
Qed.

Lemma sum_weight_one_with_coeff_oadd_Rpos_list : forall G L1 L2,
    length L1 = length L2 ->
    sum_weight_one_with_coeff G (oadd_Rpos_list L1 L2) = sum_weight_one_with_coeff G L1 + sum_weight_one_with_coeff G L2.
Proof.
  intros G L1; revert G; induction L1; intros G L2 Hlen; destruct L2; try (now inversion Hlen); [ destruct G; simpl; nra | ].
  destruct G; [ simpl ; nra | ].
  inversion Hlen.
  specialize (IHL1 G L2 H0).
  destruct a; destruct o; try destruct r; try destruct r0; simpl; nra.
Qed.

Lemma sum_weight_one_with_coeff_omul_Rpos_list : forall G L1 r,
    sum_weight_one_with_coeff G (map (mul_Rpos_oRpos r) L1) = (projT1 r) * sum_weight_one_with_coeff G L1.
Proof.
  intros G L1; revert G; induction L1; intros G r ; [ destruct G; simpl; nra | ].
  destruct G; [ destruct a; simpl ; nra | ].
  specialize (IHL1 G r).
  destruct a; try destruct r; try destruct r0; simpl in *; nra.
Qed.

Lemma sum_weight_one_with_coeff_add_nat_list : forall G L1 L2,
    length L1 = length L2 ->
    sum_weight_one_with_coeff G (map nat_oRpos (add_nat_list L1 L2)) = sum_weight_one_with_coeff G (map nat_oRpos L1) + sum_weight_one_with_coeff G (map nat_oRpos L2).
Proof.
  intros G L1; revert G; induction L1; intros G L2 Hlen; destruct L2; try (now inversion Hlen); [ destruct G; simpl; nra | ].
  destruct G; [ simpl ; nra | ].
  inversion Hlen.
  specialize (IHL1 G L2 H0).
  simpl add_nat_list.
  destruct a; destruct n; simpl; try nra.
  - change (match (a + 0)%nat with
             | 0%nat => 1
             | S _ => INR (a + 0) + 1
            end) with (INR (S a + 0)).
    change (match a with
            | 0%nat => 1
            | S _ => INR a + 1
            end) with (INR (S a)).
    rewrite Nat.add_0_r; nra.
  - change (match (a + S n)%nat with
             | 0%nat => 1
             | S _ => INR (a + S n) + 1
            end) with (INR (S a + S n)).
    change (match a with
            | 0%nat => 1
            | S _ => INR a + 1
            end) with (INR (S a)).
    change (match n with
            | 0%nat => 1
            | S _ => INR n + 1
            end) with (INR (S n)).
    rewrite plus_INR; nra.
Qed.

Lemma sum_weight_one_with_coeff_mul_nat_list : forall G L1 n',
    sum_weight_one_with_coeff G (map nat_oRpos (map (Nat.mul (S n')) L1)) = (INR (S n')) * sum_weight_one_with_coeff G (map nat_oRpos L1).
Proof.
  intros G L1; revert G; induction L1; intros G n' ; [ destruct G; simpl; nra | ].
  destruct G; [ destruct a; simpl ; nra | ].
  specialize (IHL1 G n').
  destruct a; simpl.
  - rewrite Nat.mul_0_r; apply IHL1.
  - change (match (a + n' * S a)%nat with
           | 0%nat => 1
           | S _ => INR (a + n' * S a) + 1
            end) with (INR (S n' * S a)).
    change (match a with
            | 0%nat => 1
            | S _ => INR a + 1
            end) with (INR (S a)).
    change (fun m : nat => (m + n' * m)%nat) with (Nat.mul (S n')).
    change (match n' with
            | 0%nat => 1
            | S _ => INR n' + 1
            end) with (INR (S n')).
    rewrite mult_INR; nra.
Qed.

Lemma sum_weight_var_with_coeff_perm_r : forall G H L,
    Permutation_Type G H ->
    length L = length G ->
    { L' &
      prod (Permutation_Type L L')
           ((forall n, sum_weight_var_with_coeff n G L = sum_weight_var_with_coeff n H L') *
            (sum_weight_one_with_coeff G L = sum_weight_one_with_coeff H L') *
            (Permutation_Type (concat_with_coeff_mul (only_diamond_hseq G) L) (concat_with_coeff_mul (only_diamond_hseq H) L')))}.
Proof.
  intros G H L Hperm.
  revert L; induction Hperm; intros L Hlen.
  - destruct L; inversion Hlen.
    split with nil.
    repeat split; auto.
  - destruct L; inversion Hlen.
    destruct (IHHperm L H0) as [L' [Hperm' [[Hsum Hone] Hperm'']]].
    split with (o :: L').
    repeat split; auto.
    + intros n; simpl;rewrite (Hsum n); reflexivity.
    + simpl; rewrite Hone; reflexivity.
    + destruct o; simpl; Permutation_Type_solve.
  - destruct L ;  [ | destruct L] ; inversion Hlen.
    split with (o0 :: o :: L).
    repeat split.
    + apply Permutation_Type_swap.
    + intros n; destruct o; destruct o0; simpl; nra.
    + destruct o; destruct o0; simpl; nra.
    + destruct o; destruct o0; simpl; Permutation_Type_solve.
  - destruct (IHHperm1 L Hlen) as [L' [Hperm' [[Hsum Hone] Hperm'']]].
    destruct (IHHperm2 L') as [L2' [Hperm2' [[Hsum2 Hone2] Hperm2'']]].
    { apply Permutation_Type_length in Hperm1.
      apply Permutation_Type_length in Hperm2.
      apply Permutation_Type_length in Hperm'.
      etransitivity;  [ symmetry ; apply Hperm' | ].
      etransitivity ; [ | apply Hperm1].
      apply Hlen. }
    split with L2'.
    repeat split; [ Permutation_Type_solve | | | ].
    + intros n.
      etransitivity ; [ apply (Hsum n) | apply (Hsum2 n)].
    + etransitivity ; [ apply Hone | apply Hone2].
    + Permutation_Type_solve.
Qed.

Lemma sum_weight_var_with_coeff_perm_l : forall G L L',
    Permutation_Type L L' ->
    length L = length G ->
    { H &
      prod (Permutation_Type G H)
           ((forall n, sum_weight_var_with_coeff n G L = sum_weight_var_with_coeff n H L') *
            (sum_weight_one_with_coeff G L = sum_weight_one_with_coeff H L') *
            (Permutation_Type (concat_with_coeff_mul G L) (concat_with_coeff_mul H L')))}.
Proof.
  intros G L L' Hperm.
  revert G; induction Hperm; intros G Hlen.
  - destruct G; inversion Hlen.
    split with nil.
    auto.
  - destruct G; inversion Hlen.
    destruct (IHHperm G H0) as [H [Hperm'[[Hsum Hone] Hpc]]].
    split with (s :: H).
    repeat split; auto.
    + intros n; simpl;rewrite (Hsum n); reflexivity.
    + simpl; rewrite Hone; reflexivity.
    + simpl.
      destruct x; Permutation_Type_solve.
  - destruct G ;  [ | destruct G] ; inversion Hlen.
    split with (s0 :: s :: G).
    repeat split.
    + apply Permutation_Type_swap.
    + intros n; destruct y; destruct x; simpl; nra.
    + destruct y; destruct x; simpl; nra.
    + destruct x; destruct y; simpl; Permutation_Type_solve.
  - destruct (IHHperm1 G Hlen) as [H [Hperm'[[Hsum Hone] Hpc]]].
    destruct (IHHperm2 H) as [H2 [Hperm2'[[Hsum2 Hone2] Hpc2]]].
    { apply Permutation_Type_length in Hperm1.
      apply Permutation_Type_length in Hperm2.
      apply Permutation_Type_length in Hperm'.
      etransitivity;  [ | apply Hperm' ].
      etransitivity ; [ symmetry ; apply Hperm1 | ].
      apply Hlen. }
    split with H2.
    repeat split.
    + Permutation_Type_solve.
    + intros n.
      etransitivity ; [ apply (Hsum n) | apply (Hsum2 n)].
    + etransitivity ; [ apply Hone | apply Hone2].
    + etransitivity ; [ apply Hpc | apply Hpc2].
Qed.

Lemma sum_weight_var_with_coeff_perm_r_int : forall G H L,
    Permutation_Type G H ->
    length L = length G ->
    { L' &
      prod (Permutation_Type L L')
           ((forall n, sum_weight_var_with_coeff n G (map nat_oRpos L) = sum_weight_var_with_coeff n H (map nat_oRpos L')) *
            (sum_weight_one_with_coeff G (map nat_oRpos L) = sum_weight_one_with_coeff H (map nat_oRpos L')) *
            (Permutation_Type (concat_with_coeff_copy (only_diamond_hseq G) L) (concat_with_coeff_copy (only_diamond_hseq H) L')))}.
Proof.
  intros G H L Hperm.
  revert L; induction Hperm; intros L Hlen.
  - destruct L; inversion Hlen.
    split with nil.
    repeat split; auto.
  - destruct L; inversion Hlen.
    destruct (IHHperm L H0) as [L' [Hperm' [[Hsum Hone] Hperm'']]].
    split with (n :: L').
    repeat split; auto.
    + intros n'; simpl;rewrite (Hsum n'); reflexivity.
    + simpl; rewrite Hone; reflexivity.
    + Permutation_Type_solve.
  - destruct L ;  [ | destruct L] ; inversion Hlen.
    split with (n0 :: n :: L).
    repeat split.
    + apply Permutation_Type_swap.
    + intros n'; destruct n; destruct n0; simpl in *; nra.
    + destruct n; destruct n0; simpl; nra.
    + destruct n; destruct n0; simpl; Permutation_Type_solve.
  - destruct (IHHperm1 L Hlen) as [L' [Hperm' [[Hsum Hone] Hperm'']]].
    destruct (IHHperm2 L') as [L2' [Hperm2' [[Hsum2 Hone2] Hperm2'']]].
    { apply Permutation_Type_length in Hperm1.
      apply Permutation_Type_length in Hperm2.
      apply Permutation_Type_length in Hperm'.
      etransitivity;  [ symmetry ; apply Hperm' | ].
      etransitivity ; [ | apply Hperm1].
      apply Hlen. }
    split with L2'.
    repeat split; [ Permutation_Type_solve | | | ].
    + intros n.
      etransitivity ; [ apply (Hsum n) | apply (Hsum2 n)].
    + etransitivity ; [ apply Hone | apply Hone2].
    + Permutation_Type_solve.
Qed.

Lemma sum_weight_var_with_coeff_perm_l_int : forall G L L',
    Permutation_Type L L' ->
    length L = length G ->
    { H &
      prod (Permutation_Type G H)
           ((forall n, sum_weight_var_with_coeff n G (map nat_oRpos L) = sum_weight_var_with_coeff n H (map nat_oRpos L')) *
            (sum_weight_one_with_coeff G (map nat_oRpos L) = sum_weight_one_with_coeff H (map nat_oRpos L')) *
            (Permutation_Type (concat_with_coeff_copy G L) (concat_with_coeff_copy H L')))}.
Proof.
  intros G L L' Hperm.
  revert G; induction Hperm; intros G Hlen.
  - destruct G; inversion Hlen.
    split with nil.
    auto.
  - destruct G; inversion Hlen.
    destruct (IHHperm G H0) as [H [Hperm'[[Hsum Hone] Hpc]]].
    split with (s :: H).
    repeat split; auto.
    + intros n; simpl;rewrite (Hsum n); reflexivity.
    + simpl; rewrite Hone; reflexivity.
    + simpl.
      destruct x; Permutation_Type_solve.
  - destruct G ;  [ | destruct G] ; inversion Hlen.
    split with (s0 :: s :: G).
    repeat split.
    + apply Permutation_Type_swap.
    + intros n; destruct y; destruct x; simpl; nra.
    + destruct y; destruct x; simpl; nra.
    + destruct x; destruct y; simpl; Permutation_Type_solve.
  - destruct (IHHperm1 G Hlen) as [H [Hperm'[[Hsum Hone] Hpc]]].
    destruct (IHHperm2 H) as [H2 [Hperm2'[[Hsum2 Hone2] Hpc2]]].
    { apply Permutation_Type_length in Hperm1.
      apply Permutation_Type_length in Hperm2.
      apply Permutation_Type_length in Hperm'.
      etransitivity;  [ | apply Hperm' ].
      etransitivity ; [ symmetry ; apply Hperm1 | ].
      apply Hlen. }
    split with H2.
    repeat split.
    + Permutation_Type_solve.
    + intros n.
      etransitivity ; [ apply (Hsum n) | apply (Hsum2 n)].
    + etransitivity ; [ apply Hone | apply Hone2].
    + etransitivity ; [ apply Hpc | apply Hpc2].
Qed.

Lemma sum_weight_var_with_coeff_all_0 :
  forall G L n,
    Forall_inf (fun x => x = None) L ->
    sum_weight_var_with_coeff n G L = 0.
Proof.
  intros G L; revert G; induction L; intros G n Hall; destruct G; try reflexivity.
  inversion Hall; subst.
  specialize (IHL G n X).
  simpl; apply IHL.
Qed.

Lemma sum_weight_one_with_coeff_all_0 :
  forall G L,
    Forall_inf (fun x => x = None) L ->
    sum_weight_one_with_coeff G L = 0.
Proof.
  intros G L; revert G; induction L; intros G Hall; destruct G; try reflexivity.
  inversion Hall; subst.
  specialize (IHL G X).
  simpl; apply IHL.
Qed.

Lemma only_diamond_seq_no_diamond : forall T,
    modal_complexity_seq T = 0%nat ->
    {' (r, s) : _ & prod (Permutation_Type (only_diamond_seq T) (hseq.vec s MRS_coone ++ hseq.vec r MRS_one))
                          (hseq.sum_vec r - hseq.sum_vec s = sum_weight_one_seq T) }.
Proof.
  induction T; intros Heq.
  - split with (nil, nil).
    split; simpl; try reflexivity.
    lra.
  - destruct a as [a A].
    destruct A; simpl; try (apply IHT; simpl in Heq; lia);
      destruct IHT as [[r s] [Hperm Hone]]; simpl in Heq; try lia;
        try (exfalso; revert Heq; destruct (modal_complexity_seq T); intros Heq; lia).
    + split with (a :: r, s).
      split; [ simpl; Permutation_Type_solve | ].
      simpl; lra.
    + split with (r, a :: s).
      split; [ simpl; Permutation_Type_solve | ].
      simpl; lra.
Qed.

Lemma concat_with_coeff_mul_only_diamond_no_diamond: forall G L,
    modal_complexity_hseq G = 0%nat ->
    {' (r, s) : _ & prod (Permutation_Type (concat_with_coeff_mul (only_diamond_hseq G) L) (hseq.vec s MRS_coone ++ hseq.vec r MRS_one))
                         (hseq.sum_vec r - hseq.sum_vec s = sum_weight_one_with_coeff G L) }.
Proof.
  induction G; intros L Hnd; destruct L; simpl;
    try (split with (nil, nil); split; [ reflexivity | lra]).
  specialize (IHG L) as [[r s] [Hperm Hone]].
  { simpl in Hnd; lia. }
  destruct o; [ | split with (r , s); split; simpl; assumption ].
  destruct (only_diamond_seq_no_diamond (hseq.seq_mul r0 a)) as [[r' s'] [Hperm' Hone']].
  { simpl in Hnd; rewrite hseq.modal_complexity_seq_mul; lia. }
  split with (r' ++ r , s' ++ s).
  split.
  - rewrite ? hseq.vec_app.
    rewrite only_diamond_seq_mul.
    Permutation_Type_solve.
  - rewrite ? hseq.sum_vec_app.
    rewrite sum_weight_one_seq_mul in Hone'.
    nra.
Qed.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

Require Export Coq.Arith.Arith.
Require Export Coq.FSets.FSets.
Require Export Coq.Lists.List.

Require Export CoqEqDec.
Require Export CoqListFacts.
Require Export LibTactics.
Require Export MetatheoryAtom.
(* Require Export MetatheoryEnv. *)

Require Export AssumeList.

(* ********************************************************************** *)
(** * Decidable equality *)

(** We prefer that "==" refer to decidable equality at [eq], as
    defined by the [EqDec_eq] class from the CoqEqDec library. *)

Notation " x  == y " := (eq_dec x y) (at level 70) : coqeqdec_scope.

Open Scope coqeqdec_scope.

(* ********************************************************************** *)
(** * Notations for finite sets of atoms *)

(** Common set operations and constants may be written using more
    convenient notations. *)

Notation "E [=] F" :=
  (AtomSetImpl.Equal E F)
  (at level 70, no associativity)
  : set_scope.

Notation "E [<=] F" :=
  (AtomSetImpl.Subset E F)
  (at level 70, no associativity)
  : set_scope.

Notation "{}" :=
  (AtomSetImpl.empty)
  : set_scope.

Notation "{{  x  }}" :=
  (AtomSetImpl.singleton x)
  : set_scope.

Notation "x `in` E" :=
  (AtomSetImpl.In x E)
  (at level 70)
  : set_hs_scope.

Notation "x `notin` E" :=
  (~ AtomSetImpl.In x E)
  (at level 70)
  : set_hs_scope.

Notation "E `union` F" :=
  (AtomSetImpl.union E F)
  (at level 65, right associativity, format "E  `union`  '/' F")
  : set_hs_scope.

(** We define some abbreviations for the empty set, singleton
    sets, and the union of two sets. *)

Notation add := AtomSetImpl.add.
Notation empty := AtomSetImpl.empty.
Notation remove := AtomSetImpl.remove.
Notation singleton := AtomSetImpl.singleton.
Notation union := AtomSetImpl.union.

(** Open the notation scopes declared above. *)

Open Scope set_scope.
Open Scope set_hs_scope.

(* ********************************************************************** *)
(** * Environments *)

(** As an alternative to the [x ~ a] notation, we also provide more
    list-like notation for writing association lists consisting of a
    single binding.

    Implementation note: The following notation overlaps with the
    standard recursive notation for lists, e.g., the one found in the
    Program library of Coq's standard library. *)

(* Notation "[ x ]" := (EnvImpl.one x) : env_scope.

Open Scope env_scope.
*)

(* ********************************************************************** *)
(** * Cofinite quantification *)

(** Consider a rule [H] (equivalently, constructor, lemma, etc.) whose
    type begins with [forall L, ...] and contains hypotheses of the
    form [(forall y, y `notin` L -> ...)].

    The tactic [(pick fresh x excluding F and apply H)] applies [H] to
    the current goal, instantiating [H]'s first argument ([L]) with
    the finite set of atoms [F].  In each new subgoal of the form
    [(forall y, y `notin` F -> ...)], the atom [y] is introduced as
    [x], and [(y `notin` F)] is introduced using a generated name.

    If we view [H] as a rule that uses cofinite quantification, the
    tactic can be read as picking a sufficiently fresh atom to open a
    term with. *)

Tactic Notation
  "pick" "fresh" ident(atom_name)
  "excluding" constr(L)
  "and" "apply" constr(H)
  :=
    first [apply (@H L) | eapply (@H L)];
      match goal with
        | |- forall _, _ `notin` _ -> _ =>
          let Fr := fresh "Fr" in intros atom_name Fr
        | |- forall _, _ `notin` _ -> _ =>
          fail 1 "because" atom_name "is already defined"
        | _ =>
          idtac
      end.

(** The following variant of the tactic excludes the set of atoms
    returned by the [gather_atoms] tactic.  Redefine [gather_atoms] if
    you wish to modify the behavior of this tactic. *)

Tactic Notation
  "pick" "fresh" ident(atom_name)
  "and" "apply" constr(H)
  :=
    let L := gather_atoms in
    let L := beautify_fset L in
    pick fresh atom_name excluding L and apply H.

(* ********************************************************************** *)
(** * Lemma aliases *)

(** A number of useful lemmas are given standardized, if somewhat
    unintuitive, names.  Here, we define some intuitive aliases for
    them. *)

Notation uniq_one := uniq_one_1.
Notation uniq_cons := uniq_cons_3.
Notation uniq_app := uniq_app_4.
Notation uniq_map := uniq_map_2.

Notation binds_one := binds_one_3.
Notation binds_cons := binds_cons_3.
Notation binds_app_l := binds_app_2.
Notation binds_app_r := binds_app_3.
Notation binds_map := binds_map_2.

Notation notin_empty := notin_empty_1.
Notation notin_add := notin_add_3.
Notation notin_singleton := notin_singleton_2.
Notation notin_union := notin_union_3.

(* ********************************************************************** *)
(** * Hints *)

(** The next block of hints is to help [auto] discharge many of the
    inequality and freshness goals that arise in programming language
    metatheory proofs. *)

Ltac hint_extern_solve_notin :=
  autorewrite with rewr_dom in *;
  destruct_notin;
  repeat first [ apply notin_union_3
               | apply notin_add_3
               | apply notin_singleton_2
               | apply notin_empty_1
               ];
  try tauto.

Hint Extern 1 (_ <> _ :> _) => hint_extern_solve_notin.

Hint Extern 1 (_ `notin` _) => hint_extern_solve_notin.

(** The next block of hints are occasionally useful when reasoning
    about finite sets.  In some instances, they obviate the need to
    use [auto with set]. *)

Hint Resolve
  AtomSetImpl.add_1 AtomSetImpl.add_2 AtomSetImpl.remove_1
  AtomSetImpl.remove_2 AtomSetImpl.singleton_2 AtomSetImpl.union_2
  AtomSetImpl.union_3 AtomSetImpl.inter_3 AtomSetImpl.diff_3.

(* ********************************************************************** *)
(** * Ott compatibility *)

(** Implementation note (BEA): The following definitions make this
    library usable with the output of Ott's locally nameless backend.
    They may disappear or change as Ott changes. *)

Notation var := atom (only parsing).

Notation vars := atoms (only parsing).

Notation eq_var := eq_dec (only parsing).

Notation "x  ===  y" :=
  (x == y)
  (at level 70, only parsing)
  : coqeqdec_scope.

Notation "x \in s" :=
  (x `in` s)
  (at level 70, only parsing)
  : set_sl_scope.

Notation "x \notin s" :=
  (x `notin` s)
  (at level 70, only parsing)
  : set_sl_scope.

Notation "s \u t" :=
  (s `union` t)
  (at level 65, right associativity, only parsing)
  : set_sl_scope.

Open Scope set_sl_scope.

Ltac gather_vars_with F := gather_atoms_with.

Ltac pick_fresh_gen L Y := pick fresh Y for L.

Tactic Notation "auto" "*" := auto.

Ltac apply_fresh_base H gather_vars atom_name :=
  let L := gather_vars in
  let L := beautify_fset L in
  pick fresh x excluding L and apply H.

Definition env (A : Type) := list (atom * A).

(** We provide alternative names for tactics on association lists. *)

Ltac simpl_env :=
  simpl_asnlist.

Tactic Notation "simpl_env" "in" hyp(H) :=
  simpl_asnlist in H.

Tactic Notation "simpl_env" "in" "*" :=
  simpl_asnlist in *.

Tactic Notation "rewrite_env" constr(E) :=
  rewrite_asnlist E.

Tactic Notation "rewrite_env" constr(E) "in" hyp(H) :=
  rewrite_asnlist E in H.