(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import Bool List Int63 PArray Psatz.
Require Import Misc State SMT_terms FArray SMT_classes.

Import Form.
Import Atom.

Local Open Scope array_scope.
Local Open Scope int63_scope.

Section certif.

  Variable t_form : PArray.array Form.form.
  Variable t_atom : PArray.array Atom.atom.

  Local Notation get_atom := (PArray.get t_atom) (only parsing).
  Local Notation get_form := (PArray.get t_form) (only parsing).

  Definition check_roweq lres :=
    if Lit.is_pos lres then
      match get_form (Lit.blit lres) with
      | Fatom a =>
        match get_atom a with
        | Abop (BO_eq te) xa v =>
          match get_atom xa with
          | Abop (BO_select ti1 te1) sa i =>
            match get_atom sa with
            | Atop (TO_store ti2 te2) fa j v2 =>
              if Typ.eqb ti1 ti2 &&
                 Typ.eqb te te1 && Typ.eqb te te2 &&
                 (i == j) && (v == v2)
              then lres::nil
              else C._true
            | _ => C._true
            end
          | _ => C._true
          end
        | _ => C._true
        end
      | _ => C._true
      end
    else C._true.

  Definition store_of_me a b :=
    match get_atom b with
    | Atop (TO_store ti te) a' i _ =>
      if (a' == a) then Some (ti, te, i) else None
    | _ => None
    end.

  Definition check_rowneq cl :=
    match cl with
    | leqij :: leqrow :: nil =>
      if Lit.is_pos leqij && Lit.is_pos leqrow then
        match get_form (Lit.blit leqij), get_form (Lit.blit leqrow) with
        | Fatom eqij, Fatom eqrow =>
          match get_atom eqij, get_atom eqrow with
          | Abop (BO_eq ti) i j, Abop (BO_eq te) xa x =>
            match get_atom xa, get_atom x with
            | Abop (BO_select ti1 te1) sa j1, Abop (BO_select ti2 te2) sa2 j2 =>
              if Typ.eqb ti ti1 && Typ.eqb ti ti2 &&
                 Typ.eqb te te1 && Typ.eqb te te2 then
                match store_of_me sa sa2, store_of_me sa2 sa with
                | Some (ti3, te3, i1), None | None, Some (ti3, te3, i1) =>
                  if Typ.eqb ti ti3 && Typ.eqb te te3 &&
                     (((i1 == i) && (j1 == j) && (j2 == j)) ||
                      ((i1 == j) && (j1 == i) && (j2 == i))) then
                    cl
                  else C._true
                | _, _ => C._true
                end
              else C._true
            | _, _ => C._true
            end
          | _, _ => C._true
          end
        | _, _ => C._true
        end
      else C._true
    | _ => C._true
    end.

  Definition eq_sel_sym ti te a b sela selb :=
    match get_atom sela, get_atom selb with
    | Abop (BO_select ti1 te1) a' d1, Abop (BO_select ti2 te2) b' d2 =>
      Typ.eqb ti ti1 && Typ.eqb ti ti2 &&
      Typ.eqb te te1 && Typ.eqb te te2 &&
      (a == a') && (b == b') && (d1 == d2) &&
      match get_atom d1 with
      | Abop (BO_diffarray ti3 te3) a3 b3 =>
        Typ.eqb ti ti3 && Typ.eqb te te3 &&
        (a3 == a) && (b3 == b)
      | _ => false
      end
    | _, _ => false
    end.

  Definition check_ext lres :=
    if Lit.is_pos lres then
      match get_form (Lit.blit lres) with
      | For args =>
        if PArray.length args == 2 then
          let l1 := args.[0] in
          let l2 := args.[1] in
          if Lit.is_pos l1 && negb (Lit.is_pos l2) then
            match get_form (Lit.blit l1), get_form (Lit.blit l2) with
            | Fatom eqa, Fatom eqsel =>
              match get_atom eqa, get_atom eqsel with
              | Abop (BO_eq (Typ.TFArray ti te)) a b, Abop (BO_eq te') sela selb =>
                if Typ.eqb te te' && (eq_sel_sym ti te a b sela selb ||
                                      eq_sel_sym ti te b a sela selb) then
                  lres :: nil
                else C._true
              | _, _ => C._true
              end
            | _, _ => C._true
            end
          else C._true
        else C._true
      | _ => C._true
      end
    else C._true.

  Section Correct.

    Variables (t_i : array typ_compdec)
              (t_func : array (Atom.tval t_i))
              (ch_atom : Atom.check_atom t_atom)
              (ch_form : Form.check_form t_form)
              (wt_t_atom : Atom.wt t_i t_func t_atom).

    Local Notation check_atom :=
      (check_aux t_i t_func (get_type t_i t_func t_atom)).

    Local Notation interp_form_hatom :=
      (Atom.interp_form_hatom t_i t_func t_atom).

    Local Notation interp_form_hatom_bv :=
      (Atom.interp_form_hatom_bv t_i t_func t_atom).

    Local Notation rho :=
      (Form.interp_state_var interp_form_hatom interp_form_hatom_bv t_form).

    Local Notation t_interp := (t_interp t_i t_func t_atom).

    Local Notation interp_atom := (interp_aux t_i t_func (get t_interp)).

    Let wf_t_atom : Atom.wf t_atom.
    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.

    Let def_t_atom : default t_atom = Atom.Acop Atom.CO_xH.
    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.

    Let def_t_form : default t_form = Form.Ftrue.
    Proof.
      destruct (Form.check_form_correct
                  interp_form_hatom interp_form_hatom_bv _ ch_form) as [H _];
        destruct H; auto.
    Qed.

    Let wf_t_form : Form.wf t_form.
    Proof.
      destruct (Form.check_form_correct
                  interp_form_hatom interp_form_hatom_bv _ ch_form) as [H _];
        destruct H; auto.
    Qed.

    Let wf_rho : Valuation.wf rho.
    Proof.
      destruct (Form.check_form_correct
                  interp_form_hatom interp_form_hatom_bv _ ch_form); auto.
    Qed.

    Let rho_interp : forall x : int,
        rho x = Form.interp interp_form_hatom interp_form_hatom_bv t_form (t_form.[ x]).
    Proof. intros x;apply wf_interp_form;trivial. Qed.

    Definition wf := PArray.forallbi lt_form t_form.

    Hypothesis wf_t_i : wf.
    Notation atom := int (only parsing).

    Lemma valid_check_roweq lres : C.valid rho (check_roweq lres).
    Proof.
      unfold check_roweq.
      case_eq (Lit.is_pos lres); intro Heq; simpl; try now apply C.interp_true.
      case_eq (t_form .[ Lit.blit lres]); try (intros; now apply C.interp_true).
      intros a Heq2.
      case_eq (t_atom .[ a]); try (intros; now apply C.interp_true).
      intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] a1 a2 Heq3; try (intros; now apply C.interp_true).
      case_eq (t_atom .[ a1]); try (intros; now apply C.interp_true).
      intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] b1 b2 Heq4; try (intros; now apply C.interp_true).
      case_eq (t_atom .[ b1]); try (intros; now apply C.interp_true).
      intros [ ] c1 c2 c3 Heq5.
      (* roweq *)
      - case_eq (Typ.eqb t0 t2 && Typ.eqb t t1 &&
             Typ.eqb t t3 && (b2 == c2) && (a2 == c3)); simpl; intros Heq6; try (now apply C.interp_true).

        unfold C.valid. simpl. rewrite orb_false_r.
        unfold Lit.interp. rewrite Heq.
        unfold Var.interp.
        rewrite wf_interp_form; trivial. rewrite Heq2. simpl.

        rewrite !andb_true_iff in Heq6.
        destruct Heq6 as ((((Heq6a, Heq6b), Heq6c), Heq6d), Heq6e).

        apply Typ.eqb_spec in Heq6a.
        apply Typ.eqb_spec in Heq6b.
        apply Typ.eqb_spec in Heq6c.
        apply Int63Properties.eqb_spec in Heq6d.
        apply Int63Properties.eqb_spec in Heq6e.

        pose proof (rho_interp (Lit.blit lres)) as Hrho.
        rewrite Heq2 in Hrho. simpl in Hrho.

        generalize wt_t_atom. unfold Atom.wt. unfold is_true.
        rewrite PArray.forallbi_spec;intros.

        pose proof (H a). assert (a < PArray.length t_atom).
        apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq3. easy.
        specialize (H0 H1). simpl in H0.
        rewrite Heq3 in H0. simpl in H0.
        rewrite !andb_true_iff in H0. destruct H0. destruct H0.
        unfold get_type' in H2, H3, H0. unfold v_type in H2, H3, H0.

        case_eq (t_interp .[ a]).
          intros v_typea v_vala Htia. rewrite Htia in H0.
          case_eq v_typea; intros; rewrite H4 in H0; try now contradict H0.

        case_eq (t_interp .[ a1]).
          intros v_typea1 v_vala1 Htia1. rewrite Htia1 in H3.
        case_eq (t_interp .[ a2]).
          intros v_typea2 v_vala2 Htia2. rewrite Htia2 in H2.
        rewrite Atom.t_interp_wf in Htia; trivial.
        rewrite Atom.t_interp_wf in Htia1; trivial.
        rewrite Atom.t_interp_wf in Htia2; trivial.
        rewrite Heq3 in Htia. simpl in Htia.
        rewrite !Atom.t_interp_wf in Htia; trivial.
        rewrite Htia1, Htia2 in Htia. simpl in Htia.

        apply Typ.eqb_spec in H2. apply Typ.eqb_spec in H3.

        generalize dependent v_vala1. generalize dependent v_vala2.
        generalize dependent v_vala.

        rewrite H2, H3, H4.
        rewrite !Typ.cast_refl. intros. simpl in Htia.
        unfold Bval in Htia.

        specialize (Atom.Bval_inj2 t_i (Typ.Tbool) (Typ.i_eqb t_i t v_vala1 v_vala2) (v_vala)).
        intros. specialize (H5 Htia).

        pose proof (H a1). assert (a1 < PArray.length t_atom).
        apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq4. easy.
        specialize (H6 H7). simpl in H6.
        rewrite Heq4 in H6. simpl in H6.
        rewrite !andb_true_iff in H6.
        destruct H6 as ((H6a, H6b), H6c).
        apply Typ.eqb_spec in H6a.
        apply Typ.eqb_spec in H6b.
        apply Typ.eqb_spec in H6c.

        pose proof (H b1). assert (b1 < PArray.length t_atom).
        apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq5. easy.
        specialize (H6 H8). simpl in H6.
        rewrite Heq5 in H6. simpl in H6.

        rewrite !andb_true_iff in H6.
        destruct H6 as (((H6d, H6e), H6f), H6h).
        apply Typ.eqb_spec in H6e.
        apply Typ.eqb_spec in H6f.
        apply Typ.eqb_spec in H6h.

        unfold get_type' in H6b, H6c, H6d.
        unfold v_type in H6b, H6c, H6d.
        case_eq (t_interp .[ b2]).
          intros v_typeb2 v_valb2 Htib2. rewrite Htib2 in H6c.
        rewrite Atom.t_interp_wf in Htib2; trivial.
        case_eq (t_interp .[ b1]).
          intros v_typeb1 v_valb1 Htib1. rewrite Htib1 in H6d.
        rewrite Atom.t_interp_wf in Htib1; trivial.
        rewrite <- Heq6d, <- Heq6e in *.

        rewrite Heq5 in Htib1. simpl in Htib1.

        generalize dependent v_valb2.

        rewrite H6c. intros.
        unfold Atom.interp_form_hatom, interp_hatom.
        rewrite !Atom.t_interp_wf; trivial.
        rewrite Heq3. simpl.
        rewrite !Atom.t_interp_wf; trivial.
        rewrite Heq4, Htia2. simpl.
        rewrite !Atom.t_interp_wf; trivial.
        rewrite Heq5, Htib2. simpl.
        rewrite Htib1. simpl.

        rewrite Typ.cast_refl.
        unfold apply_binop.
        rewrite Typ.cast_refl.

        case_eq (t_interp .[ b1]); intros.
        pose proof H6.
        rewrite H6 in H6b.
        rewrite !Atom.t_interp_wf in H6; trivial.
        rewrite Heq5 in H6.
        simpl in H6. rewrite H6 in Htib1.
        inversion Htib1.

        generalize dependent v_val0.

        rewrite H6b.
        intros. rewrite Typ.cast_refl.
        simpl.
        unfold get_type' in H6a.
        unfold v_type in H6a.
        case_eq (t_interp .[ a1]).
        intros.
        rewrite H10 in H6a.
        rewrite !Atom.t_interp_wf in H10; trivial.
        rewrite H10 in Htia1.
        inversion Htia1.
        rewrite <- H6a in H14.

        generalize dependent v_val0.

        rewrite H14.
        intros.
        rewrite Typ.cast_refl.
        simpl.

        unfold apply_terop in H6.
        unfold get_type', v_type in H6e, H6f, H6h.
        case_eq ( t_interp .[ c1]); intros.
        rewrite H13 in H6e.
        rewrite H13 in H6.
        case_eq (t_interp .[ b2]); intros.
        rewrite H16 in H6f.
        rewrite H16 in H6.
        case_eq (t_interp .[ a2]); intros.
        rewrite H17 in H6h.
        rewrite H17 in H6.

        generalize dependent v_val2. generalize dependent v_val3.
        generalize dependent v_val4.

        rewrite H6e, H6f, H6h.
        rewrite !Typ.cast_refl.
        intros.
        unfold Bval in H6.

        rewrite <- H11 in H6d.
        rewrite H6b in H6d.
        rewrite andb_true_iff in H6d.
        destruct H6d as (H6d1, H6d2).
        apply Typ.eqb_spec in H6d1.
        apply Typ.eqb_spec in H6d2.

        generalize dependent v_val2. generalize dependent v_val3.
        generalize dependent v_val4.

        rewrite H6d1, H6d2, H14.
        intros.
        specialize (Atom.Bval_inj2 t_i (Typ.TFArray t0 t)
          (@store _ _
                  (Typ.dec_interp t_i t0)
               _ _ _ (Typ.comp_interp t_i t) _
               v_val2 v_val3 v_val4) v_val0).
        intros. specialize (H18 H6).
        rewrite <- H18.

        rewrite !Atom.t_interp_wf in H16; trivial.
        rewrite H16 in Htib2.
        specialize (Atom.Bval_inj2 t_i t0 v_val3 v_valb2).
        intros. specialize (H19 Htib2).
        rewrite <- H19.

        rewrite !Atom.t_interp_wf in H17; trivial.
        rewrite H17 in Htia2.
        specialize (Atom.Bval_inj2 t_i t v_val4 v_vala2).
        intros. specialize (H20 Htia2).
        rewrite <- H20.
        apply Typ.i_eqb_spec.
        apply (read_over_write (elt_dec:=(@EqbToDecType _ (@Eqb _
                   (projT2 (Typ.interp_compdec_aux t_i _)))))).
    Qed.

    Lemma valid_check_rowneq cl : C.valid rho (check_rowneq cl).
    Proof.
        unfold check_rowneq.
        case_eq (cl); [ intros | intros i l ]; simpl; try now apply C.interp_true.
        case_eq (l); [ intros | intros j xsl ]; simpl; try now apply C.interp_true.
        case_eq (xsl); intros; simpl; try now apply C.interp_true.
        case_eq (Lit.is_pos i); intro Heq; simpl; try now apply C.interp_true.
        case_eq (Lit.is_pos j); intro Heq2; simpl; try now apply C.interp_true.
        case_eq (t_form .[ Lit.blit i]); try (intros; now apply C.interp_true).
        intros a Heq3.
        case_eq (t_form .[ Lit.blit j]); try (intros; now apply C.interp_true).
        intros b Heq4.
        case_eq (t_atom .[ a]); try (intros; now apply C.interp_true).
        intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] a1 a2 Heq5; try (intros; now apply C.interp_true).
        case_eq (t_atom .[ b]); try (intros; now apply C.interp_true).
        intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] b1 b2 Heq6; try (intros; now apply C.interp_true).
        case_eq (t_atom .[ b1]); try (intros; now apply C.interp_true).
        intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] c1 c2 Heq7; try (intros; now apply C.interp_true).
        case_eq (t_atom .[ b2]); try (intros; now apply C.interp_true).
        intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] d1 d2 Heq8; try (intros; now apply C.interp_true).
        case_eq (Typ.eqb t t1 && Typ.eqb t t3 && Typ.eqb t0 t2 && Typ.eqb t0 t4);
          try (intros; now apply C.interp_true). intros Heq9.

        rewrite !andb_true_iff in Heq9.
        destruct Heq9 as (((Heq9a, Heq9b), Heq9c), Heq9d).

        apply Typ.eqb_spec in Heq9a.
        apply Typ.eqb_spec in Heq9b.
        apply Typ.eqb_spec in Heq9c.
        apply Typ.eqb_spec in Heq9d.
        subst t1 t2 t3 t4.

        generalize wt_t_atom. unfold Atom.wt. unfold is_true.
        rewrite PArray.forallbi_spec;intros.

        assert (H15: b1 < PArray.length t_atom).
        apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq7. discriminate.
        assert (H20: b2 < PArray.length t_atom).
        apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq8. discriminate.
        assert (H9: b < PArray.length t_atom).
        apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq6. discriminate.
        assert (H3: a < PArray.length t_atom).
        apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq5. discriminate.

        apply H2 in H15.
        apply H2 in H20.
        apply H2 in H3.
        apply H2 in H9.

        rewrite Heq7 in H15.
        rewrite Heq8 in H20.
        rewrite Heq6 in H9.
        rewrite Heq5 in H3.

        simpl in H15, H20, H3, H9.

        rewrite !andb_true_iff in H15, H20, H3, H9.

        destruct H3 as ((H3, H6), H5).
        destruct H9 as ((H9, H12), H11).
        destruct H15 as ((H15, H18), H17).
        destruct H20 as ((H20, H23), H22).
        unfold get_type', v_type in H3, H5, H6, H9, H11, H12, H15, H17, H18, H20, H22, H23.

        case_eq (t_interp .[ a]).
          intros v_typea v_vala Htia. rewrite Htia in H3.
          case_eq v_typea; intros; rewrite H4 in H3; try now contradict H3.

        case_eq (t_interp .[ a1]).
          intros v_typea1 v_vala1 Htia1. rewrite Htia1 in H6.
        case_eq (t_interp .[ a2]).
            intros v_typea2 v_vala2 Htia2. rewrite Htia2 in H5.
        rewrite Atom.t_interp_wf in Htia, Htia1, Htia2; trivial.
        rewrite Heq5 in Htia. simpl in Htia.
        rewrite !Atom.t_interp_wf in Htia; trivial.
        rewrite Htia1, Htia2 in Htia. simpl in Htia.

        apply Typ.eqb_spec in H5. apply Typ.eqb_spec in H6.

        generalize dependent v_vala1. generalize dependent v_vala2.
        generalize dependent v_vala.
        rewrite H5, H6, H4.
        rewrite !Typ.cast_refl. intros. simpl in Htia.
        unfold Bval in Htia.

        specialize (Atom.Bval_inj2 t_i (Typ.Tbool) (Typ.i_eqb t_i t v_vala1 v_vala2) (v_vala)).
        intros H8. specialize (H8 Htia).

        case_eq (t_interp .[ b]).
          intros v_typeb v_valb Htib. rewrite Htib in H9;
          case_eq v_typeb; intros; rewrite H7 in H9; try now contradict H9.

        case_eq (t_interp .[ b1]).
          intros v_typeb1 v_valb1 Htib1. rewrite Htib1 in H12.
        case_eq (t_interp .[ b2]).
            intros v_typeb2 v_valb2 Htib2. rewrite Htib2 in H11.
        rewrite Atom.t_interp_wf in Htib, Htib1, Htib2; trivial.
        rewrite Heq6 in Htib. simpl in Htib.
        rewrite !Atom.t_interp_wf in Htib; trivial.
        rewrite Htib1, Htib2 in Htib. simpl in Htib.

        apply Typ.eqb_spec in H11. apply Typ.eqb_spec in H12.

        generalize dependent v_valb1. generalize dependent v_valb2.
        generalize dependent v_valb.
        rewrite H11, H12, H7.
        rewrite !Typ.cast_refl. intros. simpl in Htib.
        unfold Bval in Htib.

        specialize (Atom.Bval_inj2 t_i (Typ.Tbool) (Typ.i_eqb t_i t0 v_valb1 v_valb2) (v_valb)).
        intros H14. specialize (H14 Htib).

       case_eq (t_interp .[ b1]).
          intros v_typeb1' v_valb1' Htib1'. rewrite Htib1' in H15.

        case_eq (t_interp .[ c1]).
          intros v_typec1 v_valc1 Htic1. rewrite Htic1 in H18.
        case_eq (t_interp .[ c2]).
            pose proof Htib1' as Htib1''.
            intros v_typec2 v_valc2 Htic2. rewrite Htic2 in H17.
            pose proof Htic2 as Htic2''.
        rewrite Atom.t_interp_wf in Htib1', Htic1, Htic2; trivial.
        rewrite Heq7 in Htib1'. simpl in Htib1'.
        rewrite !Atom.t_interp_wf in Htib1'; trivial.
        rewrite Htic1, Htic2 in Htib1'. simpl in Htib1'.

        apply Typ.eqb_spec in H17. apply Typ.eqb_spec in H18.
        apply Typ.eqb_spec in H15.

        generalize dependent v_valc1. generalize dependent v_valc2.
        generalize dependent v_valb1'.
        rewrite H17, H18.
        rewrite !Typ.cast_refl. intros. simpl in Htib1'.
        unfold Bval in Htib1'.

        generalize dependent v_valc1. generalize dependent v_valc2.
        generalize dependent v_valb1'.

        rewrite H15. intros.
        specialize (Atom.Bval_inj2 t_i (v_typeb1') (select v_valc1 v_valc2) (v_valb1')).
        intro H19. specialize (H19 Htib1').

        (* b2 *)
       case_eq (t_interp .[ b2]).
          intros v_typeb2' v_valb2' Htib2'. rewrite Htib2' in H20.

        case_eq (t_interp .[ d1]).
          intros v_typed1 v_vald1 Htid1. rewrite Htid1 in H23.
        case_eq (t_interp .[ d2]).
            pose proof Htib2' as Htib2''.
            intros v_typed2 v_vald2 Htid2. rewrite Htid2 in H22.
        rewrite Atom.t_interp_wf in Htib2', Htid1, Htid2; trivial.
        rewrite Heq8 in Htib2'. simpl in Htib2'.
        rewrite !Atom.t_interp_wf in Htib2'; trivial.
        rewrite Htid1, Htid2 in Htib2'. simpl in Htib2'.

        apply Typ.eqb_spec in H22. apply Typ.eqb_spec in H23.
        apply Typ.eqb_spec in H20.

        generalize dependent v_vald1. generalize dependent v_vald2.
        generalize dependent v_valb2'.
        rewrite H22, H23.
        rewrite !Typ.cast_refl. intros. simpl in Htib2'.
        unfold Bval in Htib2'.

        generalize dependent v_vald1. generalize dependent v_vald2.
        generalize dependent v_valb2'.

        rewrite H20. intros.
        specialize (Atom.Bval_inj2 t_i (v_typeb2') (select v_vald1 v_vald2) (v_valb2')).
        intro H24. specialize (H24 Htib2').

        case_eq (store_of_me c1 d1);
          case_eq (store_of_me d1 c1);
          try (intros; try(destruct p0, p0); now apply C.interp_true).

        - unfold store_of_me.
          intro HT1. clear HT1.
          case_eq (t_atom .[ d1]); try discriminate.
          intros [ t5 t6 ] e1 e2 e3 Heq10 [[ti3 te3] i1].
          case_eq (e1 == c1); try discriminate. intros Heq11c.
          intro HT.
          injection HT. intros. subst i1 te3 ti3. clear HT.

          case_eq (
              Typ.eqb t t5 && Typ.eqb v_typeb1' t6 &&
                      ((e2 == a1) && (c2 == a2) && (d2 == a2) || (e2 == a2) && (c2 == a1) && (d2 == a1)));
            simpl; intros Heq11; try (now apply C.interp_true).

          unfold C.valid. simpl. rewrite orb_false_r.

          case_eq (Lit.interp rho i). intros isit.
          easy. intros isif. rewrite orb_false_l.
          specialize (rho_interp ( Lit.blit i)).
          rewrite Heq3 in rho_interp.
          simpl in rho_interp.
          unfold Lit.interp in isif.
          rewrite Heq in isif. unfold Var.interp in isif.
          rewrite rho_interp in isif.
          unfold Atom.interp_form_hatom, interp_hatom in isif.
          rewrite Atom.t_interp_wf in isif; trivial.
          rewrite Heq5 in isif.
          simpl in isif.
          unfold interp_bool in isif.

          unfold Lit.interp. rewrite Heq2.
          unfold Var.interp.
          rewrite !wf_interp_form; trivial. rewrite Heq4. simpl.

          rewrite !andb_true_iff in Heq11.
          destruct Heq11 as ((Heq11a, Heq11b), Heq11d).
          rewrite !orb_true_iff in Heq11d.

          apply Typ.eqb_spec in Heq11a.
          apply Typ.eqb_spec in Heq11b.
          apply Int63Properties.eqb_spec in Heq11c.
          rewrite !andb_true_iff in Heq11d.
          rewrite !Int63Properties.eqb_spec in Heq11d.

          rewrite !Atom.t_interp_wf in isif; trivial.
          rewrite Htia1, Htia2 in isif. simpl in isif.
          unfold Bval in isif.

          assert (H25: d1 < PArray.length t_atom).
          apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq10. discriminate.
          apply H2 in H25.
          rewrite Heq10 in H25.
          simpl in H25.
          rewrite !andb_true_iff in H25.
          destruct H25 as (((H25, H29), H28), H27).
          unfold get_type', v_type in H25, H27, H28, H29.

          case_eq (t_interp .[ d1]).
          intros v_typed1' v_vald1' Htid1'. rewrite Htid1' in H25.
          case_eq v_typed1'; intros; rewrite H10 in H25; try now contradict H25.
          rewrite andb_true_iff in H25; destruct H25 as (H25a, H25b).

          case_eq (t_interp .[ e1]).
          intros v_typee1 v_vale1 Htie1. rewrite Htie1 in H29.
          case_eq (t_interp .[ e2]).
          intros v_typee2 v_vale2 Htie2. rewrite Htie2 in H28.
          case_eq (t_interp .[ e3]).
          intros v_typee3 v_vale3 Htie3. rewrite Htie3 in H27.
          pose proof Htid1' as Htid1''.
          rewrite Atom.t_interp_wf in Htid1', Htie1, Htie2, Htie3; trivial.
          rewrite Heq10 in Htid1'. simpl in Htid1'.
          rewrite !Atom.t_interp_wf in Htid1'; trivial.
          rewrite Htie1, Htie2, Htie3 in Htid1'. simpl in Htid1'.

          apply Typ.eqb_spec in H25a. apply Typ.eqb_spec in H25b.
          apply Typ.eqb_spec in H27.  apply Typ.eqb_spec in H28.
          apply Typ.eqb_spec in H29.

          generalize dependent v_vale1. generalize dependent v_vale2.
          generalize dependent v_vale3. generalize dependent v_vald1'.
          rewrite H27, H28, H29.
          rewrite !Typ.cast_refl. intros. simpl in Htid1'.
          unfold Bval in Htid1'.

          generalize dependent v_vale1. generalize dependent v_vale2.
          generalize dependent v_vale3. generalize dependent v_vald1'.

          rewrite H25a, H25b, H10. intros.
          specialize (Atom.Bval_inj2 t_i (Typ.TFArray t1 t2)
            (@store _ _
                    (Typ.dec_interp t_i t1)
                   _ _ _ (Typ.comp_interp t_i t2) _
                   v_vale1 v_vale2 v_vale3) (v_vald1')).
          intro H25. specialize (H25 Htid1').

          unfold Atom.interp_form_hatom, interp_hatom.
          rewrite !Atom.t_interp_wf; trivial.
          rewrite Heq6. simpl.
          rewrite !Atom.t_interp_wf; trivial.
          rewrite Heq7, Heq8. simpl.
          rewrite !Atom.t_interp_wf; trivial.

          rewrite Htic1, Htic2, Htid1, Htid2.
          subst. intros. simpl.
          rewrite !Typ.cast_refl.
          unfold apply_binop.
          unfold Bval.
          rewrite !Atom.t_interp_wf in Htib1''; trivial.
          rewrite Htib1 in Htib1''.
          inversion Htib1''.
          rewrite !Atom.t_interp_wf in Htib2''; trivial.
          rewrite Htib2 in Htib2''.
          inversion Htib2''.

          rewrite !Typ.cast_refl.

          unfold interp_bool. rewrite Typ.cast_refl.
          apply Typ.i_eqb_spec.

          rewrite !Atom.t_interp_wf in Htid1''; trivial.
          rewrite Htid1 in Htid1''.
          inversion Htid1''.

          subst.
          rewrite (Atom.Bval_inj2 _ _ (v_vald1) (store v_vale1 v_vale2 v_vale3) Htid1'').

          rewrite Htie1 in Htic1.

          rewrite (Atom.Bval_inj2 t_i (Typ.TFArray t1 t2) (v_vale1) (v_valc1) Htic1).

          simpl in isif. rewrite !Typ.cast_refl in isif.
          apply Typ.i_eqb_spec_false in isif.

          rewrite !Atom.t_interp_wf in Htic2''; trivial.

          destruct Heq11d as [((Heq11d1,Heq11d2),Heq11d3) | ((Heq11d1,Heq11d2),Heq11d3) ];
            subst; intros;

              rewrite Htid2 in Htic2;
              rewrite <- (Atom.Bval_inj2 _ _  (v_vald2) (v_valc2) Htic2) in *.

          + rewrite Htie2 in Htia1.
            rewrite Htia2 in Htic2''.
            rewrite <- (Atom.Bval_inj2 _ _ _ _ Htia1) in *.
            rewrite (Atom.Bval_inj2 _ _ _ _ Htic2'') in *.
            symmetry; now apply read_over_other_write.

          + rewrite Htie2 in Htia2.
            rewrite Htia1 in Htic2''.
            rewrite <- (Atom.Bval_inj2 _ _ _ _ Htia2) in *.
            rewrite (Atom.Bval_inj2 _ _ _ _ Htic2'') in *.
            symmetry; apply read_over_other_write; now auto.

        - unfold store_of_me.
          case_eq (t_atom .[ c1]); try discriminate.
          intros [ t5 t6 ] e1 e2 e3 Heq10 [[ti3 te3] i1].
          case_eq (e1 == d1); try discriminate. intros Heq11d.
          intro HT.
          injection HT. intros E2 T6 T5 [ ]. subst i1 te3 ti3. clear HT.

          case_eq (
              Typ.eqb t t5 && Typ.eqb v_typeb1' t6 &&
                      ((e2 == a1) && (c2 == a2) && (d2 == a2) || (e2 == a2) && (c2 == a1) && (d2 == a1)));
            simpl; intros Heq11; try (now apply C.interp_true).

          unfold C.valid. simpl. rewrite orb_false_r.

          case_eq (Lit.interp rho i). intros isit.
          easy. intros isif. rewrite orb_false_l.
          specialize (rho_interp ( Lit.blit i)).
          rewrite Heq3 in rho_interp.
          simpl in rho_interp.
          unfold Lit.interp in isif.
          rewrite Heq in isif. unfold Var.interp in isif.
          rewrite rho_interp in isif.
          unfold Atom.interp_form_hatom, interp_hatom in isif.
          rewrite Atom.t_interp_wf in isif; trivial.
          rewrite Heq5 in isif.
          simpl in isif.
          unfold interp_bool in isif.

          unfold Lit.interp. rewrite Heq2.
          unfold Var.interp.
          rewrite !wf_interp_form; trivial. rewrite Heq4. simpl.

          rewrite !andb_true_iff in Heq11.
          destruct Heq11 as ((Heq11a, Heq11b), Heq11c).
          rewrite !orb_true_iff in Heq11c.

          apply Typ.eqb_spec in Heq11a.
          apply Typ.eqb_spec in Heq11b.
          apply Int63Properties.eqb_spec in Heq11d.
          rewrite !andb_true_iff in Heq11c.
          rewrite !Int63Properties.eqb_spec in Heq11c.

          rewrite !Atom.t_interp_wf in isif; trivial.
          rewrite Htia1, Htia2 in isif. simpl in isif.
          unfold Bval in isif.
          rewrite !Typ.cast_refl in isif.

          assert (H25: c1 < PArray.length t_atom).
          apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq10. discriminate.
          apply H2 in H25.
          rewrite Heq10 in H25.
          simpl in H25.
          rewrite !andb_true_iff in H25.
          destruct H25 as (((H25, H29), H28), H27).
          unfold get_type', v_type in H25, H27, H28, H29.

          case_eq (t_interp .[ c1]).
          intros v_typec1' v_valc1' Htic1'. rewrite Htic1' in H25.
          case_eq v_typec1'; intros; rewrite H10 in H25; try now contradict H25.
          rewrite andb_true_iff in H25; destruct H25 as (H25a, H25b).

          case_eq (t_interp .[ e1]).
          intros v_typee1 v_vale1 Htie1. rewrite Htie1 in H29.
          case_eq (t_interp .[ e2]).
          intros v_typee2 v_vale2 Htie2. rewrite Htie2 in H28.
          case_eq (t_interp .[ e3]).
          intros v_typee3 v_vale3 Htie3. rewrite Htie3 in H27.
          pose proof Htic1' as Htic1''.
          rewrite Atom.t_interp_wf in Htic1', Htie1, Htie2, Htie3; trivial.
          rewrite Heq10 in Htic1'. simpl in Htic1'.
          rewrite !Atom.t_interp_wf in Htic1'; trivial.
          rewrite Htie1, Htie2, Htie3 in Htic1'. simpl in Htic1'.

          apply Typ.eqb_spec in H25a. apply Typ.eqb_spec in H25b.
          apply Typ.eqb_spec in H27.  apply Typ.eqb_spec in H28.
          apply Typ.eqb_spec in H29.

          generalize dependent v_vale1. generalize dependent v_vale2.
          generalize dependent v_vale3. generalize dependent v_valc1'.
          rewrite H27, H28, H29.
          rewrite !Typ.cast_refl. intros. simpl in Htic1'.
          unfold Bval in Htic1'.

          generalize dependent v_vale1. generalize dependent v_vale2.
          generalize dependent v_vale3. generalize dependent v_valc1'.

          rewrite H25a, H25b, H10. intros.
          specialize (Atom.Bval_inj2 t_i (Typ.TFArray t1 t2)
            (@store _ _
                   (Typ.dec_interp t_i t1)
                   _ _ _ (Typ.comp_interp t_i t2) _
                   v_vale1 v_vale2 v_vale3) (v_valc1')).
          intro H25. specialize (H25 Htic1').

          unfold Atom.interp_form_hatom, interp_hatom.
          rewrite !Atom.t_interp_wf; trivial.
          rewrite Heq6. simpl.
          rewrite !Atom.t_interp_wf; trivial.
          rewrite Heq7, Heq8. simpl.
          rewrite !Atom.t_interp_wf; trivial.

          rewrite Htid1, Htic2, Htic1, Htid2.
          subst. intros. simpl.
          rewrite !Typ.cast_refl.
          unfold apply_binop.
          unfold Bval.
          rewrite !Atom.t_interp_wf in Htib1''; trivial.
          rewrite Htib1 in Htib1''.
          inversion Htib1''.
          rewrite !Atom.t_interp_wf in Htib2''; trivial.
          rewrite Htib2 in Htib2''.
          inversion Htib2''.

          rewrite !Typ.cast_refl.

          unfold interp_bool. rewrite Typ.cast_refl.
          apply Typ.i_eqb_spec.

          rewrite !Atom.t_interp_wf in Htic1''; trivial.
          rewrite Htic1 in Htic1''.
          inversion Htic1''.

          subst.
          rewrite (Atom.Bval_inj2 _ _ (v_valc1) (store v_vale1 v_vale2 v_vale3) Htic1'').

          rewrite Htie1 in Htid1.

          rewrite (Atom.Bval_inj2 t_i (Typ.TFArray t1 t2) (v_vale1) (v_vald1) Htid1).

          apply Typ.i_eqb_spec_false in isif.

          rewrite !Atom.t_interp_wf in Htic2''; trivial.

          destruct Heq11c as [((Heq11c1,Heq11c2),Heq11c3) | ((Heq11c1,Heq11c2),Heq11c3) ];
            subst; intros;

              rewrite Htid2 in Htic2;
              rewrite <- (Atom.Bval_inj2 _ _  (v_vald2) (v_valc2) Htic2) in *.

          + rewrite Htie2 in Htia1.
            rewrite Htia2 in Htic2''.
            rewrite <- (Atom.Bval_inj2 _ _ _ _ Htia1) in *.
            rewrite (Atom.Bval_inj2 _ _ _ _ Htic2'') in *.
            now apply read_over_other_write.

          + rewrite Htie2 in Htia2.
            rewrite Htia1 in Htic2''.
            rewrite <- (Atom.Bval_inj2 _ _ _ _ Htia2) in *.
            rewrite (Atom.Bval_inj2 _ _ _ _ Htic2'') in *.
            apply read_over_other_write; now auto.
    Qed.

  Lemma valid_check_ext lres : C.valid rho (check_ext lres).
    unfold check_ext, eq_sel_sym.
    case_eq (Lit.is_pos lres); intro Heq; simpl; try now apply C.interp_true.
    case_eq (t_form .[ Lit.blit lres]); try (intros; now apply C.interp_true).
    intros a Heq2.
    case_eq (length a == 2); [ intros Heq3 | intros Heq3; now apply C.interp_true].
    case_eq (Lit.is_pos (a .[ 0]) && negb (Lit.is_pos (a .[ 1])));
      [ intros Heq4 | intros Heq4; now apply C.interp_true].
    case_eq (t_form .[ Lit.blit (a .[0])]); try (intros; now apply C.interp_true).
    intros b Heq5.
    case_eq (t_form .[ Lit.blit (a .[1])]); try (intros; now apply C.interp_true).
    intros c Heq6.
    case_eq (t_atom .[ b]); try (intros; now apply C.interp_true).
    intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] b1 b2 Heq7; try (intros; now apply C.interp_true).
    case_eq t; try (intros; now apply C.interp_true). intros t0 t1 Heq8.
    case_eq (t_atom .[ c]); try (intros; now apply C.interp_true).
    intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] c1 c2 Heq9; try (intros; now apply C.interp_true).
    case_eq (Typ.eqb t1 t2); [ intros Heq10 | intros Heq10; now apply C.interp_true].
    case_eq (t_atom .[ c1]); try (intros; now apply C.interp_true).
    intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] d1 d2 Heq11; try (intros; now apply C.interp_true).
    case_eq (t_atom .[ c2]); try (intros; now apply C.interp_true).
    intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] e1 e2 Heq12; try (intros; now apply C.interp_true).
    case_eq (t_atom .[ d2]);
      try (intros; rewrite !andb_false_r; simpl; now apply C.interp_true).
    intros [ | | | | | | | |N|N|N|N|N|N|N|N| | | | ] f1 f2 Heq14;
      try (intros; rewrite !andb_false_r; simpl; now apply C.interp_true).
    case_eq (Typ.eqb t0 t3 && Typ.eqb t0 t5 && Typ.eqb t1 t4 && Typ.eqb t1 t6);
      [ intros Heq13'| intro; now apply C.interp_true].
    simpl.
    case_eq (Typ.eqb t0 t7 && Typ.eqb t1 t8);
      [ intros Heq14'| intro; rewrite !andb_false_r; simpl; now apply C.interp_true].
    simpl.
    case_eq ((b1 == d1) && (b2 == e1) && (d2 == e2) && ((f1 == b1) && (f2 == b2))
             || (b2 == d1) && (b1 == e1) && (d2 == e2) && ((f1 == b2) && (f2 == b1)));
        [ intros Heq1314 | intro; now apply C.interp_true].

    unfold C.valid. simpl. rewrite orb_false_r.

    rewrite orb_true_iff in Heq1314.
    rewrite !andb_true_iff in Heq13'.
    rewrite !andb_true_iff in Heq14'.
    rewrite !andb_true_iff in Heq1314.
    destruct Heq13' as (((Heq13, Heq13f), Heq13a), Heq13d).
    destruct Heq14' as (Heq15, Heq15a).

    apply Typ.eqb_spec in Heq13.
    apply Typ.eqb_spec in Heq13f.
    apply Typ.eqb_spec in Heq13a.
    apply Typ.eqb_spec in Heq13d.
    apply Typ.eqb_spec in Heq15.
    apply Typ.eqb_spec in Heq15a.
    subst t3 t5 t4 t6 t7 t8.
    rewrite !Int63Properties.eqb_spec in Heq1314.

    unfold Lit.interp. rewrite Heq.
    unfold Var.interp.
    rewrite !wf_interp_form; trivial. rewrite Heq2. simpl.
    rewrite afold_left_or.
    unfold to_list.
    rewrite Int63Properties.eqb_spec in Heq3.
    rewrite Heq3.

    (* for native-coq compatibility *)
    assert (0 == 2 = false) as NCC.
    { auto. } rewrite NCC.
    (* simpl. *)
    rewrite foldi_down_gt; auto.

    (* simpl. *)
    assert (2 - 1 = 1). { auto. }
                        rewrite H.
    rewrite foldi_down_eq; auto.
    simpl. rewrite orb_false_r.
    assert (1 - 1 = 0) as Has2. { auto. }
                                rewrite Has2.

    case_eq (Lit.interp rho (a .[ 0])). intro Hisa0.
    rewrite orb_true_l. easy. intro Hisa. rewrite orb_false_l.

    pose proof (rho_interp (Lit.blit (a .[ 0]))).
    pose proof (rho_interp (Lit.blit (a .[ 1]))).

    rewrite Heq5 in H0. rewrite Heq6 in H1.
    simpl in H0, H1.
    unfold Lit.interp.
    rewrite andb_true_iff in Heq4.
    destruct Heq4 as (Heq4, Heq4a).
    apply negb_true_iff in Heq4a.

    unfold Lit.interp in Hisa.
    rewrite Heq4 in Hisa. unfold Var.interp in Hisa.
    rewrite Hisa in H0. symmetry in H0.
    rewrite Heq4a.
    unfold Var.interp.
    rewrite H1.

    generalize wt_t_atom. unfold Atom.wt. unfold is_true.
    rewrite PArray.forallbi_spec;intros.

    (* b *)
    pose proof (H2 b). assert (b < PArray.length t_atom).
    apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq7. easy.
    specialize (H3 H4). simpl in H3.
    rewrite Heq7 in H3. simpl in H3.
    rewrite !andb_true_iff in H3. destruct H3. destruct H3.
    unfold get_type' in H3, H5, H6. unfold v_type in H3, H5, H6.

    case_eq (t_interp .[ b]).
    intros v_typeb v_valb Htib. rewrite Htib in H3.
    pose proof Htib as Htib''.
    case_eq v_typeb; intros; rewrite H7 in H3; try now contradict H3.

    case_eq (t_interp .[ b1]).
    intros v_typeb1 v_valb1 Htib1. rewrite Htib1 in H6.
    pose proof Htib1 as Htib1''.
    case_eq (t_interp .[ b2]).
    intros v_typeb2 v_valb2 Htib2. rewrite Htib2 in H5.
    pose proof Htib2 as Htib2''.
    rewrite Atom.t_interp_wf in Htib; trivial.
    rewrite Atom.t_interp_wf in Htib1; trivial.
    rewrite Atom.t_interp_wf in Htib2; trivial.
    rewrite Heq7 in Htib. simpl in Htib.
    rewrite !Atom.t_interp_wf in Htib; trivial.
    rewrite Htib1, Htib2 in Htib.
    unfold apply_binop in Htib.
    apply Typ.eqb_spec in H5.
    apply Typ.eqb_spec in H6.

    generalize dependent v_valb1. generalize dependent v_valb2.
    generalize dependent v_valb.
    rewrite H5, H6, H7. rewrite !Typ.cast_refl. intros.

    specialize (Atom.Bval_inj2 t_i (Typ.Tbool) (Typ.i_eqb t_i t v_valb1 v_valb2) (v_valb)).
    intros. specialize (H8 Htib).

    (* c *)
    pose proof (H2 c). assert (c < PArray.length t_atom).
    apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq9. easy.
    specialize (H9 H10). simpl in H9.
    rewrite Heq9 in H9. simpl in H9.
    rewrite !andb_true_iff in H9. destruct H9. destruct H9.
    unfold get_type' in H9, H11, H12. unfold v_type in H9, H11, H12.

    case_eq (t_interp .[ c]).
    intros v_typec v_valc Htic. rewrite Htic in H9.
    pose proof Htic as Htic''.
    case_eq v_typec; intros; rewrite H13 in H9; try now contradict H9.

    case_eq (t_interp .[ c1]).
    intros v_typec1 v_valc1 Htic1. rewrite Htic1 in H12.
    case_eq (t_interp .[ c2]).
    intros v_typec2 v_valc2 Htic2. rewrite Htic2 in H11.
    rewrite Atom.t_interp_wf in Htic; trivial.
    rewrite Atom.t_interp_wf in Htic1; trivial.
    rewrite Atom.t_interp_wf in Htic2; trivial.
    rewrite Heq9 in Htic. simpl in Htic.
    rewrite !Atom.t_interp_wf in Htic; trivial.
    rewrite Htic1, Htic2 in Htic. simpl in Htic.

    apply Typ.eqb_spec in H11. apply Typ.eqb_spec in H12.

    generalize dependent v_valc1. generalize dependent v_valc2.
    generalize dependent v_valc.
    rewrite H11, H12, H13.
    rewrite !Typ.cast_refl. intros. simpl in Htic.
    unfold Bval in Htic.

    specialize (Atom.Bval_inj2 t_i (Typ.Tbool) (Typ.i_eqb t_i t2 v_valc1 v_valc2) (v_valc)).
    intros. specialize (H14 Htic).

    (* c1 *)
    pose proof (H2 c1). assert (c1 < PArray.length t_atom).
    apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq11. easy.
    specialize (H15 H16). simpl in H15.
    rewrite Heq11 in H15. simpl in H15.
    rewrite !andb_true_iff in H15. destruct H15. destruct H15.
    unfold get_type' in H15, H17, H18. unfold v_type in H15, H17, H18.

    case_eq (t_interp .[ c1]).
    intros v_typec1' v_valc1' Htic1'. rewrite Htic1' in H15.
    pose proof Htic1' as Htic1'''.

    case_eq (t_interp .[ d1]).
    intros v_typed1 v_vald1 Htid1. rewrite Htid1 in H18.
    case_eq (t_interp .[ d2]).
    intros v_typed2 v_vald2 Htid2. rewrite Htid2 in H17.
    rewrite Atom.t_interp_wf in Htic1'; trivial.
    rewrite Atom.t_interp_wf in Htid1; trivial.
    rewrite Atom.t_interp_wf in Htid2; trivial.
    rewrite Heq11 in Htic1'. simpl in Htic1'.
    rewrite !Atom.t_interp_wf in Htic1'; trivial.
    rewrite Htid1, Htid2 in Htic1'. simpl in Htic1'.

    apply Typ.eqb_spec in H15. apply Typ.eqb_spec in H17.
    apply Typ.eqb_spec in H18.

    generalize dependent v_vald1. generalize dependent v_vald2.
    generalize dependent v_valc1'.

    rewrite H15, H17, H18.
    unfold Bval. rewrite <- H15.
    rewrite !Typ.cast_refl. intros.

    specialize (Atom.Bval_inj2 t_i t1 (select v_vald1 v_vald2) (v_valc1')).
    intros. specialize (H19 Htic1').

    (* c2 *)
    pose proof (H2 c2). assert (c2 < PArray.length t_atom).
    apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq12. easy.
    specialize (H20 H21). simpl in H20.
    rewrite Heq12 in H20. simpl in H20.
    rewrite !andb_true_iff in H20. destruct H20. destruct H20.
    unfold get_type' in H20, H22, H23. unfold v_type in H20, H22, H23.

    case_eq (t_interp .[ c2]).
    intros v_typec2' v_valc2' Htic2'. rewrite Htic2' in H20.
    pose proof Htic2' as Htic2'''.

    case_eq (t_interp .[ e1]).
    intros v_typee1 v_vale1 Htie1. rewrite Htie1 in H23.
    case_eq (t_interp .[ e2]).
    intros v_typee2 v_vale2 Htie2. rewrite Htie2 in H22.
    pose proof Htie2 as Htie2''.
    rewrite Atom.t_interp_wf in Htic2'; trivial.
    rewrite Atom.t_interp_wf in Htie1; trivial.
    rewrite Atom.t_interp_wf in Htie2; trivial.
    rewrite Heq12 in Htic2'. simpl in Htic2'.
    rewrite !Atom.t_interp_wf in Htic2'; trivial.
    rewrite Htie1, Htie2 in Htic2'. simpl in Htic2'.

    apply Typ.eqb_spec in H20. apply Typ.eqb_spec in H22.
    apply Typ.eqb_spec in H23.

    generalize dependent v_valc1'. generalize dependent v_valc2'.
    generalize dependent v_vale1. generalize dependent v_vale2.

    rewrite H22. rewrite H20 in *. rewrite H23.
    unfold Bval. rewrite <- H20.
    rewrite !Typ.cast_refl. intros.

    specialize (Atom.Bval_inj2 t_i t1 (select v_vale1 v_vale2) (v_valc2')).
    intros. specialize (H24 Htic2').

    (* d2 *)
    pose proof (H2 d2). assert (d2 < PArray.length t_atom).
    apply PArray.get_not_default_lt. rewrite def_t_atom. rewrite Heq14. easy.
    specialize (H25 H26). simpl in H25.
    rewrite Heq14 in H25. simpl in H25.
    rewrite !andb_true_iff in H25. destruct H25. destruct H25.
    unfold get_type' in H25, H27, H28. unfold v_type in H25, H27, H28.

    case_eq (t_interp .[ d2]).
    intros v_typed2' v_vald2' Htid2'. rewrite Htid2' in H25.
    pose proof Htid2' as Htid2'''.

    case_eq (t_interp .[ f1]).
    intros v_typef1 v_valf1 Htif1. rewrite Htif1 in H28.
    case_eq (t_interp .[ f2]).
    intros v_typef2 v_valf2 Htif2. rewrite Htif2 in H27.
    rewrite Atom.t_interp_wf in Htid2'; trivial.
    rewrite Atom.t_interp_wf in Htif1; trivial.
    rewrite Atom.t_interp_wf in Htif2; trivial.
    rewrite Heq14 in Htid2'. simpl in Htid2'.
    rewrite !Atom.t_interp_wf in Htid2'; trivial.
    rewrite Htif1, Htif2 in Htid2'. simpl in Htid2'.

    apply Typ.eqb_spec in H25. apply Typ.eqb_spec in H27.
    apply Typ.eqb_spec in H28.

    generalize dependent v_valf1. generalize dependent v_valf2.
    generalize dependent v_vald2'.

    rewrite H25, H27, H28.
    unfold Bval. rewrite <- H25.
    rewrite !Typ.cast_refl. intros.

    specialize (Atom.Bval_inj2 t_i t0 (@diff _ _
       (Typ.dec_interp t_i t0)
       _ _ (Typ.dec_interp t_i v_typec2') _ (Typ.comp_interp t_i v_typec2') (Typ.inh_interp t_i t0) _
       v_valf1 v_valf2) (v_vald2')).
    intros. specialize (H29 Htid2').

    (* semantics *)

    unfold Atom.interp_form_hatom, interp_hatom.
    rewrite !Atom.t_interp_wf; trivial.
    rewrite Heq9. simpl.
    rewrite !Atom.t_interp_wf; trivial.
    rewrite  Heq11, Heq12. simpl.

    unfold apply_binop.
    rewrite !Atom.t_interp_wf; trivial.
    rewrite Htid1, Heq14, Htie1, Htie2.
    rewrite !Typ.cast_refl.
    simpl. (* (* native-coq compatibility *) unfold interp_atom. *)
    rewrite !Atom.t_interp_wf; trivial.
    rewrite Htif1, Htif2. simpl.
    rewrite !Typ.cast_refl. simpl.

    rewrite !Atom.t_interp_wf in Htid2'''; trivial.
    rewrite Htid2 in Htid2'''.
    inversion Htid2'''.

    rewrite !Atom.t_interp_wf in Htic1'''; trivial.
    rewrite Htic1 in Htic1'''.
    inversion Htic1'''.

    rewrite !Atom.t_interp_wf in Htic2'''; trivial.
    rewrite Htic2 in Htic2'''.
    inversion Htic2'''.

    generalize dependent v_valc1. generalize dependent v_valc2.
    generalize dependent v_valc1'. generalize dependent v_valc2'.
    generalize dependent v_vald1. generalize dependent v_vald2.

    subst.
    rewrite !Typ.cast_refl. simpl.
    rewrite !Typ.cast_refl. intros. simpl.

    apply negb_true_iff.
    apply Typ.i_eqb_spec_false.
    subst.

    specialize (Atom.Bval_inj2 t_i v_typed2' v_vald2 (@diff
             _
             _
             (@EqbToDecType
                (@type_compdec
                   (@projT1 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typed2'))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typed2')))
                (@eqbtype_of_compdec
                   (@type_compdec
                      (@projT1 Type (fun ty : Type => CompDec ty)
                         (Typ.interp_compdec_aux t_i v_typed2'))
                      (@projT2 Type (fun ty : Type => CompDec ty)
                         (Typ.interp_compdec_aux t_i v_typed2')))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typed2'))))
             (@ord_of_compdec
                (@type_compdec
                   (@projT1 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typed2'))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typed2')))
                (@projT2 Type (fun ty : Type => CompDec ty)
                   (Typ.interp_compdec_aux t_i v_typed2')))
             (@comp_of_compdec
                (@type_compdec
                   (@projT1 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typed2'))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typed2')))
                (@projT2 Type (fun ty : Type => CompDec ty)
                   (Typ.interp_compdec_aux t_i v_typed2')))
             (@EqbToDecType
                (@type_compdec
                   (@projT1 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typec1'))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typec1')))
                (@eqbtype_of_compdec
                   (@type_compdec
                      (@projT1 Type (fun ty : Type => CompDec ty)
                         (Typ.interp_compdec_aux t_i v_typec1'))
                      (@projT2 Type (fun ty : Type => CompDec ty)
                         (Typ.interp_compdec_aux t_i v_typec1')))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typec1'))))
             (@ord_of_compdec
                (@type_compdec
                   (@projT1 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typec1'))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typec1')))
                (@projT2 Type (fun ty : Type => CompDec ty)
                   (Typ.interp_compdec_aux t_i v_typec1')))
             (@comp_of_compdec
                (@type_compdec
                   (@projT1 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typec1'))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typec1')))
                (@projT2 Type (fun ty : Type => CompDec ty)
                   (Typ.interp_compdec_aux t_i v_typec1')))
             (@inh_of_compdec
                (@type_compdec
                   (@projT1 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typed2'))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typed2')))
                (@projT2 Type (fun ty : Type => CompDec ty)
                   (Typ.interp_compdec_aux t_i v_typed2')))
             (@inh_of_compdec
                (@type_compdec
                   (@projT1 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typec1'))
                   (@projT2 Type (fun ty : Type => CompDec ty)
                      (Typ.interp_compdec_aux t_i v_typec1')))
                (@projT2 Type (fun ty : Type => CompDec ty)
                   (Typ.interp_compdec_aux t_i v_typec1'))) v_valf1 v_valf2)).
    intros H5. specialize (H5 Htid2''').
    rewrite <- H5.
    specialize (Atom.Bval_inj2 t_i v_typed2' (v_vale2) (v_vald2)).
    intros.

    unfold Atom.interp_form_hatom, interp_hatom in H0.
    rewrite !Atom.t_interp_wf in H0; trivial.
    rewrite Heq7 in H0. simpl in H0.
    rewrite !Atom.t_interp_wf in H0; trivial.
    rewrite Htib1, Htib2 in H0. simpl in H0.
    rewrite !Typ.cast_refl in H0. simpl in H0.
    apply Typ.i_eqb_spec_false in H0.

    destruct Heq1314 as [Heq1314 | Heq1314];
      destruct Heq1314 as (((Heq13a, Heq13b), Heq13c), (Heq13d, Heq13e));
      subst.

    - rewrite Htie2 in Htid2.
      rewrite Htid1 in Htib1.
      rewrite Htie1 in Htib2.
      rewrite Htid1 in Htif1.
      rewrite Htie1 in Htif2.

      rewrite (Atom.Bval_inj2 t_i _ _ _ Htib1) in *.
      rewrite (Atom.Bval_inj2 t_i _ _ _ Htib2) in *.
      rewrite (Atom.Bval_inj2 t_i _ _ _ Htif1) in *.
      rewrite (Atom.Bval_inj2 t_i _ _ _ Htif2) in *.
      rewrite (Atom.Bval_inj2 t_i _ _ _ Htid2) in *.

      now apply select_at_diff.

    - rewrite Htie2 in Htid2.
      rewrite Htid1 in Htib2.
      rewrite Htie1 in Htib1.
      rewrite Htid1 in Htif1.
      rewrite Htie1 in Htif2.

      rewrite (Atom.Bval_inj2 t_i _ _ _ Htib1) in *.
      rewrite (Atom.Bval_inj2 t_i _ _ _ Htib2) in *.
      rewrite (Atom.Bval_inj2 t_i _ _ _ Htif1) in *.
      rewrite (Atom.Bval_inj2 t_i _ _ _ Htif2) in *.
      rewrite (Atom.Bval_inj2 t_i _ _ _ Htid2) in *.

      apply select_at_diff.
      red in H0. red. intro. apply H0. auto.
  Qed.

  End Correct.

End certif.


Add LoadPath "..".
Require Export LF_PPermutLib.

Fixpoint emptyEquiv_LF (G: list (list (var * ty))) :=
match G with
| nil => nil
| a::G' => (@nil (var * ty)) :: emptyEquiv_LF G'
end.

Add Morphism emptyEquiv_LF : Permut_emptyEquiv.
intros.
induction H; simpl in *; auto.
transitivity (emptyEquiv_LF G'); auto.
Qed.

Lemma emptyEquiv_LF_Mem_nil:
forall G C,
  Mem C (emptyEquiv_LF G) -> C = nil.
induction G; simpl; intros.
rewrite Mem_nil_eq in H; contradiction.
simpl in *; rewrite Mem_cons_eq in H; destruct H; auto.
Qed.

Lemma emptyEquiv_LF_permut_empty:
forall G G',
  G ~=~ emptyEquiv_LF G' ->
  (forall C, Mem C G -> C = nil).
intros.
apply PPermut_LF_Mem with (G':=emptyEquiv_LF G') in H0; auto;
destruct H0 as (C0, (H0, H1)).
assert (C0 = nil).
  apply emptyEquiv_LF_Mem_nil with (G:=G'); auto.
subst. apply permut_nil_eq in H0; auto.
Qed.

Lemma double_emptyEquiv_LF:
forall G,
 emptyEquiv_LF G = emptyEquiv_LF (emptyEquiv_LF G).
induction G; simpl; auto; destruct a;
simpl; rewrite <- IHG; auto.
Qed.

Lemma emptyEquiv_LF_rewrite:
forall G H,
  emptyEquiv_LF (G++H) = emptyEquiv_LF G ++ emptyEquiv_LF H.
induction G; rew_app; intros; auto.
rew_app; simpl; rew_app; rewrite IHG; auto.
Qed.

Lemma emptyEquiv_LF_rewrite_last:
forall G C,
  emptyEquiv_LF (G & C) = emptyEquiv_LF G ++ emptyEquiv_LF (C::nil).
intros; apply emptyEquiv_LF_rewrite.
Qed.

Lemma emptyEquiv_LF_PPermut:
forall G Gamma G',
  G & Gamma ~=~ emptyEquiv_LF G' ->
  Gamma = nil.
intros.
assert (Mem Gamma (G & Gamma)).
rewrite Mem_app_or_eq; right; apply Mem_here.
apply emptyEquiv_LF_permut_empty with (G:=G & Gamma) (G':=G'); auto.
Qed.

Lemma emptyEquiv_LF_PPermut_eq:
forall G G',
  G ~=~ emptyEquiv_LF G' -> emptyEquiv_LF G = G.
induction G; intros; simpl in *; auto; rew_app in *.
assert (a = nil) by
  (eapply emptyEquiv_LF_permut_empty; eauto; eapply Mem_here);
subst; assert (emptyEquiv_LF G = G).
  assert (nil :: G ~=~ emptyEquiv_LF G') by auto;
  apply PPermut_LF_split_head in H0; destruct H0 as (l', (hd, (tl, (Ha, Hb))));
  subst; apply permut_nil_eq in Ha; subst.
  rewrite Hb in H.
  assert (G ~=~ hd ++ tl) by
    ( apply PPermut_LF_last_rev_simpl with (a:=nil);
      transitivity (nil::G); [ | rewrite H]; PPermut_LF_simpl).
  apply IHG with (G':=hd++tl).
  rewrite H0. apply PPermut_LF_last_rev_simpl with (a:=(nil));
  rew_app.
  assert (hd &  nil ++ tl ~=~ hd ++ tl &  nil) by PPermut_LF_simpl.
  rewrite <- H1.
  assert (emptyEquiv_LF (hd ++ tl)&(nil) ~=~ emptyEquiv_LF (hd & (nil) ++ tl)).
    (repeat rewrite emptyEquiv_LF_rewrite; PPermut_LF_simpl).
  rewrite H2.
  rewrite <- Hb.
  rewrite <- double_emptyEquiv_LF; auto.
rewrite H0; auto.
Qed.

Lemma PPermut_emptyEquiv_LF:
forall G G',
  G ~=~ G' -> emptyEquiv_LF G ~=~ emptyEquiv_LF G'.
intros; rewrite H; auto.
Qed.

Lemma emptyEquiv_LF_last_change:
forall G G' C C',
  G  ~=~ G'& C ->
  emptyEquiv_LF G ~=~ emptyEquiv_LF (G' & C').
intros; rewrite H; repeat rewrite emptyEquiv_LF_rewrite;
simpl; auto.
Qed.

Lemma emptyEquiv_LF_PPermut_equal:
forall G' G,
  G ~=~ emptyEquiv_LF G' -> G = emptyEquiv_LF G'.
induction G'; intros; simpl in *.
symmetry in H;
apply PPermut_LF_nil_impl in H; subst; auto.
destruct G.
apply PPermut_LF_nil_impl in H; inversion H.
assert (c = nil).
  apply emptyEquiv_LF_PPermut with (G:=G) (G':=nil::G');
  simpl; rewrite <- H; PPermut_LF_simpl.
subst.
assert (nil :: G ~=~ nil :: emptyEquiv_LF G') by auto.
apply PPermut_LF_split_head in H0.
destruct H0 as (l, (hd, (tl, (H0, H1)))).
apply permut_nil_eq in H0; subst.
assert (G = emptyEquiv_LF G').
apply IHG'. apply PPermut_LF_last_rev_simpl with (a:=nil).
transitivity (nil :: G). PPermut_LF_simpl.
rewrite H; PPermut_LF_simpl.
subst; auto.
Qed.


From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst.
From MetaCoq.PCUIC Require TemplateToPCUIC PCUICToTemplate.

From MetaCoq.Template Require Import config monad_utils utils TemplateMonad Loader.
From MetaCoq.Template Require Ast.
Import MCMonadNotation.
Require Import List String.
Import ListNotations.

Definition ex := tInd
  {|
  inductive_mind := (MPfile ["Logic"; "Init"; "Coq"], "ex");
  inductive_ind := 0 |} [].

(* Definition sigma := tInd *)
(*   {| *)
(*   inductive_mind := (MPfile ["Specif"; "Init"; "Coq"], "sigT"); *)
(*     inductive_ind := 0 |} []. *)

Definition sigma := match <% @Init.sigma %> with Ast.tInd i l => tInd i l | _ => tVar "no" end.
Print sigma.

Definition acc := tInd
  {| inductive_mind := (MPfile ["Wf"; "Init"; "Coq"], "Acc"); inductive_ind := 0 |}
  [].

Definition sigmaize (u : context_decl) (v : term) :=
  match (decl_body u) with
  | Some body => tLetIn (decl_name u) body (decl_type u) v
  | None => mkApps sigma [(decl_type u) ;
                      tLambda (decl_name u) (decl_type u) (tApp v (tRel 0))]
  end.

Fixpoint sigma_pack_go (n: nat) (c : context) (t : list term -> term) :=
  match c with
  | [] => t
  | ch :: ct =>
    match (decl_body ch) with
    | Some body =>
      sigma_pack_go (n - 1) ct (fun l => tLetIn (decl_name ch) body (decl_type ch) (t l))
    | None =>
      sigma_pack_go (n - 1) ct (fun l =>
      mkApps sigma [(decl_type ch);
               tLambda (decl_name ch) (decl_type ch) (t (tRel n :: l))])
    end
  end.

Definition sigma_pack_arity (t : term) : term
  := let (pai, c) := decompose_prod_assum [] t in
    (sigma_pack_go (List.length pai - 1) pai (fun l => mkApps t l) []).

Definition sigma_pack_inductive
           (i : inductive)
           (m : mutual_inductive_body)
              : option term :=
  (*let params := (ind_params m) in*)
  match (List.nth_error (ind_bodies m) (inductive_ind i)) with
  | None => None
  | Some ind =>
      let (inds, _) := decompose_prod_assum [] (ind_type ind) in
      let params := firstn (ind_npars m) (rev inds) in
      let inds := rev (skipn (ind_npars m) (rev inds)) in
      Some (
          it_mkLambda_or_LetIn params (
          sigma_pack_go (List.length inds - 1) inds (fun l => mkApps (tInd i []) (map tRel (rev (seq (List.length inds) (ind_npars m))) ++ l)) []))
  end.

Definition pack_inductive (t : Ast.term) : TemplateMonad (Ast.term) :=
    match t with
    | Ast.tInd ind0 _ =>
      decl <- tmQuoteInductive (inductive_mind ind0);;
      match (sigma_pack_inductive
               ind0
               (TemplateToPCUIC.trans_minductive_body decl)) with
      | None =>
        tmPrint t;;
        @tmFail (Ast.term) "Coulnd't pack inductive"
      | Some d =>
        v <- tmEval lazy (PCUICToTemplate.trans d);;
        @tmReturn (Ast.term) v
      end
    | _ =>
      tmPrint t;;
      @tmFail (Ast.term) " is not an inductive"
    end.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import finset.
Require Import connect.
Require Import hypermap.
Require Import jordan.
Require Import geometry.
Require Import color.
Require Import chromogram.
Require Import coloring.
Require Import patch.
Require Import snip.
Require Import sew.
Require Import revsnip.
Require Import kempe.
Require Import ctree.
Require Import initctree.
Require Import gtree.
Require Import initgtree.
Require Import ctreerestrict.
Require Import gtreerestrict.
Require Import cfmap.
Require Import cfcolor.
Require Import kempetree.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* The birkhoff theorem: a minimal coloring counter-example must be *)
(* internally 5-connected. *)

Section BirkhoffCheck.

Variable h m : nat.

Fixpoint ctree_pick_rev_rec (et : colseq) (e : color) (t' t : ctree) {struct t}
                          : colseq :=
  match t with
  | Ctree_leaf _ =>
    if ctree_mem t' (etrace (belast e et)) then Adds e et else seq0
  | Ctree_node t1 t2 t3 =>
    if ctree_pick_rev_rec (Adds Color1 et) (e +c Color1) t' t1 is Adds e' et' then
      Adds e' et' else
    if ctree_pick_rev_rec (Adds Color2 et) (e +c Color2) t' t2 is Adds e' et' then
      Adds e' et' else
    ctree_pick_rev_rec (Adds Color3 et) (e +c Color3) t' t3
  | _ => seq0
  end.

Definition ctree_pick_rev : ctree -> ctree -> colseq :=
  ctree_pick_rev_rec seq0 Color0.

Lemma sumt_ctree_pick_rev : forall t t', sumt (ctree_pick_rev t t') = Color0.
Proof.
move=> t' t; rewrite /ctree_pick_rev; set cs0 : colseq := seq0.
have: Color0 +c sumt cs0 = Color0 by done.
elim: t cs0 {1 3}Color0 => [t1 Ht1 t2 Ht2 t3 Ht3|lf _|] et e //.
  move=> Het /=; set cprr := ctree_pick_rev_rec.
  case Det1: (cprr _ _ _ t1) => [|e1 et1].
    case Det2: (cprr _ _ _ t2) => [|e2 et2].
      by apply: Ht3; rewrite [Color3]lock /= -addcA addc_inv.
    by rewrite -Det2; apply: Ht2; rewrite [Color2]lock /= -addcA addc_inv.
  by rewrite -Det1; apply: Ht1; rewrite [Color1]lock /= -addcA addc_inv.
by move=> Het /=; case (ctree_mem t' (etrace (belast e et))).
Qed.

Lemma size_ctree_pick_rev : forall t t',
  ctree_proper h t' -> set2 0 (S h) (size (ctree_pick_rev t t')).
Proof.
move=> t' t; rewrite /ctree_pick_rev; set cs0 : colseq := seq0.
have Ecs0: size cs0 + h = h by done.
elim: {1 3}h t cs0 {1}Color0 Ecs0 => [|n Hrec] [t1 t2 t3|lf|] et e //=.
rewrite addn0; case: (ctree_mem t' (etrace (belast e et))) => // Het.
  by rewrite /set2 /= Het set11.
rewrite -addSnnS; move=> Het [_ Ht1 Ht2 Ht3].
set cprr := ctree_pick_rev_rec.
case Det1: (cprr _ _ _ t1) => [|e1 et1]; last by rewrite -Det1; auto.
by case Det2: (cprr _ _ _ t2) => [|e2 et2]; last rewrite -Det2; auto.
Qed.

Section BirkhoffTree.

Variable check_basis : ctree -> bool.

Definition do_bkf_check2 et ctu gtu chk :=
  let ctr := ctree_of_ttail (etrace et) in
  if et Color0 then false else
  let (ctu', gtru') := kempe_tree_closure (pred h) h ctu ctr gtu in
  if gtru' is Gtree_pair Gtree_empty gtu' then
    check_basis ctu' || chk ctu' gtu'
  else false.

Fixpoint bkf_check2 (ctu1 : ctree) (gtu1 : gtree) (n : nat)
                    (ctu2 : ctree) (gtu2 : gtree) {struct n} : bool :=
  if n is S n' then
    if ctree_pick_rev ctu1 ctu2 is Adds e et then
         do_bkf_check2 (belast e et) ctu1 gtu1 (bkf_check2 ctu2 gtu2 n')
      && do_bkf_check2 (rev et) ctu2 gtu2 (bkf_check2 ctu1 gtu1 n')
    else false
  else false.

End BirkhoffTree.

Definition bkf_check1 cp :=
  and3b (cubic_prog cp) (S (card (cpmap cp)) < 6 * m + 4 * h) (cprsize cp =d S h).

Inductive birkhoff_check : Prop :=
    BkfCheck: forall niter cps,
      let ctu := ctree_init_tree h in let gtu := gtree_init_tree h in
      let basis := maps cpcolor cps in
      let chkb t := has (ctree_disjoint t) basis in
      all bkf_check1 cps -> bkf_check2 chkb ctu gtu niter ctu gtu ->
    birkhoff_check.

End BirkhoffCheck.

Module BirkhoffCheckLemmas.

Import ConfigSyntax.

Lemma birkhoff2 : birkhoff_check 1 0.
Proof. by exists 1 (Seq (Cprog)). Qed.

Lemma birkhoff3 : birkhoff_check 2 0.
Proof. by exists 1 (Seq (Cprog Y)). Qed.

Lemma birkhoff4 : birkhoff_check 3 0.
Proof. by exists 4 (Seq (Cprog U) (Cprog 1 U)). Qed.

Lemma birkhoff5 : birkhoff_check 4 1.
Proof.
by exists 10 (Seq (Cprog U Y) (Cprog 1 U Y) (Cprog 2 U Y) (Cprog 3 U Y)
                  (Cprog 4 U Y) (Cprog H 4 Y Y Y)).
Qed.

End BirkhoffCheckLemmas.

Import BirkhoffCheckLemmas.

Section Birkhoff.

Variable g : hypermap.
Hypothesis Hg : minimal_counter_example g.

Let Hpg : planar g := Hg.
Let Hbg : bridgeless g := Hg.
Let HgE : plain g := Hg.
Let HgN : cubic g := Hg.
Let Hcg : connected g := Hg.
Let Hkg := minimal_counter_example_is_noncolorable Hg.
Let Hmg := minimal_counter_example_is_minimal Hg.
Let De2 := plain_eq Hg.
Let He1 := plain_neq Hg.
Let Dn3 := cubic_eq Hg.

Section BirkhoffValid.

Variable n : nat.
Hypothesis Hn : forall r : seq g, scycle rlink r -> size r <= n ->
   nontrivial_ring 0 r = false.

Lemma birkhoff_valid : forall m, birkhoff_check n m ->
 forall r : seq g, scycle rlink r -> size r = S n -> nontrivial_ring m r = false.
Proof.
move=> m [nm cps ctu0 gtu0 basis chkb Hbk1 Hbk2].
have Hchkb: forall (r : seq g) (HUr : scycle rlink r),
    size r = S n -> nontrivial_ring m r ->
    forall ctu, chkb ctu ->
    exists2 et, ring_trace (snipd_ring Hpg HUr) (ctrace et)
             &  negb (ctree_mem ctu (etrace et)).
  move=> r HUr Hrn Hrm ctu; move: Hbk1 {Hbk2}; rewrite {}/chkb {}/basis.
  elim: cps => [|cp cps Hrec] //=; case/andP; move/and3P=> [Hqcp Hkcp Hrcp] Hbk1.
  case/orP; auto; move{cps Hbk1 Hrec} => Hctu.
  have Hcp := cpmap_proper Hqcp.
  pose gr := cpmap cp; pose bgr : seq gr := rotr 1 (rev (cpring gr)).
  have Hbgr: ufcycle node bgr.
    rewrite /ucycle /bgr /rotr uniq_rot uniq_rev uniq_cpring.
    by rewrite cycle_rot cycle_rev_cpring.
  pose gd := snip_disk Hpg HUr; pose bgd : seq gd := snipd_ring Hpg HUr.
  have Hbgd: sfcycle edge bgd by apply: scycle_snipd_ring.
  have Hbgdr: size bgd = size bgr.
    rewrite /bgr /rotr size_rot size_rev /gr size_ring_cpmap (eqP Hrcp) -Hrn.
    by rewrite -(maps_snipd_ring Hpg HUr) size_maps.
  have Hpp := sew_map_patch Hbgd Hbgr Hbgdr.
  have Hppr := snip_patch Hpg HUr; rewrite -/bgd in Hppr.
  pose g' := sew_map Hbgd Hbgr Hbgdr.
  move: HgE HgN; rewrite (plain_patch Hppr) (cubic_patch Hppr).
  move/andP=> [HgdE HgrrE]; move/andP=> [HgdN HgrrN].
  have Hpg': planar g'.
    rewrite /planar /g' (genus_patch Hpp).
    rewrite /gr ((_ =P 0) (cpmap_planar Hqcp)) addn0; exact: planar_snipd.
  have Hg'E: plain g'.
    by rewrite /g' (plain_patch Hpp); apply/andP; split; last exact: cpmap_plain.
  have Hg'N: cubic g'.
    rewrite /g' (cubic_patch Hpp); apply/andP; split; first done.
    apply: (etrans (eq_subset _ _) (cpmap_cubic Hqcp)) => x.
    by rewrite /setC /bgr mem_rotr.
  have Hbg': bridgeless g'.
    apply: (bridgeless_patch Hpp _ (cpmap_bridgeless Hqcp) _).
      by case (patch_bridgeless Hppr Hbg).
    apply/idPn => [Hch].
    case: (ring_disk_chord Hg Hrm Hch) => [r' HUr' [Hr' Hrr']].
    by rewrite Hrn ltnS in Hrr'; case/idP: (Hn HUr' Hrr').
  have Hkg': four_colorable g'.
    apply Hmg; try by repeat split; try apply cubic_precubic.
    rewrite ltnNge -(leq_add2l (size bgd)).
    move: (card_patch Hpp) (card_patch Hppr); rewrite !size_maps -/g'.
    rewrite -/gd -/bgd => <- <-; rewrite leq_add2l -ltnNge -ltnS.
    apply: (leq_trans Hkcp); pose bgrr := snipr_ring Hpg HUr.
    have Ebgrr: size bgrr = S n.
      by rewrite -Hrn -(size_rev r) -(maps_snipr_ring Hpg HUr) size_maps.
    case Dbgrr: bgrr (Ebgrr) => // [bgrr0 bgrr'] _.
    have Hbgrr: ucycle_plain_quasicubic_connected bgrr.
      split; first by split; [ split | apply: ucycle_snipr_ring ].
      by apply: (patch_connected_r Hppr Hcg); apply/set0Pn; exists bgrr0.
    move: (planar_snipr Hpg HUr); rewrite -/bgrr (quasicubic_Euler Hbgrr) Ebgrr.
    rewrite (patch_fcard_face_r Hppr) /outer -/gr.
    move: (card (snip_rem Hpg HUr)) => ngrr.
    pose arF := setU (diskFC r) (fband r).
    have HarF: fcard face arF = S n + fcard face (diskFC r).
      symmetry; rewrite -Hrn -(scycle_fcard_fband HUr) /n_comp -cardUI addnC.
      rewrite -(@eq_card g set0) ?card0.
        apply: eq_card => x; rewrite /setI /arF /diskFC /setU /setD.
        by case (fband r x); rewrite /= andbF ?orbF.
      move=> x; rewrite /setI /diskFC /setD.
      by case (fband r x); rewrite /= !andbF.
    rewrite Dbgrr -(@eq_n_comp_r _ arF) [muln]lock /=; unlock.
      rewrite HarF double_mul2 -(add1n n) !muln_addr !muln1 !addnA -addnA addnC.
      rewrite eqn_addr -{1}[6]/(2 + 4) muln_addl -addnA addnC eqn_addr addnS addn1.
      rewrite -ltnS; move/eqP=> <-; rewrite -addSn addnC leq_add2l.
      by rewrite ltnNge leq_mul2l orFb -ltnNge; case/andP: Hrm.
    have Ddgr := codom_snipr Hpg HUr; move=> x; apply/idP/set0Pn.
    rewrite /arF /diskFC /setU /setD; case Hx: (fband r x).
      case: (hasP Hx) => [y Hy Hxy] _; exists y.
        by rewrite /setI Hxy Ddgr /setC /diskE /setD Hy.
      move=> HxN; rewrite /= orbF in HxN; exists x; rewrite /setI connect0.
      by rewrite Ddgr /setC /diskE /setD (negbE HxN) andbF.
    case; move=> y; move/andP=> [Hxy Hy]; rewrite Ddgr in Hy.
    rewrite /arF /diskFC /setU /setD.
    case Hx: (fband r x); [ by rewrite orbT | rewrite /= orbF ].
    case HxF: (diskF r x).
      rewrite (closed_connect (diskF_face r) Hxy) in HxF.
      case: (andP HxF) => [H HyN]; case: {H}(elimN hasP H).
      rewrite /setC /diskE /setD HyN andbT negb_elim in Hy.
      by exists y; last by apply connect0.
    by rewrite /diskF /setD Hx /= in HxF; rewrite /setC HxF.
  case: (colorable_patch Hpp) => [H _]; case: {H}(H Hkg').
  case/lastP=> [|et e] Hetd Hetr.
  case: Hetr => [k _ Det]; move: (congr1 size Det).
    by rewrite /bgr size_trace size_maps size_rotr size_rev head_cpring.
  have De: sumt et = e.
    case: Hetd => [k _ Det]; move: (congr1 sumt Det); rewrite sumt_trace /=.
    rewrite -{2}[e]add0c => <-; elim: et {Hetr Det} => [|e' et Hrec] /=.
      by rewrite addcC addc_inv.
    by rewrite Hrec addcA.
  exists et; first by rewrite /ctrace De.
  apply: (negbI (ctree_mem_disjoint Hctu _)) {Hetd}.
  apply/(ctree_mem_cpcolor _ _); split; first by apply even_etrace.
  rewrite /etrace; set (h := etrace_perm et); rewrite sumt_permt De.
  case: Hetr => [k Hk Det]; exists (comp h k).
    apply: (coloring_inj (h := h)) Hk => //; apply permc_inj.
  rewrite -/gr (maps_comp h k) -/(permt h) trace_permt.
  rewrite -(rev_rev (cpring gr)) maps_rev trace_rev.
  rewrite -(rot_rotr 1 (rev (cpring gr))) maps_rot trace_rot -/bgr -Det.
  by rewrite -rev_rotr rotr_rot -rev_rotr rev_rev rotr1_add_last.
move=> r HUr Hrn; apply/idP => Hrm; case Dn: n => [|n'].
  case: (r) Hrn (andP HUr) => [|x [|x' r']]; try by rewrite Dn.
  by move=> _ [H _]; case: {H}(andP H); rewrite /rlink Sface (set0P Hbg x).
have HUr2 := scycle_rev_ring Hg HUr.
pose kv P := kempe_valid n' (fun et => ~ P et) ctu0 Ctree_empty Gtree_empty gtu0.
have Hkv0: kv (ring_trace (snipd_ring Hpg HUr)) /\
           kv (ring_trace (snipd_ring Hpg HUr2)).
  split; rewrite /kv /ctu0 /gtu0 Dn; exact: kempe_valid_init.
case/negPf: Hbk2; move: Hrn Hrm HUr HUr2 Hkv0; rewrite {}/kv.
elim: nm r ctu0 gtu0 {2 4}ctu0 {2 4}gtu0 => [|nm Hrec]; auto.
move=> r1 ctu1 gtu1 ctu2 gtu2 Hr1n Hr1m HUr1; set r2 := rev_ring r1.
move=> HUr2 [Hk1 Hk2] /=.
have Hr2n: size r2 = S n by rewrite /r2 /rev_ring size_rev size_maps.
have Hr2m: nontrivial_ring m r2 by apply: (nontrivial_rev_ring Hg).
have Hcl1 := @ring_disk_closed _ Hg Hpg _ HUr1 _ Hr1m HgN.
have Hcl2 := @ring_disk_closed _ Hg Hpg _ HUr2 _ Hr2m HgN.
case Det: (ctree_pick_rev ctu1 ctu2) => [|e et] //=.
apply/andP => [[Hck1 Hck2]]; case Hkg.
apply (@colorable_from_ring _ Hg Hpg _ HUr1 _ Hr1m (Adds e et)).
  case (decide_ring_trace (snipd_ring Hpg HUr1) (Adds e et)); auto.
  move=> Het; move: Hck1 {Hck2}; rewrite /do_bkf_check2 {1}Dn /pred.
  set ctr := ctree_of_ttail _.
  case Het0: (belast e et Color0); first done.
  pose P et' := ~ ring_trace (snipd_ring Hpg HUr1) et'.
  case (@kempe_tree_closure_correct n' P n ctu1 ctr gtu1).
    apply: kempe_valid_restrict Hk1 => et' Het'.
    rewrite {Het'}(ctree_of_ttail_mem _ _ Het');
      last by rewrite /etrace memc0_permt Het0.
    rewrite /etrace ctrace_permt {2}/permt size_maps; split.
      move: (etrace_perm _) => ge.
      move/(Hcl1 _)=> [Het' _]; case: Het; move: (Het' (inv_eperm ge)).
      have <-: Adds e et = ctrace (belast e et).
        have Hets := sumt_ctree_pick_rev ctu1 ctu2.
        rewrite Det in Hets; rewrite -(trace_untrace Color0 Hets) /trace /=.
        by rewrite (pairmap_scanl addc_inv).
      by rewrite /permt (monic_maps (inv_permc ge)).
    case: (Hk2) => [Hctu2 _]; move: (size_ctree_pick_rev ctu1 Hctu2).
    by rewrite -Dn size_belast Det /set2 /= eqdSS; move/eqP=> ->.
  case: (kempe_tree_closure n' n ctu1 ctr gtu1) => [ctu' [gtr gtu']].
  case: gtr => // Hctu' _; case/orP=> Hck.
    move: {Hchkb Hrec Hck}(Hchkb _ HUr1 Hr1n Hr1m _ Hck) => [et1 Het1 Hctu1].
    have Hset1: size et1 = S n'.
      symmetry; rewrite -Dn -[n]/(pred (S n)) -Hr1n.
      rewrite -(maps_snipd_ring Hpg HUr1) size_maps.
      case: Het1 => [k _ Det1]; rewrite -(size_maps k) -size_trace -Det1.
      by rewrite /ctrace size_add_last.
    case: (kempe_validP Hctu' Hset1 Hctu1 Hcl1 Het1) => s H; case/H {P H}.
  rewrite {Hk1 Hcl1 Het}/P in Hctu'.
  rewrite -(rev_rev_ring Hg r1) -/r2 in HUr1 Hctu' |- *.
  case/negPf: Hck; eapply (Hrec r2); auto; split; eauto.
case (decide_ring_trace (snipd_ring Hpg HUr2) (rev (Adds e et))).
  rewrite /rev_snipd_ring /rev_snipd_disk.
  by rewrite (bool_eqT (scycle_rev_ring Hg HUr1) HUr2).
move=> Het; move: Hck2 {Hck1}; rewrite /do_bkf_check2 {1}Dn /pred.
set ctr := ctree_of_ttail (etrace (rev et)).
case Het0: (rev et Color0); first done.
pose P et' := ~ ring_trace (snipd_ring Hpg HUr2) et'.
case (@kempe_tree_closure_correct n' P n ctu2 ctr gtu2).
  apply: kempe_valid_restrict (Hk2) => et' Het'.
  rewrite {Het'}(ctree_of_ttail_mem _ _ Het');
    last by rewrite /etrace memc0_permt Het0.
  rewrite /etrace ctrace_permt {2}/permt size_maps; split.
    move: (etrace_perm (rev et)) => ge; move/(Hcl2 _)=> [Het' _].
    case: Het; move: (Het' (inv_eperm ge)).
    have <-: rev (Adds e et) = ctrace (rev et).
      have Hrets: sumt (rev (Adds e et)) = Color0.
        rewrite -(rotr_rot 1 (rev (Adds e et))).
        have Hets := (sumt_ctree_pick_rev ctu1 ctu2).
        rewrite Det in Hets; rewrite -(trace_untrace Color0 Hets) -trace_rev.
        rewrite -(rot_rotr 1 (rev (untrace Color0 (Adds e et)))).
        by rewrite trace_rot rotr_rot sumt_trace.
      rewrite -(trace_untrace Color0 Hrets) rev_adds /untrace /=.
      by rewrite belast_add_last /trace /= (pairmap_scanl addc_inv).
    by rewrite /permt (monic_maps (inv_permc ge)).
  case: (Hk2) => [Hctu2 _]; move: (size_ctree_pick_rev ctu1 Hctu2).
  by rewrite -Dn size_rev Det /set2 /= eqdSS; move=> H; rewrite (eqP H).
move: (kempe_tree_closure n' n ctu2 ctr gtu2) => [ctu' [gtr gtu']].
rewrite {}/P; case: gtr=> // Hctu' _; case/orP=> Hck.
 case: {Hchkb Hrec Hck}(Hchkb _ HUr2 Hr2n Hr2m _ Hck) => [et2 Het2 Hctu2].
  have Hset2: size et2 = S n'.
    symmetry; rewrite -Dn -[n]/(pred (S n)) -Hr2n.
    rewrite -(maps_snipd_ring Hpg HUr2) size_maps.
    case: Het2 => [k _ Det2]; rewrite -(size_maps k) -size_trace -Det2.
    by rewrite /ctrace size_add_last.
  case: (kempe_validP Hctu' Hset2 Hctu2 Hcl2 Het2) => s H; case/H.
by case/negPf: Hck; eapply (Hrec r1); auto; split; eauto.
Qed.

End BirkhoffValid.

Theorem birkhoff : forall r : seq g,
  size r <= 5 -> scycle rlink r -> nontrivial_ring (size r =d 5) r = false.
Proof.
elim: {1 3}5 (leqnn 5) => [|n Hrec] Hn.
  move=> [|x r] // _ _; rewrite /nontrivial_ring /n_comp eq_card0 //.
  by move=> x; rewrite /setI andbC.
move: {Hrec}(Hrec (ltnW Hn)) => Hrec.
move=> r Hrn; rewrite leq_eqVlt in Hrn; case/orP: Hrn; auto.
move=> Hrn Hr; apply: (birkhoff_valid _ _ Hr (eqP Hrn)).
  move {r Hrn Hr} => r Hr Hrn; rewrite -(Hrec r Hrn Hr).
  by rewrite -ltnS in Hrn; rewrite eqn_leq andbC leqNgt (leq_trans Hrn Hn).
rewrite (eqP Hrn); case: n Hrn Hn {Hrec} => [|n].
  case: r Hr => [|x [|x' r']] //=.
  by rewrite /scycle /= /rlink Sface (set0P Hbg x).
case: n => [|[|[|[|n]]]] _ // _.
- exact birkhoff2.
- exact birkhoff3.
- exact birkhoff4.
exact birkhoff5.
Qed.

Lemma nontrivial_cycle2 : forall x y : g, let r := seq2 x y in
 scycle rlink r -> negb (edge x =d y) -> nontrivial_ring 0 r.
Proof.
move=> x y r HUr Hexy; apply/(nontrivial0P _); split.
  exists (node x); rewrite /diskF /setD -(fclosed1 (diskN_node r)).
  rewrite diskN_E /setU /= setU11 /= -{2}[x]Enode -cface1r (set0P Hbg) /=.
  case: (andP HUr); move/and3P=> [Hxy Hyx _] _.
  rewrite Sface -(same_cface Hxy) -[node x]Enode -{1}[x]Dn3.
  by rewrite cface1 Enode -cface1r (set0P Hbg).
pose nex := node (edge x); case Hnex: (fband r nex).
  rewrite /fband in Hnex; case: (hasP Hnex) => [z Hz Hnexz].
  rewrite /= /setU1 orbF in Hz; case/orP: Hz => Dz.
    rewrite -{1}[nex]Enode /nex -{1}[x]Eface De2 Dn3 -cface1 Sface in Hnexz.
    by rewrite -(eqP Dz) cface1 (set0P Hbg) in Hnexz.
  case: (andP HUr); move/andP=> [Hxy _].
  rewrite Sface -(eqP Dz) -(same_cface Hxy) in Hnexz.
  by rewrite -[edge x]Enode -/nex -cface1 Sface (set0P Hbg) in Hnexz.
exists nex; rewrite /diskFC /setD Hnex /= /setC /nex.
rewrite -(fclosed1 (diskN_node r)) diskN_E /setU.
rewrite -(fclosed1 (diskE_edge Hpg HUr)) /diskE /setD /= setU11 /= /setU1.
by rewrite eqd_sym He1 eqd_sym (negbE Hexy).
Qed.

Lemma double_dart : forall x y : g,
  cface x y -> cface (edge x) (edge y) -> x = y.
Proof.
move=> /= x y HxyF Hexey; apply: eqP; apply/idPn => [Hxy].
have HUp: scycle rlink (seq2 x (edge y)).
  by rewrite srcycleI //= Hexey De2 Sface.
rewrite -(inj_eqd (Iedge g)) in Hxy.
by apply: (elimF idP (birkhoff _ HUp) (nontrivial_cycle2 HUp Hxy)).
Qed.

Section SpokeRing.

Variable x : g.

Let p : seq g := orbit face x.

Remark SpokeRing_Hpx : p x. Proof. by rewrite /p -fconnect_orbit connect0. Qed.
Let Hpx := SpokeRing_Hpx.

Remark SpokeRing_HUp : ufcycle face p.
Proof. by rewrite /p /ucycle uniq_orbit (cycle_orbit (Iface g)). Qed.
Let HUp := SpokeRing_HUp.

Remark SpokeRing_Ep : cface x =1 p. Proof. by apply: fconnect_orbit. Qed.
Notation Ep := SpokeRing_Ep.

Definition spoke (y : g) : g := face (edge y).

Lemma inj_spoke : injective spoke.
Proof. apply: (monic_inj (g := node)); apply: Eedge. Qed.

Definition spoke_ring : seq g := maps spoke (rev p).

Lemma mem_spoke_ring : forall y : g, spoke_ring y = cface x (node y).
Proof.
move=> y; rewrite /spoke_ring -{1}[y]Enode -/(spoke (node y)).
by rewrite (mem_maps inj_spoke) mem_rev Ep.
Qed.

Notation r := spoke_ring.
Notation Er := mem_spoke_ring.

Lemma next_spoke_ring : forall y : g, r y -> next r y = face (spoke y).
Proof.
case: (andP HUp) => [Hp Up] y Hy.
rewrite /r -{1}[y]Enode -/(spoke (node y)).
rewrite (next_maps inj_spoke); last by rewrite uniq_rev.
rewrite (next_rev Up) -(Eface g (prev p (node y))) /spoke De2.
by rewrite Er Ep in Hy; rewrite (eqP (prev_cycle Hp Hy)) -{1}[y]Eedge Dn3.
Qed.

Lemma scycle_spoke_ring : scycle rlink r.
Proof.
case: (andP HUp) => [Hp Up]; apply/andP; split.
  apply cycle_from_next; first by rewrite /r (uniq_maps inj_spoke) ?uniq_rev.
  move=> y Hy; rewrite (next_spoke_ring Hy) /rlink -cface1r; exact: fconnect1.
rewrite /simple /r !maps_rev uniq_rev -maps_comp /comp.
have HpF: sub_set p (cface x) by move=> y Hy; rewrite Ep.
elim: (p) HpF {Hp} Up => [|y q Hrec] Hq //=; move/andP=> [Hqy Uq].
rewrite {Hrec Uq}(Hrec (fun z Hz => Hq z (setU1r _ Hz)) Uq) andbT.
apply/mapsP => [] [z Hz Hyz]; case/idP: Hqy.
rewrite (@double_dart y z) //.
  rewrite -(same_cface (Hq _ (setU11 _ _))); exact (Hq _ (setU1r _ Hz)).
by rewrite cface1 cface1r; apply/(rootP (Sface _)).
Qed.
Let HUr := scycle_spoke_ring.

Lemma diskF_spoke_ring : diskF r =1 cface x.
Proof.
move=> y; symmetry; apply/idP/idP.
  move=> Hxy; apply/andP; split.
    apply/hasP => [] [z1 Hz1 Hyz1]; rewrite Er in Hz1.
    case/idP: (set0P Hbg (node z1)).
    rewrite cface1r Enode -(same_cface Hz1); exact (connect_trans Hxy Hyz1).
  by rewrite /= -{1}[y]Eedge -(fclosed1 (diskN_node r)) diskN_E /setU Er Eedge Hxy.
case/andP=> Hy; move/hasP=> [z Hz Hzy]; case/connectP: Hzy Hy.
set z' := finv node z; rewrite Er in Hz.
have Hz': r (face z').
  by rewrite -(De2 z') Er Eedge -(Dn3 z') /z' (f_finv (Inode g)) cface1r Enode.
case=> [|z'' q] Hq <-.
  by case/hasP=> /=; exists (face z'); last by apply fconnect1.
move: Hq; rewrite /= {1}/dlink; case (r z'); first done.
case/andP; case/clinkP=> [Dz'|Dz''] Hq.
  rewrite -(f_finv (Inode g) z) -/z' (Inode g (etrans (Dn3 _) Dz')) in Hz.
  elim: q z'' {y z z' Hz' Dz'}Hz Hq => [|z q Hrec] y Hy //=.
  rewrite {1}/dlink; case: (r y) => //; case/andP; case/clinkP=> [Dy|Dz].
    have Hz: r z by rewrite Er -Dy.
    case: q {Hrec} => [|z' q]; last by rewrite /= /dlink Hz.
    by rewrite /= (subsetP (ring_fband r) _ Hz).
  by apply: Hrec; rewrite -Dz -cface1r.
rewrite Dz'' in Hz'; case: q Hq => [|z''' q]; last by rewrite /= /dlink Hz'.
by rewrite /= (subsetP (ring_fband r) _ Hz').
Qed.

Lemma chordless_spoke_ring : chordless r.
Proof.
apply/subsetP => [y1 Hy1]; apply/set0Pn => [] [y2]; case/andP.
move/adjP=> [z Hz1 Hz2]; rewrite /rlink in Hz2; move/and3P=> [Hry12 Hry21 Hy2].
pose q := seq3 (node y2) (edge z) (edge (node y1)).
have HUq: scycle rlink q.
  rewrite srcycleI //= !De2 cface1 Enode Sface Hz2 /= andbC.
  rewrite cface1r Enode Sface Hz1 /= Sface; rewrite !Er in Hy1 Hy2.
  by rewrite -!(same_cface Hy2) !(same_cface Hy1) connect0 (set0P Hbg).
apply: (elimF idP (birkhoff _ HUq) _); first done.
apply/(nontrivial0P _); split.
  pose t := node (edge (node y1)); exists t; rewrite /diskF /setD /=.
  have Dt: t = prev r y1.
    move: (andP HUr) => [_ Ur]; rewrite /t -{1}[y1](next_prev (simple_uniq Ur)).
    by rewrite next_spoke_ring ?mem_prev // Eface /spoke Eedge.
  rewrite Er in Hy2; rewrite Sface -(same_cface Hy2).
  have Ht: cface x (node t) by rewrite -Er Dt mem_prev.
  rewrite (same_cface Ht) -{2}[t]Enode -cface1r (set0P Hbg).
  rewrite Sface (same_cface Hz2) Sface /= orbC.
  rewrite -[edge (node y1)]Enode -cface1r (set0P Hbg).
  rewrite {2}/t -(fclosed1 (diskN_node q)) diskN_E /setU /= /setU1 set11.
  rewrite /= !orbT andbT; apply/idP => [Hy2t]; case/eqP: Hry21.
  by rewrite -Dt; apply (scycle_cface HUr); rewrite ?Er.
exists (node (node y1)); rewrite /diskFC /setD /= /setC.
rewrite andbC -(fclosed1 (diskN_node q)) -{1}[node y1]De2.
rewrite (diskN_edge_ring Hg) /= /setU1 ?set11 /= ?orbT //; rewrite !Er in Hy1 Hy2.
rewrite Sface -(same_cface Hy2) (same_cface Hy1) -{1}[node y1]Enode -cface1.
rewrite Sface (set0P Hbg) /= orbF orbC -[node (node y1)]Enode Dn3.
rewrite -cface1 Sface cface1 Enode (set0P Hbg) /= cface1 -/(spoke y1).
rewrite -next_spoke_ring; last by rewrite Er.
apply/idP => [Hy2t]; case/eqP: Hry12.
by apply (scycle_cface HUr); rewrite ?mem_next ?Er // (same_cface Hy2t).
Qed.

Lemma size_spoke_ring : size r = order face x.
Proof. by rewrite /r size_maps size_rev /p /orbit size_traject. Qed.

Lemma min_arity : 4 < order face x.
Proof.
rewrite /= -size_spoke_ring ltnNge; apply/idP => HrF.
case HrFC: (negb (set0b (diskFC r))).
  apply: (elimF idP (birkhoff _ HUr) _); first by apply ltnW.
  case: (size r =P 5) => [Hr5|_]; first by rewrite Hr5 in HrF.
  apply/(nontrivial0P _); split; last by exact (set0Pn HrFC).
  by exists x; rewrite diskF_spoke_ring connect0.
move: {HrFC}(set0P (negbEf HrFC)) => HrFC.
case Hkg;  exists (fun y =>
  if cface x y then Color0 else
  let i := find (cface y) r in
  if (i =d 2) && (size r =d 3) then Color3 else
  if set2 0 2 i then Color1 else Color2).
split=> y; rewrite /invariant;
  last by rewrite -cface1r -(eq_find (cface1 y)) set11.
set i1 := find (cface y) _; set i2 := find (cface (edge y)) _.
case Hxy: (cface x y).
  rewrite (same_cface Hxy) (set0P Hbg).
  by case: (_ && _); last by case (set2 0 2 i2).
case Hxey: (cface x (edge y)); first by case: (_ && _); last by case (set2 0 2 i1).
case Hy: (fband r y);
  last by rewrite -diskF_spoke_ring /diskF /setD Hy /= in Hxy;
          move: (HrFC y); rewrite /diskFC /setD Hy /setC Hxy.
case Hey: (fband r (edge y));
  last by rewrite -diskF_spoke_ring /diskF /setD Hey /= in Hxey;
          move: (HrFC (edge y)); rewrite /diskFC /setD Hey /setC Hxey.
pose z1 := sub x r i1; pose z2 := sub x r i2.
have Hz12: adj z1 z2.
  apply/adjP; exists y; first rewrite Sface; exact: sub_find.
rewrite /fband has_find -/i1 in Hy; rewrite /fband has_find -/i2 in Hey.
have Hz1: r z1 by rewrite /z1 (mem_sub x Hy).
have Hz2: r z2 by rewrite /z2 (mem_sub x Hey).
move: {Hz1}(set0P (subsetP chordless_spoke_ring _ Hz1) z2).
case: (andP HUr) => Hr; move/simple_uniq=> Ur.
rewrite /setI /setD1 {}Hz12 {}Hz2 (monic2F_eqd (prev_next Ur)) -(eqd_sym z2).
have Hpri: forall i i', i < size r -> i' < size r ->
  (sub x r i' =d prev r (sub x r i)) = (i' =d pred (if i =d 0 then size r else i)).
- move=> i i' Hi Hi'; set z := sub x r i.
  suffice <-: index (prev r z) r = pred (if i =d 0 then size r else i).
    apply/eqP/eqP=> [<- | ->]; first by rewrite (index_uniq x Hi' Ur).
    by rewrite sub_index // mem_prev /z mem_sub.
  rewrite prev_sub {}/z mem_sub // {i' Hi'}.
  case Dr: r Ur Hi => [|x0 r'] Ur //.
  rewrite index_uniq //; last by rewrite /= ltnS index_size.
  simpl in Ur; case/andP: Ur => [Hx0 Ur'].
  case: i => [|i] Hi; rewrite /= ?index_uniq //.
  by rewrite -{1}[r']cats0 index_cat (negbE Hx0) /= addn0.
rewrite {}/z1 {}/z2 !{}Hpri //.
case Dn: (size r) HrF Hy Hey => [|[|n]] //.
  case: r HUr Dn => [|x0 [|x1 r']] //.
  by rewrite /scycle /= andbT /rlink Sface (set0P Hbg).
by case: i1 i2 n {Dn} => [|[|[|[|i1]]]] [|[|[|[|i2]]]] [|[|[|n]]].
Qed.

Lemma fband_spoke_ring : fband r =1 adj x.
Proof.
move=> y; apply/hasP/adjP => [] [z Hxz Hzy].
  by exists (node z); [rewrite -Er | rewrite /rlink cface1 Enode Sface].
by exists (face (edge z)); [rewrite Er Eedge | rewrite -cface1r Sface].
Qed.

Lemma adj11_edge : forall y, adj x y -> adj x (edge y) -> r y || r (edge y).
Proof.
move=> y; rewrite -!fband_spoke_ring.
move/hasP=> [z Hrz Hyz]; move/hasP=> [z' Hrz' Heyz']; apply/norP => [] [Hry Hrey].
case/andP: (set0P (subsetP chordless_spoke_ring _ Hrz) z'); split.
  by apply/adjP; exists y; first by rewrite Sface.
case: (andP HUr) => _; move/simple_uniq=> Ur.
rewrite /setD1 Hrz' andbT (monic2F_eqd (next_prev Ur)) !next_spoke_ring //.
apply/andP; split; apply/eqP => Dz.
  rewrite -Dz /spoke -!cface1r in Heyz'.
  by rewrite (double_dart Hyz Heyz') Hrz in Hry.
rewrite Dz /spoke -!cface1r -{1}[y]De2 in Hyz.
by rewrite (double_dart Heyz' Hyz) Hrz' in Hrey.
Qed.

Lemma fcard_adj_adj : forall y, adj x y -> fcard face (setI (adj y) (adj x)) = 2.
Proof.
move=> y Hy; have Hry := Hy; rewrite -fband_spoke_ring in Hry.
move/hasP: Hry => [y' Hy' Hyy'].
rewrite /n_comp (cardD1 (froot face (next r y'))).
rewrite (cardD1 (froot face (prev r y'))).
rewrite {1}/setD1 {1 2 3 4}/setI !(roots_root (Sface g)).
have Hra: forall z, r z -> adj x z.
  by move=> z; rewrite Er; move=> Hnxz; rewrite (adjF Hnxz) adjN.
set z := prev r y'; have Hz: r z by rewrite /z mem_prev.
set z' := next r y'; have Hz': r z' by rewrite /z' mem_next.
rewrite -!(adjFr (connect_root _ _)) !Hra //.
case: (andP HUr) => Hr; move/simple_uniq=> Ur.
rewrite !(adjF Hyy') /z' (rlink_adj (next_cycle Hr Hy')) -/z'.
rewrite Sadj // /z (rlink_adj (prev_cycle Hr Hy')) -/z /=.
rewrite (sameP eqP (rootPx (Sface g) z' z)).
case Hz'z: (cface z' z).
  case: (rot_to Hz) min_arity (cycle_next Ur) (Ur) => [i r' Dr].
  rewrite -size_spoke_ring -(size_rot i) -(cycle_rot i) -(uniq_rot i) Dr.
  case: r' {Dr} => [|y'' [|z'' r']] // _; move/and3P=> [Dy'' Dz'' _].
  case/andP; case/orP; right; apply/setU1P; left.
  rewrite -(eqP Dz'') -(eqP Dy'') {1}/z (next_prev Ur) -/z'.
  exact: (scycle_cface HUr).
apply: eqP; apply/set0Pn => [] [t]; move/and5P=> [Hzt Hz't Ht Hyt Hxt].
rewrite -(eqP Ht) (sameP eqP (rootPx (Sface _) z t)) in Hzt.
rewrite -{Ht}(eqP Ht) (sameP eqP (rootPx (Sface _) z' t)) in Hz't.
rewrite -fband_spoke_ring in Hxt; case/hasP: Hxt => [t' Ht' Htt'].
case/andP: (set0P (subsetP chordless_spoke_ring _ Hy') t'); split.
  by rewrite -(adjF Hyy') -(adjFr Htt').
rewrite /setD1 Ht' andbT; apply/andP; split; apply/eqP => [Dt'].
  by rewrite Sface (same_cface Htt') -Dt' -/z' connect0 in Hz't.
by rewrite Sface (same_cface Htt') -Dt' -/z connect0 in Hzt.
Qed.

Definition adj01 (y z : g) := cface y z || adj y z.

Lemma adj12_edge : forall y z,
  adj x y -> adj x z -> adj z (edge y) -> adj01 z y || adj01 x (edge y).
Proof.
move=> y z0; rewrite -2!fband_spoke_ring.
move/hasP=> [y' Hry' Hyy']; move/hasP=> [z Hrz Hz0z].
move/adjP=> [z' Hzz' Heyz']; rewrite /rlink Sface in Heyz'.
apply/norP; case; move/norP=> [Hzy Hazy]; move/norP=> [Hxey Haxey].
rewrite !(same_cface Hz0z) in Hzy Hzz'; rewrite {z0 Hz0z}(adjF Hz0z) in Hazy.
pose q := Adds y (seq3 (edge z') (edge (node z)) (node y')).
have HUq: scycle rlink q.
  rewrite srcycleI //= Heyz' cface1r Enode Sface Hzy !De2 /=.
  rewrite (same_cface Hyy') Sface (adj_no_cface Hbg (adjN y')) /=.
  rewrite !Er in Hry' Hrz.
  rewrite cface1r Enode Sface Hzz' -(same_cface Heyz') Sface -(same_cface Hry').
  by rewrite Hxey -(same_cface Hrz) Hry' cface1 Enode Sface Hyy'.
apply: (elimF (nontrivial0P _) (birkhoff _ HUq) _); [ done | split ].
  exists (node (node y')); rewrite /diskF /setD -(fclosed1 (diskN_node q)).
  rewrite diskN_E /setU /= /setU1 set11 /= !orbT andbT.
  rewrite Sface (same_cface Hyy') -{2 4}[y']Eedge Dn3.
  rewrite -cface1r (set0P Hbg) Sface -(same_cface Heyz') (no_adj_adj Haxey).
    rewrite -cface1 Sface cface1 Enode; rewrite Sadj // in Hazy.
    rewrite (no_adj_adj Hazy); first by rewrite adj_no_cface ?adjN.
    by rewrite (adjF Hyy') adjE.
  by rewrite Er in Hry'; rewrite (adjF Hry') Sadj ?adjN.
exists (node (node z)).
rewrite /diskFC /setD /setC -(fclosed1 (diskN_node q)).
rewrite -{2}[node z]De2 (diskN_edge_ring Hg) //= /setU1 ?set11 ?orbT //.
rewrite andbT orbF -{1 3}[z]Eedge Dn3 -cface1 Sface (no_adj_adj Hazy (adjE z)).
rewrite !Er in Hry' Hrz.
rewrite Sface -(same_cface Heyz') (no_adj_adj Haxey).
  rewrite -cface1 Sface cface1 Enode (set0P Hbg) Sface -(same_cface Hry').
  by rewrite (same_cface Hrz) -{1}[node z]Enode -cface1 Sface (set0P Hbg).
by rewrite (adjF Hrz) Sadj ?adjN.
Qed.

Lemma fcard_adj_max : forall y,
  negb (cface x y) -> fcard face (setI (adj y) (adj x)) <= 2.
Proof.
move=> y Hxy0; case Hxy: (adj01 x y).
  by rewrite /adj01 (negbE Hxy0) in Hxy; rewrite (fcard_adj_adj Hxy).
rewrite {Hxy0}leqNgt /n_comp; apply/idP => Hy3.
have Hy1 := (ltnW (ltnW Hy3)); rewrite ltnNge leqn0 in Hy1.
case/set0Pn: Hy1 => [z1 Hz1]; rewrite (cardD1 z1) Hz1 /= in Hy3.
have Hy2 := (ltnW Hy3); rewrite add1n ltnS ltnNge leqn0 in Hy2.
case/set0Pn: Hy2 => [z2 Hz2]; rewrite (cardD1 z2) Hz2 /= in Hy3.
rewrite !add1n !ltnS ltnNge leqn0 in Hy3; case/set0Pn: Hy3 => [z3 Hz3].
case/and3P: Hz1 => [Hz1 Hyz1 Hxz1].
case/and4P: Hz2 => [Hz12 Hz2 Hyz2 Hxz2].
case/and5P: Hz3 => [Hz23 Hz13 Hz3 Hyz3 Hxz3].
have Hyz: forall z z', negb (z =d z') -> froots face z -> froots face z' ->
    adj x z -> adj x z' -> adj y z -> adj y z' -> adj z z'.
- move=> z z' Hzz' Hz Hz' Hxz Hxz' Hyz; move/adjP=> [z'' Hyz'' Hz''z'].
  rewrite -(adjFr Hz''z') in Hxz'; rewrite (adjF Hyz'') Sadj // -[z'']De2 in Hyz.
  move: (adj12_edge Hxz' Hxz Hyz).
  rewrite De2 orbC /adj01 -(adjFr Hyz'') (Sface _ x) -(same_cface Hyz'') Sface.
  rewrite -/(adj01 x y) Hxy Sface (same_cface Hz''z') Sface.
  rewrite (sameP (rootPx (Sface _) z z') eqP) (eqP Hz) (eqP Hz') (negbE Hzz').
  by rewrite (adjFr Hz''z').
have Hz123: and3 (adj z1 z2) (adj z1 z3) (adj z2 z3) by split; auto.
move: {y Hxy Hz1 Hyz1 Hz12 Hz2 Hyz2 Hz13 Hz23 Hz3 Hyz3 Hyz}Hxz1 Hxz2 Hxz3.
rewrite -!fband_spoke_ring; move/hasP=> [t1 Ht1 Hzt1].
move/hasP=> [t2 Ht2 Hzt2]; move/hasP=> [t3 Ht3 Hzt3].
move: Hz123; rewrite !(adjF Hzt1) (adjF Hzt2) (adjFr Hzt2) !(adjFr Hzt3).
move {z1 z2 z3 Hzt1 Hzt2 Hzt3} => [Ht12 Ht13 Ht23].
case: (andP HUr) => _; move/simple_uniq=> Ur.
have Hrt: forall t t', adj t t' -> r t -> r t' ->
    next r t <> next r t' /\ (next r t = t' \/ next r t' = t).
- move=> t t' Htt' Ht Ht'; split.
  move=> Dt'; move: (adj_no_cface Hbg Htt').
    by rewrite (monic_inj (prev_next Ur) Dt') connect0.
  move: (set0P (subsetP chordless_spoke_ring _ Ht) t').
  rewrite /setI /setD1 Htt' Ht' andbT -negb_orb.
  by case/orP; move/eqP=> <-; auto; right; apply next_prev.
move: {Ht12}(Hrt _ _ Ht12 Ht1 Ht2) => [Ht12 Dt12].
move: {Ht13}(Hrt _ _ Ht13 Ht1 Ht3) => [Ht13 Dt13].
move: {Hrt Ht23}(Hrt _ _ Ht23 Ht2 Ht3) => [Ht23 Dt23].
move: (rot_to Ht1) (min_arity) (cycle_next Ur) (Ur) => [i r' Dr].
rewrite -size_spoke_ring -(size_rot i) -(cycle_rot i) -(uniq_rot i) Dr.
case: r' {Dr} => [|u2 [|u3 [|u4 r']]] //= _; move/and4P=> [Du2 Du3 Du4 _].
case/andP; do 2 case/norP=> _; case/norP; case/eqP.
rewrite -{u4 Du4}(eqP Du4) -{u3 Du3}(eqP Du3) -{u2 Du2}(eqP Du2).
case: Dt12 => [Dt2|Dt1].
  case: Dt23 => [Dt3|Dt2']; last by case Ht13; rewrite Dt2 Dt2'.
  case: Dt13 => [Dt3'|Dt1]; first by case Ht12; rewrite Dt3 Dt3'.
  by rewrite Dt2 Dt3 Dt1.
case: Dt13 => [Dt3|Dt1']; last by case Ht23; rewrite Dt1 Dt1'.
case: Dt23 => [Dt3'|Dt2]; first by case Ht12; rewrite Dt3 Dt3'.
by rewrite Dt3 Dt2 Dt1.
Qed.

End SpokeRing.

Definition minimal_counter_example_is_plain_cubic_pentagonal :=
  PlainCubicPentagonal Hg min_arity.

End Birkhoff.

Prenex Implicits spoke spoke_ring.

Coercion minimal_counter_example_is_plain_cubic_pentagonal :
  minimal_counter_example >-> plain_cubic_pentagonal.

Unset Implicit Arguments.