Set Implicit Arguments.
Unset Strict Implicit.

Require Import extraction.
Require Import Arith ZArith.
Require Import Vector.
Require Import String.
Require Import JMeq.
Require Import List. Import ListNotations.

Require Import Integers.

Require Import lang.

Inductive fld : Type :=
  | OpCode
  | Funct
  | Format
  | Rt
  | ImmAddr
  | TaintBit : Int64.int -> fld
  | OffsetFld : Int64.int -> fld -> fld
  (*OffsetFld i f: Increase offset of f by i bits. OffsetFld is used primarily
    to test the high-order bits of particular fields, like EffAddr.*)
  | EffAddr
  | PC.

Fixpoint offset (f : fld) : Int64.int :=
  match f with
  | OpCode => Int64.repr 26
  | Funct => Int64.repr 0
  | Format => Int64.repr 21
  | Rt => Int64.repr 11
  | ImmAddr => Int64.repr 0
  | TaintBit off => off
  | OffsetFld i f => Int64.add i (offset f)
  | EffAddr => Int64.repr 32
  | PC => Int64.repr 0
  end.

Fixpoint size (f : fld) : Int64.int :=
  match f with
  | OpCode => Int64.repr 6
  | Funct => Int64.repr 6
  | Format => Int64.repr 5
  | Rt => Int64.repr 5
  | ImmAddr => Int64.repr 26
  | TaintBit _ => Int64.one  (* Taint bits are always size-1 *)
  | OffsetFld _ f => size f
  | EffAddr => Int64.repr 32
  | PC => Int64.repr 64
  end.

Inductive pred {t:ty} : Type :=
| BPred : binop -> pred -> pred -> pred
| BZero : pred
| BNeg : pred -> pred
| BField : fld -> interp_ty t -> pred.

Arguments pred t : clear implicits.

(*BFieldRange f size v: check whether the 'size' higher-order bits of 'fld' equal 'v'*)
Definition BFieldRange t (f:fld) (i:Int64.int) (v:interp_ty t) : pred t :=
  BField (OffsetFld i f) v.

Inductive pol : ty -> ty -> Type :=
| PTest : forall ity oty `{ScalarTy ity} `{ScalarTy oty}, pred ity -> pol ity oty -> pol ity oty
| PUpd : forall ity oty  `{ScalarTy ity} `{ScalarTy oty}, (exp ity -> exp oty) -> pol ity oty
| PProj1 : forall ity1 ity2 `{ScalarTy ity1} `{ScalarTy ity2}, pol (TProd ity1 ity2) ity1
| PProj2 : forall ity1 ity2 `{ScalarTy ity1} `{ScalarTy ity2}, pol (TProd ity1 ity2) ity2
| PChoice : forall ity oty `{ScalarTy ity} `{ScalarTy oty}, pol ity oty -> pol ity oty -> pol ity oty
| PConcat : forall ity mty oty  `{ScalarTy ity} `{ScalarTy mty} `{ScalarTy oty},
    pol ity mty -> pol mty oty -> pol ity oty
| PSkip : forall ity oty `{ScalarTy ity} `{ScalarTy oty}, pol ity oty
| PFail : forall ity oty `{ScalarTy ity} `{ScalarTy oty}, pol ity oty
| PId : forall ity `{ScalarTy ity}, pol ity ity.

Record Pol: Type :=
  mkPol {
      ity: ty; ity_ScalarTy: `{ScalarTy ity};
      oty: ty; oty_ScalarTy: `{ScalarTy oty};
      the_pol: pol ity oty
    }.

Fixpoint pred_interp t `{ScalarTy t} (e : pred t) : interp_ty t -> Prop :=
  match e with
  | BPred OAnd e1 e2 => fun v => pred_interp e1 v /\ pred_interp e2 v
  | BPred OOr e1 e2 => fun v => pred_interp e1 v \/ pred_interp e2 v
  | BPred _ _ _ => fun _ => False (*other binops are nonboolean*)
  | BZero => fun _ => False
  | BNeg e2 => fun v => not (pred_interp e2 v)
  | BField f i => fun v =>
                    oiszero
                      (obinop OEq
                              (obinop
                                 OAnd
                                 (obinop OShru v (ofromz (Int64.intval (offset f))))
                                 (obinop OShru
                                         (ofromz 18446744073709551615)
                                         (ofromz (Int64.intval (size f)))))
                              i)
                    = false
  end.

Module PolInterp. Section pol_interp.
  Variable s: forall t, id t -> interp_ty t.

  Fixpoint pol_interp {ity oty} `{ScalarTy ity} `{ScalarTy oty}
           (p: pol ity oty) : interp_ty ity -> interp_ty oty -> Prop :=
    match p with
    | PTest _ _ _ _ e p2 => fun v_in v_out => pred_interp e v_in /\ pol_interp p2 v_in v_out
    | PUpd _ _ _ _ f => fun v_in v_out => exp_interp s (f (EVal v_in)) = v_out
    | PProj1 _ _ _ _ => fun v_in v_out => fst v_in = v_out
    | PProj2 _ _ _ _ => fun v_in v_out => snd v_in = v_out
    | PChoice _ _ _ _ p1 p2 => fun v_in v_out => pol_interp p1 v_in v_out \/ pol_interp p2 v_in v_out
    | PConcat ity mty oty _ _ _ p1 p2 => fun v_in v_out =>
                             exists v_int:interp_ty mty,
                               pol_interp p1 v_in v_int /\ pol_interp p2 v_int v_out
    | PSkip _ _ _ _ => fun v_in v_out => True
    | PFail _ _ _ _ => fun v_in v_out => False
    | PId _ _ => fun v_in v_out => v_out = v_in
    end.
End pol_interp. End PolInterp.

Section equations.
Variable P: Pol.

Notation ity := P.(ity).
Notation oty := P.(oty).

Definition the_ity_ScalarTy := P.(ity_ScalarTy).
Existing Instance the_ity_ScalarTy.
Definition the_oty_ScalarTy := P.(oty_ScalarTy).
Existing Instance the_oty_ScalarTy.

Notation pol := (pol _ _).
Notation PId := (@PId _ _).

Import PolInterp.

Notation pol_interp s p v_in v_out :=
  (@pol_interp s ity oty the_ity_ScalarTy the_oty_ScalarTy p v_in v_out).

Definition pol_eq (p1 p2 : pol) :=
  forall s v_in v_out,
    pol_interp s p1 v_in v_out <-> pol_interp s p2 v_in v_out.

Infix "===" := (pol_eq) (at level 70).

Lemma concat_idl : forall p: pol, PConcat PId p === p.
Proof.
  intros p; split; simpl.
  { intros [v [-> H]]; auto. }
  intros H.
  exists v_in.
  split; auto.
Qed.

Lemma concat_idr (H:ity=oty) : forall p, PConcat p PId === p.
Proof.
  intros p; split; simpl.
  { intros [v_int [H1 H2]]; auto.
    subst; auto. }
  intros H2; exists v_out; split; auto.
Qed.

Lemma concat_test_id : forall p e,
  PConcat (PTest e PId) p === PTest e p.
Proof.
  intros p e; unfold pol_eq; intros s v_in v_out; split.
  { simpl.
     intros [v_int [[H1 H2] H3]].
     subst.
     split; auto. }
  simpl.
  intros [H1 H2]; exists v_in.
  split; auto.
Qed.

(*Lemma pupd_id : @PUpd ity oty (fun x => x) === PId eq_refl.
Proof.
  unfold pol_eq; intros s v_in v_out; simpl; split; auto.
Qed.*)

Lemma concat_comp : forall f g,
  (forall s e,
     exp_interp s (g e) =
     exp_interp s (g (EVal (exp_interp s e)))) ->
  PConcat (PUpd f) (PUpd g) === PUpd (fun x => g (f x)).
Proof.
  intros f g X; unfold pol_eq; intros s v_in v_out; split.
  { simpl; intros [v_int [H1 H2]].
     rewrite <-H2.
     revert g s X H1 H2.
     generalize (f (EVal v_in)).
     inversion e; intros; subst; auto. }
  simpl; intros H.
  revert g v_out X H.
  generalize (f (EVal v_in)).
  intros.
  eexists.
  split.
  { specialize (X s e).
     rewrite H in  X. subst. eapply eq_refl. }
  specialize (X s e); rewrite <-H, X; auto.
Qed.

Lemma pol_eq_sym : forall p1 p2, p1 === p2 -> p2 === p1.
Proof.
  intros p1 p2; unfold pol_eq; intros H v1 v2.
  intros v_out.
  rewrite (H v1 v2); split; auto.
Qed.

Lemma choice_failr : forall p, PChoice p PFail === p.
Proof.
  intros p v1 v2; split.
  { intros [H|H]; [auto|inversion H]. }
  intros; left; auto.
Qed.
End equations.

(* Compile Predicates *)
Fixpoint compile_pred t `{ScalarTy t} (x : id t) (p : pred t) : exp t :=
  match p with
  | BPred op pl pr => EBinop op (compile_pred x pl) (compile_pred x pr)
  | BZero => EVal (ofromz 0)
  | BNeg p' => ENot (compile_pred x p')
  | BField f i =>
    let field_val :=
        EBinop
          OAnd
          (EBinop OShru (EVar x) (EVal (ofromz (Int64.intval (offset f)))))
          (EBinop OShru (EVal (ofromz 18446744073709551615))
                  (EVal (ofromz (Int64.intval (Int64.sub (Int64.repr 64) (size f))))))
    in EBinop OEq field_val (EVal i)
  end.

(* State monad *)
Section M.
  Variable state : Type.

  Definition M (A : Type) := state -> state * A.

  Definition ret (A : Type) (a : A) : M A := fun s => (s, a).

  Definition bind (A B : Type) (m : M A) (f : A -> M B) : M B :=
    fun s =>
      match m s with
      | (s', a) => f a s'
      end.
End M.

(* Variables using decimal integers *)
Inductive digit : Type :=
  Zero | One | Two | Three | Four | Five | Six | Seven | Eight | Nine.

Definition digit2string (d : digit) : string :=
  match d with
  | Zero => "0"
  | One => "1"
  | Two => "2"
  | Three => "3"
  | Four => "4"
  | Five => "5"
  | Six => "6"
  | Seven => "7"
  | Eight => "8"
  | Nine => "9"
  end.

Definition decimal := list digit.

Fixpoint decimal2string (d : decimal) : string :=
  match d with
  | nil => ""
  | x :: d' => append (digit2string x) (decimal2string d')
  end.

Fixpoint nat2decimal_aux (fuel n : nat) (acc : decimal) : decimal :=
  match fuel with
  | O => Zero :: acc
  | S fuel' =>
      match n with
      | 0 => Zero :: acc
      | 1 => One :: acc
      | 2 => Two :: acc
      | 3 => Three :: acc
      | 4 => Four :: acc
      | 5 => Five :: acc
      | 6 => Six :: acc
      | 7 => Seven :: acc
      | 8 => Eight :: acc
      | 9 => Nine :: acc
      | _ =>
        let d := Nat.div n 10 in
        let r := Nat.modulo n 10 in
        nat2decimal_aux fuel' d (nat2decimal_aux fuel' r acc)
      end
  end.

 Definition nat2decimal (n : nat) : decimal :=
   nat2decimal_aux n n nil.

 Definition nat2string (n : nat) : string := decimal2string (nat2decimal n).

 Definition state := (nat * list string)%type.

 Definition new_buf : M state string :=
   fun p =>
     match p with
     | (n, l) =>
       let new_buf := append "internal" (nat2string n) in
       ((S n, new_buf::l), new_buf)
     end.

 (* Compile Policies *)
 Fixpoint compile_pol
          t1 t2
          `{ScalarTy t1} `{ScalarTy t2}
          (i:id t1) (o:id t2) (p : pol t1 t2) : M state stmt :=
  match p in pol t1 t2 with
  | PTest t1 t2 _ _ test p_cont =>
    let e_test := @compile_pred t1 _ i test
    in bind (@compile_pol t1 t2 _ _ i o p_cont) (fun s_cont =>
       ret (SITE e_test s_cont SSkip))

  | PUpd t1 t2 _ _ f => ret (@SAssign t2 _ o (f (@EVar t1 i)))

  | PProj1 t1 t2 _ _ => ret SSkip (*FIXME*)
  | PProj2 t1 t2 _ _ => ret SSkip (*FIXME*)

  | PChoice t1 t2 _ _ p1 p2 =>
    bind new_buf (fun o_new1 =>
    bind new_buf (fun o_new2 =>
    bind (@compile_pol t1 t2 _ _ i o_new1 p1) (fun s1 =>
    bind (@compile_pol t1 t2 _ _ i o_new2 p2) (fun s2 =>
    ret (SSeq s1
        (SSeq s2
        (SAssign o
          (EBinop OOr (EVar o_new1) (EVar o_new2)))))))))

  | PConcat t1 t2 t3 _ _ _ p1 p2 =>
    bind new_buf (fun m_new_buf =>
    bind (@compile_pol t1 t2 _ _ i m_new_buf p1) (fun s1 =>
    bind (@compile_pol t2 t3 _ _ m_new_buf o p2) (fun s2 =>
    ret (SSeq s1 s2))))

  | PSkip _ _ _ _ => ret SSkip

  | PFail _ _ _ _ => ret (SAssign o (EVal (ofromz 0)))

  | PId _ _ => ret (@SAssign t1 _ o (EVar i))
  end.

 Fixpoint compile_bufs (bufs : list string) (p : prog) : prog :=
   match bufs with
   | nil => p
   | x::bufs' => VDecl Local x (ofromz 0) (compile_bufs bufs' p)
   end.

Section compile.
  Context (ity: ty) `{ScalarTy ity}.
  Context (oty: ty) `{ScalarTy oty}.

  Variable i: id ity.
  Variable o: id oty.

  Definition compile (p: pol ity oty): prog :=
    let (state, s) := compile_pol i o p (O, nil) in
    let output_p := VDecl Input i (ofromz 0) (VDecl Output o (ofromz 0) (PStmt s))
    in match state with
       | (_, bufs) => compile_bufs bufs output_p
       end.
End compile.

Section Compile.
  Variable P: Pol.
  Notation ity := P.(ity).
  Notation oty := P.(oty).

  Definition compile_ity_ScalarTy := P.(ity_ScalarTy).
  Existing Instance compile_ity_ScalarTy.
  Definition compile_oty_ScalarTy := P.(oty_ScalarTy).
  Existing Instance compile_oty_ScalarTy.

  Variable i: id ity.
  Variable o: id oty.

  Definition Compile: prog := compile i o P.(the_pol).
End Compile.

Section Compile2.
  Variables P1 P2: Pol.
  Variables (i1: id P1.(ity)) (o1: id P1.(oty)).
  Variables (i2: id P2.(ity)) (o2: id P2.(oty)).

  Definition Compile2: prog := PSeq (Compile i1 o1) (Compile i2 o2).
End Compile2.

Section Compile3.
  Variables P1 P2 P3: Pol.
  Variables (i1: id P1.(ity)) (o1: id P1.(oty)).
  Variables (i2: id P2.(ity)) (o2: id P2.(oty)).
  Variables (i3: id P2.(ity)) (o3: id P2.(oty)).

  Definition Compile3: prog := PSeq (Compile i1 o1) (Compile2 i2 o2 i3 o3).
End Compile3.

Infix "`orpred`" := (BPred OOr) (at level 60).

Fixpoint of_bin_aux (i:Z) (l:list Z): Z :=
  match l with
  | nil => 0
  | z :: l' =>
    if Z.eqb z 0 then of_bin_aux (i+1) l'
    else Z.pow 2 i + of_bin_aux (i+1) l'
  end.

Definition of_bin (l:list Z): Z := of_bin_aux 0 (rev l).

Infix "`andpred`" := (BPred OAnd) (at level 60).

Section MIPS.
  Notation read x := (ofromz (of_bin x)%Z).

  (*R-type instructions*)
  Definition R_type := BField OpCode (read [0;0;0;0;0;0]).
  Definition add := R_type `andpred` BField Funct (read [1;0;0;0;0;0]).
  Definition addu := R_type `andpred` BField Funct (read [1;0;0;0;0;1]).
  Definition and := R_type `andpred` BField Funct (read [1;0;0;1;0;0]).
  Definition break := R_type `andpred` BField Funct (read [0;0;1;1;0;1]).
  Definition div := R_type `andpred` BField Funct (read [0;1;1;0;1;0]).
  Definition divu := R_type `andpred` BField Funct (read [0;1;1;0;1;1]).
  Definition jalr := R_type `andpred` BField Funct (read [0;0;1;0;0;1]).
  Definition jr := R_type `andpred` BField Funct (read [0;0;1;0;0;0]).
  Definition mfhi := R_type `andpred` BField Funct (read [0;1;0;0;0;0]).
  Definition mflo := R_type `andpred` BField Funct (read [0;1;0;0;1;0]).
  Definition mthi := R_type `andpred` BField Funct (read [0;1;0;0;0;1]).
  Definition mtlo := R_type `andpred` BField Funct (read [0;1;0;0;1;1]).
  Definition mult := R_type `andpred` BField Funct (read [0;1;1;0;0;0]).
  Definition multu := R_type `andpred` BField Funct (read [0;1;1;0;0;1]).
  Definition nor := R_type `andpred` BField Funct (read [1;0;0;1;1;1]).
  Definition or := R_type `andpred` BField Funct (read [1;0;0;1;0;1]).
  Definition sll := R_type `andpred` BField Funct (read [0;0;0;0;0;0]).
  Definition sllv := R_type `andpred` BField Funct (read [0;0;0;1;0;0]).
  Definition slt := R_type `andpred` BField Funct (read [1;0;1;0;1;0]).
  Definition sltu := R_type `andpred` BField Funct (read [1;0;1;0;1;1]).
  Definition sra := R_type `andpred` BField Funct (read [0;0;0;0;1;1]).
  Definition srav := R_type `andpred` BField Funct (read [0;0;0;1;1;1]).
  Definition srl := R_type `andpred` BField Funct (read [0;0;0;0;1;0]).
  Definition srlv := R_type `andpred` BField Funct (read [0;0;0;1;1;0]).
  Definition sub := R_type `andpred` BField Funct (read [1;0;0;0;1;0]).
  Definition subu := R_type `andpred` BField Funct (read [1;0;0;0;1;1]).
  Definition syscall := R_type `andpred` BField Funct (read [0;0;1;1;0;0]).
  Definition xor := R_type `andpred` BField Funct (read [1;0;1;1;0;0]).

  Definition jump_indirect := jalr `orpred` jr.

  (*I-type instructions*)
  Definition addi := BField OpCode (read [0;0;1;0;0;0]).
  Definition addiu := BField OpCode (read [0;0;1;0;0;1]).
  Definition andi := BField OpCode (read [0;0;1;1;0;0]).
  Definition beq := BField OpCode (read [0;0;0;1;0;0]).
  Definition bgez := BField OpCode (read [0;0;0;0;0;1]) `andpred` BField Rt (read [0;0;0;0;1]).
  Definition bgtz := BField OpCode (read [0;0;0;1;1;1]) `andpred` BField Rt (read [0;0;0;0;0]).
  Definition blez := BField OpCode (read [0;0;0;1;1;0]) `andpred` BField Rt (read [0;0;0;0;0]).
  Definition bltz := BField OpCode (read [0;0;0;0;0;1]) `andpred` BField Rt (read [0;0;0;0;0]).
  Definition bne := BField OpCode (read [0;0;0;1;0;1]).
  Definition lb := BField OpCode (read [1;0;0;0;0;0]).
  Definition lbu := BField OpCode (read [1;0;0;1;0;0]).
  Definition lh := BField OpCode (read [1;0;0;0;0;1]).
  Definition lhu := BField OpCode (read [1;0;0;1;0;1]).
  Definition lui := BField OpCode (read [0;0;1;1;1;1]).
  Definition lw := BField OpCode (read [1;0;0;0;1;1]).
  Definition lwcl := BField OpCode (read [1;1;0;0;0;1]).
  Definition ori := BField OpCode (read [0;0;1;1;0;1]).
  Definition sb := BField OpCode (read [1;0;1;0;0;0]).
  Definition slti := BField OpCode (read [0;0;1;0;1;0]).
  Definition sltiu := BField OpCode (read [0;0;1;0;1;1]).
  Definition sh := BField OpCode (read [1;0;1;0;0;1]).
  Definition sw := BField OpCode (read [1;0;1;0;1;1]).
  Definition swcl := BField OpCode (read [1;1;1;0;0;1]).
  Definition xori := BField OpCode (read [0;0;1;1;1;0]).

  Definition store := sb `orpred` sw.

  Definition branch := beq `orpred` bgez `orpred` bgtz `orpred` blez `orpred` bltz `orpred` bne.

  (*J-type instructions*)
  Definition j := BField OpCode (read [0;0;0;0;1;0]).
  Definition jal := BField OpCode (read [0;0;0;0;1;1]).

  Definition jump_direct := j `orpred` jal.
  Definition jump := jump_indirect `orpred` jump_direct.

  Definition ctrl := branch `orpred` jump.

  (*FP instructions*)
  Definition FP_type := BField OpCode (read [0;1;0;0;0;1]).
  Definition add_s :=
    FP_type `andpred` BField Funct (read [0;0;0;0;0;0])
            `andpred` BField Format (read [1;0;0;0;0]).
  Definition cvt_s_w :=
    FP_type `andpred` BField Funct (read [1;0;0;0;0;0])
            `andpred` BField Format (read [1;0;1;0;0]).
  Definition cvt_w_s :=
    FP_type `andpred` BField Funct (read [1;0;0;1;0;0])
            `andpred` BField Format (read [1;0;0;0;0]).
  Definition div_s :=
    FP_type `andpred` BField Funct (read [0;0;0;0;1;1])
            `andpred` BField Format (read [1;0;0;0;0]).
  Definition mfcl :=
    FP_type `andpred` BField Funct (read [0;0;0;0;0;0])
            `andpred` BField Format (read [0;0;0;0;0]).
  Definition mov_s :=
    FP_type `andpred` BField Funct (read [0;0;0;1;1;0])
            `andpred` BField Format (read [1;0;0;0;0]).
  Definition mtcl :=
    FP_type `andpred` BField Funct (read [0;0;0;0;0;0])
            `andpred` BField Format (read [0;0;1;0;0]).
  Definition mul_s :=
    FP_type `andpred` BField Funct (read [0;0;0;0;1;0])
            `andpred` BField Format (read [1;0;0;0;0]).
  Definition sub_s :=
    FP_type `andpred` BField Funct (read [0;0;0;0;0;1])
            `andpred` BField Format (read [0;0;0;0;1]).
End MIPS.

Require Import syntax.

Notation "'`IF`' e '`THEN`' p1 '`ELSE`' p2" :=
  (PChoice (PTest e p1) (PTest (BNeg e) p2)) (at level 101).

Section test_secjmp.
  Variables i o : id TVec64.
  (*High-order 10 bits of immediate address are zeroed. Because the effective
    address of the jump is calculated in MIPS as pc[0:3]++imm_addr[0:25]++[0;0],
    this enforces that all jumps are within a 2^16 offset of the higher-order 4
    bits of any instruction. Note that this policy doesn't deal with branches
    or indirect jumps. Note also that it's possible in principle to check
    statically that direct jumps are policy compliant.*)
  Definition sec_addr := BFieldRange ImmAddr (ofromz 10) (ofromz 0).
  Definition sec_jmp : pol TVec64 TVec64 :=
    `IF` jump `THEN` PTest sec_addr PId `ELSE` PId.
End test_secjmp.

Section scf.
  (*A control-flow isolation policy. We assume that the effective address
    is pre-calculated in the top 32 bits of the input vector. *)
  Variables i o : id TVec64.
  Definition control_domain := ofromz 0.
  Definition sec_addr32 := BFieldRange EffAddr (ofromz 10) control_domain.
  Definition scf: pol TVec64 TVec64 :=
    `IF` ctrl `THEN` PTest (BNeg sec_addr32) PId `ELSE` PId.
  (*We define a second version of this policy that applies just to indirect
    control flows (direct flows could be checked statically).*)
  Definition scf2: pol TVec64 TVec64 :=
    `IF` jump_indirect `THEN` PTest (BNeg sec_addr32) PId `ELSE` PId.
End scf.

Section sfi.
  (*A write isolation policy, which we called SFI in the original paper. Note that
    SFI sometimes refers to a combination of write isolation and control-flow isolation
    (a point the paper clarifies). Below, the logical fault domain (lfd_mask)
    is the sub-address space beginning with higher-order bits 0^8.*)
  Variables ri ro : id TVec64.

  Definition lfd_start := ofromz 11673330234144325632. (*162<<56*)
  Definition lfd_mask := ofromz 72057594037927935. (*0^8 1^56*)

  Definition mask e := EBinop OAnd (EVal lfd_mask) e.
  Definition force_range e := EBinop OOr (EVal lfd_start) e.

  Definition sfi: pol TVec64 TVec64 :=
    `IF` store `THEN` PConcat (PUpd mask) (PUpd force_range) `ELSE` PId.
End sfi.

Section taint.
  (*Taint tracking through ALU operations only (the monitors could be extended to
    support other taint propagation rules).*)
  Definition rs_taint := TaintBit (ofromz 63).
  Definition rt_taint := TaintBit (ofromz 62).
  Definition pc_taint := TaintBit (ofromz 61).
  Definition TAINTED := ofromz 1.
  Definition NOT_TAINTED := ofromz 0.
  Definition tainted_Itype: pred TVec64 :=
    BField pc_taint TAINTED `orpred` BField rs_taint TAINTED.
  Definition tainted_Rtype: pred TVec64 := BField rt_taint TAINTED.
  Definition taint64: pol TVec64 TVec64 :=
    `IF` tainted_Itype `orpred` (R_type `andpred` tainted_Rtype)
     `THEN` PUpd (fun _ => EVal TAINTED)
     `ELSE` PUpd (fun _ => EVal NOT_TAINTED).

  (*Here's an alternative implementation of taint64 that inputs just the required bits:
    in[0] = is_rtype, in[1] = rs_taint, in[2] = rt_taint, in[3] = pc_taint.*)
  Definition TaintTy := TArr 4 TBit.
  Lemma zlt4: 0 < 4. omega. Qed.
  Lemma olt4: 1 < 4. omega. Qed.
  Lemma tlt4: 2 < 4. omega. Qed.
  Lemma thlt4: 3 < 4. omega. Qed.
  Definition taint: pol TaintTy TBit :=
    let rtype_idx := @Fin.of_nat_lt 0 4 zlt4 in
    let rs_taint_idx := @Fin.of_nat_lt 1 4 olt4 in
    let rt_taint_idx := @Fin.of_nat_lt 2 4 tlt4 in
    let pc_taint_idx := @Fin.of_nat_lt 3 4 thlt4 in
    @PUpd TaintTy TBit _ _ (fun ax: exp TaintTy =>
            match ax with
            | EVar _ a =>
              let is_rtype := EDeref rtype_idx a in
              let rs_taint := EDeref rs_taint_idx a in
              let rt_taint := EDeref rt_taint_idx a in
              let pc_taint := EDeref pc_taint_idx a in
              EBinop OOr pc_taint (EBinop OOr rs_taint (EBinop OAnd is_rtype rt_taint))
            | _ => @EVal TBit _ false (*BOGUS: Can't occur by defn. of compile_pol.*)
            end).
End taint.

(*Section thesis_example.
  Definition KernelPC := BFieldRange (ofromz 8191 (*0x0FFF*)
*)
(*Require Import extraction.*)

(* print the program *)

Definition i : id TVec64 := "i".
Definition o : id TVec64 := "o".
Definition ri : id TVec64 := "ri".
Definition ro : id TVec64 := "ro".

Definition sec_jmp_compiled : prog := compile i o sec_jmp.
Definition SFI_compiled : prog := compile ri ro sfi.

Definition sec_jmp_sfi : prog := compile i o (PConcat sec_jmp sfi).
Opaque sec_jmp.
Opaque sfi.

Definition taint_i: id TaintTy := "ti".
Definition taint_o: id TBit := "to".
Definition taint_compiled : prog := compile taint_i taint_o taint.

Definition scf_compiled : prog := compile i o scf.

Definition pretty_print_sec_jmp :=
  pretty_print_tb "secjmp" sec_jmp_compiled.
Definition pretty_print_SFI :=
  pretty_print_tb "SFI" SFI_compiled.
Definition pretty_print_taint :=
  pretty_print_tb "taint" taint_compiled.
Definition pretty_print_SCF :=
  pretty_print_tb "SCF" scf_compiled.

(* run the program 'secjmp.hs' and pipe to a file to get verilog *)
Extract Constant main => "Prelude.putStrLn pretty_print_sec_jmp".
Extraction "secjmp.hs" pretty_print_sec_jmp main.
Extract Constant main => "Prelude.putStrLn pretty_print_SFI".
Extraction "SFI.hs" pretty_print_SFI main.
Extract Constant main => "Prelude.putStrLn pretty_print_taint".
Extraction "taint.hs" pretty_print_taint main.
Extract Constant main => "Prelude.putStrLn pretty_print_SCF".
Extraction "SCF.hs" pretty_print_SCF main.


Require sf_imp.
Require sf_spec.
Require Import sf_lemmas.
Require Import RelDec.
Require Import List.
Require Import Sorted.
Require Import Permutation.
Require Import FunctionalExtensionality.
Require Import Classical.
Require Import sf_tactic.
Require Import Coq.Numbers.BinNums.
Require Import Coq.NArith.BinNat.

Import ListNotations.

Section cand.

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

Local Open Scope N_scope.

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

Lemma no_viable_candidates_correct :
forall rec bal,
sf_imp.no_viable_candidates candidate _ rec bal = true ->
sf_spec.no_viable_candidates candidate (in_record rec) bal.
Proof.
solve_rcv.
specialize (H _ H0). solve_rcv.
apply H in H1.
Unset Ltac Debug.
solve_rcv.
Qed.

Lemma eliminated_correct :
forall rec can,
sf_imp.eliminated candidate _ rec can = true <->
in_record rec can.
Proof.
split; solve_rcv.
 exists x. solve_rcv. intuition.
 exists can.  solve_rcv.
Qed.

(*
Definition no_viable_candidates eliminated (b : sf_spec.ballot candidate) :=
Forall (Forall eliminated) b.

Lemma no_viable_candidates_Forall :
forall eliminated b,
no_viable_candidates eliminated b <->
sf_spec.no_viable_candidates candidate eliminated b.
Proof.
intros.
unfold no_viable_candidates.
unfold sf_spec.no_viable_candidates.
intuition. rewrite Forall_forall in *.
specialize (H rank). rewrite Forall_forall in H.
intuition.
rewrite Forall_forall. intro. rewrite Forall_forall. intuition.
specialize (H x). intuition.
Qed.*)

Ltac force_specialize P :=
repeat
match goal with
| [ H : _ |- _] => extend (P H)
end.

Ltac force_specialize_all :=
repeat
match goal with
| [ H : (forall x, _) |- _ ] => progress (force_specialize H)
end.

Lemma next_ranking_not_overvote :
forall rec bal cd bal' a,
sf_imp.next_ranking candidate _ rec (a :: bal) = Some (cd, bal') ->
~sf_spec.overvote candidate a.
Proof.
intros. intro.
simpl in *.
destruct a; solve_rcv;
force_specialize_all;
simpl in *; intuition; subst; solve_rcv.
Qed.

Lemma next_ranking_selects : forall a bal cd bal' rec,
    sf_imp.next_ranking candidate reldec_candidate rec (a :: bal) =
    Some (cd, bal') ->
    sf_spec.does_not_select candidate (in_record rec) a ->
    sf_imp.next_ranking candidate reldec_candidate rec (bal) = Some (cd, bal').
Proof.
intros.
destruct a; simpl in *; solve_rcv.
destruct H0; solve_rcv.
assert (x=cd).
simpl in H0; intuition; force_specialize_all; solve_rcv.
subst. clear H0.
force_specialize_all; solve_rcv.
force_specialize_all; solve_rcv.
Qed.

Hint Resolve next_ranking_not_overvote : rcv.

Lemma next_ranking_correct :
forall rec bal cd bal' ,
sf_imp.next_ranking candidate _ rec bal = Some (cd, bal') ->
exists h t,(sf_spec.next_ranking candidate (in_record rec) bal (h::t) /\ Forall (Logic.eq cd) (h::t)).
Proof.
intros.
induction bal.
- solve_rcv.
- solve_rcv.
  destruct (sf_spec.ranking_cases _  (in_record rec) a); [ | destruct H0].
  + apply next_ranking_not_overvote in H. intuition.
  + solve_rcv. destruct a; simpl in *; solve_rcv.
    * { destruct H1.
        - exfalso. apply H2.
          subst. exists x2. auto.
        - exists x0; exists (x1); solve_rcv.
          + constructor; solve_rcv.
            * exists x2. split; auto.
              destruct H7. subst; auto.
              force_specialize_all; solve_rcv.
            * force_specialize_all; solve_rcv.
      }
    * { destruct H1.
        - subst. exists x. exists a. solve_rcv.
          eapply sf_spec.next_ranking_valid; solve_rcv.
        - exists cd.  exists a.
          solve_rcv. eapply sf_spec.next_ranking_valid; solve_rcv.
          simpl in H1. intuition.
          force_specialize_all; solve_rcv.
      }
  + apply next_ranking_selects in H; auto.
    solve_rcv.
    exists x; solve_rcv. exists x0.
    destruct H0; solve_rcv. constructor; solve_rcv.
    constructor; solve_rcv. force_specialize_all; solve_rcv.
    force_specialize_all; solve_rcv.
Qed.

(* These don't have meaning anymore now that overvote is a ranking
   level predicate

Lemma overvote_cons_or :
forall b1 bal e ,
sf_spec.overvote candidate e (b1 :: bal) ->
sf_spec.overvote candidate e [b1] \/ sf_spec.overvote candidate e bal.
Proof.
intros.
inv H.
intuition.
destruct H1. destruct H0.
intuition.
edestruct (next_ranking_cons_or); eauto.
- unfold sf_spec.overvote.
  left. exists x. split; eauto.
- right. unfold sf_spec.overvote. exists x; split; eauto.
Qed.

Lemma next_ranking_not_overvote :
forall rec bal cd bal',
sf_imp.next_ranking candidate _ rec bal = Some (cd, bal') ->
~sf_spec.overvote candidate (in_record rec) bal.
Proof.
intros.
induction bal.
- simpl in *. congruence.
- simpl in *.
  destruct a.
  + intro.
    unfold sf_spec.overvote in H0.
    destruct H0.
    destruct H0.
    simpl in H0.
    intuition.
    unfold sf_spec.overvote in H2. apply H2. eauto.
    subst. destruct H1. destruct H1. intuition.
  + destruct (forallb (eq_dec c) a) eqn:?.
    * { destruct (sf_imp.eliminated candidate reldec_candidate rec c) eqn:?.
        - intuition.
          edestruct (overvote_cons_or); eauto.
          + rewrite forallb_forall in *.
            clear -H2 Heqb reldec_correct_candidate.
            inversion H2. intuition.
            inversion H0. intuition.
            intuition. subst. intuition.
            destruct H1. destruct H.
            intuition. apply H5.
            simpl in *. intuition; subst; auto.
            * specialize (Heqb x0). intuition.
              apply reldec_correct_candidate in H. auto.
            * specialize (Heqb x). intuition.
              apply reldec_correct_candidate in H. auto.
            * assert (x = c).
              specialize (Heqb x). intuition. apply reldec_correct_candidate in H.
              auto.
              assert (x0 = c).
              specialize (Heqb x0). intuition. apply reldec_correct_candidate in H7.
              auto.
              subst. auto.
        - inv H. intro.
          inv H. clear IHbal.
          intuition.
          destruct H1. destruct H0. intuition. inv H.
          destruct H2. specialize (H cd). simpl in H. intuition.
          rewrite <- eliminated_correct in H. congruence.
          intuition. subst.
          apply H3.
          rewrite forallb_forall in Heqb.
          simpl in *. intuition; subst; auto.
          + specialize (Heqb _ H1). apply reldec_correct_candidate in Heqb.
            auto.
          + specialize (Heqb _ H2). apply reldec_correct_candidate in Heqb.
            auto.
          + assert (x0 = cd); subst.
            specialize (Heqb _ H2). apply reldec_correct_candidate in Heqb. auto.
            assert (x1 = cd); subst.
            specialize (Heqb _ H1). apply reldec_correct_candidate in Heqb. auto.
            auto. }
    * congruence.
Qed. *)

Lemma next_ranking_viable :
forall bal rec cd bal',
sf_imp.next_ranking candidate reldec_candidate rec bal =
      Some (cd, bal') ->
~sf_spec.no_viable_candidates candidate (in_record rec) bal.
Proof.
induction bal; intros.
- simpl in *. congruence.
- simpl in *. destruct a.
  + intro. apply no_viable_candidates_cons in H0. destruct H0.
    eapply IHbal in H1; eauto.
  + destruct (forallb (eq_dec c) a).
    * { destruct (sf_imp.eliminated candidate reldec_candidate rec c) eqn:?.
        - apply eliminated_correct in Heqb.
          intro. apply no_viable_candidates_cons in H0.
          destruct H0.
          eapply IHbal in H1; eauto.
        - inv H. intro. apply no_viable_candidates_cons in H. destruct H.
          unfold sf_spec.no_viable_candidates in H.
          specialize (H (cd :: a)). simpl in H. intuition. clear H2.
          specialize (H cd). intuition. clear H2.
          rewrite <- eliminated_correct in H. congruence.
      }
    * congruence.
Qed.

Lemma next_ranking_selected :
forall bal cd bal' rec,
sf_imp.next_ranking candidate _ rec bal = Some (cd, bal') ->
sf_spec.selected_candidate candidate (in_record rec) bal cd.
solve_rcv.
- destruct H0.
 + apply H0; clear H0.
   apply next_ranking_correct in H.
   solve_rcv.
 + destruct bal; solve_rcv.
   copy H.
   apply next_ranking_correct in H. solve_rcv.
   unique; subst.
   force_specialize_all; solve_rcv.
- apply next_ranking_correct in H; solve_rcv.
  exists (x :: x0); solve_rcv.  simpl in *.
  force_specialize_all; solve_rcv; intuition.
Qed.

Lemma next_ranking_eliminated :
forall bal rec,
sf_imp.next_ranking candidate _ rec bal = None ->
sf_spec.exhausted_ballot candidate (in_record rec) bal.
Proof.
intros.
induction bal.
- left. solve_rcv.
- simpl in *. destruct a; solve_rcv.
  + destruct IHbal; solve_rcv.
    * left. intro. apply H0. solve_rcv.
      exists x. inv H1; solve_rcv.
    * right. exists x. solve_rcv. constructor; solve_rcv.
  + destruct IHbal.
    * left. intro. apply H2; solve_rcv.
      { inv H3.
        - solve_rcv.
        - destruct H8; solve_rcv.
          + exfalso. simpl in *. repeat (intuition; subst); force_specialize_all; solve_rcv.
          + inv H6; solve_rcv.
            * exfalso. apply H3. clear H3. exists x; solve_rcv.
            * force_specialize_all. solve_rcv.
              exfalso. apply H3; solve_rcv.
      }
    * right. solve_rcv.
      exists x1; solve_rcv.
      constructor; solve_rcv. exists x; inv H6; force_specialize_all; solve_rcv.
      simpl in *. intuition; force_specialize_all; solve_rcv.
  + right. clear IHbal. exists (c::a). solve_rcv.
    eapply sf_spec.next_ranking_valid. simpl. auto.
    left. solve_rcv. exists x. exists c.
    simpl. auto.
    exists x. exists c. simpl. auto.
Qed.

Definition boolCmpToProp {A} (c : A -> A -> bool) :=
fun a b => match c a b with
           | true => True
           | false => False
end.

Lemma insert_sorted : forall {A} c sorted (a : A),
    (forall a b, c a b = false -> c b a = true) ->
    Sorted (boolCmpToProp c) sorted ->
    Sorted (boolCmpToProp c) (sf_imp.insert c a sorted).
intros.
induction H0.
- simpl. auto.
- simpl.
  destruct (c a a0) eqn:?.
  constructor. auto. constructor. unfold boolCmpToProp. rewrite Heqb. auto.
  constructor. auto.
  clear IHSorted H0.
  induction l.
  + simpl in *.
    constructor. unfold boolCmpToProp. apply H in Heqb. rewrite Heqb.
    auto.
  + simpl in *. destruct (c a a1) eqn:?. constructor. apply H in Heqb.
    unfold boolCmpToProp. rewrite Heqb. auto.
    constructor; auto.
    unfold boolCmpToProp.
    apply H in Heqb. inv H1. unfold boolCmpToProp in H2.
    auto.
Qed.

Lemma insertion_sort_sorted' : forall {A} (l : list A) (sorted : list A) c,
    (forall a b, c a b = false -> c b a = true) ->
    Sorted (boolCmpToProp c) sorted ->
    Sorted (boolCmpToProp c) (sf_imp.insertionsort' c l sorted).
Proof.
induction l.
+ intros. simpl. auto.
+ intros. simpl in *. apply IHl; auto.
  apply insert_sorted; auto.
Qed.

Lemma insertion_sort_sorted : forall {A} (l : list A) c,
    (forall a b, c a b = false -> c b a = true) ->
    Sorted (boolCmpToProp c) (sf_imp.insertionsort c l).
intros.
apply insertion_sort_sorted'; auto.
Qed.

Lemma insert_permutation :
  forall {A} l2 l1  (a : A) c,
    Permutation l1 l2 ->
    Permutation (a :: l1) (sf_imp.insert c a l2).
Proof.
induction l2; intros.
- apply Permutation_sym in H. apply Permutation_nil in H. subst. simpl in *. auto.
- simpl in *. destruct (c a0 a).
  constructor. auto.
  eapply Permutation_trans. instantiate (1:= (a0 :: a :: l2)).
  auto. rewrite perm_swap. constructor.
  apply IHl2. auto.
Qed.

Lemma insertion_sort_permutation' :
  forall {A} (le ls : list A) c sorted,
    Permutation ls sorted ->
    Permutation (ls ++ le) (sf_imp.insertionsort' c le sorted).
Proof.
induction le; intros.
- simpl in *. rewrite app_nil_r. auto.
- simpl. rewrite <- Permutation_middle.
  rewrite app_comm_cons.
  apply IHle. apply insert_permutation. auto.
Qed.

Lemma insertion_sort_permutation :
  forall {A} (l : list A) c,
    Permutation l (sf_imp.insertionsort c l).
intros. rewrite <- app_nil_l at 1.
unfold sf_imp.insertionsort.
apply insertion_sort_permutation'. auto.
Qed.

Definition tb_func_to_Prop {c : Set} (f : list c -> option c) :=
fun l cd => match f l with
         | Some x => x = cd
         | None => False
end.

Lemma in_split : forall A B (f : A) (l : list (A * B)),
              In f (fst (split l)) ->
              exists n : B, In (f, n) l.
Proof.
induction l; intros.
- simpl in *. inv H.
- simpl in *. destruct a. simpl in *.
  destruct (split l) eqn:?.
  simpl in *. destruct H.
  + subst. eauto.
  + intuition. destruct H0. eauto.
Qed.

Lemma rel_dec_refl : forall c, rel_dec c c = true.
Proof.
intros. apply rel_dec_correct. auto.
Qed.

Lemma increment_spec : forall (m : list (candidate *  N)) cd cds (ct : N),
cds = (fst (split m)) ->
NoDup (cds) ->
(In (cd, ct) m -> In (cd, (ct + 1)%N) (sf_imp.increment candidate _ m cd)) /\
(~In cd cds -> In (cd, 1%N) (sf_imp.increment candidate _ m cd)).
Proof.
induction m; intros.
- simpl in *. intuition.
- simpl in *. destruct a.
  destruct (split m) eqn:?.
  simpl in *.
  destruct (in_dec rel_dec_p cd cds).
  + subst.
    split.
    * { intros. simpl in *.
        unfold eq_dec.
        intuition.
        - inv H2.  rewrite rel_dec_refl.
          simpl. auto.
        - subst. clear -Heqp H2 H0.
          inv H0. assert (In cd l). apply in_split_l in H2.
          simpl in H2. rewrite Heqp in *. auto.
          intuition.
        - inv H2. inv H0. intuition.
        - assert (c <> cd).
          intro. subst. inv H0. intuition.
          eapply rel_dec_neq_false in H.
          rewrite H. simpl. right.
          edestruct IHm. reflexivity.
          inv H0; auto.
          clear H4. auto. apply reldec_correct_candidate.
      }
    * intuition.
  + subst. simpl in *. inv H0. unfold eq_dec.
    split.
      * { intuition.
        - inv H0. intuition.
        - eapply rel_dec_neq_false in H. rewrite H.
          edestruct IHm; eauto. simpl in *. auto.
          apply reldec_correct_candidate.
        }
      * intuition. eapply rel_dec_neq_false in H4. rewrite H4.
        simpl.
        edestruct IHm; eauto.
        eapply reldec_correct_candidate.
Grab Existential Variables. exact 0.
Qed.

Lemma increment_not_0 : forall running cd,
NoDup (fst (split running)) ->
~In (cd, 0) (sf_imp.increment candidate reldec_candidate running cd).
Proof.
induction running; intros; intro.
- unfold sf_imp.increment in *. simpl in *; intuition. congruence.
- simpl in *. destruct a. destruct (eq_dec c cd) eqn:?.
  + clear IHrunning. apply reldec_correct_candidate in Heqb. subst.
    simpl in *. destruct (split running) eqn:?. simpl in *.
    inv H. intuition. inv H. rewrite N.add_comm in H1. rewrite N.eq_add_0 in H1.
    intuition. congruence.  apply in_split_l in H.
    simpl in H. rewrite Heqp in H. simpl. intuition.
  + simpl in *. destruct (split running) eqn:?. simpl in *.
    apply neg_rel_dec_correct in Heqb. destruct H0.
    * inv H0. auto.
    * inv H. intuition. eapply IHrunning; eauto.
Qed.

Lemma increment_nodup' : forall running cd c,
~In c (fst (split running)) ->
c <> cd ->
~In c (fst (split (sf_imp.increment candidate reldec_candidate running cd))).
Proof.
induction running; intros.
- simpl in *. intuition.
- simpl in *.
  destruct a.
  destruct (split running) eqn:?. simpl in H. intuition.
  destruct (eq_dec c0 cd) eqn:?.
  + simpl in *. rewrite Heqp in *. simpl in *. intuition.
  + simpl in *. destruct (split
                   (sf_imp.increment candidate reldec_candidate running cd)) eqn:?.
    simpl in *. intuition. eapply IHrunning; eauto.
    rewrite Heqp0. simpl. auto.
Qed.

Lemma increment_nodup : forall running cd,
NoDup (fst (split running)) ->
NoDup (fst (split (sf_imp.increment candidate reldec_candidate running cd))).
induction running; intros.
- simpl in *. constructor; auto.
- simpl in *. destruct a. destruct (eq_dec c cd) eqn:?.
  + apply reldec_correct_candidate in Heqb. subst.
    simpl in *.
    destruct (split running) eqn:?. simpl in *. auto.
  + simpl in *. destruct ( split (sf_imp.increment candidate reldec_candidate running cd)) eqn:?.
    simpl.
    destruct (split running) eqn:?. simpl in *. inv H.
    eapply IHrunning in H3. instantiate (1:=cd) in H3. rewrite Heqp in H3.
    simpl in H3. constructor; auto. intro. apply neg_rel_dec_correct in Heqb.
    eapply increment_nodup'; eauto. instantiate (1:=running).
    rewrite Heqp0. simpl. auto.
    rewrite Heqp. auto.
Qed.

Lemma increment_neq : forall running c cd v,
In (c, v) running ->
c <> cd ->
In (c, v) (sf_imp.increment candidate reldec_candidate running cd).
Proof.
induction running; intros.
- inv H.
- destruct a.
  simpl in *.
  destruct (eq_dec c0 cd) eqn:?.
  + simpl in *. intuition.
    apply reldec_correct_candidate in Heqb. inv H1. subst. intuition.
  + simpl in *. intuition.
Qed.

Lemma tabulate_not_0 : forall l cd v running,
NoDup (fst (split running)) ->
In (cd, v) running ->
v <> 0 ->
~In (cd, 0)
   (sf_imp.tabulate'' candidate reldec_candidate l running).
Proof.
induction l; intros.
- simpl in *. intuition. apply H1.
  clear H1. induction running.
  + inv H0.
  + simpl in *. destruct a. destruct (split running) eqn:?. simpl in *.
    intuition.
    * inv H1. inv H0. auto.
    * inv H1. inv H. intuition. apply in_split_l in H0. simpl in *.
      rewrite Heqp in *. simpl in *. intuition.
    * inv H. inv H0. apply in_split_l in H1. rewrite Heqp in *. simpl in *.
      intuition.
    * inv H. intuition.
- simpl in *. destruct a. intro. intuition.
  destruct (rel_dec_p c cd).
  + subst.
    eapply IHl in H2; auto.
    * apply increment_nodup. auto.
    * instantiate (1:=v + 1). edestruct increment_spec. reflexivity.
      apply H. apply H3. auto.
    * intuition.  rewrite N.eq_add_0 in H3. destruct H3. congruence.
  + eapply IHl in H2; auto.
    * apply increment_nodup; auto.
    * instantiate (1:=v). edestruct increment_spec. reflexivity.
      apply H. apply increment_neq; auto.
    * auto.
  + eapply IHl in H0; auto.
Grab Existential Variables. apply 0. apply c. (*ugh*)
Qed.

Lemma opt_eq_dec : forall A,
(forall (a b : A), {a = b} + {a <> b}) ->
forall (a b : option A), {a = b} + {a <> b}.
Proof.
intros.
destruct a, b; auto.
specialize (X a a0). destruct X. subst. auto. right.
intro. inv H. auto.
right. intro. congruence.
right. congruence.
Qed.

Lemma opt_eq_dec_cand :
forall (a b : option candidate), {a = b} + {a <> b}.
Proof.
apply opt_eq_dec. apply rel_dec_p.
Qed.

Lemma NoDup_In_fst :
forall A B l (a :A) (b :B) c,
NoDup (fst (split l)) ->
In (a, b) l ->
In (a, c) l ->
b = c.
Proof.
induction l; intros.
- inv H0.
- simpl in *.
  destruct (split l) eqn:?.
  destruct a. intuition; try congruence.
  + simpl in *. inv H2. inv H. apply in_split_l in H0. simpl in H0.
    rewrite Heqp in *. intuition.
  + simpl in *. inv H. inv H0.
    apply in_split_l in H2. simpl in*. rewrite Heqp in *.
    intuition.
  + eapply IHl; eauto. simpl. simpl in H. inv H. auto.
Qed.

Lemma tab_inc_s : forall cd ct l running running' cr,
NoDup (fst (split running)) ->
NoDup (fst (split running')) ->
In (cd, ct + 1)
   (sf_imp.tabulate'' candidate reldec_candidate l running') ->
In (cd, cr) running ->
In (cd, (cr + 1)) running' ->
In (cd, ct) (sf_imp.tabulate'' candidate reldec_candidate l running).
Proof.
induction l; intros.
- simpl in *.
  assert (cr = ct).
  eapply NoDup_In_fst in H3. instantiate (1:= ct + 1) in H3.
  apply N.add_cancel_r in H3. auto.
  auto. auto. subst. auto.
- simpl in *.
  destruct a.
  + destruct (rel_dec_p cd c).
    * subst. eapply IHl.
      apply increment_nodup. auto.
      apply increment_nodup. apply H0.
      eauto.
      eapply increment_spec in H2; eauto.
      eapply increment_spec in H3; eauto.
    * eapply increment_neq in H2; eauto.
      eapply increment_neq in H3; eauto.
      eapply IHl.
      apply increment_nodup. auto.
      apply increment_nodup. apply H0.
      apply H1.
      eauto.
      eauto.
  + eapply IHl; eauto.
Qed.

Lemma increment_neq' : forall running cd ct  c,
In (cd, ct) (sf_imp.increment candidate reldec_candidate running c) ->
c <> cd ->
In (cd, ct) running.
Proof.
induction running; intros.
- simpl in H. intuition. congruence.
- simpl in *. destruct a.
  + destruct (eq_dec c0 c) eqn:?.
    apply rel_dec_correct in Heqb. subst.
    simpl in *. intuition. inv H1. intuition.
    simpl in *. intuition.
    right. eapply IHrunning; eauto.
Qed.

Lemma tabulate''_same : forall cd l running running' cr ct,
NoDup (fst (split running)) ->
NoDup (fst (split running')) ->
In (cd, cr) running ->
In (cd, cr) running' ->
In (cd, ct) (sf_imp.tabulate'' candidate reldec_candidate l running) ->
In (cd, ct) (sf_imp.tabulate'' candidate reldec_candidate l running').
Proof.
induction l; intros.
- simpl in *.
  assert (cr = ct).
  eapply NoDup_In_fst. apply H.
  apply H1. apply H3. subst.
  auto.
- simpl in *.
  destruct a.
  + destruct (rel_dec_p cd c).
    * eapply IHl.
      apply increment_nodup. apply H.
      apply increment_nodup. auto.
      subst.
      eapply increment_spec in H1. apply H1.
      auto. auto.
      subst. eapply increment_spec in H2; eauto.
      eauto.
    * eapply IHl.
      apply increment_nodup. apply H.
      apply increment_nodup. auto.
      eapply increment_neq in n. apply n. eauto.
      eapply increment_neq in n.
      eauto. auto.
      eauto.
  + eapply IHl; eauto.
Qed.

Lemma tabulate''_same_notin : forall cd ct l running running',
NoDup (fst (split running)) ->
NoDup (fst (split running')) ->
~In cd (fst (split running)) ->
~In cd (fst (split running')) ->
In (cd, ct) (sf_imp.tabulate'' candidate reldec_candidate l running) ->
In (cd, ct) (sf_imp.tabulate'' candidate reldec_candidate l running').
Proof.
induction l; intros.
- simpl in *. intuition.
  apply in_split_l in H3. simpl in H3. intuition.
- simpl in *.
  destruct a; try solve [eapply IHl; eauto].
  destruct (rel_dec_p cd c).
  + subst. eapply increment_spec in H1; eauto.
    eapply increment_spec in H2; eauto.
    eapply (tabulate''_same _ _ _ _ _ _ _ _ _ H2).
    eauto.
  + eapply IHl. apply H.
    apply increment_nodup. auto. auto. apply increment_nodup'; eauto.
    eapply IHl in H3. eauto.
    apply increment_nodup. auto. auto. apply increment_nodup'; eauto.
    auto. Grab Existential Variables. auto.
    apply increment_nodup. auto. apply increment_nodup. auto.
Qed.

Lemma tab_inc_s_l :
forall l cd ct running,
In (cd, ct + 1) (sf_imp.tabulate'' candidate reldec_candidate l
               (sf_imp.increment candidate reldec_candidate running cd)) ->
~ In cd (fst (split running)) ->
NoDup (fst (split running)) ->
In (Some cd) l ->
In (cd, ct) (sf_imp.tabulate'' candidate reldec_candidate l running).
Proof.
induction l; intros.
- inv H2.
- simpl in *. destruct a.
  destruct (rel_dec_p cd c).
  + subst. clear H2.
    simpl in *. eapply increment_spec in H0; auto.
    copy H0.
    eapply increment_spec in H0; auto.
    eapply tab_inc_s. apply increment_nodup. auto. apply increment_nodup.
    apply increment_nodup. eauto. eauto. eauto. eauto.
    apply increment_nodup. auto.
  + destruct H2. congruence.
    eapply tabulate''_same_notin.
    eauto. apply increment_nodup. auto.
    auto.
    apply increment_nodup'; auto.
    eapply IHl; eauto.
    eapply (tabulate''_same) in H.
    apply H. apply increment_nodup. apply increment_nodup.
    auto. apply increment_nodup. auto.
    apply increment_neq; auto. eapply increment_spec in H0; eauto.
    eapply increment_spec in H0; eauto.
  + intuition. congruence.
Qed.

Lemma tabulate_not_in_l :
forall l cd ct running,
NoDup (fst (split running)) ->
In (cd, ct) running ->
~In (Some cd) l ->
In (cd, ct) (sf_imp.tabulate'' candidate reldec_candidate l running).
Proof.
induction l; intros.
- simpl. auto.
- simpl in *.
  destruct a; intuition; try congruence.
  eapply IHl; eauto. apply increment_nodup. auto.
  apply increment_neq; auto. intuition. subst. auto.
Qed.

Lemma tabulate_nodup :
forall l running,
NoDup (fst (split running)) ->
NoDup (fst (split (sf_imp.tabulate'' candidate reldec_candidate l running))).
Proof.
induction l; intros.
- simpl.  auto.
- simpl in *.
  destruct a.
  + apply IHl. apply increment_nodup; auto.
  + apply IHl. auto.
Qed.

Lemma selected_not_in :
forall  ef l cd r l0,
~(In (Some cd ) l) ->
sf_imp.option_split
           (map (sf_imp.next_ranking candidate reldec_candidate r) ef) =
         (l, l0) ->
sf_spec.first_choices candidate (in_record r) cd ef 0.
Proof.
induction ef; intros.
- simpl in *. inv H0. constructor.
- simpl in *.
  destruct (sf_imp.next_ranking candidate reldec_candidate r a) eqn:?.
  + destruct p. destruct (sf_imp.option_split
                            (map (sf_imp.next_ranking candidate reldec_candidate r) ef)) eqn:?.
    simpl in *. inv H0. simpl in *.
    intuition.
    apply next_ranking_selected in Heqo.
    constructor.
    intro. eapply sf_spec.selected_candidate_unique in Heqo; eauto.
    subst; auto.
    eapply IHef; eauto.
  + destruct (sf_imp.option_split
              (map (sf_imp.next_ranking candidate reldec_candidate r) ef)) eqn:?.
    inv H0.
    simpl in *.
    apply sf_spec.first_choices_not_selected.
    intro. intuition. unfold sf_spec.selected_candidate in H0.
    destruct H0. apply next_ranking_eliminated in Heqo.
    unfold sf_spec.continuing_ballot in H. intuition.
    eapply IHef; eauto.
Qed.

Lemma increment_same_s :
forall c running,
NoDup (fst (split running)) ->
exists n, In (c, n + 1) (sf_imp.increment candidate _ running c).
intros.
destruct (in_dec rel_dec_p c (fst (split running))).
apply in_split in i. destruct i.
exists x. eapply increment_spec in H; eauto.
destruct H. apply H. auto.
exists 0. eapply increment_spec in n; eauto. apply 0.
Qed.

Lemma tabulate''_first_choices : forall ef cd ct es running r
(NODUP : NoDup (fst (split running))),
In (cd, ct) (sf_imp.tabulate'' candidate _
                               (fst (sf_imp.option_split
                                      (map (sf_imp.next_ranking candidate reldec_candidate r)
                                           ef))) running) ->
(forall cnd, ~In cnd (fst (split running)) -> sf_spec.first_choices candidate (in_record r) cnd es 0) ->
Forall (fun x => let (cnd, n) := (x: candidate * N)
                 in sf_spec.first_choices candidate (in_record r) cnd es (N.to_nat n)) running ->
sf_spec.first_choices candidate (in_record r) cd (es ++ ef) (N.to_nat ct).
Proof.
induction ef; intros.
- simpl in *. rewrite Forall_forall in *. specialize (H1 _ H). simpl in H1.
  rewrite app_nil_r.  auto.
- simpl in H.
  assert (Permutation (a :: (es ++ ef)) (es ++ a :: ef)).
  apply Permutation_middle.
  eapply first_choices_perm; eauto. clear H2.
  destruct (sf_imp.next_ranking candidate reldec_candidate r a) eqn:?.
  +  destruct p. destruct (sf_imp.option_split
                     (map (sf_imp.next_ranking candidate reldec_candidate r)
                          ef)) eqn:?. simpl in *.
     apply next_ranking_selected in Heqo.
     destruct (rel_dec_p c cd).
     * subst.
       { destruct ct.
         - clear - H NODUP.
           assert (X := increment_same_s cd running NODUP).
           destruct X.
           exfalso. eapply tabulate_not_0; [ | | | apply H]; eauto.
           apply increment_nodup. auto. intro. rewrite N.eq_add_0 in H1. intuition; congruence.
         - assert (exists p', N.to_nat (N.pos p) = S p').
           rewrite Znat.positive_N_nat.
           apply Pnat.Pos2Nat.is_succ. destruct H2. rewrite H2 in *.
           apply sf_spec.first_choices_selected; auto.
           destruct (in_dec rel_dec_p cd (fst (split running))).
           + rewrite <- (Nnat.Nat2N.id x). eapply IHef; eauto.
             edestruct in_split. apply i.
             eapply tab_inc_s; auto.
             apply increment_nodup. eauto.
             rewrite Heqp. simpl.
             assert (N.of_nat x+1 = N.pos p).
             assert (1 = (N.of_nat 1)). auto. rewrite H4.
             rewrite <- Nnat.Nat2N.inj_add.
             rewrite Plus.plus_comm. simpl (1 + x)%nat.
             rewrite <- H2. rewrite Nnat.N2Nat.id. auto.
             rewrite H4.
             eauto.
             apply H3. eapply increment_spec in H3; eauto.
           + destruct (in_dec opt_eq_dec_cand (Some cd) l).
             * rewrite <- (Nnat.Nat2N.id x).
               eapply IHef; eauto.
               rewrite Heqp. simpl.
               apply tab_inc_s_l; auto.
               assert (N.of_nat x+1 = N.pos p).
               assert (1 = (N.of_nat 1)). auto. rewrite H3.
               rewrite <- Nnat.Nat2N.inj_add.
               rewrite Plus.plus_comm. simpl (1 + x)%nat.
               rewrite <- H2. rewrite Nnat.N2Nat.id. auto.
               rewrite H3.
               eauto.
             * copy n. eapply increment_spec in n; eauto.
               eapply tabulate_not_in_l in n; eauto.
               assert (1 = (Npos p)). eapply NoDup_In_fst; [ | eauto | eauto ].
               apply tabulate_nodup. apply increment_nodup. auto.
               assert (1%nat = (S x)). rewrite <- H2.
               rewrite <- H4. simpl. auto.
               rewrite <- H4 in *. inv H5.
               change 0%nat with (0 + 0)%nat.
               { apply first_choices_app.
                 - apply H0. auto.
                 - eapply selected_not_in; eauto.
               }
               apply increment_nodup; auto. constructor.
       }
     * apply sf_spec.first_choices_not_selected. intro.
       apply n. eapply sf_spec.selected_candidate_unique; eauto.
       { destruct (in_dec rel_dec_p cd (fst (split running))).
         - copy i. apply in_split in H2. destruct H2.
           eapply IHef; eauto.
           rewrite Heqp. simpl. eapply tabulate''_same in H; eauto.
           eauto.
           apply increment_nodup. auto.
           apply increment_neq; auto.
         - eapply IHef; eauto.
           rewrite Heqp. simpl.
           eapply tabulate''_same_notin in H.
           eauto. apply increment_nodup. auto.
           auto. intro.
           apply in_split in H2.
           destruct H2.
           apply n0.
           eapply increment_neq' in H2.
           apply in_split_l in H2. auto.
           auto. auto.
       }
  + destruct ( sf_imp.option_split
                 (map (sf_imp.next_ranking candidate reldec_candidate r)
                      ef)) eqn:?.
    simpl in *.
    apply next_ranking_eliminated in Heqo.
    apply sf_spec.first_choices_not_selected.
    intro. unfold sf_spec.selected_candidate in H2.
    intuition.
    eapply IHef; eauto. rewrite Heqp. simpl. auto.
Qed.

Lemma tabulate'_first_choices : forall l cd ct  r,
In (cd, ct) (sf_imp.tabulate' _ _ (fst (sf_imp.option_split
                                      (map (sf_imp.next_ranking candidate reldec_candidate r)
                                           l)))) ->
sf_spec.first_choices candidate (in_record r) cd (l) (N.to_nat ct).
Proof.
intros.
rewrite <- app_nil_l at 1.
eapply tabulate''_first_choices in H. eauto.
constructor.
intros. constructor.
constructor.
Qed.

Lemma tabulate_correct : forall rec election rs election',
sf_imp.tabulate candidate _ rec election = (rs, election') ->
Forall (fun (x: (candidate * N)) => let (cd, fc) := x in
                 sf_spec.first_choices candidate (in_record rec) cd election (N.to_nat fc)) rs.
Proof.
intros.
unfold sf_imp.tabulate in H. destruct (sf_imp.option_split
             (map (sf_imp.next_ranking candidate reldec_candidate rec)
                election)) eqn:?.
assert (PRM := insertion_sort_permutation (sf_imp.tabulate' candidate reldec_candidate l)
                                          (sf_imp.cnle candidate)).
rewrite Forall_forall. intros. destruct x. destruct ((sf_imp.insertionsort (sf_imp.cnle candidate)
         (sf_imp.tabulate' candidate reldec_candidate l),
      sf_imp.drop_none l0)) eqn:?. inv H.
inv Heqp0.
apply Permutation_sym in PRM.
eapply Permutation_in in PRM; eauto.
assert (l = fst (sf_imp.option_split
           (map (sf_imp.next_ranking candidate reldec_candidate rec) election))).
rewrite Heqp. auto.  subst.
clear H0.
apply tabulate'_first_choices in PRM. auto.
Qed.

(*Lemma leb_false :
forall n0  n,
NPeano.leb n0 n = false ->
n <= n0.
Proof.
induction n0; intros.
- inv H.
- simpl in *.  destruct n.
  omega.
  apply IHn0 in H. omega.
Qed.*)

Lemma tabulate_sorted :
forall rec election rs election',
sf_imp.tabulate _ _ rec election = (rs, election') ->
Sorted (boolCmpToProp (sf_imp.cnle candidate)) rs.
Proof.
intros.
intros.
unfold sf_imp.tabulate in H. destruct (sf_imp.option_split
             (map (sf_imp.next_ranking candidate reldec_candidate rec)
                election)) eqn:?.
inv H. apply insertion_sort_sorted.
intros. unfold sf_imp.cnle. destruct b.
destruct a. simpl in *. rewrite N.leb_le in *.
rewrite N.leb_gt in *. apply N.lt_le_incl in H. auto.
Qed.

Lemma tabulate_continuing :
forall election rs election' rec,
sf_imp.tabulate _ _ rec election = (rs, election') ->
Forall (fun x =>~ in_record rec x)(fst (split rs)) .
Proof.
  intros.
unfold sf_imp.tabulate in *.
Check sf_imp.increment.

Lemma increment_not_eliminated :
forall vs c rec,
~(in_record rec c) ->
Forall (fun cd =>  ~(in_record rec cd)) (fst (split vs)) ->
Forall (fun cd => ~(in_record rec cd)) (fst (split (sf_imp.increment candidate _ vs c))).
Proof.
induction vs; intros.
- simpl in *. auto.
- simpl in *. rewrite Forall_forall in *.
  intros. destruct a.
  destruct (eq_dec c0 c) eqn:?.
  + simpl in *. destruct (split vs) eqn:?.
    simpl in *. intuition. subst. apply reldec_correct_candidate in Heqb.
    subst. intuition.
    specialize (H0 x). intuition.
  + simpl in *. destruct (split (sf_imp.increment candidate reldec_candidate vs c)) eqn:?.
    simpl in *. intuition.
    * subst. specialize (H0 x).
      destruct (split vs) eqn:?. simpl in *. intuition.
    * eapply IHvs in H; eauto.
      rewrite Forall_forall in H.
      eapply H; eauto.
      rewrite Heqp. auto.
      rewrite Forall_forall. intros.
      specialize (H0 x0). destruct (split vs).
      simpl in *. intuition.
Qed.

Lemma tabulate''_continuing : forall ef cd ct  running r,
In (cd, ct) (sf_imp.tabulate'' candidate _
                               (fst (sf_imp.option_split
                                      (map (sf_imp.next_ranking candidate reldec_candidate r)
                                           ef))) running) ->
Forall (fun x => ~(in_record r x)) (fst (split running)) ->
~(in_record r cd).
Proof.
induction ef; intros.
- simpl in *. rewrite Forall_forall in H0.
  specialize (H0 (cd)). intuition. apply H0; auto.
  apply in_split_l in H. simpl in H. auto.
- simpl in *. destruct ( sf_imp.next_ranking candidate reldec_candidate r a) eqn:?.
  + destruct p. apply next_ranking_selected in Heqo.
    destruct (sf_imp.option_split
                (map (sf_imp.next_ranking candidate reldec_candidate r)
                     ef)) eqn:?. simpl in *.
    apply sf_spec.selected_candidate_not_eliminated in Heqo.
    eapply increment_not_eliminated in Heqo; eauto.
    eapply IHef. rewrite Heqp. simpl. eauto.
    auto.
  + destruct (sf_imp.option_split
                (map (sf_imp.next_ranking candidate reldec_candidate r)
                     ef)) eqn:?.
    simpl in *.
    eapply IHef. rewrite Heqp. simpl. eauto.
    eauto.
Qed.

Lemma tabulate''_first_choices_complete : forall ef cd ct es running r
(NODUP : NoDup (fst (split running))),
(forall cnd cnt,
cnt <> 0 ->
sf_spec.first_choices candidate (in_record r) cnd es (N.to_nat cnt) -> In (cnd, cnt) running) ->
ct <> 0 ->
sf_spec.first_choices candidate (in_record r) cd (es ++ ef) (N.to_nat ct) ->
In (cd, ct) (sf_imp.tabulate'' candidate _
                               (fst (sf_imp.option_split
                                      (map (sf_imp.next_ranking candidate reldec_candidate r)
                                           ef))) running).
Proof.
induction ef; intros.
- simpl in *. rewrite app_nil_r in *. intuition.
Admitted.
(*
- simpl in *.
  destruct ( sf_imp.next_ranking candidate reldec_candidate r a ) eqn:?.
  + destruct p. simpl.
    destruct (sf_imp.option_split
                (map (sf_imp.next_ranking candidate reldec_candidate r) ef)) eqn:?.
    simpl in *. assert (Permutation (es ++ a :: ef) (a :: (es ++ ef))).
    rewrite Permutation_middle. auto.
    eapply first_choices_perm in H1; eauto.
    clear H0.
    inv H1.
    * apply next_ranking_selected in Heqo; auto.
      eapply sf_spec.selected_candidate_unique in Heqo; eauto. subst.
      assert (l = fst ( sf_imp.option_split
           (map (sf_imp.next_ranking candidate reldec_candidate r) ef))).
     rewrite Heqp. auto.
     subst.
Admitted. *)

Lemma tabulate'_first_choices_complete : forall l cd ct r,
ct <> 0 ->
sf_spec.first_choices _ (in_record r) cd l (N.to_nat ct) ->
In (cd, ct) (sf_imp.tabulate' _ _
   (fst (sf_imp.option_split (map (sf_imp.next_ranking _ _ r) l)))).
Proof.
intros.
unfold sf_imp.tabulate'.
rewrite <- (app_nil_l l) in H0.
eapply tabulate''_first_choices_complete; eauto; try solve [constructor].
intros. inv H2. assert (cnt = 0). rewrite <- Nnat.Nat2N.inj_iff in H3.
rewrite Nnat.N2Nat.id in H3. auto. subst. congruence.
Qed.

Lemma tabulate_first_choices_complete : forall l cd ct r,
ct <> 0 ->
sf_spec.first_choices _ (in_record r) cd l (N.to_nat ct) ->
In (cd, ct) (fst (sf_imp.tabulate _ _ r l)).
  intros.
  unfold sf_imp.tabulate.
  destruct (sf_imp.option_split
               (map (sf_imp.next_ranking candidate reldec_candidate r) l)) eqn:?.
  eapply Permutation_in.
  apply insertion_sort_permutation.
  assert (l0 = fst (sf_imp.option_split
           (map (sf_imp.next_ranking candidate reldec_candidate r) l))).
  rewrite Heqp. auto.
  subst.
  eapply tabulate'_first_choices_complete. auto.
  auto.
Qed.

Lemma cnlt_trans : Relations_1.Transitive (boolCmpToProp (sf_imp.cnle candidate)).
Proof.
intro. intros.
destruct x, y, z.
unfold boolCmpToProp in *. simpl in *.
destruct (n <=? n0) eqn:?, (n0 <=? n1) eqn:?, (n <=? n1) eqn:?; auto.
rewrite N.leb_le in *.
rewrite N.leb_gt in *.
eapply N.le_trans in Heqb0; eauto.
rewrite N.le_ngt in *. auto.
Qed.

Lemma tabulate''_participates : forall x election n rec,
In (x, n) (sf_imp.tabulate'' _ _ (fst (sf_imp.option_split
                                        (map (sf_imp.next_ranking candidate reldec_candidate rec)
                                             election))) nil) ->
sf_spec.participates candidate x election.
Proof.
induction election; intros.
- simpl in *. inv H.
- simpl in *.
  destruct (sf_imp.next_ranking candidate reldec_candidate rec a) eqn:?.
  + destruct p.
    destruct ( sf_imp.option_split
                 (map
                    (sf_imp.next_ranking candidate reldec_candidate rec)
                    election)) eqn:?.
    simpl in *.
    destruct (rel_dec_p c x).
    * subst.
      apply next_ranking_selected in Heqo.
      eapply selected_participates. eauto.
      simpl. auto.
    * apply participates_cons. right.
      eapply IHelection. instantiate (2 := n).
      assert (fst (sf_imp.option_split
                     (map (sf_imp.next_ranking candidate reldec_candidate rec) election)) = l).
      rewrite Heqp; auto. subst.
      eapply tabulate''_same_notin. instantiate (1 := [(c,1)]).
      repeat constructor. auto. constructor.
      intro. simpl in H0. intuition. auto.
      apply H.
  + destruct (sf_imp.option_split
                     (map
                        (sf_imp.next_ranking candidate reldec_candidate rec)
                        election)) eqn:?.
    simpl in H. assert (l = (fst (sf_imp.option_split
           (map (sf_imp.next_ranking candidate reldec_candidate rec) election)))).
    rewrite Heqp. auto.
    subst.
    apply participates_cons. right.
    eapply IHelection. eauto.
Qed.

Lemma tabulate_participates : forall x n election rec,
In (x, n) (fst (sf_imp.tabulate _ _ rec election)) ->
sf_spec.participates candidate x election.
intros. unfold sf_imp.tabulate in *.
destruct (sf_imp.option_split
                  (map (sf_imp.next_ranking candidate reldec_candidate rec)
                     election)) eqn:?.
simpl in *.
assert (l = fst (sf_imp.option_split
           (map (sf_imp.next_ranking candidate reldec_candidate rec) election))).
rewrite Heqp. auto.
subst. clear Heqp.
eapply Permutation_in in H.
eapply tabulate''_participates. apply H.
symmetry. apply insertion_sort_permutation.
Qed.

Lemma get_bottom_votes_is_loser :
forall election rec losers rs election'
(ELIMO : forall c, sf_spec.participates _ c election -> sf_spec.first_choices _ (in_record rec) c election 0 ->
           (in_record rec c)),
sf_imp.tabulate _ _ rec election = (rs, election') ->
sf_imp.get_bottom_votes  _ rs = losers ->
Forall (sf_spec.is_loser candidate (in_record rec) election) losers.
Proof.
intros.
destruct (sf_imp.tabulate _ _ rec election) eqn:?. inv H.
destruct rs.
- simpl in *. auto.
- simpl in *. destruct p. rewrite N.eqb_refl.
  simpl. rewrite Forall_forall.
  intros. simpl in *.
  destruct H.
  + subst. assert (SRTD := tabulate_sorted _ _ _ _ Heqp).
    apply Sorted_StronglySorted in SRTD.
    *    assert (CRCT := tabulate_correct _ _ _ _ Heqp).
         rewrite Forall_forall in CRCT.
         specialize (CRCT (x, n)). intuition.
         simpl in *. intuition. clear H0.
         inv SRTD.
         unfold sf_spec.is_loser.
         { repeat split.
           - unfold sf_imp.tabulate in Heqp. unfold
                                           sf_imp.tabulate' in Heqp.
             destruct (sf_imp.option_split
                         (map (sf_imp.next_ranking candidate reldec_candidate rec)
                              election)) eqn:?.
             inv Heqp.
             assert (PRM := insertion_sort_permutation ((sf_imp.tabulate'' candidate reldec_candidate l []))
                                                       (sf_imp.cnle candidate)).
             eapply Permutation_sym in PRM.
             eapply Permutation_in in PRM.
             instantiate (1 := (x, n)) in PRM.
             eapply tabulate''_continuing. instantiate (1 := nil). instantiate (1 := election).
             erewrite Heqp0. simpl. eauto.
             constructor.
             rewrite H0. constructor. auto.
           - eapply tabulate_participates; eauto. instantiate (1:=rec). rewrite Heqp.
             simpl. left. reflexivity.
           - intros.
             assert (N.to_nat n = n0); [ | subst n0 ].
             { eapply sf_spec.sf_first_choices_unique in H0; [ | apply H1]. auto. }
             rewrite Forall_forall in H3.
             destruct H.
             unfold sf_spec.participates in H5.
             destruct H5.
             destruct H5. destruct H6. destruct H6.
             destruct (NPeano.Nat.eq_dec (N.to_nat n) m).
             + omega.
             + cut (In (c', (N.of_nat m)) rs).
               * intros.
                 apply H3 in H8. unfold boolCmpToProp in H8.
                 simpl in *. destruct (n <=? N.of_nat m) eqn:?; try contradiction.
                 apply N.leb_le in Heqb.
                 edestruct (rel_dec_p c' x).
                 subst.
                 eapply sf_spec.sf_first_choices_unique in H4; [ | apply H1]. intuition.
                 rewrite <- (Nnat.Nat2N.id m) in H4.
                 apply tabulate_first_choices_complete in H4.
                 rewrite Heqp in H4. simpl in H4.
                 destruct H4. congruence.
                 destruct (n <=? N.of_nat m) eqn:?; auto.
                 rewrite N.leb_le in Heqb0.
                 rewrite N.lt_eq_cases in Heqb0.
                 destruct Heqb0. rewrite Znat.N2Z.inj_lt in H9.
                 rewrite (Znat.Nat2Z.inj_le (N.to_nat n) m). rewrite Znat.N_nat_Z in *.
                 rewrite Znat.nat_N_Z in *. rewrite BinInt.Z.lt_eq_cases. auto.
                 subst. rewrite (Nnat.Nat2N.id) in *. intuition.
                 rewrite N.leb_gt in Heqb0. clear - Heqb.
                 rewrite Znat.N2Z.inj_le in Heqb.
                 rewrite Znat.nat_N_Z in *.
                 rewrite Znat.Nat2Z.inj_le.
                 rewrite Znat.N_nat_Z. auto.
                 intro. rewrite H9 in *.
                 eapply ELIMO in H4. auto.
                 unfold sf_spec.participates.
                 exists x0.
                 eauto.
               * admit.
         }
    *  apply cnlt_trans.
  + assert (In (x, n) (filter
              (fun x0 : candidate * N =>
               let (_, v') := x0 in n =? v') rs)).
    rewrite filter_In. split.
    * rewrite in_map_iff in H. destruct H. destruct x0. simpl in H. intuition.
      subst. rewrite filter_In in H1. intuition.
      apply N.eqb_eq in H0. subst.
      auto.
    * symmetry. symmetry. apply N.eqb_refl .
    * clear H.
      rewrite filter_In in H0. destruct H0.
      assert (SRTD := tabulate_sorted _ _ _ _ Heqp).
      apply Sorted_StronglySorted in SRTD.
      assert (CRCT := tabulate_correct _ _ _ _ Heqp).
      rewrite Forall_forall in CRCT.
      inv SRTD.
      simpl in *. specialize (CRCT ((x, n))).
      intuition. clear H1.
      unfold sf_spec.is_loser.
      split.
      split.
      admit. (*TODO*)
      admit.
      intros ? ? ? [??] ? ?.
      eapply sf_spec.sf_first_choices_unique in H5; eauto. subst.
      rewrite Forall_forall in H4.
      specialize (H4 (c', (N.of_nat m))).
      destruct (rel_dec_p c c').
      subst.
      assert (CRCT := tabulate_correct _ _ _ _ Heqp).
      rewrite Forall_forall in CRCT.
      specialize (CRCT (c', n)). simpl in CRCT. intuition.
      clear H8.
      eapply sf_spec.sf_first_choices_unique in H7; eauto.
      subst.
      auto.
      assert (In (c', N.of_nat m) rs).
      rewrite <- Nnat.Nat2N.id in H7.
      apply tabulate_first_choices_complete in H7.
      rewrite Heqp in *. simpl in H7. destruct H7.
      inv H5. intuition.
      auto.
      intro.
      rewrite H5 in *. clear H5.
      apply ELIMO in H7; auto.
      intuition.
      unfold boolCmpToProp in H8. simpl in H8.
      destruct (n <=? N.of_nat m) eqn:?; intuition.
      apply N.leb_le in Heqb. admit.
      apply cnlt_trans.
Qed.

Lemma last_item_in :
forall l w n,
sf_imp.last_item candidate l = Some (w,n) ->
In (w,n) l.
Proof.
induction l; intros.
simpl in *. congruence.
simpl in *. destruct l. inv H. auto.
right. auto.
Qed.

Lemma N_nat_le_inj :
forall x1 n,
x1 <= n <-> (N.to_nat x1 <= N.to_nat n)%nat.
Proof.
intros. rewrite Znat.N2Z.inj_le. rewrite Znat.Nat2Z.inj_le.
repeat rewrite Znat.N_nat_Z. intuition.
Qed.

Lemma tabulate_total_selected : forall r election election' vs,
sf_imp.tabulate _ _ r election = (vs, election') ->
sf_spec.total_selected candidate (in_record r) election (length election').
Proof.
  intros. unfold sf_imp.tabulate in *.
  destruct (sf_imp.option_split
             (map (sf_imp.next_ranking candidate reldec_candidate r) election)) eqn:?.
  simpl in *. inv H.
  generalize dependent l0.
  revert r  election l.
  induction election; intros.
  -   simpl in *. inv Heqp. constructor.
  - simpl in *. destruct (sf_imp.next_ranking candidate reldec_candidate r a) eqn:?.
    + repeat dlp.
      inv Heqp. simpl in *. apply sf_spec.total_continuing.
      apply next_ranking_selected in Heqo.
      unfold sf_spec.selected_candidate in *. intuition.
      eapply IHelection. eauto.
    + dlp. inv Heqp. simpl in *.
      apply sf_spec.total_exhausted.
      eapply next_ranking_eliminated; eauto.
      eapply IHelection; eauto.
Qed.

Lemma last_item_cons :
forall h t l,
sf_imp.last_item candidate (h :: t) = Some l ->
(t = nil /\ h = l) \/ sf_imp.last_item candidate t = Some l.
induction t; intros.
- simpl in *. inv H. auto.
- simpl in *. right.
  auto.
Qed.

Lemma ss_last :
forall l c n,
StronglySorted (boolCmpToProp (sf_imp.cnle candidate)) l ->
sf_imp.last_item candidate l = Some (c, n) ->
Forall (fun (r : candidate * N) => let (_, y) := r in y <= n) l.
Proof.
induction l; intros.
- simpl in *. congruence.
- apply last_item_cons in H0.
  rewrite Forall_forall; intros.
  intuition. subst.
  inv H1. apply N.le_refl.
  inv H0.
  destruct H1.
  + subst. destruct x.  inv H.
    rewrite Forall_forall in *.
    specialize (H4 (c, n)).
    apply last_item_in in H2. intuition.
    unfold boolCmpToProp in H.
    simpl in *.
    destruct (n0 <=? n) eqn:?; try contradiction.
    rewrite N.leb_le in Heqb. auto.
  + eapply IHl in H2; eauto.
    rewrite Forall_forall in H2.
    apply H2.  auto. inv H. auto.
Qed.

Lemma lt_of_nat :
forall n nn,
N.of_nat n < nn <->
(n < N.to_nat nn)%nat.
Proof.
intros. repeat rewrite Znat.N2Z.inj_lt.
rewrite Znat.nat_N_Z.
rewrite Znat.Nat2Z.inj_lt. rewrite Znat.N_nat_Z.
split; auto.
Qed.

Lemma gt_of_nat :
forall n nn,
N.of_nat n > nn <->
(n > N.to_nat nn)%nat.
Proof.
intros. repeat rewrite Znat.N2Z.inj_gt.
rewrite Znat.nat_N_Z.
rewrite Znat.Nat2Z.inj_gt. rewrite Znat.N_nat_Z.
split; auto.
Qed.

Lemma gt_of_nat2 :
forall n nn,
 n > N.of_nat nn <->
(N.to_nat n >  nn)%nat.
Proof.
intros. repeat rewrite Znat.N2Z.inj_gt.
rewrite Znat.nat_N_Z.
rewrite Znat.Nat2Z.inj_gt. rewrite Znat.N_nat_Z.
split; auto.
Qed.

Lemma NNatex :
forall x0,
exists nx0, N.to_nat nx0 = x0.
intros. induction x0. exists 0. auto.
destruct IHx0. exists (N.succ x).
rewrite Nnat.N2Nat.inj_succ. auto.
Qed.

Lemma run_election'_correct :
  forall fuel election winner rec' rec tbreak
         (TB : forall c x, tbreak c = Some x -> In x c)
         (N0 : forall c, sf_spec.participates _ c election ->
                           sf_spec.first_choices _ (in_record rec) c election 0 ->
                           in_record rec c),
    sf_imp.run_election' candidate _ tbreak election rec fuel = (Some winner, rec') ->
    sf_spec.winner candidate election (in_record rec) winner.
induction fuel; intros.
- simpl in *. congruence.
- simpl in *. destruct (sf_imp.tabulate candidate reldec_candidate rec election) eqn:?;
                       simpl in *; try congruence.
  destruct (sf_imp.last_item candidate l) eqn:?; try congruence.
  destruct p.
  destruct ( sf_imp.gtb_N (n * 2) (N.of_nat (length e))) eqn:?.
  + inv H.
    apply sf_spec.winner_now. unfold sf_spec.majority.
    intros. assert (winner_votes = (N.to_nat n)).
    { apply tabulate_correct in Heqp.
      rewrite Forall_forall in Heqp. specialize (Heqp (winner, n)).
      apply last_item_in in Heqo. intuition.
      eapply sf_spec.sf_first_choices_unique in H1; eauto. }
    subst.
    assert (total_votes = (length e)).
    { apply tabulate_total_selected in Heqp.
      eapply total_selected_unique; eauto. }
    subst.
    rewrite sf_imp.gtb_nat_gt in Heqb. rewrite gt_of_nat2 in Heqb.
    rewrite Nnat.N2Nat.inj_mul in Heqb. auto.
    apply _.
  + unfold sf_imp.find_eliminated_noopt in *.
    destruct (tbreak (sf_imp.get_bottom_votes candidate l)) eqn:?.
    * rename c0 into loser.
      rename Heqo0 into TBREAK.
      copy Heqp. rename H0 into ISLOSER.
      eapply get_bottom_votes_is_loser in ISLOSER; eauto.
      rewrite Forall_forall in ISLOSER.
      eapply TB in TBREAK.
      apply ISLOSER in TBREAK.
      { eapply sf_spec.winner_elimination.
        - unfold sf_spec.no_majority.
          intro. destruct H0.
          assert (~ sf_spec.majority _ (in_record rec) election c).
          { intro.
            unfold sf_spec.majority in *.
            specialize (H1 (length e) (N.to_nat n)).
            copy Heqp.
            apply tabulate_total_selected in H2. intuition.
            apply tabulate_correct in Heqp.
            rewrite Forall_forall in Heqp.
            specialize (Heqp (c, n)). simpl in *.
            apply last_item_in in Heqo. intuition.
            change 2%nat with (N.to_nat 2) in H4.
            rewrite <- Nnat.N2Nat.inj_mul in H4.
            rewrite <- gt_of_nat2 in H4.
            rewrite <- sf_imp.gtb_nat_gt in H4. congruence.
            apply _.
          }
          copy Heqp.
          apply tabulate_sorted in Heqp.
          clear - Heqp Heqo H0 H1 H2 N0.
          destruct (majority_not_0 _ _ _ _ H0). intuition.
          rename H4 into X0. rename H3 into FCX.
          apply Sorted_StronglySorted in Heqp; [ |  apply cnlt_trans].
          eapply ss_last in Heqp; eauto.
          rewrite Forall_forall in *.
          apply H1. clear H1. intro; intros.
          assert (winner_votes = (N.to_nat n)).
          { apply last_item_in in Heqo.
            apply tabulate_correct in H2.
            rewrite Forall_forall in H2. eapply H2 in Heqo; clear H2.
            eapply sf_spec.sf_first_choices_unique; eauto. }
          subst.
          unfold sf_spec.majority in H0.
          copy FCX.
          destruct (NNatex x0).
          rewrite <- H4 in H3.
          apply tabulate_first_choices_complete in H3; auto.
          rewrite H2 in *. simpl in *.
          specialize (Heqp (x, x1)).
          intuition.
          eapply H0 in FCX; eauto. subst. rewrite  N_nat_le_inj in H5. omega.
          subst. intro. subst. intuition.
        - eauto.
        - rewrite update_eliminated_in_rec_eq_noc.
          eapply IHfuel.
          + eauto.
          + intros. edestruct (rel_dec_p c0 loser).
            * subst. unfold in_record. exists [loser].
              intuition.
            * apply N0 in H0. unfold in_record in *.
              destruct H0.
              exists x. intuition.
              clear - H1 n0.
              eapply first_choices_rec_0; eauto.
          + apply H.
      }
    * congruence.
Qed.

Lemma no_dup_map_allc :  forall allc,
NoDup allc ->
NoDup (fst (split (map (fun x : candidate => (x, 0)) allc))).
Proof.
induction allc; intros.
- simpl. auto.
- simpl. inv H.
  destruct ( split (map (fun x : candidate => (x, 0)) allc) ) eqn:?.
  assert (l = fst (split (map (fun x : candidate => (x, 0)) allc))).
  rewrite Heqp. auto. subst.
  simpl in *. constructor; auto. intuition.   clear - H2 H reldec_correct_candidate.
  apply H2. apply in_split in H. intuition_nosplit.
  apply in_map_iff in H. destruct H. intuition. inv H0. auto.
Qed.

Lemma nodup_not_in_filter :
forall allc c l,
NoDup allc ->
~ In c
         (map fst
            (filter
               (fun x : candidate * N =>
                let (_, ct) := x in  ct =? 0)
               (sf_imp.tabulate'' candidate reldec_candidate l
                  (sf_imp.increment candidate reldec_candidate
                     (map (fun x : candidate => (x, 0)) allc) c)))).
Proof.
intros. intro.
apply in_map_iff in H0. destruct H0. destruct H0. destruct x. simpl in *. subst.
apply filter_In in H1. destruct H1. rewrite N.eqb_eq in H1.
subst. edestruct increment_same_s. Focus 2.
 eapply tabulate_not_0. Focus 2. eauto. apply increment_nodup.
instantiate (1:=map (fun x : candidate => (x, 0)) allc). apply no_dup_map_allc; auto.
rewrite N.add_1_r. apply N.succ_0_discr.
eauto. apply no_dup_map_allc. auto.
Qed.

Lemma tabulate_0_running :
forall (c: candidate) l running
(NODUP: NoDup (fst (split (running)))),
In (c, 0) (sf_imp.tabulate'' _ _ l running) ->
In (c, 0) running.
Proof.
induction l.
- intros. simpl in *. auto.
- intros. simpl in *. destruct a.
  destruct (rel_dec_p c c0).
  + subst. exfalso.
    edestruct (increment_same_s c0).
    eauto.
    eapply tabulate_not_0.
    * apply increment_nodup. eauto.
    * apply H0.
    * rewrite N.add_1_r. apply N.succ_0_discr.
    * eauto.
  + apply IHl in H.
    eapply increment_neq' in H; auto.
    apply increment_nodup. auto.
  + apply IHl in H; auto.
Qed.

Lemma find_0s_correct :
forall allc election c
(PART: forall c, sf_spec.participates _ c election -> In c allc),
NoDup allc ->
In c (sf_imp.find_0s candidate reldec_candidate allc election) ->
sf_spec.first_choices _ (in_record nil) c election 0.
Proof.
intros. (*destruct (classic (sf_spec.participates _ c election)). rename H1 into PTCPT.*)
induction election; intros.
- constructor.
- unfold sf_imp.find_0s in *. simpl in *.
  destruct (sf_imp.next_ranking candidate reldec_candidate [] a) eqn:?.
  + destruct p. destruct (sf_imp.option_split
                            (map (sf_imp.next_ranking candidate reldec_candidate [])
                                 election)) eqn:?.
    simpl in *. destruct (rel_dec_p c0 c).
    * subst.
      eapply nodup_not_in_filter in H. exfalso. apply H. apply H0.
    * apply sf_spec.first_choices_not_selected.
      intro. apply next_ranking_selected in Heqo.
      eapply sf_spec.selected_candidate_unique in Heqo; eauto.
      apply IHelection; eauto. intros. apply PART.
      apply participates_cons. auto.
      apply in_map_iff.
      apply in_map_iff in H0. intuition_nosplit.
      exists x. destruct x. simpl in H0. subst. intuition.
      apply filter_In in H1. apply filter_In. intuition.
      { destruct (classic (In (c, n0)
                            (sf_imp.tabulate'' candidate reldec_candidate l
                                               (map (fun x : candidate => (x, 0)) allc)))).
        - eapply tabulate''_same; [ | | | | exact H0]. apply increment_nodup.
          + apply no_dup_map_allc. auto.
          + apply no_dup_map_allc. auto.
          + apply increment_neq; eauto.
            specialize (PART c). apply in_map_iff. exists c. split.
            * reflexivity.
            * rewrite N.eqb_eq in H2. subst.
              apply tabulate_0_running in H1. apply in_map_iff in H1.
              destruct H1. destruct H1. inv H1. auto. apply no_dup_map_allc. auto.
          + rewrite N.eqb_eq in H2. subst.
            eapply tabulate_0_running. apply no_dup_map_allc; auto.
            eauto.
        - eapply tabulate''_same in H0.
          + exfalso. apply H1. apply H0.
          + apply increment_nodup; auto.
            apply no_dup_map_allc; auto.
          + apply no_dup_map_allc; auto.
          + eapply increment_neq; auto.
            apply in_map_iff. exists c.
            intuition. apply N.eqb_eq in H2. subst.
            apply tabulate_0_running in H0. eapply increment_neq' in H0; auto.
            apply in_map_iff in H0; intuition_nosplit; auto.
            apply increment_nodup. apply no_dup_map_allc. auto.
          + apply in_map_iff. exists c. intuition. apply N.eqb_eq in H2. subst.
            apply tabulate_0_running in H0. eapply increment_neq' in H0; auto.
            apply in_map_iff in H0; intuition_nosplit; auto.
            apply increment_nodup. apply no_dup_map_allc. auto.
      }
  + destruct (sf_imp.option_split
                    (map (sf_imp.next_ranking candidate reldec_candidate [])
                       election)) eqn:?.
    simpl in *.
    apply IHelection in H0; auto.
    * constructor. intro. unfold sf_spec.selected_candidate in H1.
      intuition_nosplit. apply next_ranking_eliminated in Heqo.
      unfold sf_spec.continuing_ballot in *. intuition.
      auto.
    * intros. apply PART. apply participates_cons; auto.
Qed.

Lemma find_0s_complete :
  forall election allc c,
 sf_spec.first_choices candidate
     (in_record [sf_imp.find_0s candidate reldec_candidate allc election]) c
     election 0 ->
   sf_spec.participates candidate c election ->
   In c (sf_imp.find_0s candidate reldec_candidate allc election).
Admitted. (*might be hard, can it be worded better?*)

Theorem run_election_correct : forall election winner tb rec allc
  (TB : forall c x, tb c = Some x -> In x c)
  (PART : forall c, sf_spec.participates _ c election <-> In c allc)
  (NODUP : NoDup allc),
    sf_imp.run_election candidate _ tb election allc = (Some winner, rec) ->
    sf_spec.winner _ election (in_record []) winner.
intros. unfold sf_imp.run_election in H.
apply run_election'_correct in H; auto.
- eapply winner_eliminate_0s in H; auto. admit.
  intros. eapply find_0s_correct. intros. apply PART. auto.  auto.
  destruct H0. intuition. inv H1. auto. inv H0.
- intros.
  eexists. simpl. split. left. reflexivity.
  apply find_0s_complete; auto.
Qed.


(* JMeq without the [eq] hard-wiring. Meant for use with [Require] only, not [Import]. *)
Require Import Relation_Definitions Setoid.
Require Export Unicode.Utf8 Utf8_core.

Inductive R {A: Type} (r: relation A) (x: A): forall B: Type, relation B → B → Prop := relate y: r x y → R r x A r y.

Lemma reflexive A (x:A) (Ra: relation A) `{!Reflexive Ra}: R Ra x _ Ra x.
Proof. apply relate. reflexivity. Qed.

Lemma symmetric A B (x:A) (Ra: relation A) (Rb: relation B) (y:B) `{!Symmetric Ra}: R Ra x _ Rb y → R Rb y _ Ra x.
Proof. destruct 1. apply relate. symmetry. assumption. Qed.

Lemma transitive A B C (Ra: relation A) (Rb: relation B) (Rc: relation C) (a:A) (b:B) (c:C) `{!Transitive Ra}:
  R Ra a _ Rb b → R Rb b _ Rc c → R Ra a _ Rc c.
Proof. destruct 1. destruct 1. apply relate. transitivity y; assumption. Qed.

Require Import Coq.Logic.Eqdep.

Lemma unJM A (r: relation A) (x y:A) r' (E: R r x A r' y): r x y.
Proof.
 simple inversion E.
 rewrite (eq_rect_eq__eq_dep_eq _ (eq_rect_eq _) _ _ _ _ (eq_sigT_eq_dep _ _ _ _ _ _ H2)).
 firstorder.
Qed. (* Warning: Depends on proof_irrelevance. *)


(** * Application to the bisimulation case *)

Require Export Settings.
Require Import Theory.
Set Implicit Arguments.

Section Modular.

  Variables A X: Type.
  Variable TX: reduction_t A X.

  Let F  := Comp (chaining_l (expand TX TX)) (chaining_r (bisim TX TX)).
  Let G  := Comp (star (X:=X)) (Union2 (identity (X:=X) (Y:=X)) (constant (bisim TX TX))).

  Lemma F_mon: monotonic TX TX F.
  Proof.
    unfold F; apply Comp_mon.
    apply chaining_r_mon.
    apply (proj1 (bisimulation_bisim TX TX)).
    apply chaining_l_mon.
    apply (proj1 (expansion_expand TX TX)).
  Qed.
  Lemma G_wmon: wmonotonic TX TX G.
  Proof.
    unfold G; apply Comp_wmon.
    apply Union2_wmon.
    apply monotonic_wmonotonic; apply identity_mon.
    apply monotonic_wmonotonic; apply constant_mon.
    apply (proj1 (bisimulation_bisim TX TX)).
    apply star_wmon.
  Qed.

  Lemma FG: contains F G.
  Proof.
    intros R x y XY; destruct XY as [ x' XX' X'Y ]; destruct X'Y as [ y' X'Y' Y'Y ].
    unfold G, Comp, Union2; simpl; apply S_star with x'; auto.
    right; unfold constant; apply wexpand_bisim; apply expand_wexpand; auto.
    apply S_star with y'.
    left; auto.
    apply star1; right; auto.
  Qed.

  Lemma G_reverse: forall R, eeq (trans (G R)) (G (trans R)).
    intros R; unfold G, Comp, Union2, identity, constant.
    eapply eeq_trans; [ apply inv_star | apply star_eeq ].
    eapply eeq_trans; [ apply inv_union2 | apply union2_eeq; auto ].
    split; intros x y H; apply (bisim_sym H).
  Qed.

  Variable R: relation X.
  Hypothesis HRt: evolve_t TX TX R (F R).
  Hypothesis HRa: evolve_a TX TX R (G R).
  Hypothesis HRt': evolve_t TX TX (trans R) (F (trans R)).
  Hypothesis HRa': evolve_a TX TX (trans R) (G (trans R)).

  (** Theorem 2.5 *)
  Theorem upto: incl R (bisim TX TX).
  Proof.
    intros x y H; exists (UIter (UIter G) R).
    split.
    apply unified_correct with F; auto.
    exact F_mon.
    exact G_wmon.
    exact FG.
    apply simulation_eeq with (UIter (UIter G) (trans R)).
    apply eeq_sym; repeat apply UIter_trans; repeat apply UIter_inc; try apply (wmon_m G_wmon).
    apply G_reverse.
    apply unified_correct with F; auto.
    exact F_mon.
    exact G_wmon.
    exact FG.
    exists 0; exact H.
  Qed.

End Modular.

Section Controlled.

  Variables A X: Type.
  Variable TX: reduction_t A X.

  Variables B B': relation X.
  Hypothesis HB: bicontrolled TX B.
  Hypothesis HB': bicontrolled TX B'.

  Let F  := chaining_r (X:=X) (bisim TX TX).
  Let G  := Comp (star (X:=X)) (Union2 (identity (X:=X) (Y:=X)) (constant (bisim TX TX))).

  Let F_mon: monotonic TX TX F.
  Proof.
    unfold F; apply chaining_r_mon; apply (proj1 (bisimulation_bisim TX TX)).
  Qed.

  Let FG: contains F G.
  Proof.
    intros R x y XY; destruct XY as [ w XW WY ].
    unfold G, Comp, Union2; simpl; apply S_star with w; auto.
    left; auto.
    apply star1; right; auto.
  Qed.

  Let BG: contains (chaining_l (star B)) G.
  Proof.
    intros R x y XY; destruct XY as [ w XW WY ].
    unfold G, Comp, Union2, constant; simpl; apply S_star with w; auto.
    right; induction XW as [ w | z x w ZX XW  IH ].
    apply bisim_refl.
    apply bisim_trans with z; auto.
    apply (proj2 HB _ _ ZX).
    apply star1; left; auto.
  Qed.

  Let B'G: contains (chaining_l (star B')) G.
  Proof.
    intros R x y XY; destruct XY as [ w XW WY ].
    unfold G, Comp, Union2, constant; simpl; apply S_star with w; auto.
    right; induction XW as [ w | z x w ZX XW  IH ].
    apply bisim_refl.
    apply bisim_trans with z; auto.
    apply (proj2 HB' _ _ ZX).
    apply star1; left; auto.
  Qed.

  Variable R: relation X.
  Hypothesis HRt: evolve_t TX TX R (comp (star B) (F R)).
  Hypothesis HRa: evolve_a TX TX R (G R).
  Hypothesis HRt': evolve_t TX TX (trans R) (comp (star B') (F (trans R))).
  Hypothesis HRa': evolve_a TX TX (trans R) (G (trans R)).

  (** Theorem 3.6 *)
  Theorem upto_ctrl: incl R (bisim TX TX).
  Proof.
    intros x y H; exists (UIter (UIter G) R).
    split.
    apply controlled_correct with B F; auto.
    exact (proj1 HB).
    unfold G; apply G_wmon.
    unfold transparent, F, chaining_r; intro U;
      apply (proj1 (comp_assoc (star B) U (bisim TX TX))).
    apply simulation_eeq with (UIter (UIter G) (trans R)).
    unfold G; apply eeq_sym; repeat apply UIter_trans; repeat apply UIter_inc; try apply (wmon_m (G_wmon TX)).
    apply G_reverse.
    apply controlled_correct with B' F; auto.
    exact (proj1 HB').
    unfold G; apply G_wmon.
    unfold transparent, F, chaining_r; intro U;
      apply (proj1 (comp_assoc (star B') U (bisim TX TX))).
    exists 0; exact H.
  Qed.

End Controlled.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_bnd_nil_reduce :
  forall T1 x1 L1, T1 = (t_sel_bnd x1 L1) ->
                  subtype T1 t_nil = false.
Proof.
  intros.

  remember (subtype T1 t_bot) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import FSets.
Require Import CoqlibC Maps Ordered Errors Lattice Kildall Integers.
Require Import AST Linking.
Require Import Values Memory Events Globalenvs SmallstepC.
Require Import sflib.

Section LIFTDUMMY.

Context {G ST: Type}.
Variable step: Senv.t -> G -> ST -> trace -> ST -> Prop.
Variable wf_tgt: ST -> Prop.
Variable strong_wf_tgt: ST -> Prop.
Hypothesis strong_wf_tgt_strong: strong_wf_tgt <1= wf_tgt.
(* Note: I added an arbitrary "H" alphabet to avoid name collision *)
Hypothesis strong_wf_tgt_spec: forall se ge st0 st1 tr0
    (HSWF: strong_wf_tgt st0)
    (HSTEP: step se ge st0 tr0 st1),
    <<HSWF: strong_wf_tgt st1>> \/ <<STUCK: forall tr1 st2 (HSTEP0: step se ge st1 tr1 st2), False>>.
Hypothesis wf_tgt_strengthen: forall se ge st0 tr st1
    (HWF0: strong_wf_tgt st0)
    (HSTEP: step se ge st0 tr st1)
    (HWF1: wf_tgt st1),
    <<WFTGT1: strong_wf_tgt st1>>.

Let strong_wf_tgt_spec_starN: forall se ge n st0 st1 tr0 tr1 st2
    (STEP: step se ge st0 tr0 st1)
    (STAR: starN (step) se ge n st1 tr1 st2)
    (DUMMYTGT: strong_wf_tgt st0)
    (STKAFTER: wf_tgt st2) ,
    <<WF: strong_wf_tgt st1>>.
Proof.
  ii. exploit strong_wf_tgt_spec; eauto. intro P. destruct n; ss.
  { inv STAR. des; ss. eapply wf_tgt_strengthen; eauto. }
  des; ss. exfalso. inv STAR. eapply STUCK; eauto.
Qed.

Let wf_step (se: Senv.t) (ge: G) (st0: ST) (tr: trace) (st1: ST) :=
  step se ge st0 tr st1 /\ wf_tgt st1.

Lemma lift_starN
      cnt tse tge st_tgt0 tr st_tgt1
      (STAR: starN step tse tge cnt st_tgt0 tr st_tgt1)
      (DUMMYTGT: strong_wf_tgt st_tgt0)
      (STKAFTER: wf_tgt st_tgt1):
    <<STAR: starN wf_step tse tge cnt st_tgt0 tr st_tgt1>> /\ <<DUMMYTGT: strong_wf_tgt st_tgt1>>.
Proof.
  induction STAR; ii; ss.
  { esplits; eauto. econs; et. }
  pose s as S1. pose s' as S2. pose s'' as S3.
  exploit strong_wf_tgt_spec_starN; eauto. i; des.
  exploit IHSTAR; eauto. i; des.
  esplits; eauto. econs; eauto. rr. esplits; eauto.
Qed.

Lemma lift_plus
      se ge st_tgt0 tr st_tgt1
      (PLUS: plus step se ge st_tgt0 tr st_tgt1)
      (DUMMYTGT: strong_wf_tgt st_tgt0)
      (STKAFTER: wf_tgt st_tgt1):
    <<PLUS: plus wf_step se ge st_tgt0 tr st_tgt1>> /\ <<DUMMYTGT: strong_wf_tgt st_tgt1>>.
Proof.
  apply starN_plus_iff in PLUS. des. apply lift_starN in PLUS; et. des. esplits; et. apply starN_plus_iff; et.
Qed.

End LIFTDUMMY.