(** *** Going into the opposite direction of [UniMath.Bicategories.Core.Examples.BicategoryFromMonoidal] *)
(** We fix a bicategory and an object of it and construct the monoidal category of endomorphisms.

Written by Ralph Matthes in 2019.

 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.Bicategories.Core.Bicat.

Local Open Scope cat.

Section Monoidal_Cat_From_Bicat.

Local Open Scope bicategory_scope.
Import Bicat.Notations.

Context {C : bicat}.
Context (c0: ob C).

Definition precategory_data_from_bicat_and_ob: precategory_data.
Proof.
  use make_precategory_data.
  - use make_precategory_ob_mor.
    + exact (C⟦c0,c0⟧).
    + apply prebicat_cells.
  - intro c; apply id2.
  - intros a b c; apply vcomp2.
Defined.

Lemma is_precategory_data_from_prebicat_and_ob: is_precategory precategory_data_from_bicat_and_ob.
Proof.
  use make_is_precategory.
  - intros a b f; apply id2_left.
  - intros a b f; apply id2_right.
  - intros a b c d f g h; apply vassocr.
  - intros a b c d f g h; apply pathsinv0; apply vassocr.
Qed.

Definition precategory_from_bicat_and_ob: precategory := _,, is_precategory_data_from_prebicat_and_ob.

Lemma has_homsets_precategory_from_bicat_and_ob: has_homsets precategory_from_bicat_and_ob.
Proof.
  red. intros.
  apply (cellset_property(C:=C)).
Qed.

Definition category_from_bicat_and_ob: category := precategory_from_bicat_and_ob ,, has_homsets_precategory_from_bicat_and_ob.

Local Notation EndC := category_from_bicat_and_ob.

Definition tensor_from_bicat_and_ob: category_from_bicat_and_ob ⊠ category_from_bicat_and_ob ⟶ category_from_bicat_and_ob.
Proof.
  use make_functor.
  - use make_functor_data.
    + intro ab.
      exact (pr1 ab · pr2 ab).
    + intros ab1 ab2 f.
      exact (hcomp (pr1 f) (pr2 f)).
  - abstract ( split; [ intro c; apply hcomp_identity |
                        intros a b c f g; apply hcomp_vcomp ] ).
Defined.

Local Notation tensor := tensor_from_bicat_and_ob.

Local Definition build_left_unitor: left_unitor tensor (id c0).
Proof.
  use make_nat_z_iso.
  + use make_nat_trans.
    * intro c.
      apply lunitor.
    * abstract ( intros a b f; apply lunitor_natural ).
  + intro c; apply is_z_iso_lunitor.
Defined.

Local Definition build_right_unitor: right_unitor tensor (id c0).
Proof.
  use make_nat_z_iso.
  + use make_nat_trans.
    * intro c.
      apply runitor.
    * abstract ( intros a b f; apply runitor_natural ).
  + intro c; apply is_z_iso_runitor.
Defined.

Definition nat_trans_associator: assoc_left tensor ⟹ assoc_right tensor.
Proof.
  (* very slow with library elements:
  set (aux := rassociator_transf(C := C) c0 c0 c0 c0).
  set (aux' := pre_whisker (precategory_binproduct_unassoc _ _ _) aux).
  use make_nat_trans.
  - intro c. exact (pr1 aux' c).
  - apply (pr2 aux').
   *)
  (* still very slow with new additions to library:
  set (aux := rassociator_transf'(C := C) c0 c0 c0 c0).
  use make_nat_trans.
  - intro c. exact (pr1 aux c).
  - abstract ( apply (pr2 aux) ).
   *)
  (* now def. by Anders Mörtberg: *)
  exists rassociator_fun'.
  abstract (intros f g x; apply hcomp_rassoc).
Defined.

Local Definition build_associator: associator tensor.
Proof.
  use make_nat_z_iso.
  - exact nat_trans_associator.
  - intro c; apply is_z_iso_rassociator.
Defined.

Definition monoidal_cat_from_bicat_and_ob: monoidal_cat.
Proof.
  use (make_monoidal_cat category_from_bicat_and_ob tensor_from_bicat_and_ob (id c0) build_left_unitor build_right_unitor build_associator).
  - abstract ( intros a b; apply pathsinv0; apply unit_triangle ).
  - abstract ( intros a b c d; apply pathsinv0; apply associativity_pentagon ).
Defined.

End Monoidal_Cat_From_Bicat.


From Undecidability.FOL Require Import Syntax.Facts Semantics.Tarski.FullFacts Semantics.FiniteTarski.Full.
Require Import Undecidability.Synthetic.Definitions.
Require Import Vector Lia.

Set Default Goal Selector "!".

Section Signature.
  #[local]
  Existing Instance falsity_on.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Definition exclosure phi : form :=
    let (N, _) := find_bounded phi in exist_times N phi.

  Lemma exclosure_closed phi :
    bounded 0 (exclosure phi).
  Proof.
    unfold exclosure. destruct find_bounded as [N HN]. now apply exists_close_form.
  Qed.

  Definition form2cform phi : cform :=
    exist _ (exclosure phi) (exclosure_closed phi).

  Theorem reduction :
    FSATd ⪯ FSATdc.
  Proof.
    exists form2cform. intros phi; unfold FSATdc; cbn.
    unfold exclosure. destruct find_bounded as [N HN].
    split; intros (D & M & rho & H1 & H2 & H3 & H4); exists D, M.
    - exists rho. repeat split; trivial. eapply subst_exist_sat; eauto.
    - apply subst_exist_sat2 in H4 as [sigma H]. exists sigma. repeat split; trivial.
  Qed.
End Signature.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Category.
Require Blech.Bicategory.

#[local]
Obligation Tactic := Reflect.category_simpl.

Definition Endo (C: Bicategory) (c: C): Category := C c c.

Module EndoNotations.
  Notation "Λ₊" := Endo : category_scope.
End EndoNotations.


(* This file attempts to implement a cycle-accurate emulation of a 6502 processor,
    failing only on illegal opcodes.
*)

From Coq Require Import ssreflect BinInt.
From RecordUpdate Require Import RecordSet.
Require Memory. Import Memory(memory).
Require Import Word.

(* Flags *)

Record flags : Set := mk_flags
{ FlagC : bool
; FlagZ : bool
; FlagI : bool
; FlagD : bool
; FlagV : bool
; FlagN : bool
}.

#[global]
Instance set_flags : Settable _ := settable! mk_flags
<FlagC; FlagZ; FlagI; FlagD; FlagV; FlagN>.

Definition byte_of_flags (flags : flags) : word 8 :=
Word.push_low (FlagC flags,
Word.push_low (FlagZ flags,
Word.push_low (FlagI flags,
Word.push_low (FlagD flags,
Word.push_low (true,
Word.push_low (true,
Word.push_low (FlagV flags,
Word.push_low (FlagN flags,
Word.trivial)))))))).

Definition flags_of_byte (w : word 8) : flags :=
let (C, w) := Word.pop_low w in
let (Z, w) := Word.pop_low w in
let (I, w) := Word.pop_low w in
let (D, w) := Word.pop_low w in
let (_, w) := Word.pop_low w in
let (_, w) := Word.pop_low w in
let (V, w) := Word.pop_low w in
let (N, w) := Word.pop_low w in
mk_flags C Z I D V N.

Definition setZN (w : word 8) (f : flags) : flags :=
set FlagZ (fun _ => Word.eqb w (op₀ false)) (set FlagN (fun _ => Word.bit w 7%b) f).

(* Registers *)

Record registers : Set :=
{ RegPC : word 16
; RegA : word 8
; RegX : word 8
; RegY : word 8
; RegS : word 8
; RegP : flags
}.

#[global]
Instance set_registers : Settable _ := settable! Build_registers
<RegPC; RegA; RegX; RegY; RegS; RegP>.

(* Cycles *)

Inductive cycle (T : Type) :=
| read : word 16 -> (word 8 -> T) -> cycle T
| write : word 16 -> word 8 -> T -> cycle T
.
Arguments read {T}.
Arguments write {T}.

Inductive cycles (T : Type) :=
| zero : T -> cycles T
| suc : cycle (cycles T) -> cycles T
.
Arguments zero {T}.
Arguments suc {T}.

Definition cycles_builder (A : Type) : Type :=
forall B, (A -> cycles B) -> cycles B.

(* Addressing Modes *)
(* Citation: Appendix A of
    http://archive.6502.org/books/mcs6500_family_hardware_manual.pdf
*)

Inductive addressing_mode : Set :=
| Accumulator
| Immediate
| Implied
| Relative
| Absolute
| ZeroPage
| Indirect
| AbsoluteX
| AbsoluteY
| ZeroPageX
| ZeroPageY
| IndexedIndirect
| IndirectIndexed
.

Notation "f $ x" := (f x) (at level 60, right associativity, only parsing).

(* The first argument should be true if this operation only *reads* memory,
    and does not write it. This is necessary because the processor
    occasionally takes one fewer cycle in that case.
*)
Definition effective_address (read_only : bool)
    (mode : addressing_mode) (r : registers) : cycles_builder (word 16) :=
fun _ continuation => match mode with
| Immediate => continuation (Word.increment 1 (RegPC r))
| Absolute =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun lo =>
    suc $ read (Word.increment 2 $ RegPC r) $ fun hi =>
    continuation $ Word.concat lo hi
| AbsoluteX =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun lo =>
    suc $ read (Word.increment 2 $ RegPC r) $ fun hi =>
    let (lo, carry) := Word.add_with_carry false lo (RegX r) in
    if carry || negb read_only
    then
        suc $ read (Word.concat lo hi) $ fun _ =>
        continuation $ Word.concat lo (if carry then Word.increment 1 hi else hi)
    else
        continuation $ Word.concat lo hi
| AbsoluteY =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun lo =>
    suc $ read (Word.increment 2 $ RegPC r) $ fun hi =>
    let (lo, carry) := Word.add_with_carry false lo (RegY r) in
    if carry || negb read_only
    then
        suc $ read (Word.concat lo hi) $ fun _ =>
        continuation $ Word.concat lo (if carry then Word.increment 1 hi else hi)
    else
        continuation $ Word.concat lo hi
| ZeroPage =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun lo =>
    continuation $ Word.concat lo (op₀ false)
| ZeroPageX =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun lo =>
    suc $ read (Word.concat lo (op₀ false)) $ fun _ =>
    continuation $ Word.concat (Word.add lo (RegX r)) (op₀ false)
| ZeroPageY =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun lo =>
    suc $ read (Word.concat lo (op₀ false)) $ fun _ =>
    continuation $ Word.concat (Word.add lo (RegY r)) (op₀ false)
| IndexedIndirect =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun lo =>
    suc $ read (Word.concat lo (op₀ false)) $ fun _ =>
    let lo := Word.add lo (RegX r) in
    suc $ read (Word.concat lo (op₀ false)) $ fun lo' =>
    suc $ read (Word.concat (Word.increment 1 lo) (op₀ false)) $ fun hi' =>
    continuation $ Word.concat lo' hi'
| IndirectIndexed =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun lo =>
    suc $ read (Word.concat lo (op₀ false)) $ fun lo' =>
    suc $ read (Word.concat (Word.increment 1 lo) (op₀ false)) $ fun hi' =>
    let (lo', carry) := Word.add_with_carry false lo' (RegY r) in
    if carry || negb read_only
    then
        suc $ read (Word.concat lo' hi') $ fun _ =>
        continuation $ Word.concat lo' (if carry then Word.increment 1 hi' else hi')
    else
        continuation $ Word.concat lo' hi'
| Indirect =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun lo =>
    suc $ read (Word.increment 2 $ RegPC r) $ fun hi =>
    (* Yes, this behaves weirdly when lo = 0xFF. Yes, that's intended. *)
    suc $ read (Word.concat lo hi) $ fun lo' =>
    suc $ read (Word.concat (Word.increment 1 lo) hi) $ fun hi' =>
    continuation $ Word.concat lo' hi'
| Relative =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun offset =>
    suc $ read (Word.increment 2 (RegPC r)) $ fun _ =>
    let (lo, hi) := Word.split (m := 8) (Word.increment 2 (RegPC r)) in
    let (lo, carry) := Word.add_with_carry false lo offset in
    let page_change := (
        Word.int_of_bit carry -
        Word.int_of_bit (Word.bit offset 7%b)
    )%Z in
    if Z.eqb page_change 0
    then
        continuation $ Word.concat lo hi
    else
        suc $ read (Word.concat lo hi) $ fun _ =>
        continuation $ Word.concat lo (Word.increment page_change hi)

(* These modes don't really produce addresses, so I'll produce dummy values. *)
| Accumulator =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun _ =>
    continuation $ op₀ false
| Implied =>
    suc $ read (Word.increment 1 $ RegPC r) $ fun _ =>
    continuation $ op₀ false
end.

Definition mode_length (mode : addressing_mode) : Z :=
match mode with
| Accumulator => 1
| Immediate => 2
| Implied => 1
| Relative => 2
| Absolute => 3
| AbsoluteX => 3
| AbsoluteY => 3
| ZeroPage => 2
| ZeroPageX => 2
| ZeroPageY => 2
| IndexedIndirect => 2
| IndirectIndexed => 2
| Indirect => 3
end.

Definition inc_pc (mode : addressing_mode) : registers -> registers :=
set RegPC (Word.increment (mode_length mode)).

Definition execute_non_memory_op (f : registers -> registers)
    (mode : addressing_mode) (r : registers) : cycles registers :=
suc $ read (Word.increment 1 $ RegPC r) $ fun _ =>
zero $ f (inc_pc mode r).

(* There are no "read accumulator" operations. *)
Definition execute_read_op (f : registers -> word 8 -> registers)
    (mode : addressing_mode) (r : registers) : cycles registers :=
effective_address true mode r _ $ fun addr =>
suc $ read addr $ fun w =>
zero $ f (inc_pc mode r) w.

Definition execute_write_op (f : registers -> registers * word 8)
    (mode : addressing_mode) (r : registers) : cycles registers :=
effective_address false mode r _ $ fun addr =>
let (r,w) := f (inc_pc mode r) in
suc $ write addr w $
zero $ r.

Definition execute_modify_op (f : registers -> word 8 -> registers * word 8)
    (mode : addressing_mode) (r : registers) : cycles registers :=
match mode with
| Accumulator =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun _ =>
    let (r,w) := f (inc_pc Accumulator r) (RegA r) in
    zero $ set RegA (fun _ => w) r
| _ =>
    effective_address false mode r _ $ fun addr =>
    suc $ read addr $ fun w =>
    suc $ write addr w $
    let (r,w) := f (inc_pc mode r) w in
    suc $ write addr w $
    zero $ r
end.

Definition execute_branch (cond : registers -> bool) (r : registers) : cycles registers :=
if cond r
then
    effective_address true Relative r _ $ fun addr =>
    zero $ set RegPC (fun _ => addr) r
else
    suc $ read (Word.increment 1 (RegPC r)) $ fun _ =>
    zero $ inc_pc Relative r.

(* Instructions *)

Inductive instruction : Set :=
| ADC : instruction
| AND : instruction
| ASL : instruction
| BCC : instruction
| BCS : instruction
| BEQ : instruction
| BIT : instruction
| BMI : instruction
| BNE : instruction
| BPL : instruction
| BRK : instruction
| BVC : instruction
| BVS : instruction
| CLC : instruction
| CLD : instruction
| CLI : instruction
| CLV : instruction
| CMP : instruction
| CPX : instruction
| CPY : instruction
| DEC : instruction
| DEX : instruction
| DEY : instruction
| EOR : instruction
| INC : instruction
| INX : instruction
| INY : instruction
| JMP : instruction
| JSR : instruction
| LDA : instruction
| LDX : instruction
| LDY : instruction
| LSR : instruction
| NOP : instruction
| ORA : instruction
| PHA : instruction
| PHP : instruction
| PLA : instruction
| PLP : instruction
| ROL : instruction
| ROR : instruction
| RTI : instruction
| RTS : instruction
| SBC : instruction
| SEC : instruction
| SED : instruction
| SEI : instruction
| STA : instruction
| STX : instruction
| STY : instruction
| TAX : instruction
| TAY : instruction
| TSX : instruction
| TXA : instruction
| TXS : instruction
| TYA : instruction
.

Definition run (instruction : instruction) :
    addressing_mode -> registers -> cycles registers :=
match instruction with
| NOP => execute_non_memory_op $ fun r => r

| BIT => execute_read_op $ fun r w => set RegP
    (fun f =>
        set FlagN (fun _ => Word.bit w 7%b) $
        set FlagV (fun _ => Word.bit w 6%b) $
        set FlagZ (fun _ => Word.eqb (op₂ andb w (RegA r)) (op₀ false)) f)
    r

| CMP => execute_read_op $ fun r w =>
    let (w , inv_borrow) := Word.sub_with_inv_borrow true (RegA r) w in
    set RegP (fun f => set FlagC (fun _ => inv_borrow) $ setZN w f) r
| CPX => execute_read_op $ fun r w =>
    let (w , inv_borrow) := Word.sub_with_inv_borrow true (RegX r) w in
    set RegP (fun f => set FlagC (fun _ => inv_borrow) $ setZN w f) r
| CPY => execute_read_op $ fun r w =>
    let (w , inv_borrow) := Word.sub_with_inv_borrow true (RegY r) w in
    set RegP (fun f => set FlagC (fun _ => inv_borrow) $ setZN w f) r

| DEC => execute_modify_op $ fun r w => let w := Word.increment (-1) w in
    (set RegP (setZN w) r, w)
| DEX => execute_non_memory_op $ fun r => let w := Word.increment (-1) (RegX r) in
    set RegP (setZN w) $ set RegX (fun _ => w) r
| DEY => execute_non_memory_op $ fun r => let w := Word.increment (-1) (RegY r) in
    set RegP (setZN w) $ set RegY (fun _ => w) r

| INC => execute_modify_op $ fun r w => let w := Word.increment 1 w in
    (set RegP (setZN w) r, w)
| INX => execute_non_memory_op $ fun r => let w := Word.increment 1 (RegX r) in
    set RegP (setZN w) $ set RegX (fun _ => w) r
| INY => execute_non_memory_op $ fun r => let w := Word.increment 1 (RegY r) in
    set RegP (setZN w) $ set RegY (fun _ => w) r

(* Bitwise Operations *)
| AND => execute_read_op $ fun r w =>
    let w := op₂ andb w (RegA r) in
    set RegA (fun _ => w) $
    set RegP (setZN w) r
| EOR => execute_read_op $ fun r w =>
    let w := op₂ xorb w (RegA r) in
    set RegA (fun _ => w) $
    set RegP (setZN w) r
| ORA => execute_read_op $ fun r w =>
    let w := op₂ orb w (RegA r) in
    set RegA (fun _ => w) $
    set RegP (setZN w) r

| ASL => execute_modify_op $ fun r w =>
    let (w , carry) := Word.pop_high (Word.push_low (false, w)) in
    (set RegP (fun f => set FlagC (fun _ => carry) $ setZN w f) r, w)
| LSR => execute_modify_op $ fun r w =>
    let (carry , w) := Word.pop_low (Word.push_high (w , false)) in
    (set RegP (fun f => set FlagC (fun _ => carry) $ setZN w f) r, w)
| ROL => execute_modify_op $ fun r w =>
    let (w , carry) := Word.pop_high (Word.push_low (FlagC (RegP r), w)) in
    (set RegP (fun f => set FlagC (fun _ => carry) $ setZN w f) r, w)
| ROR => execute_modify_op $ fun r w =>
    let (carry , w) := Word.pop_low (Word.push_high (w , FlagC (RegP r))) in
    (set RegP (fun f => set FlagC (fun _ => carry) $ setZN w f) r, w)

(* Moving Data Around *)
| LDA => execute_read_op $ fun r w => set RegP (setZN w) $ set RegA (fun _ => w) r
| LDX => execute_read_op $ fun r w => set RegP (setZN w) $ set RegX (fun _ => w) r
| LDY => execute_read_op $ fun r w => set RegP (setZN w) $ set RegY (fun _ => w) r
| STA => execute_write_op $ fun r => (r , RegA r)
| STX => execute_write_op $ fun r => (r , RegX r)
| STY => execute_write_op $ fun r => (r , RegY r)
| TAX => execute_non_memory_op $ fun r =>
    set RegP (setZN (RegA r)) $ set RegX (fun _ => RegA r) r
| TAY => execute_non_memory_op $ fun r =>
    set RegP (setZN (RegA r)) $ set RegY (fun _ => RegA r) r
| TSX => execute_non_memory_op $ fun r =>
    set RegP (setZN (RegS r)) $ set RegX (fun _ => RegS r) r
| TXA => execute_non_memory_op $ fun r =>
    set RegP (setZN (RegX r)) $ set RegA (fun _ => RegX r) r
| TXS => execute_non_memory_op $ fun r =>
    set RegP (setZN (RegX r)) $ set RegS (fun _ => RegX r) r
| TYA => execute_non_memory_op $ fun r =>
    set RegP (setZN (RegY r)) $ set RegA (fun _ => RegY r) r

(* Flags *)
| CLC => execute_non_memory_op $ set RegP $ set FlagC $ fun _ => false
| CLD => execute_non_memory_op $ set RegP $ set FlagD $ fun _ => false
| CLI => execute_non_memory_op $ set RegP $ set FlagI $ fun _ => false
| CLV => execute_non_memory_op $ set RegP $ set FlagV $ fun _ => false
| SEC => execute_non_memory_op $ set RegP $ set FlagC $ fun _ => true
| SED => execute_non_memory_op $ set RegP $ set FlagD $ fun _ => true
| SEI => execute_non_memory_op $ set RegP $ set FlagI $ fun _ => true

(* Branch and Jump *)
| BCS => fun _ => execute_branch $ fun r =>      (FlagC (RegP r))
| BCC => fun _ => execute_branch $ fun r => negb (FlagC (RegP r))
| BEQ => fun _ => execute_branch $ fun r =>      (FlagZ (RegP r))
| BNE => fun _ => execute_branch $ fun r => negb (FlagZ (RegP r))
| BVS => fun _ => execute_branch $ fun r =>      (FlagV (RegP r))
| BVC => fun _ => execute_branch $ fun r => negb (FlagV (RegP r))
| BMI => fun _ => execute_branch $ fun r =>      (FlagN (RegP r))
| BPL => fun _ => execute_branch $ fun r => negb (FlagN (RegP r))
| JMP => fun mode r => effective_address true mode r _ $ fun addr =>
    zero $ set RegPC (fun _ => addr) r

(* Addition and Subtraction *)
| ADC => execute_read_op $ fun r num1 =>
    let num0 := RegA r in
    let (binary_sum, binary_carry) :=
        Word.add_with_carry (FlagC (RegP r)) num0 num1 in
    if FlagD (RegP r)
    then
        let (lo0, hi0) := Word.split (m := 4) num0 in
        let (lo1, hi1) := Word.split (m := 4) num1 in

        let (lo, carry_mid) := Word.add_with_carry (FlagC (RegP r)) lo0 lo1 in
        let (lo_minus_10, no_decimal_carry) :=
            Word.sub_with_inv_borrow true lo (word_of_int 10) in
        let (lo, carry_mid) :=
            if no_decimal_carry
            then (lo, carry_mid)
            else (lo_minus_10, true) in

        let (hi, carry_out) := Word.add_with_carry carry_mid hi0 hi1 in
        let (hi_minus_10, no_decimal_carry) :=
            Word.sub_with_inv_borrow true hi (word_of_int 10) in
        let (hi, carry_out) :=
            if no_decimal_carry
            then (hi, carry_out)
            else (hi_minus_10, true) in

        set RegA (fun _ => Word.concat lo hi) $
        set RegP
            (fun f =>
                set FlagC (fun _ => carry_out) $
                set FlagZ (fun _ => Word.eqb binary_sum (op₀ false)) $
                set FlagN (fun _ => Word.bit hi 3%b) $
                set FlagV
                    (fun _ =>
                       Word.bit hi0 3%b
                    && Word.bit hi1 3%b
                    && negb (Word.bit hi 3%b)
                    || negb (Word.bit hi0 3%b)
                    && negb (Word.bit hi1 3%b)
                    && Word.bit hi 3%b
                    )%bool $
                setZN binary_sum f)
            r
    else
        set RegA (fun _ => binary_sum) $
        set RegP
            (fun f =>
                set FlagC (fun _ => binary_carry) $
                set FlagV
                    (fun _ =>
                       Word.bit num0 7%b
                    && Word.bit num1 7%b
                    && negb (Word.bit binary_sum 7%b)
                    || negb (Word.bit num0 7%b)
                    && negb (Word.bit num1 7%b)
                    && Word.bit binary_sum 7%b
                    )%bool $
                setZN binary_sum f)
            r
| SBC => execute_read_op $ fun r num1 =>
    let num0 := RegA r in
    let (binary_difference, binary_inv_borrow) :=
        Word.sub_with_inv_borrow (FlagC (RegP r)) num0 num1 in
    let r := set RegP
        (fun f =>
            set FlagC (fun _ => binary_inv_borrow) $
            set FlagV (fun _ =>
                Word.bit num0 7%b
                && negb (Word.bit num1 7%b)
                && negb (Word.bit binary_difference 7%b)
                || negb (Word.bit num0 7%b)
                && Word.bit num1 7%b
                && Word.bit binary_difference 7%b
                )%bool $
            setZN binary_difference f)
        r in
    if FlagD (RegP r)
    then
        let (lo0, hi0) := Word.split (m := 4) num0 in
        let (lo1, hi1) := Word.split (m := 4) num1 in

        let (lo, inv_borrow_mid) := Word.sub_with_inv_borrow (FlagC (RegP r)) lo0 lo1 in
        let lo := if inv_borrow_mid then lo else Word.increment 10 lo in

        let (hi, inv_borrow_out) := Word.sub_with_inv_borrow inv_borrow_mid hi0 hi1 in
        let hi := if inv_borrow_out then hi else Word.increment 10 hi in

        set RegA (fun _ => Word.concat lo hi) r
    else
        set RegA (fun _ => binary_difference) r

(* Stack operations *)
| BRK => fun _ r =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun _ =>
    let (lo, hi) := Word.split (m := 8) (RegPC r) in
    suc $ write (Word.concat                      (RegS r)  (word_of_int 1)) hi $
    suc $ write (Word.concat (Word.increment (-1) (RegS r)) (word_of_int 1)) lo $
    suc $ write (Word.concat (Word.increment (-2) (RegS r)) (word_of_int 1))
        (byte_of_flags (RegP r)) $
    suc $ read (word_of_int 0xfffe) $ fun lo =>
    suc $ read (word_of_int 0xffff) $ fun hi =>
    zero $
        set RegS (Word.increment (-3)) $
        set RegP (set FlagI (fun _ => true)) $
        set RegPC (fun _ => Word.concat lo hi) r
| JSR => fun _ r =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun lo' =>
    let (lo, hi) := Word.split (m := 8) (Word.increment 2 (RegPC r)) in
    suc $ read  (Word.concat                      (RegS r)  (word_of_int 1)) $ fun _ =>
    suc $ write (Word.concat                      (RegS r)  (word_of_int 1)) hi $
    suc $ write (Word.concat (Word.increment (-1) (RegS r)) (word_of_int 1)) lo $
    suc $ read (Word.increment 2 (RegPC r)) $ fun hi' =>
    zero $
        set RegS (Word.increment (-2)) $
        set RegPC (fun _ => Word.concat lo' hi') r
| PHA => fun _ r =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun _ =>
    suc $ write (Word.concat (RegS r)  (word_of_int 1)) (RegA r) $
    zero $
        set RegS (Word.increment (-1)) $
        set RegPC (Word.increment 1) r
| PHP => fun _ r =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun _ =>
    suc $ write (Word.concat (RegS r)  (word_of_int 1)) (byte_of_flags (RegP r)) $
    zero $
        set RegS (Word.increment (-1)) $
        set RegPC (Word.increment 1) r
| PLA => fun _ r =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun _ =>
    suc $ read (Word.concat                   (RegS r)  (word_of_int 1)) $ fun _ =>
    suc $ read (Word.concat (Word.increment 1 (RegS r)) (word_of_int 1)) $ fun w =>
    zero $
        set RegS (Word.increment 1) $
        set RegA (fun _ => w) $
        set RegPC (Word.increment 1) r
| PLP => fun _ r =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun _ =>
    suc $ read (Word.concat                   (RegS r)  (word_of_int 1)) $ fun _ =>
    suc $ read (Word.concat (Word.increment 1 (RegS r)) (word_of_int 1)) $ fun w =>
    zero $
        set RegS (Word.increment 1) $
        set RegP (fun _ => flags_of_byte w) $
        set RegPC (Word.increment 1) r
| RTI => fun _ r =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun _ =>
    suc $ read (Word.concat                   (RegS r)  (word_of_int 1)) $ fun _ =>
    suc $ read (Word.concat (Word.increment 1 (RegS r)) (word_of_int 1)) $ fun flags =>
    suc $ read (Word.concat (Word.increment 2 (RegS r)) (word_of_int 1)) $ fun lo =>
    suc $ read (Word.concat (Word.increment 3 (RegS r)) (word_of_int 1)) $ fun hi =>
    suc $ read (Word.concat lo hi) $ fun _ =>
    zero $
        set RegS (Word.increment 3) $
        set RegP (fun _ => flags_of_byte flags) $
        set RegPC (fun _ => Word.concat lo hi) r
| RTS => fun _ r =>
    suc $ read (Word.increment 1 (RegPC r)) $ fun _ =>
    suc $ read (Word.concat                   (RegS r)  (word_of_int 1)) $ fun _ =>
    suc $ read (Word.concat (Word.increment 1 (RegS r)) (word_of_int 1)) $ fun lo =>
    suc $ read (Word.concat (Word.increment 2 (RegS r)) (word_of_int 1)) $ fun hi =>
    suc $ read (Word.concat lo hi) $ fun _ =>
    zero $
        set RegS (Word.increment 2) $
        set RegPC (fun _ => Word.increment 1 (Word.concat lo hi)) r
end.

(* Opcodes *)

Definition opcode_table : memory 8 (option (instruction * addressing_mode)) :=
    Eval compute in Memory.new 8 (fun x => x)

    (Some (BRK, Implied))   (Some (ORA, IndexedIndirect)) None                      None
    None                    (Some (ORA, ZeroPage))        (Some (ASL, ZeroPage))    None
    (Some (PHP, Implied))   (Some (ORA, Immediate))       (Some (ASL, Accumulator)) None
    None                    (Some (ORA, Absolute))        (Some (ASL, Absolute))    None
    (Some (BPL, Relative))  (Some (ORA, IndirectIndexed)) None                      None
    None                    (Some (ORA, ZeroPageX))       (Some (ASL, ZeroPageX))   None
    (Some (CLC, Implied))   (Some (ORA, AbsoluteY))       None                      None
    None                    (Some (ORA, AbsoluteX))       (Some (ASL, AbsoluteX))   None

    (Some (JSR, Absolute))  (Some (AND, IndexedIndirect)) None                      None
    (Some (BIT, ZeroPage))  (Some (AND, ZeroPage))        (Some (ROL, ZeroPage))    None
    (Some (PLP, Implied))   (Some (AND, Immediate))       (Some (ROL, Accumulator)) None
    (Some (BIT, Absolute))  (Some (AND, Absolute))        (Some (ROL, Absolute))    None
    (Some (BMI, Relative))  (Some (AND, IndirectIndexed)) None                      None
    None                    (Some (AND, ZeroPageX))       (Some (ROL, ZeroPageX))   None
    (Some (SEC, Implied))   (Some (AND, AbsoluteY))       None                      None
    None                    (Some (AND, AbsoluteX))       (Some (ROL, AbsoluteX))   None

    (Some (RTI, Implied))   (Some (EOR, IndexedIndirect)) None                      None
    None                    (Some (EOR, ZeroPage))        (Some (LSR, ZeroPage))    None
    (Some (PHA, Implied))   (Some (EOR, Immediate))       (Some (LSR, Accumulator)) None
    (Some (JMP, Absolute))  (Some (EOR, Absolute))        (Some (LSR, Absolute))    None
    (Some (BVC, Relative))  (Some (EOR, IndirectIndexed)) None                      None
    None                    (Some (EOR, ZeroPageX))       (Some (LSR, ZeroPageX))   None
    (Some (CLI, Implied))   (Some (EOR, AbsoluteY))       None                      None
    None                    (Some (EOR, AbsoluteX))       (Some (LSR, AbsoluteX))   None

    (Some (RTS, Implied))   (Some (ADC, IndexedIndirect)) None                      None
    None                    (Some (ADC, ZeroPage))        (Some (ROR, ZeroPage))    None
    (Some (PLA, Implied))   (Some (ADC, Immediate))       (Some (ROR, Accumulator)) None
    (Some (JMP, Indirect))  (Some (ADC, Absolute))        (Some (ROR, AbsoluteX))   None
    (Some (BVS, Relative))  (Some (ADC, IndirectIndexed)) None                      None
    None                    (Some (ADC, ZeroPageX))       (Some (ROR, ZeroPageX))   None
    (Some (SEI, Implied))   (Some (ADC, AbsoluteY))       None                      None
    None                    (Some (ADC, AbsoluteX))       (Some (ROR, Absolute))    None

    None                    (Some (STA, IndexedIndirect)) None                      None
    (Some (STY, ZeroPage))  (Some (STA, ZeroPage))        (Some (STX, ZeroPage))    None
    (Some (DEY, Implied))   None                          (Some (TXA, Implied))     None
    (Some (STY, Absolute))  (Some (STA, Absolute))        (Some (STX, Absolute))    None
    (Some (BCC, Relative))  (Some (STA, IndirectIndexed)) None                      None
    (Some (STY, ZeroPageX)) (Some (STA, ZeroPageX))       (Some (STX, ZeroPageY))   None
    (Some (TYA, Implied))   (Some (STA, AbsoluteY))       (Some (TXS, Implied))     None
    None                    (Some (STA, AbsoluteX))       None                      None

    (Some (LDY, Immediate)) (Some (LDA, IndexedIndirect)) (Some (LDX, Immediate))   None
    (Some (LDY, ZeroPage))  (Some (LDA, ZeroPage))        (Some (LDX, ZeroPage))    None
    (Some (TAY, Implied))   (Some (LDA, Immediate))       (Some (TAX, Implied))     None
    (Some (LDY, Absolute))  (Some (LDA, Absolute))        (Some (LDX, Absolute))    None
    (Some (BCS, Relative))  (Some (LDA, IndirectIndexed)) None                      None
    (Some (LDY, ZeroPageX)) (Some (LDA, ZeroPageX))       (Some (LDX, ZeroPageY))   None
    (Some (CLV, Implied))   (Some (LDA, AbsoluteY))       (Some (TSX, Implied))     None
    (Some (LDY, AbsoluteX)) (Some (LDA, AbsoluteX))       (Some (LDX, AbsoluteY))   None

    (Some (CPY, Immediate)) (Some (CMP, IndexedIndirect)) None                      None
    (Some (CPY, ZeroPage))  (Some (CMP, ZeroPage))        (Some (DEC, ZeroPage))    None
    (Some (INY, Implied))   (Some (CMP, Immediate))       (Some (DEX, Implied))     None
    (Some (CPY, Absolute))  (Some (CMP, Absolute))        (Some (DEC, Absolute))    None
    (Some (BNE, Relative))  (Some (CMP, IndirectIndexed)) None                      None
    None                    (Some (CMP, ZeroPageX))       (Some (DEC, ZeroPageX))   None
    (Some (CLD, Implied))   (Some (CMP, AbsoluteY))       None                      None
    None                    (Some (CMP, AbsoluteX))       (Some (DEC, AbsoluteX))   None

    (Some (CPX, Immediate)) (Some (SBC, IndexedIndirect)) None                      None
    (Some (CPX, ZeroPage))  (Some (SBC, ZeroPage))        (Some (INC, ZeroPage))    None
    (Some (INX, Implied))   (Some (SBC, Immediate))       (Some (NOP, Implied))     None
    (Some (CPX, Absolute))  (Some (SBC, Absolute))        (Some (INC, Absolute))    None
    (Some (BEQ, Relative))  (Some (SBC, IndirectIndexed)) None                      None
    None                    (Some (SBC, ZeroPageX))       (Some (INC, ZeroPageX))   None
    (Some (SED, Implied))   (Some (SBC, AbsoluteY))       None                      None
    None                    (Some (SBC, AbsoluteX))       (Some (INC, AbsoluteX))   None.

Definition parse_opcode (w : word 8) : option (instruction * addressing_mode) :=
    Memory.read w opcode_table.

(* Step through a single processor instruction. *)
Definition step (r : registers) : cycle (option (cycles registers)) :=
read (RegPC r) $ fun opcode => option_map
    (fun x => run (fst x) (snd x) r)
    (parse_opcode opcode).


Require Import Coq.Sorting.Permutation.
Require Import RegExp.Definitions.
(* model columns as a set *)

Inductive id :=
| Id : nat -> id.

Inductive option :=
| Instructional : option
| Option : id -> nat -> option.

Inductive freetext :=
| Freetext : bool -> freetext
| Default : string -> freetext
| Validated : RegExp -> freetext.

Inductive flag :=
| Exclusive : bool -> flag
| Randomize : bool -> flag
| Ordered : bool -> flag.

Inductive flags :=
| Flags : flag -> flag -> flag -> flags.

Inductive block :=
| Top : id -> branch -> block
| Sub : id -> bool -> block -> block
with  branch :=
| Null : branch
| Next : branch
| Dest : block -> branch.

Inductive question :=
| Question : id  -> flags -> block -> branch -> question.

Inductive answer :=
| Answer : question -> option -> answer.

Definition randomize (q : list question) : list question :=
  q.

(* an answer set satisfies a question set if it describes a valid, complete path *)
(* when is a path complete? when we've reached the last question  -- this doesn't hold for breakoff *)
Inductive satisfies (a : list answer) (b : list question) : Prop :=
| True.

(* goal to prove : given a ground truth set of responses, these responses are invariant under randomization - use permutation here *)

Theorem answer_invariant : forall Q A,
                             satisfies A Q -> satisfies A (randomize Q).
Admitted.


Require Import SecOrder.
Require Import P_occurs_in_alpha.
Require Import ST_setup.
Require Import Correctness_ST.
Require Import Arith.EqNat.
Require Import List_machinery_impl.
Require Import Unary_Predless nList_egs Rep_Pred_FOv my_bool my_arith__my_leb_nat.
(*
  Uniform_Mod_Lemmas8a
*)

(* ---------------------------------------------------------  *)

Lemma P_occ_rep_pred : forall (alpha cond : SecOrder) (x : FOvariable)
                              (P P2 : predicate),
  is_unary_predless cond = true ->
    P_occurs_in_alpha (replace_pred alpha P x cond) P2 = true ->
      P_occurs_in_alpha alpha P2 = true.
Proof.
  intros alpha cond x P P2 Hunary HPocc.
  unfold P_occurs_in_alpha in *.
  induction alpha;
    try destruct f as [x1];
    try destruct P as [Pn];
    try destruct P2 as [Pm];
    try destruct p as [Qm];
    try destruct f0 as [x2];
(*    destruct p as [Qm]; destruct f; destruct P as [Pn]; destruct P2 as [Pm]. *)
    try (case_eq (beq_nat Pn Qm); intros Hbeq1; simpl in *; rewrite Hbeq1 in *;
         [rewrite preds_in_rep_FOv in HPocc;
         rewrite un_predless_preds_in in HPocc;
         simpl in * | ]; try assumption ; discriminate);
    try (simpl in *; discriminate);
    try (simpl in *; apply IHalpha; assumption);
    try (simpl in HPocc;
    apply P_occurs_in_l_app in HPocc;
    simpl; apply P_occurs_in_l_app;
    destruct HPocc as [Hl | Hr]; [left; apply IHalpha1 | right ; apply IHalpha2];
      assumption);
    try (simpl in *;
    case_eq (beq_nat Pm Qm); intros Hbeq; try reflexivity;
      apply IHalpha;
      case_eq (beq_nat Pn Qm); intros Hbeq2; rewrite Hbeq2 in *;
        [ | simpl in HPocc ; rewrite Hbeq in *]; assumption).
Qed.

Lemma P_occ_in_alpha_rep_pred_f : forall (alpha cond : SecOrder) (x : FOvariable)
                                    (Q : predicate),
  is_unary_predless cond = true ->
    P_occurs_in_alpha (replace_pred alpha Q x cond) Q = false.
Proof.
  intros alpha cond x Q Hcond.
  induction alpha;
    try destruct p as [Pn]; try destruct f;
    try destruct Q as [Qm]; try destruct f0;
    [ | rewrite rep_pred_relatSO | rewrite rep_pred_eqFO |
      rewrite rep_pred_allFO | rewrite rep_pred_exFO |
      rewrite rep_pred_negSO | rewrite rep_pred_conjSO |
      rewrite rep_pred_disjSO | rewrite rep_pred_implSO |
      rewrite rep_pred_allSO | rewrite rep_pred_exSO ];
    try (unfold P_occurs_in_alpha; simpl;
        try reflexivity; try assumption);
    try (apply (contrapos_bool_or _ _ _
                  (P_occurs_in_alpha_conjSO _ _ _));
        apply conj; assumption).

    unfold P_occurs_in_alpha; simpl.
    case_eq (beq_nat Qm Pn); intros Hbeq.
      rewrite preds_in_rep_FOv.
      rewrite un_predless_preds_in.
        reflexivity.
        assumption.

      simpl.
      rewrite Hbeq; reflexivity.

    case_eq (beq_nat Pn Qm); intros Hbeq;
      simpl; unfold P_occurs_in_alpha in *.
      rewrite (beq_nat_true _ _ Hbeq).
      assumption.

      rewrite beq_nat_comm.
      rewrite Hbeq.
      assumption.

    case_eq (beq_nat Pn Qm); intros Hbeq;
      simpl; unfold P_occurs_in_alpha in *.
      rewrite (beq_nat_true _ _ Hbeq).
      assumption.

      rewrite beq_nat_comm.
      rewrite Hbeq.
      assumption.
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import rules_useful.
Require Export rules_partial.

(** This section is a work in progress. We plan to prove the
  rules that characterize the class of Mono types, i.e. types T such
  that the type [mkc_mono T] is inhabited. Crary proved monohood
  of many types (see %\cite[Sec. 5.3.2]{Crary:1998}%).
  Here is what we have proved so far:

  The class of Mono types include :
  - mkc_int (see [rule_mono_int] below)

  Monohood is closed under the following type constructors.
  - mkc_function (see [rule_mono_function] below)
  - mkc_product (see [rule_mono_product] below)

  We will keep updating this list as we prove more rules.
*)

(**
<<
   H |- Mono Z

     By int_mono
     no subgoals
>>
 *)
Definition rule_mono_int {o}
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_mono mk_int) ))
    []
    [].

Lemma rule_mono_int_true {o} : forall lib (H : @barehypotheses o),
  rule_true lib (rule_mono_int H).
Proof.
  unfold rule_mono_int, rule_true, closed_type_baresequent, closed_extract_baresequent. simpl.
  intros.
  clear cargs.
  destseq; allsimpl.
  dLin_hyp.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  rw @member_eq.
  allrw @lsubstc_mk_int.
  dands;[ apply tequality_mono; apply tequality_int |].
  apply equality_in_mkc_mono.
  exists (@equality_of_int o lib).
  dands; eauto with nequality;
  try(spcast;apply computes_to_valc_refl; eauto 3 with slow);
  [apply equality_of_int_xxx; fail|].
  introv Heq Hap.
  allunfold @equality_of_int.
  exrepnd. GC.
  exists k.
  dands; auto.
  spcast.
  clear pC2 pC1 cg wfct wfh sim eqh H.
  allunfold @computes_to_valc.
  allunfold @approxc.
  dest_ctermsn.
  allsimpl.
  repnud Hap.
  invertsn Hap.
  apply Hap in Heq1.
  exrepnd.
  match goal with
  [H : lblift _ _ ?bterms'  |- _ ] => unfold lblift in H; simpl in H;
    let Hlen := fresh H "len" in
      destruct H as [Hlen H];   dlist_len_name bterms' bt
  end;
  dforall_lt_hyp Hbt; auto.
Qed.
(**
<<
   H |- Mono ((x:A) -> B)

     By function_mono
     H |- Mono A
     H, x:A |- Mono B
>>
 *)
Definition rule_mono_function {o}
           (A B : @NTerm o)
           (x : NVar)
           (H : barehypotheses) :=
  mk_rule
    (mk_baresequent H (mk_conclax
        (mk_mono (mk_function A x B)) ))
    [   (mk_baresequent H (mk_conclax  (mk_mono A) )), (* probably not necessary *)
        (mk_baresequent (snoc H (mk_hyp x A)) (mk_conclax (mk_mono B)))
    ]
    [].

Ltac abbrev_ls t s :=
let ts:= fresh t s in
match goal with
[H: context [lsubstc t ?w s ?c] |- _ ] =>
  remember (lsubstc t w s c) as ts
end.

Ltac abbrev_lsc t s :=
let ts:= fresh t s in
match goal with
[H: context [(lsubstc_vars t ?w (csub_filter s [?v1]) [?v2] ?c)] |- _ ] =>
  remember ((lsubstc_vars t w (csub_filter s [v1]) [v2] c)) as ts
end.

Lemma approxc_mkc_apply_congr {o} :
  forall lib (f g a b : @CTerm o),
    approxc lib f g
    -> approxc lib a b
    -> approxc lib (mkc_apply f a) (mkc_apply g b).
Proof.
  intros. dest_ctermsn.
  allunfold @approxc.
  allsimpl.
  apply implies_approx_apply; auto.
Qed.
Hint Resolve approxc_refl : slow.

Lemma rule_mono_function_true {o} :
  forall lib (H : @barehypotheses o)
         (A B : NTerm)
         (x: NVar),
    rule_true lib (rule_mono_function A B x H).
Proof.
  unfold rule_mono_function, rule_true, closed_type_baresequent,
       closed_extract_baresequent. simpl.
  intros.
  clear cargs.
  destseq; allsimpl.
  dLin_hyp.
  (* We prove the well-formedness of things *)
  destruct Hyp as [ wsa Hypa ].
  destruct Hyp0 as [ wsb Hypb ].
  destseq; allsimpl; proof_irr; GC.
  dup wfh0 as h; apply vswf_hypotheses_eq in h.
  inversion h as [XX |  Hsn HsH H2h H3h H4h H5h]; cpx; allsimpl.
  rename H4h into Hin.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  rw @member_eq.
  applydup @similarity_dom in sim. repnd.
  vr_seq_true in Hypa.
  generalize (Hypa s1 s2 eqh sim). rename Hypa into Hypab. intro Hypa. exrepnd.
  lsubst_tac. rw @tequality_mono in Hypa0.
  vr_seq_true in Hypb.
  match goal with
  [|- (tequality ?lib (mkc_mono ?A) (mkc_mono ?B))# _] =>
  assert (tequality lib A B) as Hteq
  end.
  - apply tequality_function.
    dands; auto;[]. introv Heq.
    specialize (Hypb (snoc s1 (x,a)) (snoc s2 (x,a'))).
    (* why not cons? see defn of similarity *)
    autodimp Hypb Hypb';[ |autodimp Hypb Hypb'].
    + (* hyps_functionality *)
      intros s3 sim2. inversion sim2; cpx; allsimpl; cpx.
      rw @eq_hyps_snoc; simpl.
      assert (cover_vars A s4) as cv4
          by (apply (similarity_cover_vars lib) with (hs := H) (s1 := s1); auto).
      exists s1 s4 a t2 w p cv4; sp.
      (* while proving that functionality result, we have to prove that
       * a1 is functional, which we prove using our 1st hyp *)
      specialize (Hypab s1 s4);
      autodimp Hypab hyp1';
      autodimp Hypab hyp1'; exrepnd; clear_irr.
      lsubst_tac.
      apply tequality_mono; auto.
    + (* similarity *)
      rw @similarity_snoc; simpl.
      exists s1 s2 a a' w0 c2; sp;
      complete (allapply similarity_refl; sp).
    + exrepnd.
      lsubst_tac.
      rw @tequality_mono in Hypb0.
      rewrite <- simple_substc2 with (c:=c6);
      [|rw sim1; auto; fail].
      rewrite <- simple_substc2 with (c:=c7);
      [|rw sim0; auto; fail]. trivial.
  - split;[apply tequality_mono; auto; fail |].
    apply equality_in_mkc_mono.
    applydup @tequality_refl in Hteq.
    repnud Hteq0. exrepnd.
    rename eq into eqfun.
    exists eqfun.
    dands; auto;
    try(spcast;apply computes_to_valc_refl; eauto 3 with slow); [].
    introv Heq Hap.
    abbrev_ls A s1.
    abbrev_lsc B s1.
    assert (equality lib t t (mkc_function As1 x Bs1)) as Heqf
      by (exists eqfun; dands; auto).
    clear Heq.
    assert (equality lib t t' (mkc_function As1 x Bs1)) as Heqf';
    [ | exrepnd; repnud Heqf';exrepnd;
        equality_unique; apply Huniq; auto].
    apply equality_in_function in Heqf.
    exrepnd.
    apply equality_in_function.
    dands;auto;[].
    introv Heqa. duplicate Heqa as Heqb.
    apply_clear Heqf in Heqa.
    dimp (approxc_mkc_apply_congr lib t t' a' a');
    eauto with slow;[].
    specialize (Hypb (snoc s1 (x,a)) (snoc s2 (x,a'))). (* why not cons? *)
    autodimp Hypb Hypb';[ |autodimp Hypb Hypb'].
    + (* hyps_functionality .. exactly same as the one above *)
      intros s3 sim2. inversion sim2; cpx; allsimpl; cpx.
      rw @eq_hyps_snoc; simpl.
      assert (cover_vars A s4) as cv4
          by (apply (similarity_cover_vars lib) with (hs := H) (s1 := s1); auto).
      exists s1 s4 a t2 w p cv4; sp.
      (* while proving that functionality result, we have to prove that
       * a1 is functional, which we prove using our 1st hyp *)
      specialize (Hypab s1 s4);
      autodimp Hypab hyp1';
      autodimp Hypab hyp1'; exrepnd; clear_irr.
      lsubst_tac.
      apply tequality_mono; auto.
    + (* similarity *)
      rw @similarity_snoc; simpl.
      exists s1 s2 a a' w0 c2; sp;[].
      subst As1; auto.
    + exrepnd.
      repeat match goal with
      [H: _ = _ |- _ ] => hide_hyp H
      end; lsubst_tac.
      show_hyps.
      rewrite  simple_substc2 with (cu:= c3) in Hypb1;
      [|rw sim1; auto; fail].
      rw <- HeqBs1 in Hypb1.
      apply equality_in_mkc_mono in Hypb1.
      exrepnd.
      clear Hypb1 Hypb3 pt3 pt0 Hypb0 c7 c6 pC5 pC4.
      apply equality_sym in Heqa.
      applydup @equality_refl in Heqa.
      repnud Heqa0.
      repnud Heqa0.
      exrepnd.
      equality_unique.
      apply Huniq in Heqa1.
      repnud Hypb2.
      pose proof (Hypb2 _ _ Heqa1 hyp).
      repeat match goal with
      [H: eqa ?t1 ?t2 |- _ ] =>
        assert (equality lib t1 t2 ((Bs1) [[x \\ a]]))
         by (exists eqa; dands; auto); clear H
      end.
      eauto with nequality.
Qed.

(*
Lemma resp_cequiv_sequent : forall H, respects1 cequiv
  (fun C: NTerm => let seq:= ((H) ||- (mk_conclax C)) in
      forall  wg cg c, sequent_true (mk_wcseq seq (ext_wf_cseq seq wg cg c))).
Abort.
*)

(**
<<
   H |- Mono ((x:A) × B)

     By product_mono
     H |- Mono A
     H, x:A |- Mono B
>>
 *)
Definition rule_mono_product {o}
           (A B : @NTerm o)
           (x : NVar)
           (H : barehypotheses) :=
  mk_rule
    (mk_baresequent H (mk_conclax
        (mk_mono (mk_product A x B)) ))
    [   (mk_baresequent H (mk_conclax  (mk_mono A) )),
        (mk_baresequent (snoc H (mk_hyp x A)) (mk_conclax (mk_mono B)))
    ]
    [].

(** The following lemma lifts [approx_mk_pair] of Sec. %\ref{sec:comp:approx}%
    to the [CTerm] type *)
Lemma approxc_mkc_pair {o} :
  forall lib (t t' a b : @CTerm o),
    computes_to_valc lib t (mkc_pair a b)
    -> approxc lib t t'
    -> {a', b' : CTerm $
         computes_to_valc lib t' (mkc_pair a' b')
         # approxc lib a a'
         # approxc lib b b'}.
Proof.
  introv Hcv Hap. dest_ctermsn.
  allunfold @approxc. allunfold @computes_to_valc.
  allsimpl.
  repeat match goal with
  [H : isprog _ |- _] => clear H
  end.
  eapply approx_mk_pair in Hap; eauto;[].
  exrepnd.
  dest_ctermsn.
  applydup @approx_relates_only_progs in Hap1 as bp.
  applydup @approx_relates_only_progs in Hap2 as ap.
  repnd.
  exists (mk_cterm a' ap).
  exists (mk_cterm b' bp).
  dands; simpl; auto.
Qed.

Lemma rule_mono_product_true {o} :
  forall lib (H : @barehypotheses o)
         (A B : NTerm)
         (x: NVar),
    rule_true lib (rule_mono_product A B x H).
Proof.
  unfold rule_mono_product, rule_true, closed_type_baresequent,
       closed_extract_baresequent. simpl.
  intros.
  clear cargs.
  destseq; allsimpl.
  dLin_hyp.
  (* We prove the well-formedness of things *)
  destruct Hyp as [ wsa Hypa ].
  destruct Hyp0 as [ wsb Hypb ].
  destseq; allsimpl; proof_irr; GC.
  dup wfh0 as h; apply vswf_hypotheses_eq in h.
  inversion h as [XX |  Hsn HsH H2h H3h H4h H5h]; cpx; allsimpl.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  rw @member_eq.
  applydup @similarity_dom in sim. repnd.
  vr_seq_true in Hypa.
  generalize (Hypa s1 s2 eqh sim). rename Hypa into Hypab. intro Hypa. exrepnd.
  lsubst_tac. rw @tequality_mono in Hypa0.
  vr_seq_true in Hypb.
  match goal with
  [|- (tequality ?lib (mkc_mono ?A) (mkc_mono ?B))# _] =>
  assert (tequality lib A B) as Hteq
  end.
  - apply tequality_product.
    (* the of this subgal is exactly same as rule_function*)
    dands; auto;[]. introv Heq.
    specialize (Hypb (snoc s1 (x,a)) (snoc s2 (x,a'))).
    (* why not cons? see defn of similarity *)
    autodimp Hypb Hypb';[ |autodimp Hypb Hypb'].
    + (* hyps_functionality *)
      intros s3 sim2. inversion sim2; cpx; allsimpl; cpx.
      rw @eq_hyps_snoc; simpl.
      assert (cover_vars A s4) as cv4
          by (eapply @similarity_cover_vars with (hs := H) (s1 := s1); eauto).
      exists s1 s4 a t2 w p cv4; sp.
      (* while proving that functionality result, we have to prove that
       * a1 is functional, which we prove using our 1st hyp *)
      specialize (Hypab s1 s4);
      autodimp Hypab hyp1';
      autodimp Hypab hyp1'; exrepnd; clear_irr.
      lsubst_tac.
      apply tequality_mono; auto.
    + (* similarity *)
      rw @similarity_snoc; simpl.
      exists s1 s2 a a' w0 c2; sp;
      complete (allapply similarity_refl; sp).
    + exrepnd.
      lsubst_tac.
      rw @tequality_mono in Hypb0.
      rewrite <- simple_substc2 with (c:=c6);
      [|rw sim1; auto; fail].
      rewrite <- simple_substc2 with (c:=c7);
      [|rw sim0; auto; fail]. trivial.
  - split;[apply tequality_mono; auto; fail |].
    apply equality_in_mkc_mono.
    applydup @tequality_refl in Hteq.
    repnud Hteq0. exrepnd.
    rename eq into eqfun.
    exists eqfun.
    dands; auto;
    try(spcast;apply computes_to_valc_refl; eauto 3 with slow); [].
    introv Heq Hap.
    abbrev_ls A s1.
    abbrev_lsc B s1.
    assert (equality lib t t (mkc_product As1 x Bs1)) as Heqf
      by (exists eqfun; dands; auto).
    clear Heq.
    assert (equality lib t t' (mkc_product As1 x Bs1)) as Heqf';
    [ | exrepnd; repnud Heqf';exrepnd;
        equality_unique; apply Huniq; auto].
    apply equality_in_product in Heqf.
    exrepnd.
    apply equality_in_product.
    dands;auto;[].
    spcast.
    pose proof (computes_to_valc_eq _ _ _ _ Heqf4 Heqf2) as XX.
    apply mkc_pair_eq in XX. repnd.
    subst a2. subst b2.
    eapply approxc_mkc_pair in Hap; eauto.
    revert Hypa1. introv Hypa1. (* move to top for better visibility*)
    apply' @mono_inhabited_implies  Hypa1.
    exrepnd; auto. eapply Hypa1 in Hap2; eauto;[].
    clear Hypa1. exrepnd. exists a1 a' b1 b'. dands; spcast; auto;[].

    (* apply_clear Heqf in Heqa. *)
    specialize (Hypb (snoc s1 (x,a1)) (snoc s2 (x,a'))). (* why not cons? *)
    autodimp Hypb Hypb';[ |autodimp Hypb Hypb'].
    + (* hyps_functionality *)
      intros s3 sim2. inversion sim2; cpx; allsimpl; cpx.
      rw @eq_hyps_snoc; simpl.
      assert (cover_vars A s4) as cv4
          by (eapply @similarity_cover_vars with (hs := H) (s1 := s1); eauto).
      exists s1 s4 a1 t2 w p cv4; sp.
      (* while proving that functionality result, we have to prove that
       * a1 is functional, which we prove using our 1st hyp *)
      specialize (Hypab s1 s4);
      autodimp Hypab hyp1';
      autodimp Hypab hyp1'; exrepnd; clear_irr.
      lsubst_tac.
      apply tequality_mono; auto.
    + (* similarity *)
      rw @similarity_snoc; simpl.
      exists s1 s2 a1 a' w0 c2; sp;[].
      subst As1; auto.
    + exrepnd.
      repeat match goal with
      [H: _ = _ |- _ ] => hide_hyp H
      end; lsubst_tac.
      show_hyps.
      rewrite  simple_substc2 with (cu:= c3) in Hypb1;
      [|rw sim1; auto; fail].
      rw <- HeqBs1 in Hypb1.
      apply' @mono_inhabited_implies Hypb1.
      clear Hypb0.
      repeat match goal with
      [H:cover_vars _ _ |- _] => try clear H
      end.
      eapply Hypb1 in Hap1; eauto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


(* (c) Copyright 2006-2015 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype path fingraph.
From fourcolor Require Import hypermap jordan geometry color chromogram.
From fourcolor Require Import coloring patch snip sew revsnip kempe.
From fourcolor Require Import ctree initctree gtree initgtree ctreerestrict.
From fourcolor Require Import gtreerestrict cfmap cfcolor kempetree.

(******************************************************************************)
(* The Birkhoff theorem, stating that a minimal coloring counter-example must *)
(* be internally 5-connected, along with some of its consequences: the        *)
(* minimum face arity must be 5, and cartwheels (the radius-2 submap about a  *)
(* central hub face) must be well-formed (in particular, the radius-1 spoke   *)
(* ring about the hub must be chordless).                                     *)
(* Defined here:                                                              *)
(*        cpcard cp == number of darts in cpmap cp.                           *)
(*  ctree_pick_rev t' t == a (complete) trace coloring et such that the       *)
(*                     corresponding even partial trace is in t' : ctree, and *)
(*                     the partial trace corresonding to rev et is in t;      *)
(*                     returns [::] if there is no such trace.                *)
(*  Birkhoff_check h m <-> all configurations with ring size h+1 and kernel   *)
(*                     size greater than m are locally reducible (reducible   *)
(*                     in a map with more than m other faces). The evidence   *)
(*                     for this is a 'basis' of cprog's for cubic, but not    *)
(*                     necessarily connected configurations with at most m    *)
(*                     kernel faces (condition Birkhoff_check1), and an       *)
(*                     iteration count n such that, starting with two full    *)
(*                     ctree/gtree pairs, repeating n times the process of    *)
(*                     removing via Kempe_tree_closure a common trace         *)
(*                     returned by ctree_pick_rev in either of the ctrees,    *)
(*                     yields a ctree that is disjoint from one of the basis  *)
(*                     coloring trees computed by cpcolor (condition          *)
(*                     Birkhoff_check2).                                      *)
(*   --> The Birkhoff check condition implies there are no m-nontrivial rings *)
(* in a minimal counter-example because the two configurations consisting of  *)
(* the inside and the outside of the ring should have disjoint coloring sets, *)
(* (else we could glue two ring-compatible colourings), closed under Kempe    *)
(* flips, and meeting the coloring sets of each of the basis configurations.  *)
(*  --> In Birkhoff_check2 we could pick a trace in the intersection of the   *)
(* ctrees rather than in the intersection with reversal, but then the         *)
(* correctness proof would no longer be symmetrical as we would have to       *)
(* mirror one of the configurations. Similarly, we recheck dynamically that   *)
(* the trace is proper rather than prove it at an awkward time.               *)
(*          spoke y == the dart on the first ring of faces surrounding a      *)
(*                     central 'hub' face, that corresponds to a dart y in    *)
(*                     that hub (= face (edge y)).                            *)
(*     spoke_ring x == the (contour) ring obtained by mapping spoke on the    *)
(*                     reverse face (F-cycle) at x; spoke_ring x is simple    *)
(*                     (hence a ring, in our terminology) and indeed          *)
(*                     chordless in an internally 4-connected hypermap, hence *)
(*                     in a minimal counter-example by the Birkhoff theorem.  *)
(*        adj01 x y == x and y either belong to the same or to adjacent faces *)
(*                     of thier hypermap.                                     *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section BirkhoffCheck.

Variable h m : nat.

Fixpoint cpcard (cp : cprog) :=
  match cp with
  | (CpR _ | CpA | CpR') :: cp' => cpcard cp'
  | (CpU | CpK) :: cp' => (cpcard cp').+2
  | CpY :: cp' => (cpcard cp').+4
  | CpH :: cp' => (cpcard cp').+4.+2
  | [::] => 2
  end.

Lemma card_cpmap cp : #|cpmap cp| = cpcard cp.
Proof. by elim: cp => [|[] cp //=]; rewrite ?card_ecp ?card_bool // => ->. Qed.

Definition Birkhoff_check1 cp :=
  [&& cubic_prog cp, (cpcard cp).+1 < 6 * m + 4 * h & cprsize cp == h.+1].

Fixpoint ctree_pick_rev_rec (et : colseq) e t' t {struct t} : colseq :=
  match t with
  | CtreeLeaf _ =>
    if ctree_mem t' (etrace (belast e et)) then e :: et else [::]
  | CtreeNode t1 t2 t3 =>
    if ctree_pick_rev_rec (Color1 :: et) (e +c Color1) t' t1 is e' :: et' then
      e' :: et' else
    if ctree_pick_rev_rec (Color2 :: et) (e +c Color2) t' t2 is e' :: et' then
      e' :: et' else
    ctree_pick_rev_rec (Color3 :: et) (e +c Color3) t' t3
  | _ => [::]
  end.

Definition ctree_pick_rev := ctree_pick_rev_rec [::] Color0.

Lemma sumt_ctree_pick_rev t t' : sumt (ctree_pick_rev t t') = Color0.
Proof.
rewrite /ctree_pick_rev; set cs0 := [::].
have: Color0 +c sumt cs0 = Color0 by [].
elim: t' cs0 {1 3}Color0 => // [t1 IHt1 t2 IHt2 t3 IHt3|lf _] et e; last first.
  by move=> e_et_0 /=;  case : ifP.
move=> e_et_0 /=; set cprr := ctree_pick_rev_rec.
case Det1: (cprr _ _ _ t1) => [|e1 et1]; last first.
  by rewrite -Det1 IHt1 // [Color1]lock /= -addcA addKc.
case Det2: (cprr _ _ _ t2) => [|e2 et2]; last first.
  by rewrite -Det2 IHt2 // [Color2]lock /= -addcA addKc.
by rewrite IHt3 // [Color3]lock /= -addcA addKc.
Qed.

Lemma size_ctree_pick_rev t t' :
  ctree_proper h t' -> pred2 0 h.+1 (size (ctree_pick_rev t t')).
Proof.
rewrite /ctree_pick_rev; set cs0 := [::]; have: size cs0 + h = h by [].
elim: {1 3}h t' cs0 {1}Color0 => [|n IHn] [t1 t2 t3|lf|] et e //=.
  by rewrite addn0; case: ifP => //= _ ->.
rewrite -addSnnS => Het [_ t1ok t2ok t3ok]; set cprr := ctree_pick_rev_rec.
case Det1: (cprr _ _ _ t1) => [|e1 et1]; last by rewrite -Det1; apply: IHn.
by case Det2: (cprr _ _ _ t2) => [|e2 et2]; last rewrite -Det2; apply: IHn.
Qed.

Section BirkhoffTree.

Variable check_basis : ctree -> bool.

Definition do_Birkhoff_check2 et ctu gtu chk :=
  let ctr := ctree_of_ttail (etrace et) in
  if Color0 \in et then false else
  let: (ctu', GtreePair gtr gtu') := Kempe_tree_closure h.-1 h ctu ctr gtu in
  gtree_empty gtr && (check_basis ctu' || chk ctu' gtu').

Fixpoint Birkhoff_check2 ctu1 gtu1 n ctu2 gtu2 :=
  if n isn't n'.+1 then false else
  if ctree_pick_rev ctu1 ctu2 isn't e :: et then false else
      do_Birkhoff_check2 (belast e et) ctu1 gtu1 (Birkhoff_check2 ctu2 gtu2 n')
   && do_Birkhoff_check2 (rev et) ctu2 gtu2 (Birkhoff_check2 ctu1 gtu1 n').

End BirkhoffTree.

Inductive Birkhoff_check : Prop :=
   BirkhoffCheck niter cps (ctu := ctree_init_tree h) (gtu := gtree_init_tree h)
     (basis := map cpcolor cps) (chkb := fun t => has (ctree_disjoint t) basis)
   of all Birkhoff_check1 cps & Birkhoff_check2 chkb ctu gtu niter ctu gtu.

End BirkhoffCheck.

Module BirkhoffCheckLemmas.

Import ConfigSyntax.

Lemma Birkhoff2 : Birkhoff_check 1 0.
Proof. by exists 1 [:: Cprog]. Qed.

Lemma Birkhoff3 : Birkhoff_check 2 0.
Proof. by exists 1 [:: Cprog Y]. Qed.

Lemma Birkhoff4 : Birkhoff_check 3 0.
Proof. by exists 4 [:: Cprog U; Cprog 1 U]. Qed.

Lemma Birkhoff5 : Birkhoff_check 4 1.
Proof.
by exists 10 [:: 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 geoG : minimal_counter_example G.

Let planarG : planar G := geoG.
Let bridge'G : bridgeless G := geoG.
Let plainG : plain G := geoG.
Let cubicG : cubic G := geoG.
Let ccG : connected G := geoG.
Let noncolG := minimal_counter_example_is_noncolorable geoG.
Let minG := minimal_counter_example_is_minimal geoG.
Let ee := plain_eq geoG.
Let e'id := plain_neq geoG.
Let nnn := cubic_eq geoG.

Section BirkhoffValid.

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

Lemma Birkhoff_valid m (r : seq G) :
   Birkhoff_check n m -> scycle rlink r -> size r = n.+1 ->
 nontrivial_ring m r = false.
Proof.
case=> nm cps ctu0 gtu0 basis chkb bk1ok bk2ok; move: r.
have chkbP (r : seq G) (Ur : scycle rlink r) (bGd := snipd_ring planarG Ur) :
    size r = n.+1 -> nontrivial_ring m r ->
    forall ctu, chkb ctu ->
  exists2 et, ring_trace bGd (ctrace et) &  ~~ ctree_mem ctu (etrace et).
- move=> sz_r nt_r ctu; move: bk1ok {bk2ok}; rewrite {}/chkb {}/basis.
  elim: cps => [|cp cps IHcp] //= /andP[/and3P[cpQ ltn_cp szr_cp] bk1ok].
  case/orP=> [{cps bk1ok IHcp}ctu'cp|]; last exact: IHcp.
  pose Gr := cpmap cp; pose bGr : seq Gr := rotr 1 (rev (cpring Gr)).
  have ntGr : proper_cpring Gr := cpmap_proper cpQ.
  have cycNbGr: ufcycle node bGr.
    by rewrite rot_ucycle /ucycle cycle_rev_cpring rev_uniq cpring_uniq.
  set Gd := snip_disk planarG Ur in bGd *.
  have cycEbGd: sfcycle edge bGd by apply: scycle_snipd_ring.
  have sz_bGdr: size bGd = size bGr.
    rewrite size_rot size_rev size_ring_cpmap (eqP szr_cp) -sz_r.
    by rewrite -(map_snipd_ring planarG Ur) size_map.
  pose G2 := sew_map cycEbGd cycNbGr sz_bGdr.
  have ppG2 := sew_map_patch cycEbGd cycNbGr sz_bGdr.
  have ppGd := snip_patch planarG Ur; rewrite -/bGd in ppGd.
  move: plainG; rewrite (plain_patch ppGd) => /andP[plainGd plainGrr].
  move: cubicG; rewrite (cubic_patch ppGd) => /andP[cubicGd cubicGrr].
  have planarG2: planar G2.
    by rewrite /planar (genus_patch ppG2) addn_eq0 cpmap_planar // planar_snipd.
  have plainG2: plain G2.
    by rewrite (plain_patch ppG2); apply/andP; split; last apply: cpmap_plain.
  have cubicG2: cubic G2.
    rewrite (cubic_patch ppG2); apply/andP; split => //.
    by apply/subsetP=> x; rewrite !inE mem_rot => /(subsetP (cpmap_cubic cpQ)).
  have bridge'G2: bridgeless G2.
    have [bridge'Gd _] := patch_bridgeless ppGd bridge'G.
    apply: bridgeless_patch ppG2 bridge'Gd (cpmap_bridgeless cpQ) _.
    apply/idPn=> chord_bGd.
    have [r1 Ur1 [nt_r1 lt_r1r]] := ring_disk_chord geoG nt_r chord_bGd.
    by rewrite (leq_n_trivial Ur1) // -ltnS -sz_r in nt_r1.
  have colG2: four_colorable G2.
    apply: minG; try by do ![split | apply: cubic_precubic].
    rewrite ltnNge -(leq_add2l (size bGd)).
    move: (card_patch ppG2) (card_patch ppGd); rewrite !size_map -/G2 => <- <-.
    rewrite leq_add2l -ltnNge -ltnS card_cpmap (leq_trans ltn_cp) //.
    pose bGrr := snipr_ring planarG Ur.
    have sz_bGrr: size bGrr = n.+1.
      by rewrite -sz_r -(size_rev r) -(map_snipr_ring planarG Ur) size_map.
    case DbGrr: bGrr (sz_bGrr) => // [z0 bGrr1] _.
    have geoGrr: ucycle_plain_quasicubic_connected bGrr.
      split; first by split; [ split | apply: ucycle_snipr_ring].
      exact: (patch_connected_r ppGd ccG).
    move: (planar_snipr planarG Ur); rewrite (quasicubic_Euler geoGrr) /nilp.
    rewrite sz_bGrr add1n (patch_fcard_face_r ppGd) /outer -/Gr.
    move: #|_| => nGrr; pose arF := [predU diskFC r & fband r].
    have nbFarF: fcard face arF = n.+1 + fcard face (diskFC r).
      rewrite -sz_r -(scycle_fcard_fband Ur) -cardUI addnC eq_card0 => [|x].
        apply: eq_card => x; rewrite !inE.
        by case: (x \in fband r); rewrite andbF ?orbT ?orbF.
      by rewrite !inE; case: (x \in fband r); rewrite !andbF.
    rewrite mulnSr addnA (addnA _ 6 6) eqn_add2r.
    rewrite -(@eq_n_comp_r _ _ arF) => [|x].
      rewrite nbFarF addSn mulnSr eqn_add2r mulnDr (mulnDl 4 2) addnC.
      rewrite mul2n addnA doubleS -2!addSnnS eqn_add2r -ltnS => /eqP <-.
      by rewrite ltn_add2r ltn_pmul2l //; case/andP: nt_r.
    have imGr := codom_snipr planarG Ur.
    apply/idP/exists_inP=> [|[y]].
      rewrite !inE orbC unfold_in; case: hasP => [[y ry xFy] | _ dN'x].
        by exists y; rewrite // !inE imGr !inE ry.
      by exists x; rewrite !inE // imGr !inE (negPf dN'x) andbF.
    rewrite !(inE, imGr) orbC => xFy; apply: contraR.
    case/norP=> rF'x; rewrite rF'x negbK => dNx.
    have /andP[/= rF'y ->]: y \in diskF r.
      by rewrite -(closed_connect (diskF_face r) xFy) !inE rF'x.
    by rewrite (contra (subsetP (ring_fband r) _)).
  have [/(_ colG2)[et Det_d Det_r] _] := colorable_patch ppG2.
  case/lastP: et => [|et e] in Det_d Det_r.
    have [k _ /esym/nilP/negP[]] := Det_r.
    by rewrite /nilp size_trace size_map size_rot size_rev head_cpring.
  have De: sumt et = e.
    apply/eqP; have [k _ /(congr1 (sumt \o rotr 1))/eqP] := Det_d.
    by rewrite /= rotr1_rcons -[rotr 1 _]trace_rot sumt_trace /= addcC addc_eq0.
  exists et => [|{Det_d}]; first by rewrite /ctrace De.
  rewrite (ctree_mem_disjoint ctu'cp) //; apply/ctree_mem_cpcolor.
  split; first exact: even_etrace; rewrite /etrace sumt_permt De.
  have [k col_k Det] := Det_r; exists (etrace_perm et \o k).
    by apply: coloring_inj col_k; apply: permc_inj.
  rewrite -/Gr map_comp trace_permt -(revK (cpring Gr)) map_rev trace_rev.
  rewrite -rev_rotr -[rotr 1 _]trace_rot size_trace -[rot _ _]map_rotr -Det.
  by rewrite !(rev_rcons, rot1_cons) revK.
case Dn: {1}n => [|n'] => [[|x[]] // /andP[/andP[]] | r Ur sz_r].
  by rewrite /rlink cfaceC bridgeless_cface.
apply: contraTF bk2ok => nt_r; have Ur2 := scycle_rev_ring geoG Ur.
pose P Ur1 et := ~ ring_trace (snipd_ring planarG Ur1) et.
pose kv r1 Ur1 := Kempe_valid n' (P r1 Ur1) ctu0 CtreeEmpty GtreeEmpty gtu0.
have: kv _ Ur2 by rewrite /kv /ctu0 /gtu0 Dn; apply: Kempe_valid_init.
have: kv r Ur by rewrite /kv /ctu0 /gtu0 Dn; apply: Kempe_valid_init.
move: sz_r nt_r Ur Ur2; rewrite {}/kv -Dn.
elim: nm r ctu0 gtu0 {2 4}ctu0 {2 4}gtu0 => // nm IHnm r1 ctu1 gtu1 ctu2 gtu2.
set r2 := rev_ring r1 => sz_r1 nt_r1 Ur1 Ur2 r1valid r2valid /=.
have sz_r2: size r2 = n.+1 by rewrite size_rev size_map.
have nt_r2: nontrivial_ring m r2 by apply: (nontrivial_rev_ring geoG).
have r1closed := @ring_disk_closed _ geoG planarG _ Ur1 _ nt_r1 cubicG.
have r2closed := @ring_disk_closed _ geoG planarG _ Ur2 _ nt_r2 cubicG.
case Det: (ctree_pick_rev ctu1 ctu2) => //= [e et].
have Dct0 (ct0 := untrace Color0 (e :: et)): trace ct0 = e :: et.
  by rewrite trace_untrace // -Det sumt_ctree_pick_rev.
have sz_et: size et = n.
  have [[ctu2ok _] _] := r2valid; have:= size_ctree_pick_rev ctu1 ctu2ok.
  by rewrite Det !inE /= -Dn => /eqP[].
apply/andP=> [[r1check r2check]]; case: noncolG.
apply: (@colorable_from_ring _ geoG planarG _ Ur1 _ nt_r1 (e :: et)).
  have [// | tr1'et] := decide_ring_trace (snipd_ring planarG Ur1) (e :: et).
  move: r1check {r2check}; rewrite /do_Birkhoff_check2 {1}Dn.
  set ctr := ctree_of_ttail _; case: ifPn => // et'0.
  have []:= @Kempe_tree_closure_correct n' (P _ Ur1) n ctu1 ctr gtu1.
    apply: Kempe_valid_restrict r1valid => et1 /ctree_of_ttail_mem Det1.
    rewrite Det1 ?memc0_permt // ctrace_permt.
    split; last by rewrite size_map size_belast sz_et.
    move: (etrace_perm _) => g /r1closed[tr1_et _]; case: tr1'et.
    suffices ->: e :: et = ctrace (belast e et).
      by rewrite -[ctrace _](mapK (inv_permc g)); apply: tr1_et.
    by rewrite -Dct0 /= (scanlK addKc).
  case: Kempe_tree_closure => ctu3 [[] // gtu3] {tr1'et}r1valid _.
  case/orP=> [/(chkbP r1)[]// et1 tr_et1 ct3'et1 | {r1closed}/idPn[]].
    suffices sz_et1: size et1 = n'.+1.
      by have[] := Kempe_validP r1valid sz_et1 ct3'et1 r1closed tr_et1.
    have [k _ /(congr1 size)] := tr_et1; rewrite size_rcons size_trace size_map.
    by rewrite -(size_map snipd) (map_snipd_ring planarG Ur1) sz_r1 Dn => [][].
  by rewrite -(rev_rev_ring geoG r1) in Ur1 r1valid; apply: (IHnm r2).
have [| tr2'et] := decide_ring_trace (snipd_ring planarG Ur2) (rev (e :: et)).
  by congr (ring_trace (snipd_ring _ _) _); apply: bool_irrelevance.
move: r2check {r1check}; rewrite /do_Birkhoff_check2 {1}Dn.
set ctr := ctree_of_ttail _; case: ifPn => // et'0.
have []:= @Kempe_tree_closure_correct n' (P r2 Ur2) n ctu2 ctr gtu2.
  apply: Kempe_valid_restrict r2valid => et2 /ctree_of_ttail_mem-Det2.
  rewrite {}Det2 ?memc0_permt {et'0}// ctrace_permt.
  split; last by rewrite size_map size_rev -Dn.
  move: (etrace_perm _) => g /r2closed[tr2_et _]; case: tr2'et.
  suffices ->: rev (e :: et) = ctrace (rev et).
    by rewrite -[ctrace _](mapK (inv_permc g)); apply: tr2_et.
  suffices /eqP: sumt (rev (rcons et e)) = Color0.
    by rewrite rev_cons rev_rcons /= addc_eq0 => /eqP->.
  rewrite -rot1_cons -Dct0 -[rev _](rotrK 1) -rev_rot -!trace_rot -trace_rev.
  exact: sumt_trace.
case: Kempe_tree_closure => ctu3 [[] // gtu3] {tr2'et}r2valid _.
case/orP=> [/(chkbP r2)[]// et3 tr_et3 ct'et3 | /idPn[]]; last exact: (IHnm r1).
suffices sz_et3: size et3 = n'.+1.
  by have [] := Kempe_validP r2valid sz_et3 ct'et3 r2closed tr_et3.
have [k _ /(congr1 size)] := tr_et3; rewrite size_rcons size_trace size_map.
by rewrite -(size_map snipd) map_snipd_ring sz_r2 Dn => [][].
Qed.

End BirkhoffValid.

Theorem Birkhoff (r : seq G) :
  size r <= 5 -> scycle rlink r -> nontrivial_ring (size r == 5) r = false.
Proof.
elim: {1 3}5 (leqnn 5) => [|n IHn] n_lt5 in r *.
  case: r => // _ _; rewrite /nontrivial_ring [fcard _ _]eq_card0 // => x.
  by rewrite !inE andbF.
move/(_ (ltnW n_lt5)) in IHn; rewrite leq_eqVlt => /predU1P[]; last exact: IHn.
move=> sz_r Ur; apply: (Birkhoff_valid _ _ Ur sz_r).
  move {r Ur sz_r} => r Ur r_le_n; rewrite -(IHn r r_le_n) //.
  by rewrite eqn_leq andbC leqNgt (leq_trans _ n_lt5).
have [*] := And4 Birkhoff2 Birkhoff3 Birkhoff4 Birkhoff5.
rewrite sz_r; case: n sz_r n_lt5 {IHn}; last by do 4![case=> //].
by case: r Ur => [|x []]; rewrite /scycle //= /rlink cfaceC bridgeless_cface.
Qed.

Lemma nontrivial_cycle2 (x y : G) (r := [:: x; y]) :
  scycle rlink r -> edge x != y -> nontrivial_ring 0 r.
Proof.
move=> Ur y'ex; apply/nontrivial0P; split.
  exists (node x); rewrite !inE -(fclosed1 (diskN_node r)).
  rewrite diskN_E mem_head unfold_in /= -{2}[x]nodeK -cface1r.
  rewrite bridgeless_cface //= orbF andbT; apply: contraL Ur => nxFy /=.
  rewrite /rlink -(same_connect_r cfaceC nxFy) -[node x]nodeK -cface1r.
  by rewrite cface1 -(canRL nodeK (nnn x)) bridgeless_cface.
pose nex := node (edge x); have rF'nex: nex \notin fband r.
  rewrite unfold_in /= orbF -{1}[nex]nodeK -cface1 (canRL nodeK (nnn _)) ee.
  rewrite cfaceC cface1 bridgeless_cface //; apply: contraL Ur => /= nexFy.
  rewrite {1}/rlink -(same_connect_r cfaceC nexFy) -[edge x]nodeK -cface1.
  by rewrite cfaceC bridgeless_cface.
exists nex; rewrite !inE rF'nex -(fclosed1 (diskN_node r)) diskN_E inE /=.
by rewrite -(fclosed1 (diskE_edge planarG Ur)) !inE e'id eqxx (negPf y'ex).
Qed.

Lemma double_dart (x y : G) : cface x y -> cface (edge x) (edge y) -> x = y.
Proof.
move=> xFy exFey; apply: contraTeq isT => y'x /=.
have Ur: scycle rlink [:: x; edge y] by rewrite srcycleI //= exFey ee cfaceC.
by rewrite -(Birkhoff _ Ur) // nontrivial_cycle2 // (inj_eq edgeI).
Qed.

Section SpokeRing.

Variable x : G.

Let p : seq G := orbit face x.

Let p_x : x \in p. Proof. by rewrite -fconnect_orbit. Qed.

Let ucycFp : ufcycle face p.
Proof. by rewrite /ucycle orbit_uniq (cycle_orbit faceI). Qed.

Let Ep y : cface x y = (y \in p). Proof. exact: fconnect_orbit. Qed.

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

Lemma inj_spoke : injective spoke.
Proof. by apply: can_inj node _; apply: edgeK. Qed.

Definition spoke_ring : seq G := map spoke (rev p).

Lemma mem_spoke_ring y : (y \in spoke_ring) = cface x (node y).
Proof. by rewrite -{1}[y]nodeK (mem_map inj_spoke) mem_rev Ep. Qed.

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

Lemma next_spoke_ring (y : G) : y \in r -> next r y = face (spoke y).
Proof.
move=> ry; have [cycFp Up] := andP ucycFp.
rewrite -{1}[y]nodeK (next_map inj_spoke) ?rev_uniq // (next_rev Up).
rewrite -[prev p _]faceK /spoke ee -(canRL nodeK (nnn y)).
by rewrite (eqP (prev_cycle cycFp _)) // -Ep -Er.
Qed.

Lemma scycle_spoke_ring : scycle rlink r.
Proof.
have [cycFp Up] := andP ucycFp; apply/andP; split.
  apply: cycle_from_next; first by rewrite (map_inj_uniq inj_spoke) ?rev_uniq.
  by move=> y ry; rewrite (next_spoke_ring ry) /rlink -!cface1r.
rewrite /simple /r !map_rev rev_uniq -map_comp map_inj_in_uniq // => y z py pz.
move/(rootP cfaceC); rewrite -cface1 -cface1r; apply: double_dart.
by rewrite -!Ep in py pz; rewrite -(same_cface py).
Qed.
Let scycRr := scycle_spoke_ring.

Lemma diskF_spoke_ring y : (y \in diskF r) = cface x y.
Proof.
apply/andP/idP=> [[/= rF'y /hasP[z rz n'zDy]] | xFy]; last first.
  split; last first.
     rewrite /= -{1}[y]edgeK -(fclosed1 (diskN_node r)) diskN_E inE /= Er.
     by rewrite edgeK xFy.
  apply/hasP=> -[z]; rewrite Er => xFnz.
  rewrite -[z]nodeK -cface1r -(same_cface xFy) (same_cface xFnz).
  by rewrite bridgeless_cface.
case/connectP: n'zDy rF'y; set z0 := finv node z.
have rfz0: face z0 \in r.
  by rewrite -(ee z0) Er edgeK -(nnn z0) (f_finv nodeI) cface1r nodeK -Er.
case=> [|z1 q] /= z0Dq ->{y}.
  by case/hasP; exists (face z0); last exact: fconnect1.
case/andP: z0Dq => /andP[_ /clinkP[z0nz1 | fz0z1]] z1Dq; last first.
  case: q z1Dq => [|z2 q]; last by rewrite /dlink /= -fz0z1 rfz0.
  by rewrite (subsetP (ring_fband r)) // -fz0z1.
move: rz z1Dq; rewrite Er {z z0 z0nz1 rfz0}(canRL (f_finv nodeI) z0nz1) nnn.
elim: q z1 => //= z q IHq y xFy /andP[/andP[_ /clinkP[ynz | fyz]]].
  have rz: z \in r by rewrite Er -ynz.
  case: q {IHq} => [|z1 q]; last by rewrite /dlink /= rz.
  by rewrite (subsetP (ring_fband r)).
by apply: IHq; rewrite -fyz -cface1r.
Qed.

Lemma chordless_spoke_ring : chordless r.
Proof.
apply/subsetP=> y1 ry1; apply: contraLR isT => /exists_inP[y2] /= /adjP[z y1Fz].
rewrite /rlink => ezFy2 /and3P[ry1'y2 r'y1'y2 /= ry2].
pose q := [:: node y2; edge z; edge (node y1)].
have scycRq: scycle rlink q.
  rewrite srcycleI //= !ee cface1 nodeK cfaceC ezFy2 /= andbC.
  rewrite cface1r nodeK cfaceC y1Fz /= cfaceC; rewrite !Er in ry1 ry2.
  by rewrite -!(same_cface ry2) !(same_cface ry1) connect0 bridgeless_cface.
rewrite -(Birkhoff _ scycRq) //; apply/(nontrivial0P _); split.
  pose t := node (edge (node y1)); exists t; rewrite !inE.
  have Dt: t = prev r y1.
    have [_ Ur] := andP scycRr; rewrite /t -{1}[y1](next_prev (simple_uniq Ur)).
    by rewrite next_spoke_ring ?mem_prev // faceK edgeK.
  rewrite Er in ry2; rewrite unfold_in /= cfaceC -(same_cface ry2).
  have xFnt: cface x (node t) by rewrite -Er Dt mem_prev.
  rewrite (same_cface xFnt) -{2}[t]nodeK -cface1r bridgeless_cface //= orbF.
  rewrite cfaceC (same_cface ezFy2) cfaceC /= orbC.
  rewrite -[edge _]nodeK -cface1r bridgeless_cface //=.
  rewrite -(fclosed1 (diskN_node q)) diskN_E inE /= !inE eqxx !orbT andbT.
  apply: contra r'y1'y2 => tFy2; rewrite -Dt eq_sym.
  by apply/eqP/(scycle_cface scycRr); rewrite ?Er.
exists (node (node y1)); rewrite !inE andbC -(fclosed1 (diskN_node q)).
rewrite -{1}[node y1]ee (diskN_edge_ring geoG) ?inE ?eqxx ?orbT ?unfold_in //=.
rewrite !Er in ry1 ry2; rewrite cfaceC -(same_cface ry2) (same_cface ry1).
rewrite -{1}[node _]nodeK -cface1 cfaceC bridgeless_cface //= orbF orbC.
rewrite (canRL nodeK (nnn _)) -cface1 cfaceC cface1 nodeK bridgeless_cface //=.
rewrite cface1 cfaceC (same_cface ezFy2) -next_spoke_ring; last by rewrite Er.
by apply: contra ry1'y2 => /(scycle_cface scycRr)->; rewrite ?mem_next ?Er.
Qed.

Lemma size_spoke_ring : size r = arity x.
Proof. by rewrite /r size_map size_rev /p /orbit size_traject. Qed.

(* Proof note: the Birkhoff theorem only tells us the spoke ring must have an *)
(* empty exterior -- we must reuse the non-colorability condition to rule out *)
(* the tetrahedral map! It then turns out to be easier to use colorability    *)
(* as well to rule out the square map, rather than prove it is not cubic.     *)
Lemma min_arity : 4 < arity x.
Proof.
rewrite /= -size_spoke_ring ltnNge; apply: contraL isT => r_le4 /=.
have [y dFCy | dCF_0] := pickP [pred y | y \in diskFC r].
  rewrite -(Birkhoff _ scycRr) 1?ltnW // eqn_leq andbC ltnNge r_le4 /=.
  apply/(nontrivial0P _); split; last by exists y.
  by exists x; rewrite diskF_spoke_ring.
case: noncolG; exists (fun y =>
  if cface x y then Color0 else
  let i := find (cface y) r in
  if (i == 2) && (size r == 3) then Color3 else
  if pred2 0 2 i then Color1 else Color2).
split=> y /=; last by rewrite -cface1r -(eq_find (cface1 y)) eqxx.
set i1 := find (cface y) r; set i2 := find (cface (edge y)) r.
case xFy: (cface x y).
  by rewrite (same_cface xFy) bridgeless_cface //; do 2?case: ifP.
case xFey: (cface x (edge y)); first by do 2?case: ifP.
have rFy: y \in fband r.
  apply: contraFT (dCF_0 y) => rF'y; rewrite !inE rF'y.
  by rewrite -diskF_spoke_ring !inE rF'y /= in xFy; rewrite xFy.
have rFey: edge y \in fband r.
  apply: contraFT (dCF_0 (edge y)) => rF'ey; rewrite !inE rF'ey.
  by rewrite -diskF_spoke_ring !inE rF'ey /= in xFey; rewrite xFey.
pose z1 := nth x r i1; pose z2 := nth x r i2.
have z1Az2: adj z1 z2.
  by apply/adjP; exists y; first rewrite cfaceC; apply: nth_find.
have [lti1r lti2r]: i1 < size r /\ i2 < size r by rewrite -!has_find.
have [rz1 rz2]: z1 \in r /\ z2 \in r by rewrite !mem_nth.
have [cycRr /simple_uniq Ur] := andP scycRr.
have{rz1}:= pred0P (subsetP chordless_spoke_ring _ rz1) z2.
rewrite !inE {}z1Az2 {}rz2 andbT (eq_sym z2) (canF_eq (prev_next Ur)) /=.
have eq_nth_prev i j (lti : i < size r) (ltj : j < size r):
  (nth x r j == prev r (nth x r i)) = (j == (if i == 0 then size r else i).-1).
- suff <-: index (prev r (nth x r i)) r = (if i == 0 then size r else i).-1.
    by rewrite -(nth_uniq x _ _ Ur) ?nth_index ?index_mem // mem_prev ?mem_nth.
  rewrite prev_nth mem_nth //; case Dr: r => // [x0 r1] in Ur lti *.
  rewrite index_uniq ?ltnS ?index_size //; have /=/andP[r1'x0 Ur1] := Ur.
  case: i => [|i] /= in lti *; last by rewrite index_uniq.
  by apply/eqP; rewrite eqn_leq index_size leqNgt index_mem.
rewrite !{}eq_nth_prev {z1 z2}//.
case Dn: (size r) r_le4 lti1r lti2r => [|[|n]] //.
  by case: r cycRr Dn => [|x0 []] //=; rewrite /rlink cfaceC bridgeless_cface.
by case: i1 i2 n {Dn} => [|[|[|[|i1]]]] [|[|[|[|i2]]]] [|[|[|n]]].
Qed.

Lemma fband_spoke_ring y : (y \in fband r) = adj x y.
Proof.
apply/hasP/adjP => [[z rz zFy] | [z xFz zRy]].
  by exists (node z); [rewrite -Er | rewrite /rlink cface1 nodeK cfaceC].
by exists (face (edge z)); [rewrite Er edgeK | rewrite -cface1r cfaceC].
Qed.

Lemma adj11_edge y : adj x y -> adj x (edge y) -> (y \in r) || (edge y \in r).
Proof.
rewrite -!fband_spoke_ring => /hasP[z rz yFz] /hasP[t rt eyFt].
apply: contraFT (pred0P (subsetP chordless_spoke_ring _ rz) t).
case/norP=> r'y r'ey; rewrite !inE -(adjF yFz) -(adjFr eyFt) adjE rt andbT.
have [cycRr /simple_uniq Ur] := andP scycRr.
rewrite /= andbC eq_sym (canF_eq (next_prev Ur)) !next_spoke_ring //.
apply/andP; split; apply/eqP=> Dz.
  rewrite Dz -!cface1r -[y]ee in yFz.
  by rewrite (double_dart eyFt) ?rt in r'ey.
by rewrite Dz -!cface1r in eyFt; rewrite (double_dart yFz) ?rz in r'y.
Qed.

Lemma fcard_adj_adj y : adj x y -> fcard face (predI (adj y) (adj x)) = 2.
Proof.
move=> xAy; have /hasP[y1 ry1 yFy1]: y \in fband r by rewrite fband_spoke_ring.
rewrite [fcard _ _](cardD1 (froot face (next r y1))).
rewrite (cardD1 (froot face (prev r y1))) !inE !(roots_root cfaceC).
have r_xA z: z \in r -> adj x z by rewrite Er => /adjF->; apply: adjN.
set z1 := prev r y1; have rz1: z1 \in r by rewrite mem_prev.
set z2 := next r y1; have rz2: z2 \in r by rewrite mem_next.
rewrite -!(adjFr (connect_root _ _)) !r_xA //=.
have [cycRr /simple_uniq Ur] := andP scycRr.
rewrite !(adjF yFy1) (rlink_adj (next_cycle cycRr ry1)) adjC //.
rewrite (rlink_adj (prev_cycle cycRr ry1)) /= (sameP eqP (rootP cfaceC)).
case z1Fz2: (cface z1 z2).
  case: (rot_to rz1) min_arity (cycle_next Ur) (Ur) => [i r1 Dr].
  rewrite -size_spoke_ring -(size_rot i) -(rot_cycle i) -(rot_uniq i) Dr.
  case: r1 {Dr} => [|y3 [|z3 r3]] // _ /and3P[/= /eqP Dy3 /eqP Dz3 _].
  case/andP=> /= /norP[_ /norP[/eqP[]]]; rewrite -Dz3 -Dy3.
  by rewrite (next_prev Ur); apply: (scycle_cface scycRr).
rewrite eq_card0 // => t; apply/and5P=> [] [z1F't z2F't /eqP Dt yAt xAt].
rewrite -Dt !(sameP eqP (rootP cfaceC)) in z1F't z2F't.
move: xAt; rewrite -fband_spoke_ring => /hasP[t1 rt1 tFt1].
case/andP: (pred0P (subsetP chordless_spoke_ring _ ry1) t1); split.
  by rewrite !inE -(adjF yFy1) -(adjFr tFt1).
rewrite !inE rt1 andbT; apply/andP; split; apply/eqP => [Dt1].
  by rewrite (same_cface tFt1) Dt1 connect0 in z2F't.
by rewrite (same_cface tFt1) Dt1 connect0 in z1F't.
Qed.

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

Lemma adj12_edge y z :
  adj x y -> adj x z -> adj z (edge y) -> adj01 z y || adj01 x (edge y).
Proof.
rewrite -2!fband_spoke_ring => /hasP[y1 ry1 yFy1] /hasP[z1 rz1 zFz1].
case/adjP=> x1 zFx1; rewrite /rlink cfaceC => eyFex1.
apply/norP=> [] [/norP[zF'y zA'y] /norP[xF'ey xA'ey]].
rewrite !(same_cface zFz1) in zF'y zFx1; rewrite {z zFz1}(adjF zFz1) in zA'y.
pose q := [:: y; edge x1; edge (node z1); node y1].
have scycRq: scycle rlink q.
  rewrite srcycleI //= eyFex1 cface1r nodeK cfaceC zF'y !ee /= andbT.
  rewrite (same_cface yFy1) cfaceC (adj_no_cface geoG (adjN y1)) /=.
  rewrite cface1r nodeK cfaceC zFx1 -(same_cface eyFex1) cfaceC.
  rewrite !Er in ry1 rz1; rewrite -(same_cface ry1) xF'ey.
  by rewrite -(same_cface rz1) ry1 cface1 nodeK cfaceC yFy1.
apply: (elimF (nontrivial0P _) (Birkhoff _ scycRq) _) => //; split.
  exists (node (node y1)); rewrite !inE -(fclosed1 (diskN_node q)).
  rewrite diskN_E !inE eqxx /= !orbT andbT // unfold_in /= orbF.
  rewrite cfaceC (same_cface yFy1) -{2 4}[y1]edgeK nnn -cface1r.
  rewrite bridgeless_cface // cfaceC -(same_cface eyFex1) (no_adj_adj xA'ey).
    rewrite -cface1 cfaceC cface1 nodeK; rewrite adjC // in zA'y.
    rewrite (no_adj_adj zA'y); first by rewrite adj_no_cface ?adjN.
    by rewrite (adjF yFy1) adjE.
  by rewrite Er in ry1; rewrite (adjF ry1) adjC ?adjN.
exists (node (node z1)); rewrite !inE -(fclosed1 (diskN_node q)).
rewrite -{2}[node z1]ee (diskN_edge_ring geoG) //= ?inE ?eqxx ?orbT //.
rewrite unfold_in /= andbT orbF -{1 3}[z1]edgeK nnn -cface1 cfaceC.
rewrite (no_adj_adj zA'y (adjE z1)); rewrite !Er in ry1 rz1.
rewrite cfaceC -(same_cface eyFex1) (no_adj_adj xA'ey) /=.
  rewrite -cface1 cfaceC cface1 nodeK bridgeless_cface //.
  rewrite cfaceC -(same_cface ry1) (same_cface rz1) -{1}[node z1]nodeK -cface1.
  by rewrite cfaceC bridgeless_cface.
by rewrite (adjF rz1) adjC ?adjN.
Qed.

Lemma fcard_adj_max y : ~~ cface x y -> fcard face (predI (adj y) (adj x)) <= 2.
Proof.
move=> xA'y; case xAy: (adj01 x y).
  by rewrite /adj01 (negPf xA'y) in xAy; rewrite (fcard_adj_adj xAy).
rewrite {xA'y}leqNgt /(fcard _ _); set axy := predI _ _; apply/negP => axy_gt2.
have{axy_gt2} []: {e | 2 < size e & all axy e /\ uniq e}.
  exists (enum axy); [by rewrite -cardE | split; last exact: enum_uniq].
  by apply/allP=> z; rewrite mem_enum.
case=> [|z1 [|z2 [|z3 e]]] //= _ [/and4P]; rewrite !inE !negb_or.
case=> /and3P[Dz1 yAz1 xAz1] /and3P[Dz2 yAz2 xAz2] /and3P[Dz3 yAz3 xAz3] _.
case/and3P=> /and3P[z2'1 z3'1 _] /andP[z3'2 _] _ {axy e}.
have{xAy} cross_adj z t: z != t -> froots face z -> froots face t ->
    adj x z -> adj x t -> adj y z -> adj y t -> adj z t.
- move=> /negPf t'z /eqP Dz /eqP Dt xAz xAt yAz /adjP[u yFu uRt].
  rewrite -(adjFr uRt) in xAt; rewrite (adjF yFu) adjC // -[u]ee in yAz.
  move: (adj12_edge xAt xAz yAz).
  rewrite ee orbC /adj01 -(adjFr yFu) cfaceC -(same_cface yFu) cfaceC.
  rewrite -/(adj01 x y) xAy cfaceC (same_cface uRt) cfaceC.
  by rewrite (sameP (rootP cfaceC) eqP) Dz Dt t'z (adjFr uRt).
have []: [/\ adj z1 z2, adj z1 z3 & adj z2 z3] by split; apply: cross_adj.
move: {y Dz1 Dz2 Dz3 yAz1 yAz2 yAz3 z2'1 z3'1 z3'2 cross_adj} xAz1 xAz2 xAz3.
rewrite -!fband_spoke_ring => /hasP[t1 rt1 zFt1] /hasP[t2 rt2 zFt2].
move=> /hasP[t3 rt3 zFt3].
rewrite !(adjF zFt1) (adjF zFt2) (adjFr zFt2) !(adjFr zFt3).
move {z1 z2 z3 zFt1 zFt2 zFt3} => t1At2 t1At3 t2At3.
have [cycRr /simple_uniq Ur] := andP scycRr.
have Ar_xor u v: adj u v -> u \in r -> v \in r ->
    next r u <> next r v /\ (next r u = v \/ next r v = u).
- move=> uAv ru rv; split=> [eq_ruv | ].
    have /idP[] := adj_no_cface bridge'G uAv.
    by rewrite (can_inj (prev_next Ur) eq_ruv).
  apply/pred2P; apply: contraFT (pred0P (subsetP chordless_spoke_ring _ ru) v).
  by rewrite !inE uAv rv -(canF_eq (prev_next Ur)) eq_sym negb_or andbT.
have{t1At2} [rt2'1 rt1V2] := Ar_xor t1 t2 t1At2 rt1 rt2.
have{t1At3} [rt3'1 rt1V3] := Ar_xor t1 t3 t1At3 rt1 rt3.
have{Ar_xor t2At3} [rt3'2 rt2V3] := Ar_xor t2 t3 t2At3 rt2 rt3.
have [i r1 Dr1] := rot_to rt1.
move: min_arity (cycle_next Ur) (Ur).
rewrite -size_spoke_ring -(size_rot i) -(rot_cycle i) -(rot_uniq i) {i}Dr1.
case: r1 => [|u2 [|u3 [|u4 r1]]] //= _ /and4P[/eqP <- /eqP <- /eqP <- _].
rewrite !negb_or => /andP[/and4P[_ _ /eqP[]]] {u2 u3 u4 r1}.
case: rt1V2 rt2V3 rt1V3 rt2'1 rt3'1 rt3'2; first by move=> -> [] -> // [] ->.
by move=> Dt1; rewrite Dt1 => [] [-> | Dt2] // [] -> //; rewrite Dt2.
Qed.

End SpokeRing.

Definition minimal_counter_example_is_plain_cubic_pentagonal :=
  PlainCubicPentagonal geoG min_arity.

End Birkhoff.

Prenex Implicits spoke spoke_ring.

Coercion minimal_counter_example_is_plain_cubic_pentagonal :
  minimal_counter_example >-> plain_cubic_pentagonal.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^150 - 3
Base: 50
***)

Definition curve : CurveParameters :=
  {|
    sz := 3%nat;
    base := 50;
    bitwidth := 64;
    s := 2^150;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 3); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From iris.proofmode Require Import base proofmode classes.
From transfinite.base_logic.lib Require Export fancy_updates.
From melocoton.mlanguage Require Export mlanguage progenv weakestpre.
From melocoton Require Import multirelations named_props.
From iris.bi Require Export weakestpre.
From iris.prelude Require Import options.
From transfinite.base_logic.lib Require Import satisfiable.
From transfinite.stepindex Require Import ordinals.
Import uPred.
Import umrel.

Section CoinductiveSteps.
    CoInductive star_mrel_w {A} (M : umrel A) : A → (A → Prop) → Prop :=
    | star_refl_w x (X : A → Prop) :
      X x → star_mrel_w M x X
    | star_step_w x Y (X : A → Prop) :
      M x Y →
      (∀ y, Y y → star_mrel_w M y X) →
      star_mrel_w M x X.
End CoinductiveSteps.

Section Adequacy.
  Existing Instance ordI.
  Context {val : Type}.
  Context {Λ : mlanguage val}.
  Context {Σ : gFunctors}.

  Context {Φpure : val → state Λ → Prop}.
  Context {pe : prog_environ Λ Σ}.
  Context {Φbi : val → iProp Σ}.

  Notation step := (prim_step (penv_prog pe)).
  Notation cfg := (prod (expr Λ) (state Λ)).

  Implicit Types σ : state Λ.
  Implicit Types v : val.
  Implicit Types e : expr Λ.
  Implicit Types X : cfg → Prop.

  Definition sideConds `{!invG Σ, !mlangG val Λ Σ} : iProp Σ :=
    □ (∀ σ v, state_interp σ ∗ Φbi v ==∗ ⌜Φpure v σ⌝)
  ∗ □ (∀ f s vv, penv_proto pe f s vv -∗ False).

  Section GenAdequacy.
    Context `{!mlangG val Λ Σ, !invG Σ}.
    Context (sat_at : coPset → iProp Σ → Prop).
    Context `{!SatisfiableAt sat_at}.
    Context `{SatisfiableAtExists (cfg→Prop) sat_at}.

    Lemma value_from_wp σ v E :
      sat_at E (sideConds ∗ state_interp σ ∗ WP (of_val Λ v) @ pe; E {{Φbi}})%I
    → Φpure v σ.
    Proof using All.
      intros Hsat. eapply sat_mono in Hsat. 1: eapply sat_fupd, sat_elim in Hsat; eapply Hsat.
      iIntros "(#(HΦ&Hproto)&Hσ&HWP)".
      rewrite wp_unfold /wp_pre.
      iPoseProof ("HWP" $! σ with "Hσ") as "HWP".
      iMod "HWP" as "[(%z & %HH & H)|[(%s & %vv & %K & %is_call & H2 & Hb & Hσ & (%Ξ & Hprot & _))|(%Hnv&H3)]]".
      - apply of_val_inj in HH. subst z.
        iApply ("HΦ" $! σ v with "H").
      - iExFalso. iApply "Hproto". iApply "Hprot".
      - by rewrite to_of_val in Hnv.
    Qed.

    Lemma one_step_from_wp σ e E:
      (to_val e = None) →
      sat_at E (sideConds ∗ state_interp σ ∗ WP e @ pe; E {{Φbi}})%I →
      ∃ X, step (e,σ) X ∧ ∀ e' σ', X (e', σ') → sat_at E (sideConds ∗ state_interp σ' ∗ WP e' @ pe; E {{Φbi}}).
    Proof using All.
      intros Hnv Hsat.
      eapply sat_mono in Hsat.
      1: eapply sat_fupd, sat_exists in Hsat;
         destruct Hsat as (X&(Hstep%sat_elim & Hsat)%sat_sep).
      2: {
        iIntros "(Hsides&Hσ&HWP)".
        rewrite wp_unfold /wp_pre.
        iMod ("HWP" $! σ with "Hσ") as "[(%z & %HH & H)|[(%s & %vv & %K & %is_call & H2 & Hb & Hσ & (%Ξ & Hprot & _))|(_&%X&Hpure&H3)]]".
        - exfalso. subst e. by rewrite to_of_val in Hnv.
        - iExFalso. iDestruct "Hsides"  as "(_&Hproto)". iApply "Hproto". iApply "Hprot".
        - iModIntro. iApply (exist_intro X). iFrame; iAccu. }
      exists X; split; first done.
      intros e' σ' Hcfg'.
      eapply sat_mono in Hsat; first (eapply sat_fupd, sat_later, sat_fupd in Hsat; exact Hsat).
      iIntros "(Hside&H3)". iFrame. iMod ("H3" $! e' σ' Hcfg') as "H3".
      iModIntro. iNext. iApply "H3".
    Qed.

    Lemma star_step_from_wp σ e E X:
      sat_at E (sideConds ∗ state_interp σ ∗ WP e @ pe; E {{Φbi}})%I →
      (star_AD step (e, σ) X) →
      (∃ e σ, X (e, σ) ∧ (∀ v, to_val e = Some v → Φpure v σ)).
    Proof using All.
      assert (∃ x, fst x = e ∧ snd x = σ ∧ (e,σ)=x) as (x&<-&<-&->).
      1: by exists (e,σ).
      intros Hsat. unfold mrel; cbn in *.
      induction 1 as [[e σ] X H|[e σ] X IH] in Hsat|-*; cbn in *.
      - exists e, σ. split; first done.
        intros v <-%of_to_val. by eapply value_from_wp.
      - destruct (to_val e) as [v|] eqn:Heq.
        1: eapply of_to_val in Heq; subst e;
          destruct (IH _ (val_prim_step _ _ _)) as (?&[]&_).
        eapply one_step_from_wp in Hsat; last done.
        destruct Hsat as (Y&HstepY&Hcont).
        destruct (IH Y HstepY) as ([e' σ']&Hy&Hmrel&Hsat).
        eapply Hsat, Hcont, Hy.
    Qed.

    Lemma star_step_from_wp_coind σ e E:
      sat_at E (sideConds ∗ state_interp σ ∗ WP e @ pe; E {{Φbi}})%I →
      (star_mrel_w step (e, σ) (λ '(e, σ), match to_val e with Some v => Φpure v σ | _ => False end)).
    Proof using All.
      revert e σ. cofix IH.
      intros e σ Hsat.
      destruct (to_val e) as [v|] eqn:Heq.
      - eapply star_refl_w. eapply of_to_val in Heq; subst e.
        rewrite to_of_val. by eapply value_from_wp.
      - eapply one_step_from_wp in Hsat; last done.
        destruct Hsat as (Y&HstepY&Hcont).
        eapply star_step_w. 1: exact HstepY.
        intros [e' σ'] Hy. eapply IH, Hcont, Hy.
    Qed.

  End GenAdequacy.

  Section ConreteAdequacy.
    Context `{!invPreG Σ}.

    Context (e : Λ.(expr)).
    Context (σ : Λ.(state)).
    Context (Halloc : ∀ `{!invG Σ}, Alloc (mlangG val Λ Σ) (λ H,
      sideConds ∗ state_interp σ ∗ WP e @ pe ; ⊤ {{Φbi}})%I True).

    Lemma alloc_adequacy X:
      (star_AD step (e, σ) X) →
      (∃ e σ, X (e, σ) ∧ (∀ v, to_val e = Some v → Φpure v σ)).
    Proof using All.
      pose proof (@alloc_intro _ Σ) as Hsat.
      eapply alloc_wsat_inst in Hsat as (HinvG&Hsat); last done.
      eapply (Halloc HinvG) in Hsat as (HmlangG&Hsat); last done.
      eapply alloc_iProp_sat in Hsat.
      eapply (star_step_from_wp iProp_sat_at).
      unfold iProp_sat_at, sat_frame.
      eapply sat_mono; last exact Hsat.
      iIntros "((_&$)&$)".
    Qed.

    Lemma alloc_adequacy_coind X:
      (star_mrel_w step (e, σ) (λ '(e, σ), match to_val e with Some v => Φpure v σ | _ => False end)).
    Proof using All.
      pose proof (@alloc_intro _ Σ) as Hsat.
      eapply alloc_wsat_inst in Hsat as (HinvG&Hsat); last done.
      eapply (Halloc HinvG) in Hsat as (HmlangG&Hsat); last done.
      eapply alloc_iProp_sat in Hsat.
      eapply (star_step_from_wp_coind iProp_sat_at).
      unfold iProp_sat_at, sat_frame.
      eapply sat_mono; last exact Hsat.
      iIntros "((_&$)&$)".
    Qed.

  End ConreteAdequacy.
End Adequacy.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^401 - 31
Base: 57 + 2/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 57 + 2/7;
    bitwidth := 64;
    s := 2^401;
    c := [(1, 31)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj7synthconj5 : forall  (lv0 : lst), (@eq natural (len (Cons Zero lv0)) (Succ (len lv0))).
Admitted.
QuickChick conj7synthconj5.


(* from https://github.com/coq/coq/issues/9294#issuecomment-450860504 *)

Inductive Foo@{i} (A:Type@{i}) : Type := foo : (Set:Type@{i}) -> Foo A.
Arguments foo {_} _.

Definition bar : Foo True -> Set := fun '(foo x) => x.

Definition foo_bar (n : Foo True) : foo (bar n) = n.
Proof. destruct n;reflexivity. Qed.

Definition bar_foo (n : Set) : bar (foo n) = n.
Proof. reflexivity. Qed.

Require Import Hurkens.

Inductive box (A : Set) : Prop := Box : A -> box A.

Definition paradox : False.
Proof.
unshelve refine (
  NoRetractFromSmallPropositionToProp.paradox
  (Foo True)
  (fun A => foo A)
  (fun A => box (bar A))
  _
  _
  False
).
+ cbn; intros A [x]; exact x.
+ cbn; intros A x; refine (Box _ x).
Qed.

Check paradox.
Print Assumptions paradox.


From iris.program_logic Require Export total_adequacy.
From iris.heap_lang Require Export adequacy.
From iris.heap_lang Require Import proofmode notation.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".

Definition heap_total Σ `{heapPreG Σ} s e σ φ :
  (∀ `{heapG Σ}, WP e @ s; ⊤ [{ v, ⌜φ v⌝ }]%I) →
  sn step ([e], σ).
Proof.
  intros Hwp; eapply (twp_total _ _); iIntros (?) "".
  iMod (gen_heap_init σ) as (?) "Hh".
  iModIntro. iExists gen_heap_ctx; iFrame.
  iApply (Hwp (HeapG _ _ _)).
Qed.