(* Project files imports *)
Require Import MyLists.
Require Import Sequent_Calculus.
Require Import Basic_Properties.

(* Other imports *)
From Coq Require Import Arith.Arith.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
Import ListNotations.
Import Wf_nat.

Theorem cut_lolli :
  forall (A B : formula),
    (forall (n m : nat) (C : formula)
            (Gamma Delta1 Delta2 : list formula),
        (n; Gamma |- A) ->
        (m; Delta1 ++ [A] ++ Delta2 |- C) ->
        exists z : nat,
          (z; Gamma ++ Delta1 ++ Delta2 |- C))
    ->
    (forall (n m : nat) (C : formula)
            (Gamma Delta1 Delta2 : list formula),
        (n; Gamma |- B) ->
        (m; Delta1 ++ [B] ++ Delta2 |- C) ->
        exists z : nat,
          (z; Gamma ++ Delta1 ++ Delta2 |- C))
    ->
    forall (n m : nat)
           (C: formula)
           (Gamma Delta1 Delta2 : list formula),
      (n; Gamma |- (A -o B))
      ->
      (m; Delta1 ++ [A -o B] ++ Delta2 |- C)
      -> exists z, z; (Gamma ++ Delta1 ++ Delta2) |- C.
Proof.
  intros A B IHA1 IHA2 n m.
  (* We start induction on depth of proof *)
  (* This is necessary for Commuting Conversions *)
  remember (n + m) as l.
  generalize dependent m.
  generalize dependent n.
  induction (lt_wf l) as [l _ IHl].

  intros n m sum C Gamma Delta1 Delta2 LH.
  remember (A -o B) as cutF.

  (* By cases on LH *)
  destruct LH.

  (* LH = OneL *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1 n m eq2
                    C Gamma Delta1 Delta2 LH RH).
    clear eq1. clear eq2. clear RH. clear LH.

    destruct IHl as [z Hyp].
    exists (S z).
    simpl in *.
    constructor; auto.

  (* LH = OneR *)
  * discriminate.

  (* LH = Axiom *)
  * intros RH.
    subst. clear IHA1. clear IHA2.
    assert (RH' : m; [] ++ Delta1 ++ [A -o B]
                       ++ Delta2 |- C)
      by auto.
    apply exchange_with_env_l in RH'.
    exists (m + length Delta1).
    assumption.

  (* LH = TensorL *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1 n m eq2
                    C (A0::B0::env)
                    Delta1 Delta2 LH RH).
    clear eq1. clear eq2. clear RH. clear LH.

    destruct IHl as [z Hyp].
    exists (S z).
    simpl in *.
    constructor; auto.

    (* LH = TensorR *)
  * discriminate.

  (* LH is LolliL *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1
                    n m  eq2
                    C
                    (B0 :: env2)
                    Delta1 Delta2 LH2 RH
               ).
    clear eq1. clear eq2. clear RH. clear LH2.
    destruct IHl as [z IHl].

    assert (z; B0:: env2 ++ Delta1
                 ++ Delta2 |- C) by auto.
    apply (level_depth
             n env1 A0
             z (B0::env2 ++ Delta1 ++ Delta2) C
             LH1) in H.
    clear LH1. destruct H as [k [H1 H2]].

    apply (LolliL k env1 A0
                   (env2 ++ Delta1 ++ Delta2) B0 C
                   H1) in H2.

    exists (S k).
    assert (eq: S k;
            ([A0 -o B0] ++ env1 ++ env2)
              ++ Delta1 ++ Delta2  |- C)
      by (repeat rewrite <- app_assoc in *; auto).
    auto.

  (* LH is LolliR *)
  * intros RH.
    subst.
    remember (Delta1 ++ [A0 -o B0] ++ Delta2) as CF.
    inversion HeqCF as [backup].
    assert(Premise: n; A0 :: env |- B0) by auto.
    apply (LolliR n env A0 B0) in LH.

    {
      destruct RH.

      (* RH is OneL *)
      - apply element_in_app_head in HeqCF.

        destruct HeqCF as [Left | Right].

        * destruct Left as [t1 [t2 t3]].
          discriminate.

        * destruct Right as [l H].
          inversion HeqcutF.
          subst.
          clear HeqcutF. clear IHA1. clear IHA2.
          assert (eq: (One :: l) ++ [A -o B] ++ Delta2 =
                      Delta1 ++ A -o B :: Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst. clear backup.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          specialize (IHl (S n + n0) eq1 (S n) n0 eq2
                    A1 env l Delta2 LH RH).
          clear eq1. clear eq2. clear RH. clear LH.

          destruct IHl as [z H].
          apply OneL in H.
          assert (eq: S z; [] ++ [One] ++ env ++ l
                              ++ Delta2 |- A1)
            by auto.
          apply exchange_with_env_r in eq.
          assert (Hyp:
                    (S z + length env);
                  env ++ ([One] ++ l)
                      ++ Delta2 |- A1) by auto.

          exists (S z + length env); auto.

      (* RH is OneR *)
      - simpl in *.
        apply app_cons_not_nil in HeqCF.
        destruct HeqCF.

      (* RH is Atom *)
      - inversion HeqcutF.
        subst. clear HeqcutF. clear IHA1. clear IHA2.
        apply element_in_app_head in HeqCF.

        destruct HeqCF as [Left | Right].

        * destruct Left as [t1 [t2 t3]].
          subst.
          exists (S n).
          rewrite app_nil_r; auto.

        * destruct Right as [l H].
          apply app_cons_not_nil in H.
          destruct H.

      (* RH is TensorL *)
      - apply element_in_app_head in HeqCF.

        destruct HeqCF as [Left | Right].

        * destruct Left as [t1 [t2 t3]].
          discriminate.

        * destruct Right as [l H].
          subst.
          assert (eq: (A1 ** B1 :: l)
                        ++ [A0 -o B0] ++ Delta2 =
                      Delta1 ++ [A0 -o B0] ++ Delta2)
            by auto.
          apply app_inv_tail in eq.
          inversion HeqcutF.
          subst. clear backup.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          specialize (IHl (S n + n0) eq1 (S n) n0 eq2
                          C env
                          (A1::B1::l)
                          Delta2 LH RH).
          clear eq1. clear eq2. clear RH. clear LH.

          destruct IHl as [z H].

          rewrite app_assoc in H.
          apply exchange_subset in H.
          destruct H as [m [ _ H]].

          assert( eq: m;
                  [A1] ++ [B1]
                       ++ l ++ env ++ Delta2 |- C)
            by (repeat rewrite <- app_assoc in *; auto).
          simpl in eq.

          apply (TensorL m (l ++ env ++ Delta2) A1 B1 C)
            in eq.

          assert (eq': S m;
                  ((A1 ** B1 :: l) ++ env)
                    ++ Delta2 |- C)
            by (repeat rewrite <- app_assoc in *; auto).

          apply exchange_subset in eq'.
          destruct eq' as [k [ _ Final]].
          rewrite <- app_assoc in Final.

          exists k; auto.

      (* RH is TensorR *)
      - (* cleaning *)
        clear IHA1. clear IHA2.
        inversion HeqcutF.
        subst. clear HeqcutF.

        (* some pre-processing of IHl *)
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1 (S n) n0 eq2).
        clear eq1. clear eq2.

        (* We go by cases, since A1 -o A2 could be in RH1 or RH2 *)
        apply element_in_app in HeqCF.
        {
          destruct HeqCF as [inEnv1 | inEnv2].

          (* on the left *)
          - destruct inEnv1 as [t1 [t2 [l t3]]].
            subst. clear t1. clear t2.

            (* one more infere&substitute *)
            assert (eq: (Delta1 ++ [A -o B]) ++ (l ++ env2) =
                        (Delta1 ++ [A -o B]) ++ Delta2).
            { repeat rewrite <- app_assoc in *. auto. }
            apply app_inv_head in eq. subst. clear backup.

            specialize (IHl A1 env Delta1 l LH RH1).
            clear LH. clear RH1.
            destruct IHl as [z LH].

            apply (level_depth z (env ++ Delta1 ++ l) A1
                               n0 env2 B1 LH) in RH2.
            clear LH.
            destruct RH2 as [k [LH RH]].

            exists (S k).
            rewrite app_assoc.
            rewrite app_assoc.
            constructor; [rewrite <- app_assoc; auto | auto].

          (* on the right *)
          - destruct inEnv2 as [t1 [t2 [l t3]]].
            subst. clear t1. clear t2.

            (* one more infere&substitute *)
            assert (eq: (env1 ++ l) ++ ([A -o B] ++ Delta2) =
                        Delta1 ++ (A -o B :: Delta2))
              by (repeat rewrite <- app_assoc in *; auto).
            apply app_inv_tail in eq. subst.
            clear backup.

            specialize (IHl B1 env l Delta2 LH RH2).
            clear LH. clear RH2.
            destruct IHl as [z LH].

            apply (level_depth z (env ++ l ++ Delta2) B1
                               n0 env1 A1 LH) in RH1.
            clear LH.
            destruct RH1 as [k [RH LH]].

            pose proof (TensorR k env1 A1 (env ++ l ++ Delta2) B1
                                LH RH).
            assert (eq: S k; (env1 ++ env) ++ l ++ Delta2
                           |- (A1 ** B1))
              by (rewrite <- app_assoc; auto ).
            apply exchange_subset in eq.
            destruct eq as [m [temp final]]. clear temp.
            exists m.
            repeat rewrite <- app_assoc in *; auto.
        }

        (* RH is LolliL *)
      - inversion HeqcutF.
        subst.
        (* we need to proceed by cases *)
        assert (eq: (A1 -o B1 :: env1) ++ env2 =
                    Delta1 ++ [A -o B] ++ Delta2) by auto.
        apply element_in_app in eq.
        {
          destruct eq as [inLeft | inRight].

          (* on the left *)
          - destruct inLeft as [t1 [t2 [l t3]]]. clear t1. clear t2.

            (* we have two more cases: reduce or commute *)
            assert (eq: [A1 -o B1] ++ env1 =
                        Delta1 ++ [A -o B] ++ l) by auto.
            apply element_in_app in eq.

            {
              destruct eq as [reduction | commute].

              (* reduction case *)
              - destruct reduction as [_ [_ [l' t]]].
              apply app_singleton in t.
              destruct t as [t1 [t2 t4]].
              inversion t4.
              subst. clear t4.
              inversion t3.
              subst.
              inversion backup.
              subst. clear backup. clear HeqCF.
              clear HeqcutF. clear LH.
              clear t3. clear IHl.

              assert (LH: n; [] ++ A :: env |- B) by auto.
              apply (IHA1 n0 n B l [] env RH1) in LH.
              destruct LH as [z LH].
              simpl in LH.

              assert (RH: n0; [] ++ B :: env2 |- C) by auto.
              apply (IHA2 z n0 C (l ++ env)
                          [] env2 LH) in RH.
              destruct RH as [z' H].
              simpl in *.
              apply exchange_subset in H.
              destruct H as [m [ _ H]].
              rewrite app_assoc.
              exists m; auto.

              (* commute case *)
              - destruct commute as [t1 [t2 [l' t4]]].
                clear t1. clear t2. clear IHA1. clear IHA2.

                (* some substitutions *)
                subst.
                assert (eq: (A1 -o B1 :: l') ++ ([A -o B] ++ l) =
                            Delta1 ++ ([A -o B] ++ l)) by auto.
                apply app_inv_tail in eq.
                subst. clear t3.
                assert (eq: ([A1 -o B1] ++ l' ++ [A -o B]) ++ l ++
                                 env2 =
                            ([A1 -o B1] ++ l' ++ [A -o B])
                              ++ Delta2).
                { repeat rewrite <- app_assoc in *. auto. }
                apply app_inv_head in eq.
                subst.
                clear backup. clear Premise. clear HeqCF.

                assert (eq1: S n + n0 < S n + S n0) by omega.
                assert (eq2: S n + n0 = S n + n0) by omega.
                specialize (IHl (S n + n0) eq1
                                (S n) n0 eq2
                                A1 env l' l LH RH1).
                clear eq1. clear eq2. clear LH. clear RH1.
                destruct IHl as [z Last].

                apply (level_depth z (env ++ l' ++ l) A1
                                   n0 (B1::env2) C Last) in RH2.

                destruct RH2 as [k [First Second]].
                pose proof (LolliL k (env ++ l' ++ l)
                                   A1
                                   env2 B1 C First Second).

                assert(eq: S k; [] ++ [A1 -o B1] ++ env
                                   ++ l' ++ l ++ env2 |- C).
                { simpl in *. repeat rewrite <- app_assoc in *.
                  auto. }

                apply exchange_with_env_r in eq.

                exists (S k + length env); auto.
            }

          (* on the right *)
          - destruct inRight as [t1 [t2 [l t3]]].
            clear t1. clear t2. clear IHA1. clear IHA2.

            (* first some subst, to simplify *)
            subst.
            assert (eq: (A1 -o B1 :: env1 ++ l) ++
                                              (A -o B :: Delta2)
                        =
                        Delta1 ++ (A -o B :: Delta2)).
            { simpl in *.
              repeat rewrite <- app_assoc in *. auto. }
            apply app_inv_tail in eq.
            subst.
            clear backup. clear HeqCF. clear HeqcutF.

            assert (eq1: S n + n0 < S n + S n0) by omega.
            assert (eq2: S n + n0 = S n + n0) by omega.
            specialize (IHl (S n + n0) eq1
                            (S n) n0 eq2
                            C env (B1::l) Delta2 LH RH2).
            clear eq1. clear eq2. clear LH. clear RH2.
            destruct IHl as [z Last].

            assert (eq1: z; [] ++ env ++ [B1] ++ l ++ Delta2 |- C)
              by auto.

            apply exchange_with_env_l in eq1.
            simpl in eq1.
            apply (level_depth
                     (z + length env) (B1 :: env ++ l ++ Delta2) C
                     n0 env1 A1 eq1) in RH1.
            clear eq1. clear Last.

            destruct RH1 as [k [RH LH]].

            pose proof (LolliL k env1 A1
                               (env ++ l ++ Delta2) B1 C
                               LH RH).

            assert (eq1: S k; (([A1 -o B1] ++ env1)
                                 ++ env) ++ l ++ Delta2
                              |- C).
            { repeat rewrite <- app_assoc in *.
              simpl. auto. }

            apply exchange_subset in eq1.
            destruct eq1 as [m [temp Final]].

            exists m.

            assert (eq1:  m; env ++ ([A1 -o B1] ++ env1 ++ l)
                                 ++ Delta2 |- C).
            { repeat rewrite <- app_assoc in *. auto. }

            simpl in *; auto.
        }

      (* RH is LolliR *)
      - inversion HeqcutF.
        subst. clear HeqcutF.
        clear IHA1. clear IHA2. clear Premise.

        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1
                        (S n) n0 eq2
                        B1 env (A1:: Delta1) Delta2 LH RH).
        clear eq1. clear eq2. clear LH. clear RH.
        destruct IHl as [z Last].

        assert (eq: z; [] ++ env ++ [A1] ++ Delta1 ++ Delta2 |- B1)
          by auto.

        apply exchange_with_env_l in eq.
        simpl in eq.
        apply (LolliR (z + length env) (env ++ Delta1 ++ Delta2)
                      A1 B1) in  eq.

        exists (S (z + length env)).
        auto.

      (* RH is WithL1 *)
      - inversion HeqcutF.
        subst. clear HeqcutF.
        apply element_in_app_head in backup.
        destruct backup as [Left | Right].

        * destruct Left as [t1 [t2 t3]].
          subst. discriminate.

        * destruct Right as [l t].
          subst.
          clear IHA1. clear IHA2.

          assert (eq: (A1 & B1 :: l) ++ [A -o B] ++ Delta2 =
                      Delta1 ++ [A -o B] ++ Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst. clear HeqCF. clear Premise.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          apply (IHl (S n + n0) eq1
                          (S n) n0 eq2
                          C env (A1::l) Delta2 LH) in RH.
          clear eq1. clear eq2. clear LH.
          destruct RH as [z Last].

          rewrite app_assoc in Last.
          apply exchange_subset in Last.
          destruct Last as [m [_ Last]].
          rewrite <- app_assoc in Last.
          simpl in *.
          apply (WithL1 m (l ++ env ++Delta2) A1 B1 C) in Last.

          assert (eq: S m;
                  ((A1 & B1 :: l) ++ env) ++ Delta2 |- C)
            by (repeat rewrite <- app_assoc in *; auto).
          apply exchange_subset in eq.
          destruct eq as [m' [_ eq]].
          rewrite <- app_assoc in *.
          simpl in *.
          exists m'; auto.

      (* RH is WithL2 *)
      - inversion HeqcutF.
        subst. clear HeqcutF.
        apply element_in_app_head in backup.
        destruct backup as [Left | Right].

        * destruct Left as [t1 [t2 t3]].
          subst. discriminate.

        * destruct Right as [l t].
          subst.
          clear IHA1. clear IHA2.

          assert (eq: (A1 & B1 :: l) ++ [A -o B] ++ Delta2 =
                      Delta1 ++ [A -o B] ++ Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst. clear HeqCF. clear Premise.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          apply (IHl (S n + n0) eq1
                          (S n) n0 eq2
                          C env (B1::l) Delta2 LH) in RH.
          clear eq1. clear eq2. clear LH.
          destruct RH as [z Last].

          rewrite app_assoc in Last.
          apply exchange_subset in Last.
          destruct Last as [m [_ Last]].
          rewrite <- app_assoc in Last.
          simpl in *.
          apply (WithL2 m (l ++ env ++Delta2) A1 B1 C) in Last.

          assert (eq: S m;
                  ((A1 & B1 :: l) ++ env) ++ Delta2 |- C)
            by (repeat rewrite <- app_assoc in *; auto).
          apply exchange_subset in eq.
          destruct eq as [m' [_ eq]].
          rewrite <- app_assoc in *.
          simpl in *.
          exists m'; auto.

      (* RH is WithR *)
      - subst.
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        apply (IHl (S n + n0) eq1 (S n) n0 eq2
                   A1 env Delta1 Delta2 LH) in RH1.
        apply (IHl (S n + n0) eq1 (S n) n0 eq2
                   B1 env Delta1 Delta2 LH) in RH2.
        destruct RH1 as [z1 RH1].
        destruct RH2 as [z2 RH2].

        apply (level_depth
                 z1 (env ++ Delta1 ++ Delta2) A1
                 z2 (env ++ Delta1 ++ Delta2) B1 RH1) in RH2.
        destruct RH2 as [k [H1 H2]].
        apply (WithR k (env ++ Delta1 ++ Delta2) A1 B1 H1) in H2.

        exists (S k); auto.

      (* RH is OplusL *)
      - inversion HeqcutF.
        subst.
        apply element_in_app_head in backup.
        destruct backup as [L | R].

        * destruct L as [L1 [L2 L3]].
          discriminate.

        * destruct R as [l R].
          subst.
          assert (eq: (A1 # B1 :: l)
                        ++ [A -o B] ++ Delta2 =
                      Delta1 ++ [A -o B] ++ Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst.
          clear HeqCF. clear HeqcutF. clear Premise.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          assert (RH1': n0; (A1 :: l) ++ [A -o B] ++ Delta2
                            |- C) by auto.
          assert (RH2': n0; (B1 :: l) ++ [A -o B] ++ Delta2
                            |- C) by auto.
          apply (IHl (S n + n0) eq1 (S n) n0 eq2
                     C env (A1::l) Delta2 LH) in RH1'.
          apply (IHl (S n + n0) eq1 (S n) n0 eq2
                     C env (B1::l) Delta2 LH) in RH2'.
          destruct RH1' as [z1 RH1'].
          destruct RH2' as [z2 RH2'].

          clear RH1. clear RH2.
          rewrite app_assoc in RH1'.
          rewrite app_assoc in RH2'.
          apply exchange_subset in RH1'.
          destruct RH1' as [m1 [ _ RH1]].
          apply exchange_subset in RH2'.
          destruct RH2' as [m2 [ _ RH2]].
          rewrite <- app_assoc in *.
          simpl in *.

          apply (level_depth
                   m1 (A1::l ++ env ++ Delta2) C
                   m2 (B1::l ++ env ++ Delta2) C RH1)
            in RH2.
          destruct RH2 as [k [H1 H2]].
          apply (OplusL k (l ++ env ++ Delta2)
                        A1 B1 C H1) in H2.
          assert (eq: S k;
                  (A1 # B1 :: l) ++ env ++ Delta2
                  |- C) by auto.
          rewrite app_assoc in eq.
          apply exchange_subset in eq.
          destruct eq as [m [ _ H]].
          rewrite <- app_assoc in H.
          simpl in *.
          exists m; auto.

      (* RH is OplusR1 *)
      - subst.
        clear Premise.

        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        apply (IHl (S n + n0) eq1 (S n) n0 eq2
                   A1 env Delta1 Delta2 LH) in RH.
        clear eq1. clear eq2.

        destruct RH as [z H].
        exists (S z).
        constructor; auto.

      (* RH is OplusR2 *)
      - subst.
        clear Premise.

        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        apply (IHl (S n + n0) eq1 (S n) n0 eq2
                   B1 env Delta1 Delta2 LH) in RH.
        clear eq1. clear eq2.

        destruct RH as [z H].
        exists (S z).
        apply (OplusR2 z (env ++ Delta1 ++ Delta2) A1 B1)
          in H; auto.

      (* RH is Perm *)
      - subst. clear HeqcutF.
        clear IHA1. clear IHA2. clear Premise.

        apply elements_in_app in HeqCF.

        {
          destruct HeqCF as [First | Remaining].

          (* First case *)
          - (* first some substitutions *)
            destruct First as [temp1 [l eq1]].
            subst.
            assert (eq1:
                      (Delta1 ++ [A0 -o B0])
                        ++ (l ++ [B1] ++ [A1] ++ Delta) =
                      (Delta1 ++ [A0 -o B0]) ++ Delta2).
            { repeat rewrite <- app_assoc in *. auto. }
            apply app_inv_head in eq1.
            subst. clear temp1. clear backup.

            repeat rewrite <- app_assoc in *.
            assert (eq1: S n + n0 < S n + S n0) by omega.
            assert (eq2: S n + n0 = S n + n0) by omega.

            specialize (IHl (S n + n0) eq1
                            (S n) n0 eq2
                            C env Delta1
                            (l ++ [A1] ++ [B1] ++ Delta)
                            LH RH).
            clear eq1. clear eq2. clear LH. clear RH.
            destruct IHl as [z Last].

            assert (eq1:
                      z;
                    (env ++ Delta1 ++ l)
                      ++ [A1] ++ [B1] ++ Delta
                    |- C).
            { repeat rewrite <- app_assoc in *. auto. }

            apply (Perm z (env ++ Delta1 ++ l) Delta
                        A1 B1 C) in eq1.

            repeat rewrite <- app_assoc in *.

            exists (S z).
            auto.

          - (* other cases *)
            destruct Remaining as [Current | Remaining].

            (* Second Case *)
            + destruct Current as [temp1 [eq1 eq2]].
              subst. clear backup.

            assert (eq1: S n + n0 < S n + S n0) by omega.
            assert (eq2: S n + n0 = S n + n0) by omega.
            assert (RH': n0; (Delta1 ++ [A1])
                               ++ [A0 -o B0] ++ Delta |- C)
                   by (repeat rewrite <- app_assoc in *; auto).

            specialize (IHl (S n + n0) eq1
                            (S n) n0 eq2
                            C env (Delta1 ++ [A1])
                            Delta
                            LH RH').
            clear eq1. clear eq2. clear LH. clear RH. clear RH'.
            destruct IHl as [z Last].

            exists z.
            repeat rewrite <- app_assoc in *; auto.

            (* other cases *)
            + destruct Remaining as [Current | Final].

              (* Third Case *)
              * destruct Current as [temp1 [eq1 eq2]].
                subst. clear backup.
                assert (eq1: S n + n0 < S n + S n0) by omega.
                assert (eq2: S n + n0 = S n + n0) by omega.

                specialize (IHl (S n + n0) eq1
                                (S n) n0 eq2
                                C env Gamma
                                ([B1] ++ Delta2)
                                LH RH).
                clear eq1. clear eq2. clear LH. clear RH.
                destruct IHl as [z Last].

                exists z.
                repeat rewrite <- app_assoc in *; auto.

              (* Fourth Case *)
              * (* some substs first *)
                destruct Final as [temp1 [l eq1]].
                subst.

                assert (eq1:
                          (Gamma ++ B1 :: A1 :: l)
                                ++ ([A0 -o B0] ++ Delta2) =
                          Delta1 ++ (A0 -o B0 :: Delta2))
                  by (repeat rewrite <- app_assoc in *; auto).

                apply app_inv_tail in eq1.
                subst. clear backup. clear temp1.

                repeat rewrite <- app_assoc in *.
                assert (eq1: S n + n0 < S n + S n0) by omega.
                assert (eq2: S n + n0 = S n + n0) by omega.
                assert (RH': n0;
                        (Gamma ++ [A1] ++ [B1] ++ l)
                          ++ [A0 -o B0] ++ Delta2 |- C)
                  by (repeat rewrite <- app_assoc in *; auto).

                specialize (IHl (S n + n0) eq1
                                (S n) n0 eq2
                                C env
                                (Gamma ++ [A1] ++ [B1] ++ l)
                                Delta2
                                LH RH').
                clear eq1. clear eq2. clear LH.
                clear RH. clear RH'.
                destruct IHl as [z Last].

                assert (eq1:
                          z;
                        (env ++ Gamma)
                          ++ [A1] ++ [B1] ++ l ++ Delta2
                    |- C).
            { repeat rewrite <- app_assoc in *. auto. }

            apply (Perm z (env ++ Gamma) (l ++ Delta2)
                        A1 B1 C) in eq1.

            repeat rewrite <- app_assoc in *.

            exists (S z).
            auto.
        }
    }

  (* LH is WithL1 *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1
                    n m  eq2
                    C
                    (A0 :: Gamma)
                    Delta1 Delta2 LH RH
               ).
    clear eq1. clear eq2. clear RH. clear LH.
    destruct IHl as [z IHl].

    assert (eq: z; A0:: Gamma ++ Delta1
                 ++ Delta2 |- C) by auto.

    apply (WithL1 z (Gamma ++ Delta1 ++ Delta2)
                   A0 B0 C)
      in eq.

    exists (S z).
    assert (H: S z;
            ([A0 & B0] ++ Gamma)
              ++ Delta1 ++ Delta2 |- C) by auto.
    auto.

  (* LH is WithL2 *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1
                    n m  eq2
                    C
                    (B0 :: Gamma)
                    Delta1 Delta2 LH RH
               ).
    clear eq1. clear eq2. clear RH. clear LH.
    destruct IHl as [z IHl].

    assert (eq: z; B0:: Gamma ++ Delta1
                 ++ Delta2 |- C) by auto.

    apply (WithL2 z (Gamma ++ Delta1 ++ Delta2)
                   A0 B0 C)
      in eq.

    exists (S z). auto.

  (* LH is WithR *)
  * discriminate.

  (* LH is OplisL *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    assert (RH': m; Delta1 ++ [A -o B] ++ Delta2 |- C)
           by auto.
    apply (IHl (n + m) eq1
                    n m  eq2
                    C
                    (A0 :: Gamma)
                    Delta1 Delta2 LH1) in RH.
    apply (IHl (n + m) eq1
                    n m  eq2
                    C
                    (B0 :: Gamma)
                    Delta1 Delta2 LH2) in RH'.
    clear eq1. clear eq2. clear LH1. clear LH2.
    destruct RH as [z RH].
    destruct RH' as [z' RH'].

    assert (H1: z; A0 :: Gamma
                     ++ Delta1 ++ Delta2 |- C)
      by auto.
    assert (H2: z'; B0 :: Gamma
                     ++ Delta1 ++ Delta2 |- C)
      by auto.

    apply (level_depth
             z (A0 :: Gamma ++ Delta1 ++ Delta2) C
             z' (B0 :: Gamma ++ Delta1 ++ Delta2) C
             H1) in H2.
    destruct H2 as [k [H H']].

    apply (OplusL k (Gamma ++ Delta1 ++ Delta2)
                  A0 B0 C H) in H'.

    exists (S k).
    auto.

  (* LH is OplusR1 *)
  * discriminate.

  (* LH is OplusR2 *)
  * discriminate.

  (* LH is Perm *)
  * intros.
    clear IHA1. clear IHA2.
    assert (eq1: n + m < l) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1 n m eq2
                    C (Gamma ++ [A0] ++ [B0] ++ Delta)
                    Delta1 Delta2
                    LH
                    H
               ).
    destruct IHl as [z Hyp].
    exists (S z).
    repeat rewrite <- app_assoc in *.
    constructor; auto.
Qed.


Require Import
  List Coq.Vectors.Fin
  Arith.Compare_dec Lia
  Program
  .
Import ListNotations.
From CasperCBC
  Require Import
    Preamble
    VLSM.Common
    .

(** * VLSM Equivocation

An [equivocator_vlsm] for a given [VLSM] <<X>> is a VLSM which
- starts as a regular machine X
- can equivocate any of its current copies by duplicating it.
- can start a new machine in a (potentially) different initial state.
- can perform [valid] [transition]s using any of the internal machines

The state of such a machine will be abstracted using

1. A [nat]ural <<n>>, stating the number of copies of the original machine
2. A state of <<X>> for each 1..n+1

To preserve determinism we need to update the labels to indicate what copy
of the machine will be used for a transition.
To achieve this, we'll extend the labels of <<X>>, say <<L_X>> as follows

[L = <<L_X>> x MachineDescriptor]

The second component of the label tells which internal machine should be
used for performing the transition. It can be one of the following:
- [NewMachine <<s>>] where <<s>> is an state of <<X>>, will
  extend the state with a new machine initialized with <<s>>
  and will perform the transition on that machine.
- [Existing <<i>> <<is_equiv>>] perform transition on internal machine <<i>>
  but may equivocate, depending on the <<is_equiv>> as follows:

  - if <<is_equiv>> is [false], update the state of machine <<i>>
  - if <<is_equiv>> is [true], duplicate the state of machine <<i>> and
    perform transition on the copy

These changes are reflected in the validity and transition functions.
For validity we additionaly require that the machine descriptor refers
to a valid internal machine, or to an initial state of <<X>>.

*)

Section equivocator_vlsm.
  Context
    {message : Type}
    (X : VLSM message)
    .

Inductive MachineDescriptor : Type
  :=
  | NewMachine : vstate X -> MachineDescriptor
  | Existing : nat -> bool -> MachineDescriptor.

Definition equivocator_type : VLSM_type message :=
  {| state := {n : nat & Fin.t (S n) -> vstate X};
     label := vlabel X * MachineDescriptor
  |}.

Definition equivocator_state : Type := @state message equivocator_type.

Definition mk_singleton_state
  (s : vstate X)
  : equivocator_state
  :=
  existT _ 0 (fun _ => s).

Definition is_singleton_state
  (s : equivocator_state)
  : Prop
  := projT1 s = 0.

Lemma is_singleton_state_dec
  (s : equivocator_state)
  : Decision (is_singleton_state s).
Proof.
  apply nat_eq_dec.
Qed.

Definition is_equivocating_state
  (s : equivocator_state)
  : Prop
  := not (is_singleton_state s).

Lemma is_equivocating_state_dec
  (s : equivocator_state)
  : Decision (is_equivocating_state s).
Proof.
  apply Decision_not.
  apply is_singleton_state_dec.
Qed.

Definition equivocator_label : Type := @label message equivocator_type.

Definition mk_label
  (lx : vlabel X)
  (d : MachineDescriptor)
  : equivocator_label
  := (lx, d).

(**
Attempts to obtain the state of the internal machine with index <<i>>
from an [equivocator_state]. Fails with index <<i>> does not refer to a
machine.
*)
Definition equivocator_state_project
  (bs : equivocator_state)
  (i : nat)
  : option (vstate X)
  :=
  let (n, s) := bs in
  match (le_lt_dec (S n) i) with
  | right lt_in => Some (s (of_nat_lt lt_in))
  | _ =>  None
  end.

(**
Projecting an [equivocator_state] over a [MachineDescriptor].

This is extracted from the original [equivocators_state_project] to allow
factoring out the proofs by proving properties at this level.
*)

Definition equivocator_state_descriptor_project
  (s : equivocator_state)
  (descriptor : MachineDescriptor)
  : vstate X
  :=
  match descriptor with
  | NewMachine sn => sn
  | Existing j _ =>
    match equivocator_state_project s j with
    | Some sj => sj
    | None => projT2 s F1
    end
  end.

Definition equivocator_state_update
  (bs : equivocator_state)
  (n := projT1 bs)
  (i : Fin.t (S n))
  (si : vstate X)
  : equivocator_state
  :=
  existT _ n
    (fun j => if Fin.eq_dec i j then si else projT2 bs j).

(** Some basic properties for 'equivocator_state_update' *)

Lemma equivocator_state_update_size
  (bs : equivocator_state)
  (i : Fin.t (S (projT1 bs)))
  (si : vstate X)
  : projT1 (equivocator_state_update bs i si) = projT1 bs.
Proof.
  destruct bs. reflexivity.
Qed.

Lemma equivocator_state_update_eq
  (bs : equivocator_state)
  (n := projT1 bs)
  (i : Fin.t (S n))
  (si : vstate X)
  : projT2 (equivocator_state_update bs i si) i = si.
Proof.
  simpl. rewrite eq_dec_if_true; reflexivity.
Qed.

Lemma equivocator_state_update_neq
  (bs : equivocator_state)
  (n := projT1 bs)
  (i j : Fin.t (S n))
  (si : vstate X)
  (Hij : i <> j)
  : projT2 (equivocator_state_update bs i si) j = projT2 bs j.
Proof.
  simpl. rewrite eq_dec_if_false by assumption. reflexivity.
Qed.

(**
Extends an [equivocator_state] with a new state of the original machine.
*)
Program Definition equivocator_state_extend
  (bs : equivocator_state)
  (s : vstate X)
  : equivocator_state
  :=
  let (n, is) := bs in
  existT _ (S n)
    (fun j =>
      let (nj, Hnj) := to_nat j in
      if (nat_eq_dec nj (S n)) then s else is (@of_nat_lt nj (S n) _)
    ).
Next Obligation.
  lia.
Defined.

(** The original state index is present in any equivocator state*)
Lemma Hzero (s : equivocator_state) : 0 < S (projT1 s).
Proof. lia. Qed.

(* An [equivocator_state] has the [initial_state_prop]erty if it only
contains one state of original machine, and that state is initial.
*)
Definition equivocator_initial_state_prop
  (bs : equivocator_state)
  : Prop
  := projT1 bs = 0 /\ vinitial_state_prop X (projT2 bs (of_nat_lt (Hzero bs))).

Definition equivocator_initial_state
  := sig equivocator_initial_state_prop.

Definition equivocator_s0 : equivocator_initial_state.
Proof.
  exists (mk_singleton_state (proj1_sig (vs0 X))).
  unfold mk_singleton_state.
  unfold equivocator_initial_state_prop.
  split; [reflexivity|].
  simpl. destruct (vs0 X). assumption.
Defined.

Definition equivocator_l0 : equivocator_label :=
  (vl0 X, Existing 0 false).

Definition equivocator_sig
  : VLSM_sign equivocator_type
  :=
    {|   initial_state_prop := equivocator_initial_state_prop
       ; s0 := equivocator_s0
       ; initial_message_prop := vinitial_message_prop X
       ; m0 := vm0 X
       ; l0 := equivocator_l0
    |}.

Definition equivocator_transition
  (bl : equivocator_label)
  (bsom : equivocator_state * option message)
  : equivocator_state * option message
  :=
  let (bs, om) := bsom in
  let n := projT1 bs in
  let s := projT2 bs in
  let l := fst bl in
  match snd bl with
  | NewMachine sn  => (* creating a new machine with initial state sn*)
    (equivocator_state_extend bs sn, None)
  | Existing i is_equiv => (* transition using the state of machine i *)
    match (le_lt_dec (S n) i) with
    | right lt_in =>
      let ni := of_nat_lt lt_in in
      let si := s ni in
      let (si', om') := vtransition X l (si, om) in
      match is_equiv with
      | false => (equivocator_state_update bs ni si', om') (* not equivocating *)
      | true => (equivocator_state_extend bs si', om') (* equivocating in a new copy *)
      end
    | _ =>  bsom
    end
  end.

Definition equivocator_valid
  (bl : equivocator_label)
  (bsom : equivocator_state * option message)
  : Prop
  :=
  let (bs, om) := bsom in
  let n := projT1 bs in
  let s := projT2 bs in
  let l := fst bl in
  match snd bl with
  | NewMachine sn  => (* state is initial *)
    vinitial_state_prop X sn /\ om = None
  | Existing i is_equiv => (* the index is good, and transition valid for it *)
    exists (Hi : i < S n), vvalid X l (s (of_nat_lt Hi), om)
  end.

Definition equivocator_vlsm_machine
  : VLSM_class equivocator_sig
  :=
  {|  transition := equivocator_transition
   ;  valid := equivocator_valid
  |}.

Definition equivocator_vlsm
  : VLSM message
  :=
  mk_vlsm equivocator_vlsm_machine.

Lemma mk_singleton_initial_state
  (s : vstate X)
  : vinitial_state_prop X s ->
    vinitial_state_prop equivocator_vlsm (mk_singleton_state s).
  Proof.
    intro Hs.
    split;[reflexivity|assumption].
  Qed.

End equivocator_vlsm.

Section equivocator_vlsm_protocol_state_projections.

Context
  {message : Type}
  (X : VLSM message)
  (equivocator_vlsm := equivocator_vlsm X)
  (MachineDescriptor := MachineDescriptor X)
  .

 (** Whether a [MachineDescriptor] can be used to project an
 [equivocator_state] to a regular [state].
 The [NewMachine] descriptor signals that an equivocation has occured
 starting a new machine, thus we require the argument to be initial.
 For an [Existing] descriptor, the index of the descriptor must
 refer to an existing machine in the current state.
 *)
Definition proper_descriptor
  (d : MachineDescriptor)
  (s : vstate equivocator_vlsm)
  :=
  match d with
  | NewMachine _ sn => vinitial_state_prop X sn
  | Existing _ i _ => i < S (projT1 s)
  end.

(** Same as above, but disallowing equivocation. *)
Definition not_equivocating_descriptor
  (d : MachineDescriptor)
  (s : vstate equivocator_vlsm)
  :=
  match d with
  | Existing _ i false => i < S (projT1 s)
  | _ => False
  end.

Lemma not_equivocating_descriptor_proper
  (d : MachineDescriptor)
  (s : vstate equivocator_vlsm)
  (Hned : not_equivocating_descriptor d s)
  : proper_descriptor d s.
Proof.
  destruct d; [contradict Hned|].
  destruct b; [contradict Hned|].
  assumption.
Qed.

Local Ltac unfold_transition H :=
  ( unfold transition in H; unfold equivocator_vlsm in H
  ; unfold Common.equivocator_vlsm in H
  ; unfold mk_vlsm in H; unfold machine in H
  ; unfold projT2 in H; unfold equivocator_vlsm_machine in H
  ; unfold equivocator_transition in H).
(* TODO: derive some some simpler lemmas about the equivocator operations,
or a simpler way of defining the equivocator_transition
- it's not nice to need to pick apart these cases from inside
equivocator_transition inside of so many proofs.
*)

(** If the state obtained after one transition has no equivocation, then
the descriptor of the label of the transition must be Existing 0 false
*)
Lemma equivocator_transition_no_equivocation_zero_descriptor
  (iom oom: option message)
  (l: vlabel equivocator_vlsm)
  (s s': vstate equivocator_vlsm)
  (Hv: vvalid equivocator_vlsm l (s, iom))
  (Ht: vtransition equivocator_vlsm l (s, iom) = (s', oom))
  (Hs' : is_singleton_state X s')
  : snd l = Existing _ 0 false.
Proof.
  unfold is_singleton_state in Hs'.
  unfold vtransition in Ht. unfold_transition Ht.
  destruct l as (l, [sn | ei ef]); unfold snd in Ht
  ; [inversion Ht; subst; destruct s; simpl; inversion Hs'|].
  destruct Hv as [Hei _].
  destruct (le_lt_dec (S (projT1 s)) ei); [lia|].
  match type of Ht with
  | (let (_, _) := ?t in _) = _ => destruct t as (_s', _om')
  end.
  destruct ef; inversion Ht; subst; clear Ht.
  - destruct s. inversion Hs'.
  - destruct s. simpl in *. assert (ei = 0) by lia. subst. reflexivity.
Qed.

(** If the state obtained after one transition has no equivocation, then
the state prior to the transition has no equivocation as well.
*)
Lemma equivocator_transition_reflects_singleton_state
  (iom oom: option message)
  (l: vlabel equivocator_vlsm)
  (s s': vstate equivocator_vlsm)
  (Ht: vtransition equivocator_vlsm l (s, iom) = (s', oom))
  : is_singleton_state X s' -> is_singleton_state X s.
Proof.
  unfold is_singleton_state.
  unfold vtransition in Ht. unfold_transition Ht.
  destruct l as (l, [sn | ei ef]); unfold snd in Ht
  ; [inversion Ht; subst; destruct s; simpl; congruence|].
  destruct (le_lt_dec (S (projT1 s)) ei)
  ; [inversion Ht; subst; exact id|].
  match type of Ht with
  | (let (_, _) := ?t in _) = _ => destruct t as (_s', _om')
  end.
  destruct ef; inversion Ht; subst; [|exact id].
  destruct s. simpl. congruence.
Qed.

(**
Protocol messages in the [equivocator_vlsm] are also protocol in the
original machine.  All components of a protocol state in the
[equivocator_vlsm] are also protocol in the original machine.
*)
Lemma equivocator_state_project_protocol
  (bs : vstate equivocator_vlsm)
  (om : option message)
  (Hbs : protocol_prop equivocator_vlsm (bs, om))
  :
  option_protocol_message_prop X om /\
  let (n, bs) := bs in
  forall (i : Fin.t (S n)), protocol_state_prop X (bs i).
Proof.
  dependent induction Hbs; split.
  - apply option_initial_message_is_protocol;assumption.
  - destruct bs as [n bs]; intro i.
    destruct Hs as [Hn0 Hinit].
    simpl in Hn0, Hinit.
    subst n.
    dependent induction i;[|inversion i].
    apply initial_is_protocol; assumption.
  - specialize (IHHbs1 X s _om eq_refl JMeq_refl).
    specialize (IHHbs2 X _s om0 eq_refl JMeq_refl).
    specialize (protocol_generated X) as Hgen.
    simpl in Hv.
    destruct l as (l, descriptor). simpl in Hv.
    destruct descriptor as [sn| i is_equiv].
    + destruct Hv as [Hsn Hv]. subst om0.
      simpl in x. inversion x. subst. apply IHHbs2.
    + unfold_transition x.
      unfold snd in x. destruct Hv as [Hi Hv].
      destruct (le_lt_dec (S (projT1 s)) i); [lia|].
      replace (of_nat_lt l0) with (of_nat_lt Hi) in * by apply of_nat_ext.
      clear l0.
      destruct s as (n, bs').
      destruct IHHbs1 as [_ IHHbs1].
      spec IHHbs1 (of_nat_lt Hi).
      destruct IHHbs1 as [_om' Hbs't].
      destruct IHHbs2 as [Hom _].
      clear Hbs2 _s.
      destruct Hom as [_s Hom].
      specialize (Hgen l (bs' (of_nat_lt Hi)) _om' Hbs't _s om0 Hom Hv).
      match type of Hgen with
      | protocol_prop _ ?t =>
        change t  with (vtransition X l (bs' (of_nat_lt Hi), om0))
          in Hgen
      end.
      simpl in *.
      destruct (vtransition X l (bs' (of_nat_lt Hi), om0)) as (si', om') eqn:Ht.
      exists si'.
      destruct is_equiv as [|]; inversion x; subst; assumption.
  - destruct bs as (n, bs).
    intro j.
    specialize (IHHbs1 X s _om eq_refl JMeq_refl).
    destruct IHHbs1 as [_ IHHbs1].
    specialize (IHHbs2 X _s om0 eq_refl JMeq_refl).
    specialize (protocol_generated X) as Hgen.
    unfold_transition x.
    destruct l as (l, descriptor). unfold snd in x.
    destruct descriptor as [sn | i is_equiv].
    + destruct Hv as [Hsn Hv]. subst om0.
      inversion x. subst om.
      unfold equivocator_state_extend in H0.
      destruct s as (n0, bs0).
      inversion H0. subst n.
      simpl_existT. subst.
      destruct (to_nat j) as (nj, Hnj).
      try destruct (nat_eq_dec nj (S n0)).
      * apply initial_is_protocol;assumption.
      * apply IHHbs1.
    + destruct Hv as [Hi Hv].
      destruct (le_lt_dec (S (projT1 s)) i); [lia|].
      replace (of_nat_lt l0) with (of_nat_lt Hi) in * by apply of_nat_ext.
      clear l0.
      destruct s as (n0, bs0); simpl in *.
      destruct (IHHbs1 (of_nat_lt Hi)) as [_om0 Hbs0t].
      destruct IHHbs2 as [(_som, Hom) _].
      specialize (Hgen l (bs0 (of_nat_lt Hi))  _om0 Hbs0t _som om0 Hom Hv).
      match type of Hgen with
      | protocol_prop _ ?t =>
        change t  with (vtransition X l (bs0 (of_nat_lt Hi), om0))
          in Hgen
      end.
      destruct (vtransition X l (bs0 (of_nat_lt Hi), om0)) as (si', om') eqn:Ht.
      destruct is_equiv as [|]; inversion x; clear x
      ; subst n om'; apply inj_pairT2 in H1; subst.
      * destruct (to_nat j) as (nj, Hnj).
        destruct (nat_eq_dec  nj (S n0)); [exists om; assumption|].
        apply IHHbs1.
      * destruct (Fin.eq_dec (of_nat_lt Hi) j); [|apply IHHbs1].
        exists om. assumption.
Qed.

Lemma equivocator_state_project_protocol_state
  (bs : vstate equivocator_vlsm)
  (Hbs : protocol_state_prop equivocator_vlsm bs)
  :
  let (n, bs) := bs in
  forall (i : Fin.t (S n)), protocol_state_prop X (bs i).
Proof.
  destruct Hbs as [om Hbs].
  apply equivocator_state_project_protocol in Hbs.
  apply proj2 in Hbs.
  assumption.
Qed.

Lemma equivocator_state_project_protocol_message
  (om : option message)
  (Hom : option_protocol_message_prop equivocator_vlsm om)
  :
  option_protocol_message_prop X om.
Proof.
  destruct Hom as [s Hom].
  apply equivocator_state_project_protocol in Hom.
  apply proj1 in Hom.
  assumption.
Qed.

(**
All components of a protocol states of the [pre_loaded_with_all_messages_vlsm] corresponding
to an [equivocator_vlsm] are also protocol for the [pre_loaded_with_all_messages_vlsm]
corresponding to the original machine.
*)
Lemma preloaded_equivocator_state_project_protocol_state
  (bs : vstate equivocator_vlsm)
  (Hbs : protocol_state_prop (pre_loaded_with_all_messages_vlsm equivocator_vlsm) bs)
  (i : Fin.t (S (projT1 bs)))
  :
  protocol_state_prop (pre_loaded_with_all_messages_vlsm X) (projT2 bs i).
Proof.
  revert bs Hbs i.
  induction 1 using protocol_state_prop_ind;intros.
  - destruct Hs as [Hzero His].
    destruct s. simpl in *. subst x.
    apply initial_is_protocol.
    dependent destruction i; [|inversion i].
    assumption.
  - destruct Ht as [[Hps [_ Hv]] Ht].
    simpl in Ht. unfold vtransition in Ht. unfold_transition Ht.
    destruct l as (l, description).
    unfold snd in Ht.
    destruct description as [sn| j is_equiv].
    + destruct Hv as [Hsn Hv]. subst om.
      inversion Ht. subst.
      unfold equivocator_state_extend.
      destruct s as (ns, bs).
      simpl in *. destruct (to_nat i) as (ni, Hni).
      destruct (nat_eq_dec ni (S ns)); [|apply IHHbs].
      subst.
      apply initial_is_protocol;assumption.
    + destruct Hv as [Hj Hv].
      destruct (le_lt_dec (S (projT1 s)) j); [lia|].
      replace (of_nat_lt l0) with (of_nat_lt Hj) in * by apply of_nat_ext. clear l0.
      destruct (IHHbs (of_nat_lt Hj)) as [_omj Hsj].
      specialize (protocol_generated (pre_loaded_with_all_messages_vlsm X) l (projT2 s (of_nat_lt Hj)) _omj Hsj)
        as Hgen.
      spec Hgen (proj1_sig (vs0 X)) om (pre_loaded_with_all_messages_message_protocol_prop X om) Hv.
      change (transition l (projT2 s (of_nat_lt Hj), om))
        with (vtransition X l (projT2 s (of_nat_lt Hj), om))
        in Hgen.
      simpl in *.
      destruct (vtransition X l (projT2 s (of_nat_lt Hj), om)) as (sj', omj').
      destruct is_equiv as [|]; inversion Ht; subst; clear Ht; simpl in *.
      * destruct s as (ns, bs). simpl in *.
        destruct (to_nat i) as (ni, Hni).
        destruct (nat_eq_dec ni (S ns)); [|apply IHHbs].
        exists om'. assumption.
      * destruct (Fin.eq_dec (of_nat_lt Hj) i); [|apply IHHbs].
        exists om'. assumption.
Qed.

(**
Next couple of lemmas characterize the projections of a [equivocator_state]
after taking a transition in terms of the preceeeding state.

These are simpler version of the results concerning the projection of
states from the composition of equivocators over [equivocation_descriptors].

These results are used for characterizing the projection of the [destination]
of a [transition_item] in an equivocator trace in
[equivocator_transition_item_project_proper_characterization].
*)

Lemma new_machine_label_equivocator_state_project_last
  (l : vlabel equivocator_vlsm) s oin s' oout
  (Ht : vtransition equivocator_vlsm l (s, oin) = (s', oout))
  sn
  (Hnew: snd l = NewMachine _ sn)
  fi
  : equivocator_state_descriptor_project X s' (Existing _ (projT1 s') fi) =
    equivocator_state_descriptor_project X s (NewMachine _ sn).
Proof.
  destruct l as (l, new). simpl in Hnew. subst new.
  unfold vtransition in Ht. simpl in Ht. inversion Ht. subst.
  clear Ht.
  remember (equivocator_state_extend X s sn) as ext.
  destruct ext as (n, bs).
  unfold projT1. unfold equivocator_state_descriptor_project.
  unfold equivocator_state_project.
  destruct (le_lt_dec (S n) n); [lia|].
  destruct s as (nsi, bsi). unfold equivocator_state_extend in Heqext.
  inversion Heqext. subst.
  simpl_existT. subst. rewrite to_nat_of_nat.
  destruct (nat_eq_dec (S nsi) (S nsi)); [|congruence].
  reflexivity.
Qed.

Lemma new_machine_label_equivocator_state_project_not_last
  (l : vlabel equivocator_vlsm) s oin s' oout
  (Ht : vtransition equivocator_vlsm l (s, oin) = (s', oout))
  sn
  (Hnew: snd l = NewMachine _ sn)
  ni fi
  (Hni : ni < projT1 s')
  fi'
  : equivocator_state_descriptor_project X s' (Existing _ ni fi) =
    equivocator_state_descriptor_project X s (Existing _ ni fi').
Proof.
  destruct l as (li, new). simpl in Hnew. subst new.
  inversion Ht. subst.
  unfold equivocator_state_descriptor_project.
  unfold equivocator_state_project.
  unfold equivocator_state_extend.
  unfold equivocator_state_extend in Hni.
  destruct s as (nsi', bsi').
  unfold projT1 in Hni.
  destruct (le_lt_dec (S (S nsi')) ni); [lia|].
  rewrite to_nat_of_nat.
  destruct (nat_eq_dec ni (S nsi')); [lia|].
  destruct (le_lt_dec (S nsi') ni); [lia|].
  f_equal.
  apply of_nat_ext.
Qed.

Lemma existing_true_label_equivocator_state_project_not_last
  (l : vlabel equivocator_vlsm) s oin s' oout
  (Ht : vtransition equivocator_vlsm l (s, oin) = (s', oout))
  ieqvi
  (Hex_true: snd l = Existing _ ieqvi true)
  (Hieqvi : ieqvi < S (projT1 s))
  ni fi
  (Hni : ni < projT1 s')
  fi'
  : equivocator_state_descriptor_project X s' (Existing _ ni fi)
  = equivocator_state_descriptor_project X s (Existing _ ni fi').
Proof.
  destruct l as (li, ex_true). simpl in Hex_true. subst ex_true.
  unfold vtransition in Ht. unfold_transition Ht. unfold snd in Ht.
  destruct ( le_lt_dec (S (projT1 s)) ieqvi ); [lia|].
  destruct
    (vtransition X (fst (li, Existing X ieqvi true))
    (projT2 s (of_nat_lt l), oin))
    as (si'', om'').
  inversion Ht. subst. clear Ht.
  unfold equivocator_state_descriptor_project.
  unfold equivocator_state_project.
  unfold equivocator_state_extend.
  unfold equivocator_state_extend in Hni.
  destruct s as (nsi', bsi').
  unfold projT1 in Hni.
  destruct (le_lt_dec (S (S nsi')) ni); [lia|].
  rewrite to_nat_of_nat.
  destruct (nat_eq_dec ni (S nsi')); [lia|].
  destruct (le_lt_dec (S nsi') ni); [lia|].
  f_equal.
  apply of_nat_ext.
Qed.

Lemma existing_false_label_equivocator_state_project_not_same
  (l : vlabel equivocator_vlsm) s oin s' oout
  (Ht : vtransition equivocator_vlsm l (s, oin) = (s', oout))
  ieqvi
  (Hex_false: snd l = Existing _ ieqvi false)
  (Hieqvi : ieqvi < S (projT1 s))
  ni fi
  (Hni : ni < S (projT1 s'))
  (Hnieqvi : ieqvi <> ni)
  fi'
  : equivocator_state_descriptor_project X s' (Existing _ ni fi)
  = equivocator_state_descriptor_project X s (Existing _ ni fi').
Proof.
  destruct l as (li, ex_false). simpl in Hex_false. subst ex_false.
  unfold vtransition in Ht. unfold_transition Ht. unfold snd in Ht.
  destruct ( le_lt_dec (S (projT1 s)) ieqvi ); [lia|].
  destruct
    (vtransition X (fst (li, Existing X ieqvi false))
    (projT2 s (of_nat_lt l), oin))
    as (si'', om'').
  inversion Ht. subst. clear Ht.
  unfold equivocator_state_descriptor_project.
  unfold equivocator_state_project.
  destruct s as (nsi', bsi').
  simpl in Hieqvi, l.
  unfold equivocator_state_update in *.
  unfold projT1 in *.
  destruct (le_lt_dec (S nsi') ni); [lia|].
  rewrite eq_dec_if_false; [reflexivity|].
  intro contra. elim Hnieqvi.
  apply (f_equal to_nat) in contra. repeat rewrite to_nat_of_nat in contra.
  inversion contra. reflexivity.
Qed.

End equivocator_vlsm_protocol_state_projections.


From Hammer Require Import Hammer.

Require Export Ensembles.
From ZornsLemma Require Import EnsemblesImplicit.
From ZornsLemma Require Export Families.
From ZornsLemma Require Export IndexedFamilies.
From ZornsLemma Require Export FiniteTypes.
From ZornsLemma Require Import EnsemblesSpec.

Record TopologicalSpace : Type := {
point_set : Type;
open : Ensemble point_set -> Prop;
open_family_union : forall F : Family point_set,
(forall S : Ensemble point_set, In F S -> open S) ->
open (FamilyUnion F);
open_intersection2: forall U V:Ensemble point_set,
open U -> open V -> open (Intersection U V);
open_full : open Full_set
}.

Arguments open {t}.
Arguments open_family_union {t}.
Arguments open_intersection2 {t}.

Lemma open_empty: forall X:TopologicalSpace,
open (@Empty_set (point_set X)).
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.open_empty".
intros.
rewrite <- empty_family_union.
apply open_family_union.
intros.
destruct H.
Qed.

Lemma open_union2: forall {X:TopologicalSpace}
(U V:Ensemble (point_set X)), open U -> open V -> open (Union U V).
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.open_union2".
intros.
assert (Union U V = FamilyUnion (Couple U V)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
exists U; auto with sets.
exists V; auto with sets.
destruct H1.
destruct H1.
left; trivial.
right; trivial.

rewrite H1; apply open_family_union.
intros.
destruct H2; trivial.
Qed.

Lemma open_indexed_union: forall {X:TopologicalSpace} {A:Type}
(F:IndexedFamily A (point_set X)),
(forall a:A, open (F a)) -> open (IndexedUnion F).
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.open_indexed_union".
intros.
rewrite indexed_to_family_union.
apply open_family_union.
intros.
destruct H0.
rewrite H1; apply H.
Qed.

Lemma open_finite_indexed_intersection:
forall {X:TopologicalSpace} {A:Type}
(F:IndexedFamily A (point_set X)),
FiniteT A -> (forall a:A, open (F a)) ->
open (IndexedIntersection F).
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.open_finite_indexed_intersection".
intros.
induction H.
rewrite empty_indexed_intersection.
apply open_full.

assert (IndexedIntersection F = Intersection
(IndexedIntersection (fun x:T => F (Some x)))
(F None)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
constructor.
constructor.
intros; apply H1.
apply H1.
destruct H1.
destruct H1.
constructor.
destruct a.
apply H1.
apply H2.
rewrite H1.
apply open_intersection2.
apply IHFiniteT.
intros; apply H0.
apply H0.

destruct H1.
assert (IndexedIntersection F =
IndexedIntersection (fun x:X0 => F (f x))).
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct H3.
intro; apply H3.
constructor.
destruct H3.
intro; rewrite <- H2 with a.
apply H3.
rewrite H3.
apply IHFiniteT.
intro; apply H0.
Qed.

Definition closed {X:TopologicalSpace} (F:Ensemble (point_set X)) :=
open (Ensembles.Complement F).

Lemma closed_complement_open: forall {X:TopologicalSpace}
(U:Ensemble (point_set X)), closed (Ensembles.Complement U) ->
open U.
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.closed_complement_open".
intros.
red in H.
rewrite Complement_Complement in H.
assumption.
Qed.

Lemma closed_union2: forall {X:TopologicalSpace}
(F G:Ensemble (point_set X)),
closed F -> closed G -> closed (Union F G).
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.closed_union2".
intros.
red in H, H0.
red.
assert (Ensembles.Complement (Union F G) =
Intersection (Ensembles.Complement F)
(Ensembles.Complement G)).
unfold Ensembles.Complement.
apply Extensionality_Ensembles; split; red; intros.
constructor.
auto with sets.
auto with sets.
destruct H1.
red; red; intro.
destruct H3.
apply (H1 H3).
apply (H2 H3).

rewrite H1.
apply open_intersection2; assumption.
Qed.

Lemma closed_intersection2: forall {X:TopologicalSpace}
(F G:Ensemble (point_set X)),
closed F -> closed G -> closed (Intersection F G).
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.closed_intersection2".
intros.
red in H, H0.
red.
assert (Ensembles.Complement (Intersection F G) =
Union (Ensembles.Complement F)
(Ensembles.Complement G)).
apply Extensionality_Ensembles; split; red; intros.
apply NNPP.
red; intro.
unfold Ensembles.Complement in H1.
unfold In in H1.
contradict H1.
constructor.
apply NNPP.
red; intro.
auto with sets.
apply NNPP.
red; intro.
auto with sets.

red; red; intro.
destruct H2.
destruct H1; auto with sets.

rewrite H1; apply open_union2; trivial.
Qed.

Lemma closed_family_intersection: forall {X:TopologicalSpace}
(F:Family (point_set X)),
(forall S:Ensemble (point_set X), In F S -> closed S) ->
closed (FamilyIntersection F).
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.closed_family_intersection".
intros.
unfold closed in H.
red.
assert (Ensembles.Complement (FamilyIntersection F) =
FamilyUnion [ S:Ensemble (point_set X) |
In F (Ensembles.Complement S) ]).
apply Extensionality_Ensembles; split; red; intros.
apply NNPP.
red; intro.
red in H0; red in H0.
contradict H0.
constructor.
intros.
apply NNPP.
red; intro.
contradict H1.
exists (Ensembles.Complement S).
constructor.
rewrite Complement_Complement; assumption.
assumption.
destruct H0.
red; red; intro.
destruct H2.
destruct H0.
pose proof (H2 _ H0).
contradiction H3.

rewrite H0; apply open_family_union.
intros.
destruct H1.
pose proof (H _ H1).
rewrite Complement_Complement in H2; assumption.
Qed.

Lemma closed_indexed_intersection: forall {X:TopologicalSpace}
{A:Type} (F:IndexedFamily A (point_set X)),
(forall a:A, closed (F a)) -> closed (IndexedIntersection F).
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.closed_indexed_intersection".
intros.
rewrite indexed_to_family_intersection.
apply closed_family_intersection.
intros.
destruct H0.
rewrite H1; trivial.
Qed.

Lemma closed_finite_indexed_union: forall {X:TopologicalSpace}
{A:Type} (F:IndexedFamily A (point_set X)),
FiniteT A -> (forall a:A, closed (F a)) ->
closed (IndexedUnion F).
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.closed_finite_indexed_union".
intros.
red.
assert (Ensembles.Complement (IndexedUnion F) =
IndexedIntersection (fun a:A => Ensembles.Complement (F a))).
apply Extensionality_Ensembles; split; red; intros.
constructor.
intros.
red; red; intro.
contradiction H1.
exists a.
assumption.
destruct H1.
red; red; intro.
destruct H2.
contradiction (H1 a).

rewrite H1; apply open_finite_indexed_intersection; trivial.
Qed.

Hint Unfold closed : topology.
Hint Resolve (@open_family_union) (@open_intersection2) open_full
open_empty (@open_union2) (@open_indexed_union)
(@open_finite_indexed_intersection) (@closed_complement_open)
(@closed_union2) (@closed_intersection2) (@closed_family_intersection)
(@closed_indexed_intersection) (@closed_finite_indexed_union)
: topology.

Section Build_from_closed_sets.

Variable X:Type.
Variable closedP : Ensemble X -> Prop.
Hypothesis closedP_empty: closedP Empty_set.
Hypothesis closedP_union2: forall F G:Ensemble X,
closedP F -> closedP G -> closedP (Union F G).
Hypothesis closedP_family_intersection: forall F:Family X,
(forall G:Ensemble X, In F G -> closedP G) ->
closedP (FamilyIntersection F).

Definition Build_TopologicalSpace_from_closed_sets : TopologicalSpace.
refine (Build_TopologicalSpace X
(fun U:Ensemble X => closedP (Ensembles.Complement U)) _ _ _).
intros.
replace (Ensembles.Complement (FamilyUnion F)) with
(FamilyIntersection [ G:Ensemble X | In F (Ensembles.Complement G) ]).
apply closedP_family_intersection.
destruct 1.
rewrite <- Complement_Complement.
apply H; trivial.
apply Extensionality_Ensembles; split; red; intros.
intro.
destruct H1.
destruct H0.
absurd (In (Ensembles.Complement S) x).
intro.
contradiction H3.
apply H0.
constructor.
rewrite Complement_Complement; trivial.
constructor.
destruct 1.
apply NNPP; intro.
contradiction H0.
exists (Ensembles.Complement S); trivial.

intros.
replace (Ensembles.Complement (Intersection U V)) with
(Union (Ensembles.Complement U) (Ensembles.Complement V)).
apply closedP_union2; trivial.
apply Extensionality_Ensembles; split; red; intros.
intro.
destruct H2.
destruct H1; contradiction H1.
apply NNPP; intro.
contradiction H1.
constructor; apply NNPP; intro; contradiction H2;
[ left | right ]; trivial.

apply eq_ind with (1 := closedP_empty).
apply Extensionality_Ensembles; split; auto with sets;
red; intros.
contradiction H.
constructor.
Defined.

Lemma Build_TopologicalSpace_from_closed_sets_closed:
forall (F:Ensemble (point_set Build_TopologicalSpace_from_closed_sets)),
closed F <-> closedP F.
Proof. hammer_hook "TopologicalSpaces" "TopologicalSpaces.Build_TopologicalSpace_from_closed_sets_closed".
intros.
unfold closed.
simpl.
rewrite Complement_Complement.
split; trivial.
Qed.

End Build_from_closed_sets.

Arguments Build_TopologicalSpace_from_closed_sets {X}.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e384m317_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(******************************************************************************
September 2004
Authors: Jean-Yves Vion-dury and Pierre Geneves

jean-yves.vion-dury@xrce.xerox.com
WAM Research Project, INRIA Rhone-Alpes and Xerox Research Center Europe

pierre.geneves@inrialpes.fr
WAM Research Project, INRIA Rhone-Alpes

Please do not reuse or publish this code without explicit consent from authors.
*******************************************************************************)
Require Export zorder.
Require Export xnodes.

Require Export Mapping.
Require Export graphInt.
Require Export dgraph.

Require Import graphProp.

Module XTree
  (*	: graphSig with Definition Node := theXNode *)
  := Dgraph XNodes.

Module P := GProp XTree.

Inductive wfXmlTree (t : XTree.DGraph) : Prop :=
    wfxml :
      (* it is indeed a tree, not a general graph *)
      P.Tree t ->
      forall (e e' e'' : NodeId) (aNode : XTree.Node),
      XTree.get_node t e = Some aNode ->

      (* nodes are totally ordered *)
      XTree.get_order t e <> None ->

      (* nodes are strictly ordered *)
      (forall z z' : Z,
       z <> z' ->
       XTree.get_order t e = Some z ->
       XTree.get_order t e' = Some z' -> (z < z')%Z \/ (z' < z)%Z) ->

      (* some topological properties w.r.t. node types *)
      match aNode with
      | root =>
          XTree.parents t e = emptyNS /\ XTree.children t e = single e''
      | element _ => True
      | _ => XTree.children t e = emptyNS
      end -> wfXmlTree t.


Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import Program.
Require Import Category.
Require Import Isomorphism.
Require Import Coq.
Require Import Co.

Set Universe Polymorphism.

Class Terminal `{Category} := {
  terminal : object;
  receivesAll o : o → terminal;
  receivesAllUnique {o f} : receivesAll o = f
}.

Instance co `(Category) : Category := {|
  object := object;
  morphism a b := morphism b a;
  id a := id;
  composition a b c f g := g ∘ f
|}.
Proof.
  - intros.
    apply Category.rightId.
  - intros.
    apply Category.leftId.
  - intros.
    symmetry.
    apply Category.assoc.
Defined.

Definition Initial {C} := @Terminal (co C).

Definition coqInitialEmptySet : @Initial Coq.
refine {|
  terminal := Empty_set:@object (co Coq);
  receivesAll o := Empty_set_rect (const o)
|}.
Proof.
  compute.
  intros.
  extensionality a.
  destruct a.
Defined.

Instance coqTerminalUnit : @Terminal Coq.
refine {|
  terminal := unit:@object Coq;
  receivesAll o := fun _ => tt
|}.
Proof.
  compute.
  intros.
  extensionality a.
  destruct (f a).
  reflexivity.
Defined.

Instance coqTerminalTrue : @Terminal Coq.
refine {|
  terminal := True:@object Coq;
  receivesAll o := fun _ => I
|}.
Proof.
  compute.
  intros.
  apply proof_irrelevance.
Defined.

Instance BoolCat : Category := {|
  object := bool:Type;
  morphism a b := match a,b with true,false => Empty_set | _,_ => unit end:Type;
  id := $( intros []; exact tt )$;
  composition := $( intros [] [] [] [] []; exact tt)$
|}.
Proof.
  all: repeat intros []; reflexivity.
Defined.

Instance boolTerminal : @Terminal BoolCat := {|
  terminal := true:@object BoolCat;
  receivesAll := $( intros []; exact tt )$
|}.
Proof.
  repeat intros []; reflexivity.
Defined.

Definition boolInitial : @Initial BoolCat.
refine {|
  terminal := false:@object (co BoolCat);
  receivesAll := $( intros []; exact tt )$
|}.
Proof.
  repeat intros []; reflexivity.
Defined.

Instance allTerminalsIso `{C:Category} (t t':Terminal) : @terminal _ t ≈ @terminal _ t'.
  refine {|
    f := receivesAll terminal;
    g := receivesAll terminal
  |}.
  - match goal with |- ?H = _ => generalize H; intros h end.
    specialize (@receivesAllUnique _ t _ id).
    specialize (@receivesAllUnique _ t _ h).
    congruence.
  - match goal with |- ?H = _ => generalize H; intros h end.
    specialize (@receivesAllUnique _ t' _ id).
    specialize (@receivesAllUnique _ t' _ h).
    congruence.
Defined.

(* dualityPrinciple, should be formalized *)
Instance allInitialsIso `{C:Category} (t t':Initial) : @terminal _ t ≈ @terminal _ t'.
  apply allTerminalsIso.
Defined.

Lemma allTerminalsIsoUnique `{C:Category} (t t':@Terminal C)
                             (i:@terminal _ t ≈ @terminal _ t')
                             (j:@terminal _ t ≈ @terminal _ t') : i = j.
  destruct i as [fi gi].
  destruct j as [fj gj].
  f_equal.
  - intros; subst.
    f_equal; apply proof_irrelevance.
  - specialize (@receivesAllUnique _ _ _ fj).
    specialize (@receivesAllUnique _ _ _ fi).
    congruence.
  - specialize (@receivesAllUnique _ _ _ gj).
    specialize (@receivesAllUnique _ _ _ gi).
    congruence.
Qed.


Require Import GraphBasics.Graphs.
Require Import GraphBasics.Trees.
Require Import Coq.Logic.Classical_Prop.

Load Bipartition_checker.
Require Export Coq.Bool.BoolEq.

Section Checker_proofs.

(******** Network of the algorithm *********)
Variable v : V_set.
Variable a : A_set.
Variable c : Connected v a.
(********/Network of the algorithm *********)

(******** Interface of checker *********)
Variable global_bipartite_answer : bool.
Variable local_bipartite_answer : Component -> bool.
Variable leader : Component -> Component.
Variable distance : Component -> nat.
Variable parent : Component -> Component.
Variable neighbors_input : Component -> list Component.
Variable nld : Component -> nldlist.
(********/Interface of checker *********)

(******** Seperate function to implement in the framework *********)
Variable global_output_consistent : bool.
(********/Seperate function to implement in the framework *********)

Definition neighbors (x: Component) : list Component :=
  (A_in_neighborhood x (CA_list v a c)).

Fixpoint manual_construct_checker_input_neighbor_list (l : list Component) (leader : Component -> Component) (distance : Component -> nat) : nldlist :=
  match l with
  | nil => nil
  | hd :: tl => (hd, leader hd, distance hd) :: (manual_construct_checker_input_neighbor_list tl leader distance)
  end.

(* This axiom means, that distances and leaders are consistent: if a component knows about some
   other component's information, the values of that information must be the same. This shall be checked
   by a consistency checker. This is work in progress, though.
 *)
Axiom checker_global_output_consistent_nld_correct1 : forall (x1 x2 : Component),
  global_output_consistent = true ->
    get_distance_in_list x2 (nld x1) = distance x2 /\
    get_leader_in_list x2 (nld x1) = leader x2.

(* The next axiom means, that if the checker is given some neighbors, they are actually neighbors in the network.
 *)
Axiom neighbor_input_is_correct : forall v0,
  neighbors_input v0 = neighbors v0.

Lemma CA_list_complete : forall (v : V_set) (a : A_set) (c : Connected v a) (x : Arc),
  a x <-> In x (CA_list v a c).
Proof. clear v a c.
  intros v a c x.
  split ; intros.
  - induction c.
    + simpl.
      inversion H.
    + simpl.
      inversion H.
      inversion H0.
      auto. subst.
      inversion H0 ; subst ; auto.
      subst.
      right. right.
      apply (IHc0 ) ; auto.
    + simpl.
      inversion H ; subst ; auto.
      inversion H0 ; subst ; intuition.
    + rewrite <- e in *.
      rewrite <- e0 in *.
      apply (IHc0 ) ; auto.
  - induction c.
    + simpl in H.
      destruct H.
    + simpl in H.
      destruct H ; subst ; intuition.
      apply In_left. apply E_right.
      subst. apply In_left. apply E_left.
      apply In_right.
      auto.
    + simpl in H.
      destruct H ; subst ; intuition.
      apply In_left. apply E_right.
      subst. apply In_left. apply E_left.
      apply In_right.
      auto.
    + rewrite <- e in *.
      rewrite <- e0 in *.
      apply (IHc0 ) ; auto.
Qed.

Lemma is_in_once_correct : forall x l,
  is_in_once x l -> exists y n, In (x,y,n) l.
Proof.
  intros x l H. clear neighbors_input local_bipartite_answer.
  induction l.
  inversion H.
  simpl in *. destruct a0. destruct p.
  destruct (V_eq_dec x c0) ; subst ; intuition.
  exists c1. exists n. auto.
  destruct H4. destruct H4. exists x0. exists x1. auto.
Qed.

Lemma is_not_in_correct : forall l a b c,
  is_not_in a l -> ~ In (a,b,c) l.
Proof.
  intro l. clear neighbors_input. clear local_bipartite_answer.
  induction l ; simpl in * ; intuition.
  inversion H5. subst. destruct (V_eq_dec a1 a1) ; intuition.
  destruct (V_eq_dec a1 a0) ; intuition.
  specialize (IHl a1 b1 c0) ; intuition.
Qed.

Lemma is_not_in_correct' : forall l le d x,
(~ In x l) ->  is_not_in x (manual_construct_checker_input_neighbor_list l le d).
Proof.
  intros.
  induction l ; simpl in * ; intuition.
  destruct (V_eq_dec x a0) ; subst ; intuition.
Qed.

Lemma local_input_correct: forall (x1 x2: Component),
  In x2 (neighbors_input x1) <-> a (A_ends x1 x2).
Proof.
  intros.
  rewrite neighbor_input_is_correct. clear neighbors_input local_bipartite_answer.
  unfold neighbors.
  induction c ; split ; intros ; simpl in * ; subst ; intuition.
  - inversion H.
  - destruct (V_eq_dec x1 y) ; destruct (V_eq_dec x1 x) ; subst ; intuition.
    inversion H ; subst ; auto.
    apply In_left. apply E_left.
    intuition. apply In_right. auto.
    inversion H ; subst ; auto.
    apply In_left. apply E_right.
    intuition. apply In_right. auto.
    apply In_right. auto.
  - destruct (V_eq_dec x1 y) ; destruct (V_eq_dec x1 x) ; subst ; intuition.
    inversion H ; subst.
    inversion H4 ; subst ; intuition.
    intuition. inversion H ; subst.
    inversion H4 ; subst ; intuition. intuition.
    inversion H ; subst.
    inversion H4 ; subst ; intuition.
    intuition.
  - destruct (V_eq_dec x1 y) ; destruct (V_eq_dec x1 x) ; subst ; intuition.
    inversion H ; subst ; auto.
    apply In_left. apply E_left.
    intuition. apply In_right. auto.
    inversion H ; subst ; auto.
    apply In_left. apply E_right.
    intuition. apply In_right. auto.
    apply In_right. auto.
  - destruct (V_eq_dec x1 y) ; destruct (V_eq_dec x1 x) ; subst ; intuition.
    inversion H ; subst.
    inversion H4 ; subst ; intuition.
    intuition. inversion H ; subst.
    inversion H4 ; subst ; intuition. intuition.
    inversion H ; subst.
    inversion H4 ; subst ; intuition.
    intuition.
Qed.

Lemma nld_correct2' : forall (x1 x2 : Component),
  global_output_consistent = true ->
     get_distance_in_list x2 (nld x1) = distance x2.
Proof.
  intros.
  apply checker_global_output_consistent_nld_correct1 ; auto.
Qed.

Lemma nld_correct2 : forall (x1 x2 : Component),
  global_output_consistent = true ->
     get_distance_in_list x2 (nld x1) = distance x2.
Proof.
  intros.
  apply (nld_correct2' x1 x2) ; auto.
Qed.

Lemma nld_correct5' : forall (x1 x2 : Component),
  global_output_consistent = true ->
     get_leader_in_list x2 (nld x1) = leader x2.
Proof.
  intros.
  apply checker_global_output_consistent_nld_correct1 ; auto.
Qed.

Lemma nld_correct5 : forall (x1 x2 : Component),
  global_output_consistent = true ->
     get_leader_in_list x2 (nld x1) = leader x2.
Proof.
  intros.
  apply (nld_correct5' x1 x2) ; auto.
Qed.

Lemma nld_correct4' : forall (x y : Component),
  is_in_once y (nld x) ->
  (exists (z : Component) (n : nat),
  In (y,z,n) (nld x)).
Proof.
  intros x y H.
  induction (nld x) ; simpl in *.
  inversion H.
  destruct a0. destruct p. destruct (V_eq_dec y c0).
  subst.
  exists c1. exists n0. left. auto.
  apply IHn in H.
  destruct H. destruct H. exists x0. exists x1.
  right. auto.
Qed.

Lemma nld_correct4 : forall (x y : Component),
  is_in_once y (nld x) ->
  (exists (z : Component) (n : nat),
  In (y,z,n) (nld x)).
Proof.
  intros.
  apply (nld_correct4' x y) ; auto.
Qed.

Lemma leader_same_correct : forall (x a b: Component) (l : nldlist) (c : nat),
  leader_same x l = true -> In (a, b, c) l -> b = x.
Proof.
  intros.
  induction l ; simpl in * ; intuition.
  destruct a1. destruct p. inversion H1 ; subst ; intuition.
  destruct (V_eq_dec x b) ; intuition. inversion H.
  destruct a1. destruct p.
  destruct (V_eq_dec x c2) ; intuition.
Qed.

Lemma is_in_correct : forall (x : Component) (l : list Component),
  is_in x l = true <-> In x l.
Proof.
  split ; intros.
  induction l ; simpl in * ; intuition.
  destruct (V_eq_dec x a0) ; subst ; intuition.
  induction l ; simpl in * ; intuition.
  destruct (V_eq_dec x a0) ; subst ; intuition.
  destruct (V_eq_dec x a0) ; subst ; intuition.
Qed.

Lemma NoDup_b_1: forall (y z : Component) (n : nat) (l : nldlist),
  NoDup_b ((y, z, n) :: l) = true ->
    is_in_once y ((y, z, n) :: l).
Proof.
  intros. clear neighbors_input local_bipartite_answer.
  simpl in *.
  destruct (V_eq_dec y y) ; intuition.
  apply andb_true_iff in H.
  destruct H.
  unfold is_not_in.
  induction l ; auto.
  destruct a0. destruct p. simpl in *.
  destruct (V_eq_dec c0 c0) ; intuition.
  destruct (V_eq_dec y c0) ; intuition.
  simpl in *.
  apply andb_true_iff in H4.
  destruct H4.
  intuition.
Qed.

Lemma NoDup_b_2 : forall a0 l,
  NoDup_b (a0 :: l) = true
    -> NoDup_b l = true.
Proof.
  intros.
  unfold NoDup_b in *. destruct a0. destruct p. simpl in *.
  destruct (V_eq_dec c0 c0) ; intuition.
  apply andb_true_iff in H.
  destruct H.
  intuition.
Qed.

Lemma nld_correct1' : forall (x1 x2 : Component),
  Checker_local_output_consistent (neighbors_input x1) (nld x1) = true ->
  is_in_once x2 (nld x1) ->
  In x2 (neighbors_input x1).
Proof.
  intros.
  simpl.
  unfold Checker_local_output_consistent in H.
  apply andb_true_iff in H. destruct H.
  apply andb_true_iff in H. destruct H.
  clear H2.
  simpl in *.
  induction (nld x1).
  inversion H0.
  simpl in *.
  destruct a0. destruct p.
  apply andb_true_iff in H1. destruct H1.
  apply andb_true_iff in H. destruct H.
  destruct (V_eq_dec c0 c0).
  destruct (V_eq_dec x2 c0) ; subst.
  apply is_in_correct in H1 ; auto.
  intuition. intuition.
Qed.

Lemma nld_correct1 : forall (x1 x2 : Component),
  Checker_local_output_consistent (neighbors_input x1) (nld x1) = true ->
  In x2 (neighbors_input x1) ->
    is_in_once x2 (nld x1).
Proof.
  intros x1 x2 H H1.
  unfold Checker_local_output_consistent in H.
  apply andb_true_iff in H.
  destruct H. clear H0.
  apply andb_true_iff in H.
  destruct H.
  clear H.
  simpl in *. rewrite neighbor_input_is_correct in *. clear neighbors_input.
  induction (neighbors x1).
  inversion H1.
  simpl in *.
  destruct H1 ; subst.
  apply andb_true_iff in H0.
  destruct H0.
  clear H0 IHl.
  induction (nld x1).
  simpl in *. inversion H.
  simpl in *.
  destruct a0. destruct p. destruct (V_eq_dec x2 c0) ; subst ; intuition.
  induction n. simpl. auto.
  simpl in *. destruct a0. destruct p. destruct (V_eq_dec c0 c2) ; subst ; intuition.
  apply andb_true_iff in H0. destruct H0.
  auto.
Qed.

Lemma nld_correct0 : forall (x y z : Component) (n : nat),
  Checker_local_output_consistent (neighbors_input x) (nld x) = true ->
  In (y,z,n) (nld x) ->
    is_in_once y (nld x).
Proof.
  simpl in * ; intros.
  unfold Checker_local_output_consistent in H.
  apply andb_true_iff in H. destruct H. clear H1. apply andb_true_iff in H. destruct H. clear H1.
  induction (nld x). auto.

  assert (NoDup_b n0 = true).
  apply NoDup_b_2 in H. auto.
  inversion H0. subst.
  apply NoDup_b_1 in H. auto.
  apply IHn0 in H1 ; auto.
  clear H0 IHn0.
  destruct a0. destruct p.
  assert (c0 <> y).
  intuition. subst.
  induction n0. inversion H2. inversion H2. subst. unfold NoDup_b in H.
  simpl in H. destruct (V_eq_dec y y) ; intuition.
  destruct a0. destruct p. simpl in *. destruct (V_eq_dec y y) ; destruct (V_eq_dec c0 c0) ; destruct (V_eq_dec y c0) ; intuition.
  assert (is_not_in_b y n0 && NoDup_b n0 = true).
  apply andb_true_iff in H. destruct H.
  apply andb_true_iff in H2. destruct H2.
  apply andb_true_iff. auto. auto.
  assert (is_not_in_b y n0 && NoDup_b n0 = true).
  apply andb_true_iff in H. destruct H.
  apply andb_true_iff in H2. destruct H2.
  apply andb_true_iff. auto. auto.
  unfold is_in_once.
  destruct (V_eq_dec y c0) ; intuition.
  symmetry in e. intuition.
Qed.

Lemma neighborhood_correct : forall (v : V_set) a c x y,
  In y (A_in_neighborhood x (CA_list v a c)) ->
  a (A_ends x y).
Proof.
  clear v a c.
  intros v a c. clear neighbors_input local_bipartite_answer.
  induction c ; simpl in * ; intuition.
  + destruct (V_eq_dec x0 y) ; subst ; intuition.
    - destruct (V_eq_dec y x) ; subst ; intuition.
      simpl in *.
      intuition.
      subst. apply In_left. apply E_left.
      apply In_right.
      specialize (H3 y y0) ; auto.
    - destruct (V_eq_dec x0 x) ; subst ; intuition.
      simpl in *. intuition ; subst.
      apply In_left. apply E_right.
      apply In_right. apply (H3 x y0) ; auto.
      apply In_right. apply (H3 x0 y0) ; auto.
  + destruct (V_eq_dec x0 y) ; subst ; intuition.
    - destruct (V_eq_dec y x) ; subst ; intuition.
      simpl in *.
      intuition.
      subst. apply In_left. apply E_left.
      apply In_right.
      specialize (H3 y y0) ; auto.
    - destruct (V_eq_dec x0 x) ; subst ; intuition.
      simpl in *. intuition ; subst.
      apply In_left. apply E_right.
      apply In_right. apply (H3 x y0) ; auto.
      apply In_right. apply (H3 x0 y0) ; auto.
  + subst. intuition.
Qed.

Lemma neighborhood_correct1 : forall (v : V_set) (a : A_set) c x y,
  a (A_ends x y) ->
  In y (A_in_neighborhood x (CA_list v a c)).
Proof.
  clear v a c.
  intros. clear neighbors_input local_bipartite_answer.
  induction c ; simpl in * ; intuition.
  inversion H.
  destruct (V_eq_dec x y0) ; subst ; intuition.
  destruct (V_eq_dec y0 x0) ; subst ; intuition.
  inversion H.
  subst. inversion H5. subst. simpl. left. auto.
  subst. simpl. auto.
  subst. simpl. right. auto.
  destruct (V_eq_dec x x0) ; subst ; intuition.
  inversion H. inversion H5 ; subst ; simpl.
  auto. auto. subst. simpl. auto.
  inversion H ; subst. inversion H5 ; subst ; simpl.
  intuition. intuition.
  auto.
  destruct (V_eq_dec x y0) ; subst ; intuition.
  destruct (V_eq_dec y0 x0) ; subst ; intuition.
  inversion H.
  subst. inversion H5. subst. simpl. left. auto.
  subst. simpl. auto.
  subst. simpl. right. auto.
  destruct (V_eq_dec x x0) ; subst ; intuition.
  inversion H. inversion H5 ; subst ; simpl.
  auto. auto. subst. simpl. auto.
  inversion H ; subst. inversion H5 ; subst ; simpl.
  intuition. intuition.
  auto.
  subst. auto.
Qed.

Definition get_color (x : Component) : bool :=
  Nat.odd (distance x).

Lemma checker_bipartite_correct : (forall x : Component,
  v x ->
  (Checker_local_bipartition (distance x) (nld x) = true /\
  Checker_local_output_consistent (neighbors_input x) (nld x) = true /\
  global_output_consistent = true)) ->
  forall y : Component, gamma_1 v a c y get_color.
Proof.
  unfold gamma_1.
  intros H y v2 H0. destruct H0 as [H0 H1].
  assert (v y) as vy.
  assert (Connected v a).
  apply c.
  apply Connected_Isa_Graph in H2.
  apply (G_ina_inv1 v a H2) in H1 ; auto.
  assert (H' := H).
  specialize (H y). specialize (H' v2).
  apply H' in H0. apply H in vy. clear H' H.
  unfold get_color.
  assert (In y (neighbors v2)) as H.
  unfold neighbors.
  apply neighborhood_correct1.
  apply (G_non_directed v a) ; auto.
  apply (Connected_Isa_Graph v a) ; auto.
  clear H1.
  destruct H0 as [H0 H00]. destruct H00 as [H00 H000].
  destruct vy as [H1 H11]. destruct H11 as [H11 H111].
  apply (nld_correct1 v2 y) in H00 ; simpl in * ; auto.
  apply (nld_correct2' v2 y) in H000. clear H1 H11 H111 H.
  intuition.
  induction (nld v2).

  inversion H00.
  simpl in *. destruct a0. destruct p.
  destruct (V_eq_dec y c0) ; subst ; intuition.
  assert (eqb (Nat.odd (distance v2)) (Nat.odd (distance v2)) = true) as obvious.
  destruct (Nat.odd (distance v2)). auto. auto.
  rewrite H in *.
  rewrite obvious in *. inversion H0.

  destruct (eqb (Nat.odd (distance v2)) (Nat.odd n0)). inversion H0.
  auto.
  rewrite neighbor_input_is_correct. auto.
Qed.

Lemma Checker_tree_correct : forall (x : Component),
  v x -> (Checker_tree x (neighbors_input x) (leader x) (parent x) (distance x) (nld x)) = true -> global_output_consistent = true -> gamma_2 parent distance v a (leader x) x.
Proof.
  intros x H H0 Hglobal.
  unfold Checker_tree in H0.
  unfold gamma_2.
  unfold parent_prop.
  unfold distance_prop.
  unfold is_same in H0.
  apply andb_prop in H0.
  destruct H0 as [H0 H1].
  rewrite nld_correct2 in * ; auto.

  destruct (V_eq_dec x (leader x)) ; subst.
  simpl in *. rewrite orb_false_r in H1.
  apply andb_prop in H1.
  destruct H1. subst.
  destruct (V_eq_dec x (parent x)) ; subst ; intuition.
  right. intuition. apply beq_nat_true in H2. auto.
  inversion H1.
  inversion H1. simpl in *. split.

  left.
  assert (a (A_ends x (parent x))).
  apply andb_prop in H1.
  destruct H1.
  unfold neighbors in H1.
  apply is_in_correct in H1.
  apply (neighborhood_correct v a c) ; auto.
  assert (Graph v a).
  apply (Connected_Isa_Graph v a c).
  rewrite neighbor_input_is_correct in *. intuition.
  simpl in *.
  assert (Graph v a).
  apply (Connected_Isa_Graph v a c).
  intuition.
  apply (G_ina_inv2 _ _ H3 _ _ H2).
  apply (G_non_directed _ _ H3 _ _ H2).
  left. intuition.
  apply andb_prop in H1. destruct H1.
  apply beq_nat_true in H3.
  auto.
Qed.

Lemma all_leader_same : forall x v_random,
  (forall x : Component, v x -> (Checker_tree x (neighbors_input x) (leader x) (parent x) (distance x) (nld x)) = true /\
  Checker_local_output_consistent (neighbors_input x) (nld x) = true /\
  global_output_consistent = true) ->
  v v_random -> v x ->
  leader x = leader v_random.
Proof.
  unfold Checker_tree.
  intros x v_random H H0 H1.
  assert ({vl : V_list & {el : E_list & Walk v a v_random x vl el}}).
  apply Connected_walk ; auto.
  destruct H2. destruct s.
  induction w.
  + reflexivity.
  + apply W_endx_inv in w. remember local_bipartite_answer as lba.
    intuition.
    rewrite H3.
    assert (H' := H).
    specialize (H x) ; intuition.
    apply andb_true_iff in H.
    destruct H.

    apply orb_true_iff in H4.
    apply local_input_correct in a0.
    rename H5 into Hglobal.
    clear H3 H2.
    assert (a1 := a0).
    apply nld_correct1 in a0.
    apply nld_correct4 in a0.
    destruct a0. destruct H2.
    apply (nld_correct5 x y) in Hglobal ; auto.
    rewrite <- Hglobal. clear Hglobal.
    assert (a0 := H2).
    apply (leader_same_correct (leader x)) in H2 ; auto.
    rewrite <- H2. clear H2 v0. rename a0 into aneu.

    unfold neighbors in *.

    simpl in *.
    specialize (H' x). clear H4. intuition.
    clear a1 H3 H2 H5.
    induction (nld x).
    inversion aneu.
    simpl in *. destruct a0. destruct p.
    destruct (V_eq_dec y c0) ; destruct (V_eq_dec (leader x) c1) ; subst.
    destruct aneu.
    inversion H2. auto. symmetry.
    apply (leader_same_correct (leader x) c0 x0 n x1) ; auto.
    inversion H. destruct aneu. inversion H2.
    subst. intuition.
    auto.
    inversion H.
    specialize (H' x). intuition.
Qed.

Fixpoint get_root (v : V_set) (a : A_set) (c : Connected v a) : Component :=
  match c with
  | C_isolated x => x
  | C_leaf v' a' c' x y _ _ => get_root v' a' c'
  | C_edge v' a' c' x y _ _ _ _ _ => get_root v' a' c'
  | C_eq v' _ a' _ _ _ c' => get_root v' a' c'
  end.

Theorem checker_correct :
 ((forall (x : Component), v x ->
  Checker_local_bipartition (distance x) (nld x) = true /\ Checker_local_output_consistent (neighbors_input x) (nld x) = true /\
  global_output_consistent = true) ->
    bipartite a)

  /\

(((forall (x : Component), v x ->
  (Checker_tree x (neighbors_input x) (leader x) (parent x) (distance x) (nld x) = true /\ Checker_local_output_consistent (neighbors_input x) (nld x) = true /\
  global_output_consistent = true)) /\
  (exists (x : Component), v x /\
  Checker_local_bipartition (distance x) (nld x) = false)) -> ~ bipartite a).
Proof.
  split ; intros.
  - apply (Gamma_1_Psi1 (get_root v a c) parent distance v a c get_color).
    unfold Gamma_1.
    intros.
    apply checker_bipartite_correct ; intros ; auto.
  - assert ((forall x : Component,
     v x -> Checker_tree x (neighbors_input x) (leader x) (parent x) (distance x) (nld x) = true) /\
    (exists x : Component, v x /\ Checker_local_bipartition (distance x) (nld x) = false)).
    destruct H ; split ; intros ; auto. apply (H x) ; auto.
    assert (forall x : Component, v x -> Checker_local_output_consistent (neighbors_input x) (nld x) = true).
    intros. destruct H. apply (H x) ; auto.

    destruct H0.
    assert (forall x : Component, v x -> global_output_consistent = true).
    destruct H. clear H3.
    intros. specialize (H x). intuition. clear H.
    assert (exists v_random, v v_random) as v_r.
    apply (v_not_empty v a c).
    destruct v_r as [v_random v_r].
    assert (forall (x : Component), v x -> leader x = leader v_random).
    intros.
    apply all_leader_same ; auto. intros. intuition. apply (H3 x0) ; auto.
    assert (spanning_tree v a (leader v_random) parent distance c) as G1.
    apply G2'G2. unfold Gamma_2'.
    exists (leader v_random). unfold root_prop''.
    split ; auto. intros x vx.
    specialize (H x). assert (vxx := vx). apply H in vx. rewrite <- vx.

    apply Checker_tree_correct ; auto. apply (H3 x) ; auto.

    destruct H2 as [x H2]. destruct H2 as [H2 H4].

    apply (Gamma_implies_Psi (leader v_random) parent distance v a c) ; auto.
    apply (Gamma_2_Gamma_3_Gamma (leader v_random) parent distance v a c G1).
    unfold Gamma_3.
    unfold gamma_3.
    unfold neighbors_with_same_color.
    clear H G1 v_r v_random.
    rename H0 into H0'. rename H2 into H0.
    unfold Checker_local_bipartition in H0.
    assert (forall (x y z : Component) (n : nat),
      v x ->
      In (y,z,n) (nld x) ->
      a (A_ends x y)).
    intros.
    apply local_input_correct. simpl in *.
    apply nld_correct0 in H2 ; auto. simpl in *.
    apply nld_correct1' in H2 ; auto.
    exists x.
    specialize (H x).

    assert (forall (x y z : Component) (n : nat),
      v x ->
      In (y,z,n) (nld x) ->
      get_distance_in_list y (nld x) = (distance y)).
    intros.
    apply nld_correct2. apply (H3 x0) ; auto.
    specialize (H2 x).
    assert ({y : Component & {z : Component & In (y, z, distance y) (nld x) /\
      Nat.odd (distance x) = Nat.odd (distance y)}}).

    assert (forall (y z : Component) (n : nat),
      In (y,z,n) (nld x) ->
      is_in_once y (nld x)) as new.
    intros.
    (* specialize (Hneu x). apply Hneu in H. *)
    apply (nld_correct0 x y z n) in H5.
    auto. simpl in H3. auto.
    clear H.
    remember leader as ll. remember parent as pp. remember nld as rr.
    unfold Checker_local_bipartition in H4.
    simpl in *.
    induction (rr x) ; simpl in * ; intuition.

    inversion H4.
    destruct a0. destruct p.
    assert (H2' := H2).
    specialize (H2 c0 c1 n0). intuition. clear H6.
    destruct ((V_eq_dec c0 c0)) ; subst.
    assert ({Nat.odd (distance x) = Nat.odd (distance c0)} +
            {Nat.odd (distance x) <> Nat.odd (distance c0)}).
    apply bool_dec.
    destruct H2.
    exists c0. exists c1.
    rewrite e0 in *. intuition.
    unfold eqb in H4.
    assert ({y : Component & {z : Component &
      In (y, z, distance y) n /\
      Nat.odd (distance x) = Nat.odd (distance y)}} ->
      {y : Component & {z : Component &
      ((c0, c1, distance c0) = (y, z, distance y) \/
      In (y, z, distance y) n) /\
      Nat.odd (distance x) = Nat.odd (distance y)}}).
    intros. destruct H2. destruct s. exists x0. exists x1. intuition.
    apply H2. clear H2.
    apply IHn ; auto.
    destruct (Nat.odd (distance x)) ; destruct (Nat.odd (distance c0)) ; intuition.

    intros. specialize (H2' y z n1). specialize (new y z n1).
    destruct (V_eq_dec y c0) ; subst. remember leader as lll. remember parent as ppp.
    remember nld as rr. intuition.
    apply (is_not_in_correct n c0 z n1) in H9. intuition.
    intuition.
    clear IHn H2' H4.
    intros.
    specialize (new y z n1).
    destruct (V_eq_dec y c0) ; subst.
    assert (is_not_in c0 n). apply new. auto.
    apply (is_not_in_correct n c0 z n1) in H2. intuition.
    intuition.

    intuition. intuition.
    destruct H5. repeat destruct s.
    destruct a0.
    exists x0.
    apply H in H5 ; auto.
    assert (v x0).
    assert (Graph v a).
    apply (Connected_Isa_Graph v a c).
    apply (G_ina_inv2 v a H7 _ _ H5).
    intuition.
Qed.

Theorem checker_correct2: (forall x, v x -> Local_checker x (neighbors_input x) (leader x) (parent x) (distance x) (nld x) (local_bipartite_answer x) global_output_consistent = true) ->
  ((forall x: Component, v x -> local_bipartite_answer x = true) <-> bipartite a).
Proof.
  intros H. split ; intros H0.
  - apply checker_correct. intros x vx.
    unfold Local_checker in H. specialize (H x).
    apply andb_true_iff in H. destruct H as [H H'].
    apply andb_true_iff in H. destruct H as [H H''].
    apply andb_true_iff in H. destruct H as [H H'''].
    apply eqb_prop in H. specialize (H0 x). rewrite H0 in H.
    intuition. auto. auto.
  - intros x vx.
    unfold Local_checker in H. assert (Hcopy := H). specialize (H x).
    apply andb_true_iff in H ; auto. destruct H as [H H'].
    apply andb_true_iff in H. destruct H as [H H''].
    apply andb_true_iff in H. destruct H as [H H'''].
    apply eqb_prop in H. rewrite <- H.
    assert (~ (exists (x : Component), v x /\ Checker_local_bipartition (distance x) (nld x) = false)) as H1.
    unfold not. intros.
    assert (((forall (x : Component), v x ->
        (Checker_tree x (neighbors_input x) (leader x) (parent x) (distance x) (nld x) = true /\ Checker_local_output_consistent (neighbors_input x) (nld x) = true /\
        global_output_consistent = true)) /\
        (exists (x : Component), v x /\
        Checker_local_bipartition (distance x) (nld x) = false))) as H2.
    split ; intros. specialize (Hcopy x0).
    apply andb_true_iff in Hcopy. destruct Hcopy as [Hcopy Hcopy'].
    apply andb_true_iff in Hcopy. destruct Hcopy as [Hcopy Hcopy''].
    apply andb_true_iff in Hcopy. destruct Hcopy as [Hcopy Hcopy'''].
    intuition. auto.
    destruct H1 as [proof H1]. exists proof ; auto.
    apply checker_correct in H2. intuition.
    clear - H1 vx.

    assert (~(exists x : Component, v x /\ ~Checker_local_bipartition (distance x) (nld x) = true)).
    intuition. apply H1.
    destruct H as [proof H]. exists proof. intuition.
    destruct (Checker_local_bipartition (distance proof) (nld proof)) ; simpl in * ; auto.
    intuition.
    clear H1.
    unfold not at 1 in H.
    clear - H vx.
    assert (~~ Checker_local_bipartition (distance x) (nld x) = true -> Checker_local_bipartition (distance x) (nld x) = true).
    tauto.
    assert ((Checker_local_bipartition (distance x) (nld x) <> true -> False) -> Checker_local_bipartition (distance x) (nld x) = true).
    destruct (Checker_local_bipartition (distance x) (nld x)) ; simpl in * ; auto.
    apply H1.
    intros.
    apply H.
    exists x. auto.
Qed.

End Checker_proofs.


Require Import Reals.
Require Import PolSBase.
Require Import PolAuxList.
Require Import PolAux.

Definition Rconvert_back (e : PExpr Z) (l : list R) : R :=
   convert_back Z R R0 Rplus Rminus Rmult Ropp Z2R l e.

Definition Rsimpl_minus (e : PExpr Z) :=
    (simpl_minus
      Z Zplus Zmult Z.opp Z0 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div e).

Definition Rsimpl (e : PExpr Z) :=
    (simpl
      Z Zplus Zmult Z.opp Z0 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div e).

Ltac
rs term1 term2 :=
let term := constr:(Rminus term1 term2) in
let rfv := FV RCst Rplus Rmult Rminus Ropp term (@nil R) in
let fv := Trev rfv in
let expr1 := mkPolexpr Z RCst Rplus Rmult Rminus Ropp term1 fv in
let expr2 := mkPolexpr Z RCst Rplus Rmult Rminus Ropp term2 fv in
let re := eval vm_compute in (Rsimpl_minus (PEsub expr1 expr2)) in
let expr3 := match re with (PEsub ?X1 _) => X1 end in
let expr4 := match re with (PEsub _ ?X1 ) => X1 end in
let re1 :=  constr:(PEsub expr1 expr3) in
let
 re1' :=
  eval
     unfold
      Rconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl, Z2R, P2R in (Rconvert_back (PEadd re1 expr3) fv) in
let re1'' := eval lazy beta in re1' in
let
 re2' :=
  eval
     unfold
      Rconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl, Z2R, P2R in (Rconvert_back (PEadd re1 expr4) fv) in
let re2'' := eval lazy beta in re2' in
replace2_tac term1 term2 re1'' re2''; [idtac| ring | ring].

Ltac
rpols :=
match goal with
| |- (?X1 = ?X2)%R =>
rs X1 X2; try apply Rplus_eq_compat_l
| |- (?X1 <> ?X2)%R =>
rs X1 X2; apply Rplus_neg_compat_l
| |- Rlt ?X1 ?X2 =>
rs X1 X2; apply Rplus_lt_compat_l
| |- Rgt ?X1 ?X2 =>
rs X1 X2; apply Rplus_gt_compat_l
| |- Rle ?X1 ?X2 =>
rs X1 X2; apply Rplus_le_compat_l
| |- Rge ?X1 ?X2 =>
rs X1 X2; apply Rplus_ge_compat_l
| _ => fail end.

Ltac
hyp_rpols H :=
generalize H;
let tmp := fresh "tmp" in
match (type of H) with
   (?X1 = ?X2)%R =>
rs X1 X2; intros tmp; generalize (Rplus_eq_reg_l _ _ _ tmp); clear H tmp; intro H
|  (?X1 <> ?X2)%nat =>
rs X1 X2; intros tmp; generalize (Rplus_neg_reg_l _ _ _ tmp); clear H tmp; intro H
|  Rlt ?X1 ?X2 =>
rs X1 X2; intros tmp; generalize (Rplus_lt_reg_r _ _ _ tmp); clear H tmp; intro H
|  Rgt ?X1 ?X2 =>
rs X1 X2; intros tmp; generalize (Rplus_gt_reg_l _ _ _ tmp); clear H tmp; intro H
|  Rle ?X1 ?X2 =>
rs X1 X2; intros tmp; generalize (Rplus_le_reg_l _ _ _ tmp); clear H tmp; intro H
|  Rge ?X1 ?X2 =>
rs X1 X2; intros tmp; generalize (Rplus_ge_reg_l _ _ _ tmp); clear H tmp; intro H
| _ => fail end.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Leo Ducas, 2007-08-06

Strongly Connected Components (SCC) of a graph seen as a relation
*)

Set Implicit Arguments.

From CoLoR Require Import Cycle Path ListUtil RelUtil LogicUtil.

Section S.

  Variable A : Type.

  Section definition.

    Variable R : relation A.

(** Definition of SCC seen as a relation : are x and y in the same SCC ? *)

    Definition SCC x y := R! x y /\ R! y x.

(** Basic properties *)

    Lemma SCC_trans : forall x y z, SCC x y -> SCC y z -> SCC x z.

    Proof.
      intros. unfold SCC in *. destruct H; destruct H0.
      split; eapply t_trans; eauto; auto.
    Qed.

    Lemma SCC_sym : forall x y, SCC x y -> SCC y x.

    Proof. intros. unfold SCC in *. destruct H; split; hyp. Qed.

    Lemma cycle_in_SCC : forall x l, cycle R x l -> forall y, In y l -> SCC x y.

    Proof.
      intros. unfold SCC. unfold cycle in H.
      gen (in_elim H0); intros.
      destruct H1; destruct H1; subst.
      apply path_app_elim in H.
      destruct H.
      apply path_clos_trans in H; apply path_clos_trans in H1.
      split; auto.
    Qed.

    Lemma SCC_in_cycle : forall x y, SCC x y -> exists l, cycle R x l /\ In y l.

    Proof.
      intros.
      destruct H.
      apply clos_trans_path in H; apply clos_trans_path in H0.
      destruct H; destruct H0.
      exists (x0++y::x1).
      split; auto with *.
      unfold cycle.
      apply path_app; auto.
    Qed.

    Lemma cycle_in_SCC_bound : forall x l, cycle R x l -> SCC x x.

    Proof.
      intros; unfold SCC; unfold cycle in H.
      split; apply path_clos_trans in H; auto.
    Qed.

  End definition.

  Section inclusion.

    Variables R1 R2 : relation A.

    Lemma SCC_incl : R1 << R2 -> SCC R1 << SCC R2.

    Proof.
      intros.
      unfold inclusion; unfold SCC.
      intros.
      destruct H0.
      assert (R1! << R2!).
      apply tc_incl; hyp.
      split; unfold inclusion in H2.
      apply (H2 x y); hyp.
      apply (H2 y x); hyp.
    Qed.

  End inclusion.

End S.