Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Bedrock.Platform.Cito.SemanticsFacts4.
  Require Import Bedrock.Platform.Cito.ProgramLogic2.
  Require Import Bedrock.Platform.Cito.Transit.
  Require Import Bedrock.Platform.Cito.Semantics.

  Require Import Bedrock.Platform.Cito.GLabel.
  Require Import Bedrock.Platform.Cito.GLabelMap.
  Import GLabelMap.
  Require Import Bedrock.Platform.Cito.GLabelMapFacts.

  Notation Internal := (@Internal ADTValue).

  Definition strengthen_specs specs_op specs_ax env_ax :=
    forall (lbl : glabel),
      find lbl specs_op = find lbl specs_ax \/
      exists spec_op spec_ax,
        find lbl specs_op = Some (Internal spec_op) /\
        find lbl specs_ax = Some (Foreign spec_ax) /\
        strengthen_op_ax spec_op spec_ax env_ax.

  Require Import Bedrock.Platform.Cito.GeneralTactics Bedrock.Platform.Cito.GeneralTactics2.
  Require Import Bedrock.Platform.Cito.Option.

  Lemma strengthen_specs_strengthen : forall specs_op specs_ax env_op env_ax, strengthen_specs specs_op specs_ax env_ax -> specs_env_agree specs_op env_op -> specs_env_agree specs_ax env_ax -> (forall lbl, fst env_op lbl = fst env_ax lbl) -> strengthen env_op env_ax.
  Proof.
    split; intros.
    eauto.
    destruct (option_dec (fs_op w)).
    destruct s.
    generalize e; intro.
    eapply H0 in e.
    openhyp.
    edestruct (H x0).
    left.
    rewrite e0.
    symmetry.
    eapply H1.
    rewrite H5 in H4; clear H5.
    descend; eauto.
    rewrite <- H2.
    eauto.

    openhyp.
    rewrite H5 in H4; injection H4; intros; subst.
    assert (fs_ax w = Some (Foreign x2)).
    eapply H1.
    descend; eauto.
    rewrite <- H2; eauto.
    right; descend; eauto.

    destruct (option_dec (fs_ax w)).
    destruct s.
    generalize e0; intro.
    eapply H1 in e0.
    openhyp.
    edestruct (H x0).
    assert (fs_op w = Some x).
    eapply H0.
    descend; eauto.
    rewrite H2; eauto.
    rewrite H5.
    eauto.
    rewrite H6 in e; intuition.
    openhyp.
    assert (fs_op w = Some (Internal x1)).
    eapply H0.
    descend; eauto.
    rewrite H2; eauto.
    rewrite H8 in e; intuition.
    left; congruence.
  Qed.

  Notation Foreign := (@Foreign ADTValue).

  Definition apply_specs_diff specs specs_diff := update specs (map Foreign specs_diff).

  Definition strengthen_diff_f specs env_ax k v a :=
    a /\
    (find k specs = Some (Foreign v) \/
     exists op,
       find k specs = Some (Internal op) /\
       strengthen_op_ax op v env_ax).

  Definition strengthen_diff specs specs_diff env_ax :=
    fold (strengthen_diff_f specs env_ax) specs_diff True.

  Lemma strengthen_diff_intro : forall specs_diff env_ax specs, (forall lbl ax, find lbl specs_diff = Some ax -> find lbl specs = Some (Foreign ax) \/ exists op, find lbl specs = Some (Internal op) /\ strengthen_op_ax op ax env_ax) -> strengthen_diff specs specs_diff env_ax.
  Proof.
    do 3 intro.
    (* intros Hforall. *)
    (* unfold strengthen_diff. *)
    eapply fold_rec_bis with (P := fun specs_diff (H : Prop) => (forall lbl ax, find lbl specs_diff = Some ax -> find lbl specs = Some (Foreign ax) \/ exists op, find lbl specs = Some (Internal op) /\ strengthen_op_ax op ax env_ax) -> H); simpl.
    intros m m' a Heqm Ha Hforall.
    {
      eapply Ha.
      intros lbl ax Hfind.
      rewrite Heqm in Hfind.
      eauto.
    }
    { eauto. }
    intros k e a m' Hmapsto Hnin Ha Hforall.
    unfold strengthen_diff_f.
    split.
    {
      eapply Ha.
      intros lbl ax Hfind.
      eapply Hforall.
      eapply find_mapsto_iff.
      eapply add_mapsto_iff.
      right.
      split.
      {
        intro Heq; subst.
        contradict Hnin.
        eapply MapsTo_In.
        eapply find_mapsto_iff.
        eauto.
      }
      eapply find_mapsto_iff.
      eauto.
    }
    eapply Hforall.
    eapply find_mapsto_iff.
    eapply add_mapsto_iff.
    left.
    eauto.
  Qed.

  Lemma strengthen_diff_elim : forall specs_diff env_ax specs, strengthen_diff specs specs_diff env_ax -> forall lbl ax, find lbl specs_diff = Some ax -> find lbl specs = Some (Foreign ax) \/ exists op, find lbl specs = Some (Internal op) /\ strengthen_op_ax op ax env_ax.
    do 3 intro.
    eapply fold_rec_bis with (P := fun specs_diff (H : Prop) => H -> forall lbl ax, find lbl specs_diff = Some ax -> find lbl specs = Some (Foreign ax) \/ exists op, find lbl specs = Some (Internal op) /\ strengthen_op_ax op ax env_ax); simpl; intros.
    eapply H0; eauto.
    rewrite H; eauto.
    rewrite empty_o in H0; intuition.
    eapply find_mapsto_iff in H3.
    eapply add_mapsto_iff in H3.
    openhyp.
    subst.
    destruct H2.
    openhyp.
    eauto.
    right; descend; eauto.
    eapply H1.
    destruct H2; eauto.
    eapply find_mapsto_iff; eauto.
  Qed.

  Lemma strengthen_diff_strengthen_specs : forall specs specs_diff env_ax, strengthen_diff specs specs_diff env_ax -> strengthen_specs specs (apply_specs_diff specs specs_diff) env_ax.
    intros.
    unfold strengthen_specs.
    intros.
    destruct (option_dec (find lbl specs_diff)).
    destruct s.
    eapply strengthen_diff_elim in H; eauto.
    openhyp.
    left.
    rewrite H.
    symmetry.
    eapply find_mapsto_iff.
    eapply update_mapsto_iff.
    left.
    eapply find_mapsto_iff.
    rewrite map_o.
    rewrite e.
    eauto.
    right; descend; eauto.
    eapply find_mapsto_iff.
    eapply update_mapsto_iff.
    left.
    eapply find_mapsto_iff.
    rewrite map_o.
    rewrite e.
    eauto.
    left.
    unfold apply_specs_diff.
    rewrite update_o_1; eauto.
    nintro.
    eapply map_4 in H0.
    eapply In_find_not_None in H0.
    erewrite e in H0.
    intuition.
  Qed.

  Lemma strengthen_diff_strenghthen : forall specs specs_diff env_op env_ax, strengthen_diff specs specs_diff env_ax -> specs_env_agree specs env_op -> specs_env_agree (apply_specs_diff specs specs_diff) env_ax -> (forall lbl, fst env_op lbl = fst env_ax lbl) -> strengthen env_op env_ax.
    intros.
    eapply strengthen_specs_strengthen; eauto.
    eapply strengthen_diff_strengthen_specs; eauto.
  Qed.

  Notation Callee := (@Callee ADTValue).

  Definition is_pointer_of_label specs (stn : glabel -> option W) w : option Callee :=
    fold (fun k v res =>
            match res with
              | Some _ => res
              | None =>
                match stn k with
                  | Some w' => if weq w w' then Some v else None
                  | None => None
                end
            end
         ) specs None.

  Notation Env := (@Env ADTValue).

  Definition change_env new_specs (env : Env) : Env :=
    let stn := fst env in
    let fs := snd env in
    (stn,
     fun w =>
       match is_pointer_of_label new_specs stn w with
         | Some new_spec => Some new_spec
         | None => fs w
       end).

  Notation specs_stn_injective := (@specs_stn_injective ADTValue).

  Lemma sub_domain_specs_stn_injective : forall specs1 specs2 stn, specs_stn_injective specs1 stn -> sub_domain specs2 specs1 -> specs_stn_injective specs2 stn.
    unfold ProgramLogic2.specs_stn_injective, sub_domain; intros.
    eapply H; eauto.
  Qed.

  Lemma add_specs_stn_injective : forall specs k v stn, specs_stn_injective (add k v specs) stn -> specs_stn_injective specs stn.
    intros.
    eapply sub_domain_specs_stn_injective; eauto.
    unfold sub_domain; intros.
    eapply add_in_iff; eauto.
  Qed.

  Lemma is_pointer_of_label_intro_elim : forall specs stn w, (forall v, is_pointer_of_label specs stn w = Some v -> exists lbl, find lbl specs = Some v /\ stn lbl = Some w) /\ (forall v lbl, specs_stn_injective specs stn -> find lbl specs = Some v -> stn lbl = Some w -> is_pointer_of_label specs stn w = Some v).
    do 3 intro.
    eapply fold_rec_bis with (P := fun specs a => (forall v, a = Some v -> exists lbl, find lbl specs = Some v /\ stn lbl = Some w) /\ (forall v lbl, specs_stn_injective specs stn -> find lbl specs = Some v -> stn lbl = Some w -> a = Some v)); simpl; intros.
    unfold ProgramLogic2.specs_stn_injective in *.
    setoid_rewrite H in H0.
    eapply H0; eauto.
    split; intros.
    intuition.
    rewrite empty_o in H0; intuition.
    openhyp.
    split; intros.
    destruct a.
    injection H3; intros; subst.
    edestruct H1; eauto.
    openhyp.
    descend; eauto.
    eapply find_mapsto_iff; eapply add_mapsto_iff.
    right.
    split.
    nintro; subst.
    eapply find_mapsto_iff in H4; eapply MapsTo_In in H4.
    contradiction.
    eapply find_mapsto_iff; eauto.
    destruct (option_dec (stn k)).
    destruct s.
    rewrite e0 in *.
    destruct (weq w x).
    subst.
    injection H3; intros; subst.
    descend; eauto.
    eapply find_mapsto_iff; eapply add_mapsto_iff.
    eauto.
    intuition.
    rewrite e0 in *; intuition.
    destruct a.
    edestruct H1; eauto.
    openhyp.
    eapply find_mapsto_iff in H4; eapply find_mapsto_iff in H6.
    assert (lbl = x).
    eapply H3; eauto.
    eapply MapsTo_In; eauto.
    eapply add_in_iff; right; eapply MapsTo_In; eauto.
    subst.
    eapply add_mapsto_iff in H4; openhyp.
    subst.
    eapply MapsTo_In in H6; contradiction.
    eapply H2; eauto.
    eapply add_specs_stn_injective; eauto.
    eapply find_mapsto_iff; eauto.

    eapply find_mapsto_iff in H4.
    destruct (option_dec (stn k)).
    destruct s.
    rewrite e0 in *.
    eapply add_mapsto_iff in H4; openhyp.
    subst.
    rewrite H5 in e0; injection e0; intros; subst.
    destruct (weq x x); intuition.
    destruct (weq w x).
    subst.
    contradict H4.
    eapply H3; eauto.
    eapply add_in_iff; eauto.
    eapply add_in_iff; right; eapply MapsTo_In; eauto.
    eapply H2; eauto.
    eapply add_specs_stn_injective; eauto.
    eapply find_mapsto_iff; eauto.
    rewrite e0 in *.
    eapply add_mapsto_iff in H4; openhyp.
    subst.
    rewrite H5 in e0; intuition.
    eapply H2; eauto.
    eapply add_specs_stn_injective; eauto.
    eapply find_mapsto_iff; eauto.
  Qed.

  Lemma is_pointer_of_label_intro : forall specs stn w v lbl, specs_stn_injective specs stn -> find lbl specs = Some v -> stn lbl = Some w -> is_pointer_of_label specs stn w = Some v.
    eapply is_pointer_of_label_intro_elim; eauto.
  Qed.

  Lemma is_pointer_of_label_elim : forall specs stn w v, is_pointer_of_label specs stn w = Some v -> exists lbl, find lbl specs = Some v /\ stn lbl = Some w.
    eapply is_pointer_of_label_intro_elim; eauto.
  Qed.

  Lemma equal_domain_specs_stn_injective : forall specs1 specs2 stn, equal_domain specs1 specs2 -> (specs_stn_injective specs1 stn <-> specs_stn_injective specs2 stn).
    split; intros.
    eapply sub_domain_specs_stn_injective; eauto; eapply H.
    eapply sub_domain_specs_stn_injective; eauto; eapply H.
  Qed.
  Lemma equal_domain_sym : forall elt1 elt2 (m1 : t elt1) (m2 : t elt2), equal_domain m1 m2 -> equal_domain m2 m1.
    unfold equal_domain; intuition.
  Qed.

  Lemma change_env_agree : forall specs new_specs, equal_domain new_specs specs -> forall env, specs_env_agree specs env -> specs_env_agree new_specs (change_env new_specs env).
  Proof.
    unfold specs_env_agree.
    intros.
    openhyp.
    simpl.
    split.
    unfold labels_in_scope in *.
    intros.
    eapply H0.
    eapply H; eauto.

    split.
    eapply equal_domain_specs_stn_injective; eauto.

    unfold specs_fs_agree in *.
    split; intros.
    simpl in *.
    destruct env in *; simpl in *.
    destruct (option_dec (is_pointer_of_label new_specs o p)).
    destruct s.
    rewrite e in *.
    injection H3; intros; subst.
    eapply is_pointer_of_label_elim in e; openhyp.
    descend; eauto.
    rewrite e in *.
    eapply H2 in H3; openhyp.
    eapply find_mapsto_iff in H4; eapply MapsTo_In in H4.
    eapply H in H4.
    eapply In_MapsTo in H4; openhyp.
    assert (is_pointer_of_label new_specs o p = Some x0).
    eapply is_pointer_of_label_intro; eauto.
    eapply equal_domain_specs_stn_injective; eauto.

    eapply find_mapsto_iff; eauto.
    rewrite e in H5; intuition.
    openhyp.
    simpl in *.
    destruct env; simpl in *.
    assert (is_pointer_of_label new_specs o p = Some spec).
    eapply is_pointer_of_label_intro; eauto.
    eapply equal_domain_specs_stn_injective; eauto.
    rewrite H5; eauto.
  Qed.

  Lemma sub_domain_apply_specs_diff_equal_domain a b : sub_domain b a -> equal_domain (apply_specs_diff a b) a.
  Proof.
    unfold apply_specs_diff.
    unfold equal_domain.
    intros H.
    split.
    {
      eapply sub_domain_update_sub_domain; eauto.
      eapply sub_domain_map_1; eauto.
    }
    {
      eapply sub_domain_update_1.
      eapply sub_domain_refl.
    }
  Qed.

End ADTValue.


From Coq Require Import ssreflect.
From stdpp Require Import base gmap.
From iris.proofmode Require Import tactics.
From aneris.prelude Require Import gset_map.
From aneris.aneris_lang.lib Require Import list_proof.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.aneris_lang Require Import aneris_lifting proofmode.
From aneris.examples.crdt.spec Require Import crdt_base crdt_time crdt_events crdt_denot crdt_resources.
From aneris.examples.crdt.oplib Require Import oplib_code.
From aneris.examples.crdt.oplib.spec Require Import model spec.
From aneris.examples.crdt.oplib.examples.pncounter Require Import pncounter_code pncounter_proof.
From aneris.examples.crdt.oplib.examples.map_comb Require Import map_comb_code map_comb_proof.
From aneris.examples.crdt.oplib.examples.table_of_counters Require Import table_of_counters_code.

Section table_of_counters_proof.
  Context `{!anerisG M Σ, !CRDT_Params, !OpLib_Res (mapOp CtrOp)}.

  Lemma table_of_counters_init_st_fn_spec :
    ⊢ @init_st_fn_spec _ _ _ _ _ _ _ map_OpLib_Params table_of_counters_init_st.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /table_of_counters_init_st.
    wp_pure _.
    wp_apply map_init_st_fn_spec; done.
  Qed.

  Lemma table_of_counters_effect_spec :
    ⊢ @effect_spec _ _ _ _ _ _ _ map_OpLib_Params table_of_counters_effect.
  Proof.
    iIntros (addr ev st s log_ev log_st).
    iIntros "!#" (Φ) "(%Hev & %Hst & %Hs & %Hevs) HΦ".
    rewrite /table_of_counters_effect.
    wp_pures.
    rewrite /map_comb_effect.
    do 4 wp_pure _.
    wp_apply map_effect_spec; [iApply Ctr_init_st_fn_spec|iApply Ctr_effect_spec|done|done].
  Qed.

  Lemma table_of_counters_crdt_fun_spec :
    ⊢ @crdt_fun_spec _ _ _ _ _ _ _ map_OpLib_Params table_of_counters_crdt.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /table_of_counters_crdt.
    wp_pures.
    iApply "HΦ".
    iExists _, _; iSplit; first done.
    iSplit.
    - iApply table_of_counters_init_st_fn_spec; done.
    - iApply table_of_counters_effect_spec; done.
  Qed.

  Notation oplib_init' :=
    (oplib_init
       (s_ser (s_serializer (@OpLib_Serialization _ _ _ _ map_OpLib_Params)))
       (s_deser (s_serializer (@OpLib_Serialization _ _ _ _ map_OpLib_Params)))).

  Lemma table_of_counters_init_spec :
    @init_spec _ _ _ _ _ _ _ map_OpLib_Params _ _ oplib_init' -∗
    @init_spec_for_specific_crdt _ _ _ _ _ _ _ map_OpLib_Params _ _ table_of_counters_init.
  Proof.
    iIntros "#Hinit" (repId addr addrs_val).
    iIntros (Φ) "!# (%Haddrs & %Hrepid & Hprotos & Hskt & Hfr & Htoken) HΦ".
    rewrite /table_of_counters_init /table_of_counters_crdt.
    wp_pures.
    wp_apply ("Hinit" with "[$Hprotos $Htoken $Hskt $Hfr]").
    { do 2 (iSplit; first done). iApply table_of_counters_crdt_fun_spec; done. }
    iIntros (get update) "(HLS & #Hget & #Hupdate)".
    wp_pures.
    iApply "HΦ"; eauto.
  Qed.

End table_of_counters_proof.


Require Import Coq.Lists.List Coq.Logic.FunctionalExtensionality Names.

Module Fun.

  Definition temp_name_mapping := name -> option star.

  Definition temp_name_mapping_star := star -> option star.

  Definition empty : temp_name_mapping := fun _ => None.

  Definition in_domain (f : temp_name_mapping) (x : name) := f x <> None.

  Definition in_range f x := exists y : name, f y = Some (star_name x).

  Definition in_range_in_domain f := forall x, in_range f x -> in_domain f x.

  Definition fun_exclusive f1 f2 := forall x,
    (in_domain f1 x -> ~ in_domain f2 x) /\ (in_domain f2 x -> ~ in_domain f1 x).

  Lemma in_domain_not_empty : forall f x, in_domain f x -> f <> empty.
  Proof.
    intros.
    intro.
    unfold in_domain in H.
    apply equal_f with x in H0.
    compute in H0.
    auto.
  Qed.

  Definition to_star_function (f : temp_name_mapping) : temp_name_mapping_star :=
    fun s : star =>
      match s with
        | star_name n => f n
        | _ => Some star_bottom
      end.

  Definition beq_option_star (o1 : option star) (o2 : option star) : bool :=
    match o1, o2 with
      | Some s1, Some s2 => beq_star s1 s2
      | _, _ => false
    end.

  Definition fun_plus (f1 : temp_name_mapping) (f2 : temp_name_mapping) : temp_name_mapping :=
    fun x : name =>
      match f1 x with
        | Some n => match n with
                      | star_bottom => match f2 x with
                                         | Some n' => Some n'
                                         | None => Some n
                                       end
                      | _ => Some n
                    end
        | None => f2 x
      end.

  Lemma fun_plus_assoc : forall f1 f2 f3, fun_plus f1 (fun_plus f2 f3) = fun_plus (fun_plus f1 f2) f3.
  Proof.
    intros.
    apply functional_extensionality.
    intros.
    unfold fun_plus.
    destruct (f1 x); auto.
    destruct s; auto.
    destruct (f2 x); auto.
    destruct s; auto.
    destruct (f3 x); auto.
  Qed.

  Lemma fun_plus_empty_split : forall f1 f2, fun_plus f1 f2 = empty <-> f1 = empty /\ f2 = empty.
  Proof.
    unfold fun_plus.
    split.
      intro.
      split.
      apply functional_extensionality.
      intro.
      apply equal_f with x in H.
      destruct (f1 x).
        destruct s.
          auto.
          destruct (f2 x).
            discriminate.
            discriminate.
          discriminate.
        auto.

      apply functional_extensionality.
      intro.
      apply equal_f with x in H.
      destruct (f1 x).
        destruct s.
          discriminate.
          destruct (f2 x).
            discriminate.
            discriminate.
          discriminate.
        auto.

      intros.
      inversion_clear H.
      apply functional_extensionality.
      rewrite H0; rewrite H1.
      unfold empty.
      auto.
  Qed.

  Lemma fun_plus_in_domain : forall f1 f2 x, in_domain (fun_plus f1 f2) x <-> in_domain f1 x \/ in_domain f2 x.
  Proof.
    unfold in_domain.
    split.
      intro.
      unfold fun_plus in H.
      destruct (f1 x) eqn:?.
        induction s.
          left; auto.
          destruct (f2 x) eqn:?.
            right; auto.
            left; auto.
          left; auto.
          right; auto.
      intro.
      unfold fun_plus.
      inversion H.
        destruct (f1 x) eqn:?.
          induction s.
            auto.
            destruct (f2 x) eqn:?; intro; discriminate.
            auto.
          exfalso; apply H0; auto.
        destruct (f1 x).
          destruct s.
            intro; discriminate.
            destruct (f2 x).
              auto.
              auto.
            intro; discriminate.
          auto.
  Qed.

  Lemma fun_plus_not_in_domain : forall f1 f2 x, ~ in_domain (fun_plus f1 f2) x <-> ~ in_domain f1 x /\ ~ in_domain f2 x.
  Proof.
    unfold in_domain.
    split.
      intros.
      split.
      intro.
      apply H.
      intro.
      unfold fun_plus in H1.
      apply H0.
      destruct (f1 x) eqn:?.
        destruct s eqn:?.
          discriminate.
          destruct (f2 x) eqn:?.
            discriminate.
            discriminate.
          discriminate.
        auto.
      intro.
      apply H.
      intro.
      unfold fun_plus in H1.
      apply H0.
      destruct (f1 x) eqn:?.
        destruct s eqn:?.
          discriminate.
          destruct (f2 x) eqn:?.
            discriminate.
            discriminate.
          discriminate.
        auto.

      intros.
      inversion H.
      intro.
      unfold fun_plus in H2.
      apply H0.
      intro.
      rewrite H3 in H2.
      apply H1.
      auto.
  Qed.

  Lemma fun_plus_in_range_in_domain : forall f1 f2,
                                  in_range_in_domain f1 ->
                                  in_range_in_domain f2 ->
                                  in_range_in_domain (fun_plus f1 f2).
  Proof.
    unfold in_range_in_domain.
    unfold in_range.
    unfold in_domain.
    unfold fun_plus.
    intros.
    destruct (f1 x) eqn:?.
      destruct s; try (intro; discriminate).
      destruct (f2 x) eqn:?; try (intro; discriminate).

      destruct (f2 x) eqn:?; try (intro; discriminate).
      inversion_clear H1.
      destruct (f1 x0) eqn:?.
        destruct s.
          specialize (H x).
          rewrite Heqo in H.
          apply H.
          exists x0.
          rewrite Heqo1; auto.

          destruct (f2 x0) eqn:?.
            inversion H2; subst.
            specialize (H0 x).
            rewrite Heqo0 in H0.
            apply H0.
            exists x0.
            auto.

            discriminate.
          discriminate.
        specialize (H0 x).
        rewrite Heqo0 in H0.
        apply H0.
        exists x0.
        auto.
  Qed.

  Definition fun_remove f x : temp_name_mapping :=
    fun y : name =>
      if beq_name y x
      then None
      else
        match f y with
          | Some (star_name n) =>
            if beq_name n x
            then Some star_star
            else Some (star_name n)
          | a => a
        end.

  Goal forall x y z f, x <> y -> y <> z -> z <> x ->
         f = (fun a =>
            if beq_name a x then Some (star_name y) else
              if beq_name a y then Some (star_name z) else
                if beq_name a z then Some star_bottom else None) ->
         fun_remove f z z = None /\
         fun_remove f z y = Some star_star /\
         fun_remove f z x = Some (star_name y).
  Proof.
    intros.
    split.
      unfold fun_remove.
      rewrite beq_name_refl.
      auto.

      split.
        unfold fun_remove.
        apply beq_name_false_iff in H0.
        rewrite H0.
        rewrite H2.
        apply beq_name_false_iff in H.
        rewrite beq_name_sym in H.
        rewrite H.
        rewrite beq_name_refl.
        rewrite beq_name_refl.
        auto.

        unfold fun_remove.
        rewrite H2.
        apply beq_name_false_iff in H1.
        rewrite beq_name_sym in H1.
        rewrite H1.
        rewrite beq_name_refl.
        apply beq_name_false_iff in H0.
        rewrite H0.
        auto.
  Qed.

  Lemma fun_remove_in_domain_1 : forall f x y, in_domain f x -> in_domain (fun_remove f y) x \/ x = y.
  Proof.
    unfold in_domain.
    unfold fun_remove.
    intros.
    destruct (beq_name x y) eqn:?.
      apply beq_name_true_iff in Heqb.
      right; auto.

      destruct (f x).
        destruct s.
          left.
          destruct (beq_name n y); easy.
          left; easy.
          left; easy.
          auto.
  Qed.

  Lemma fun_remove_in_domain_2 : forall f x y, in_domain (fun_remove f y) x -> x <> y /\ in_domain f x.
  Proof.
    unfold in_domain.
    unfold fun_remove.
    split.
      intro.
      apply beq_name_true_iff in H0.
      rewrite H0 in H.
      apply H; auto.

      intro.
      rewrite H0 in H.
      apply H.
      destruct (beq_name x y); auto.
  Qed.

  Lemma fun_remove_not_in_domain_1 : forall f x y, ~ in_domain f x -> ~ in_domain (fun_remove f y) x.
  Proof.
    unfold in_domain.
    intros.
    unfold fun_remove.
    intro.
    destruct (beq_name x y) eqn:?.
      apply H0; auto.
      apply H.
      intro.
      rewrite H1 in H0.
      apply H0; auto.
  Qed.

  Lemma fun_remove_not_in_domain_2 : forall f x y, ~ in_domain (fun_remove f y) x -> x = y \/ ~ in_domain f x.
  Proof.
    unfold in_domain.
    unfold fun_remove.
    intros.
    destruct (beq_name x y) eqn:?.
      apply beq_name_true_iff in Heqb.
      left; auto.

      right.
      intro.
      apply H.
      destruct (f x) eqn:?.
        destruct s eqn:?.
          destruct (beq_name n y) eqn:?.
            intro; discriminate.
            intro; discriminate.
          intro; discriminate.
          intro; discriminate.
        auto.
  Qed.

  Lemma fun_remove_in_range_in_domain : forall f x, in_range_in_domain f -> in_range_in_domain (fun_remove f x).
  Proof.
    unfold in_range_in_domain.
    unfold in_range, in_domain, fun_remove.
    intros.
    inversion_clear H0.
    destruct (beq_name x0 x) eqn:?.
      destruct (beq_name x1 x).
        discriminate.

        destruct (f x1) eqn:?.
          destruct s.
            destruct (beq_name n x) eqn:?.
              discriminate.

              inversion H1.
              subst.
              rewrite Heqb in Heqb0.
              discriminate.

            discriminate.

            discriminate.

          discriminate.

      destruct (f x0) eqn:?.
        destruct s.
          destruct (beq_name n x); intro; discriminate.

          intro; discriminate.

          intro; discriminate.

        destruct (beq_name x1 x) eqn:?.
          discriminate.

          destruct (f x1) eqn:?.
            destruct s.
              destruct (beq_name n x) eqn:?.
                discriminate.

                inversion H1; subst.
                specialize (H x0).
                rewrite Heqo in H.
                apply H.
                exists x1; auto.

              discriminate.

              discriminate.

            discriminate.
  Qed.

  Definition fun_double (f : temp_name_mapping) : temp_name_mapping :=
    fun x : name =>
      match f x with
        | Some (star_name n) => f n
        | Some _ => Some star_bottom
        | None => None
      end.

  Definition Fun_comm (f1 : temp_name_mapping) (f2 : temp_name_mapping) :=
    fun_plus f1 f2 = fun_plus f2 f1.

  (* f(x) /= x *)
  Definition Fun_prop_1 (f : temp_name_mapping) :=
    forall x : name, f x <> Some (star_name x).

  (* f(x) = f(y) and is not member of {_|_, *} -> x = y *)
  Definition Fun_prop_2 (f : temp_name_mapping) :=
    forall (x y : name), (exists n, f x = Some (star_name n)) ->
                         (exists n, f y = Some (star_name n)) ->
                         f x = f y ->
                         x = y.

  (* f*(f(x)) = _|_ *)
  Definition Fun_prop_3 (f : temp_name_mapping) :=
    forall x, in_domain f x -> fun_double f x = Some star_bottom.

  Definition Fun_prop (f : temp_name_mapping) :=
    Fun_prop_1 f /\ Fun_prop_2 f /\ Fun_prop_3 f.

  Record Compatible (f1 : temp_name_mapping) (f2 : temp_name_mapping) := Build_compatible {
    Compatible_comm : Fun_comm f1 f2;
    Compatible_prop : Fun_prop (fun_plus f1 f2)
  }.

  Fixpoint Mutually_compatible (fs : list temp_name_mapping) :=
    match fs with
      | nil => True
      | f :: fs' => Forall (Compatible f) fs' /\ Mutually_compatible fs'
    end.

  (* ch_0 *)

  Definition ch_0 := empty.

  Lemma ch_0_in_range_in_domain : in_range_in_domain ch_0.
  Proof.
    unfold in_range_in_domain.
    unfold in_range, in_domain.
    intros.
      inversion H.
      compute in H0; discriminate.
  Qed.

  Lemma ch_0_prop_1 : Fun_prop_1 ch_0.
  Proof.
    unfold Fun_prop_1.
    intro.
    intro.
    compute in H.
    discriminate.
  Qed.

  Lemma ch_0_prop_2 : Fun_prop_2 ch_0.
  Proof.
    unfold Fun_prop_2.
    intros.
    compute in H.
    inversion H.
    discriminate.
  Qed.

  Lemma ch_0_prop_3 : Fun_prop_3 ch_0.
  Proof.
    unfold Fun_prop_3.
    intros.
    compute in H.
    exfalso; apply H; auto.
  Qed.

  Theorem ch_0_prop : Fun_prop ch_0.
  Proof.
    unfold Fun_prop.
    split.
    apply ch_0_prop_1.
    split.
    apply ch_0_prop_2.
    apply ch_0_prop_3.
  Qed.

  (* ch_1 *)

  Definition ch_1 (n : name) : temp_name_mapping :=
    fun x => if beq_name n x
             then Some star_bottom
             else None.

  Lemma ch_1_equal : forall x y, ch_1 x = ch_1 y <-> x = y.
  Proof.
    unfold ch_1.
    split; intros.
      apply equal_f with x in H.
      rewrite beq_name_refl in H.
      destruct (beq_name y x) eqn:?.
        apply beq_name_true_iff in Heqb.
        auto.

        discriminate.

      rewrite H.
      auto.
  Qed.

  Lemma ch_1_not_empty : forall x, ch_1 x <> empty.
  Proof.
    intros.
    intro.
    apply equal_f with x in H.
    unfold ch_1 in H.
    rewrite beq_name_refl in H.
    discriminate.
  Qed.

  Lemma ch_1_in_domain : forall x y, in_domain (ch_1 x) y <-> x = y.
  Proof.
    unfold in_domain.
    unfold ch_1.
    intros.
    destruct (beq_name x y) eqn:?.
      apply beq_name_true_iff in Heqb.
      rewrite Heqb.
      split.
        intro; auto.
        intro; intro; discriminate.
      split.
        intro; exfalso.
        apply H; auto.
        intro; apply beq_name_false_iff in Heqb.
        contradiction.
  Qed.

  Lemma ch_1_not_in_domain : forall x y, ~ in_domain (ch_1 x) y <-> x <> y.
  Proof.
    unfold in_domain.
    unfold ch_1.
    intros.
    destruct (beq_name x y) eqn:?.
      apply beq_name_true_iff in Heqb.
      rewrite Heqb.
      split.
        intro; intro.
        unfold not in H.
        apply H.
        intro.
        discriminate.

        intro.
        exfalso; apply H; auto.

      split.
        intro; intro.
        apply beq_name_false_iff in Heqb.
        auto.

        intro.
        intro.
        apply H0; auto.
  Qed.

  Lemma ch_1_not_name : forall x y z, ch_1 x y <> Some (star_name z).
  Proof.
    unfold ch_1.
    intros.
    destruct (beq_name x y) eqn:?.
      intro.
      discriminate.

      intro.
      discriminate.
  Qed.

  Lemma ch_1_in_range_in_domain : forall x, in_range_in_domain (ch_1 x).
  Proof.
    unfold in_range_in_domain.
    unfold in_range, in_domain.
    unfold ch_1.
    intros.
    inversion H.
    destruct (beq_name x x1) eqn:?; discriminate.
  Qed.

  Lemma ch_1_prop_1 : forall n, Fun_prop_1 (ch_1 n).
  Proof.
    unfold Fun_prop_1.
    intros.
    unfold ch_1.
    destruct (beq_name n x); intro; discriminate.
  Qed.

  Lemma ch_1_prop_2 : forall n, Fun_prop_2 (ch_1 n).
  Proof.
    unfold Fun_prop_2.
    unfold ch_1.
    intros.
    destruct (beq_name n x) eqn:?.
      apply beq_name_true_iff in Heqb.
      destruct (beq_name n y) eqn:?.
        apply beq_name_true_iff in Heqb0.
        rewrite <- Heqb.
        rewrite Heqb0.
        auto.

        discriminate.
      inversion H.
      discriminate.
  Qed.

  Lemma ch_1_prop_3 : forall n, Fun_prop_3 (ch_1 n).
  Proof.
    unfold Fun_prop_3.
    unfold in_domain.
    unfold ch_1.
    unfold fun_double.
    intros.
    destruct (beq_name n x) eqn:?.
      auto.

      exfalso.
      apply H.
      auto.
  Qed.

  Theorem ch_1_prop : forall n, Fun_prop (ch_1 n).
  Proof.
    unfold Fun_prop.
    split.
    apply ch_1_prop_1.
    split.
    apply ch_1_prop_2.
    apply ch_1_prop_3.
  Qed.

  (* ch_2 *)

  Definition ch_2 (n m : name) : temp_name_mapping :=
    fun x =>
      if beq_name n x
      then Some (star_name m)
      else if beq_name m x
           then Some star_bottom
           else None.

  Lemma ch_2_not_empty : forall x y, ch_2 x y <> empty.
  Proof.
    intros.
    intro.
    apply equal_f with x in H.
    unfold ch_2 in H.
    rewrite beq_name_refl in H.
    compute in H.
    discriminate.
  Qed.

  Theorem ch_2_in_domain : forall x y z, in_domain (ch_2 x y) z <-> x = z \/ y = z.
  Proof.
    split.
    intros.

    unfold in_domain in H.
    unfold ch_2 in H.
    destruct (beq_name x z) eqn:?.
      apply beq_name_true_iff in Heqb.
      left; auto.

      destruct (beq_name y z) eqn:?.
        apply beq_name_true_iff in Heqb0.
        right; auto.

        exfalso; apply H; auto.
    intro.
    unfold in_domain.
    unfold ch_2.
    inversion H.
      rewrite <- H0.
      rewrite beq_name_refl.
      intro; discriminate.

      rewrite H0.
      destruct (beq_name x z) eqn:?.
        intro; discriminate.
        rewrite beq_name_refl.
        intro; discriminate.
  Qed.

  Lemma ch_2_not_in_domain : forall x y z, ~ in_domain (ch_2 x y) z <-> x <> z /\ y <> z.
  Proof.
    unfold in_domain.
    unfold ch_2.
    intros.
    destruct (beq_name x z) eqn:?.
      apply beq_name_true_iff in Heqb.
      rewrite Heqb.
      split; try split.
        exfalso; apply H.
        intro; discriminate.

        exfalso; apply H; intro; discriminate.

        intro.
        inversion H.
        exfalso; apply H0; auto.
      split; try split.
        destruct (beq_name y z) eqn:?.
          apply beq_name_true_iff in Heqb0.
          intro.
          rewrite H0 in Heqb.
          rewrite beq_name_refl in Heqb.
          discriminate.

          intro.
          rewrite H0 in Heqb.
          rewrite beq_name_refl in Heqb.
          discriminate.

        intro.
        rewrite H0 in H.
        rewrite beq_name_refl in H.
        apply H; intro.
        discriminate.

        intros.
        inversion H.
        intro.
        destruct (beq_name y z) eqn:?.
        apply beq_name_true_iff in Heqb0.
        auto.
        apply H2; auto.
  Qed.

  Lemma ch_2_in_range_in_domain : forall x y, x <> y -> in_range_in_domain (ch_2 x y).
  Proof.
    unfold in_range_in_domain.
    unfold in_range, in_domain, ch_2.
    intros.
    inversion_clear H0.
    destruct (beq_name x x1) eqn:?.
      inversion H1.
      destruct (beq_name x x0) eqn:?.
        intro; discriminate.

        rewrite beq_name_refl.
        intro; discriminate.

      destruct (beq_name x x0) eqn:?.
        intro; discriminate.

        destruct (beq_name y x0) eqn:?.
          intro; discriminate.

          destruct (beq_name y x1); discriminate.
  Qed.

  Lemma ch_2_prop_1 : forall n m, n <> m -> Fun_prop_1 (ch_2 n m).
  Proof.
    unfold Fun_prop_1.
    unfold ch_2.
    intros.
    destruct (beq_name n x) eqn:?.
      apply beq_name_true_iff in Heqb.
      rewrite <- Heqb.
      intro.
      inversion H0.
      auto.

      destruct (beq_name m x) eqn:?.
        intro.
        discriminate.
        intro.
        discriminate.
  Qed.

  Lemma ch_2_prop_2 : forall n m, Fun_prop_2 (ch_2 n m).
  Proof.
    unfold Fun_prop_2.
    unfold in_domain.
    unfold ch_2.
    intros.
    destruct (beq_name n x) eqn:?.
      apply beq_name_true_iff in Heqb.
      destruct (beq_name n y) eqn:?.
        apply beq_name_true_iff in Heqb0.
        rewrite <- Heqb.
        rewrite Heqb0.
        auto.

        destruct (beq_name m y) eqn:?.
          discriminate.
          discriminate.
      destruct (beq_name m x) eqn:?.
        apply beq_name_true_iff in Heqb0.
        destruct (beq_name n y) eqn:?.
          discriminate.
          destruct (beq_name m y) eqn:?.
            apply beq_name_true_iff in Heqb2.
            rewrite <- Heqb0.
            apply Heqb2.

            discriminate.
        inversion H; discriminate.
  Qed.

  Lemma ch_2_prop_3 : forall n m, n <> m -> Fun_prop_3(ch_2 n m).
  Proof.
    unfold Fun_prop_3.
    unfold in_domain.
    unfold ch_2.
    unfold fun_double.
    unfold to_star_function.
    intros.
    destruct (beq_name n x) eqn:?.
      apply beq_name_true_iff in Heqb.
      rewrite Heqb.
      rewrite beq_name_refl.
      destruct (beq_name x m) eqn:?.
        apply beq_name_true_iff in Heqb0.
        rewrite Heqb0 in Heqb.
        contradiction.

        auto.
      destruct (beq_name m x) eqn:?.
        auto.
        exfalso; apply H0; auto.
  Qed.

  Theorem ch_2_prop : forall n m, n <> m -> Fun_prop (ch_2 n m).
  Proof.
    split.
    apply ch_2_prop_1; auto.
    split.
    apply ch_2_prop_2.
    apply ch_2_prop_3; auto.
  Qed.

  Lemma fun_plus_prop_1 : forall f1 f2,
                            Fun_prop_1 f1 ->
                            Fun_prop_1 f2 ->
                            Fun_prop_1 (fun_plus f1 f2).
  Proof.
    unfold Fun_prop_1.
    unfold fun_plus.
    intros.
    destruct (f1 x) eqn:?.
      destruct s.
        rewrite <- Heqo.
        apply H.

        destruct (f2 x) eqn:?.
          rewrite <- Heqo0.
          apply H0.

          intro; discriminate.

        intro; discriminate.
      apply H0.
  Qed.

  Lemma fun_plus_prop_2 : forall f1 f2,
                            in_range_in_domain f1 ->
                            in_range_in_domain f2 ->
                            fun_exclusive f1 f2 ->
                            Fun_prop_2 f1 ->
                            Fun_prop_2 f2 ->
                            Fun_prop_2 (fun_plus f1 f2).
  Proof.
    unfold Fun_prop_2.
    unfold fun_exclusive.
    unfold in_domain.
    unfold fun_plus.
    intros.
    destruct (f1 x) eqn:?.
      destruct (f1 y) eqn:?.
        induction s.
          induction s0.
            apply H2.
              exists n; auto.
              exists n0; auto.
              rewrite Heqo; rewrite Heqo0; auto.
            destruct (f2 y) eqn:?.
              specialize (H1 y).
              inversion H1.
              rewrite Heqo0 in H7.
              rewrite Heqo1 in H7.
              assert (Some star_bottom <> None).
                intro; discriminate.
              apply H7 in H9.
              exfalso; apply H9; intro; discriminate.

              discriminate.
            discriminate.
          induction s0.
            destruct (f2 x) eqn:?.
              specialize (H1 x).
              inversion H1.
              rewrite Heqo in H7.
              rewrite Heqo1 in H7.
              assert (Some star_bottom <> None).
                intro; discriminate.
              apply H7 in H9.
              exfalso; apply H9; intro; discriminate.

              discriminate.
            destruct (f2 x) eqn:?.
              specialize (H1 x).
              inversion H1.
              rewrite Heqo in H7.
              rewrite Heqo1 in H7.
              assert (Some star_bottom <> None).
                intro; discriminate.
              apply H7 in H9.
              exfalso; apply H9; intro; discriminate.

              inversion H4; discriminate.
            inversion H5; discriminate.
          inversion H4; discriminate.

        induction s.
          symmetry in H6.
          unfold in_range_in_domain, in_range, in_domain in H.
          unfold in_range_in_domain, in_range, in_domain in H0.
          specialize (H n).
          specialize (H0 n).
          specialize (H1 n).
          inversion H1.
          assert (exists y : name, f1 y = Some (star_name n)).
            exists x; auto.
          assert (exists y : name, f2 y = Some (star_name n)).
            exists y; auto.
          apply H in H9.
          apply H0 in H10.
          apply H7 in H9.
          exfalso; apply H9; auto.

          destruct (f2 x) eqn:?.
            apply H3.
              rewrite Heqo1; auto.

              auto.

              rewrite Heqo1; auto.
            inversion H4; discriminate.

          inversion H4; discriminate.
      inversion H4; subst.
      rewrite H7 in H6.
      destruct (f1 y) eqn:?.
        destruct s.
          inversion H6; subst.
          unfold in_range_in_domain, in_range, in_domain in H.
          unfold in_range_in_domain, in_range, in_domain in H0.
          specialize (H n).
          specialize (H0 n).
          assert (exists y, f1 y = Some (star_name n)).
            exists y; auto.
          assert (exists y, f2 y = Some (star_name n)).
            exists x; auto.
          apply H in H8.
          apply H0 in H9.
          specialize (H1 n).
          inversion H1.
          apply H10 in H8.
          exfalso; apply H8; auto.

          destruct (f2 y) eqn:?.
            specialize (H1 y).
            inversion H1.
            assert (f1 y <> None).
              rewrite Heqo0; intro; discriminate.
            apply H8 in H10.
            exfalso; apply H10.
            rewrite Heqo1; intro; discriminate.

          discriminate.
        discriminate.

        apply H3.
          exists x0; auto.

          exists x0; rewrite H6; auto.

          rewrite H7; auto.
  Qed.

  Lemma fun_plus_prop_3 : forall f1 f2,
                            fun_exclusive f1 f2 ->
                            Fun_prop_3 f1 ->
                            Fun_prop_3 f2 ->
                            Fun_prop_3 (fun_plus f1 f2).
  Proof.
    unfold Fun_prop_3.
    unfold fun_exclusive.
    unfold fun_double.
    unfold to_star_function.
    unfold fun_plus.
    unfold in_domain.
    intros.
    destruct (f1 x) eqn:?.
      destruct s.
        destruct (f1 n) eqn:?.
          specialize (H0 x).
          assert (f1 x <> None).
            rewrite Heqo.
            intro; discriminate.
          apply H0 in H3.
          rewrite Heqo in H3.
          rewrite Heqo0 in H3.
          inversion H3.
          destruct (f2 n) eqn:?.
            specialize (H n).
            inversion H.
            assert (f1 n <> None).
              rewrite Heqo0; intro; discriminate.
            apply H4 in H7.
            exfalso; apply H7; intro.
            rewrite Heqo1 in H8; discriminate.

            auto.

          specialize (H0 x).
          assert (f1 x <> None).
            rewrite Heqo; intro; discriminate.
          apply H0 in H3.
          rewrite Heqo in H3.
          rewrite Heqo0 in H3; discriminate.

        destruct (f2 x) eqn:?.
          specialize (H x).
          inversion H.
          assert (f1 x <> None).
            rewrite Heqo; intro; discriminate.
          apply H3 in H5.
          exfalso; apply H5; intro.
          rewrite Heqo0 in H6; discriminate.

          auto.
        auto.
      destruct (f2 x) eqn:?.
        destruct s.
          destruct (f1 n) eqn:?.
            specialize (H1 x).
            assert (f2 x <> None).
              rewrite Heqo0; intro; discriminate.
            apply H1 in H3.
            rewrite Heqo0 in H3.
            specialize (H n).
            inversion H.
            assert (f1 n <> None).
              rewrite Heqo1; intro; discriminate.
            apply H4 in H6.
            exfalso; apply H6; intro.
            rewrite H3 in H7; discriminate.

            assert (f2 x <> None).
              rewrite Heqo0; intro; discriminate.
            apply H1 in H3.
            rewrite Heqo0 in H3.
            auto.
          auto.
          auto.
        exfalso; apply H2; auto.
  Qed.

  Theorem fun_plus_prop : forall f1 f2,
                            in_range_in_domain f1 ->
                            in_range_in_domain f2 ->
                            fun_exclusive f1 f2 ->
                            Fun_prop f1 ->
                            Fun_prop f2 ->
                            Fun_prop (fun_plus f1 f2).
  Proof.
    intros.
    inversion_clear H2.
    inversion_clear H5.
    inversion_clear H3.
    inversion_clear H7.
    unfold Fun_prop.
    split; try split.
    apply fun_plus_prop_1; auto.
    apply fun_plus_prop_2; auto.
    apply fun_plus_prop_3; auto.
  Qed.

  Lemma fun_prop_plus_fst : forall f1 f2,
                              Fun_prop (fun_plus f1 f2) ->
                              in_range_in_domain f1 ->
                              Fun_prop f1.
  Proof.
    intros f1 f2 H rd.
    inversion_clear H.
    inversion_clear H1.

    unfold Fun_prop.
    unfold Fun_prop_1 in H0.
    unfold Fun_prop_2 in H.
    unfold Fun_prop_3 in H2.

    split; try split.
      unfold Fun_prop_1.
      intros.
      intro.
      apply H0 with x.
      unfold fun_plus.
      rewrite H1; auto.

      unfold Fun_prop_2; intros.
      apply H.
        inversion_clear H1.
        exists x0.
        unfold fun_plus.
        rewrite H5; auto.

        inversion_clear H3.
        exists x0.
        unfold fun_plus.
        rewrite H5; auto.

        unfold fun_plus.
        destruct (f1 x); auto.
          destruct s; auto.
            destruct (f1 y); auto.
              destruct s; auto.
              inversion H4.
            inversion H4.
          destruct (f1 y); auto.
            destruct s; auto.
              discriminate.
              inversion H1; discriminate.
              inversion H1; discriminate.
            discriminate.
          inversion H1; discriminate.
          inversion H1; discriminate.

      unfold Fun_prop_3; intros.
      unfold fun_double.
      unfold to_star_function.

      unfold in_range_in_domain in rd.
      unfold in_range in rd.

      unfold fun_double in H2.
      unfold in_domain in H2, H1, rd.
      unfold to_star_function in H2.
      unfold fun_plus in H2.
      specialize H2 with x.
      destruct (f1 x) eqn:?; auto.
        destruct s; auto.
        destruct (f1 n) eqn:?; auto.
          destruct s; auto.
          specialize rd with n.
          assert (exists y, f1 y = Some (star_name n)).
            exists x; auto.
          apply rd in H3.
          easy.

          exfalso; apply H1; auto.
  Qed.

  Lemma compatible_split : forall f1 f2,
                             Compatible f1 f2 ->
                             in_range_in_domain f1 ->
                             in_range_in_domain f2 ->
                             Fun_prop f1 /\ Fun_prop f2.
  Proof.
    assert (forall f1 f2, Fun_prop (fun_plus f1 f2) -> in_range_in_domain f1 -> Fun_prop f1).
    intros f1 f2 H rd.
    inversion_clear H.
    inversion_clear H1.

    unfold Fun_prop.
    unfold Fun_prop_1 in H0.
    unfold Fun_prop_2 in H.
    unfold Fun_prop_3 in H2.

    split; try split.
      unfold Fun_prop_1.
      intros.
      intro.
      apply H0 with x.
      unfold fun_plus.
      rewrite H1; auto.

      unfold Fun_prop_2; intros.
      apply H.
        inversion_clear H1.
        exists x0.
        unfold fun_plus.
        rewrite H5; auto.

        inversion_clear H3.
        exists x0.
        unfold fun_plus.
        rewrite H5; auto.

        unfold fun_plus.
        destruct (f1 x); auto.
          destruct s; auto.
            destruct (f1 y); auto.
              destruct s; auto.
              inversion H4.
            inversion H4.
          destruct (f1 y); auto.
            destruct s; auto.
              discriminate.
              inversion H1; discriminate.
              inversion H1; discriminate.
            discriminate.
          inversion H1; discriminate.
          inversion H1; discriminate.

      unfold Fun_prop_3; intros.
      unfold fun_double.
      unfold to_star_function.

      unfold in_range_in_domain in rd.
      unfold in_range in rd.

      unfold fun_double in H2.
      unfold in_domain in H2, H1, rd.
      unfold to_star_function in H2.
      unfold fun_plus in H2.
      specialize H2 with x.
      destruct (f1 x) eqn:?; auto.
        destruct s; auto.
        destruct (f1 n) eqn:?; auto.
          destruct s; auto.
          specialize rd with n.
          assert (exists y, f1 y = Some (star_name n)).
            exists x; auto.
          apply rd in H3.
          easy.

          exfalso; apply H1; auto.

  intros.
  inversion H0 as [c p].
  split.
    apply H with f2; auto.
    unfold Fun_comm in c.
    rewrite c in p.
    apply H with f1; auto.
Qed.

  Theorem fun_plus_compatible : forall f f1 f2,
                                  in_range_in_domain f ->
                                  in_range_in_domain f1 ->
                                  in_range_in_domain f2 ->
                                  Compatible f (fun_plus f1 f2) ->
                                  Compatible f1 f2 ->
                                  Mutually_compatible (f :: f1 :: f2 :: nil).
  Proof.
    intros.
    simpl.
    inversion_clear H2 as [c0 p0].
    inversion_clear H3 as [c1 p1].
    unfold Fun_comm in c0.
    unfold Fun_comm in c1.
    subst.
    assert (Fun_comm f f1).
      unfold Fun_comm.
      apply functional_extensionality; intros.
      apply equal_f with x in c1.
      apply equal_f with x in c0.
      unfold fun_plus.
      unfold fun_plus in c1, c0.
      destruct (f x); auto.
        destruct s; auto; destruct (f1 x); auto; destruct s; auto.
        destruct (f1 x); auto; destruct s; auto.
    assert (Fun_comm f f2).
      rewrite c1 in c0.
      symmetry in c1.
      unfold Fun_comm.
      apply functional_extensionality; intros.
      apply equal_f with x in c1.
      apply equal_f with x in c0.
      unfold fun_plus.
      unfold fun_plus in c1, c0.
      destruct (f x); auto.
        destruct s; auto; destruct (f2 x); auto; destruct s; auto.
        destruct (f2 x); auto; destruct s; auto.
    split; try (split; try (split; try (split; try split))).
      apply Forall_cons; auto.
        apply Build_compatible; auto.
        rewrite fun_plus_assoc in p0.
        apply fun_prop_plus_fst in p0; auto.
        apply fun_plus_in_range_in_domain; auto.

        apply Forall_cons; auto.
        apply Build_compatible; auto.
        rewrite c1 in p0.
        rewrite fun_plus_assoc in p0.
        apply fun_prop_plus_fst in p0; auto.
        apply fun_plus_in_range_in_domain; auto.
      apply Forall_cons; auto.
      apply Build_compatible; auto.

      auto.
  Qed.

  Lemma fun_remove_prop_1 : forall f x,
                              Fun_prop_1 f ->
                              Fun_prop_1 (fun_remove f x).
  Proof.
    unfold Fun_prop_1.
    unfold fun_remove.
    intros.
    destruct (beq_name x0 x) eqn:?.
      intro; discriminate.

      apply beq_name_false_iff in Heqb.
      destruct (f x0) eqn:?.
        destruct s.
          destruct (beq_name n x) eqn:?.
            intro; discriminate.

            specialize (H x0).
            rewrite Heqo in H.
            auto.
          intro; discriminate.
          intro; discriminate.
        intro; discriminate.
  Qed.

  Lemma fun_remove_prop_2 : forall f n,
                              Fun_prop_2 f ->
                              Fun_prop_2 (fun_remove f n).
  Proof.
    unfold Fun_prop_2.
    unfold fun_remove.
    intros.
    destruct (beq_name x n) eqn:?.
      inversion H0; discriminate.

      destruct (beq_name y n) eqn:?.
        inversion H1; discriminate.

        destruct (f x) eqn:?.
          destruct s.
            destruct (beq_name n0 n) eqn:?.
              inversion H0; discriminate.

              destruct (f y) eqn:?.
                destruct s.
                  destruct (beq_name n1 n) eqn:?.
                    inversion H1; discriminate.

                    inversion H2.
                    apply H.
                      exists n0; auto.

                      exists n1; auto.

                      rewrite Heqo.
                      rewrite Heqo0.
                      rewrite H4; auto.
                  discriminate.

                  discriminate.
                discriminate.
            inversion H0; discriminate.

            inversion H0; discriminate.
          inversion H0; discriminate.
  Qed.

  Lemma fun_remove_prop_3 : forall f n,
                              Fun_prop_3 f ->
                              Fun_prop_3 (fun_remove f n).
  Proof.
    unfold Fun_prop_3.
    unfold fun_remove, fun_double, in_domain, to_star_function.
    intros.
    assert (forall o, (exists (x : Type), o = Some x) -> o <> None).
      intros.
      inversion H1.
      rewrite H2; intro; discriminate.
    destruct (beq_name x n) eqn:?.
      contradict H0; auto.

      destruct (f x) eqn:?.
        destruct s.
          destruct (beq_name n0 n) eqn:?.
            auto.

            rewrite Heqb0.
            rewrite <- Heqo in H0.
            apply H in H0.
            rewrite Heqo in H0.
            rewrite H0.
            auto.
          auto.
          auto.
        contradiction H0; auto.
  Qed.
End Fun.