(* in order to prove something we define some Theorem or Lemma *)
Theorem f (A : Set) (p : A -> Prop) (q: Prop) :
  (exists x : A, q /\ p x) <-> (q /\ exists x : A, p x).

(* if something can be proven with firstorder logic then just use firstorder *)
Proof.
  firstorder.
Qed.

Print f.
(* OUTPUT:
  f =
  fun (A : Set) (p : A -> Prop) (q : Prop) =>
  conj
    (fun H : exists x : A, q /\ p x =>
    ex_ind
      (fun (x : A) (H0 : q /\ p x) =>
        and_ind
          (fun (H1 : q) (H2 : p x) =>
          conj H1 (ex_intro (fun x0 : A => p x0) x H2)) H0) H)
    (fun H : q /\ (exists x : A, p x) =>
    and_ind
      (fun (H0 : q) (H1 : exists x : A, p x) =>
        ex_ind
          (fun (x : A) (H2 : p x) =>
          ex_intro (fun x0 : A => q /\ p x0) x (conj H0 H2)) H1) H)
      : forall (A : Set) (p : A -> Prop) (q : Prop),
        (exists x : A, q /\ p x) <-> q /\ (exists x : A, p x)
*)

(* MANUAL PROOF
Proof.
  (* prove in both directions *)
  (* split into two subgoals *)
  split.
  (*
    A : Set
    p : A -> Prop
    q : Prop
    ============================
    (exists x : A, q /\ p x) -> q /\ (exists x : A, p x)

    subgoal 2 (ID 9) is:
    q /\ (exists x : A, p x) -> exists x : A, q /\ p x
  *)
  intros [x [H1 H2]].
  split.
  assumption.
  exists x.
  assumption.
  (*
    A : Set
    p : A -> Prop
    q : Prop
    ============================
    q /\ (exists x : A, p x) -> exists x : A, q /\ p x
  *)
  intros [H1 [y H2]].
  exists y.
  (*
    A : Set
    p : A -> Prop
    q : Prop
    H1 : q
    y : A
    H2 : p y
    ============================
    q /\ p y
  *)
  auto.
Qed.

Check f.
Print f.
*)


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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> 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 append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. lfind.  reflexivity.
Admitted.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (qreva x (rev y))) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite rev_rev. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite (eq_refl : Cons n (rev y) = append (rev (Cons n Nil)) (rev y)). rewrite <- rev_append. rewrite IHx. rewrite append_assoc. simpl. reflexivity.
Qed.


(* Copyright 2021 Pierre Courtieu
  This file is part of LibHyps. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it. *)
(* We add commands, and Assign is an expr. *)

Require Import FSets.FMapList FSets.FMapFacts Arith ZArith
        LibHyps.LibHyps List.
Require Import Structures.OrderedTypeEx FSets.FSetList.

Module Env := FMapList.Make(Nat_as_OT).
Module EnvFact := FMapFacts.Facts(Env).

Inductive binop := Plus | Minus | Mult.

Inductive exp : Type :=
| Val : Z -> exp
| Var : nat -> exp
| BinOp: binop -> exp -> exp -> exp
| Assign: nat -> exp -> exp.

Inductive Com : Type :=
| Skip: Com
| Seq: Com -> Com -> Com.

Record Ret := { val: Z; env: Env.t Z }.

Definition EqRet ret1 ret2 :=
  ret1.(val) = ret2.(val)
  /\ Env.Equal ret1.(env) ret2.(env).

Definition eval_op op :=
  match op with
     Plus => Z.add| Minus => Z.sub| Mult => Z.mul
  end.

Inductive Eval_exp Γ: exp -> Ret -> Prop :=
  EE_val: forall v, Eval_exp Γ (Val v) {| val := v; env := Γ |}
| EE_var: forall x v, Env.MapsTo x v Γ -> Eval_exp Γ (Var x) {| val := v; env := Γ |}
| EE_binop: forall e1 e2 v1 v2 op f,
    Eval_exp Γ e1 v1 -> Eval_exp Γ e2 v2 -> eval_op op = f
    -> Eval_exp Γ (BinOp op e1 e2) {| val :=(f v1.(val) v2.(val)); env := Γ |}
| EX_Assign: forall (x:nat) (e:exp) v,
    Eval_exp Γ e v ->
    Eval_exp Γ (Assign x e) {| val := v.(val);
                               env := (Env.add x v.(val) v.(env)) |}
.

Inductive Exec Γ: Com -> Env.t Z -> Prop :=
| EX_Skip: Exec Γ Skip Γ
| EX_Seq: forall Γ1 Γ2 (c1 c2:Com),
    Exec Γ c1 Γ1 -> Exec Γ1 c2 Γ2 -> Exec Γ (Seq c1 c2) Γ2.

(* optional customization *)
Ltac rename_depth ::= constr:(3).
Local Open Scope autonaming_scope.
Import ListNotations.
Ltac rename_hyp_eval n th :=
  match th with
    Eval_exp _ ?e ?v => name(`_EE` ++ e#n ++ v#n)
  | Val ?v => name(v#(S n))
  | Var ?x => name(x#(S n))
  | BinOp ?o ?e1 ?e2 => name(o#(S 0) ++ e1#n ++ e2#n)
  | eval_op ?o ?v1 ?v2 => name(o#(S 0) ++ v1#n ++ v2#n)
  | Exec ?G ?c ?G' => name(`_EX` ++ G#n ++ c#n ++ G'#n)
  | Env.Equal ?X ?Y => name(`_EQ` ++ X#n ++ Y#n) (* shorten Equal *)
  | EqRet ?X ?Y => name(`_EQ` ++ X#n ++ Y#n) (* shorten Equal *)
  end.
Close Scope autonaming_scope.
Ltac rename_hyp ::= rename_hyp_eval.

(* We actually need to prove modulo equivalence of environments *)
(* Here I give up giving names for all these inversions. *)
Lemma determ_nolibhyp: forall Γ Γ' e v v',
    Eval_exp Γ e v ->
    Eval_exp Γ' e v' ->
    Env.Equal Γ Γ' ->
    EqRet v v'.
Proof.
  intros * h_EE_e_v.
  revert v'.
  induction h_EE_e_v as
      [v | x v h_MapsTo | e1 e2 v1 v2 op f h_e_v1 IH_v1 h_e_v2 IH_v2 hop
       |  x e v h_EE_e_v_ h_all_EQ_v_v'_]
  ; intros v' h_EE_e_v' heq_Γ.
  - inversion h_EE_e_v'.
    red;auto.
  - inversion h_EE_e_v'; auto; subst.
    rewrite heq_Γ in h_MapsTo.
    red.
    assert (v=v0);subst.
    { eapply EnvFact.MapsTo_fun;eauto. }
    auto.
  - inversion h_EE_e_v' as [| |e0 e3 v0 v3 op0 f0 h_EE_e1_v0_ h_EE_e2_v3_ | ];subst.
    specialize IH_v1 with (1:=h_EE_e1_v0_) (2:=heq_Γ).
    specialize IH_v2 with (1:=h_EE_e2_v3_) (2:=heq_Γ).
    unfold EqRet in IH_v1,IH_v2.
    destruct IH_v1 as [h_eq_val_v1_val_v0_ ?], IH_v2 as [h_eq_val_v2_val_v3_ ?].
    rewrite h_eq_val_v1_val_v0_, h_eq_val_v2_val_v3_.
    red;auto.
  - inversion h_EE_e_v' as [ | | | x0 e0 v0 h_EE_e_v0_ ]; subst.
    specialize h_all_EQ_v_v'_ with (1:=h_EE_e_v0_) (2:=heq_Γ).
    unfold EqRet in h_all_EQ_v_v'_.
    destruct h_all_EQ_v_v'_ as [h_eq_val_v_val_v0_ h_eq_env_v_env_v0_].
    repeat rewrite h_eq_val_v_val_v0_.
    red;split;auto.
    cbn.
    rewrite h_eq_env_v_env_v0_.
    reflexivity.
Qed.

(* We actually need to prove modulo equivalence of environments *)
Lemma determ: forall Γ Γ' e v v',
    Eval_exp Γ e v ->
    Eval_exp Γ' e v' ->
    Env.Equal Γ Γ' ->
    EqRet v v'.
Proof.
  intros until 1 /ng.
  revert v'.
  induction h_EE_e_v_; intros /sng.
  - inversion h_EE_v_v'_.
    red;auto.
  - inversion h_EE_x_v'_; auto /sng.
    rewrite h_EQ_Γ_Γ'_ in h_MapsTo_x_v_Γ_.
    red.
    assert (v=v0);subst/sng.
    { eapply EnvFact.MapsTo_fun;eauto. }
    auto.
  - inversion h_EE_op_e1_e2_v'_ /sng.
    specialize h_all_EQ_v1_v'_ with (1:=h_EE_e1_v0_) (2:=h_EQ_Γ_Γ'_).
    specialize h_all_EQ_v2_v'_ with (1:=h_EE_e2_v3_) (2:=h_EQ_Γ_Γ'_).
    unfold EqRet in h_all_EQ_v1_v'_, h_all_EQ_v2_v'_.
    destruct h_all_EQ_v1_v'_, h_all_EQ_v2_v'_/sng.
    rewrite h_eq_val_v1_val_v0_,h_eq_val_v2_val_v3_.
    red;auto.
  - inversion h_EE_Assign_x_e_v'_ /sng.
    subst.
    specialize h_all_EQ_v_v'_ with (1:=h_EE_e_v0_) (2:=h_EQ_Γ_Γ'_).
    unfold EqRet in h_all_EQ_v_v'_.
    destruct h_all_EQ_v_v'_ /sng.
    repeat rewrite h_eq_val_v_val_v0_.
    red;split;auto.
    cbn.
    rewrite h_EQ_env_v_env_v0_.
    reflexivity.
Qed.

(*** Local Variables: ***)
(*** eval: (company-coq-mode 1) ***)
(*** End: ***)


Module Maps.

Require Export maps_int.
Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.

(*Key and value*)
  Inductive S: Type.
  Inductive T: Type.

  (*pair and map definition*)
  Definition pair_     :Type := prod S T.
  Definition map_     :Type := list pair_.

  Definition empty_map : set T := nil.

  Axiom (Seq_dec : forall x y: S, {x = y} + {x <> y}).
  Axiom (Teq_dec : forall x y: T, {x = y} + {x <> y}).
  Axiom (Peq_dec : forall x y: pair_, {x = y} + {x <> y}).
  Axiom (Mapeq_dec : forall x y: map_, {x = y} + {x <> y}).

(* get key and value*)
  Definition getKey (p: pair_)   : S := fst p.
  Definition getValue (p: pair_) : T :=  snd p.

  (** Foi preferível trabalhar com Prop*)
  (* Prop to bool *)
  Definition is_true (b:Prop) : bool :=
   match b with
     | True => true
   end.

  (** Checa se há um mapeamento entre uma chave e um determinado valor *)
  Fixpoint isMappable_func (s: map_) (l: S) (r: T): Prop :=
        match s with
          | nil     => False
          | p :: ps => if is_true ((fst p) = l) then
                          if is_true (snd p = r) then True
                          else (isMappable_func ps l r)
                       else (isMappable_func ps l r)
        end.

  Definition unique s : Prop :=
    forall (l: S) (r1 r2: T),
      (isMappable_func s l r1 /\ isMappable_func s l r2) -> r1 = r2.

  (** mapeamento único: se há um mapeamento entre uma chave para dois valores
      esses valores devem ser os mesmos.*)
  Definition unique_func s : Prop :=
    forall (l: S) (r1 r2: T),
      (isMappable_func s l r1 /\ isMappable_func s l r2) -> r1 = r2.

  (* obtêm os domínio dos pares*)
  Fixpoint dom_func (m: map_) : set S :=
    match m with
      | nil     => nil
      | p :: ps => set_add Seq_dec (fst p) (dom_func ps)
    end.

  (* obtêm a imagem dos pares*)
  Fixpoint img_func (m: map_) : set T :=
    match m with
      | nil     => nil
      | p :: ps => set_add Teq_dec (snd p) (img_func ps)
    end.

  (*união de S*)
Fixpoint union_s_func (ls1 ls2: set S) : set S:=
    match ls1 with
    | nil => ls2
    | x :: xs => match ls2 with
                  | nil => ls1
                  | y :: ys => if is_true(set_In y ls1) then
                                set_add Seq_dec x ( union_s_func xs ys)
                                else set_add Seq_dec x (set_add Seq_dec y ( union_s_func xs ys))
                    end
    end.
  (*União de T*)
  Definition union_t_func (rs1 rs2: set T) : set T :=
  match rs1 with
    | nil => rs2
    | x :: xs => match rs2 with
                  | nil => rs1
                  | y :: ys => set_union Teq_dec rs1 rs2
                  end
  end.

    (* Indicates whether there is a key *)
  Fixpoint existsT (s: map_) (l: S): Prop :=
      match s with
      | nil     => False
      | x :: xs => (fst x = l) \/ existsT xs l
      end.

   (* can pick up more than one value for a key, if there is *)
  Fixpoint getTs_func (s: map_) (l: S) : set T :=
   match s with
    | nil     => nil
    | x :: xs => if is_true(fst x = l)
                  then set_add Teq_dec (snd x) (getTs_func xs l)
                 else getTs_func xs l
    end.

  Definition option_elim (defaulT: T) (o : option T) : T :=
    match o with
      | Some n'=> n'
      | None   =>  defaulT
    end.

  (* get value *)
  Fixpoint getT (s: map_) (l: S) : option T :=
   match s with
    | nil     => None
    | x :: xs => if is_true (fst x = l) then Some (snd x) else getT xs l
    end.

  (*asset mapping function*)
  Fixpoint maps_func (defaulT: T) (s: map_) (ls: set S) : set T :=
    match s with
      | nil     => nil
      | c :: cs => match ls with
                    | nil     => nil
                    | x :: xs => if is_true (existsT s x)
                                    then app (option_elim defaulT (getT s x) :: nil)
                                      (maps_func defaulT s xs)
                                 else (maps_func defaulT s xs)
                   end
    end.

   Lemma uniqueUnion:
    forall m1 m2,
      forall l,
        set_In l (dom_func m1) -> ~(set_In l (dom_func m2))
          -> unique(app m1 m2).
  Proof.
    intros.
    induction m1.
      - induction m2.
        + intuition.
        + intuition. destruct l. simpl in H, H0, H1. contradiction.
       - induction m2.
Admitted.

  Definition set_add_S_func (s: S) (s1: set S): set S := set_add Seq_dec s s1.
  Definition set_add_T_func (t: T) (t1: set T): set T := set_add Teq_dec t t1.

End Maps.


Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.

Inductive reg_exp {T : Type} : Type :=
| EmptySet : reg_exp
| EmptyStr : reg_exp
| Char : T -> reg_exp
| App : reg_exp -> reg_exp -> reg_exp
| Union : reg_exp -> reg_exp -> reg_exp
| Star : reg_exp -> reg_exp.

Inductive exp_match {T} : list T -> reg_exp -> Prop :=
| MEmpty : exp_match nil EmptyStr
| MChar : forall x, exp_match (cons x nil) (Char x)
| MApp : forall s1 re1 s2 re2,
           exp_match s1 re1 ->
           exp_match s2 re2 ->
           exp_match (app s1 s2) (App re1 re2)
| MUnionL : forall s1 re1 re2,
              exp_match s1 re1 ->
              exp_match s1 (Union re1 re2)
| MUnionR : forall re1 s2 re2,
              exp_match s2 re2 ->
              exp_match s2 (Union re1 re2)
| MStar0 : forall re, exp_match nil (Star re)
| MStarApp : forall s1 s2 re,
               exp_match s1 re ->
               exp_match s2 (Star re) ->
               exp_match (s1 ++ s2) (Star re).

(* pumping constant *)
Fixpoint pc {T} (re : @reg_exp T) : nat :=
  match re with
  | EmptySet => 0
  | EmptyStr => 1
  | Char _ => 2
  | App re1 re2 =>
      pc re1 + pc re2
  | Union re1 re2 =>
      pc re1 + pc re2
  | Star _ => 1
  end.

Fixpoint napp {T} (n : nat) (l : list T) : list T :=
  match n with
  | 0 => nil
  | S n' => app l (napp n' l)
  end.

Lemma list_dec : forall {T:Type} (l:list T), l = nil \/ l <> nil.
Proof.
destruct l. left;reflexivity. right. intro h. inversion h.
Qed.

Lemma app_assoc : forall T (l m n : list T), app (app l m) n = app l (app m n).
Proof.
induction l.
simpl. reflexivity.
simpl. intros. rewrite IHl. reflexivity.
Qed.

Theorem pumping_lemma : forall T (re : @reg_exp T) s,
  exp_match s re ->
  pc re <= length s ->
  exists s1 s2 s3,
    s = app s1 (app s2 s3) /\
    s2 <> nil /\
    forall m, exp_match (app s1 (app (napp m s2) s3)) re.
Proof.
intros T r s m.
induction m as [
  (* empty *)
| (* char *) ch
| (* app *) sa ra sb rb ma ia mb ib
| (* union left *) sl rl rr ml il
| (* union right *) rl sr rr mr ir
| (* star empty *) r
| (* star next *) sr srs R mr ir mrs irs
];simpl.
{ (* Empty *)
  intro l. inversion l.
}
{ (* Char *)
  intro l. apply Nat.nle_succ_diag_l in l. contradiction.
}
{ (* App *)
  intro l.
  rewrite app_length in l.
  apply Nat.add_le_cases in l.
  inversion_clear l as [ la | lb ].
  {
    specialize (ia la). clear ib.
    inversion ia as [ ta [ tb [ tc [ hx [ hy hz ]]]]].
    exists ta, tb, (tc++sb).
    split. subst sa. repeat (rewrite app_assoc). reflexivity.
    split. assumption.
    intro m.
      assert (eq: ta++napp m tb ++ tc ++ sb = (ta++napp m tb ++ tc) ++ sb).
      repeat (rewrite app_assoc). reflexivity.
    rewrite eq. constructor. apply hz. assumption.
  }
  {
    specialize (ib lb). clear ia.
    inversion ib as [ ta [ tb [ tc [ hx [ hy hz ]]]]].
    exists (sa++ta), tb, tc.
    split. subst sb. repeat (rewrite app_assoc). reflexivity.
    split. assumption.
    intro m.
      assert (eq: (sa++ta)++napp m tb ++ tc = sa++(ta++napp m tb ++ tc)).
      repeat (rewrite app_assoc). reflexivity.
    rewrite eq. constructor. assumption. apply hz.
  }
}
{ (* Union left *)
  intro l.
    assert (ll:pc rl <= length sl).
    apply (le_trans _ (pc rl + pc rr) _). apply le_plus_trans. constructor. assumption.
  specialize (il ll).
  inversion il as [ ta [ tb [ tc [ hx [ hy hz ]]]]].
  exists ta, tb, tc. split. assumption. split. assumption.
  intro m. apply MUnionL. apply hz.
}
{ (* Union right *)
  intro l.
    assert (lr:pc rr <= length sr).
    apply (le_trans _ (pc rl + pc rr) _). rewrite plus_comm. apply le_plus_trans. constructor. assumption.
  specialize (ir lr).
  inversion ir as [ ta [ tb [ tc [ hx [ hy hz ]]]]].
  exists ta, tb, tc. split. assumption. split. assumption.
  intro m. apply MUnionR. apply hz.
}
{ (* Star none *)
  intro h. inversion h.
}
{ (* Star some *)
  intro l.
  simpl in irs.
  elim (list_dec sr);simpl.
  {
    intro eq. subst sr. simpl in l. specialize (irs l).
    inversion irs as [ ta [ tb [ tc [ hx [ hy hz ]]]]].
    exists ta, tb, tc;simpl.
    split. assumption. split. assumption.
    assumption.
  }
  {
    intro neq.
    exists nil, sr, srs. simpl.
    split. reflexivity. split. assumption.
    simpl. induction m as [ | m im ];simpl.
    - assumption.
    - rewrite app_assoc. constructor.
      + assumption.
      + assumption.
  }
}
Qed.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype tuple.
Require Import BinPos BinNat PArith.
Require Import ssr_ext.

(******************************************************************************)
(*                 Equivalence bitstrings <-> natural numbers                 *)
(*                                                                            *)
(* bitseq_of_pos       == conversion positive -> bitseq                       *)
(* bitseq_of_N         == conversion N -> bitseq                              *)
(* rem_lea_false       == remove leading false's                              *)
(* N_of_bitseq         == conversion bitseq -> N                              *)
(* tuple2N             == conversion tuple -> N                               *)
(* bitseq_of_nat i n   == conversion i < 2 ^ n to bitseq (of length n)        *)
(* rV_of_nat           == encoding of naturals as vectors, e.g.,              *)
(*                        rV_of_nat 3 1 = [ 0 0 1 ]                           *)
(*                        rV_of_nat 3 2 = [ 0 1 0 ]                           *)
(*                        rV_of_nat 3 3 = [ 0 1 1 ]                           *)
(* nat_of_rV           == conversion 'rV['F_2]_n -> nat                       *)
(* cV_of_nat/nat_of_cV == the same using column vectors                       *)
(*                                                                            *)
(******************************************************************************)

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

(* NB: not used? *)
Lemma pad_seqL_leading_true_inj : forall n i j,
  size i <= n -> size j <= n ->
  pad_seqL false (true :: i) n.+1 = pad_seqL false (true :: j) n.+1 ->
  i = j.
Proof.
elim=> [[] // [] // | ] n IH i j Hi Hj; rewrite /pad_seqL /= !ltnS !subSS => X.
rewrite Hi Hj in X.
move: Hi; rewrite leq_eqVlt.
case/orP => [/eqP Hi|Hi].
  rewrite Hi subnn /= in X.
  move: Hj; rewrite leq_eqVlt.
  case/orP => [/eqP Hj|Hj].
    by move: X; rewrite Hj subnn /= => -[].
  rewrite subSn //= in X; by rewrite -ltnS.
move: Hj; rewrite leq_eqVlt.
case/orP => [/eqP Hj|Hj].
  rewrite Hj subnn /= in X.
  rewrite subSn //= in X; by rewrite -ltnS.
move: X; rewrite !subSn //= => -[] X.
apply IH => //.
by rewrite /pad_seqL /= Hi Hj !subSS.
Qed.

Fixpoint bitseq_of_pos (p : positive) : bitseq :=
  match p with
    | xI q => true :: bitseq_of_pos q
    | xO q => false :: bitseq_of_pos q
    | xH => true :: nil
  end.

Lemma bitseq_of_pos_not_nil a : bitseq_of_pos a <> [::]. Proof. by case: a. Qed.

Lemma bitseq_of_pos_not_nseq_false i r : bitseq_of_pos i <> nseq r false.
Proof.
elim : i r => /= [p Hp [] //|| [] //].
move=> p Hp [] // r [X].
by apply Hp with r.
Qed.

Lemma bitseq_of_pos_not_false a : bitseq_of_pos a <> [:: false].
Proof. exact: bitseq_of_pos_not_nseq_false a 1. Qed.

Lemma bitseq_of_pos_inj : injective bitseq_of_pos.
Proof.
elim.
- move=> a IH [] //=.
  + by move=> b [] /IH ->.
  + by case => /bitseq_of_pos_not_nil.
- by move=> a IH [] // b /= [] /IH ->.
- by case=> // a /= [] /esym/bitseq_of_pos_not_nil.
Qed.

Lemma bitseq_of_pos_true : forall p, bitseq_of_pos p = [:: true] -> p = xH.
Proof. by case => //; case. Qed.

Fixpoint pos_of_bitseq s : positive :=
  match s with
    | [::] => xH
    | true :: t => xI (pos_of_bitseq t)
    | false :: t => xO (pos_of_bitseq t)
  end.

Lemma pos_of_bitseq_nseq_false : forall p, Pos.to_nat (pos_of_bitseq (nseq p false)) = 2 ^ p.
Proof. elim=> // p IH /=; by rewrite expnS -IH Pos2Nat.inj_xO. Qed.

Lemma pos_of_bitseq_rev : forall y p,
  rev (bitseq_of_pos p) = true :: y -> pos_of_bitseq (rev y) = p.
Proof.
elim/last_ind => [p Hp /=|h t IH []// p /=].
  apply/esym/bitseq_of_pos_true; by rewrite -[LHS]revK Hp.
- rewrite rev_cons -rcons_cons => /eqP.
  rewrite eqseq_rcons => /andP[/eqP/IH H1 /eqP <-].
  by rewrite rev_rcons /= H1.
- rewrite rev_cons -rcons_cons => /eqP.
  rewrite eqseq_rcons => /andP[/eqP/IH H1 /eqP <-].
  by rewrite rev_rcons /= H1.
- by move: p; case => <-.
Qed.

Lemma pos_of_bitseq_up : forall p l, size l <= p ->
  Pos.to_nat (pos_of_bitseq l) < 2 ^ p.+1.
Proof.
elim=> [|p ih [|h t] //]; first by destruct l.
- move=> _ /=.
  by rewrite (@leq_ltn_trans 1) // -{1}(expn0 2) ltn_exp2l.
- move=> H1 /=.
  destruct h.
    rewrite Pos2Nat.inj_xI expnS multE.
    rewrite (@leq_trans  (2 * (Pos.to_nat (pos_of_bitseq t)).+1)) //.
      by rewrite mulnS addnC addn2.
    by rewrite leq_mul2l /= ih.
  by rewrite Pos2Nat.inj_xO expnS multE ltn_mul2l /= ih.
Qed.

Definition bitseq_of_N (x : N) :=
  match x with
    | N0 => false :: nil
    | Npos p => bitseq_of_pos p
  end.

Lemma bitseq_of_N_2 x : x <> N0 -> bitseq_of_N (2 * x) = false :: bitseq_of_N x.
Proof. by case : x. Qed.

Lemma bitseq_of_N_leading_bit n : n <> N0 -> exists k, rev (bitseq_of_N n) = true :: k.
Proof.
case : n => //.
elim => [i IH _ | i IH _ | _ /=].
- have : Npos i <> 0%N by [].
  case/IH => k /= Hk.
  exists (rcons k true); by rewrite rev_cons Hk.
- have : Npos i <> 0%N by [].
  case/IH => k /= Hk.
  exists (rcons k false); by rewrite rev_cons Hk.
- by exists nil.
Qed.

Lemma bitseq_of_N_nseq_false i r : i <> O -> bitseq_of_N (bin_of_nat i) <> nseq r false.
Proof. case: i r => // i r _ /=; exact: bitseq_of_pos_not_nseq_false. Qed.

Lemma bitseq_of_N_inj : injective bitseq_of_N.
Proof.
case.
- by case => // a /= /esym/bitseq_of_pos_not_false.
- move=> a /= [] //=.
  + by move/bitseq_of_pos_not_false.
  + by move=> b /bitseq_of_pos_inj ->.
Qed.

Lemma bitseq_of_N_bin_of_nat_expn2 : forall m : nat,
  bitseq_of_N (bin_of_nat (2 ^ m)) = nseq m false ++ [:: true].
Proof.
elim => // m0 IH.
rewrite [in X in _ = X]/= -IH bin_of_nat_expn2 bitseq_of_N_2 //.
suff [i Hi] : exists i, 2 ^ m0 = nat_of_pos i.
  rewrite Hi.
  by apply bin_of_nat_nat_of_pos_not_0.
exists (Pos.of_nat (2 ^ m0)).
rewrite -BinPos_nat_of_P_nat_of_pos Nat2Pos.id //.
apply/eqP; by rewrite -lt0n expn_gt0.
Qed.

Lemma size_bitseq_of_N_ub' : forall i n, nat_of_bin i <> O ->
  nat_of_bin i < 2 ^ n -> size (bitseq_of_N i) <= n.
Proof.
case=> //=.
elim => [p IHp n _ H /= | p IHp n _ H /= | [] //].
- case: n H => [//|n H].
  have X : nat_of_pos p < 2 ^ n.
    have {H} : (nat_of_pos p).*2 < 2 ^ n.+1.
      rewrite /= NatTrec.doubleE in H.
      by apply leq_ltn_trans with (nat_of_pos p).*2.+1.
    by rewrite expnSr muln2 ltn_double.
  apply IHp in X; last exact: nat_of_pos_not_0.
  by apply leq_ltn_trans with n.
- case: n H => [H|n H].
  + rewrite expn0 in H.
    have {H} : nat_of_pos (BinPos.xO p) = O.
      by destruct (nat_of_pos (BinPos.xO p)).
    by move: (@nat_of_pos_not_0 (BinPos.xO p)).
  + have : nat_of_pos p < 2 ^ n.
      by rewrite /= NatTrec.doubleE expnSr muln2 ltn_double in H.
    rewrite ltnS; move/IHp; apply.
    exact: nat_of_pos_not_0.
Qed.

Lemma size_pad_positive c (s : bitseq) :
  pad_seqL false (rev (c :: bitseq_of_pos (pos_of_bitseq s))) (size s).+2 =
  rcons (pad_seqL false (rev (bitseq_of_pos (pos_of_bitseq s))) (size s).+1) c.
Proof.
rewrite /pad_seqL !size_rev /= ltnS.
case: ifPn => Hsz; first by rewrite subSS rev_cons rcons_cat.
have Hup := pos_of_bitseq_up (leqnn (size s)).
have Hub' := @size_bitseq_of_N_ub' (Npos (pos_of_bitseq s)) (size s).+1
             (@nat_of_pos_not_0 _).
rewrite /= -BinPos_nat_of_P_nat_of_pos in Hub'.
by rewrite Hub' in Hsz.
Qed.

Lemma size_bitseq_of_N_ub i n : i <> O ->
  i < 2 ^ n -> size (bitseq_of_N (bin_of_nat i)) <= n.
Proof.
move=> Hi Hin.
apply (@size_bitseq_of_N_ub' (bin_of_nat i) n); by rewrite bin_of_natK.
Qed.

Lemma size_bitseq_of_N_lb' : forall i n,
  2 ^ n <= nat_of_bin i -> n < size (bitseq_of_N i).
Proof.
case => [m|]; first by rewrite leqn0 expn_eq0.
elim => [p ih m K /= | p ih m K /= | m].
- case: m K => [//|m K].
  have /ih : 2 ^ m <= nat_of_pos p.
    move: K.
    by rewrite /= NatTrec.doubleE expnS -ltnS -doubleS -muln2 mulnC ltn_pmul2r.
  by rewrite ltnS.
- case: m K => [//|m K].
  have /ih : 2 ^ m <= nat_of_pos p.
    by rewrite /= NatTrec.doubleE expnS -muln2 mulnC leq_pmul2r in K.
  by rewrite ltnS.
- by rewrite -[in X in _ <= X](_ : 2 ^ 0 = 1%num) // leq_exp2l.
Qed.

Lemma size_bitseq_of_N_lb i n : 2 ^ n <= i ->
  n < size (bitseq_of_N (bin_of_nat i)).
Proof. move=> Hn; by rewrite size_bitseq_of_N_lb' // bin_of_natK. Qed.

Fixpoint rem_lea_false s :=
  match s with
    | [::] => [::]
    | true :: _ => s
    | _ :: t => rem_lea_false t
  end.

Lemma rem_lea_false_nseq : forall a b, rem_lea_false (nseq a false ++ b) =
  rem_lea_false b.
Proof. by elim. Qed.

Lemma rem_lea_false_pad_seqL : forall a l, (size l < a)%nat ->
  rem_lea_false (pad_seqL false (true :: l) a) = true :: l.
Proof.
case=> [//| a l H].
by rewrite /pad_seqL /= H subSS rem_lea_false_nseq.
Qed.

Definition N_of_bitseq s : N :=
  match rem_lea_false s with
    | [::] => N0
    | true :: t => Npos (pos_of_bitseq (rev t))
    | _ => N0 (* shouldn't happen *)
  end.

Lemma N_of_bitseq_false : forall l, N_of_bitseq (false :: l) = N_of_bitseq l.
Proof. by case. Qed.

Lemma N_of_bitseq_nseq_false : forall k, N_of_bitseq (nseq k false) = N0.
Proof. by elim. Qed.

Lemma N_of_bitseq_up : forall p l, size l <= p ->
  N.to_nat (N_of_bitseq l) < 2 ^ p.
Proof.
elim=> [[|//] _ /= |p IH [/=|h t]].
- by rewrite expn_gt0.
- by rewrite expn_gt0.
- rewrite /= ltnS => tp.
  destruct h; first by rewrite /= pos_of_bitseq_up // size_rev.
  by rewrite N_of_bitseq_false (ltn_trans (IH _ tp)) // ltn_exp2l.
Qed.

Lemma N_of_bitseq_true p : N.to_nat (N_of_bitseq (true :: nseq p false)) = 2 ^ p.
Proof.
elim : p => // p IH /=.
by rewrite (_ : false :: _ = nseq p.+1 false) // rev_nseq pos_of_bitseq_nseq_false.
Qed.

Lemma N_of_bitseq_0 : forall n0 p, N_of_bitseq p = N0 -> size p = n0 ->
  p = nseq n0 false.
Proof. elim => [ [] // | n0 IH [|[] t] //= Hp [Hsz] ]. by rewrite -(IH t). Qed.

Lemma Npos_pos_of_bitseq_rev' : forall x y,
  rev (bitseq_of_N x) = true :: y ->
  Npos (pos_of_bitseq (rev y)) = nat_of_bin x :> nat.
Proof.
elim/Nind => // x IH y.
move Heq : (N.succ x) => eq.
destruct eq => //= H.
f_equal.
by apply pos_of_bitseq_rev in H.
Qed.

Lemma Npos_pos_of_bitseq_rev x y :
  rev (bitseq_of_N (bin_of_nat x)) = true :: y ->
  Npos (pos_of_bitseq (rev y)) = x :> nat.
Proof.
move=> H.
by rewrite (@Npos_pos_of_bitseq_rev' (bin_of_nat x) y H) bin_of_natK.
Qed.

Lemma size_N_of_bitseqK (s : bitseq) :
  size s > 0 -> size (bitseq_of_N (bin_of_nat (N_of_bitseq s))) <= size s.
Proof.
move=> Hs.
case Hbs : (bin_of_nat _) => //.
apply size_bitseq_of_N_ub'.
  by apply nat_of_pos_not_0.
by rewrite -Hbs bin_of_natK -Nto_natE N_of_bitseq_up.
Qed.

Definition bitseq_of_nat (i : nat) n :=
  pad_seqL false (rev (bitseq_of_N (bin_of_nat i))) n.

Lemma size_bitseq_of_nat i n : size (bitseq_of_nat i n) == n.
Proof. by rewrite /bitseq_of_nat size_pad_seqL. Qed.

Lemma bitseq_of_nat_nseq_false i r : i <> O ->
  i < 2 ^ r -> bitseq_of_nat i r <> nseq r false.
Proof.
move=> Hi Hin.
rewrite /bitseq_of_nat /pad_seqL.
have : size (bitseq_of_N (bin_of_nat i)) <= r by exact/size_bitseq_of_N_ub.
rewrite leq_eqVlt.
case/orP => X.
- move/eqP : X => X.
  rewrite {1}size_rev {1}X leqnn -X -{1}size_rev subnn /=.
  have Y : bitseq_of_N (bin_of_nat i) <>
    rev (nseq (size (bitseq_of_N (bin_of_nat i))) false).
    rewrite rev_nseq.
    exact: bitseq_of_N_nseq_false.
  contradict Y.
  by rewrite -Y revK.
- rewrite {1}size_rev leq_eqVlt X orbC /= size_rev => abs.
  move: (nseq_cat abs) => {}abs.
  have W : bitseq_of_N (bin_of_nat i) = nseq (size (rev (bitseq_of_N (bin_of_nat i)))) false.
    by rewrite -[LHS]revK abs rev_nseq !size_nseq.
  exact: bitseq_of_N_nseq_false Hi W.
Qed.

Lemma bitseq_of_nat_expn2 p m : p < m ->
  bitseq_of_nat (2 ^ p) m = nseq (m - p.+1) false ++ true :: nseq p false.
Proof.
move=> pm.
rewrite /bitseq_of_nat /= /pad_seqL /= bitseq_of_N_bin_of_nat_expn2 size_rev.
by rewrite size_cat size_nseq /= -ltnS addn1 ltnS pm rev_cat /= rev_nseq.
Qed.

Lemma N_of_bitseq_bitseq_of_nat m x : x <> O -> (x < 2 ^ m)%nat ->
  N_of_bitseq (bitseq_of_nat x m) = x :> nat.
Proof.
move=> Hx x_m.
rewrite /N_of_bitseq /bitseq_of_nat.
have Hx' : bin_of_nat x <> N0.
  contradict Hx.
  rewrite (_ : 0 = bin_of_nat (nat_of_bin 0))%N // in Hx.
  by apply bin_of_nat_inj in Hx.
case: (@bitseq_of_N_leading_bit _ Hx') => y Hy.
rewrite Hy.
rewrite rem_lea_false_pad_seqL; last first.
  move: (size_bitseq_of_N_ub Hx x_m).
  by rewrite -size_rev Hy.
  by apply Npos_pos_of_bitseq_rev in Hy.
Qed.

Lemma bitseq_of_nat_0 n : bitseq_of_nat 0 n = nseq n false.
Proof.
rewrite /bitseq_of_nat /= /pad_seqL /=.
case: ifP => [Hn|]; last by case: n.
by rewrite cats1 -nseq_S subn1 prednK.
Qed.

Lemma bitseq_of_nat_inj n i j : i < 2 ^ n -> j < 2 ^ n ->
  bitseq_of_nat i n = bitseq_of_nat j n -> i = j.
Proof.
move=> Hi Hj.
case/boolP : (i == 0) => [/eqP -> | /eqP Hi0].
  rewrite bitseq_of_nat_0 => abs.
  apply/eqP/negPn/negP.
  rewrite eq_sym => /eqP.
  move/(@bitseq_of_nat_nseq_false j n); by apply.
case/boolP : (j == 0) => [/eqP -> | /eqP Hj0].
  rewrite bitseq_of_nat_0 => abs.
  apply/eqP/negPn/negP.
  move/eqP/(@bitseq_of_nat_nseq_false i n); by apply.
move=> H.
by rewrite -(N_of_bitseq_bitseq_of_nat Hi0 Hi) -(N_of_bitseq_bitseq_of_nat Hj0 Hj) H.
Qed.

Lemma N_of_bitseqK (s : bitseq) :
  size s > 0 -> bitseq_of_nat (N.to_nat (N_of_bitseq s)) (size s) = s.
Proof.
clear.
rewrite Nto_natE.
elim: s => // b s IHs Hs /=.
case b; simpl.
  rewrite /bitseq_of_nat nat_of_posK /=.
  rewrite -size_rev -{3}(revK s).
  elim: (rev s) => //.
  clear.
  move => b s IHs /=.
  rewrite -(cat1s b) rev_cat -cat_cons -IHs cats1.
  by case b; apply size_pad_positive.
case Hs': (size s > 0); last by destruct s.
rewrite -{3}IHs /bitseq_of_nat //.
rewrite (_ : N_of_bitseq (false :: s) = N_of_bitseq s) //.
rewrite /pad_seqL size_rev.
have Hsz := size_N_of_bitseqK Hs'.
rewrite !ifT //.
  by rewrite subSn.
by apply leqW.
Qed.

Definition tuple2N {m} (x : m.-tuple bool) := match x with Tuple x _ => N_of_bitseq x end.

Lemma tuple2N_0 n : forall p, tuple2N p = N0 -> p = [tuple of nseq n false].
Proof.
case=> p Hp /= Hp'.
apply val_inj => /=.
apply N_of_bitseq_0 => //; by apply/eqP.
Qed.

(* sample vectors *)

Lemma rev7_neq0 n : (7 * 2 ^ (n - 3))%nat <> O.
Proof.
rewrite -[in X in _ <> X ](muln0 7).
move/eqP.
by rewrite eqn_mul2l /= expn_eq0.
Qed.

Lemma rev7_ub n (Hlen : 2 < n) : 7 * 2 ^ (n - 3) < 2 ^ n.
Proof.
rewrite -[in X in _ < X](@subnKC 3 n) //.
by rewrite /= expnD ltn_pmul2r // expn_gt0.
Qed.

Lemma rev7_lb n (Hn : 2 < n) : 2 ^ n.-1 <= 7 * 2 ^ (n - 3).
Proof.
destruct n => //=.
rewrite (@leq_trans (2 ^ 2 * 2 ^( n.+1 - 3))) //.
  rewrite -expnD leq_exp2l // addnBA // addnC addn2 -addn3.
  by rewrite -addnBA // subnn addn0.
by rewrite leq_pmul2r // expn_gt0.
Qed.

Lemma bin_of_nat_7 : forall n, 2 < n ->
  bin_of_nat 7 = BinNums.Npos (BinNums.xI (BinNums.xI (BinNums.xH))).
Proof. by []. Qed.

Fixpoint xOs n cont :=
  match n with
    | O => cont
    | S m => BinNums.xO (xOs m cont)
  end.

Lemma bin_of_nat_rev7 : forall n, 2 < n ->
  bin_of_nat (7 * 2 ^ (n - 3)) =
  BinNums.Npos (xOs (n - 3) (BinNums.xI (BinNums.xI (BinNums.xH)))).
Proof.
elim=> //.
case=> //.
case=> //.
case=> //.
move=> n /(_ Logic.eq_refl) => IH _.
rewrite (_ : n.+4 - 3 = n.+1)%nat //.
rewrite (_ : n.+3 - 3 = n)%nat // in IH; last by rewrite 3!subSS subn0.
transitivity (BinNat.N.mul 2 (bin_of_nat (7 * 2 ^ n))); last by rewrite {}IH -BinPos.Pos.add_diag.
set lhs := bin_of_nat _.
set rhs := BinNat.N.mul _ _.
suff : nat_of_bin lhs = nat_of_bin rhs.
  rewrite {1}/lhs bin_of_natK /lhs => ->.
  by rewrite nat_of_binK.
rewrite /lhs /rhs bin_of_natK nat_of_mul_bin expnS mulnA (mulnC 7) -mulnA.
f_equal.
by rewrite bin_of_natK.
Qed.

(* TODO: move *)
From mathcomp Require Import bigop zmodp ssralg matrix.
Require Import ssralg_ext f2.

Import GRing.Theory.

Section rV_and_nat_def.

Variable n : nat.

Definition rV_of_nat (i : nat) : 'rV['F_2]_n :=
  row_of_bitseq (size_bitseq_of_nat i n).

Definition nat_of_rV (y : 'rV['F_2]_n) : nat :=
  BinNat.N.to_nat (N_of_bitseq (map bool_of_F2 (tuple_of_row y))).

End rV_and_nat_def.

Section rV_and_nat_prop.

Variable n : nat.

Local Open Scope ring_scope.

Lemma rV_of_nat_neq0 i : i <> O -> (i < expn 2 n)%nat -> rV_of_nat n i <> 0%R.
Proof.
move=> Hi W.
move: (bitseq_of_nat_nseq_false Hi W) => H.
contradict H.
apply eq_from_nth with false.
- by rewrite /= size_pad_seqL size_nseq.
- move=> j Hj.
  rewrite (_ : size _ = n) in Hj; last by apply/eqP; rewrite size_bitseq_of_nat.
  move/rowP : H => /(_ (Ordinal Hj)).
  rewrite !mxE /= => Hj'.
  rewrite nth_nseq Hj.
  by apply F2_of_bool_0_inv.
Qed.

Lemma rV_of_nat_inj i j : (i < expn 2 n)%nat -> (j < expn 2 n)%nat ->
  rV_of_nat n i = rV_of_nat n j -> i = j.
Proof.
move=> Hi Hj /bitseq_row_nth => h; apply (@bitseq_of_nat_inj n) => //.
by apply h; rewrite !(eqP (size_bitseq_of_nat _ _)).
Qed.

Local Open Scope nat_scope.
Local Open Scope ring_scope.

Lemma rV_of_natD_neq0 i j : i <> j -> i <> O -> j <> O ->
  (i < expn 2 n)%nat -> (j < expn 2 n)%nat -> rV_of_nat n i + rV_of_nat n j <> 0.
Proof.
move=> Hij Hi Hj Hin Hjn.
destruct i => //.
destruct j => //.
contradict Hij.
apply F2_addmx0 in Hij.
have [ii Hii] : exists ii, i.+1 = nat_of_pos ii.
  exists (BinPos.P_of_succ_nat i).
  by rewrite -Pnat.nat_of_P_o_P_of_succ_nat_eq_succ BinPos_nat_of_P_nat_of_pos.
have [jj Hjj] : exists jj, j.+1 = nat_of_pos jj.
  exists (BinPos.P_of_succ_nat j).
  by rewrite -Pnat.nat_of_P_o_P_of_succ_nat_eq_succ BinPos_nat_of_P_nat_of_pos.
rewrite Hii Hjj in Hij.
apply rV_of_nat_inj in Hij; last 2 first.
  by rewrite -Hii.
  by rewrite -Hjj.
apply nat_of_pos_inj in Hij.
rewrite Hjj; by subst ii.
Qed.

Lemma mulmx_rV_of_nat_row m (M : 'M_(n, m)) (k : 'I_n) :
  rV_of_nat n (expn 2 k) *m M = row (Ordinal (rev_ord_proof k)) M.
Proof.
rewrite /rV_of_nat.
apply/rowP => i.
rewrite !mxE /=.
transitivity (\sum_(j < n) (F2_of_bool (nth false (bitseq_of_nat (expn 2 k) n) j) * M j i)).
  apply eq_bigr => l _; by rewrite mxE.
rewrite bitseq_of_nat_expn2 //.
set j := Ordinal _.
rewrite (bigD1 j) //=.
set x := nth _ _ _.
have -> : x = true by rewrite /x nth_cat size_nseq ltnn subnn.
rewrite mul1r.
rewrite [X in _ + X = _](_ : _ = 0) ?addr0 //.
rewrite (eq_bigr (fun=> 0)) ?big_const ?iter_addr0 // => l lj.
rewrite (_ : nth _ _ _ = false) ?mul0r //.
rewrite  nth_cat size_nseq.
case: ifP => lnk; first by rewrite nth_nseq lnk.
rewrite (_ : true :: _ = [:: true] ++ nseq k false) // nth_cat /=.
case: ifP => lnk1; last by rewrite nth_nseq; case: ifP.
exfalso.
clear -lnk1 lj lnk.
have {lnk1} : l <= n - k.+1 by rewrite ltnS leqn0 in lnk1.
rewrite leq_eqVlt lnk orbC /=; by apply/negP.
Qed.

Lemma rV_of_nat_0 : rV_of_nat n 0 = 0.
Proof.
rewrite /rV_of_nat /row_of_bitseq; apply/rowP => b /=.
by rewrite !mxE bitseq_of_nat_0 nth_nseq (ltn_ord b).
Qed.

Lemma nat_of_rV_up (y : 'rV_n) : nat_of_rV y < expn 2 n.
Proof. by rewrite /nat_of_rV N_of_bitseq_up // size_map size_tuple. Qed.

Lemma nat_of_rV_0 : nat_of_rV (0 : 'rV_n) = O.
Proof.
rewrite /nat_of_rV (_ : N_of_bitseq _ = 0%N) //.
rewrite (_ : map _ _ = nseq n false) // ?N_of_bitseq_nseq_false //.
apply eq_from_nth with false; first by rewrite size_map size_nseq size_tuple.
move=> i; rewrite size_map size_tuple => ni.
rewrite (nth_map 0) ?size_tuple // nth_nseq ni (_ : nth _ _ _ = 0) //.
by rewrite /tuple_of_row /= (nth_map (Ordinal ni)) ?size_enum_ord // mxE.
Qed.

Lemma nat_of_rV_ord0 (y : 'rV_0) : nat_of_rV y = O.
Proof. by rewrite /nat_of_rV Nto_natE tuple_of_row_ord0. Qed.

Lemma nat_of_rVK (y : 'rV_n) : rV_of_nat n (nat_of_rV y) = y.
Proof.
case: n y => [|n0] y.
  apply/rowP; by case.
apply/rowP => i.
rewrite mxE /nat_of_rV.
set tmp := [seq bool_of_F2 i | i <- _].
rewrite [X in bitseq_of_nat _ X](_ : _ = size tmp); last by rewrite size_map size_tuple.
rewrite N_of_bitseqK; last by rewrite size_tuple.
rewrite /tmp (nth_map (0 : 'F_2)); last by rewrite size_tuple.
by rewrite bool_of_F2K /tuple_of_row nth_mktuple.
Qed.

Lemma nat_of_rV_eq0 (y : 'rV_n) : (nat_of_rV y == O) = (y == 0).
Proof.
case/boolP : (nat_of_rV _ == O) => H.
  have : rV_of_nat n (nat_of_rV y) = 0 by rewrite (eqP H) rV_of_nat_0.
  by rewrite nat_of_rVK => ->; rewrite eqxx.
apply/esym/eqP/eqP; apply: contra H => /eqP ->.
by rewrite nat_of_rV_0.
Qed.

End rV_and_nat_prop.

Section cV_and_nat.

Local Open Scope ring_scope.

Definition cV_of_nat (n i : nat) : 'cV['F_2]_n := (rV_of_nat n i)^T.

Definition nat_of_cV n (y : 'cV['F_2]_n) : nat := nat_of_rV y^T.

Lemma nat_of_cV_0 k : nat_of_cV (0 : 'cV_k) = O.
Proof. by rewrite /nat_of_cV trmx0 nat_of_rV_0. Qed.

Lemma nat_of_rV_tr n (y : 'rV_n) : nat_of_rV y = nat_of_cV (y^T).
Proof. by rewrite /nat_of_cV trmxK. Qed.

End cV_and_nat.

Lemma rev7_bin : forall m, (2 < m)%nat ->
  rev (bitseq_of_N (BinNums.Npos (xOs (m - 3) (BinNums.xI 3)))) =
  true :: true :: true :: nseq (m - 3) false.
Proof.
elim=> //.
case=> //.
case=> //.
case=> // m /(_ isT).
rewrite -{1}addn3 -addnBA // subnn addn0 => IH _.
rewrite -{1}addn4 -addnBA //= (_ : 4 - 3 = 1)%nat // addn1 /=.
by rewrite rev_cons IH /= -{1}addn3 -addnBA // subnn addn0 -nseq_S.
Qed.

Lemma rev_bitseq_of_nat_7 n : (2 < n)%nat ->
  rev (bitseq_of_nat 7 n) = bitseq_of_nat (7 * expn 2 (n - 3)) n.
Proof.
move=>Hn.
rewrite /bitseq_of_nat.
rewrite (bin_of_nat_rev7 Hn).
rewrite (@bin_of_nat_7 n) //=.
rewrite (rev7_bin Hn) /=.
rewrite {1}/pad_seqL /=.
rewrite Hn.
rewrite rev_cat /=.
rewrite /pad_seqL /=.
rewrite size_nseq.
case: ifP => H //.
  rewrite (_ : n - (n - 3).+3 = 0)%nat //; last first.
  destruct n => //.
  destruct n => //.
  destruct n => //.
  rewrite -addn3.
  by rewrite -(@addnBA n 3 3) // subnn addn0 addn3 subnn.
by rewrite rev_nseq.
exfalso.
move/negbT in H.
rewrite -leqNgt in H.
destruct n => //.
destruct n => //.
destruct n => //.
by rewrite -{2}addn3 -addnBA // subnn addn0 ltnn in H.
Qed.


Require Export D.

Theorem O_le_n : forall n,
  0 <= n.
 Proof. intros. induction n as [|n']. apply le_n. apply le_S. assumption. Qed.


From mathcomp Require Import ssreflect ssrbool ssrnat ssrfun.
From mathcomp Require Import eqtype choice order seq tuple path zify.
From mathcomp Require Import fintype finfun fingraph finmap.
From mathcomp.tarjan Require Import extra.
From eventstruct Require Import utils.

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

Import Order.Theory.

Section SeqUtils.
Context {T : Type}.
Implicit Types (p : pred T) (r : rel T) (s : seq T) (n : nat).

Lemma behead_rcons x s :
  behead (rcons s x) = if s is [::] then [::] else rcons (behead s) x.
Proof. by case: s. Qed.

Lemma headNnil x y s :
  ~~ nilp s -> head y s = head x s.
Proof. by case: s. Qed.

Lemma lastNnil x y s :
  ~~ nilp s -> last y s = last x s.
Proof. by case: s. Qed.

Lemma hasNcount p s :
   ~~ has p s = (count p s == 0).
Proof. by rewrite has_count -leqNgt leqn0. Qed.

Lemma hasNtake p s :
   ~~ has p (take (find p s) s).
Proof. by apply/contra; first apply/find_ltn; rewrite ltnn. Qed.

Lemma count_take_find p s :
  count p (take (find p s) s) = 0.
Proof. apply/eqP; rewrite -hasNcount; apply/hasNtake. Qed.

Lemma count_set_nth m i :
   ~~ nth false m i -> count id (set_nth false m i true) = 1 + count id m.
Proof.
  move: i; elim: m=> [|b {}m IH] i /=.
  - by rewrite set_nth_nil addn0 /= => _; elim i.
  elim i=> [|{}i IHi] => /=.
  - by move=> /negbTE ->.
  move=> /IH ->; lia.
Qed.

Lemma mkseqS (f : nat -> T) n :
  mkseq f n.+1 = rcons (mkseq f n) (f n).
Proof. by rewrite /mkseq -addn1 iotaD add0n map_cat cats1. Qed.

Lemma set_nthE x s i y : i < size s ->
  set_nth x s i y = (rcons (take i s) y) ++ (drop i.+1 s).
Proof.
  move=> Hi; apply/(@eq_from_nth _ x).
  - rewrite size_set_nth size_cat size_rcons.
    rewrite size_drop size_takel ?maxnE //; exact/ltnW.
  move=> j Hj; rewrite nth_set_nth /=.
  rewrite -cats1 -catA !nth_cat size_takel ?nth_drop /=; last exact/ltnW.
  case: (j < i)/idP.
  - move=> /[dup] Hlt; rewrite nth_take //.
    by rewrite ltn_neqAle=> /andP[/negPf->].
  move=> /negP; rewrite -leqNgt ltnS leqn0.
  rewrite leq_eqVlt=> /orP[/eqP->|].
  - by rewrite subnn eq_refl /=.
  rewrite ?subn_eq0 eq_sym.
  move=> /[dup]; rewrite {1}ltnNge=> /negPf->.
  move=> /[dup]; rewrite {1}ltn_neqAle=> /andP[/negPf-> _].
  by move=> ?; rewrite -subnDA addn1 subnKC.
Qed.

Lemma find_take p s n :
  has p (take n s) -> find p (take n s) = find p s.
Proof. by rewrite -[in find p s](@cat_take_drop n _ s) find_cat=> ->. Qed.

Lemma sorted_rcons x r s y :
  sorted r (rcons s y) = sorted r s && (nilp s || r (last x s) y).
Proof. case s=> [|??] //=; exact/rcons_path. Qed.

Lemma sorted_subn (s : seq nat) n :
  sorted ltn s -> all (fun m => n <= m) s -> sorted ltn (map (subn^~ n) s).
Proof.
  elim s=> [|i {}s IH] //=.
  rewrite !path_sortedE; try by exact/ltn_trans.
  move=> /andP[Hi Hs] /andP[Hn Hleq].
  apply/andP; split=> //; last by apply/IH.
  apply/allP=> j /mapP[k + ->] /=.
  move: Hi=> /allP /[apply] /= Hk.
  apply/ltn_sub2r=> //.
  by apply/(leq_ltn_trans Hn).
Qed.

Lemma sorted_ltn_nth (s : seq nat) i j :
  sorted ltn s -> i < j < size s -> nth 0 s i < nth 0 s j.
Proof.
  move=> Hs /andP[Hij Hsz].
  suff: (nth 0 s i < nth 0 s j)%O by done.
  rewrite lt_sorted_ltn_nth=> //=.
  exact/(ltn_trans Hij).
Qed.

Lemma sorted_nth_drop_lt (s : seq nat) i j :
  sorted ltn s -> i.+1 < size s -> j \in drop i.+1 s -> nth 0 s i < j.
Proof.
  move=> Hs Hi Hj; apply/leq_trans.
  - by apply/(@sorted_ltn_nth s i i.+1)=> //; apply/andP.
  have: exists k, (nth 0 s k = j) /\ (i.+1 <= k < size s).
  - move: Hj=> /(nthP 0) [k].
    rewrite size_drop nth_drop=> ??.
    exists (i.+1 + k); split=> //.
    apply/andP; split=> //; first lia.
    by rewrite -ltn_subRL.
  move=> [k [<- /andP[]]].
  rewrite leq_eqVlt=> /orP[/eqP ->|??] //.
  by apply/ltnW/sorted_ltn_nth=> //; apply/andP.
Qed.

End SeqUtils.

Arguments sorted_rcons {T} x.

Section SeqEqUtils.
Context {T : eqType}.
Implicit Types (p : pred T) (r : rel T) (s : seq T) (n : nat).

Lemma eq_mem0 s1 s2 :
  s1 =i s2 -> (s1 == [::]) = (s2 == [::]).
Proof.
  case: s1; case s2=> //= x s eqm; rewrite eqxx; apply/idP/idP.
  - by rewrite /= -(in_nil x) eqm inE eqxx.
  by move: (eqm x); rewrite !inE in_nil eqxx /=.
Qed.

Lemma subseq_anti :
  antisymmetric (@subseq T).
Proof.
  move=> s1 s2 /andP[].
  move=> /size_subseq_leqif /leqifP.
  case: ifP=> [/eqP->|_] //.
  move=> /[swap] /size_subseq.
  by rewrite leqNgt=> /negP.
Qed.

Lemma index_inj s :
  {in s &, injective (index^~ s)}.
Proof.
  move=> x y; elim s=> [|z {}s] IH //=.
  case: ifP=> [/eqP->|]; case: ifP=> [/eqP->|] => //.
  rewrite !inE [z == y]eq_sym [z == x]eq_sym => -> -> /=.
  move=> ?? []; exact/IH.
Qed.

Lemma mkseq_in_uniq (f : nat -> T) n :
  { in iota 0 n &, injective f } -> uniq (mkseq f n).
Proof. by move/map_inj_in_uniq ->; apply: iota_uniq. Qed.

End SeqEqUtils.

Section Slice.
Context {T : eqType}.
Implicit Types (s : seq T) (n m : nat).

Definition slice n m s :=
  take (m - n) (drop n s).

Lemma size_slice n m s :
  (m <= size s)%N -> size (slice n m s) = m - n.
Proof.
  move=> sz.
  rewrite /slice size_takel //.
  rewrite size_drop; lia.
Qed.

Lemma index_drop s x n :
  (n <= index x s)%N -> index x (drop n s) = index x s - n.
Proof.
  move: s; elim n=> [|{}n IH] s nLe.
  - rewrite drop0 subn0 //=.
  rewrite -addn1 -drop_drop.
  move: nLe; case: s=> [|y {}s] //=.
  case: ifP => // _.
  rewrite drop0 ltnS addn1 subSS=> nLe.
  by rewrite IH.
Qed.

Lemma index_drop_uniq s x n :
  uniq s -> (index x s < n <= size s)%N -> index x (drop n s) = size s - n.
Proof.
  move=> uq /andP[] ixLe nLe.
  rewrite memNindex ?size_drop //.
  case: (x \in s)/idP; last first.
  - move=> /negP; exact/contra/mem_drop.
  move: uq; rewrite -{1 2}[s](cat_take_drop n)=> uq xIn.
  by rewrite -(uniq_catLR uq) // in_take_leq.
Qed.

Lemma in_slice_index n m s x :
  (n <= m <= size s)%N -> uniq s -> x \in (slice n m s) = (n <= index x s < m)%N.
Proof.
  rewrite /slice=> sz.
  rewrite in_take_leq; last first.
  - rewrite size_drop; lia.
  move=> uq; case: (n <= index x s)%N/idP.
  - move=> nLe; rewrite index_drop //; lia.
  move=> /negP; rewrite -ltnNge=> ixLe.
  rewrite index_drop_uniq //; lia.
Qed.

End Slice.

Section FindNth.

Context {T : Type}.
Implicit Types (p : pred T) (s : seq T) (n : nat).

(* TODO: rename to avoid collision with find_nth_spec from mathcomp? *)
Fixpoint find_nth p s n :=
  match n with
  | 0    => find p s
  | n.+1 =>
    let i := find_nth p s n in
    (i.+1 + find p (drop i.+1 s))%N
  end.

Variant split_count_find_nth_spec p :
  seq T -> nat -> nat -> seq T -> seq T -> T -> Type :=
    FindNth x n i s1 s2 of p x & (size s1 = i) & (count p s1 = n) :
      split_count_find_nth_spec p (rcons s1 x ++ s2) n i s1 s2 x.

Lemma split_count_find_nth x0 p s n : n < count p s ->
  let i := find_nth p s n in
  split_count_find_nth_spec p s n i (take i s) (drop i.+1 s) (nth x0 s i).
Proof.
  move: s; elim n=> [|{}n IH] s H /=.
  - case: (split_find_nth x0); first by rewrite has_count.
    move=> x s1 s2 Hp Hh; constructor=> //.
    - rewrite -cats1 !find_cat has_cat /= Hp orbT addn0 /=.
      by move: Hh; case: ifP=> //.
    by move: Hh; rewrite has_count -leqNgt leqn0=> /eqP.
  move: H=> /[dup] H; case: (IH s); first by apply/ltnW.
  move: H=> _ x m i s1 s2; clear s.
  pose s := rcons s1 x ++ s2.
  have Hs: s = rcons s1 x ++ s2 by done.
  move=> Hp Hsz Hcs1 Hc; rewrite -Hs.
  have Hs1 : s1 = take i s.
  - rewrite Hs -cats1 !take_cat size_cat Hsz /=.
    by rewrite ltnn addn1 leqnn subnn take0 cats0.
  have Hs1' : rcons s1 x = take i.+1 s.
  - by rewrite Hs take_cat size_rcons Hsz ltnn subnn take0 cats0.
  have Hs2 : s2 = drop i.+1 s.
  - by rewrite Hs drop_cat size_rcons Hsz ltnn subnn drop0.
  have Hcs2 : 0 < count p s2.
  - move: Hc; rewrite -cats1 !count_cat /= addn0 Hcs1 Hp.
    by rewrite addn1 -{1}[m.+1]addn0 ltn_add2l.
  have Hszf : i.+1 + find p s2 < size s.
  - move: Hcs2; rewrite -has_count has_find.
    by rewrite Hs size_cat size_rcons Hsz ltn_add2l=> ->.
  rewrite -[s in split_count_find_nth_spec p s m.+1]
           (cat_take_drop (i.+1 + find p s2) s).
  rewrite (drop_nth x0 _)=> //.
  rewrite -cat_rcons. constructor=> //.
  - by rewrite -nth_drop Hs2 nth_find // has_count -Hs2 //.
  - by rewrite size_take Hszf.
  rewrite takeD take_drop addnC takeD drop_cat size_takel; last first.
  - rewrite Hs size_cat size_rcons Hsz; lia.
  rewrite ltnn subnn drop0 count_cat -Hs1' Hs2.
  by rewrite -cats1 count_cat Hcs1 count_take_find /= Hp !addn0 addn1.
Qed.

Lemma count_Nfind_nth (x0 : T) p s n :
  (count p s <= n) -> (find_nth p s n >= size s).
Proof.
  move: s; elim n=> [|{}n IH] s /=.
  - rewrite leqn0=> /eqP H; rewrite hasNfind=> //.
    by rewrite has_count -leqNgt H.
  rewrite leq_eqVlt=> /orP[/eqP H|].
  - move: H=> /[dup] H; case: (split_count_find_nth x0).
    + by rewrite H.
    move=> x m i s1 s2 Hp Hsz Hc Hc'.
    rewrite size_cat size_rcons Hsz.
    rewrite leq_add2l leqNgt -has_find has_count -leqNgt.
    move: Hc'; rewrite count_cat -cats1 count_cat /= Hp /= Hc; lia.
  by move=> /ltnSE H; apply/(leq_trans (IH s H)); lia.
Qed.

Lemma count_find_nth (x0 : T) p s n :
  (n < count p s) = (find_nth p s n < size s).
Proof.
  symmetry; case H: (n < count p s).
  - case: (split_count_find_nth x0 H).
    move=> x m i s1 s2 ? <- ?.
    rewrite size_cat size_rcons; lia.
  apply/negP/negP; rewrite -leqNgt; apply/(count_Nfind_nth x0).
  by move: H=> /negP/negP; rewrite -leqNgt.
Qed.

Lemma find_nth_ltn p s n m :
  n < m -> find_nth p s n < find_nth p s m.
Proof.
  elim: m=> [|{}m IH] // /ltnSE.
  rewrite leq_eqVlt=> /orP[/eqP->|/IH] /=.
  - exact/leq_addr.
  move=> H; apply/(ltn_trans H); exact/leq_addr.
Qed.

Lemma find_nth_leq p s n m :
  n <= m -> find_nth p s n <= find_nth p s m.
Proof.
  rewrite leq_eqVlt=> /orP[/eqP->|] //.
  by move=> ?; apply/ltnW/find_nth_ltn.
Qed.

Lemma find_nth_inj p s :
  injective (find_nth p s).
Proof.
  move=> i j; move: (ltn_total i j).
  by move=> /orP[/eqP|/orP[]] // /(find_nth_ltn p s); lia.
Qed.

Lemma find_nth_consT p x xs n :
  p x -> find_nth p (x::xs) n = if n is n'.+1 then 1 + find_nth p xs n' else 0.
Proof.
  elim n=> [|{}n IH] //=.
  - case: ifP=> ? //=.
  move=> ?; rewrite IH //=.
  case n=> [|{}n'] //=.
  by rewrite drop0.
Qed.

Lemma find_nth_consF p x xs n :
  ~~ p x -> find_nth p (x::xs) n = 1 + find_nth p xs n.
Proof.
  elim n=> [|{}n IH] //=.
  - case: ifP=> ? //=.
  by move=> ?; rewrite IH.
Qed.

End FindNth.

Section MaskUtils.

Context {T : Type}.
Implicit Types (s : seq T) (m : bitseq) (n : nat).

Lemma mask_size_find_nth s n m :
   size m = size s -> n < size (mask m s) -> find_nth id m n < size m.
Proof. by move=> /size_mask ->; rewrite (count_find_nth false). Qed.

Lemma mask_size_Nfind_nth s n m :
   size m = size s -> size (mask m s) <= n -> size m <= find_nth id m n.
Proof. by move=> /size_mask ->; exact/(count_Nfind_nth false). Qed.

Lemma nth_mask (x : T) s m n :
  size m = size s -> nth x (mask m s) n = nth x s (find_nth id m n).
Proof.
  move=> Hsz; case: (n < size (mask m s))/idP; last first.
  - move=> /negP; rewrite -leqNgt.
    move=> /[dup] ? /(mask_size_Nfind_nth Hsz) ?.
    by rewrite !nth_default -?Hsz.
  move=> /[dup] Hn /(mask_size_find_nth Hsz) Hi.
  move: n m Hsz Hn Hi; elim s=> [|y ys IH] n m /=.
  - by rewrite mask0 /=.
  case m=> [|b bs] //; rewrite mask_cons /=.
  move=> [] Hsz; rewrite -cat1s !nth_cat.
  case H: b=> /=; last first.
  - rewrite subn0 !find_nth_consF //.
    move=> /[dup] Hn /(mask_size_find_nth Hsz) Hi ?.
    by rewrite IH.
  case: ifP.
  - by rewrite ltnS leqn0=> /eqP -> /=.
  move=> /negP/negP; rewrite -leqNgt.
  case n=> [|{}n'] //.
  rewrite find_nth_consT //.
  rewrite add1n !ltnS subn1 -pred_Sn=> _ Hn Hi /=.
  by apply/IH.
Qed.

End MaskUtils.

Section MkMask.
Context {T : Type}.
Implicit Types (s : seq nat) (m : bitseq) (n : nat).

Definition mkmask s n : bitseq :=
  (fix mkmask (s : seq nat) m := match s with
    | [::]    => m
    | i :: s' => set_nth false (mkmask s' m) i true
  end) s (nseq n false).

Lemma mkmask_cons i s n :
  mkmask (i::s) n = set_nth false (mkmask s n) i true.
Proof. by case s. Qed.

Lemma size_mkmask s n :
  (all (fun i => i < n) s) -> size (mkmask s n) = n.
Proof.
  elim s=> [|i {}s IH] //.
  - by rewrite size_nseq.
  rewrite mkmask_cons size_set_nth /=.
  move=> /andP[Hi Ha]; rewrite IH //=.
  exact/maxn_idPr.
Qed.

Lemma nth_mkmask s n i :
  nth false (mkmask s n) i = (i \in s).
Proof.
  move: n; elim s=> [|j {}s IH] n.
  - by rewrite /mkmask /= nth_nseq inE; case: ifP.
  rewrite mkmask_cons nth_set_nth in_cons /=.
  by case: ifP=> //.
Qed.

Lemma count_mkmask s n :
   uniq s -> count id (mkmask s n) = size s.
Proof.
  move: n; elim s=> [|i {}s IH] n.
  - by rewrite count_nseq.
  rewrite mkmask_cons /= => /andP[Hi Hu].
  rewrite count_set_nth ?IH //.
  rewrite nth_mkmask; apply/(nthP 0).
  move=> [j] Hj; move: Hi=> /[swap] <-.
  by rewrite mem_nth.
Qed.

End MkMask.

(* The following lemmas rely on a similar set of assumptions about a sequence s.
 * Putting all of these assumptions in front of each lemma makes it harder
 * to read the code and grasp the idea.
 * However, because of some technical problems of the section mechanism
 * we cannot declare all these assumptions in a single section.
 * It looks like in the case of a single section
 * the lemmas' arguments (hypothesis) cannot be generalized and
 * we cannot apply previous lemmas in subsequent lemmas.
 * Thus we pick a middle ground: we put each lemma in a separate section.
 * Then we can declare all the assumptions as Hypothesis.
 * It improves readability and preserves the lemma statments generalized enough.
 *)

Section SortedSizeSubn.
Context {T : Type}.
Variables (s : seq nat) (n i : nat).
Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s).
Hypothesis (Hsz : i < size s <= n).

Lemma sorted_size_subn :
  size s - i <= n - (nth 0 s i).
Proof.
  (* move: s i Hs Ha Hsz; clear s i Hs Ha Hsz. *)
  move: Hsz=> /andP[Hi Hn].
  pose f := fun i => size s - i.
  pose g := fun i => size s - i.
  pose p := fun i => i < size s.
  have K: {in p, cancel f g}.
  - move=> j; subst f g p=> /= ?.
    rewrite subKn //; exact/ltnW.
  rewrite -[i in nth 0 s i]K //.
  have ->: size s - i = f i by done.
  have: 0 < f i by rewrite subn_gt0.
  have: f i <= size s by exact/leq_subr.
  elim (f i)=> [|k]; subst g=> //=.
  move=> IH Hks.
  case: (0 < k)/idP; last first.
  - move=> /negP; rewrite -leqNgt leqn0=> /eqP-> _.
    rewrite subn1 nth_last ltn_subCr subn0.
    move: (mem_last 0 s); rewrite in_cons.
    move=> /orP[/eqP->|] //; first lia.
    by move: Ha=> /allP /[apply].
  move=> Hk _; move: (IH (ltnW Hks) Hk)=> Hkn.
  apply/(leq_ltn_trans Hkn).
  have Hnth: nth 0 s (size s - k.+1) < nth 0 s (size s - k).
  - apply/sorted_ltn_nth=> //.
    apply/andP; split=> //.
    apply/ltn_sub2l=> //.
    lia.
  apply/(ltn_sub2l _ Hnth)/(ltn_trans Hnth).
  by rewrite -subn_gt0; apply/(leq_trans Hk).
Qed.

End SortedSizeSubn.

Section DropMkMaskLt.
Context {T : Type}.
Variables (s : seq nat) (n j : nat).
Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s) (Hj : all (ltn j) s).
Hypothesis (Hsz : size s <= n).

Lemma drop_mkmask_lt :
  drop j.+1 (mkmask s n) = mkmask [seq k - j.+1 | k <- s] (n - j.+1).
Proof.
  move: s Hs Ha Hj Hsz; clear s Hs Ha Hj Hsz.
  elim=> [|i {}s IH].
  - by move=> /= ?? Hn ?; rewrite drop_nseq.
  rewrite map_cons !mkmask_cons /=.
  rewrite path_sortedE; last exact/ltn_trans.
  move=> /andP[Ha Hs] /andP[Hi Hlt] /andP[Hj Hjs] Hn.
  rewrite !set_nthE ?drop_cat /=; last first.
  - rewrite size_mkmask //; exact/ltnW.
  - rewrite size_mkmask //.
    + apply/ltn_sub2r=> //.
      by apply/(leq_ltn_trans Hj).
    rewrite all_map /preim; apply/allP.
    move=> k Hk /=; rewrite ltn_sub2r //.
    + by apply/(leq_ltn_trans Hj).
    by move: Hlt Hk=> /allP /[apply].
  rewrite size_rcons size_takel ?ltnS ?Hj; last first.
  - rewrite size_mkmask //; exact/ltnW.
  rewrite -IH //; last first.
  - exact/ltnW.
  rewrite drop_drop -subSn //.
  rewrite take_drop !subnK //; last exact/ltnW.
  rewrite drop_rcons //.
  rewrite size_takel ?size_mkmask //.
  by apply/ltnW.
Qed.

End DropMkMaskLt.

Section DropMkMask.
Context {T : Type}.
Variables (s : seq nat) (n i : nat).
Let j : nat := nth 0 s i.
Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s).
Hypothesis (Hsz : i < size s <= n).

Lemma drop_mkmask :
  drop j.+1 (mkmask s n) = mkmask [seq k - j.+1 | k <- drop i.+1 s] (n - j.+1).
Proof.
  subst j; move: s i Hs Ha Hsz; clear s i Hs Ha Hsz.
  elim=> [|j {}s IH] i //.
  rewrite mkmask_cons /=.
  rewrite path_sortedE; last exact/ltn_trans.
  move=> /andP[Hjs Hs] /andP[Hj Ha].
  rewrite set_nthE ?drop_cat ?size_rcons ?size_takel ?size_mkmask //;
    last exact/ltnW.
  move=> /andP[Hi Hn].
  have: j <= nth 0 (j :: s) i.
  - move: Hi; case i=> [|{}k] //=.
    rewrite ltnS=> /(mem_nth 0) Hi.
    move: Hjs=> /allP=> H; move: (H (nth 0 s k) Hi)=> //; exact/ltnW.
  case: ifP=> [|_]; first lia.
  move: Hi; case i=> [|{}k] /=.
  - move=> Hsz _; rewrite subnn !drop0.
    apply/drop_mkmask_lt=> //; last exact/ltnW.
  rewrite ltnS=> Hi Hjn.
  rewrite drop_drop subnK ?ltnS ?IH //.
  apply/andP; split=> //; exact/ltnW.
Qed.

End DropMkMask.

Section FindMkMask.
Context {T : Type}.
Variables (s : seq nat) (n : nat).
Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s).
Hypothesis (Hsz : 0 < size s <= n).

Lemma find_mkmask :
  find id (mkmask s n) = nth 0 s 0.
Proof.
  move: s Hs Ha Hsz; clear s Hs Ha Hsz.
  elim=> [|i {}s IH] Hl //.
  rewrite mkmask_cons /=.
  move=> /andP[Hi Ha] Hs.
  rewrite set_nthE; last first.
  - by rewrite size_mkmask.
  rewrite -?cats1 !find_cat has_cat /= orbT.
  case: (size s == 0)/eqP.
  - move=> /size0nil -> /=.
    rewrite take_nseq; last by exact/ltnW.
    by rewrite has_nseq andbF size_nseq addn0.
  move=> /eqP; rewrite eqn0Ngt=> /negbNE Hs0.
  case: ifP=> [|_]; last first.
  - by rewrite size_take size_mkmask ?Hi ?addn0.
  move: Hl=> /=; rewrite lt_path_sortedE=> /andP[Hil Hl].
  move=> H; exfalso; move: H.
  move=> /[dup] /find_take; rewrite has_find=> ->.
  rewrite size_take size_mkmask ?Hi ?addn0 //.
  rewrite {}IH //; last first.
  - apply/andP; split=> //; exact/ltnW.
  move: Ha Hs Hs0 Hil Hl; case: s=> [|j {}s'] //.
  move=> /= ??? /andP[] + ??.
  rewrite /Order.lt /=; lia.
Qed.

End FindMkMask.

Section FindNthMkMask.
Context {T : Type}.
Variables (s : seq nat) (n i : nat).
Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s).
Hypothesis (Hsz : i < size s <= n).

Lemma find_nth_mkmask :
  find_nth id (mkmask s n) i = nth 0 s i.
Proof.
  move: i s Hs Ha Hsz; clear s i Hs Ha Hsz.
  elim=> [|{}i IH] s /=.
  - by apply/find_mkmask.
  move=> Hl Ha /andP[Hi Hs].
  rewrite IH=> //; last first.
  - apply/andP; split=> //; exact/ltnW.
  rewrite drop_mkmask ?find_mkmask //; last first.
  - apply/andP; split=> //; exact/ltnW.
  - rewrite size_map size_drop; apply/andP; split.
    + by rewrite subn_gt0.
    rewrite !subnS -subn1 -subn1 leq_sub2r //.
    apply/sorted_size_subn=> //.
    apply/andP; split=> //; exact/ltnW.
  - rewrite all_map; apply/allP=> j Hj /=.
    rewrite -subSn; last first.
    + apply/sorted_nth_drop_lt=> //.
    by apply/leq_sub2r/(allP Ha)/mem_drop/Hj.
  - apply/sorted_subn=> //.
    + by apply/drop_sorted.
    apply/allP=> j Hj.
    by apply/sorted_nth_drop_lt.
  rewrite (nth_map 0) ?nth_drop ?addn0; last first.
  - by rewrite size_drop subn_gt0.
  rewrite subnKC //.
  suff: (nth 0 s i < nth 0 s i.+1)%O by done.
  apply/nth_count_lt; last by rewrite count_lt_nth.
  by move: Hl; rewrite lt_sorted_uniq_le=> /andP[].
Qed.

End FindNthMkMask.

Section MkMaskMask.
Context {T : Type} {n m : nat}.
Variables (t : n.-tuple T) (u : m.-tuple T) (f : 'I_n -> 'I_m).
Let s := mkseq (sub_lift (addn m) f) n.

Hypothesis (Hhm  : {homo f : x y / x < y}).
Hypothesis (Hinj : injective f).
Hypothesis (Hnm  : forall i, f i < m).
Hypothesis (Hnth : forall i, tnth t i = tnth u (f i)).

Lemma mkmask_mask :
  mask (mkmask s m) u = t.
Proof.
  (* move=> Hfh Hf Hm Hn. *)
  have Ha: all (fun i : nat => i < m) s.
  - apply/allP=> i /(nthP 0) [j].
    rewrite size_mkseq=> Hj <-.
    by rewrite nth_mkseq // sub_liftT.
  have Hsz: size (mask (mkmask s m) u) = size t.
  - rewrite size_mask ?size_mkmask ?count_mkmask ?size_tuple //.
    apply/mkseq_uniq/sub_lift_inj.
    + by move=> {}x {}y; move: (valP (f y))=> /[swap] /= <-; lia.
    + by move=> ??; apply/addnI.
    by move=> ???; apply/Hinj/val_inj.
  have Hsz': size (mask (mkmask s m) u) = n.
  - by rewrite Hsz size_tuple.
  apply/(@eq_from_tuple _ _ _ Hsz).
  rewrite tvalK; apply/eq_from_tnth.
  move=> i; rewrite tcastE /tnth /=.
  have Hi: i < n by move: i=> []; rewrite size_tuple.
  rewrite nth_mask ?find_nth_mkmask=> //; last first.
  - by rewrite size_mkmask ?size_tuple //.
  - rewrite size_mkseq; apply/andP; split=> //.
    move: Hinj Hi=> /leq_card /=.
    by rewrite !card_ord.
  - apply/homo_sorted; last by exact/iota_ltn_sorted.
    apply/sub_lift_homo=> //=; [lia| ..]; last first.
    + by move=> ?? /=; rewrite ltn_add2l.
    move=> {}x {}y /= /negP; rewrite -leqNgt=> Hyn.
    rewrite -[val (f x)]addn0 -addnS; apply/leq_add.
    - by apply/ltnW; move: (valP (f x)).
   apply/(leq_trans _ Hyn); lia.
  rewrite -tnth_nth tcastE esymK Hnth.
  have ->: cast_ord (size_tuple t) i = Ordinal Hi by exact/val_inj.
  by subst s; rewrite nth_mkseq // sub_liftT // -tnth_nth.
Qed.

End MkMaskMask.


From Hammer Require Import Hammer.

Require Import Coq.Strings.String.
From VFA Require Import Perm.
From VFA Require Import Priqueue.

Module BinomQueue <: PRIQUEUE.

Definition key := nat.

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

Definition priqueue := list tree.

Definition empty : priqueue := nil.

Definition smash (t u:  tree) : tree :=
match t , u with
|  Node x t1 Leaf, Node y u1 Leaf =>
if  x >? y then Node x (Node y u1 t1) Leaf
else Node y (Node x t1 u1) Leaf
| _ , _ => Leaf
end.

Fixpoint carry (q: list tree) (t: tree) : list tree :=
match q, t with
| nil, Leaf        => nil
| nil, _            => t :: nil
| Leaf :: q', _  => t :: q'
| u :: q', Leaf  => u :: q'
| u :: q', _       => Leaf :: carry q' (smash t u)
end.

Definition insert (x: key) (q: priqueue) : priqueue :=
carry q (Node x Leaf Leaf).

Eval compute in fold_left (fun x q =>insert q x) [3;1;4;1;5;9;2;3;5] empty.

Fixpoint join (p q: priqueue) (c: tree) : priqueue :=
match p, q, c with
[], _ , _            => carry q c
| _, [], _             => carry p c
| Leaf::p', Leaf::q', _              => c :: join p' q' Leaf
| Leaf::p', q1::q', Leaf            => q1 :: join p' q' Leaf
| Leaf::p', q1::q', Node _ _ _  => Leaf :: join p' q' (smash c q1)
| p1::p', Leaf::q', Leaf            => p1 :: join p' q' Leaf
| p1::p', Leaf::q',Node _ _ _   => Leaf :: join p' q' (smash c p1)
| p1::p', q1::q', _                   => c :: join p' q' (smash p1 q1)
end.

Fixpoint unzip (t: tree) (cont: priqueue -> priqueue) : priqueue :=
match t with
|  Node x t1 t2   => unzip t2 (fun q => Node x t1 Leaf  :: cont q)
| Leaf => cont nil
end.

Definition heap_delete_max (t: tree) : priqueue :=
match t with
Node x t1 Leaf  => unzip t1 (fun u => u)
| _ => nil
end.

Fixpoint find_max' (current: key) (q: priqueue) : key :=
match q with
|  []         => current
| Leaf::q' => find_max' current q'
| Node x _ _ :: q' => find_max' (if x >? current then x else current) q'
end.

Fixpoint find_max (q: priqueue) : option key :=
match q with
| [] => None
| Leaf::q' => find_max q'
| Node x _ _ :: q' => Some (find_max' x q')
end.

Fixpoint delete_max_aux (m: key) (p: priqueue) : priqueue * priqueue :=
match p with
| Leaf :: p'   => let (j,k) := delete_max_aux m p'  in (Leaf::j, k)
| Node x t1 Leaf :: p' =>
if m >? x
then (let (j,k) := delete_max_aux m p'
in (Node x t1 Leaf::j,k))
else (Leaf::p', heap_delete_max (Node x t1 Leaf))
| _ => (nil, nil)
end.

Definition delete_max (q: priqueue) : option (key * priqueue) :=
match find_max q with
| None => None
| Some  m => let (p',q') := delete_max_aux m q
in Some (m, join p' q' Leaf)
end.

Definition merge (p q: priqueue) := join p q Leaf.

Fixpoint pow2heap' (n: nat) (m: key) (t: tree) :=
match n, m, t with
0, m, Leaf       => True
| 0, m, Node _ _ _  => False
| S _, m,Leaf    => False
| S n', m, Node k l r  =>
m >= k /\ pow2heap' n' k l /\ pow2heap' n' m r
end.

Definition pow2heap (n: nat) (t: tree) :=
match t with
Node m t1 Leaf => pow2heap' n m t1
| _ => False
end.

Fixpoint priq'  (i: nat) (l: list tree) : Prop :=
match l with
| t :: l' => (t=Leaf \/ pow2heap i t) /\ priq' (S i) l'
| nil => True
end.

Definition priq (q: priqueue) : Prop := priq' 0 q.

Theorem empty_priq: priq empty.
Admitted.

Theorem smash_valid:
forall n t u, pow2heap n t -> pow2heap n u -> pow2heap (S n) (smash t u).
Admitted.

Theorem carry_valid:
forall n q,  priq' n q ->
forall t, (t=Leaf \/ pow2heap n t) -> priq' n (carry q t).
Admitted.

Theorem insert_priq: forall x q, priq q -> priq (insert x q).
Admitted.

Theorem join_valid: forall p q c n, priq' n p -> priq' n q -> (c=Leaf \/ pow2heap n c) -> priq' n (join p q c).
Admitted.

Theorem merge_priq:  forall p q, priq p -> priq q -> priq (merge p q).
Proof. hammer_hook "Binom" "Binom.BinomQueue.merge_priq".
intros. unfold merge. apply join_valid; auto.
Qed.

Theorem delete_max_Some_priq:
forall p q k, priq p -> delete_max p = Some(k,q) -> priq q.
Admitted.

Inductive tree_elems: tree -> list key -> Prop :=
| tree_elems_leaf: tree_elems Leaf nil
| tree_elems_node:  forall bl br v tl tr b,
tree_elems tl bl ->
tree_elems tr br ->
Permutation b (v::bl++br) ->
tree_elems (Node v tl tr) b.

Inductive priqueue_elems: list tree -> list key -> Prop :=

.

Definition manual_grade_for_priqueue_elems : option (prod nat string) := None.

Definition Abs (p: priqueue) (al: list key) := priqueue_elems p al.

Theorem tree_elems_ext: forall t e1 e2,
Permutation e1 e2 -> tree_elems t e1 -> tree_elems t e2.
Admitted.

Theorem tree_perm: forall t e1 e2,
tree_elems t e1 -> tree_elems t e2 -> Permutation e1 e2.
Admitted.

Theorem priqueue_elems_ext: forall q e1 e2,
Permutation e1 e2 -> priqueue_elems q e1 -> priqueue_elems q e2.
Admitted.

Theorem abs_perm: forall p al bl,
priq p -> Abs p al -> Abs p bl -> Permutation al bl.
Proof. hammer_hook "Binom" "Binom.BinomQueue.abs_perm".
Admitted.

Lemma tree_can_relate: forall t, exists al, tree_elems t al.
Proof. hammer_hook "Binom" "Binom.BinomQueue.tree_can_relate".
Admitted.

Theorem can_relate:  forall p, priq p -> exists al, Abs p al.
Proof. hammer_hook "Binom" "Binom.BinomQueue.can_relate".
Admitted.

Theorem empty_relate:  Abs empty nil.
Proof. hammer_hook "Binom" "Binom.BinomQueue.empty_relate".
Admitted.

Theorem smash_elems: forall n t u bt bu,
pow2heap n t -> pow2heap n u ->
tree_elems t bt -> tree_elems u bu ->
tree_elems (smash t u) (bt ++ bu).
Admitted.

Theorem carry_elems:
forall n q,  priq' n q ->
forall t, (t=Leaf \/ pow2heap n t) ->
forall eq et, priqueue_elems q eq ->
tree_elems t et ->
priqueue_elems (carry q t) (eq++et).
Admitted.

Theorem insert_relate:
forall p al k, priq p -> Abs p al -> Abs (insert k p) (k::al).
Admitted.

Theorem join_elems:
forall p q c n,
priq' n p ->
priq' n q ->
(c=Leaf \/ pow2heap n c) ->
forall pe qe ce,
priqueue_elems p pe ->
priqueue_elems q qe ->
tree_elems c ce ->
priqueue_elems (join p q c) (ce++pe++qe).
Admitted.

Theorem merge_relate:
forall p q pl ql al,
priq p -> priq q ->
Abs p pl -> Abs q ql -> Abs (merge p q) al ->
Permutation al (pl++ql).
Proof. hammer_hook "Binom" "Binom.BinomQueue.merge_relate".
Admitted.

Theorem delete_max_None_relate:
forall p, priq p -> (Abs p nil <-> delete_max p = None).
Admitted.

Theorem delete_max_Some_relate:
forall (p q: priqueue) k (pl ql: list key), priq p ->
Abs p pl ->
delete_max p = Some (k,q) ->
Abs q ql ->
Permutation pl (k::ql) /\ Forall (ge k) ql.
Admitted.

End BinomQueue.


Require Import Coq.omega.Omega.
Require Import Coq.Arith.Arith.
Require Import Imp Maps.

Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        st & { l --> (aeval st a1)}
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st (* bogus *)
  end.

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => { --> 0 }
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          st & { l --> (aeval st a1) }
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.

 Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (st & { l --> (aeval st a1) })
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.

 Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (st & { l --> (aeval st a1)})
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None => None
  | Some st => Some (st X, st Y, st Z)
  end.
(* Compute
     (test_ceval { --> 0 }
         (X ::= 2;;
          IFB (X <= 1)
            THEN Y ::= 3
            ELSE Z ::= 4
          FI)).
   ====>
      Some (2, 0, 4)   *)