Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.

Require Import Arith.
Require Import Ascii.
Require Import Bool.
Require Import Coq.Strings.Byte.
Import Nat.
Require Import ZArith.

Require Import Omega.
Set Nested Proofs Allowed.

Require Import List.
Local Open Scope list_scope.
Scheme Equality for list.
Import ListNotations.

Inductive types : Set :=
| typeNat : nat -> types
| typeBool : bool -> types.

Inductive ErrorNat :=
  | error_nat : ErrorNat
  | num : nat -> ErrorNat.

Inductive ErrorBool :=
  | error_bool : ErrorBool
  | boolean : bool -> ErrorBool.

Inductive ErrorChars :=
  | error_char : ErrorChars
  | chars : string -> ErrorChars.

Check (chars "aaa").

Coercion num: nat>->ErrorNat.
Coercion boolean : bool >-> ErrorBool.
Coercion chars : string >-> ErrorChars.

Check (typeNat 3).

Coercion typeNat: nat>->types.
Coercion typeBool : bool >-> types.

(*Nat and Bool List*)

Inductive list (T : Type) : Type :=
| nil : list T
| node : T -> list T -> list T.

Check (node nat 3 (nil nat)).
Check (node bool false (node bool true (nil bool))).

Notation "'listNat' [ x ,, y ,, .. ,, z ]" :=(node nat x (node nat y ..(node nat z (nil nat)) ..)).
Check (listNat [3,,4,,5]).

Notation "'listBool' [ x ,, y ,, .. ,, z ]" :=(node bool x (node bool y ..(node bool z (nil bool)) ..)).
Check (listBool [true,,true,,true]).

(*Vectors*)

Inductive Vector :=
  | vectorNat: list nat -> Vector
  | vectorBool : list bool -> Vector.

(*Refolosesc notatiile listelor pentru vectori*)

Notation "'vectorNat' L" := (vectorNat L) (at level 20).
Notation "'vectorBool' L" := (vectorBool L) (at level 20).

Check (vectorNat listNat [3 ,, 4 ,, 5]).
Check (vectorBool listBool [true ,, false ,, false ,, true]).

Inductive ErrorVector:=
  | errorVector : ErrorVector
  | vector : Vector -> ErrorVector.

Check (errorVector).

Check (vector (vectorNat listNat [3 ,, 4 ,, 5])).
Check (vector (vectorBool listBool [false ,, false ,, true])).

(*Stack*)

Inductive natStack:=
  | stackBottomNat : natStack
  | stackElementNat  : nat -> natStack -> natStack.

Inductive boolStack:=
  | stackBottomBool : boolStack
  | stackElementBool  : bool -> boolStack -> boolStack.

Inductive Stack :=
  | NatStack : natStack -> Stack
  | BoolStack : boolStack -> Stack.

Check (NatStack stackBottomNat).
Check (NatStack (stackElementNat 3 stackBottomNat)).

Check (NatStack (stackElementNat 3 (stackElementNat 5 stackBottomNat))).

Notation "'NatStack' [ x >> y >> .. >> z ]" :=(NatStack (stackElementNat x (stackElementNat y .. ( stackElementNat z (stackBottomNat) ) ..))).
Notation "'BoolStack' [ x >> y >> .. >> z ]" :=(BoolStack (stackElementBool x (stackElementBool y .. ( stackElementBool z (stackBottomBool) ) ..))).

Check (NatStack [3 >> 4 >> 5]).
Check (BoolStack [true >> true >> false >> true >> false]).

Inductive ErrorStack :=
  | errorStack : ErrorStack
  | stack: Stack -> ErrorStack.

Check (stack (NatStack [3 >> 4 >> 5])).
Check (stack (BoolStack [true >> true >> false >> true >> false])).

(*Queue*)

Inductive natQueue:=
  | queueBottomNat : natQueue
  | queueElementNat  : nat -> natQueue -> natQueue.

Inductive boolQueue:=
  | queueBottomBool : boolQueue
  | queueElementBool  : bool -> boolQueue -> boolQueue.

Inductive Queue :=
  | NatQueue : natQueue -> Queue
  | BoolQueue : boolQueue -> Queue.

Check (NatQueue queueBottomNat).
Check (NatQueue (queueElementNat 3 queueBottomNat)).

Check (NatQueue (queueElementNat 3 (queueElementNat 5 queueBottomNat))).

Notation "'NatQueue' [ x << y << .. << z ]" :=(NatQueue (queueElementNat x (queueElementNat y .. ( queueElementNat z (queueBottomNat) ) ..))).
Notation "'BoolQueue' [ x << y << .. << z ]" :=(BoolQueue (queueElementBool x (queueElementBool y .. ( queueElementBool z (queueBottomBool) ) ..))).

Check (NatQueue [3 << 4 << 5]).
Check (BoolQueue [true << true << false << true << false]).

Inductive ErrorQueue :=
  | errorQueue : ErrorQueue
  | queue: Queue -> ErrorQueue.

Check (queue (NatQueue [3 << 4 << 5])).
Check (queue (BoolQueue [true << true << false << true << false])).

(*Map*)

Inductive MapElement : Type :=
| mapElement : string -> nat -> MapElement.

Inductive Map : Type :=
| mapEl : string -> list MapElement -> Map.

Inductive ErrorMap :=
| errorMap : ErrorMap
| map : Map -> ErrorMap.

Coercion map : Map >-> ErrorMap.

Notation "[( E1 , E2 )]" := (mapElement E1 E2) (at level 0).

Check (mapElement "S1" 1).
Check [("S1" , 1)].

Check (mapEl "map" ( node MapElement (mapElement "S1" 1 )(nil MapElement ) ) ) .

Notation "{ x , y , .. , z }" :=  (node MapElement x (node  MapElement y .. (node  MapElement z (nil MapElement) ) ..) ) .

Check { [("S1", 1)] , [("S2" , 2)] }.
Check mapEl "Map" { [("S1", 1)] , [("S2" , 2)] }.

Inductive returnType :=
  | errorUndeclared : returnType
  | errorAssignment : returnType
  | default : returnType
  | returnNat : ErrorNat -> returnType
  | returnBool : ErrorBool -> returnType
  | returnChars : ErrorChars -> returnType
  | returnVector : ErrorVector -> returnType
  | returnStack : ErrorStack -> returnType
  | returnQueue : ErrorQueue -> returnType
  | returnMap : ErrorMap -> returnType.

Definition Env := string -> returnType.

Definition env : Env := fun x => errorUndeclared.

Definition check_eq_over_types (t1 : returnType) (t2 : returnType) : bool :=
  match t1 with
    | errorUndeclared => match t2 with
                     | errorUndeclared => true
                     | _ => false
                     end
    | errorAssignment => match t2 with
                     | errorAssignment => true
                     | _ => false
                     end
    | default => match t2 with
                     | default => true
                     | _ => false
                     end
    | returnNat a => match t2 with
                     | returnNat b => true
                     | _ => false
                     end
    | returnBool a => match t2 with
                     | returnBool b => true
                     | _ => false
                     end
    | returnChars a => match t2 with
                     | returnChars b => true
                     | _ => false
                     end
    | returnVector a => match t2 with
                     | returnVector b => true
                     | _ => false
                     end
    | returnStack a => match t2 with
                     | returnStack b => true
                     | _ => false
                     end
    | returnQueue a =>  match t2 with
                     | returnQueue b => true
                     | _ => false
                     end
    | returnMap a =>  match t2 with
                     | returnMap b => true
                     | _ => false
                     end
  end.

Compute (check_eq_over_types (returnBool true) (returnBool false) ).

Compute (check_eq_over_types (returnChars "aaa") (returnChars "bbb") ).

Compute (check_eq_over_types (returnNat 3) (returnStack (stack (NatStack [3 >> 4 >> 5]) ) ) ).

Definition update (env : Env) (x : string) (v : returnType) : Env :=
  fun y =>
    if (string_beq y x)
        then
        if (andb (bool_beq (check_eq_over_types v default) true) (bool_beq (check_eq_over_types (env x) errorUndeclared) true)) then v
            else if (bool_beq (check_eq_over_types (env x) default) true)  then v
                     else if (bool_beq (check_eq_over_types (env x) errorUndeclared) true) then (env x)
                              else if (bool_beq (check_eq_over_types (env x) v) true) then v
                                       else errorAssignment
    else (env y).

Notation "S [ V /' X ]" := (update S X V) (at level 0).

Compute (env "y").
Compute (update (update env "y" (default)) "y" (returnBool true) "y").
Compute ((update (update (update env "y" default) "y" (returnNat 10)) "y" (returnBool true)) "y").

(*EXP*)

(*vector exp*)

Inductive VExp :=
| vvar : string -> VExp
| vconst : ErrorVector -> VExp.

Coercion vvar: string >-> VExp.
Coercion vconst : ErrorVector >-> VExp.

(*stack exp*)

Inductive SExp :=
| svar : string -> SExp
| sconst : ErrorStack -> SExp
| popS : SExp -> SExp
| pushSNat : SExp -> nat -> SExp
| pushSBool : SExp -> bool -> SExp .

Coercion svar: string >-> SExp.
Coercion sconst : ErrorStack >-> SExp.

(*queue exp*)

Inductive QExp :=
| qvar : string -> QExp
| qconst : ErrorQueue -> QExp
| popQ : QExp -> QExp
| pushQNat : QExp -> nat -> QExp
| pushQBool : QExp -> bool -> QExp.

Coercion qvar: string >-> QExp.
Coercion qconst : ErrorQueue >-> QExp.

(*MExp*)

Inductive MExp :=
| mvar : string -> MExp
| mconst : ErrorMap -> MExp.

(*chars exp*)

Inductive CExp :=
| cvar : string -> CExp
| cconst : ErrorChars -> CExp
| mapFindCh : MExp -> nat -> CExp
| strcat : CExp -> CExp -> CExp
| strcpy : CExp -> CExp -> CExp.

Coercion cvar: string >-> CExp.
Coercion cconst : ErrorChars >-> CExp.

(*AEXP*)

Inductive AExp :=
| avar: string -> AExp
| anum: ErrorNat -> AExp
| aplus: AExp -> AExp -> AExp
| aminus: AExp -> AExp -> AExp
| amul: AExp -> AExp -> AExp
| adiv: AExp -> AExp -> AExp
| amod: AExp -> AExp -> AExp
| index : VExp -> nat -> AExp
| topS : SExp -> AExp
| topQ : QExp -> AExp
| mFind : MExp -> string -> AExp
| strstr : CExp -> CExp -> AExp.

Coercion anum: ErrorNat >-> AExp.
Coercion avar: string >-> AExp.

Notation "A +' B" := (aplus A B)(at level 50, left associativity).
Notation "A -' B" := (aminus A B)(at level 50, left associativity).
Notation "A *' B" := (amul A B)(at level 48, left associativity).
Notation "A /' B" := (adiv A B)(at level 48, left associativity).
Notation "A %' B" := (amod A B)(at level 45, left associativity).

Check (3 +' 4).

Check (popQ (queue(NatQueue [3 << 4 << 5]))).

Check (topS (stack(BoolStack [true >> false >> true >> true]))).

Check (index (vector (vectorNat listNat [3 ,, 4 ,, 5])) 2).

Check (mFind (mconst (mapEl "Map" { [("S1", 1)] , [("S2" , 2)] })) "maria").

(*BEXP*)

Inductive BExp :=
| berror
| btrue
| bfalse
| bvar: string -> BExp
| ble : AExp -> AExp -> BExp
| bnot : BExp -> BExp
| band : BExp -> BExp -> BExp
| beq : AExp -> AExp -> BExp
| bor : BExp -> BExp -> BExp
| strcmp : CExp -> CExp -> BExp
| strncmp : CExp -> CExp -> AExp -> BExp.

Notation "A <' B" := (ble A B) (at level 70).
Notation "!' A" := (bnot A)(at level 51, left associativity).
Notation "A &&' B" := (band A B)(at level 52, left associativity).
Notation "A ||' B" := (bor A B)(at level 53, left associativity).
Notation "A ==' B" := (beq A B)(at level 53, left associativity).

(*STMT*)

Inductive Stmt :=
  | nDecl: string -> AExp -> Stmt
  | bDecl: string -> BExp -> Stmt
  | vDecl : string -> VExp -> Stmt
  | chDecl : string -> CExp -> Stmt
  | mDecl : string -> MExp -> Stmt
  | sDecl : string -> SExp -> Stmt
  | qDecl : string -> QExp -> Stmt
  | sAssign : string -> SExp -> Stmt
  | qAssign : string -> QExp -> Stmt
  | nAssign : string -> AExp -> Stmt
  | bAssign : string -> BExp -> Stmt
  | chAssign : string -> CExp -> Stmt
  | sequence : Stmt -> Stmt -> Stmt
  | while : BExp -> Stmt -> Stmt
  | break : Stmt
  | continue : Stmt
  | switch :  AExp -> Datatypes.list (AExp * Stmt)  -> Stmt
  | ifthenelse : BExp -> Stmt -> Stmt -> Stmt
  | ifthen : BExp -> Stmt -> Stmt
  | vIndex : Vector -> types -> Stmt
  | qOperation : QExp -> Stmt
  | sOperation : SExp -> Stmt
  | chOperation : CExp -> Stmt
  | aOperation : AExp -> Stmt
  | bOperation : BExp -> Stmt.

Notation "'int' X ::= A" := (nDecl X A)(at level 90).
Notation "X :n= A" := (nAssign X A)(at level 90).
Notation "X :b= A" := (bAssign X A)(at level 90).
(*Notation "X :s= A" := (stringAssign X A)(at level 90). *)
Notation "'vDecl' X ::= A" := (vDecl X A)(at level 90).
Notation "'qDecl' X ::= A" := (qDecl X A)(at level 90).
Notation "'bool' X ::= A" := (bDecl X A)(at level 90).
(*Notation "'strings' X ::= A" := (string_decl X A)(at level 90).*)
Notation "'sDecl' X ::= A" := (sDecl X A)(at level 90).
Notation "'mapp' X ::= A" := (mDecl X A)(at level 90).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 93).

Definition pgm :=
  int "var" ::= 2;;                                                (*declarare variabila de tipul intreg*)
  "var" :n= 3;;                                                    (*schimbare valoare variabila de tipul intreg*)
  vDecl "vector" ::= (vector (vectorNat listNat [3 ,, 4 ,, 5]));;  (*declarare vector*)
  sDecl "stiva" ::= (stack (NatStack [3 >> 4 >> 5]));;             (*declarare stiva*)
  vIndex (vectorNat listNat [3 ,, 4 ,, 5]) 2;;                     (*accesare element din vector*)
  sOperation (pushSNat (stack (NatStack [3 >> 4 >> 5])) 3);;       (*adaugare element pe stiva*)
  qOperation (popQ (queue (BoolQueue [true << true <<false])));;   (*elimare element din coada*)
  aOperation (strstr "aaa" "bbb");;                                (*cautarea unui sir in alt sir, returnand pozitia pe care se gaseste*)
  bOperation (strcmp "aaa" "bbb");;                                (*comparare a doua siruri*)
  chOperation (mapFindCh (mconst (mapEl "Map" { [("S1", 1)] , [("S2" , 2)] })) 1).  (*cauta cheia valorii date ca parametru in map*)


Require Import Category.Lib.
Require Import Category.Theory.Category.

Generalizable All Variables.

(* This is the category of three objects and two arrows, from the first object
   to the other two (as well as the three identity morphisms):

                x
              /   \
           f /     \ g
            /       \
           v         v
          y           z

  This is used to build diagrams that identify spans and pullbacks. *)

Inductive RoofObj : Type := RNeg | RZero | RPos.

Inductive RoofHom : RoofObj → RoofObj → Type :=
  | IdNeg   : RoofHom RNeg  RNeg
  | ZeroNeg : RoofHom RZero RNeg
  | IdZero  : RoofHom RZero RZero
  | ZeroPos : RoofHom RZero RPos
  | IdPos   : RoofHom RPos  RPos.

Definition RoofHom_inv_t : ∀ x y, RoofHom x y → Prop.
Proof.
  intros [] [] f.
  - exact (f = IdNeg).
  - exact False.          (* Unused, any Prop is ok here *)
  - exact False.          (* Unused, any Prop is ok here *)
  - exact (f = ZeroNeg).
  - exact (f = IdZero).
  - exact (f = ZeroPos).
  - exact False.          (* Unused, any Prop is ok here *)
  - exact False.          (* Unused, any Prop is ok here *)
  - exact (f = IdPos).
Defined.

Corollary RoofHom_inv x y f : RoofHom_inv_t x y f.
Proof. destruct f; reflexivity. Qed.

Lemma RNeg_RNeg_id (f : RoofHom RNeg RNeg) : f = IdNeg.
Proof. exact (RoofHom_inv _ _ f). Qed.

Lemma RZero_RPos_id (f : RoofHom RZero RPos) : f = ZeroPos.
Proof. exact (RoofHom_inv _ _ f). Qed.

Lemma RNeg_RZero_absurd : RoofHom RNeg RZero → False.
Proof. inversion 1. Qed.

#[export] Hint Extern 4 => contradiction RNeg_RZero_absurd : roof_laws.

Lemma RPos_RZero_absurd : RoofHom RPos RZero → False.
Proof. inversion 1. Qed.

#[export] Hint Extern 4 => contradiction RPos_RZero_absurd : roof_laws.

Lemma RNeg_RPos_absurd : RoofHom RNeg RPos → False.
Proof. inversion 1. Qed.

#[export] Hint Extern 4 => contradiction RNeg_RPos_absurd : roof_laws.

Lemma RPos_RNeg_absurd : RoofHom RPos RNeg → False.
Proof. inversion 1. Qed.

#[export] Hint Extern 4 => contradiction RPos_RNeg_absurd : roof_laws.

Program Definition Roof : Category := {|
  obj    := RoofObj;
  hom    := RoofHom;
  (* Any hom that typechecks is valid. *)
  homset := fun x y => {| equiv := fun (f g : RoofHom x y) => True |};
  id     := fun x => match x return RoofHom x x with
    | RNeg  => IdNeg
    | RZero => IdZero
    | RPos  => IdPos
    end
|}.
Next Obligation.
  destruct x, y, z;
  try constructor;
  try inversion f;
  try inversion g.
Defined.


Require Import mathcomp.ssreflect.ssreflect.

Structure stuff :=
  Stuff { one : bool; two : nat }.

Lemma stuff_one s b n : s = Stuff b n -> one s = b.
Proof.
by case: s => [b' n']; case =>->.
Qed.


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

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

Print Assumptions carry.


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

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

Print Assumptions sub.


Require Export StlcFix.SpecTyping.
Require Export StlcFix.SpecAnnot.
Require Export StlcFix.SpecEvaluation.

Definition PCtxEquivalent (Γ: Env) (t₁ t₂: Tm) (τ: Ty) : Prop :=
  ∀ C τ',
    ⟪ a⊢ C : Γ , τ → empty, τ' ⟫ →
    (pctx_app t₁ (eraseAnnot_pctx C))⇓ ↔ (pctx_app t₂ (eraseAnnot_pctx C))⇓.
Notation "⟪  Γ ⊢ t₁ ≃ t₂ : τ  ⟫" :=
  (PCtxEquivalent Γ t₁ t₂ τ)
  (at level 0, Γ at level 98, t₁ at level 98, t₂ at level 98, τ at level 98).

Lemma pctx_equiv_symm {Γ t₁ t₂ τ} :
  ⟪ Γ ⊢ t₁ ≃ t₂ : τ ⟫ → ⟪ Γ ⊢ t₂ ≃ t₁ : τ ⟫.
Proof.
  unfold PCtxEquivalent.
  intros equiv C τ' ty; split;
  apply (equiv C τ' ty).
Qed.


(*********************************************************************************

 Colimits in slice bicategory

 Contents:
 1. Initial object
 2. Coproducts

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.Colimits.Coproducts.

Local Open Scope cat.

(**
 1. Initial object
 *)
Section InitialSlice.
  Context {B : bicat}
          (I : biinitial_obj B)
          (b : B).

  Let κ : slice_bicat b
    := pr1 I ,, is_biinitial_1cell_property (pr2 I) b.

  Definition biinitial_1cell_property_slice
    : biinitial_1cell_property κ.
  Proof.
    intros f.
    refine (is_biinitial_1cell_property (pr2 I) _ ,, _) ; cbn.
    apply (is_biinitial_invertible_2cell_property (pr2 I)).
  Defined.

  Definition biinitial_2cell_property_slice
             (f : slice_bicat b)
    : biinitial_2cell_property κ f.
  Proof.
    intros g₁ g₂.
    simple refine (_ ,, _).
    - apply (is_biinitial_2cell_property (pr2 I)).
    - apply (is_biinitial_eq_property (pr2 I)).
  Defined.

  Definition biinitial_eq_property_slice
             (f : slice_bicat b)
    : biinitial_eq_property κ f.
  Proof.
    intros g₁ g₂ α β.
    use subtypePath.
    {
      intro.
      apply cellset_property.
    }
    apply (is_biinitial_eq_property (pr2 I)).
  Qed.

  Definition is_biinitial_slice
    : is_biinitial κ.
  Proof.
    refine (_ ,, _).
    - exact biinitial_1cell_property_slice.
    - intro f.
      split.
      + exact (biinitial_2cell_property_slice f).
      + exact (biinitial_eq_property_slice f).
  Defined.

  Definition biinitial_in_slice
    : biinitial_obj (slice_bicat b)
    := κ ,, is_biinitial_slice.
End InitialSlice.

(**
 2. Coproducts
 *)
Section CoproductSlice.
  Context {B : bicat}
          (b : B)
          {x₁ x₂ : B}
          (h₁ : x₁ --> b)
          (h₂ : x₂ --> b)
          (sum : B)
          (ι₁ : x₁ --> sum)
          (ι₂ : x₂ --> sum)
          (sum_cone := make_bincoprod_cocone sum ι₁ ι₂)
          (ump : has_bincoprod_ump sum_cone).

  Let hh₁ : slice_bicat b := make_ob_slice h₁.
  Let hh₂ : slice_bicat b := make_ob_slice h₂.

  Definition sum_slice : slice_bicat b
    := make_ob_slice (bincoprod_ump_1cell ump h₁ h₂).

  Definition inl_slice : hh₁ --> sum_slice.
  Proof.
    simple refine (make_1cell_slice _ _).
    - exact ι₁.
    - exact (inv_of_invertible_2cell (bincoprod_ump_1cell_inl ump _ h₁ h₂)).
  Defined.

  Definition inr_slice : hh₂ --> sum_slice.
  Proof.
    simple refine (make_1cell_slice _ _).
    - exact ι₂.
    - exact (inv_of_invertible_2cell (bincoprod_ump_1cell_inr ump _ h₁ h₂)).
  Defined.

  Definition slice_coprod_cone
    : bincoprod_cocone hh₁ hh₂.
  Proof.
    use make_bincoprod_cocone.
    - exact sum_slice.
    - exact inl_slice.
    - exact inr_slice.
  Defined.

  Section UMP1.
    Context (q : bincoprod_cocone hh₁ hh₂).

    Definition slice_coprod_ump_1_map_mor
      : sum --> pr11 q.
    Proof.
      use (bincoprod_ump_1cell ump).
      - exact (pr1 (bincoprod_cocone_inl q)).
      - exact (pr1 (bincoprod_cocone_inr q)).
    Defined.

    Definition slice_coprod_ump_1_map_inv2cell
      : invertible_2cell
          (bincoprod_ump_1cell ump h₁ h₂)
          (slice_coprod_ump_1_map_mor · pr21 q).
    Proof.
      use make_invertible_2cell.
      - use (bincoprod_ump_2cell ump).
        + exact (bincoprod_ump_1cell_inl _ _ _ _
                 • pr1 (pr2 (bincoprod_cocone_inl q))
                 • ((bincoprod_ump_1cell_inl _ _ _ _)^-1 ▹ _)
                 • rassociator _ _ _).
        + exact (bincoprod_ump_1cell_inr _ _ _ _
                 • pr1 (pr2 (bincoprod_cocone_inr q))
                 • ((bincoprod_ump_1cell_inr _ _ _ _)^-1 ▹ _)
                 • rassociator _ _ _).
      - use bincoprod_ump_2cell_invertible.
        + is_iso ; apply property_from_invertible_2cell.
        + is_iso ; apply property_from_invertible_2cell.
    Defined.

    Definition slice_coprod_ump_1_map
      : slice_coprod_cone --> q.
    Proof.
      use make_1cell_slice ; cbn.
      - exact slice_coprod_ump_1_map_mor.
      - exact slice_coprod_ump_1_map_inv2cell.
    Defined.

    Definition slice_coprod_ump_1_map_inl_cell
      : ι₁ · slice_coprod_ump_1_map_mor
        ==>
        pr1 (bincoprod_cocone_inl q)
      := bincoprod_ump_1cell_inl
           ump
           _
           (pr1 (bincoprod_cocone_inl q))
           (pr1 (bincoprod_cocone_inr q)).

    Definition slice_coprod_ump_1_map_inl_eq
      : cell_slice_homot
          (bincoprod_cocone_inl slice_coprod_cone · slice_coprod_ump_1_map)
          (bincoprod_cocone_inl q)
          slice_coprod_ump_1_map_inl_cell.
    Proof.
      unfold cell_slice_homot.
      cbn.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        apply maponpaths_2.
        apply (bincoprod_ump_2cell_inl ump).
      }
      rewrite !vassocr.
      rewrite vcomp_linv, id2_left.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        apply id2_left.
      }
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      apply id2_right.
    Qed.

    Definition slice_coprod_ump_1_map_inl
      : invertible_2cell
          (bincoprod_cocone_inl slice_coprod_cone · slice_coprod_ump_1_map)
          (bincoprod_cocone_inl q).
    Proof.
      use make_invertible_2cell.
      - use make_2cell_slice.
        + exact slice_coprod_ump_1_map_inl_cell.
        + exact slice_coprod_ump_1_map_inl_eq.
      - use is_invertible_2cell_in_slice_bicat.
        apply property_from_invertible_2cell.
    Defined.

    Definition slice_coprod_ump_1_map_inr_cell
      : ι₂ · slice_coprod_ump_1_map_mor
        ==>
        pr1 (bincoprod_cocone_inr q)
      := bincoprod_ump_1cell_inr
           ump
           _
           (pr1 (bincoprod_cocone_inl q))
           (pr1 (bincoprod_cocone_inr q)).

    Definition slice_coprod_ump_1_map_inr_eq
      : cell_slice_homot
          (bincoprod_cocone_inr slice_coprod_cone · slice_coprod_ump_1_map)
          (bincoprod_cocone_inr q)
          slice_coprod_ump_1_map_inr_cell.
    Proof.
      unfold cell_slice_homot.
      cbn.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        apply maponpaths_2.
        apply (bincoprod_ump_2cell_inr ump).
      }
      rewrite !vassocr.
      rewrite vcomp_linv, id2_left.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        apply id2_left.
      }
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      apply id2_right.
    Qed.

    Definition slice_coprod_ump_1_map_inr
      : invertible_2cell
          (bincoprod_cocone_inr slice_coprod_cone · slice_coprod_ump_1_map)
          (bincoprod_cocone_inr q).
    Proof.
      use make_invertible_2cell.
      - use make_2cell_slice.
        + exact slice_coprod_ump_1_map_inr_cell.
        + exact slice_coprod_ump_1_map_inr_eq.
      - use is_invertible_2cell_in_slice_bicat.
        apply property_from_invertible_2cell.
    Defined.
  End UMP1.

  Definition slice_coprod_ump_1
    : bincoprod_ump_1 slice_coprod_cone.
  Proof.
    intros q.
    use make_bincoprod_1cell.
    - exact (slice_coprod_ump_1_map q).
    - exact (slice_coprod_ump_1_map_inl q).
    - exact (slice_coprod_ump_1_map_inr q).
  Defined.

  Definition slice_coprod_ump_unique
             {q : slice_bicat b}
             {φ ψ : slice_coprod_cone --> q}
             (α : bincoprod_cocone_inl slice_coprod_cone · φ
                  ==>
                  bincoprod_cocone_inl slice_coprod_cone · ψ)
             (β : bincoprod_cocone_inr slice_coprod_cone · φ
                  ==>
                  bincoprod_cocone_inr slice_coprod_cone · ψ)
    : isaprop
        (∑ (γ : φ ==> ψ),
         bincoprod_cocone_inl slice_coprod_cone ◃ γ = α
         ×
         bincoprod_cocone_inr slice_coprod_cone ◃ γ = β).
  Proof.
    use invproofirrelevance.
    intros γ₁ γ₂.
    use subtypePath.
    {
      intro.
      apply isapropdirprod ; apply cellset_property.
    }
    use eq_2cell_slice.
    use (bincoprod_ump_2cell_unique_alt ump).
    - exact (maponpaths pr1 (pr12 γ₁) @ !(maponpaths pr1 (pr12 γ₂))).
    - exact (maponpaths pr1 (pr22 γ₁) @ !(maponpaths pr1 (pr22 γ₂))).
  Qed.

  Definition slice_coprod_ump_2
    : bincoprod_ump_2 slice_coprod_cone.
  Proof.
    intros q φ ψ α β.
    use iscontraprop1.
    - exact (slice_coprod_ump_unique α β).
    - simple refine ((_ ,, _) ,, _ ,, _).
      + exact (bincoprod_ump_2cell ump (pr1 α) (pr1 β)).
      + cbn.
        use (bincoprod_ump_2cell_unique_alt ump).
        * abstract
            (rewrite <- lwhisker_vcomp ;
             use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ;
             rewrite !vassocl ;
             rewrite rwhisker_lwhisker ;
             rewrite bincoprod_ump_2cell_inl ;
             use (vcomp_lcancel ((bincoprod_ump_1cell_inl ump b h₁ h₂) ^-1)) ; [ is_iso | ] ;
             rewrite !vassocr ;
             pose (pr2 α) as p ;
             cbn in p ;
             rewrite !vassocr in p ;
             exact p).
        * abstract
            (rewrite <- lwhisker_vcomp ;
             use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ;
             rewrite !vassocl ;
             rewrite rwhisker_lwhisker ;
             rewrite bincoprod_ump_2cell_inr ;
             use (vcomp_lcancel ((bincoprod_ump_1cell_inr ump b h₁ h₂) ^-1)) ; [ is_iso | ] ;
             rewrite !vassocr ;
             pose (pr2 β) as p ;
             cbn in p ;
             rewrite !vassocr in p ;
             exact p).
      + abstract
          (use eq_2cell_slice ; cbn ;
           apply (bincoprod_ump_2cell_inl ump)).
      + abstract
          (use eq_2cell_slice ; cbn ;
           apply (bincoprod_ump_2cell_inr ump)).
  Defined.
End CoproductSlice.

Definition has_bincoprod_slice_bicat
           {B : bicat}
           (HB : has_bincoprod B)
           (b : B)
  : has_bincoprod (slice_bicat b).
Proof.
  intros h₁ h₂.
  pose (sum := HB (pr1 h₁) (pr1 h₂)).
  refine (slice_coprod_cone b (pr2 h₁) (pr2 h₂) _ _ _ (pr2 sum) ,, _).
  split.
  - apply (slice_coprod_ump_1 b (pr2 h₁) (pr2 h₂)).
  - apply (slice_coprod_ump_2 b (pr2 h₁) (pr2 h₂)).
Defined.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Language LibTactics.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import SubAndTopLike.
Require Import Psatz. (* lia *)

Ltac ind_typ_size s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with
         | [ h : typ |- _ ] => (gen h)
         end;
  induction i as [|i IH]; [
      intros; match goal with
              | [ H : _ < 0 |- _ ] => (dependent destruction H)
              end
    | intros ].

Lemma split_decrease_size:
  forall A B C,
    splitable A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A.
Proof.
  introv H. dependent induction H; simpl; lia.
Qed.

Theorem disjoint_complete :
  forall A B, disjoint A B -> disjoint_spec A B.
Proof.
  intros A B Hdisj C Hsub1 Hsub2.
  ind_typ_size (size_typ A + size_typ B + size_typ C).
  destruct (split_or_ord C).
  - dependent destruction Hdisj; try solve [eapply sub_toplike_preservation; eauto 3].
    + dependent destruction Hsub1.
      * eapply sub_toplike_preservation; eauto.
      * exfalso. eapply split_and_ord; eauto.
      * simpl in SizeInd.
        assert ((size_typ A1 + size_typ B + size_typ C) < i) by lia.
        now pose proof (IH _ _ Hdisj1 _ Hsub1 Hsub2 H1).
      * simpl in SizeInd.
        assert ((size_typ A2 + size_typ B + size_typ C) < i) by lia.
        now pose proof (IH _ _ Hdisj2 _ Hsub1 Hsub2 H1).
    + dependent destruction Hsub2.
      * eapply sub_toplike_preservation; eauto.
      * exfalso. eapply split_and_ord; eauto.
      * simpl in SizeInd.
        assert ((size_typ A + size_typ B1 + size_typ C) < i) by lia.
        now pose proof (IH _ _ Hdisj1 _ Hsub1 Hsub2 H1).
      * simpl in SizeInd.
        assert ((size_typ A + size_typ B2 + size_typ C) < i) by lia.
        now pose proof (IH _ _ Hdisj2 _ Hsub1 Hsub2 H1).
    + dependent destruction Hsub1; dependent destruction Hsub2; eauto 3.
      * inversion H.
      * dependent destruction H.
        exfalso. eapply split_and_ord; eauto.
      * exfalso. eapply split_and_ord; eauto.
    + dependent destruction Hsub1; dependent destruction Hsub2; eauto 3.
      * exfalso. eapply split_and_ord; eauto.
      * inversion H.
      * exfalso. eapply split_and_ord; eauto.
    + dependent destruction Hsub1; dependent destruction Hsub2; eauto 3.
      * constructor. eapply IH.
        eapply Hdisj. eapply Hsub1_2. eapply Hsub2_2.
        simpl in SizeInd. lia.
      * exfalso. eapply split_and_ord; eauto.
      * exfalso. eapply split_and_ord; eauto.
      * exfalso. eapply split_and_ord; eauto.
  - destruct_conjs.
    dependent destruction Hsub1; dependent destruction Hsub2;
      try solve [exfalso; eapply split_and_ord; eauto].
    eapply split_determinism in H0; eauto 3. destruct_conjs. subst.
    eapply split_determinism in H; eauto 3. destruct_conjs. subst.
    pose proof (split_decrease_size _ _ _ H3).
    destruct_conjs.
    eapply toplike_spl_combine; eauto 3.
    + eapply IH; eauto 3. lia.
    + eapply IH; eauto 3. lia.
Qed.

Lemma disjoint_symmetry:
  forall (A B : typ),
    disjoint A B -> disjoint B A.
Proof.
  introv H.
  dependent induction H; eauto.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Max.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.FOL.TRAKHTENBROT
  Require Import notations utils enumerable
                 fol_ops fo_sig fo_terms fo_logic fo_enum decidable
                 fo_sat fo_sat_dec red_utils.

Set Implicit Arguments.

(* * Collection of high-level enumerability results *)

Section FSAT_enumerable.

  Variable (Σ : fo_signature).

  Implicit Type (A : fol_form Σ).

  Theorem FSAT_FSAT_in_pos A : FSAT Σ A <-> exists n, fo_form_fin_dec_SAT_in A (pos n).
  Proof.
    rewrite fo_form_fin_dec_SAT_discr_equiv.
    apply fo_form_fin_discr_dec_SAT_pos.
  Qed.

  Hypothesis (H1 : discrete (syms Σ))
             (H2 : discrete (rels Σ)).

  Let dec n A : decidable (fo_form_fin_dec_SAT_in A (pos n)).
  Proof. apply FSAT_in_dec; auto; apply finite_t_pos. Qed.

  Theorem FSAT_rec_enum_t : rec_enum_t (FSAT Σ).
  Proof using H2 H1.
    exists (fun n A => if dec n A then true else false).
    intros A.
    rewrite FSAT_FSAT_in_pos.
    apply exists_equiv; intros n.
    destruct (dec n A); split; auto; discriminate.
  Qed.

  Hypothesis (H3 : type_enum_t (syms Σ)).
  Hypothesis (H4 : type_enum_t (rels Σ)).

  Theorem FSAT_opt_enum_t : opt_enum_t (FSAT Σ).
  Proof using H4 H3 H2 H1.
    generalize FSAT_rec_enum_t.
    apply rec_enum_opt_enum_type_enum_t.
    apply type_enum_t_fol_form; auto.
  Qed.

End FSAT_enumerable.


Require Import RelationClasses.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Structures.Reducible.

Set Implicit Arguments.
Set Strict Implicit.

(** First-class maps **)
Section Maps.
  Variables K V : Type.
  Variable map : Type.

  (** General Maps **)
  Class Map : Type :=
  { empty    : map
  ; add      : K -> V -> map -> map
  ; remove   : K -> map -> map
  ; lookup   : K -> map -> option V
  ; union    : map -> map -> map
  }.

  Variable R : K -> K -> Prop.

  Class MapOk (M : Map) : Type :=
  { mapsto : K -> V -> map -> Prop
  ; mapsto_empty : forall k v, ~mapsto k v empty
  ; mapsto_lookup : forall k v m, lookup k m = Some v <-> mapsto k v m
  ; mapsto_add_eq : forall m k v, mapsto k v (add k v m)
  ; mapsto_add_neq : forall m k v k',
                       ~R k k' ->
                       forall v', (mapsto k' v' m <-> mapsto k' v' (add k v m))
  ; mapsto_remove_eq: forall m k v, ~ mapsto k v (remove k m)
  ; mapsto_remove_neq : forall m k k',
          ~ R k k' ->
          forall v', (mapsto k' v' m <-> mapsto k' v' (remove k m))
  }.

  Variable M : Map.

  Definition contains (k : K) (m : map) : bool :=
    match lookup k m with
      | None => false
      | Some _ => true
    end.

  Definition singleton (k : K) (v : V) : map :=
    add k v empty.

  (* Finite Maps *)
  Context {F : Foldable map (K * V)}.

  Definition combine (f : K -> V -> V -> V) (m1 m2 : map) : map :=
    fold (fun k_v acc =>
      let '(k,v) := k_v in
      match lookup k acc with
        | None => add k v acc
        | Some v' => add k (f k v v') acc
      end) m2 m1.

  Definition filter (f : K -> V -> bool) (m : map) : map :=
    fold (fun k_v acc =>
      let '(k,v) := k_v in
      if f k v
        then add k v acc
        else acc) empty m.

  Definition submap_with (le : V -> V -> bool) (m1 m2 : map) : bool :=
    fold (fun k_v (acc : bool) =>
      if acc then
        let '(k,v) := k_v in
        match lookup k m2 with
          | None => false
          | Some v' => le v v'
        end
      else false) true m1.

(*
  Definition keys (s : Type) (_ : DMonad s K) : map T -> s :=
    fold (fun k_v (acc : s) =>
      djoin (dreturn (fst k_v)) acc) dzero.

  Definition values (s : Type) (_ : DMonad s T) : map T -> s :=
    fold (fun k_v (acc : s) =>
      djoin (dreturn (snd k_v)) acc) dzero.
*)

End Maps.

Arguments empty {_} {_} {_} {_} .
Arguments add {K V} {map} {Map} _ _ _.
Arguments remove {K V} {map} {Map} _ _.
Arguments lookup {K V} {map} {Map} _ _.
Arguments contains {K V} {map} {M} _ _.
Arguments singleton {K V} {map} {M} _ _.
Arguments combine {K V} {map} {M} _ _ _ _.


Require Import Recdef.
Require sf_spec.
Require Import sf_tactic.
Require Import RelDec.
Require Import List.
Require Import Sorted.
Require Import Permutation.
Require Import FunctionalExtensionality.
Require Import Classical.
Import ListNotations.

Section cand.

Variable candidate : Set.
Variable reldec_candidate : RelDec (@eq candidate).
Variable reldec_correct_candidate : RelDec_Correct reldec_candidate.

Ltac solve_rcv := sf_tactic.solve_rcv reldec_correct_candidate.
Ltac intuition_nosplit := sf_tactic.intuition_nosplit reldec_correct_candidate.

Lemma next_ranking_cons_or :
forall b1 bal e x,
sf_spec.next_ranking candidate e (b1 :: bal) x ->
sf_spec.next_ranking candidate e [b1] x \/
sf_spec.next_ranking candidate e bal x.
intros. inv H; solve_rcv. left.
destruct H4; solve_rcv. eapply sf_spec.next_ranking_valid; solve_rcv.
left. eauto. eapply sf_spec.next_ranking_valid; solve_rcv.
Qed.

Lemma next_ranking_in :
forall e bal x,
  sf_spec.next_ranking candidate e bal x ->
  In x bal.
Proof.
induction bal; solve_rcv.
inv H; solve_rcv.
Qed.

Lemma no_viable_candidates_cons :
forall a b e,
sf_spec.no_viable_candidates candidate (e) (a ::  b) <->
(sf_spec.no_viable_candidates candidate e [a] /\
sf_spec.no_viable_candidates candidate e b).
split.
intros.
unfold sf_spec.no_viable_candidates in *.
split.
intros. eapply H; eauto. inv H0; simpl in *; intuition.
intros. eapply H; eauto. simpl. intuition.
intros. intuition.
unfold sf_spec.no_viable_candidates in *. simpl in *.
intuition. eapply H0; eauto.
eapply H1; eauto.
Qed.

Lemma first_choices_app :
forall c l1 l2 x1 x2  r cnd,
sf_spec.first_choices c r cnd l1 x1 ->
sf_spec.first_choices c r cnd l2 x2 ->
sf_spec.first_choices c r cnd (l1 ++ l2) (x1 + x2).
Proof.
induction l1; intros.
- simpl in *. inv H. simpl. auto.
- simpl in *.
  inv H.
  + apply sf_spec.first_choices_selected. auto. fold plus.
    apply IHl1; auto.
  + apply sf_spec.first_choices_not_selected; auto.
Qed.

Lemma first_choices_app_gt :
forall c l1 l2 x1 x2 r cnd,
sf_spec.first_choices c r cnd l1 x1 ->
sf_spec.first_choices c r cnd (l1 ++ l2) (x2) ->
x2 >= x1.
Proof.
induction l1; intros.
- simpl in *. inv H. omega.
- simpl in *. inv H; inv H0; try congruence; try omega.
  eapply IHl1 in H5; eauto. omega.
  eapply IHl1; eauto.
Qed.

Lemma first_choices_perm :
forall c l1 l2 x r cnd,
Permutation l1 l2 ->
sf_spec.first_choices c r cnd l1 x ->
sf_spec.first_choices c r cnd l2 x.
Proof.
induction l1; intros.
- apply Permutation_nil in H. subst. auto.
- assert (exists l2s l23, l2 = l2s ++ (a :: l23)).
  { eapply Permutation_in in H. instantiate (1 := a) in H.
    apply List.in_split in H. auto.
    constructor; auto. }
  destruct H1. destruct H1.
  subst.
  apply Permutation_cons_app_inv in H.
  inv H0.
  + eapply (IHl1 _ n' r cnd) in H; auto.
    clear - H H3.
    { generalize dependent x1. generalize dependent n'.
      induction x0; intros.
      - simpl in *. constructor; auto.
      - simpl in *. inv H.
        + constructor; auto.
        + apply sf_spec.first_choices_not_selected; auto.
    }
  + eapply IHl1 in H; eauto.
    { clear - H H3.
      generalize dependent x1. generalize dependent x.
      induction x0; intros.
      - simpl in *. apply sf_spec.first_choices_not_selected; auto.
      - simpl in *. inv H.
        + constructor; auto.
        + apply sf_spec.first_choices_not_selected; auto.
    }
Qed.

Lemma selected_participates : forall election (c : candidate) bal  r,
sf_spec.selected_candidate _ r bal c ->
In bal election ->
sf_spec.participates _ c election.
Proof.
induction election; intros.
inv H0.
destruct H0. subst.
unfold sf_spec.participates.
unfold sf_spec.selected_candidate in H.
destruct H. destruct H0.
exists bal. split; eauto.
simpl. auto.
exists x. intuition.
apply next_ranking_in in H1. auto.
eapply IHelection in H0.
unfold sf_spec.participates in H0.
unfold sf_spec.participates.
simpl in *.
destruct H0.
exists x. split; auto. intuition.
destruct H0.
apply H1.
eauto.
Qed.

Lemma participates_cons : forall e a (c : candidate) ,
        sf_spec.participates _ c [a] \/ sf_spec.participates _ c e <->
        sf_spec.participates _ c (a :: e).
Proof.
split.
- intros.
  destruct H.
  + unfold sf_spec.participates in *.
    destruct H. destruct H. destruct H0. destruct H0.
    exists a. simpl in *. intuition.
    subst. exists x0. auto.
  + unfold sf_spec.participates in *.
    destruct  H. intuition. destruct H1. exists x; intuition.
    exists x0; intuition.
- intros. destruct H.
  destruct H. destruct H0.
  destruct H.
  +  unfold sf_spec.participates.
     subst. left. exists x. intuition.
     exists x0; auto.
  +  right. unfold sf_spec.participates.
     exists x. intuition.
     exists x0; auto.
Qed.

Lemma total_selected_unique : forall r e v v',
sf_spec.total_selected candidate r e v ->
sf_spec.total_selected candidate r e v' ->
v= v'.
Admitted.

Lemma majority_not_0 :
forall r e x ,
sf_spec.majority candidate r e x ->
exists v, sf_spec.first_choices _ r x e v /\ v <> 0.
Proof.
intros.
unfold sf_spec.majority in *.
edestruct (sf_spec.sf_first_choices_total _ r e x).
edestruct (sf_spec.total_selected_total _ r e).
exists x0. intuition.
subst.
eapply H in H0; eauto.
omega.
Qed.

Lemma update_eliminated_in_rec : forall rec loser c,
sf_spec.update_eliminated candidate (in_record rec) loser c <->
in_record ([loser] :: rec) c.
Proof.
split; intros.
{ induction rec.
  - unfold sf_spec.update_eliminated in H.
    intuition. inv H0. destruct H. inv H.
    subst. unfold in_record. exists [c]. intuition; auto.
  - unfold sf_spec.update_eliminated in  *. intuition.
    unfold in_record in H0. destruct H0. intuition.
    simpl in H2. destruct H2.
    + subst. unfold in_record. exists x.
      intuition.
    + unfold in_record. exists x. intuition.
    + unfold in_record in H2. destruct H2.
      intuition. simpl in H2. destruct H2.
      * subst. unfold in_record. exists [c].
        intuition.
      * exists x. intuition. }
{ unfold in_record in H. destruct H. intuition. simpl in H0.
  destruct H0. subst. unfold sf_spec.update_eliminated.
  right. inv H1; auto. inv H.
  left. unfold in_record. eauto. }
Qed.

Axiom prop_ext : forall (P Q : Prop),
  (P <-> Q) -> P = Q.

Lemma update_eliminated_in_rec_eq : forall rec loser c,
sf_spec.update_eliminated candidate (in_record rec) loser c =
in_record ([loser] :: rec) c.
Proof. intros.
apply prop_ext. apply update_eliminated_in_rec.
Qed.

Lemma update_eliminated_in_rec_eq_noc : forall rec loser,
sf_spec.update_eliminated candidate (in_record rec) loser =
in_record ([loser] :: rec).
intros. extensionality c. apply update_eliminated_in_rec_eq.
Qed.

Definition continuing2 b rec:=
exists r, sf_spec.next_ranking candidate rec b r /\ ~sf_spec.overvote candidate r.

Lemma continuing2_continuing :
forall b rec,
continuing2 b rec <-> sf_spec.continuing_ballot candidate rec b.
Proof.
intros.
split.
intros.
unfold continuing2 in *.
solve_rcv.
destruct H1. apply H1. exists x. auto.
destruct H1. solve_rcv.
eapply sf_spec.next_ranking_unique in H; eauto. subst.
apply H0; eauto.
intros.
unfold continuing2.
solve_rcv.

apply Classical_Prop.not_or_and in H.
destruct H. apply Classical_Prop.NNPP in H.
destruct H. exists x.
split. auto.
intro. apply H0. exists x. auto.
Qed.

Lemma continuing_ballot_cons :
forall r h t,
sf_spec.continuing_ballot candidate r (h :: t) ->
sf_spec.continuing_ballot candidate r [h] \/ ((~sf_spec.overvote candidate h) /\ sf_spec.continuing_ballot candidate r t).
Proof.
intros. repeat rewrite <- continuing2_continuing in *.
induction t.
- auto.
- unfold continuing2 in *.
  destruct H. destruct H.
  inv H.
  + right. intuition. exists x. auto.
  + destruct H5.
    *  intuition.
    * left. exists x.
      intuition. eapply sf_spec.next_ranking_valid.
      apply H3. auto.
Qed.

Lemma continuing_ballot_cons2 :
forall r a b,
sf_spec.continuing_ballot candidate r [a] ->
sf_spec.continuing_ballot candidate r (a :: b).
Proof.
intros. rewrite <- continuing2_continuing in *.
unfold continuing2 in *. destruct H.
exists x.
destruct H. intuition.
clear H0.
inv H. inv H5. eapply sf_spec.next_ranking_valid; eauto.
Qed.

Lemma continuing_ballot_cons3 :
forall t h r
(OV : ~sf_spec.overvote candidate h),
sf_spec.continuing_ballot candidate r t ->
sf_spec.continuing_ballot candidate r (h :: t).
Proof.
intros. rewrite <- continuing2_continuing in *.
unfold continuing2 in *.
destruct H. destruct H.
destruct (classic (Forall r h)).
exists x. intuition.
constructor; eauto.
destruct h. exfalso. solve_rcv. apply H1. solve_rcv.
exists (c::h). intuition.
eapply sf_spec.next_ranking_valid. simpl. eauto.
right. solve_rcv. apply H1. intros. destruct H3. subst. auto.
destruct (rel_dec_p c x0).
subst. auto.
exfalso. apply OV. exists c. exists x0.
simpl. auto.
Qed.

Lemma continuing_ballot_rec_cons :
forall l r b,
  sf_spec.continuing_ballot candidate (in_record ([l] :: r)) (b) ->
   sf_spec.continuing_ballot candidate (in_record r) (b).
Proof.
  intros. induction b.
  - unfold sf_spec.continuing_ballot in *.
    intro. apply H. clear H.
    unfold sf_spec.exhausted_ballot. left. intro.
    inv H. inv H1.
  - apply continuing_ballot_cons in H.
    destruct H.
    apply continuing_ballot_cons2.
    rewrite <- continuing2_continuing in *.
    unfold continuing2.
    unfold continuing2 in H.
    destruct H. exists x.
    destruct H. intuition.
    inv H. constructor; solve_rcv.
    destruct H5. intuition.
    eapply sf_spec.next_ranking_valid; eauto.
    right. intro. apply H; clear H.
    unfold in_record in *. solve_rcv.
    intuition.
    apply continuing_ballot_cons3; auto.
Qed.

Lemma next_ranking_cons_or2 :
forall b1 bal e x,
sf_spec.next_ranking candidate e (b1 :: bal) x ->
sf_spec.next_ranking candidate e [b1] x \/
(Forall e b1 /\ sf_spec.next_ranking candidate e bal x).
intros. inv H; solve_rcv. left.
destruct H4; solve_rcv. eapply sf_spec.next_ranking_valid; solve_rcv.
left. eauto. eapply sf_spec.next_ranking_valid; solve_rcv.
Qed.

Lemma continuing_ballot_cons4 : (*should be main lemma, don't want to rework proofs :( *)
forall r h t,
sf_spec.continuing_ballot candidate r (h :: t) ->
sf_spec.continuing_ballot candidate r [h] \/ ((~sf_spec.overvote candidate h) /\ sf_spec.continuing_ballot candidate r t /\ Forall r h).
Proof.
intros. repeat rewrite <- continuing2_continuing in *.
induction t.
- auto.
- unfold continuing2 in *.
  destruct H. destruct H.
  inv H.
  + right. intuition. exists x. auto.
  + destruct H5.
    *  intuition.
    * left. exists x.
      intuition. eapply sf_spec.next_ranking_valid.
      apply H3. auto.
Qed.

Lemma selected_cons :
forall r a b c,
sf_spec.selected_candidate candidate  r (a :: b) c ->
sf_spec.selected_candidate candidate r [a] c \/
(Forall r a /\ ~sf_spec.overvote candidate a /\sf_spec.selected_candidate candidate r b c).
Proof.
intros.
unfold sf_spec.selected_candidate in H.
intuition_nosplit. apply continuing_ballot_cons4 in H.
apply next_ranking_cons_or2 in H0.
destruct H, H0.
left. unfold sf_spec.selected_candidate. intuition.
eauto.
rewrite <- continuing2_continuing in H.
unfold continuing2 in H. destruct H. destruct H.
inv H. inv H8. rewrite Forall_forall in H0. firstorder.
destruct H. destruct H2. inv H0. inv H9. rewrite Forall_forall in *.
firstorder.
right. unfold sf_spec.selected_candidate. intuition.
eauto.
Qed.

Lemma first_choices_0_cons :
forall r c h t,
sf_spec.first_choices candidate r c (h :: t) 0 <->
sf_spec.first_choices candidate r c [h] 0 /\
sf_spec.first_choices candidate r c t 0.
Proof.
split.
- intros.
  induction t. intuition. constructor.
  inv H. intuition.
  inv H4.
  apply IHt.
  constructor. auto. auto.
- intros. destruct H.
  inv H. constructor; auto.
Qed.

Lemma next_ranking_record_same :
forall b x c l r,
  In c x ->
  c <> l ->
  sf_spec.next_ranking candidate (in_record r) b x ->
  ~ sf_spec.overvote candidate x ->
  sf_spec.next_ranking candidate (in_record ([l] :: r)) b x.
Proof.
induction b; intros.
inv H1.
inv H1.
- constructor. solve_rcv. specialize (H5 x0); solve_rcv.
  auto.
  eapply IHb; eauto.
- intuition.
  eapply sf_spec.next_ranking_valid.
  apply H5. right. intro.
  apply H1. solve_rcv. simpl in H3. destruct H3; solve_rcv.
  assert (c0 = l). inv H4. subst; intuition. inv H3. subst. clear H4.
  exfalso. apply H2. exists c. exists l. eauto.
Qed.

Lemma ne_still_continuing :
forall b c l  x r,
sf_spec.next_ranking candidate (in_record r) b x ->
sf_spec.continuing_ballot candidate (in_record r) b ->
In c x ->
c <> l ->
sf_spec.continuing_ballot candidate (in_record ([l] :: r)) b.
Proof.
intros. repeat rewrite <- continuing2_continuing in *.
unfold continuing2 in *. intuition_nosplit.
exists x0. split; eauto.
eapply sf_spec.next_ranking_unique in H; eauto. subst.
eapply next_ranking_record_same; eauto.
Qed.

Lemma selected_rec_cons :
forall r b c l,
c <> l ->
sf_spec.selected_candidate candidate (in_record r) b c ->
sf_spec.selected_candidate candidate (in_record ([l]::r)) b c.
intros.
induction b. solve_rcv.
apply selected_cons in H0.
destruct H0.
- clear IHb.
  unfold sf_spec.selected_candidate in *.
  intuition_nosplit.
  split.
  + apply continuing_ballot_cons2.
  eapply ne_still_continuing; eauto.
  + inv H1. inv H8.
    destruct H7. exists x. intuition.
    eapply sf_spec.next_ranking_valid; eauto.
    exists x. intuition. eapply sf_spec.next_ranking_valid; eauto.
    right. intro. apply H1. rewrite <- continuing2_continuing in *.
    unfold continuing2 in *. unfold in_record in *. intuition_nosplit.
    simpl in *. destruct H3; subst; try solve [solve_rcv].
    inv H4; intuition_nosplit. inv H0. inv H10. intuition.
    exfalso. apply H6. solve_rcv.
- intuition. clear H3.
  unfold sf_spec.selected_candidate in *.
  intuition_nosplit. split.
  rewrite <- continuing2_continuing. unfold continuing2. exists x.
  intuition. constructor; auto. rewrite Forall_forall in *.
  intro. specialize (H1 x0). intro. intuition.
  solve_rcv.  rewrite <-  continuing2_continuing in *.
  unfold continuing2 in *. intuition_nosplit.
  eapply sf_spec.next_ranking_unique in H2; eauto. subst.
  auto.
  exists x. intuition.
  constructor; auto.
  rewrite Forall_forall in *. intros. specialize (H1 x0).
  solve_rcv.
Qed.

Lemma first_choices_rec_0 :
forall c l r e,
  sf_spec.first_choices candidate (in_record ([l] :: r)) c e 0 ->
  c <> l ->
  sf_spec.first_choices candidate (in_record r) c e 0.
Proof.
intros.
induction e.
- constructor.
- apply first_choices_0_cons in H. destruct H. intuition.
  apply first_choices_0_cons. intuition.
  inv H.
  constructor. intro. apply H5. clear H5.
  apply selected_rec_cons; auto. constructor.
Qed.

Lemma first_choices_0_loser :
forall c election l,
~in_record l c ->
sf_spec.participates _ c election ->
sf_spec.first_choices candidate (in_record l) c election 0 ->
sf_spec.is_loser _ (in_record l) election c.
Proof.
intros. unfold sf_spec.is_loser in *.
split.
- unfold sf_spec.viable_candidate.
  split.
  + unfold in_record. intuition_nosplit. apply H. unfold in_record. eauto.
  + auto.
- intros. eapply sf_spec.sf_first_choices_unique in H1; eauto. subst. omega.
Qed.

Lemma in_record_nil_nil (c: candidate) :
forall l, in_record l c <-> in_record ([] :: l) c.
split; intros; unfold in_record in *;
intuition_nosplit. exists x. simpl. intuition.
inv H. inv H0. exists x; simpl; auto.
Qed.

Lemma in_record_nil_nil_eq :
forall (l : list (list candidate)), in_record l = in_record ([] :: l).
intros. extensionality c. apply prop_ext.
apply in_record_nil_nil.
Qed.

Fixpoint flatten {A} (l : list (list A)) : list A :=
match l with
| h :: t => h ++ flatten t
| nil => nil
end.

Lemma in_flatten :
forall A (x: list A) l (c : A),
(exists x, In x l /\ In c x) <-> In c (flatten l).
split; intros.
- induction l.
  +  intuition_nosplit.
  + intuition_nosplit. simpl in *. destruct H.
    * subst. apply in_app_iff. auto.
    * apply in_app_iff. right. apply IHl. eauto.
- induction l.
  inv H.
  simpl in *. apply in_app_or in H. destruct H.
  eauto.
  edestruct IHl; eauto.
  exists x0. intuition.
Qed.

Lemma in_record_flatten (c : candidate):
forall l, in_record l c <-> in_record ([flatten l]) c.
Proof.
split; intros;
unfold in_record in *; intuition_nosplit.
exists (flatten l). intuition. apply in_flatten; eauto.
inv H. apply in_flatten in H0. auto. apply nil.
inv H1.
Qed.

Fixpoint inb {A} {ed : (forall (a b : A), {a = b} + {a <> b})}  i (l : list A) :=
match l with
| h :: t => if ed i h then true else @inb A ed i t
| nil => false
end.

Lemma inb_in :
forall A (i :A) l ed,
@inb A ed i l =true <-> In i l.
split; intros; induction l; simpl in *; try destruct (ed i a); intuition.
Qed.

Fixpoint remove_dups' {A} (ed : (forall (a b : A), {a = b} + {a <> b}))  (l : list A) acc  :=
match l with
| h :: t => if @inb A ed h acc then remove_dups' ed t acc else remove_dups' ed t (h :: acc)
| nil => acc
end.

Definition remove_dups {A} (ed : (forall (a b : A), {a = b} + {a <> b}))  (l : list A) :=
remove_dups' ed l nil.

Lemma in_acc_in :
forall A ed l (i :A) acc, In i acc -> In i (remove_dups' ed l acc).
Proof.
induction l; intros.
- simpl. auto.
- simpl in *. destruct (inb a acc) eqn:?. rewrite inb_in in *.
  intuition.
  intuition.
Qed.

Lemma In_remove_dups' :
forall {A} ed (l : list A) i acc, In i l -> In i (remove_dups' ed l acc).
Proof.
induction l; intros.
- inv H.
- simpl in *. destruct (inb a acc) eqn:?. rewrite inb_in in Heqb.
  destruct H. subst. apply in_acc_in. auto.
  intuition.
  intuition. subst. apply in_acc_in. simpl. auto.
Qed.

Lemma remove_dups_in :
forall {A} ed (l : list A) i acc,
In i (remove_dups' ed l acc) ->
(In i l \/ In i acc).
Proof.
induction l; intros.
- intuition.
- simpl in *. destruct (inb a acc) eqn:?.
  rewrite inb_in in Heqb. edestruct IHl; eauto.
  edestruct IHl; eauto. simpl in H0. intuition.
Qed.

Lemma remove_dups_in_iff :
forall A ed (i : A) l,
In i (remove_dups ed l) <-> In i l.
Proof.
intuition.
unfold remove_dups in H. apply remove_dups_in in H. firstorder.
unfold remove_dups. apply In_remove_dups'. auto.
Qed.

Lemma nodup_remove_dups' :
forall A ed (l : list A) acc,
NoDup acc ->
NoDup (remove_dups' ed l acc).
Proof.
induction l; intros; simpl. auto.
simpl. destruct (inb a acc) eqn:?.
auto.  apply IHl. constructor.
intro. rewrite <- inb_in in H0. instantiate (1:= ed) in H0.
congruence.
auto.
Qed.

Lemma nodup_remove_dups :
forall A ed (l : list A) ,
NoDup (remove_dups ed l ).
Proof. unfold remove_dups. intros. apply nodup_remove_dups'. constructor.
Qed.

Lemma in_record_remove_dups (c : candidate):
forall l ed, in_record l c <-> in_record ([remove_dups ed (flatten l)]) c.
Proof.
split; intros.
unfold in_record in *. intuition_nosplit.
exists (remove_dups ed (flatten l)).
intuition.
apply remove_dups_in_iff. apply in_flatten. apply nil.
eauto.
unfold in_record in *. intuition_nosplit.
inv H. apply remove_dups_in_iff in H0. apply in_flatten in H0.
eauto. apply nil. inv H1.
Qed.

Lemma in_record_remove_dups_eq :
forall l ed, @in_record candidate l  = in_record ([remove_dups ed (flatten l)]).
Proof.
intros. extensionality c. apply prop_ext. apply in_record_remove_dups.
Qed.

Lemma in_record_duplicate_remove :
forall h t l c,
@in_record candidate l h ->
(in_record ((h::t) :: l) c <-> in_record (t :: l) c).
intuition.
- unfold in_record in *; intuition_nosplit; simpl in *;
  repeat (intuition; subst; eauto; simpl in *).
- unfold in_record in *. intuition_nosplit. simpl in H0.
  destruct H0. subst. simpl.
  exists (h :: x). intuition.
  simpl. eauto.
Qed.

Lemma in_record_duplicate_remove_eq :
forall h t l,
@in_record candidate l h ->
(in_record ((h::t) :: l)  = in_record (t :: l) ).
Proof.
intros. extensionality c. apply prop_ext. apply in_record_duplicate_remove; auto.
Qed.

Lemma selected_cons' :
forall r a b c,
Forall r a ->
~sf_spec.overvote _ a ->
sf_spec.selected_candidate candidate r b c ->
sf_spec.selected_candidate _ r (a :: b) c.
Proof.
intros. rewrite Forall_forall in *.
induction b.
inv H1. intuition_nosplit.
destruct H1.  intuition_nosplit.
unfold sf_spec.selected_candidate.
split.
- rewrite <- continuing2_continuing in *.
  unfold continuing2 in *.
  intuition_nosplit. exists x0. intuition.
  constructor; try rewrite Forall_forall; auto.
- exists x. intuition.
  constructor; auto.
  rewrite Forall_forall. auto.
Qed.

Lemma first_choices_0_not_next :
forall election c b l rnk
(OV: ~sf_spec.overvote _ rnk),
 sf_spec.first_choices candidate (in_record l) c election 0 ->
In b election ->
sf_spec.next_ranking candidate (in_record l) b rnk ->
~In c rnk.
Proof.
intros.
intro.
induction election.
inv H0.
simpl in H0.
destruct H0.
- clear IHelection. subst. induction b.
  + inv H1.
  + inv H1.
    * apply IHb; auto.  inv H. intuition.
      constructor. intro. apply H3. clear H3. apply selected_cons'; auto.
      auto.
    * destruct H6. intuition. inv H. apply H5. clear H5.
      split. rewrite <- continuing2_continuing. unfold continuing2.
      exists rnk. intuition. eapply sf_spec.next_ranking_valid.
      apply H4. intuition.
      exists rnk. intuition. eapply sf_spec.next_ranking_valid. apply H4. intuition.
- apply IHelection; auto. inv H. auto.
Qed.

Lemma not_selected_eliminated :
forall r c a b,
~sf_spec.overvote candidate (c :: a) ->
~sf_spec.selected_candidate _ r ((c :: a)::b) c ->
r c.
Proof.
intros.
- unfold sf_spec.selected_candidate in H0. rewrite <- continuing2_continuing in H0.
  destruct (classic (r c)). auto. exfalso.
  apply H0. clear H0. split.
  unfold continuing2. exists (c :: a).
  intuition. eapply sf_spec.next_ranking_valid with (c := c).
  simpl. auto. auto.
  exists (c::a). intuition.
  apply sf_spec.next_ranking_valid with (c := c). simpl. auto.
  intuition.
Qed.

Lemma rem_0_still_next :
forall c l  x b election,
sf_spec.first_choices candidate (in_record [l]) c (election) 0 ->
In b election ->
sf_spec.next_ranking candidate (in_record [c :: l]) b x ->
sf_spec.next_ranking candidate (in_record [l]) b x.
intros. induction election.
- inv H0.
- simpl in H0. destruct H0.
  + subst. clear IHelection.
    induction b.
    * inv H1.
    * { inv H. inv H1.
        - destruct a.
          + constructor; auto. apply IHb; auto. constructor.
            * intro. apply H3. clear H3. apply selected_cons'; auto.
            * auto.
          + rewrite Forall_forall in H2. pose proof (H2 c0).  simpl in H. intuition.
            clear H6. unfold in_record in H. intuition_nosplit.
            simpl in H. intuition. subst.
            simpl in H1. destruct H1.
            * subst. constructor; auto. apply not_selected_eliminated in H3; auto.
              rewrite Forall_forall. intros.
              simpl in H. destruct H. solve_rcv.
              apply sf_spec.not_overvote_all_same with (c := c0) in H4; simpl; auto.
              rewrite Forall_forall in H4. specialize (H4 x0).
              simpl in H4. intuition. subst. auto. apply (fun _ => False).
              apply H0. clear H0. constructor; auto.
              intro. apply H3. apply selected_cons'; auto. apply not_selected_eliminated in H3; auto.
              rewrite Forall_forall. intros. simpl in *. intuition; try solve[solve_rcv].
              apply sf_spec.not_overvote_all_same with (c := c0) in H4; simpl; auto.
              rewrite Forall_forall in H4. specialize (H4 x0). simpl in *. intuition.
              subst. auto. apply (fun _ => False).
            * constructor; auto. apply sf_spec.not_overvote_all_same with (c := c0) in H4;
                                 simpl; auto.
              rewrite Forall_forall in *.
              intros. simpl in H1. intuition; subst; auto. unfold in_record. exists l.
              simpl; auto. exists l. intuition. assert (c0 = x0). apply H4; simpl; auto.
              subst. auto. apply (fun _ => False).
              apply H0. clear H0. constructor; auto.
              intro. apply H3. apply selected_cons'; auto.
              rewrite Forall_forall. intros. simpl in *. intuition; try solve[solve_rcv].
              apply sf_spec.not_overvote_all_same with (c := c0) in H4; simpl; auto.
              rewrite Forall_forall in H4. specialize (H4 x0). simpl in *. intuition.
              subst. exists l. simpl. auto. apply (fun _ => False).
        - destruct H6.
           + eapply sf_spec.next_ranking_valid; eauto.
           + eapply sf_spec.next_ranking_valid; eauto.
             right. intro. apply H. unfold in_record in H0. intuition_nosplit.
             exists (c::l). intuition. simpl. inv H0. auto. inv H4.
      }
  + apply IHelection; auto. rewrite first_choices_0_cons in H. intuition.
Qed.

Lemma rem_0_still_continuing :
forall election c l b,
sf_spec.first_choices candidate (in_record [l]) c (election) 0 ->
In b election ->
sf_spec.continuing_ballot candidate (in_record [c :: l]) b ->
sf_spec.continuing_ballot candidate (in_record [l]) b.
intros. rewrite <- continuing2_continuing in *. unfold continuing2 in *.
intuition_nosplit. exists x. intuition.
eapply rem_0_still_next; eauto.
Qed.

Lemma next_ranking_add_c :
forall c l a x election,
sf_spec.first_choices candidate (in_record [l]) c election 0 ->
In a election ->
sf_spec.next_ranking candidate (in_record [l]) a x ->
sf_spec.next_ranking candidate (in_record [c::l]) a x.
Admitted.

Lemma total_selected_remove_0 :
forall election c l t,
  sf_spec.first_choices candidate (in_record [l]) c election 0 ->
  sf_spec.total_selected candidate (in_record [c :: l]) election t ->
  sf_spec.total_selected candidate (in_record [l]) election t.
Proof.
induction election; intros.
inv H0. constructor.
inv H0.
constructor.
eapply rem_0_still_continuing; simpl; eauto. simpl. eauto.
eapply IHelection; eauto. inv H; auto. constructor; auto.
unfold sf_spec.exhausted_ballot in *.
destruct H3.
left. intro. apply H0. clear H0.
intuition_nosplit. exists x. eapply next_ranking_add_c; eauto.
simpl. auto.
right. intuition_nosplit. exists x. intuition.
eapply rem_0_still_next in H0; simpl; eauto. simpl. eauto.
eapply IHelection; eauto.
inv H. auto.
Qed.

Lemma first_choices_remove_0 :
  forall l c x election winner_votes,
  sf_spec.first_choices candidate (in_record [l]) c election 0 ->
  sf_spec.first_choices candidate (in_record [c :: l]) x election
                        winner_votes ->
  sf_spec.first_choices candidate (in_record [l]) x election winner_votes.
Admitted.

Lemma no_majority_remove_0 :
forall  l election c,
sf_spec.first_choices candidate (in_record [l]) c election 0 ->
sf_spec.no_majority candidate (in_record [c :: l]) election ->
sf_spec.no_majority candidate (in_record [l]) election.
Proof.
intros. unfold sf_spec.no_majority in *.
intro. apply H0. clear H0.
destruct H1.
exists x. unfold sf_spec.majority in *. intros.
apply total_selected_remove_0 in H1; auto.
apply H0; auto. generalize dependent H2. revert H.  apply first_choices_remove_0.
Qed.

Lemma not_isloser_nil :
forall loser r,
~ sf_spec.is_loser candidate r [] loser.
intros. intro.
unfold sf_spec.is_loser in *.
intuition. inv H0. inv H2. intuition.
Qed.

Lemma not_winner_nil :
forall r winner,
~sf_spec.winner candidate [] r winner.
intros. intro. inv H.
- unfold sf_spec.majority in *.
  specialize (H0 0 0). assert (0 * 2 > 0).
  apply H0. constructor. constructor. omega.
- apply not_isloser_nil in H1. auto.
Qed.

Lemma in_record_flatten_eq : forall r,
@in_record candidate r = in_record [flatten r].
intros. extensionality c. apply prop_ext. apply in_record_flatten.
Qed.

Lemma not_participates_rec :
  forall c election l winner,
    ~ sf_spec.participates candidate c (election) ->
    sf_spec.winner candidate (election) (in_record [c :: l]) winner ->
    sf_spec.winner candidate (election) (in_record [l]) winner.
 Admitted.

Lemma majority_unique :
forall r e x x',
sf_spec.majority candidate r e x ->
sf_spec.majority candidate r e x' ->
x = x'.
Admitted.

Lemma majority_remove_0 :
  forall l c election winner,
  sf_spec.first_choices candidate (in_record [l]) c (election) 0 ->
   sf_spec.majority candidate (in_record [c :: l]) (election) winner ->
   sf_spec.majority candidate (in_record [l]) (election) winner.
Admitted.

Lemma winner_eliminate_0s' :
forall election  c winner l
(NODUP : NoDup (c::l)),
sf_spec.first_choices _ (in_record [l]) c election 0 ->
sf_spec.winner candidate election (in_record ([c ::l]) ) winner ->
sf_spec.winner candidate election (in_record [l]) winner.
Proof.
intros.
induction election.
- clear H. inv H0.
  + unfold sf_spec.majority in *. specialize (H 0 0).
    assert (0*2 > 0). apply H. constructor; auto. constructor. omega.
  + apply not_winner_nil in H2. inv H2.
- destruct (classic (sf_spec.no_majority candidate (in_record [c :: l]) (a :: election))).
  + destruct (classic ( sf_spec.participates candidate c (a :: election))).
    * apply sf_spec.winner_elimination with (loser := c); auto.
      apply no_majority_remove_0 in H1; auto.
      apply first_choices_0_loser. inv NODUP. intro. apply H5.
      solve_rcv. inv H3. auto. inv H7.
      auto. auto. rewrite update_eliminated_in_rec_eq_noc. rewrite in_record_flatten_eq.
      simpl. rewrite app_nil_r. auto.
    * eapply not_participates_rec; eauto.
  + unfold sf_spec.no_majority in *.  apply NNPP in H1. destruct H1.
    inv H0. assert (x = winner). eapply majority_unique; eauto. subst.
    constructor.  apply majority_remove_0 in H2. auto.
    auto.
    exfalso. apply H2. exists x. auto.
Qed.

Lemma first_choices_0_rev:
forall l a election,
(forall c, In c l -> sf_spec.first_choices candidate (in_record []) c election 0) ->
sf_spec.first_choices candidate (in_record []) a election 0 ->
sf_spec.first_choices candidate (in_record [l]) a election 0.
Admitted.

Lemma winner_eliminate_0s :
forall election winner l
(NODUP : NoDup l),
(forall c, in_record [l] c -> sf_spec.first_choices _ (in_record []) c election 0) ->
sf_spec.winner candidate election (in_record [l] ) winner ->
sf_spec.winner candidate election (in_record []) winner.
Proof.
  induction l; intros. rewrite in_record_nil_nil_eq. auto.
  apply winner_eliminate_0s' in H0; auto.
  apply IHl; auto. inv NODUP; auto. intros.
  specialize (H c). apply H. destruct H1. intuition.
  exists (a::l). simpl; intuition. inv H2; auto. inv H1.
  assert (sf_spec.first_choices candidate (in_record []) a election 0).
  apply H. exists (a::l); simpl; intuition.
  apply first_choices_0_rev; auto. intros. apply H.
  exists (a :: l). simpl; auto.
Qed.

End cand.


(* This file contains definitions that seemed missing from Coq.Vectors.Vector *)

From Coq         Require Import PeanoNat.
From Coq.Vectors Require Vector.

Fixpoint zip {a b : Type} {n : nat} (xs : Vector.t a n) (ys : Vector.t b n) : Vector.t (a * b) n.
  refine (
    match
      xs in Vector.t _ n'
      return Vector.t _ n' -> Vector.t _ n'
    with
    | Vector.nil _ => fun _ => Vector.nil _
    | Vector.cons _ x pn xs =>
      fun ys =>
        match
          ys in Vector.t _ n'
          return S pn = n' -> Vector.t _ n'
        with
        | Vector.nil _ => fun absurd => False_rect _ (Nat.neq_succ_0 _ absurd)
        | Vector.cons _ y pn' ys =>
          fun eq =>
            let xs' := eq_rect _ _ xs _ (eq_add_S _ _ eq) in
            Vector.cons _ (x, y) pn' (zip _ _ _ xs' ys)
        end eq_refl
    end ys
    ).
Defined.


Require Import CT.Category.
Require Import CT.Functor.

(** * Full Functors

A "full" functor is one that is surjective on hom-sets. That is,
A functor \(F : C \to D\) is _full_ if \(\forall x, y \in C\), the function
\(F : C(x, y) \to D(F(x), F(y))\) is surjective.

So we require a [Functor] and a proof that surjectivity of hom-sets is
satisfied.
*)
Section FullFunctor.
  Context {A B : Category}.
  Variable (F : Functor A B).

  (* Surjectivity of [F_mor] *)
  Definition FullFunctor :=
    forall {a b} (f : mor B (F_ob F a) (F_ob F b)),
      { f' : mor A a b | F_mor F f' = f }.
End FullFunctor.