From mathcomp Require Import all_ssreflect.
Require Import bfs.

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

Arguments make_path {state move state_fmap}.
Arguments bfs {state move state_fmap}.

Section proof_context.

(* Variables state : eqType.*)
Variable state move : finType.
Variables state_fmap : Type.

Variable empty : state_fmap.

Variable find : state_fmap -> state -> option move.
Variable add : state_fmap -> state -> move -> state_fmap.
Variable step : state -> list (state * move).

Variable transition : state -> move -> option state.

Hypothesis find_empty : forall s, find empty s = None.
Hypothesis add_find : forall d s m, find (add d s m) s = Some m.
Hypothesis add_find2 :
  forall d s1 s2 m, s1 != s2 -> find (add d s1 m) s2 = find d s2.

(* step gives all reverse steps of transition *)
Hypothesis step_def : forall s,
  step s =i [set p | transition p.1 p.2 == Some s].

Lemma step_transition :
 forall s1 s2,
  (exists m, transition s1 m = Some s2) <-> s1 \in [seq fst p | p <- step s2].
Proof.
intros s1 s2; split.
  move=>[m s1m].
  have : (s1, m) \in [set p | transition p.1 p.2 == Some s2] by rewrite inE s1m.
  by rewrite -step_def=> s1mstep; apply/mapP; exists (s1, m).
move=> /mapP[] p + ->; rewrite step_def inE=> /eqP trp.
by exists p.2.
Qed.

(* What we want to prove are the following facts:
  - for each position it contains, the table makes it possible to compute
    a path of shortest length to the targets,
  - the number given as second result is 2 + the maximal length of such
    shortest paths.
  To prove these two facts, we will prove similar statements about bfs_aux. *)

(* We first explain what it means to have a path from x to the set of target. *)
Fixpoint is_solution (targets : list state) (x : state)
   (l : list move) : bool :=
  match l with
  | nil => x \in targets
  | m :: l1 =>
    match transition x m with
      Some y => is_solution targets y l1
    | None => false
    end
  end.

(* we then explain what it means to be at depth n *)
Definition at_depth (targets : list state) (n : nat) : {set state} :=
  [set x |
  [exists t : {tuple n of move}, is_solution targets x t] &&
  [forall i : 'I_n, [forall t : {tuple i of move}, ~~is_solution targets x t]]].

Lemma at_depthP targets n s:
  reflect ((exists2 l, is_solution targets s l & size l = n) /\
           forall l, is_solution targets s l -> n <= size l)
      (s \in at_depth targets n).
Proof.
apply: Bool.iff_reflect.
split.
  move=> [[l sol zl] optim]; rewrite inE; apply/andP; split.
    by apply/existsP; exists (tcast zl (in_tuple l)); rewrite val_tcast.
  apply/forallP=> -[i iltn]; apply/forallP=> -[l' /eqP /= zl'].
  apply/negP=> abs.
  have := optim l' abs; rewrite leqNgt=> /negP [].
  by rewrite zl'.
rewrite inE=> /andP[] /existsP[][l /= /eqP zl] sol optim.
split; first by exists l.
move=> l' sol'; rewrite leqNgt; apply/negP=> zl'.
move: optim=> /forallP /(_ (Ordinal zl')) /forallP /(_ (in_tuple l')).
by move=> /negP[] /=.
Qed.

(* TODO : rename into depth_bounded  or bounded_depth *)
Definition depth_ge (targets : list state) (n : nat) :=
  [set x | [exists l : n.-bseq move, is_solution targets x l]].

(* Definition depth_ge (targets : list state) (n : nat) :=
  [set x |
  [exists i : 'I_n.+1,
     [exists t : {tuple i of move}, is_solution targets x t]]]. *)

Lemma depth_geS (targets : list state) (n : nat) :
  depth_ge targets n.+1 = depth_ge targets n :|: at_depth targets n.+1.
Proof.
rewrite -setP=> x; apply/idP/idP.
  rewrite inE=> /existsP [] l sol.
  rewrite inE; case ngedx : (x \in depth_ge _ _) => //=.
  have [isn | insn] := eqVneq (size l) n.+1.
    apply/at_depthP; split; first by exists l.
    move=> l' abs; rewrite ltnNge; apply/negP=> zl'.
    case/negP: ngedx; rewrite inE; apply/existsP.
    by exists (insub_bseq n l'); rewrite insubdK.
    (* TODO : understand why rewrite /= fails here.
    rewrite -[X in is_true X]/(size l' <= n). *)
  case/negP: ngedx; rewrite inE; apply/existsP; exists (insub_bseq n l).
  rewrite insubdK //.
  (* same TODO applies here *)
  rewrite -[X in is_true X]/(size l <= n).
  by have := size_bseq l; rewrite leq_eqVlt (negbTE insn) ltnS.
move=> tmp; rewrite inE; apply/existsP; move: tmp.
rewrite 3!inE=>/orP[/existsP[]l | /andP[+ _]].
  by exists (widen_bseq (ltnW (leqnn _)) l).
by move=> /existsP[] t sol; exists (bseq_of_tuple t).
Qed.

Lemma at_depth_sub_ge (targets : list state)(n : nat) :
  at_depth targets n \subset depth_ge targets n.
Proof.
apply/subsetP=> s /at_depthP[] [l sol zl] _.
have zl' : size l <= n by rewrite zl.
(* TODO : complain that cast_bseq is useless here *)
by rewrite inE; apply/existsP; exists (widen_bseq zl' (in_bseq l)).
Qed.

Lemma at_depthSNge (targets : list state) (n : nat) :
  at_depth targets n.+1 :&: depth_ge targets n = set0.
Proof.
apply/eqP; rewrite setI_eq0 disjoint_subset; apply/subsetP=> s.
move/at_depthP=> [] _ nosol.
rewrite 2!inE /=; apply/negP=>/existsP[] l.
move/nosol; rewrite ltnNge=> /negP[].
by rewrite size_bseq.
Qed.

Lemma at_depth_decrease targets n s s' m l :
  s \in at_depth targets n.+1 ->
  transition s m = Some s' ->
  is_solution targets s' l ->
  size l = n ->
  s' \in at_depth targets n.
Proof.
move=>/at_depthP[] _ optim /= sms' sol zl.
apply/at_depthP; split; first by exists l.
move=> l' sol'.
have := optim (m :: l').
by rewrite /= sms' => /(_ sol'); rewrite ltnS.
Qed.

Definition at_depth_step (targets : list state) (n : nat) :
  \bigcup_(s in at_depth targets n)
     [set s' in [seq p.1 | p <- step s] | s' \notin depth_ge targets n] =
  at_depth targets n.+1.
Proof.
apply/setP=> s';apply/bigcupP/idP.
  move=> [] s sin; rewrite 2!inE => /andP[]/[dup]s'in /mapP[]p pin s'p.
  move=> /existsP/= optim.
  have : s' \in depth_ge targets n.+1.
    move: sin; rewrite inE=> /andP[] /existsP[] l sol W.
    have sl' : size (p.2 :: l) <= n.+1 by rewrite /= size_tuple.
    rewrite inE; apply/existsP; exists (Bseq sl')=> /=.
    rewrite s'p.
    by move: pin; rewrite step_def inE => /eqP ->.
  by rewrite depth_geS 2!inE=> /orP[] // /existsP sn; case: optim.
move=> /[dup]s'in /at_depthP[] []l sol zl optim.
case lq : l zl => [ | mv l'] // zl.
have [s sms] : exists s, transition s' mv = Some s.
  move: sol; rewrite lq /=.
  by case: (transition s' mv) => [s | ] //; exists s.
have sols : is_solution targets s l'.
  by move: sol; rewrite lq /= sms.
exists s; last first.
  have /step_transition : exists m, transition s' m = Some s.
    by exists mv.
  move=> sin; rewrite inE sin; apply/negP; rewrite inE=> /existsP[] l2 sol2.
  by have := optim l2 sol2; rewrite ltnNge size_bseq.
by apply: (at_depth_decrease s'in sms sols); move: zl=> /= [].
Qed.

Lemma depth_ge_trans targets n n' : n <= n' ->
  depth_ge targets n \subset depth_ge targets n'.
Proof.
elim: n' => [ | n' Ih]; first by rewrite leqn0=> /eqP ->.
rewrite leq_eqVlt=> /orP[/eqP -> // | ].
rewrite ltnS => /Ih {}Ih.
apply: (subset_trans Ih).
by rewrite depth_geS subsetUl.
Qed.

Lemma at_depth_unique n n' s targets : s \in at_depth targets n ->
  s \in at_depth targets n' -> n = n'.
Proof.
wlog : n n' / n <= n'.
  move=> main; case: (leqP n n'); first by apply: main.
  by move=> /ltnW n'len depn depn'; apply/esym/(main _ _ n'len depn' depn).
rewrite leq_eqVlt=> /orP[/eqP -> // | ].
case: n' => [// | n'] /[dup] nltSn'; rewrite ltnS=> nlen'.
move/(subsetP (at_depth_sub_ge targets n)).
move/(subsetP (depth_ge_trans targets nlen'))=> dge dat.
have : s \in at_depth targets n'.+1 :&: depth_ge targets n'.
  by rewrite inE dge dat.
by rewrite at_depthSNge inE.
Qed.

Lemma at_depth0 targets : targets =i at_depth targets 0.
Proof.
move=> s; rewrite inE; apply/idP/idP.
  move=> sin; apply/andP; split.
    by apply/existsP; exists [tuple].
  by apply/forallP=> - [x xlt0].
by move=>/andP[] /existsP[] t; have := tuple0 t => ->.
Qed.

Lemma at_depth_exists s targets l :
  is_solution targets s l -> exists n, s \in at_depth targets n.
Proof.
suff main : forall n l, size l <= n ->
    is_solution targets s l -> exists n', s \in at_depth targets n'.
  by apply: (main (size l)).
elim=> [ | n Ih] {}l szl sol.
  case : l szl sol => //= _ sin.
  by exists 0; rewrite -at_depth0.
have [/existsP [n' /existsP [t]] | there] := boolP [exists i : 'I_n.+1,
        [exists t : {tuple i of move}, is_solution targets s t]].
  by apply: Ih; rewrite size_tuple -ltnS ltn_ord.
have zl : size l = n.+1.
  move: szl; rewrite leq_eqVlt => /orP[/eqP // | szlt].
  case/negP: there; apply/existsP; exists (Ordinal szlt).
  by apply/existsP; exists (in_tuple l).
exists (size l).
apply/at_depthP; split; first by exists l.
move=> l' sol'; rewrite zl ltnNge; apply/negP; rewrite -ltnS => zl'.
case/negP: there; apply/existsP.
by exists (Ordinal zl'); apply/existsP; exists (in_tuple l').
Qed.

Lemma depth_ge_exists s targets n :
  s \in depth_ge targets n ->
  exists2 n', s \in at_depth targets n' & n' <= n.
Proof.
rewrite inE=> /existsP [l lsol].
have [n' n'P1] := at_depth_exists lsol; exists n' => //.
apply: leq_trans (size_bseq l).
case : (leqP n' (size l)) => // lltn'.
by move: n'P1=> /at_depthP[] _ /(_ l lsol); rewrite leqNgt lltn'.
Qed.

Definition fact1 :=
  forall targets depth t r count,
  bfs find add step depth targets empty count = inl(t, r) ->
  forall s l, is_solution [seq p.1 | p <- targets] s l = true ->
  exists l', make_path find t (mem [seq p.1 | p <- targets])
                transition s depth = Some l' /\
    length l' <= length l.

Definition fact2 :=
  forall targets t s r l depth depth' count,
  bfs find add step depth targets empty count = inl(t, r) ->
  make_path find t (mem [seq p.1 | p <- targets]) transition s depth' = Some l ->
  is_solution [seq p.1 | p <- targets] s l = true.

Definition fact3 :=
  forall targets t r depth,
  bfs find add step depth targets empty 0 = inl(t, r) ->
  forall s l, is_solution [seq p.1 | p <- targets] s l = true ->
    length l + 2 <= r /\
  exists s l, is_solution [seq p.1 | p <- targets] s l = true /\
               length l + 2 = r.

Lemma bfs_step (fuel : nat) (w : seq (state * move)) (settled : state_fmap)
   round:
   bfs find add step fuel w settled round =
  match fuel with
  | 0 => inr (w, settled)
  | p.+1 =>
      let (w0, s) :=
        bfs_aux state move state_fmap find add step w [::] settled in
      match w0 with
      | [::] => inl (s, round)
      | _ :: _ => bfs find add step p w0 s (round + 1)%coq_nat
      end
  end.
Proof. by case: fuel. Qed.

Lemma make_path_step db targetb play x fuel:
  make_path find db targetb play x fuel =
    match fuel with
  | 0 => None
  | S p =>
      if targetb x
      then Some nil
      else
       match find db x with
       | Some m =>
           match play x m with
             Some y =>
             match make_path find db targetb play y p with
             | Some l => Some (m :: l)
             | None => None
             end
           | None => None
           end
         | None => None
       end
  end.
Proof. by case: fuel. Qed.

Lemma make_path_preserve x m s db targetb play depth l:
  find db s = None ->
  make_path find db targetb play x depth = Some l ->
  make_path find (add db s m) targetb play x depth = Some l.
Proof.
move=> dbnone.
elim: depth x l => [ | depth Ih]; first by [].
move=> x l /=.
case: ifP => exq //.
case fdbx: (find db x) => [m' | ] //.
case trq : (play x m') => [y | ] //.
case mpq : (make_path find db targetb play y depth) => [ l' | ] // [eql].
have nochange : find (add db s m) x = find db x.
  by rewrite add_find2 //; apply/eqP=> sx; move: dbnone; rewrite sx fdbx.
by rewrite nochange fdbx trq (Ih y l') ?eql.
Qed.

Lemma make_path_add_length db targetb play s depth l :
  make_path find db targetb play s depth = Some l ->
  make_path find db targetb play s depth.+1 = Some l.
Proof.
elim: depth s l => [ | n Ih] s l //.
rewrite 2!make_path_step.
case exq : (targetb _)=> //.
case fdbq : (find db s) => [m | ] //.
case trq : (play s m) => [s' | ] //.
case mq : (make_path _ _ _ _ _ _)=> [l' | ] //.
by move/Ih : mq => ->.
Qed.

Lemma make_path_le db targetb play s n m l :
  n <= m -> make_path find db targetb play s n = Some l ->
  make_path find db targetb play s m = Some l.
Proof.
elim: m => [ | m Ih].
  by rewrite leqn0=> /eqP ->.
rewrite leq_eqVlt=> /orP[/eqP <- // | ].
rewrite ltnS.
by move=> /Ih /[apply]; apply: make_path_add_length.
Qed.

Definition states_included (l : list (state * move)) (t : state_fmap) :=
  forall s, s \in [seq fst p | p <-  l] -> find t s <> None.

Lemma states_included_add l t s m :
  states_included l t -> states_included l (add t s m).
Proof.
elim: l => [ | [s' m'] tl Ih] //.
move=> h s2 /h inl.
case : (eqVneq s s2) => [ss2 | sns2]; first by rewrite ss2 add_find.
by rewrite add_find2.
Qed.

Lemma add_find_none db s m s' :
   find db s' <> None -> find (add db s m) s' <> None.
Proof.
case fdbs' : (find db s') => [m' |] // _.
case: (eqVneq s s') => [sq | snq].
  by move: fdbs'; rewrite -sq add_find.
by rewrite add_find2 // fdbs'.
Qed.

Lemma bfs_aux_included1 w w2 w3 db db2 s:
  bfs_aux _ _ _ find add step w w2 db = (w3, db2) ->
  find db2 s <> None <-> s \in [seq p.1 | p <- w] \/ find db s <> None.
Proof.
elim: w w2 db => [ | [a mv] w Ih] w2 db.
  move=> /= [_  <-].
  by rewrite in_nil; intuition done.
case: (eqVneq s a) Ih=> [-> | sna] /=.
  case fdba : (find db a) => [m | ] /[apply] ->;
       rewrite ?fdba ?add_find ?inE ?eqxx; split; intuition easy.
case fdba : (find db a) => [m | ] /[apply].
  by rewrite inE (negbTE sna).
rewrite add_find2; last by rewrite eq_sym.
by rewrite inE (negbTE sna).
Qed.

Lemma at_depth_exists_path targets n s :
  s \in at_depth targets n -> exists2 l, is_solution targets s l & size l = n.
Proof.
(* Not redoing, this is just part of at_depthP *)
by rewrite inE=> /andP[] /existsP[] x sol _; exists x; rewrite ?size_tuple.
Qed.

Lemma at_depth_depth_ge_le s targets n m :
  s \in at_depth targets n -> s \in depth_ge targets m ->
  n <= m.
Proof.
by move=> sin; move/depth_ge_exists=> [] n' /(at_depth_unique sin) ->.
Qed.

Lemma at_depth_le s targets l n :
  s \in at_depth targets n -> is_solution targets s l -> n <= size l.
Proof.
move=> sin sol.
suff : s \in depth_ge targets (size l) by apply: at_depth_depth_ge_le.
by rewrite inE; apply/existsP; exists (in_bseq l).
Qed.

Lemma bfs_aux_layering n targets w w2 w3 db db2:
  (forall s, find db s <> None -> s \in depth_ge targets n.+1) ->
  (forall s, s \in depth_ge targets n -> find db s <> None) ->
  (forall s p, s \in at_depth targets n -> p \in step s ->
       p \in w \/ find db p.1 <> None) ->
  (forall s, s \in at_depth targets n.+1 -> find db s <> None ->
     step s \subset w2) ->
  (forall p, p \in w ->
     exists2 s, transition p.1 p.2 = Some s & s \in at_depth targets n) ->
  (forall p, p \in w2 ->
      exists2 s, transition p.1 p.2 = Some s &
             s \in at_depth targets n.+1 /\
             find db s <> None) ->
  (forall s m n, s \in at_depth targets n.+1 -> find db s = Some m ->
     exists2 s', transition s m = Some s' &
       find db s' <> None /\ s' \in at_depth targets n) ->
  bfs_aux _ _ _ find add step w w2 db = (w3, db2) ->
  (forall s, find db2 s <> None <-> s \in depth_ge targets n.+1) /\
  (forall s, s \in at_depth targets n.+1 -> step s \subset w3) /\
  (forall p, p \in w3 ->
     exists2 s, transition p.1 p.2 = Some s & s\in at_depth targets n.+1) /\
  (forall s m n, s \in at_depth targets n.+1 -> find db2 s = Some m ->
     exists2 s', transition s m = Some s' &
       find db2 s' <> None /\ s' \in at_depth targets n).
Proof.
elim: w w2 db => [ | [a m] w Ih] w2 db dbSn dbn invstep stepw2 invw invw2 dbc.
  rewrite /= => -[<- <-]; split;[ | split; [ | split]].
  - move=> s; split;[move=> indb | ]; first by have /dbSn := indb.
    rewrite depth_geS inE=> /orP[/dbn // | sinS].
    have [m [tsm tsmq trin]] : exists m,
       exists2 tsm, transition s m = Some tsm & tsm \in at_depth targets n.
      move: sinS => /[dup] atdS /at_depth_exists_path[] [ | m l] //= + /eqP.
      case trq: (transition s m) => [tsm | ] //.
      rewrite eqSS=> + /eqP => /at_depth_decrease /[apply] /(_ s m atdS) trin.
      by exists m, tsm => //; apply: trin.
    have instep : (s, m) \in step tsm.
      by rewrite step_def inE tsmq.
    by have [ // | ] := invstep tsm (s, m) trin instep.
  - move=> s sinS; apply stepw2=> //.
    (* TODO : check about duplication of work. *)
    have [m [tsm tsmq trin]] : exists m,
       exists2 tsm, transition s m = Some tsm & tsm \in at_depth targets n.
      move: sinS => /[dup] atdS /at_depth_exists_path[] [ | m l] //= + /eqP.
      case trq: (transition s m) => [tsm | ] //.
      rewrite eqSS=> + /eqP => /at_depth_decrease /[apply] /(_ s m atdS) trin.
      by exists m, tsm => //; apply: trin.
    have instep : (s, m) \in step tsm.
      by rewrite step_def inE tsmq.
    by have [ // | ]:= invstep _ (s, m) trin instep.
  - by move=> p pin2; have [tp tpq tpin]:= invw2 _ pin2; exists tp; tauto.
  exact dbc.
rewrite /=.
have invw' : forall p, p \in w ->
  exists2 s, transition p.1 p.2 = Some s & s \in at_depth targets n.
  by move=> p pin; apply: invw; rewrite inE pin orbT.
case fdba : (find db a)=> [mv | ].
  have invstep' : forall s p, s \in at_depth targets n ->
       p \in step s -> p \in w \/ find db p.1 <> None.
    move=> s p sin pin.
    have [pa | pna] := eqVneq p.1 a.
      by right; rewrite pa fdba.
    case: (invstep s p sin pin);[rewrite inE=> /orP[]; [ | tauto] | tauto].
    by case: p pna { pin }=> p1 p2; rewrite xpair_eqE /= => /negbTE ->.
  by apply: Ih.
have aSn : a \in depth_ge targets n.+1.
  have [tam trq tamd] : exists2 tam, transition a m = Some tam &
       tam \in at_depth targets n.
    by apply: (invw (a, m)); rewrite inE eqxx.
  have /at_depth_exists_path [l sol zl]:= tamd.
  have zl' : size (m :: l) <= n.+1.
    by rewrite /= ltnS zl.
  rewrite inE; apply/existsP; exists (widen_bseq zl' (in_bseq (m :: l))).
  by rewrite /=; rewrite trq.
have aSn' : a \in at_depth targets n.+1.
  by move: aSn; rewrite depth_geS inE=> /orP[] // /dbn [].
apply: Ih=> //.
- move=> s; have [<- _ // | ans] := eqVneq a s.
  by rewrite add_find2 //; apply: dbSn.
- move=> s sin; apply: add_find_none.
  by apply: dbn.
- move=> s [s' m'] sin.
  have [as'q | ans'] := eqVneq a s'.
    by move=> _; right; rewrite as'q add_find.
  move=> instep; have := invstep s _ sin instep; rewrite inE.
  rewrite xpair_eqE eq_sym (negbTE ans') /=.
  by rewrite add_find2.
- move=> s sin; have [-> _ | ans'] := eqVneq a s.
    by apply/subsetP=> x xin; rewrite mem_cat xin.
  (* TODO : complain about missing (_ \subset _ ++ _) theorems *)
  rewrite add_find2 // => fdbs; apply/subsetP=> p pin; rewrite mem_cat.
  by apply/orP; right; move: p pin; apply/subsetP/stepw2.
- move=> p; rewrite mem_cat=> /orP[ | inw2]; last first.
    have := invw2 _ inw2=> -[tp tpq [tpin1 tpdb]].
    by exists tp=> //; split=> //; apply: add_find_none.
  by rewrite step_def inE=> /eqP ->; exists a=> //; rewrite add_find.
move=> s ms n2 sin2.
case : (eqVneq a s)=> [ /[dup] asq -> | ans].
  rewrite add_find => -[<-].
  have := invw (a, m); rewrite inE eqxx => /(_ isT)[] s' tamq s'in.
  exists s'=> //; first by rewrite -asq.
  split.
    by apply/add_find_none/dbn; rewrite (subsetP (at_depth_sub_ge _ _)).
  by move: sin2; rewrite -asq=> /(at_depth_unique aSn') [] <-.
rewrite !add_find2 // => fdbs.
have [s' tsmq [fdbs' s'in2]]:= dbc _ _ _ sin2 fdbs.
exists s'=> //; split => //.
rewrite add_find2 //.
apply/eqP => as'q; case s'in2.
have fdbsN : find db s <> None by rewrite fdbs.
have n2len : n2 <= n.
  by have := at_depth_depth_ge_le sin2 (dbSn _ fdbsN); rewrite ltnS.
rewrite -as'q in s'in2.
have := at_depth_unique s'in2 aSn'.
by move: n2len=> /[swap] ->; rewrite ltnn.
Qed.

Lemma bfs_depth_main targets n' n w db db2 :
  w =i \bigcup_(s in at_depth targets n) [set x in step s] ->
  (forall s, find db s <> None <-> s \in depth_ge targets n) ->
  (forall s m n, s \in at_depth targets n.+1 -> find db s = Some m ->
     exists2 s', transition s m = Some s' &
       find db s' <> None /\ s' \in at_depth targets n) ->
  (forall k, bfs find add step n'.+1 w db n.+1 = inl(db2, k.+1) ->
    (forall s, find db2 s <> None <-> s \in depth_ge targets k.+1) /\
    at_depth targets k.+2 = set0 /\
  (forall s m n, s \in at_depth targets n.+1 -> find db2 s = Some m ->
     exists2 s', transition s m = Some s' &
       find db2 s' <> None /\ s' \in at_depth targets n)) /\
  (forall w2, bfs find add step n'.+1 w db n.+1 = inr(w2, db2) ->
   w2 =i \bigcup_(s in at_depth targets (n' + n).+1) [set x in step s] /\
   (forall s, find db2 s <> None <-> s \in depth_ge targets (n' + n).+1) /\
   (forall s m n, s \in at_depth targets n.+1 -> find db2 s = Some m ->
     exists2 s', transition s m = Some s' &
       find db2 s' <> None /\ s' \in at_depth targets n)).
Proof.
elim: n' n w db=> [ | n' Ih] n w db.
  rewrite /= => wq dbq dbc.
  case bfs_auxq: (bfs_aux _ _ _ _ _ _ _ _ _) => [w' db'].
  have inge1 : forall s, find db s <> None -> s \in depth_ge targets n.+1.
    by move=> s /dbq; rewrite depth_geS [_ \in _ :|: _]inE => ->.
  have inge : forall s, s \in depth_ge targets n -> find db s <> None.
    by move=> s; rewrite -dbq.
  have stepin:
    forall s p, s \in at_depth targets n -> p \in step s -> p \in w \/
           find db p.1 <> None.
    move=> s p sin pin; left; rewrite wq; apply/bigcupP.
    by exists s; rewrite // inE.
  have subnil : forall s, s \in at_depth targets n.+1 -> find db s <> None ->
             step s \subset nil.
    move=> s sinS; rewrite dbq => sin.
    suff : s \in set0 by rewrite inE.
    by have <- := at_depthSNge targets n; rewrite inE sin sinS.
  have trw : forall p, p \in w ->
    exists2 tp, transition p.1 p.2 = Some tp & tp \in at_depth targets n.
    move=> p; rewrite wq=> /bigcupP[s sin]; rewrite inE.
    by rewrite step_def inE=> /eqP ->; exists s.
  have trnil :
    forall p, p \in nil ->
       exists2 tp, transition p.1 p.2 = Some tp &
         tp \in at_depth targets n.+1 /\ find db tp <> None.
    by [].
  have [db'q [stepinS [trw' db'c]]] :=
    bfs_aux_layering inge1 inge stepin subnil trw trnil dbc bfs_auxq.
  case w'q : w' => [ | p1 w''];split; [ | discriminate | discriminate |].
    move=> k [<- <-]; split=> //.
    split; last by apply: db'c.
    apply/setP=> s; rewrite in_set0; apply/negP.
    move=> /[dup] deps /at_depth_exists_path[] l sol zl.
    case lq: l zl => [ | m l'] // [zl].
    move: sol; rewrite lq /=.
    case tsmq : (transition s m) => [tsm | ] // sol.
    have trSn := at_depth_decrease deps tsmq sol zl.
    have stepsub := stepinS _ trSn.
    have instep : (s, m) \in step tsm by rewrite step_def inE tsmq.
    suff : (s, m) \in w' by rewrite w'q.
    by rewrite (subsetP stepsub).
  rewrite -w'q=> w2 [<- <-]; split; last by [].
  move=> p; apply/idP/idP.
    move=> pin.
    have [tp tpq tpd] : exists2 tp, transition p.1 p.2 = Some tp &
                            tp \in at_depth targets n.+1.
      by apply: trw'.
    by apply/bigcupP; exists tp=> //; rewrite inE step_def inE tpq.
  move=> /bigcupP[s sin]; rewrite inE => pin.
  by rewrite (subsetP (stepinS _ sin)).
move=> wq dbq dbc.
rewrite bfs_step.
(* rewrite -[bfs _ _ _ _ _ _ _ _ _ _]/
   (let (w3, db3) := bfs_aux _ _ _ find add step w [::] db in
   match w3 with [::] => inl (db3, n.+1)
   | _ => bfs _ _ _ find add step n'.+1 w3 db3 (n.+1 + 1)%nat end). *)
case bfs_auxq: (bfs_aux _ _ _ _ _ _ _ _ _) => [w3 db3].
(* TODO : all subproofs down to trnil have to be shared with the base case:
  right now, it is a simple copy paste, adjusted for indentation. *)
have inge1 : forall s, find db s <> None -> s \in depth_ge targets n.+1.
  by move=> s /dbq; rewrite depth_geS [_ \in _ :|: _]inE => ->.
have inge : forall s, s \in depth_ge targets n -> find db s <> None.
  by move=> s; rewrite -dbq.
have stepin:
  forall s p, s \in at_depth targets n -> p \in step s -> p \in w \/
         find db p.1 <> None.
  move=> s p sin pin; left; rewrite wq; apply/bigcupP.
  by exists s; rewrite // inE.
have subnil : forall s, s \in at_depth targets n.+1 -> find db s <> None ->
           step s \subset nil.
  move=> s sinS; rewrite dbq => sin.
  suff : s \in set0 by rewrite inE.
  by have <- := at_depthSNge targets n; rewrite inE sin sinS.
have trw : forall p, p \in w ->
   exists2 tp, transition p.1 p.2 = Some tp & tp \in at_depth targets n.
  move=> p; rewrite wq=> /bigcupP[s sin]; rewrite inE.
  by rewrite step_def inE=> /eqP ->; exists s.
have trnil :
  forall p, p \in nil ->
    exists2 tp, transition p.1 p.2 = Some tp & tp \in at_depth targets n.+1 /\
         find db tp <> None.
  by [].
have [db'q [stepinS [trw' db'c]]] :=
  bfs_aux_layering inge1 inge stepin subnil trw trnil dbc bfs_auxq.
have w3q : w3 =i \bigcup_(s in at_depth targets n.+1) [set x in step s].
  move=> p; apply/idP/idP.
    move=> /trw' [tp tpq trin]; apply/bigcupP; exists tp=> //.
    by rewrite inE step_def inE tpq.
  move=>/bigcupP[s sin]; rewrite inE=> pin.
  by rewrite (subsetP (stepinS _ sin)).
have [Ihl Ihr] := Ih (n.+1) w3 db3 w3q db'q db'c.
move: Ihr; rewrite ?addn1 !addnS !addSn=> Ihr.
case w3q' : w3 => [ | p3 w4]; split;[ | discriminate | | ].
- move=> k [<- <-] {k}; split=> //.
(* TODO : big duplication here. *)
  split; last by apply: db'c.
  apply/setP=> s; rewrite in_set0; apply/negP.
  move=> /[dup] deps /at_depth_exists_path[] l sol zl.
  case lq: l zl => [ | m l'] // [zl].
  move: sol; rewrite lq /=; case tsmq : (transition s m) => [tsm | ] // sol.
  have trSn := at_depth_decrease deps tsmq sol zl.
  have stepsub := stepinS _ trSn.
  have instep : (s, m) \in step tsm by rewrite step_def inE tsmq.
  suff : (s, m) \in w3 by rewrite w3q'.
  by rewrite (subsetP stepsub).
- by rewrite -w3q' PeanoNat.Nat.add_succ_r PeanoNat.Nat.add_0_r.
by rewrite -w3q' PeanoNat.Nat.add_succ_r PeanoNat.Nat.add_0_r.
Qed.

Lemma depth_ge0 targets : targets =i depth_ge targets 0.
Proof.
move=> s; rewrite inE; apply/idP/idP.
  by move=> sin; apply/existsP; exists [bseq].
by move=>/existsP[] /= l; have := bseq0 l => ->.
Qed.

Lemma at_depth_empty_le targets n m : n <= m ->
  at_depth targets n = set0 -> at_depth targets m = set0.
Proof.
move=> nm.
suff main k : at_depth targets n = set0 -> at_depth targets (k + n) = set0.
  by rewrite -(subnK nm); apply: main.
elim: k => [ | k Ih] //.
move=> /Ih {}Ih; rewrite addSn; apply/setP=> s; rewrite in_set0; apply/negP.
move=>/[dup] sinS /at_depth_exists_path[][ |m' l]//= sol [] zl.
move: sol; case tsmq : (transition s m') => [tsm' | ] // sol.
have sm'in := at_depth_decrease sinS tsmq sol zl.
by move/setP: Ih=> /(_ tsm'); rewrite in_set0=> /negP; apply.
Qed.

Lemma bfs_aux_layer0 m targets w1 db1 :
  bfs_aux _ _ _ find add step [seq (s, m) | s <- targets]
                    nil empty = (w1, db1) ->
  (forall s, find db1 s <> None -> s \in at_depth targets 0) /\
      (forall s,  s \in depth_ge targets 0 -> find db1 s <> None) /\
      (forall s p, s \in at_depth targets 0 -> p \in step s ->
        p \in w1) /\
      (forall s, s \in at_depth targets 1 -> find db1 s <> None ->
          step s \subset [::]) /\
      (forall p, p \in w1 ->
          exists2 tp, transition p.1 p.2 = Some tp &
                   tp \in at_depth targets 0) /\
      (forall p, p \in [::] ->
        exists2 tp, transition p.1 p.2 = Some tp
           & tp \in at_depth targets 1 /\ find db1 tp <> None).
Proof.
suff main (ts : seq state) :
  forall db w2,
  (targets =i [set s in ts] :|: [set s | find db s != None]) ->
  (w2 =i \bigcup_(s in [set s | find db s != None]) [set p in step s]) ->
  bfs_aux _ _ _ find add step [seq (s, m) | s <- ts] w2 db = (w1, db1) ->
  (forall s, find db1 s <> None -> s \in at_depth targets 0) /\
      (forall s,  s \in depth_ge targets 0 -> find db1 s <> None) /\
      (forall s p, s \in at_depth targets 0 -> p \in step s ->
        p \in w1) /\
      (forall s, s \in at_depth targets 1 -> find db1 s <> None ->
          step s \subset [::]) /\
      (forall p, p \in w1 ->
          exists2 tp, transition p.1 p.2 = Some tp
              & tp \in at_depth targets 0) /\
      (forall p, p \in [::] ->
          exists2 tp, transition p.1 p.2 = Some tp &
           tp \in at_depth targets 1 /\ find db1 tp <> None).
  apply: (main targets empty [::]).
    have -> : [set s | find empty s != None] = set0.
      by apply/setP; move=> s; rewrite inE find_empty eqxx in_set0.
    by rewrite setU0=> s; rewrite inE.
  move=> s /=; rewrite in_nil; apply/esym/negP=> /bigcupP=> -[] s'.
  by rewrite inE find_empty.
elim: ts => [ | s ts Ih] db w2.
  move=> /= targetsq w2q [<- <-].
    have targetsq' : forall s, s \in targets <-> find db s <> None.
      by move=>s; split; rewrite targetsq !inE in_nil=> /eqP.
  have db0 : forall s, find db s <> None -> s \in at_depth targets 0.
    by move=> s fdbs; rewrite -at_depth0 targetsq'.
  split; first by [].
  split.
    by move=> s; rewrite -depth_ge0 targetsq'.
  split.
    move=> s p; rewrite -at_depth0 targetsq'=> /eqP sin pin.
    by rewrite w2q; apply/bigcupP; exists s; rewrite inE.
  split.
    move=> s sin1 /db0 sin; suff : s \in set0 by rewrite in_set0.
    rewrite -(at_depthSNge targets 0) inE sin1.
    by rewrite (subsetP (at_depth_sub_ge _ _)).
  split.
    move=> p; rewrite w2q=>/bigcupP[] s; rewrite inE=> /eqP/db0 sin.
    by rewrite inE step_def inE => /eqP ->; exists s.
  by [].
move=> targetsq w2q /=.
case fdbs : (find db s) => [m' | ].
  apply: Ih=> //.
  move=> s'; rewrite targetsq !inE.
  by have [-> | s'ns]  := eqVneq s' s; first rewrite fdbs !orbT.
apply: Ih.
  move=> s'; rewrite !inE targetsq !inE.
  have [-> | s'ns]  := eqVneq s' s; first by rewrite add_find !orbT.
  by rewrite add_find2 1?eq_sym.
move=> p; rewrite mem_cat; apply/idP/bigcupP.
  move=> /orP[pins | ].
    exists s; rewrite inE //; first by rewrite add_find.
  rewrite w2q=> /bigcupP[] s'; rewrite !inE=> /eqP sin pins'.
  have sns' : s != s' by apply/eqP=> ss'; case sin; rewrite -ss' fdbs.
  by exists s'; rewrite !inE ?add_find2 //; apply/eqP.
move=>[] s'; have [ss' _ | sns'] := eqVneq s s'.
  by rewrite inE ss' => ->.
rewrite !inE add_find2 // => s'in pins'.
apply/orP; right.
by rewrite w2q; apply/bigcupP; exists s'; rewrite inE.
Qed.

Lemma bfs_depth_bound m targets n db2 k:
  bfs find add step n.+2
    [seq (s, m) | s <- targets] empty 0 = inl (db2, k.+1) ->
  (forall s, find db2 s <> None <-> s \in depth_ge targets k.+1) /\
  at_depth targets k.+2 = set0 /\
  (forall s m n, s \in at_depth targets n.+1 ->
  find db2 s = Some m ->
  exists2 s', transition s m = Some s' &
   find db2 s' <> None /\ s' \in at_depth targets n).
Proof.
rewrite bfs_step.
case bfs_aux0q : (bfs_aux _ _ _ _ _ _ _ _ _) => [w1 db0].
have [db0depth [depth0in [depth1in [startw2 [propw1 propw2]]]]] :=
  bfs_aux_layer0 bfs_aux0q.
case w1q: w1 => [ | e w1'].
  move=> [<- <-]; split;[ | split].
  - move=> s; split; last by move/depth0in.
    by move/db0depth; apply/subsetP/at_depth_sub_ge.
  - apply/setP=> s; rewrite in_set0; apply/negP=>/[dup] sin.
    move=> /at_depth_exists_path[] [ | m' []] /= sol zl //.
    suff : (s, m') \in w1 by rewrite w1q.
    move: sol; case tsmq : (transition s m') => [tsm' | ] // sol.
    apply: (depth1in tsm' (s, m')).
      by rewrite -at_depth0.
    by rewrite step_def inE tsmq.
  move=> s m2 n2 sin2 fdbs.
  have /db0depth : find db0 s <> None by rewrite fdbs.
  by move=> /(at_depth_unique sin2).
rewrite -w1q [(0 + 1)%coq_nat]/=.
move=> bfsq.
have w1q' : w1 =i \bigcup_(s in at_depth targets 0) [set x in step s].
  move=> p; apply/idP/idP.
    move=> /propw1 [tp tpq tr1].
    by apply/bigcupP; exists tp => //; rewrite inE step_def inE tpq.
  by move=>/bigcupP[] s /depth1in; rewrite inE=> /[apply].
have db0q : forall s, find db0 s <> None <-> s \in depth_ge targets 0.
  move=> s; split; first by move=> /db0depth; apply/subsetP/at_depth_sub_ge.
  by move=> /depth0in.
have db0c : forall s m n, s \in at_depth targets n.+1 ->
  find db0 s = Some m ->
  exists2 s', transition s m = Some s' &
   find db0 s' <> None /\ s' \in at_depth targets n.
 move=> s2 m2 n2.
  move=> s2in2 s2db.
  have /db0q : find db0 s2 <> None by rewrite s2db.
  by rewrite -depth_ge0 at_depth0=> /(at_depth_unique s2in2).
have [endcase contcase] := bfs_depth_main n db2 w1q' db0q db0c.
by have := endcase _ bfsq; tauto.
Qed.

(* Lemma bfs_depth guarantees that the longest path is smaller than k.+2, but
  it may well be smaller than k.+1.  For a more precise estimate of the
  longest path length, we need to observe the last non-empty working list. *)

Lemma bfs_depth_witness m targets n db2 w :
  bfs find add step n [seq (s, m) | s <- targets] empty 0 =
  inr(w, db2) ->
  (forall p, p \in w -> find db2 p.1 = None -> p.1 \in at_depth targets n) /\
  ((forall p, p \in w -> find db2 p.1 <> None) -> at_depth targets n = set0).
Proof.
case: n => [ | n].
  rewrite /= => -[<- <-]; split.
    by move=> p /mapP[] s + -> //=; rewrite at_depth0.
  move=> abs.
  apply/setP; move=> s; rewrite in_set0 -at_depth0; apply/negP=> sin.
  by apply: (abs (s, m)); rewrite ?find_empty //; apply/mapP; exists s.
case: n => [ | n].
  rewrite /=; case bfs_auxq : (bfs_aux _ _ _ _ _ _ _ _ _)=> [w3 db3].
  case w3q : w3 => [ // | p' w3']; rewrite -w3q {w3q p' w3'}.
  move=> [<- <-].
  have [db3d0 [deb0db3 [step0w [dep1ndb3 [w3P _]]]]] :=
    bfs_aux_layer0 bfs_auxq.
  split.
    move=> [s ms] /= inw3 ndb3; apply/at_depthP; split.
      by exists [:: ms]; move: (w3P _ inw3)=> //= [sms ->]; rewrite at_depth0.
    move=> l sol; rewrite ltnNge leqn0 size_eq0; apply/negP=> /eqP lnil.
    by move: sol; rewrite lnil=> /=; rewrite depth_ge0=> /deb0db3[].
  move=> all0; apply/setP=> s; rewrite in_set0; apply/negP.
  move=> /[dup] sd1.
  move=>/at_depthP[][][ | m' [ | ? ?]] // /=.
  case tsmq : (transition s m') => [tsm' | ] // + _.
  have : (s, m') \in step tsm' by rewrite step_def inE tsmq.
  rewrite at_depth0=> /step0w /[apply] /all0/db3d0 /=.
  by move=> /(at_depth_unique sd1).
rewrite bfs_step.
case bfs_auxq: (bfs_aux _ _ _ _ _ _ _ _ _) => [w3 db3].
case w3q : w3 => [ | m3 w4] //; rewrite -w3q {m3 w4 w3q}.
rewrite [(0 + 1)%coq_nat]/=.
have [db3d0 [deb0db3 [step0w [dep1ndb3 [w3P _]]]]] :=
    bfs_aux_layer0 bfs_auxq.
have w1q' : w3 =i \bigcup_(s in at_depth targets 0) [set x in step s].
  move=> p; apply/idP/idP.
    move=> /w3P [] tp tpq tpin.
    apply/bigcupP; exists tp => //.
    by rewrite inE step_def inE tpq.
  by move=>/bigcupP[] s; rewrite inE; apply step0w.
have db0q : forall s, find db3 s <> None <-> s \in depth_ge targets 0.
  move=> s; split; first by move=> /db3d0; apply/subsetP/at_depth_sub_ge.
  by apply: deb0db3.
(* TODO : code duplication. *)
have db0c : forall s m n, s \in at_depth targets n.+1 ->
  find db3 s = Some m ->
  exists2 s', transition s m = Some s' &
   find db3 s' <> None /\ s' \in at_depth targets n.
 move=> s2 m2 n2.
  move=> s2in2 s2db.
  have /db0q : find db3 s2 <> None by rewrite s2db.
  by rewrite -depth_ge0 at_depth0=> /(at_depth_unique s2in2).
have [_ contcase] := bfs_depth_main n db2 w1q' db0q db0c.
move=> /contcase; rewrite addn0=> -[wq [ZZ _]].
split.
  move=> p; rewrite wq=> /bigcupP[] s sin; rewrite inE=> pin pndb.
  suff : p.1 \in depth_ge targets n.+2.
    by rewrite depth_geS inE=> /orP[] //; rewrite -ZZ pndb.
  move: sin=> /at_depth_exists_path[] l sol zl.
  move: pin; rewrite step_def inE=> /eqP trps.
  have zl' : size (p.2 :: l) <= n.+2 by rewrite /= zl.
  rewrite inE; apply/existsP=> /=; exists (Bseq zl') => /=.
  by rewrite trps.
move=> /= alldb.
apply/setP=> s; rewrite in_set0; apply/negP.
move=> /[dup]sdn2.
move=> /at_depthP[][] [ | m' l] // sol /= [zl] nshort.
have zl' : size l <= n.+1  by rewrite zl.
move: sol => /=; case tsmq : (transition s m') => [ tsm' | ] // sol.
have : tsm' \in at_depth targets n.+1.
   by have := at_depth_decrease sdn2 tsmq sol zl.
move=> /[dup] trn /(subsetP (at_depth_sub_ge targets n.+1)) trindb.
have /alldb/=/ZZ sdn1 : (s, m') \in w.
  rewrite wq; apply/bigcupP; exists tsm'=> //.
  by rewrite inE step_def inE tsmq.
suff : s \in set0 by rewrite in_set0.
by rewrite -(at_depthSNge targets n.+1); rewrite inE sdn2 sdn1.
Qed.

Lemma bfs_shiftr n w w2 k1 k2 db db2 :
  bfs find add step n w db k1 = inr(w2, db2) ->
  bfs find add step n w db k2 = inr(w2, db2).
Proof.
elim: n w db k1 k2=> [ | n Ih] w db k1 k2//=.
case: (bfs_aux _ _ _ _ _ _ _ _ _)=> [w' db'].
case w'q : w' => [ | p3 w3] //; rewrite -w'q {p3 w3 w'q}.
by apply: Ih.
Qed.

Lemma bfs_cat n m w w2 w3 k1 k2 k3 db db2 db3:
  bfs find add step n w db k1 = inr(w2, db2) ->
  bfs find add step m w2 db2 k2 = inr(w3, db3) ->
  bfs find add step (n + m) w db k3 = inr(w3, db3).
Proof.
elim: n w k1 k3 db => [ | n Ih] w k1 k3 db.
  move=> /= [] <- <-; rewrite add0n.
  by apply: bfs_shiftr.
rewrite /=; case bfsaq : (bfs_aux _ _ _ _ _ _ _ _ _) => [w' db'] .
case w'q : w' => [ | p4 w4] //; rewrite -w'q {w'q p4 w4}.
by move=> cp1 cp2; have := Ih _ _ (k3 + 1)%coq_nat _ cp1 cp2.
Qed.

Lemma table_consistent_make_path N db targets targetb:
  targetb =1 mem targets ->
  (forall s, find db s <> None <-> s \in depth_ge targets N) ->
  (forall s m n, s \in at_depth targets n.+1 -> find db s = Some m ->
     exists2 s', transition s m = Some s' &
       find db s' <> None /\ s' \in at_depth targets n) ->
  forall s n, n <= N -> s \in at_depth targets n ->
     exists2 l, make_path find db targetb transition s n.+1 = Some l &
      is_solution targets s l /\ size l = n.
Proof.
move=> targetbP bnd consistent /[swap]; elim => [ | n Ih] s nN.
  rewrite -at_depth0=> sin /=.
  by rewrite targetbP /= sin; exists [::].
move=> /[dup] sin1 /(subsetP (at_depth_sub_ge _ _)).
move=> /(subsetP (depth_ge_trans targets nN)) /bnd.
case fdbq : (find db s) => [ m | ] // _.
have [s' tsmq [fdbs' s'in]] := consistent _ _ _ sin1 fdbq.
have nleN : n <= N by exact: (ltnW nN).
have [l' l'q [sol' zl']] := Ih s' nleN s'in.
exists (m :: l').
  rewrite make_path_step fdbq tsmq l'q.
  rewrite targetbP /=; case: ifP=> //.
  rewrite at_depth0 => sin0.
  by have := at_depth_unique sin1 sin0.
by rewrite /= tsmq zl' sol'.
Qed.

(* This is the final theorem:
  if breadth_first_search succeeds (result of the form inl(db, k) then:
  - the number in the result is an over estimate of the maximal length
    of solutions
  - the table can be used by function make_path (which will always
    succeeds on elements of the path) to produce optimal solutions *)

Lemma bfs_make_path_optimal db targets targetb n m k:
  targetb =i mem targets ->
  bfs find add step n.+2 [seq (s, m) | s <- targets] empty 0 =
  inl (db, k.+1) ->
  forall s, find db s <> None ->
    [/\ s \in depth_ge targets k.+1,
    is_solution targets s (odflt [::]
       (make_path find db targetb transition s k.+2)) &
    forall l, is_solution targets s l ->
       size (odflt [::] (make_path find db targetb transition s k.+2)) <= size l].
Proof.
move=> targetbP bfsq.
have [dle [_ expath]] := bfs_depth_bound bfsq.
move=> s /[dup] fdbn; case fdbq : (find db s) => [ms | ] // _.
have := table_consistent_make_path targetbP dle expath.
have /dle/depth_ge_exists[ n' sin' n'le]  := fdbn.
move=> /(_ s n' n'le sin')[l lq [sol zl]].
have n'le' : n'.+1 <= k.+2 by rewrite ltnS.
rewrite (make_path_le n'le' lq) /=; split => //; first by apply/dle.
by rewrite zl=> l2 sol2; apply: (at_depth_le sin').
Qed.

End proof_context.


Require Import QArith_base.
Require Import ballotPollAudit.
Require Import FCF.
Require Import Crypto.
Require Import Basics.
Require Import Bernoulli.

Definition is_some {A : Type} (o : option A) :=
match o with
| Some _ => true
| None => false
end.

Definition nat_to_posnat_ (n : nat) : option posnat.
destruct n eqn:?. exact (None).
assert (nz n). constructor. symmetry in Heqn0.
subst.
exact (gt_Sn_O n0).
exact (Some (pos n)).
Defined.

Definition nat_to_posnat (n : nat) : posnat.
destruct n eqn:?. exact (pos 1).
assert (nz n). constructor. symmetry in Heqn0.
subst.
exact (gt_Sn_O n0).
exact (pos n).
Defined.

Definition get_random_ballot' (votes : list (option bool)) : Comp (option bool) :=
(n <-$ (RndNat (nat_to_posnat (length votes))) ; ret (nth n votes (None))).

Definition get_random_ballot_ratio (ratio : Rat) : Comp bool :=
Bernoulli ratio.

Definition get_random_ballot votes :=
match votes with
| nil => ret None
| _ => get_random_ballot' votes
end.

Definition is_winner_vote (o : option bool) :=
match o with
| Some true => true
| _ => false
end.

Definition is_loser_vote (o : option bool) :=
match o with
| Some true => true
| _ => false
end.

Definition count {A} (f : A -> bool) (l : list A) :=
length (filter f l).

Lemma get_random_ballot_wf : forall v,
    well_formed_comp (get_random_ballot v).
intros.
unfold get_random_ballot.
destruct v; wftac.
unfold get_random_ballot'.
simpl. wftac.
Qed.

Hint Resolve get_random_ballot_wf : wftac.

Instance EqDecOptionBool : EqDec (option bool).
apply _.
Qed.

Definition nat_to_rat n := RatIntro n (pos 1).

Definition tabulate (votes : list (option bool)) :=
(count is_winner_vote votes, count is_loser_vote votes).

Lemma tabulate_sumlist : forall votes winners losers,
length votes <> O ->
tabulate votes = (winners, losers) ->
sumList (allNatsLt (nat_to_posnat (length votes)))
     (fun z : nat => evalDist (ret nth z votes None) (Some true)) == (nat_to_rat winners).
intros. destruct votes. intuition.
clear H.
generalize dependent winners.
revert o losers.
induction votes; intros.
- simpl in *. unfold sumList. simpl.
  dist_compute. subst. unfold tabulate in H0. unfold count in H0 at 1. simpl in H0. inversion H0.
  unfold nat_to_rat. unfold eqRat. simpl. unfold beqRat.
  simpl in *. auto.
  destruct o eqn:?.
  + destruct b;  intuition.
    unfold tabulate, count in H0. simpl in *. inversion H0; auto.
    unfold nat_to_rat. unfold eqRat. unfold beqRat. simpl. auto.
  + subst.
    unfold tabulate, count in H0. simpl in *. inversion H0; auto.
    unfold nat_to_rat. unfold eqRat. unfold beqRat. simpl. auto.
- simpl in *. rewrite sumList_app.
  destruct a eqn:?.
  +
Admitted.

Lemma random_prob' : forall votes winnervotes loservotes totalvotes,
tabulate votes = (winnervotes,loservotes ) ->
nat_to_posnat_ (length votes) = Some totalvotes ->
evalDist (get_random_ballot votes) (Some true) ==
RatIntro (winnervotes) (totalvotes).
intros.
destruct votes. inversion H0.
unfold get_random_ballot, get_random_ballot'.
rewrite RndNat_seq. remember (cons o votes) as all_votes.
rewrite (sumList_filter_partition (compose is_winner_vote (fun n => nth n votes None))).
(*
rewrite (sumList_filter_partition (compose is_loser_vote (fun n => nth n votes None))) at 2.

specialize (H1 (allNatsLt (length votes))).
rewrite (sumList_filter_partition (is_winner_vote)).
SearchAbout sumList. Print sumList.
eapply eqRat_trans. Check RndNat_seq.
change (ret nth n (o :: votes) None) with (fun n => ret nth n (o :: votes) None).
apply RndNat_seq.
SearchAbout evalDist.
*)
Admitted.

Lemma random_prob :  forall votes winnervotes loservotes totalvotes,
tabulate votes = (winnervotes,loservotes ) ->
nat_to_posnat_ (length votes) = Some totalvotes ->
Pr[v <-$ (get_random_ballot votes); ret (is_winner_vote v)] ==
RatIntro (winnervotes) (totalvotes).
intros. destruct votes. inversion H0.
unfold get_random_ballot, get_random_ballot'.
pose proof  RndNat_prob.
specialize (H1 (length (o :: votes))).
eapply eqRat_trans. SearchAbout RndNat. SearchAbout evalDist. Print Distribution.
simpl. unfold evalDist. Print getSupport. Print getAllBvectors.
Compute (getAllBvectors 2).
Print Bind.
simpl.
Check evalDist_seq_case_split_eq.
SearchAbout evalDist.
Admitted.

Fixpoint sampleBallots' (toSample : nat)  (votes : list (option bool)) : Comp (list (option bool)) :=
match toSample with
| O => ret (nil)
| S x' => n <-$ (RndNat (length votes));
          r <-$ (sampleBallots' x'  votes);
          ret (cons (nth n votes (None)) r)
end.

Definition sampleBallots toSample votes :=
match votes with
| nil => ret nil
| _ => sampleBallots' toSample votes
end.

Lemma sampleBallots_wf : forall c v,
    well_formed_comp (sampleBallots c v).
intros.
unfold sampleBallots.
destruct v; wftac.
induction c; simpl; wftac.
Qed.

Local Open Scope nat.

Lemma plus_gt_0 :
forall (a b : nat),
a > 0 ->
a + b > 0.
intros.
induction a; omega.
Qed.

Definition posnatAdd (p1 : posnat) (n : nat) : posnat.
destruct p1.
exact (@natToPosnat (x + n) (Build_nz (plus_gt_0 x n g))).
Defined.

Definition winner_margin v : option Rat:=
let (winvotes, losevotes) := tabulate v in
option_map (fun v => RatIntro winvotes (posnatAdd v losevotes)) (nat_to_posnat_ winvotes).

Definition posnat_to_pos (p : posnat) : positive.
destruct p.
exact (Pos.of_nat x).
Defined.

Definition Rat_to_Q r :=
match r with
| RatIntro n d => Z.of_nat n # posnat_to_pos d
end.

Definition gtb a b :=
match nat_compare a b with
| Gt => true
| _ => false
end.

Definition full_count_audit (votes : list (option bool)) (_ : Q) (_ : Q) :=
let (rep_winner_count, rep_loser_count) := tabulate votes in
if (gtb rep_winner_count rep_loser_count) then
    ret true
else
    ret false.

Definition update_T (vote : bool) (T : Q) (winnerShare : Q) :=
if vote then
  (((2 # 1) * winnerShare) * T)%Q
else
  (((2 # 1) * (1 - winnerShare)) * T)%Q
.

Fixpoint do_audit_inc' total_votes votes T margin risk : Comp bool :=
match total_votes with
| O => full_count_audit votes risk margin
| S n => b <-$ get_random_ballot votes;
        (match b with
         | Some vote =>
           let T' := update_T vote T margin in
           if (Qlt_bool T' risk) then
             ret true
           else
             do_audit_inc' n votes T' margin risk
         | None => do_audit_inc' n votes T margin risk
         end)
end.

(*an audit returns true if the election result is likely correct, and false otherwise*)
Fixpoint do_audit_inc_rat' T n total_votes actual_margin reported_margin risk : Comp bool :=
match total_votes with
| O => ret false
| S total_votes' => vote <-$ get_random_ballot_ratio actual_margin;
        let T' := update_T vote T reported_margin in
        if (Qlt_bool T' risk) then
          ret true
        else
          do_audit_inc_rat' T' (S n) total_votes' actual_margin reported_margin risk
end.

Definition do_audit_inc_rat total_votes actual_margin reported_margin risk : Comp bool :=
do_audit_inc_rat' 1 0 total_votes actual_margin reported_margin risk .

Definition isProb_Q (a : Q) :=
(a <= 1)%Q.

Definition isUncertain_Q (a : Q) :=
~ (a == 0)%Q /\ ~(a == 1)%Q.

Definition isProb_Rat (a : Rat) :=
(a <= 1)%rat.

Definition isUncertain_Rat (a : Rat) :=
~ (a == 0)%rat /\ ~(a == 1)%rat.

Definition lose_game_prob_only (audit : nat -> Rat -> Q -> Q -> Comp bool)
           total_votes (actual_margin : Rat) (reported_margin : Q) risk:=
  if (Qle_bool (Rat_to_Q actual_margin) (1 # 2))
  then audit total_votes actual_margin reported_margin risk
  else ret false.

Definition valid_audit_prob_only audit :=
forall total_votes actual_margin reported_margin risk,
  isProb_Rat actual_margin ->
  isProb_Q reported_margin ->
  isUncertain_Rat (actual_margin) ->
  leRat (Pr [lose_game_prob_only audit total_votes actual_margin reported_margin (Rat_to_Q risk)])
        risk.

Ltac if_match_tac :=
match goal with
|  [  |- context [ if ?b then _ else _ ] ] =>
   destruct b eqn:?
|  [ |- context [ match ?m with _ => _ end ] ] =>
   destruct m eqn:?
end.

Lemma get_support_bernoulli_nz :
forall n f,
~(n == 0)%rat ->
~(n == 1)%rat ->
(n <= 1)%rat ->
sumList (getSupport (Bernoulli n)) f == sumList (cons true (cons false nil)) f.
intros.
pose proof (getSupport_correct (Bernoulli n)).
unfold Support in *.
destruct H2.
assert (In true (getSupport (Bernoulli n))).
apply H3. intro. rewrite Bernoulli_correct in H4. intuition.
auto.
assert (In false (getSupport (Bernoulli n))).
apply H3. intro.
rewrite Bernoulli_correct_complement in H5.
apply ratSubtract_0_inv in H5. SearchAbout leRat.
apply leRat_impl_eqRat in H5; auto. auto.
destruct (getSupport (Bernoulli n)). inversion H4.
destruct l. destruct b; simpl in *; intuition; try congruence.
simpl in *. destruct l. destruct b, b0; intuition; try congruence; auto.
unfold sumList. simpl. repeat rewrite <- ratAdd_0_l.
rewrite (ratAdd_comm (f false) (f true)). reflexivity.
inversion H2. subst. destruct b, b0, b1; try intuition.
inversion H9. intuition.
inversion H9; intuition.
inversion H9; intuition.
inversion H9; intuition.
Qed.

Lemma plus_minus_1 : forall (m : Rat),
(m <= 1)%rat ->
(m + (ratSubtract 1 m)%rat)%rat == 1%rat.
intros.
rewrite <- ratSubtract_ratAdd_assoc; auto.
rewrite ratSubtract_ratAdd_inverse. reflexivity.
Qed.

Definition bool_to_nat (b: bool) :=
if b then 1 else 0.

Fixpoint n_bernoulli (n : nat) R : Comp nat :=
match n with
| O => (b <-$ (Bernoulli R);
        ret (bool_to_nat b))
| S n => b <-$ Bernoulli R;
         r <-$ n_bernoulli n R;
         ret ((bool_to_nat b) + r)
end.

Definition do_binomial x (N : posnat) R :=
b <-$ n_bernoulli N R;
ret leb x b.

Lemma nat_lt_gt : forall x y,
x < y <-> y > x.
intros. omega.
Qed.

Definition fact_posnat (x : posnat) : posnat.
assert (nz (fact x)) by (constructor; rewrite <- nat_lt_gt; apply lt_O_fact).
apply (pos (fact x)).
Defined.

Definition fact_nat_posnat (x : nat) : posnat.
assert (nz (fact x)) by (constructor; rewrite <- nat_lt_gt; apply lt_O_fact).
apply (pos (fact x)).
Defined.

Fixpoint ratPower (r : Rat) (n : nat) : Rat :=
match n with
| O => 1%rat
| S n' => (r * ratPower r n')%rat
end.

Definition choose (N : posnat) (x : nat) : Rat :=
RatIntro (fact N) (posnatMult (fact_nat_posnat x) (fact_nat_posnat (N - x))).

Definition binomial (N : posnat) (x : nat) (r : Rat) : Rat :=
((choose N x) * (ratPower r x) * (ratPower (ratSubtract 1%rat r)%rat (N - x)))%rat.

Lemma n_bernoulli_binomial :
forall N x R,
Pr[ do_binomial x N R ] == binomial N x R.
Proof.
intros.
destruct N.
destruct x0. omega.
generalize dependent g.
induction x0. intros.
unfold binomial. unfold choose. simpl fact.
simpl ratPower.
unfold do_binomial. unfold evalDist. fold evalDist.
simpl n_bernoulli. unfold getSupport.
Admitted.

Lemma do_audit_inc_rat'_correct :
forall R T n,
R T n ->
valid_audit_prob_only (do_audit_inc_rat' T n).
Proof.
  intros. unfold valid_audit_prob_only.
  intros.
  induction total_votes.
  - unfold lose_game_prob_only.
    if_match_tac; dist_compute; apply rat0_le_all.
  - unfold lose_game_prob_only. simpl. if_match_tac.
    simpl. rewrite get_support_bernoulli_nz.
    unfold sumList.
    simpl. dist_compute_simp.
    rewrite Bernoulli_correct.
    rewrite Bernoulli_correct_complement.
     { repeat if_match_tac.
        - simpl. dist_compute. rewrite plus_minus_1.

Lemma do_audit_inc'_wf :
forall total_votes votes T margin risk,
well_formed_comp (do_audit_inc' total_votes votes T margin risk).
induction total_votes; intros; simpl; wftac.
simpl. unfold full_count_audit; wftac.
simpl. intros. destruct b; simpl; wftac.
Qed.

Fixpoint do_audit' total_votes votes winnerseen loserseen margin risk : Comp bool :=
match total_votes with
| O => ret (false)
| S n => b <-$ get_random_ballot votes;
        (match b with
        | Some true => match (auditDone (N.of_nat (S winnerseen)) (N.of_nat loserseen) margin risk) with
                       | true => ret (true)
                       | false => (do_audit' n votes (S winnerseen) loserseen margin risk)
                       end
        | Some false => do_audit' n votes winnerseen (S loserseen) margin risk
        | _ => do_audit' n votes winnerseen loserseen margin risk
        end)
end.

Lemma do_audit'_wf :
forall tv v ws ls m r, well_formed_comp (do_audit' tv v ws ls m r).
induction tv; intros; unfold do_audit'.
wftac. simpl. wftac.
intros.
repeat if_match_tac; wftac.
Qed.

Definition do_audit votes risk margin :=
do_audit' (length votes) votes 0 0 (Rat_to_Q margin) risk.

Definition do_audit_inc votes risk margin :=
do_audit_inc' (length votes) votes 0 margin risk.

Definition vote_to_win_lose (winner loser vote : nat) : option bool :=
if (beq_nat winner vote) then
  Some true
else
  if (beq_nat loser vote) then
    Some false
  else
    None.

Definition votes_to_win_lose (winner loser : nat) votes :=
map (vote_to_win_lose winner loser) votes.

Lemma gtb_gt_iff : forall a b, gtb a b = true <-> a > b.
Proof.
intros.
split; intros;
unfold gtb in *;
destruct (nat_compare a b) eqn:?; intuition;
try rewrite <- nat_compare_gt in *;
try rewrite <- nat_compare_lt in *;
try rewrite nat_compare_eq_iff in *; subst; try omega; auto.
Qed.

Definition win_game (audit : list (option bool) -> Q -> Q -> Comp bool)
           (actual_votes : list nat) (reported_winner : nat)
           (reported_loser : nat) (reported_margin : Q) risk  :=
  if (beq_nat (length actual_votes)  0)
  then ret true
  else
    let win_loss_votes := votes_to_win_lose reported_winner reported_loser actual_votes in
    let (rep_winner_count, rep_loser_count) := tabulate win_loss_votes in
    if (gtb rep_winner_count rep_loser_count) then
      ret true
    else
      result <-$ audit win_loss_votes risk reported_margin;
      ret (negb result)
.

Definition valid_audit audit :=
forall actual_votes reported_winner
       reported_loser reported_margin risk,
  leRat (ratSubtract 1%rat risk)
         (Pr[win_game audit actual_votes reported_winner
                      reported_loser (Rat_to_Q risk)
                      reported_margin]).

Lemma valid_full_count :
  valid_audit full_count_audit.
Proof.
  intros.
  unfold valid_audit.
  intros.
  unfold win_game. if_match_tac.
  - dist_compute. apply ratSubtract_le. auto.
  - simpl in *. if_match_tac. dist_compute. apply ratSubtract_le; auto.
    unfold full_count_audit. simpl in *. rewrite Heqb0. simpl.
    dist_compute. apply ratSubtract_le; auto.
Qed.

Lemma evalDist_negb : forall (c : Comp bool) (a : bool),
    evalDist (x <-$ c; ret (negb x)) a == evalDist (x <-$ c; ret x) (negb a).
Proof.
Admitted.

Lemma length_filter_true_bool :
forall l,
NoDup l ->
length (filter (fun b : bool => b) l) <= 1.
intros.
induction l. simpl. auto.
simpl. destruct a. simpl. inversion H.
intuition.
subst.

Lemma not_true_length : forall l,
~In true l -> length (filter (fun b => b) l) = 0.
intros.
induction l. auto.
simpl in *. destruct a. simpl in *. intuition.
intuition.
Qed.

rewrite not_true_length. auto. auto.
inversion H. auto.
Qed.

Lemma ratone_rat :
(1/1 == 1)%rat.
rattac. inversion H0.
auto.
Qed.

Lemma rat_ratone :
(1 == 1/1)%rat.
rattac. inversion H0.
auto.
Qed.

Lemma lognat_0_unique :
forall x, lognat x = 0 -> x = 0.
intros.
induction x. auto.
unfold lognat in H. simpl in *.
destruct (Pos.of_succ_nat x) eqn:?.
simpl in *. congruence. simpl in H. intuition. simpl in *. congruence.
Qed.

(*Lemma sumlist_support_superSet :*)

Lemma valid_ballot_poll_inc_rat :
  valid_audit_prob_only do_audit_inc_rat.
Proof.
  unfold valid_audit_prob_only.
  intros.
  unfold lose_game_prob_only.
  if_match_tac.
  unfold do_audit_inc_rat. remember 1%Q. clear Heqq.
  - induction total_votes.
    + simpl. unfold sumList. simpl. repeat if_match_tac; dist_compute; auto. rattac.
    + unfold do_audit_inc_rat. unfold do_audit_inc_rat'. fold do_audit_inc_rat'.
      simpl.
      unfold get_random_ballot_ratio.
      rewrite get_support_bernoulli_nz. unfold sumList. simpl.
      rewrite Bernoulli_correct.
      rewrite Bernoulli_correct_complement. dist_compute_simp.
      remember (Qlt_bool ((2 # 1) * reported_margin * q) (Rat_to_Q risk)).
      destruct b.
      simpl.
      dist_compute_1; try congruence. dist_compute_simp.
      if_match_tac. dist_compute.
      rewrite plus_minus_1; auto.
      admit. (*believable*)

Local Open Scope rat.

      simpl. dist_compute.
      SearchAbout Rat.
      rewrite multRat_1_r.

 dist_compute.

      rewrite (sumList_filter_partition (fun b => b)).
      eapply leRat_trans.
      eapply ratAdd_leRat_compat.
Check sumList_all.
      rewrite sumList_all.
      Focus 2. intros.
      apply filter_In in H. destruct H. subst.
      reflexivity.
      simpl. SearchAbout Support.
      destruct (Qlt_bool ((2 # 1) * reported_margin * 1) (Rat_to_Q risk)) eqn:?.
      simpl. rewrite Bernoulli_correct.
      eapply ratMult_leRat_compat. instantiate (1:=1%rat).
      destruct (length
                  (filter (fun b : bool => b) (getSupport (Bernoulli actual_margin)))) eqn:?.
      rattac.
      destruct n. rewrite ratone_rat. rattac.

      assert (X := length_filter_true_bool (getSupport (Bernoulli actual_margin))).
      assert ( NoDup (getSupport (Bernoulli actual_margin))) by (apply getSupport_NoDup).
      intuition.

      instantiate (1:=actual_margin).
      dist_compute.

Lemma le_Q_Rat :
forall r s,
Qle_bool (Rat_to_Q r) (Rat_to_Q s) =true -> leRat r s.
Proof.
intros.
destruct r. destruct s. simpl in *.
unfold Qle_bool in H. simpl in *. unfold leRat, bleRat. simpl.
if_match_tac; auto. exfalso. SearchAbout Z.of_nat.
clear Heqs.
apply inj_gt in g.
repeat rewrite Nat2Z.inj_mul in g.

Lemma of_nat_posnat :
forall (p: posnat), Z.of_nat p = Zpos (posnat_to_pos p).
Proof.
intros.
destruct p. simpl. unfold Z.of_nat. destruct x; try omega.
f_equal. apply Pos.of_nat_succ.
Qed.

repeat rewrite of_nat_posnat in g. rewrite <-Zle_is_le_bool in H.
omega.
Qed.

assert ( (1 # 2) = (Rat_to_Q (RatIntro 1 (pos 2)))) by auto.
rewrite H in Heqb.
apply le_Q_Rat in Heqb.
eapply leRat_trans. apply Heqb. simpl.
rattac. inversion H2. subst. omega.

rewrite rat_ratone.
rattac.
simpl.
SearchAbout Z.of_nat.
SearchAbout posnat_to_pos.
Set Printing All.
 SearchAbout Z.of_nat.

Check ratle.
Lemma Qle_

simpl
simpl. auto.
inversion H3.
subst. simpl. destruct a. simpl.

      destruct a. simpl.
      SearchAbout (Rat -> Prop).
Lemma getSupport_bernoulli : forall r,
~ r == 1%rat ->
~ r == 0%rat ->
(getSupport (Bernoulli r)) = cons true (cons false nil).
Proof.
intros. destruct r.
destruct p.
induction (lognat x) eqn:?. simpl. rewrite Heqn0. simpl.
unfold bvToNat. simpl. clear - Heqn0 g. exfalso.
induction x. omega.
unfold lognat in *. simpl in *.
unfold lognat in *.
Check Pos.size_nat. Print Pos.size_nat.
- simpl. unfold getAllBvectors.
SearchAbout getSupport.
      Print Support.
      Print evalDist.

Print bind_eq_dec.
Print Bind.
      simpl.
      Check sumList_all.
      rewrite sumList_exactly_one.

      SearchAbout evalDist.
simpl. unfold get_random_ballot_ratio at 1. unfold Bernoulli. destruct actual_margin.
Set Printing All.
Print Proper.
      rewrite (evalDist_negb (do_audit_inc_rat' (S total_votes) actual_margin reported_margin 1
       (Rat_toQ risk)) true) at 1.
Check evalDist_right_ident.

Theorem evalDist_right_ident : forall (A : Set)(eqd : EqDec A)(c : Comp A) a,
  evalDist (x <-$ c; ret x) a == evalDist c a.

  intuition.
  destruct (in_dec (EqDec_dec eqd) a (getSupport c)).
  simpl.
  eapply eqRat_trans.
Locate sumList_exactly_one.
Check sumList_exactly_one.
  eapply sumList_exactly_one.
  eapply getSupport_NoDup.
  eauto.
  intuition.
  destruct (EqDec_dec eqd b a).
  subst.
  intuition.
  eapply ratMult_0_r.

  destruct (EqDec_dec eqd a a).
  eapply ratMult_1_r.
  congruence.

  simpl.
  eapply eqRat_trans.
  eapply sumList_0.
  intuition.
  destruct (EqDec_dec eqd a0 a).
  subst.
  intuition.
  eapply ratMult_0_r.
  symmetry.
  eapply getSupport_not_In_evalDist.
  trivial.
Qed.

Lemma evalDist_negb : forall (c : Comp bool) (a : bool),
    evalDist (x <-$ c; ret (negb x)) a == evalDist (x <-$ c; ret x) (negb a).
Proof.
  intuition.
  destruct (in_dec (EqDec_dec _) a (getSupport c)).
  simpl.
  eapply eqRat_trans.
  eapply sumList_exactly_one.
  eapply getSupport_NoDup.
  eauto.
  intuition.
  destruct (EqDec_dec eqd b a).
  subst.
  intuition.
  eapply ratMult_0_r.

  destruct (EqDec_dec eqd a a).
  eapply ratMult_1_r.
  congruence.

  simpl.
  eapply eqRat_trans.
  eapply sumList_0.
  intuition.
  destruct (EqDec_dec eqd a0 a).
  subst.
  intuition.
  eapply ratMult_0_r.
  symmetry.
  eapply getSupport_not_In_evalDist.
  trivial.

  intros.
  destruct a.
  rewrite evalDist_right_ident.
  eapply (@ratAdd_add_same_l _ (Pr[c])).
  rewrite <- sumList_support_bool. simpl.
  rewrite sumList_inverse. SearchAbout sumList.
  rewrite evalDist_left_ident_eq at 2.
  SearchAbout evalDist.
  f_equal.
  Check sumList_support_bool. SearchAbout (Comp bool).

  erewrite beqRat_trans.

Lemma valid_ballot_poll_inc :
  valid_audit do_audit_inc.
Proof.
  unfold valid_audit.
  intros.
  unfold win_game.
  if_match_tac.
  - dist_compute. apply ratSubtract_le. auto.
  - simpl.
    if_match_tac.
    + simpl. dist_compute. apply ratSubtract_le. auto.
    + induction actual_votes.
      * simpl. inversion Heqb.
      * unfold votes_to_win_lose.
        simpl map.
        unfold vote_to_win_lose at 1.
        if_match_tac.
        symmetry in Heqb1.
        apply beq_nat_eq in Heqb1.
        subst.
        Check do_audit_inc.


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.implementations.assume_rationals
               HoTT.Classes.theory.rationals
               HoTT.Classes.theory.premetric
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe FunextAxiom
               TruncType UnivalenceAxiom Types.Sigma
               HIT.quotient.

Require Import HoTTClasses.sierpinsky partiality dedekind.

Require Import Rlow Cpo.

Set Implicit Arguments.

(** * Positive 'integrable functions from A to RlowPos *)

(** Definitions *)
Definition mf (A:hSet) : Type := A -> RlowPos.

Definition ffle {A} : mf A -> mf A -> hProp.
Proof.
intros f g.
unfold mf in f, g.
refine (BuildhProp (forall x, Rlle (f x) (g x))).
Defined.

(** Order on functions *)
Global Instance fle {A} : Le (mf A)
               := fun x y => ffle x y.

(** fle is a partial order *)
Global Instance fle_ord {A} : PartialOrder (@fle A).
Proof.
split.
+  apply (@HSet.isset_hrel_subpaths _
       (fun f g => fle f g /\ fle g f)).
  red; intros.
  split; repeat red; intros; auto.
  apply _.
  intros x y (Hf1,Hf2).
  apply path_forall.
  intros s.
  unfold fle, ffle in *.
  simpl in Hf1, Hf2.
  specialize (Hf1 s).
  specialize (Hf2 s).
  apply (antisymmetry Rllepos); trivial.
+ intros x y.
  apply _.
+ split.
  - hnf.
    intros x.
    repeat red.
    auto.
  - hnf.
    intros x y z Hxy Hyz s.
    specialize (Hxy s).
    specialize (Hyz s).
    unfold Rlle in *.
    auto.
+ hnf.
  intros x y H' H1.
  apply path_forall.
  intros s.
  apply (antisymmetry Rllepos).
  apply H'.
  apply H1.
Defined.

(** Operations of functions *)
Global Instance fplus {A} : Plus (mf A) := fun f g => fun x => RlP_plus (f x) (g x).

Global Instance fzero {A} : Zero (mf A) := fun x => RlP_0.
Implicit Arguments fzero [].

Global Instance fone {A} : One (mf A) := fun x => RlP_1.
Implicit Arguments fone [].

(** Properties of fplus  *)
Lemma fplus_comm {A} : Commutative (@fplus A).
Proof.
intros a b; apply fle_ord;
intros s; unfold fplus;
rewrite (RlPPlus_comm (a s) (b s));
unfold Rlle; trivial.
Qed.

Lemma fplus_assoc {A} : Associative (@fplus A).
Proof.
intros a b c; apply fle_ord;
intros s; unfold fplus;
rewrite RlPPlus_assoc;
unfold Rlle; trivial.
Qed.

Lemma fplus_left_id {A} : LeftIdentity (@fplus A) (fzero A).
Proof.
intros a.
unfold fplus.
apply path_forall.
intros s.
apply RlPPlus_left_id.
Qed.

Lemma fplus_le_preserving {A} : forall f, OrderPreserving (fun g => fplus f g)
                                      (Ale := fle) (Ble := @fle A).
Proof.
intros f g h Hgh.
unfold fplus.
intros q.
apply RlPlus_le_preserving.
apply Hgh.
Qed.

(** Semigroup structure on mf with sg_op = plus
     - sg_op associative
     - mf A is an hset *)
Global Instance mf_semi_group {A} : SemiGroup (mf A).
Proof.
split.
+ apply _.
+ hnf. intros x y z.
  unfold sg_op, plus_is_sg_op.
  rewrite fplus_assoc.
  reflexivity.
Defined.

(** mf A is a cpo *)
Global Instance mf_cpo {A} : cpo (mf A).
Proof.
split with (fzero A) (fun f : (nat -> mf A) => (fun x =>
                 RllubPos (fun n => f n x))).
+ intros f n a.
  apply (Rllub_lub (fun n => f n a)).
+ intros f x H.
  assert (HL : forall n a, Rlle (f n a) (x a)).
  apply H. intros a.
  apply Rllub_le; trivial.
  intros n; unfold toRlseq.
  apply HL.
+ intros x Hx s Hs.
  simpl in Hs.
  unfold semi_decide, Rllt_semi_dec,
         decidable_semi_decide in Hs;
  destruct (dec (s < Qzero)).
  apply rlpos; trivial.
  apply not_bot in Hs; case Hs.
Defined.

(** Bounded functions *)

Record mfb (A : hSet) := mk_mfb {
    ff :> A -> RlowPos;
    Hfb : merely (exists b, forall x, Rlle (ff x) (QRlow b))
}.

Definition fbzero (A : hSet) : Zero (mfb A).
Proof.
exists (fzero A).
apply tr; exists Qzero.
intros x s; trivial.
Qed.

Definition fbone (A : hSet) : One (mfb A).
Proof.
exists (fone A).
apply tr; exists Qone.
intros x s; trivial.
Defined.

Definition fbplus (A : hSet) : Plus (mfb A).
Proof.
intros f g; exists (fun x => (fplus f g) x).
destruct f as (f,Hf).
destruct g as (g,Hg).
revert Hf; apply (Trunc_ind _); intros (bf,Hf).
revert Hg; apply (Trunc_ind _); intros (bg,Hg).
apply tr; exists (bf + bg); intros x.
simpl; intros s Hs.
rewrite RlPlus_Q.
revert Hs; apply Rlow_mon.
reflexivity.
assert (H2 : Rlle (RlPlus (f x) (g x))
                  (RlPlus (f x) (QRlow bg))).
apply RlPlus_le_preserving.
apply Hg.
assert (H3 : Rlle (RlPlus (f x) (QRlow bg))
                  (RlPlus (QRlow bf) (QRlow bg))).
rewrite RlPlus_comm.
rewrite (RlPlus_comm (QRlow bf)).
apply RlPlus_le_preserving.
apply Hf.
intros k H4.
apply H3, H2, H4.
Qed.

Global Instance fble {A}: Le (mfb A) :=
                     fun f g => fle f g.

Global Instance Hfb_hprop {A} : forall f,
       IsHProp (merely (exists b, forall x:A, Rlle (f x) (QRlow b))).
Proof.
apply _.
Qed.

Lemma fble_eq_ext {A} : forall f g : mfb A, ff f = ff g -> f = g.
Proof.
intros (f,Hf) (g,Hg); simpl; intros E.
destruct E.
apply ap.
apply path_ishprop.
Qed.


From mathcomp
Require Import all_ssreflect all_algebra all_field all_fingroup.
Require irreducible.

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

Section mulBE.
Local Open Scope ring_scope.
Variable w r : nat.
Variable R : ringType.
Variable ul : 'M[R]_(r, w).
Variable dl : 'M[R]_(w, w).
Local Notation B := (castmx (erefl, addnC _ _) (block_mx ul 1%:M dl 0)).
Lemma mulBE_hidden (x : 'rV[R]_(r + w)) :
  x *m B = castmx (erefl, addnC _ _)
                  (row_mx (lsubmx x *m ul + rsubmx x *m dl) (lsubmx x)).
Proof.
apply/rowP => i; rewrite ?(castmxE, mxE).
apply/etrans; first by apply/eq_bigr => j _; rewrite castmxE block_mxEh mxE.
set T := cast_ord _ i; case: (splitP T) => j Tj.
+ rewrite ?(castmxE, mxE) big_split_ord /=.
  congr (_ + _); apply/eq_bigr => k _;
  rewrite ?(castmxE, mxE) !cast_ord_id.
  - case: (splitP (lshift w k)) => j0 wkj0.
    * congr (_ * ul _ _).
      apply/ord_inj.
      by rewrite -wkj0.
    * case: k wkj0 => k /= i0 krj0.
      suff: false by []; move: i0.
      by rewrite krj0 ltnNge leq_addr.
  - case: (splitP (rshift r k)) => j0 wkj0.
    * case: j0 wkj0 => j0 /= i0 rkj0.
      suff: false by []; move: i0.
      by rewrite -rkj0 ltnNge leq_addr.
    * congr (_ * dl _ _).
      apply/ord_inj; move/eqP: wkj0.
      by rewrite /= eqn_add2l eq_sym => /eqP.
+ rewrite ?(castmxE, mxE) [in RHS](matrix_sum_delta x) summxE big_ord1
          summxE !big_split_ord /= !cast_ord_id.
  congr (_ + _); apply/eq_bigr => k _.
  * by rewrite cast_ord_id col_mxEu !mxE !eqE /= eq_sym.
  * rewrite cast_ord_id col_mxEd !mxE !eqE /=.
    case jrk: (val j == r + k)%N => //.
    case: j jrk {Tj} => j + /= /eqP jrk.
    by rewrite jrk ltnNge leq_addr.
Qed.
End mulBE.
Section mulAE.
Local Open Scope ring_scope.
Variable w r : nat.
Variable dl : 'F_2.
Variable dr : 'rV['F_2]_r.
Local Notation A :=
  (castmx (addn1 _, etrans (addnC _ _) (addn1 _)) (block_mx 0 1%:M dl%:M dr)).

Lemma Aul (i1 : 'I_r) : A (widen_ord (leqnSn r) i1) ord0 = 0.
Proof.
  rewrite ?(castmxE, mxE).
  set T := cast_ord _ _.
  case: (splitP T) => k Tk.
  + set S := cast_ord _ _.
    by rewrite mxE; case: (splitP S) => l Sl; rewrite mxE.
  + case: k Tk => [][]//= ?.
    rewrite addn0 => i1r.
    suff: (r < r)%nat by rewrite ltnn.
    by rewrite -[X in (X < _)%nat]i1r.
Qed.

Lemma Adr (j : 'I_r) : A ord_max (lift ord0 j) = dr ord0 j.
Proof.
  rewrite ?(castmxE, mxE).
  set T := cast_ord _ _.
  case: (splitP T) => k /= Tk.
  + suff: (r < r)%nat by rewrite ltnn.
    by rewrite [X in (X < _)%nat]Tk.
  + rewrite mxE.
    set S := cast_ord _ _.
    case: (splitP S) => l /= Sl.
     by case: l Sl => [][].
    congr (dr _ _); apply/ord_inj; first by case: k Tk => [][].
    by move: Sl; rewrite /bump /= !add1n; case.
Qed.

Lemma Aur i0 j :
  A (widen_ord (leqnSn r) i0) (lift ord0 j) = if i0 == j then 1 else 0.
Proof.
  rewrite castmxE mxE.
  set T := cast_ord _ _.
  case: (splitP T) => k /= Tk; last first.
   case: k Tk => [][]//= ?; rewrite addn0 => Tk.
   suff: (r < r)%nat by rewrite ltnn.
   by rewrite -[X in (X < _)%nat]Tk.
  rewrite mxE.
  set S := cast_ord _ _.
  case: (splitP S) => l /= Sl.
   by case: l Sl => [][].
  rewrite /bump /= !add1n in Sl.
  rewrite mxE !eqE /= -Tk; case: Sl => ->.
  by case: ifP.
Qed.

Lemma mulAE_hidden (x : 'rV['F_2]_(r.+1)) :
  x *m A =
  row_mx 0 (\row_i x ord0 (widen_ord (leqnSn r) i)) + (row_mx dl%:M dr) *+ (x ord0 ord_max == 1%R).
Proof.
apply/rowP => i; rewrite ?(castmxE, mxE).
case x00: (x ord0 ord_max == 1); rewrite !mxE.
- case: (@splitP 1 r i) => j /= ij.
  * case: j ij => [][]//= ? i0.
    rewrite !mxE GRing.add0r eqE /= -GRing.mulr_natr GRing.mulr1.
    have->: i = ord0 by apply/ord_inj.
    rewrite big_ord_recr /= (eqP x00) GRing.mul1r castmxE mxE.
    set T := cast_ord _ _.
    case: (splitP T) => k Tk.
     suff: (r < r)%nat by rewrite ltnn.
     by move: Tk => /= Tk; rewrite [X in (X < _)%nat]Tk.
    set S := cast_ord _ _.
    rewrite !mxE; case: (splitP S) => l Sl; last by rewrite /= add1n in Sl.
    case: k l {Tk Sl} => [][]//?[][]//? /=.
    rewrite mxE eqE /= -GRing.mulr_natr GRing.mulr1 -[RHS]GRing.add0r.
    congr (_ + _).
    apply/etrans; first by apply/eq_bigr => k _; rewrite Aul GRing.mulr0.
    rewrite /= big_const_ord.
    by elim: r => // r' IHr; rewrite iterS IHr GRing.addr0.
  * rewrite mxE big_ord_recr /=.
    have->: i = lift ord0 j by apply/ord_inj; rewrite ij.
    rewrite Adr (eqP x00) GRing.mul1r; congr (_ + _).
    apply/etrans; first by apply/eq_bigr => k _; rewrite Aur.
    rewrite [in RHS](matrix_sum_delta x) summxE big_ord1 summxE
            /= [in RHS]big_ord_recr /= !mxE -[LHS]GRing.addr0.
    congr (_ + _).
    apply eq_bigr => i0 _;
     first by rewrite !mxE eqxx /= !eqE /= eq_sym; case: ifP.
    rewrite !eqE /=; case jr: (j == r :> nat)%nat; last by rewrite GRing.mulr0.
    move/eqP: jr => jr; suff: (r < r)%nat by rewrite ltnn.
    by rewrite -[X in (X < _)%nat]jr.
- have x00': (x ord0 ord_max == 0) by case: (x ord0 ord_max) x00 => [][|[]//].
  case: (@splitP 1 r i) => j /= ij.
  * case: j ij => [][]//= ? i0.
    have->: i = ord0 by apply/ord_inj.
    rewrite big_ord_recr /= (eqP x00') GRing.mul0r GRing.addr0.
    apply/etrans; first by apply/eq_bigr => k _; rewrite Aul GRing.mulr0.
    rewrite /= mxE big_const_ord GRing.addr0.
    by elim: r => // r' IHr; rewrite iterS IHr GRing.addr0.
  * rewrite mxE big_ord_recr /=.
    have->: i = lift ord0 j by apply/ord_inj; rewrite ij.
    rewrite Adr (eqP x00') GRing.mul0r GRing.addr0.
    apply/etrans; first by apply/eq_bigr => k _; rewrite Aur.
    rewrite [in RHS](matrix_sum_delta x) summxE big_ord1 summxE
            /= [in RHS]big_ord_recr /= !mxE GRing.addr0 -[LHS]GRing.addr0.
    congr (_ + _).
    apply eq_bigr => i0 _;
     first by rewrite !mxE eqxx /= !eqE /= eq_sym; case: ifP.
    rewrite !eqE /=; case jr: (j == r :> nat)%nat; last by rewrite GRing.mulr0.
    move/eqP: jr => jr; suff: (r < r)%nat by rewrite ltnn.
    by rewrite -[X in (X < _)%nat]jr.
Qed.
End mulAE.

Section Main.
Variables w n m r : nat.
Variable a : w.-tuple [fieldType of 'F_2].
Notation p := (n * w - r).
Hypothesis pm : prime (2 ^ p - 1).
Hypothesis mn : m.+1 < n.-2.
Hypothesis m0 : 0 < m.
Hypothesis r0 : 0 < r.
Hypothesis rw : r < w.
Hypothesis p3 : 3 <= p.

Lemma n2 : 2 < n.
Proof. by case: n mn m0 => []//[]//[]//. Qed.

Lemma n2' : 2 <= n.
Proof. by apply: ltnW n2. Qed.

Lemma mn' : m < n.
Proof.
  case: n mn => []//[]//[]// n'.
  rewrite /= ltnS => H.
  apply/(leq_trans H).
  by rewrite leqW // leqW //.
Qed.

Lemma n0 : 0 < n.
Proof. by case: n n2. Qed.

Lemma p0 : 0 < p.
Proof. by case: p p3. Qed.

Lemma w0 : 0 < w.
Proof. by case: w rw r0 => //; rewrite leqn0 => /eqP ->. Qed.

Lemma rw' : r <= w.
by apply/ltnW.
Qed.

Lemma rnpw : r <= n.-1 * w.
Proof.
  case: n mn' m0 => []//=[|*]; first by case m.
  rewrite mulSn.
  by apply/leq_trans/leq_addr/rw'.
Qed.

Lemma rnmw : r <= (n - m) * w.
Proof.
case: n mn' => // n' ?.
by rewrite subSn // mulSn; apply/leq_trans/leq_addr/ltnW.
Qed.

Lemma rnppw : r <= n.-2 * w.
Proof.
  case: n n2 => []//[]//[]// n0 _.
  rewrite mulSn.
  by apply/leq_trans/leq_addr/rw'.
Qed.

Lemma wnpwr : w <= n.-1 * w - r.
Proof.
  case: n n2 rnppw => []//[]//[]// n0 _ ?.
  by rewrite mulSn -addnBA // leq_addr.
Qed.

Lemma tecr : r = r.-1.+1.
Proof. by case: r r0. Qed.

Lemma tecwr : w - r = (w - r).-1.+1.
Proof. by rewrite prednK // /leq subnBA ?rw' // add1n subn_eq0 rw. Qed.

Lemma tecw : (w - r).-1.+1 + r.-1.+1 = w.
Proof.
by rewrite !prednK // ?subnK ?rw' // /leq subnBA ?rw' // add1n subn_eq0 rw.
Qed.

Lemma twist : r + (w - r) = w.
Proof. by rewrite subnKC // ltnW. Qed.

Lemma tecw' : w.-1.+1 = w.
Proof. by case: w w0. Qed.

Lemma tecw'' : 1 + w.-1 = w.
Proof. by case: w w0. Qed.

Lemma rnwp : r <= n * w.-1.
Proof.
  case: n mn' m0 => []//=[|*]; first by case m.
  move: rw => rw''.
  rewrite -tecw' ltnS in rw''.
  rewrite mulSn.
  by apply/leq_trans/leq_addr/rw''.
Qed.

Lemma tecnw : w + (n.-1 * w - r) = p.
Proof. by rewrite addnBA ?rnpw // -mulSn prednK ?n0. Qed.

Lemma choose_m : m.-1 * w + w + ((n - m) * w - r) = p.
Proof.
by rewrite addnC addnA addnC addnCA -mulSn addnC addnBA
           ?rnmw // -mulnDl prednK // addnC subnK // ltnW ?mn'.
Qed.

Lemma choose_last : (n.-1 * w - r) + w = p.
Proof. by rewrite addnC tecnw. Qed.

Lemma tecpr : p + r = n * w.
Proof.
  rewrite subnK //.
  case: n mn' => // ??.
  rewrite mulSn.
  by apply/leq_trans/leq_addr/ltnW.
Qed.

Lemma tecp : p = p.-1.+1.
Proof. by case: p p3. Qed.

Lemma tecn : n = n.-2.+2.
Proof. by case: n n2' => []//[]. Qed.

Lemma wrpwr : (w - r).-1 < w - r.
Proof.
  by rewrite /leq prednK ?subnn // ltnNge /leq subn0 subn_eq0 -ltnNge.
Qed.

Lemma wrw : (w - r) < w.
Proof.
  rewrite /leq -subSn; last by apply/ltnW.
  by rewrite subnAC subSn // subnn subn_eq0.
Qed.

Lemma wrp : (w - r) < p.
Proof.
  apply/(leq_trans wrw).
  by rewrite -choose_last leq_addl.
Qed.

Lemma wr0 : 0 < w - r.
Proof. by case: (w - r) wrpwr. Qed.

Lemma pwn : p %/ w < n.
Proof.
  rewrite divnMBl ?w0 //.
  case wr: (w %| r).
   case/dvdnP: wr => [][|p rpw].
    rewrite mul0n => rn0.
    by move: rn0 r0 => ->.
   move: rpw rw => ->.
   rewrite mulSn => /(leq_ltn_trans (leq_addr _ _)).
   by rewrite ltnn.
  rewrite subn1 divn_small // subn0.
  by case: n n0.
Qed.

Hint Resolve p0 n2' n0 w0 rw' rnwp rnpw rnmw wnpwr mn' wr0 : core.
Local Open Scope ring_scope.

Definition A :=
  castmx (tecw', tecw')
  (castmx (addn1 _, etrans (addnC _ w.-1) (addn1 _))
  (block_mx 0 1%:M (nth 0 a 0)%:M (\row_i nth 0 a i.+1))).

Definition S :=
  castmx (etrans (addnC _ _) tecw, tecw)
  (block_mx 0                             (castmx (tecr, tecr) 1%:M)
            (castmx (tecwr, tecwr) 1%:M)                          0) *m A.

Definition UL : 'M['F_2]_(n.-1 * w - r, w) :=
\matrix_(i, j) (1 *+ ((j == i - (m.-1 * w) :> nat) && (i >= (m.-1 * w)))%nat).

Definition B :=
  castmx (etrans (addnC _ _) tecnw, tecnw)
 (block_mx  UL 1%:M
            S  0).

Definition phi := char_poly (castmx (tecp, tecp) B).
Lemma size_phi : (size phi).-1 = p.
Proof. by rewrite size_char_poly prednK. Qed.

Lemma X2X : 'X ^ 2 %% phi != 'X %% phi.
Proof.
  rewrite -GRing.subr_eq0 -modp_opp -modp_add.
  apply/negP => /dvdp_leq H.
  have/H: 'X ^ 2 - 'X != 0 :> {poly 'F_2}.
   rewrite GRing.subr_eq0.
   apply/negP => /eqP/(f_equal (size : {poly 'F_2} -> nat)).
   by rewrite size_polyXn size_polyX.
  case: (size phi) size_phi => //= p0' => [|->].
   by move: p0' pm => <-; rewrite expn0 subn1.
  rewrite size_addl ?size_polyXn ?size_opp ?size_polyX //.
  by apply/negP; rewrite -leqNgt.
Qed.

Lemma pm' : prime (2 ^ (size phi).-1 - 1).
Proof. by rewrite size_phi. Qed.

Hint Resolve pm' : core.

Lemma irreducibleP : reflect (irreducible_poly phi)
                             ('X ^ (2 ^ (size phi).-1)%N %% phi == 'X %% phi).
Proof.
apply/(iffP idP).
* move=> H1; apply/irreducible.irreducibleP => //.
  by rewrite X2X /=.
* by case/irreducible.irreducibleP/andP.
Qed.

Lemma phi_mxminpoly :
  irreducible_poly phi ->
  phi = mxminpoly (castmx (tecp, tecp) B).
Proof.
 case => ? H0.
 move/H0: (mxminpoly_dvd_char (castmx (tecp, tecp) B)).
 rewrite size_mxminpoly eqSS -lt0n mxminpoly_nonconstant => /implyP /= ?.
 apply/esym/eqP.
 by rewrite -eqp_monic ?char_poly_monic ?mxminpoly_monic.
Qed.

Local Open Scope quotient_scope.

Lemma cycleB_dvdP :
  irreducible_poly phi ->
  forall q, (castmx (tecp, tecp) B ^+ (2 ^ q) == castmx (tecp, tecp) B)
        = (2 ^ (size phi).-1 - 1 %| 2 ^ q - 1)%nat.
Proof.
  move=> H q.
  apply/eqP; case: ifP => H0.
  * rewrite -(horner_mx_X (castmx _ _)) -GRing.rmorphX
            (divp_eq 'X^(2 ^ q) phi) GRing.rmorphD
            GRing.rmorphM /= Cayley_Hamilton GRing.mulr0 GRing.add0r.
    move/(irreducible.cycleF_dvdP pm' H q)/(_ (\pi 'X)) : H0.
    rewrite irreducible.expXpE -GRing.rmorphX => /eqP.
    rewrite exprnP -irreducible.XnE => /eqP ->.
    by rewrite modp_small // size_polyX size_char_poly prednK ltnW // ltnW.
  * move=> H1.
    suff: (2 ^ (size phi).-1 - 1 %| 2 ^ q - 1)%N by rewrite H0.
    rewrite -(horner_mx_X (castmx _ _)) -GRing.rmorphX /= in H1.
    move/(f_equal (mx_inv_horner (castmx (tecp, tecp) B))): H1.
    rewrite !horner_mxK -!phi_mxminpoly // => H1.
    by apply/(irreducible.cycleF_dvdP pm' H q)/irreducible.expandF/eqP.
Qed.

Lemma size_ord_enum q : size (ord_enum q) = q.
Proof. by rewrite -(size_map val) val_ord_enum size_iota. Qed.

Lemma nth_ord_enum i (q : nat) k : (i < q)%nat -> val (nth k (ord_enum q) i) = i.
Proof.
move=> iq.
by rewrite -(nth_map k (val k) val) ?val_ord_enum ?nth_iota // size_ord_enum.
Qed.

Lemma eq_big_cond (T : ringType) p q (pq : p = q) (F1 : 'I_p -> T)
  (F2 : 'I_q -> T) (F12 : forall i, F1 (cast_ord (esym pq) i) = F2 i) :
  \sum_(j < p) F1 j = \sum_(i < q) F2 i.
Proof.
case p0: (p > 0)%nat; last first.
 case: p p0 pq F1 F2 F12 => //= _.
 case: q => // *.
 by rewrite !big_ord0.
have dq: 'I_q.
 rewrite -pq.
 case: p p0 {F1 F12 pq} => // *.
 by apply ord0.
apply/etrans; last first.
 apply congr_big => [|//|i _]; last by rewrite -F12.
 apply: (_ : map (cast_ord pq) (index_enum (ordinal_finType p)) = _).
  apply/eq_from_nth.
  by rewrite size_map /index_enum !unlock /= -!(size_map val) !val_ord_enum !size_iota.
 rewrite size_map /index_enum !unlock /= size_ord_enum => i Hi.
 apply: (_ : nth dq [seq cast_ord pq i | i <- ord_enum p] i = nth dq (ord_enum q) i).
 apply/val_inj.
 rewrite (nth_map (cast_ord (esym pq) dq)); last by rewrite size_ord_enum.
 rewrite /= !nth_ord_enum //; last by rewrite -pq.
rewrite big_map; apply eq_bigr => i _.
by rewrite -F12; congr (F1 _); apply/val_inj.
Qed.

Lemma mulBE_hidden' (x : 'rV['F_2]_p) :
let x' := castmx (erefl, etrans (esym tecnw) (addnC _ _)) x in
x *m B = castmx (erefl, tecnw)
        (row_mx (lsubmx x' *m UL + rsubmx x' *m S) (lsubmx x')).
Proof.
move=> x'.
apply: (can_inj (castmxK (esym erefl) (esym tecnw))).
apply: (can_inj (castmxK erefl (addnC w (n.-1 * w - r)%N))).
rewrite !castmxK -mulBE_hidden castmx_comp /=; subst x'.
apply: (can_inj (castmxK (esym erefl) (esym (etrans (esym tecnw) (addnC w _))))).
rewrite castmxK; apply/rowP => k.
rewrite ?(mxE, castmxE).
apply/etrans; last first.
 apply eq_bigr => j _.
 by rewrite !castmxE !cast_ord_id !esymK.
apply: eq_big_cond => [|? i].
 by rewrite addnC tecnw.
congr (_ * _); first by congr (x 0 _); apply/val_inj.
rewrite castmxE //=.
by congr (block_mx _ _ _ _ _ _); apply/val_inj.
Qed.

Lemma mulSE (x : 'rV['F_2]_(n.-1 * w - r + w)) :
  let x' := castmx (erefl, esym tecw')
            (rsubmx x *m castmx (etrans (addnC _ _) tecw, tecw)
                         (block_mx 0 (castmx (tecr, tecr) 1%:M)
                                   (castmx (tecwr, tecwr) 1%:M) 0)) in
  rsubmx x *m S = castmx (erefl, tecw')
  (row_mx 0 (\row_i x' ord0 (widen_ord (leqnSn w.-1) i))
             + row_mx a`_0%:M (\row_i a`_i.+1) *+ (x' ord0 ord_max == 1)).
Proof.
  move=> x'; rewrite mulmxA -mulAE_hidden.
  apply/rowP => k; rewrite ?(mxE, castmxE).
  apply: eq_big_cond => [|? i]; first by rewrite prednK.
  rewrite ?(mxE, castmxE).
  congr (_ * _).
  apply/eq_bigr => j _.
  congr (rsubmx x _ _ * _); first by apply/val_inj.
  by rewrite !castmxE; congr (block_mx _ _ _ _ _ _); apply/val_inj.
  set I := cast_ord _ _; set I' := cast_ord (esym _) i.
  by have->: I = I' by apply/val_inj.
Qed.

Definition z (x : 'rV['F_2]_p) :=
  rsubmx (castmx (erefl _, etrans (esym tecnw) (addnC _ _)) x) *m
  castmx (etrans (addnC _ _) tecw, tecw)
 (block_mx 0 (castmx (tecr, tecr) 1%:M) (castmx (tecwr, tecwr) 1%:M) 0).

Definition y (x : 'rV['F_2]_p) :=
lsubmx (castmx (erefl _, etrans (esym tecnw) (addnC _ _)) x).

Lemma sum_f2_eq0 q (P : pred 'I_q) :
\big[GRing.add_comoid [ringType of 'F_2]/0]_(i0 | P i0) 0 = 0.
Proof.
rewrite big_const; set T := #|_|.
elim: T => // t IHt.
by rewrite iterS IHt /= GRing.addr0.
Qed.

Lemma ULE (x : 'rV['F_2]_p) :
  y x *m UL = rsubmx (lsubmx (castmx (erefl, esym choose_m) x)).
Proof.
apply/rowP => i.
rewrite ?(mxE, castmxE).
apply/etrans; first by apply/eq_bigr => j _; rewrite ?(mxE, castmxE).
have inwr: (i + m.-1 * w < n.-1 * w - r)%nat.
 apply: leq_trans.
  apply: (_ : (_ < w + m.-1 * w)%nat); first by rewrite ltn_add2r.
 have->: n.-1 = n.-2.+1 by case: n n2 => []//[].
 rewrite -mulSn [X in (_ <= X - _)%nat]mulSn addnC
         -[X in (X <= _)%nat]addn0 -addnBA //.
 apply leq_add.
  rewrite leq_mul2r; apply/orP; right; apply: (leq_trans _ mn).
  by case: m => []//= ?; apply ltnW.
 by rewrite /leq sub0n.
rewrite (bigD1 (Ordinal inwr)) // -[RHS]GRing.addr0.
congr (_ + _).
 rewrite /= addnK leq_addl !eqxx GRing.mulr1; congr (x _ _).
 by apply/ord_inj; rewrite /= addnC.
apply/etrans; first apply/eq_bigr => j /= P.
case mpwj : (m.-1 * w <= j)%nat.
 have->: (i == (j - m.-1 * w)%N :> nat) = false.
  apply/negP/negP; move: P; apply contra.
  rewrite !eqE /= => /eqP ->.
  by rewrite subnK //.
 by rewrite GRing.mulr0.
 by rewrite andbF GRing.mulr0.
by apply sum_f2_eq0.
Qed.

Definition twist_word (x y : 'rV['F_2]_w) :=
  castmx (erefl, etrans (addnC _ _) twist)
 (row_mx (rsubmx (castmx (erefl, esym twist) x))
         (lsubmx (castmx (erefl, esym twist) y))).

Definition z' (x : 'rV['F_2]_p) :=
  let l := rsubmx (castmx (erefl, esym choose_last) x) in
  twist_word l l.

Lemma zE (x : 'rV['F_2]_p) : z x = z' x.
Proof.
  rewrite /z'.
  set l := rsubmx (castmx (erefl, esym choose_last) x).
  apply/rowP => j.
  rewrite !(mxE, castmxE).
  apply/etrans; first by apply/eq_bigr => k _; rewrite !castmxE block_mxEh !mxE.
  set T := cast_ord _ _; set S := cast_ord _ _.
  case: (splitP T) => i Ti.
  - case: (splitP S) => k Sk; last first.
     suff: (w - r < w - r)%nat by rewrite ltnn.
     suff: (w - r + k < w - r)%nat; apply/leq_trans.
     + by rewrite ltnS leq_addr.
       rewrite /= in Ti, Sk; rewrite -Sk Ti.
     + case: i {Ti} => i /=; apply.
     + apply: wrpwr.
    apply/etrans; first by apply/eq_bigr => t _; rewrite !(castmxE, mxE).
    rewrite !(mxE, castmxE) !cast_ord_id !esymK.
    have rkw: (r + k < w)%nat.
     case: k {Sk} => k /= H.
     apply/leq_trans.
      apply: (_ : _  <  r + (w - r))%nat; by rewrite ltn_add2l.
     by rewrite addnBA // addnC addnK.
    rewrite (bigD1 (Ordinal rkw)) // -[RHS]GRing.addr0; congr (_ + _).
     set Q' := cast_ord (esym (etrans _ _)) _; set Q := cast_ord (esym (etrans _ _)) _.
     case: (splitP Q) => t Qt.
      suff: (r < r)%nat by rewrite ltnn.
      suff: (r + k < r)%nat by apply/leq_trans; rewrite ltnS leq_addr.
      rewrite /= in Qt; rewrite Qt.
      case: t {Qt} => t /=.
      by rewrite prednK //.
     rewrite castmxE mxE eqE /=.
     move/eqP: Qt; rewrite /= prednK // eqn_add2l => /eqP <-.
     rewrite -Sk -Ti eqxx GRing.mulr1.
     by congr (x _ _); apply/val_inj.
    apply/etrans; first apply/eq_bigr => q /= P.
     set Q' := cast_ord (esym (etrans _ _)) _; set Q := cast_ord (esym (etrans _ _)) _.
     case: (splitP Q) => t Qt.
      by rewrite mxE GRing.mulr0.
     rewrite /= in Qt, Sk.
     rewrite castmxE mxE eqE /= -Ti /= Sk.
     case tk: (t == k :> nat)%nat.
      case: q P Q' {Q} Qt => /= q qw.
      rewrite eqE /= (eqP tk) prednK // => qrk ? /eqP.
      by rewrite (negPf qrk).
     by rewrite GRing.mulr0.
    by apply sum_f2_eq0.
  - case: (splitP S) => k Sk.
     suff: (w - r < w - r)%nat by rewrite ltnn.
     suff: (w - r + i < w - r)%nat; apply/leq_trans.
     + by rewrite ltnS leq_addr.
     + rewrite /= prednK // in Ti; rewrite /= in Sk.
       rewrite -Ti Sk; case: k {Sk} => k; apply.
     + by rewrite leqnn.
    apply/etrans; first by apply/eq_bigr => t _; rewrite !(castmxE, mxE).
    rewrite !(mxE, castmxE) !cast_ord_id !esymK.
    have kw: (k < w)%nat.
     case: k {Sk} => k /= H; by apply/(leq_trans H).
    rewrite (bigD1 (Ordinal kw)) // -[RHS]GRing.addr0; congr (_ + _).
     set Q' := cast_ord (esym (etrans _ _)) _; set Q := cast_ord (esym (etrans _ _)) _.
     case: (splitP Q) => t Qt.
      rewrite castmxE mxE eqE /=.
      rewrite /= in Ti, Sk.
      rewrite Sk prednK // in Ti.
      move/eqP: Ti; rewrite eqn_add2l -Qt /= => ->.
      rewrite GRing.mulr1.
      by congr (x _ _); apply/val_inj.
     rewrite /= in Qt.
     suff: (r < r)%nat by rewrite ltnn.
     suff: (r + t < r)%nat by apply/leq_trans; rewrite ltnS leq_addr.
     rewrite prednK // in Qt.
     by rewrite -Qt.
    apply/etrans; first apply/eq_bigr => q /= P.
     set Q' := cast_ord (esym (etrans _ _)) _; set Q := cast_ord (esym (etrans _ _)) _.
     apply: (_ : _ = 0).
     case: (splitP Q) => t Qt.
      rewrite /= ?prednK // in Ti, Qt, Sk.
      rewrite castmxE mxE eqE /= -Qt.
      rewrite Ti in Sk; move/eqP: Sk; rewrite eqn_add2l => /eqP ->.
      case: q P Q' {Q Qt} => //= q ?.
      rewrite eqE /= => /negPf -> ?.
      by rewrite GRing.mulr0.
     by rewrite mxE GRing.mulr0.
    by apply sum_f2_eq0.
Qed.

Definition ra : 'rV_(1 + w.-1) := (row_mx a`_0%:M (\row_i a`_i.+1)).

Definition shiftr (x : 'rV['F_2]_w) : 'rV_(1 + w.-1) :=
row_mx 0 (\row_i castmx (erefl _, esym tecw') x ord0 (widen_ord (leqnSn w.-1) i)).

Definition computeB (x : 'rV['F_2]_p) :=
castmx (erefl _, tecnw)
(row_mx (rsubmx (lsubmx (castmx (erefl, esym choose_m) x)) + castmx (erefl _, tecw')
(shiftr (z' x) + ra *+ (castmx (erefl _, esym tecw') (z' x) ord0 ord_max == 1)))
        (y x)).

Lemma mulBE (x : 'rV['F_2]_p) : x *m B = computeB x.
Proof. by rewrite mulBE_hidden' mulSE ULE -/(z x) !zE. Qed.

Lemma mulBE0 (x : 'rV['F_2]_p) (k : 'I_(n.-1 * w - r)) :
  (x *m B) ord0 (cast_ord tecnw (rshift w k)) = y x ord0 k.
Proof.
  rewrite mulBE_hidden' mulSE ?(castmxE, mxE) /=.
  set T := cast_ord _ _.
  case: (splitP T) => j jT.
   suff: (j >= w)%nat.
    case: j {jT} => j H.
    by rewrite leqNgt /= H.
   by rewrite -jT /= leq_addr.
  rewrite ?(castmxE, mxE).
  congr (x _ _); apply/val_inj => //=.
  by move/eqP: jT; rewrite /= eqn_add2l eq_sym => /eqP.
Qed.

Definition row_ind (o : 'I_p) := Ordinal (ltn_pmod o w0).
Definition col_ind_prf (o : 'I_p) : (o %/ w < n)%nat.
Proof.
  case: o => o oH.
  by apply/leq_ltn_trans/pwn/(leq_div2r _ (ltnW oH)).
Qed.
Definition col_ind (o : 'I_p) :=
  Ordinal (col_ind_prf o).

Definition arr_ind_prf (x : 'I_n) (y : 'I_w) : (x * w + y < n * w)%nat.
Proof.
 case: x => x xn; case: y => y yw.
 apply/leq_ltn_trans; first apply leq_add.
  apply: (_ : _ <= n.-1 * w)%nat.
   apply leq_mul => //.
   by case: n xn n0.
  apply: (_ : _ <= w.-1)%nat.
  by case: w w0 yw.
 case: n n0 => // n' _; case: w w0 => // w' _ /=.
 by rewrite !mulSn !mulnS addnCA -!addnA ltn_add2l addnC ltn_add2r.
Qed.
Definition arr_ind_large (x : 'I_n) (y : 'I_w) := Ordinal (arr_ind_prf x y).
Definition arr_ind (x : 'I_n) (y : 'I_w) :=
match split (cast_ord (esym tecpr) (arr_ind_large x y)) with
| inl l => l
| inr r => cast_ord (esym tecp) ord0
end.

Definition incomplete_array (x : 'M['F_2]_(n, w)) :=
  \row_i x (col_ind i) (row_ind i).

Definition array_incomplete (y : 'rV['F_2]_p) : 'M_(n, w) :=
  \matrix_(i, j) y ord0 (arr_ind i j).

Lemma array_incompleteK : cancel array_incomplete incomplete_array.
Proof.
move=> y; rewrite /incomplete_array /array_incomplete; apply/rowP => j.
rewrite !mxE; congr (y _ _); apply/ord_inj.
rewrite /arr_ind; set T := cast_ord _ _.
case: (splitP T) => s Ts; rewrite /= -divn_eq in Ts.
 by rewrite Ts.
suff: (p < p)%nat by rewrite ltnn.
suff: (p + s < p)%nat; first by apply/leq_trans; rewrite ltnS leq_addr.
by rewrite -Ts.
Qed.
End Main.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    * lfind. Admitted.


(**
An introduction to small scale reflection in Coq

6. Finite objects in SSReflect

http://hal.inria.fr/docs/00/55/53/79/PDF/main-rr.pdf
*)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Require Import path choice fintype tuple finfun finset.

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

(**
6.3 Finite functions, finite sets

CIC (Calculus of Inductive Constructions) では、以下は成立しない。
forall f1 f2 : aT -> rT, (forall x : aT, f1 x = f2 x) -> f1 = f2
しかし、aTが有限型ならば、成立する。
*)

Check ffunP.
(**
forall (aT : finType) (rT : Type) (f1 f2 : {ffun aT -> rT}),
  f1 =1 f2 <-> f1 = f2.

ただし、(f1 =1 f2) == (forall x, f1 x = f2 x)
*)
Lemma tuto_ffunP : forall (f1 f2 : {ffun 'I_6 -> nat}),
       (forall x, f1 x = f2 x) <-> f1 = f2.
Proof.
  move=> f1 f2.
  by apply ffunP.
Qed.

(** 同様に *)

Check setP.
(**
forall (T : finType) (A B : {set T}), A =i B <-> A = B
*)
Lemma tuto_setP : forall (A B : {set 'I_6}),
       A =i B <-> A = B.
Proof.
  move=> A B.
  by apply setP.
Qed.

(** 有限集合の例 *)

(*
Definition S : {set 'I_6}.
Proof.
  rewrite /set_of.
  apply FinSet.
  rewrite /pred.
  apply finfun.
  apply (testn ).
Defined.
*)

Definition q0 : 'I_6. Proof. have : 0 < 6 by []. apply Ordinal. Defined.
Definition q1 : 'I_6. Proof. have : 1 < 6 by []. apply Ordinal. Defined.
Definition q2 : 'I_6. Proof. have : 2 < 6 by []. apply Ordinal. Defined.
Definition q3 : 'I_6. Proof. have : 3 < 6 by []. apply Ordinal. Defined.
Definition q4 : 'I_6. Proof. have : 4 < 6 by []. apply Ordinal. Defined.
Definition q5 : 'I_6. Proof. have : 5 < 6 by []. apply Ordinal. Defined.

Check [set q0] : {set 'I_6}.
Check [set x in 'I_6] : {set 'I_6}.
Check [set x | x \in 'I_6] : {set 'I_6}.    (* [set x in 'I_6] の構文糖 *)
Check [set x | x in 'I_6] : {set 'I_6}.
Check [set: 'I_6] : {set 'I_6}.

(** よく使うコンストラクション *)
Goal q0 \in [set q0].
Proof.
  by apply/set1P.
Qed.

Goal mem [set q0] q0.
Proof.
  by apply/set1P.
Qed.

Goal q0 \in q0 |: set0.
Proof.
  Search (_ |: _).
  by apply setU11.
Qed.

Goal q0 \in [set q0; q1].
Proof.
  Search ([set _]).
  apply/set2P.
  by left.
Qed.

Goal q0 |: set0 = [set q0].
Proof.
  by rewrite setU0.
Qed.

Goal [set q0] \subset [set q0; q1].
Proof.
  rewrite -{1}(setU0 [set q0]).
  (* 構文糖のせいで解りにくいが： *)
  (* [set q0] :|: set0 = [set q0] :|: [set q1] *)
  Search (_ \subset _).
  apply setUS.
  by apply sub0set.
Qed.

Goal [set q0] \proper [set q0; q1].
Proof.
  Search (_ \proper _).
  apply properUl.
  apply negbT.
  admit.
Qed.

Goal q0 \in [set q0] :|: [set q1].
Proof.
  (* q0 \in [set q0; q1] *)
  apply/set2P.
  by left.
Qed.

Goal q0 \in [set q0; q1] :&: [set q0; q2].
Proof.
  admit.
Qed.

Goal q0 \in [set q0] :&: [set: 'I_6].
Proof.
  Search (_ :&: _).
  rewrite setIT.
  by apply/set1P.
Qed.

Goal q0 \in ~: [set q1].
Proof.
  Search ([set~ _]).
  rewrite in_setC1.
  by [].
(* q0とq1 の定義がQedで終わっていたり、
型だけの定義のとき、q0 != q1 は証明できない。 *)
Qed.

Goal q0 \in [set~ q1].
Proof.
  rewrite in_setC1.
  by [].
Qed.

Goal q0 \in [set q0; q1] :\: [set q1].
Proof.
  apply/setD1P.
  split.
  - by [].
  - apply/set2P.
    by left.
Qed.

Goal q0 \in [set q0; q1] :\ q1.
Proof.
  apply/setD1P.
  split.
  - by [].
  - apply/set2P.
    by left.
Qed.

(**
Exercise 6.3.1
 *)
Section setOpsExos.
  Variable T : finType.
  Implicit Types a x : T.
  Implicit Types A B C D : {set T}.

  Lemma tuto_eqEsubset : forall A B,
                           (A == B) = (A \subset B) && (B \subset A).
  Proof.
    move=> A B.
    apply/eqP/subset_eqP.
    - by move=> <-.
    - by move/setP.
  Qed.

  Check in_set.                           (* これは覚えておくべき。 *)
  Lemma tuto_in_set : forall (T : finType) (pA : pred T) (x : T),
                        (x \in [set x | pA x]) = pA x.
  Proof.
    move=> T' pA x.
    by rewrite inE.
  Qed.

  Lemma tuto_set1P : forall x a, reflect (x = a) (x \in [set a]).
  Proof.
    move=> x a.
    rewrite /set1.                          (* x \in [set x0 | x0 == a] *)
    rewrite tuto_in_set.                    (* x == a *)
    by apply/eqP.
  Qed.

  Check T.                                  (* finType *)
  Lemma tuto_in_setD1 : forall (x : T) (A : {set T}) (b : T),
                          (x \in A :\ b) = (x != b) && (x \in A).
  Proof.
    move=> x A b.
    Check inE.
    rewrite 2!inE.
    by [].
  Qed.

  Lemma tuto_setD1P : forall x A b,
                        reflect (x != b /\ x \in A) (x \in A :\ b).
  Proof.
    move=> x A b.
    Search (_ :\ _).
    rewrite tuto_in_setD1.
    by apply andP.
  Qed.

  Lemma tuto_setIA : forall A B C, A :&: (B :&: C) = A :&: B :&: C.
  Proof.
    move=> A B C.
    apply/setP=> x.
    rewrite !inE.
    (* x \in A, x \in B, x \in C の三者の&&の結合則にもちこむ。 *)
    rewrite andbA.
    by [].
  Qed.

  Lemma tuto_setUIl : forall A B C,
                        (A :&: B) :|: C = (A :|: C) :&: (B :|: C).
  Proof.
    move=> A B C.
    apply/setP => x.
    rewrite !inE.
    Search (_ && _ || _ = (_ || _) && (_ || _)).
    rewrite Bool.orb_andb_distrib_l.
    by [].
  Qed.

  Lemma tuto_setCU : forall A B, ~: (A :|: B) = ~: A :&: ~: B.
  Proof.
    move=> A B.
    apply/setP => x.
    rewrite !inE.
    rewrite negb_or.
    by [].
  Qed.
End setOpsExos.

(** Exercise 6.3.2 *)

Section MinSet.
  Variable T : finType.
  Notation sT := {set T}.
  Implicit Types A B C : sT.
  Implicit Type P : pred sT.

  Definition tuto_minset' P A : Prop :=
    forall B : sT, B \subset A -> (B == A) == P B.
  Definition tuto_minset P A : bool :=
    [forall (B : sT | B \subset A), (B == A) == P B].
  Print minset.
  Print tuto_minset.
  Print tuto_minset'.

  Lemma tuto_minset_eq : forall P1 P2 A,
                         P1 =1 P2 -> minset P1 A = minset P2 A.
  Proof.
    admit.
  Qed.

  Lemma tuto_minsetP :
    forall P A,
      reflect ((P A) /\ (forall B, P B -> B \subset A -> B = A)) (minset P A).
  Proof.
    admit.
  Qed.

  Lemma tuto_minsetp : forall P A, minset P A -> P A.
  Proof.
    admit.
  Qed.

  Lemma tuto_minsetinf : forall P A B,
                           minset P A -> P B -> B \subset A -> B = A.
  Proof.
    admit.
  Qed.

  Lemma tuto_ex_minset : forall P, (exists A, P A) -> {A | minset P A}.
  Proof.
    move=> P exP; pose pS n := [pred B | P B && (#|B| == n)].
    pose p n := ~~ pred0b (pS n); have{exP}: exists n, p n.
      by case: exP => A PA; exists #|A|; apply/existsP; exists A;
                      rewrite PA /=.
    case/ex_minnP=> n; move/pred0P; case: (pickP (pS n)) => // A.
      admit.
  Qed.

  Lemma tuto_minset_exists : forall P C,
                               P C -> {A | minset P A & A \subset C}.
  Proof.
    admit.
  Qed.
End MinSet.

(* END *)