Require Import Arith.
Require Export Coq.Lists.List.
Require Import Coq.Logic.JMeq.
Require Import Coq.Classes.Morphisms.
Require Export Coq.Sorting.Permutation.

Import ListNotations. Open Scope list_scope.

Section Forall.

  Variable A : Type.
  Variable P : A -> Prop.

  Theorem map_isFunctorial : forall {A B C : Type} (l : list A) (f1 : B -> C) (f2 : A -> B), map f1 (map f2 l) = map (fun x => f1 (f2 x)) l.
  Proof.
    induction l; simpl; intros; auto.
    f_equal.
    auto.
  Qed.

  Theorem map_preservesIn : forall {A B : Type} (l : list A) (f : A -> B) (tb : B), In tb (map f l) -> exists ta, (In ta l) /\ (tb = f ta).
  Proof.
    induction l; simpl; intros; auto.
    - inversion H.
    - destruct H; subst; eauto.
      destruct (IHl f tb H).
      destruct H0.
      subst.
      exists x; eauto.
  Qed.

  Theorem Forall_append : forall (l1 l2 : list A),
    Forall P (l1 ++ l2) <-> Forall P l1 /\ Forall P l2.
  Proof.
    intros l1 l2; split; intro H.
    - split; apply Forall_forall; intros x H0;
        rewrite Forall_forall in H; apply H; apply in_or_app; [left | right]; auto.
    - destruct H as [H1 H2]; rewrite Forall_forall in H1; rewrite Forall_forall in H2;
        rewrite Forall_forall; intros x H0; rewrite in_app_iff in H0; destruct H0;
          [apply H1 | apply H2]; auto.
  Qed.

  Definition Forall_inv_car := Forall_inv.
  Theorem Forall_inv_cdr : forall (a : A) (l : list A), Forall P (a :: l) -> Forall P l.
  Proof.
    intros a l H; inversion H; auto.
  Qed.

End Forall.

Fixpoint list_insert {A : Type} (a : A) (n : nat) (l : list A) {struct l} : list A :=
    match n with
    | 0 => a :: l
    | S n' =>
      match l with
      | [] => []
      | x :: l' => x :: (list_insert a n' l')
      end
    end.

Theorem list_insert_nth : forall {A : Type} (a : A) (n : nat) (l : list A),
    nth n (list_insert a n l) a = a.
Proof.
  intros A a n l; generalize n; clear n.
  induction l; intro n; destruct n; simpl; auto.
Qed.

Theorem list_insert_nth_len : forall {A : Type} (x a : A) (n : nat) (l : list A),
    n <= length l -> nth n (list_insert a n l) x = a.
Proof.
  intros A x a n l H; generalize dependent n.
  induction l; intros n H; simpl in H; inversion H; simpl.
  - reflexivity.
  - apply IHl; reflexivity.
  - destruct n; simpl; [reflexivity | apply IHl; apply Le.le_Sn_le; auto].
Qed.

Theorem mth_list_insert_lt : forall {A : Type} (x a : A) (n m : nat) (l : list A),
    m < n -> nth m (list_insert a n l) x = nth m l x.
Proof.
  intros A x a n m l H.
  generalize dependent m; generalize dependent n; induction l; intros n m H; simpl in H.
  - destruct m; destruct n; simpl; auto; inversion H.
  - destruct n; [inversion H | destruct m; auto; simpl; apply Lt.lt_S_n in H; apply IHl; auto].
Qed.

Theorem mth_list_insert_gt : forall {A : Type} (x a : A) (l : list A) (n m : nat),
    n < m -> nth m (list_insert a n l) x = nth (m - 1) l x.
Proof.
  intros A x a l.
  induction l; intros n m H; simpl in H.
  - destruct m; destruct n; simpl; auto; inversion H; simpl; auto;
      rewrite PeanoNat.Nat.sub_0_r; [reflexivity | destruct m; simpl; reflexivity].
  - destruct n; simpl. repeat (destruct m; inversion H; simpl; auto).
    destruct m; inversion H; simpl.
    -- rewrite H1;
         assert (n = m - 1) by (rewrite <- H1; simpl; rewrite PeanoNat.Nat.sub_0_r; reflexivity);
         rewrite H0 at 2; apply IHl; apply Lt.lt_S_n; auto.
    -- rewrite PeanoNat.Nat.sub_0_r.
       destruct m; simpl. inversion H1.
       assert (m = S m - 1) by (simpl; symmetry; apply PeanoNat.Nat.sub_0_r).
       rewrite H2 at 2. apply IHl. apply Lt.lt_S_n; auto.
Qed.

Program Fixpoint ExceptNth {A : Type} (n : nat) (l : list A) : list A :=
  match l with
  | [] => []
  | (x :: xs) => match n with
                | 0 => xs
                | S n' => x :: ExceptNth n' xs
                end
  end.

Theorem rev_app_to_cons : forall {A : Type} {l : list A} {a : A},
    exists b l', rev l ++ [a] = b :: l'.
Proof.
  intros A l; induction l as [| c l]; intro a.
  - simpl; exists a; exists []; auto.
  - simpl; destruct (IHl c) as [x Hx]; destruct Hx as [l'' Hxl''];
      exists x; exists (l'' ++ [a]); rewrite Hxl''; simpl; auto.
Qed.

Theorem ReverseNil : forall {A : Type} {l : list A}, rev l = [] -> l = [].
Proof.
  intros A l Hl; destruct l;
  [ auto
  | simpl in Hl; exfalso; apply in_nil with (a := a);
    rewrite <- Hl; apply in_or_app; right; simpl; left; auto
  ].
Qed.

Lemma ReverseNilIff : forall {A : Type} {l : list A}, rev l = [] <-> l = [].
Proof.
  intros A l; split; intro H; [apply ReverseNil; auto | rewrite H; auto].
Qed.

Lemma ReverseNilIff' : forall {A : Type} {l : list A}, rev l <> [] <-> l <> [].
Proof.
  intros A l; split; intros H H'; apply H; apply ReverseNilIff; auto.
Qed.

Theorem RevApp : forall {A : Type} (l l' : list A),
    rev (l ++ l') = rev l' ++ rev l.
Proof.
  intros A l; induction l;
    [ intros l'; simpl; rewrite <- app_nil_end; reflexivity
    | intros l'; simpl; rewrite IHl; rewrite app_assoc; reflexivity
    ].
Qed.

Lemma RevConsIsApp : forall {A : Type} (l l' : list A) {a : A},
    rev l = a :: l' -> l = rev l' ++ [a].
Proof.
  intros A l; induction l.
  - intros l' a H; simpl in H; inversion H.
  - simpl; intros l' b H.
    destruct (rev l) as [| c l''] eqn:e.
    simpl in H; inversion H; simpl; rewrite @ReverseNil with (l := l); auto.
    inversion H; simpl in H; rewrite <- H2 in H; simpl; rewrite RevApp; simpl;
      assert (l = rev l'' ++ [b]) by (apply IHl; inversion H; auto).
    rewrite H0. auto.
Qed.

Lemma ForallRev : forall {A : Type} {P : A -> Prop} {l : list A},
    Forall P l -> Forall P (rev l).
Proof.
  intros A P l H.
  induction l; [simpl; apply Forall_nil|].
  pose proof (Forall_inv_car A P _ _ H).
  pose proof (Forall_inv_cdr A P _ _ H).
  simpl; apply Forall_append; split; auto.
Qed.

Lemma RemoveLastApp1 : forall {A : Type} (l : list A) (a : A),
    removelast (l ++ [a]) = l.
Proof.
  intros A l; induction l as [| b l']; intro a; simpl.
  auto.
  destruct (l' ++ [a]) eqn:e.
  - exfalso; apply in_nil with (a := a); rewrite <- e; apply in_or_app; right; simpl; left; auto.
  - rewrite <- e; rewrite IHl'; reflexivity.
Qed.

Lemma InRemoveLast : forall {A : Type} (l : list A) (a : A),
    In a (removelast l) -> In a l.
Proof.
  intros A l a H.
  induction l; [simpl in H; destruct H | idtac].
  simpl in H. destruct l. destruct H.
  simpl in H; destruct H. simpl; left; auto.
  simpl; right; fold In.  simpl in IHl. apply IHl; auto.
Qed.

Lemma App1NonEmpty : forall {A : Type} (l : list A) (a : A),
    l ++ [a] <> [].
Proof.
  intros A l a; intro H; apply in_nil with (a := a);
    rewrite <- H; apply in_or_app; right; simpl; auto.
Qed.

Definition InBool : forall {A : Type} (ADec : forall a b : A, {a = b} + {a <> b}), A -> list A -> bool :=
  fun A ADec a l =>
      match (@in_dec A ADec a l) with
      | left _ => true
      | right _ => false
      end.

Theorem InBoolSpec : forall {A : Type} {ADec : forall a b : A, {a = b} + {a <> b}}
                       {a : A} {l : list A},
    InBool ADec a l = true <-> In a l.
Proof.
  intros A ADec a l.
  unfold InBool; (destruct in_dec); split; intro H; auto.
  inversion H.
Qed.

Theorem InBoolSpec' : forall {A : Type} {ADec : forall a b : A, {a = b} + {a <> b}}
                        {a : A} {l : list A},
    InBool ADec a l = false <-> ~ In a l.
Proof.
  intros A ADec a l; split; intro H.
  intro Hcontra. rewrite <- @InBoolSpec with (ADec := ADec) in Hcontra.
  pose proof (eq_trans (eq_sym H) Hcontra); inversion H0.
  destruct (InBool ADec a l) eqn:e.
  exfalso; rewrite InBoolSpec in e; apply H; auto.
  auto.
Qed.

Theorem InBoolSubset : forall {A : Type} {ADec : forall a b : A, {a = b} + {a <> b}}
                         {a : A} {l1 l2 : list A},
    InBool ADec a l1 = true -> (forall b : A, In b l1 -> In b l2) -> InBool ADec a l2 = true.
Proof.
  intros A ADec a l1 l2 H H0.
  rewrite InBoolSpec. rewrite InBoolSpec in H.
  apply H0; auto.
Qed.

Definition InBoolCons : forall {A : Type} {ADec : forall a b : A, {a = b} + {a <> b}}
                       {a b : A} {l : list A},
    InBool ADec a (b :: l) = true -> {a = b} + {InBool ADec a l = true}.
Proof.
  intros A ADec a b l H.
  unfold InBool in H.
  destruct (ADec a b).
  left; auto.
  right.
  destruct (in_dec ADec a (b :: l)); [| inversion H].
  destruct i as [e | i0]; [exfalso; apply n; symmetry; apply e |].
  rewrite InBoolSpec; auto.
Defined.

Lemma InCons: forall {A:Type} {ADec : forall a b : A, {a = b} + {a <> b}} (l:A) m a , In a (l :: m) -> {a = l} + {In a m}.
Proof.
  intros A ADec l m a H.
  eapply InBoolSpec in H.
  eapply InBoolCons in H.
  destruct H; auto.
  right.
  eapply InBoolSpec; eauto.
  Unshelve.
  apply ADec.
Qed.

Program Definition EqNil {A : Type} (l : list A) : {l = []} + {l <> []} :=
  match l with
  | [] => left _
  | _ => right _
  end.

Ltac EqNilDestruct l :=
  let e := fresh "e" in
  let n := fresh "n" in
  match l with
  | [] => destruct (EqNil l) as [e | n];
         [clear e | exfalso; apply n; auto]
  | _ =>
    match goal with
    | [ H : l = [] |- _  ] =>
      destruct (EqNil l) as [e | n];
      [| exfalso; apply n; exact H]
    | [ H : [] = l |- _ ] =>
      destruct (EqNil l) as [e | n];
      [| exfalso; apply n; exact (eq_sym H)]
    | [ H : l <> [] |- _ ] =>
      destruct (EqNil l) as [e | n];
      [ exfalso; apply H; exact e |]
    | [ H : [] <> l |- _ ] =>
      destruct (EqNil l) as [e | n];
      [exfalso; apply H; exact (eq_sym e) |]
    | [ H : l = _ :: _ |- _ ] =>
      destruct (EqNil l) as [e | n];
      [rewrite e in H; inversion H |]
    | [ H : _ :: _ = l |- _ ] =>
      destruct (EqNil l) as [e | n];
      [rewrite e in H; inversion H |]
    | _ => destruct (EqNil l) as [e | n]
    end
  end.

Inductive Path {A : Set} : A -> list A -> Set :=
| Here : forall (a : A) (l : list A), Path a (a :: l)
| There : forall {a : A} (b : A) {l : list A}, Path a l -> Path a (b :: l).

Inductive MaybePath {A : Set} : A -> list A -> Set :=
| IsPath : forall {a : A} {l : list A}, Path a l -> MaybePath a l
| NoPath : forall {a : A} {l : list A}, (Path a l -> False) -> MaybePath a l.

Program Fixpoint FindPath {A : Set} {AEq : forall a b : A, {a = b} + {a <> b}} (a : A) (l : list A)
  : MaybePath a l :=
  match l with
  | [] => NoPath (fun p => _)
  | b :: l' => match (AEq a b) with
              | left e => eq_rec_r (fun a0 : A => MaybePath a0 (b :: l')) (IsPath (Here b l')) e
              | right n => let m := @FindPath A AEq a l' in
                          match m in (MaybePath y l0) return (y <> b -> MaybePath y (b :: l0)) with
                          | @IsPath _ a0 l0 p => _
                          | @NoPath _ a0 l0 f => _
                          end n
              end
  end.
Next Obligation.
  inversion p.
Defined.
Next Obligation.
  apply IsPath; apply There; auto.
Defined.
Next Obligation.
  apply NoPath. intro p. inversion p.
  - apply H; auto.
  - apply f; auto.
Defined.

Theorem InPathDoubleNeg : forall {A : Set} {AEq : forall a b : A, {a = b} + {a <> b}} (a : A) (l : list A),
    In a l -> (Path a l -> False) -> False.
Proof.
  intros A AEq a l H H0.
  induction l.
  inversion H.
  destruct H.
  rewrite H in H0; apply (H0 (Here a l)).
  apply IHl; auto.
  intro p. apply H0. apply There; auto.
Qed.

Program Definition InToPath {A :Set} (AEq : forall a b : A, {a = b} + {a <> b}) {a : A} {l : list A} :
  In a l -> Path a l :=
  fun H => match @FindPath A AEq a l with
        | IsPath pi => pi
        | NoPath npi => _
        end.
Next Obligation.
  apply JMeq_eq in Heq_l; clear Heq_anonymous; rewrite Heq_l in npi.
  exfalso; apply @InPathDoubleNeg with (a := a) (l := l); auto.
Defined.

Fixpoint PathToIndex {A : Set} {a : A} {l : list A} (pi : Path a l) {struct pi} : nat :=
  match pi with
  | Here _ _ => 0
  | There _ pi' => 1 + PathToIndex pi'
  end.

Lemma PathToIndex0_Here : forall {A : Set} {a b : A} {l : list A} (pth : Path a (b :: l)),
    PathToIndex pth = 0 -> a = b /\ JMeq pth (Here a l).
Proof.
  intros A a b l pth H.
  remember (b :: l). destruct pth eqn:e.
  inversion Heql0. split; auto.
  simpl in H. inversion H.
Qed.

Lemma PathToIndexS_There : forall {A : Set} {a : A} {l : list A} (pth : Path a l) (n : nat),
    PathToIndex pth = S n -> exists b l' (pth' : Path a l'), l = b :: l' /\ JMeq pth (@There A a b l' pth').
Proof.
  intros A a l pth n H.
  destruct pth eqn:e. inversion H.
  exists b; exists l; exists p; auto.
Qed.

Program Fixpoint nth_known_correct {A : Type} (n : nat) (l : list A) (n_corr : n < length l) : A :=
  match n with
  | O => match l with
        | [] => _
        | a :: _ => a
        end
  | S m => match l with
          | [] => _
          | _ :: l' => @nth_known_correct A m l' _
          end
  end.
Next Obligation.
  simpl in n_corr; exfalso; eapply PeanoNat.Nat.nlt_0_r; eauto.
Defined.
Next Obligation.
  simpl in n_corr; exfalso; eapply PeanoNat.Nat.nlt_0_r; eauto.
Defined.
Next Obligation.
  simpl in n_corr; apply Lt.lt_S_n; auto.
Defined.

Lemma nth_known_correct_pf_irr : forall {A : Type} (n : nat) (l : list A) (pf pf' : n < length l),
    @nth_known_correct A n l pf = @nth_known_correct A n l pf'.
Proof.
  intros A n l pf pf'.
  generalize dependent n.
  induction l; intros n pf pf'; [simpl in pf; exfalso; eapply PeanoNat.Nat.nlt_0_r; eauto|].
  destruct n; [simpl; reflexivity |].
  simpl. apply IHl.
Qed.

Lemma PathToIndexGivesValidIndex : forall {A : Set} {a : A} {l : list A} (pi : Path a l),
    PathToIndex pi < length l.
Proof.
  intros A a l pi; induction pi; [simpl; apply PeanoNat.Nat.lt_0_succ | simpl; apply Lt.lt_n_S; auto].
Qed.

Lemma ItemAtPathToIndex : forall {A : Set} {a : A} {l : list A} {pi : Path a l},
    @nth_known_correct A (PathToIndex pi) l (PathToIndexGivesValidIndex pi) = a.
Proof.
  intros A a l pi.
  induction pi; simpl; [auto | erewrite nth_known_correct_pf_irr; exact IHpi].
Qed.

Lemma ItemAtPathToIndex' :forall {A : Set} {a : A} {l : list A} {pi : Path a l}
                            (H : PathToIndex pi < length l),
    nth_known_correct (PathToIndex pi) l H = a.
Proof.
  intros A a l pi.
  induction pi; intro H; simpl; simpl in H; [auto| apply IHpi].
Qed.

Program Fixpoint IndexToPath {A : Set} (n : nat) (l : list A) (pf : n < length l) :
  Path (@nth_known_correct A n l pf) l :=
  match n with
  | 0 => match l with
        | [] => _
        | a :: l' => Here a l'
        end
  | S m => match l with
          | [] => _
          | a :: l' => @There _ _ a l' (@IndexToPath _ m l' _)
          end
  end.
Next Obligation.
  simpl in pf; exfalso; eapply PeanoNat.Nat.nlt_0_r; eauto.
Defined.
Next Obligation.
  simpl in pf; exfalso; eapply PeanoNat.Nat.nlt_0_r; eauto.
Defined.
Next Obligation.
  simpl in pf; apply Lt.lt_S_n; auto.
Defined.

Lemma IndexToPathToIndexId : forall {A : Set} (n : nat) (l : list A) (pf : n < length l),
    PathToIndex (@IndexToPath A n l pf) = n.
Proof.
  intros A n l pf.
  generalize dependent n; induction l; intros n pf;
    [simpl in pf; exfalso; eapply PeanoNat.Nat.nlt_0_r; eauto|].
  simpl in pf.
  destruct n; simpl; [reflexivity |].
  apply f_equal. apply IHl.
Qed.

Lemma PathToIn : forall {A : Set} {a : A} {l : list A}, Path a l -> In a l.
Proof.
  intros A a l H; induction H; [left | right]; auto.
Qed.

Ltac ClearLTZero :=
  match goal with
  | [ H : _ < length [] |- _ ] =>
    exfalso; eapply Nat.nlt_0_r; eauto
  | [ H : _ < 0 |- _ ] =>
    exfalso; eapply Nat.nlt_0_r; eauto
  | _ => idtac
  end.

Definition _add_one_corr_cons : forall {A : Type} i a (l : list A), i < length l -> (i + 1) < length (a :: l).
Proof.
  intros A i a l Hi.
  rewrite Nat.add_comm; simpl.
  apply Lt.lt_n_S; auto.
Qed.

Lemma nth_known_correct_cons : forall {A : Type} i a (l : list A) (Hi : i < length l),
    nth_known_correct i l Hi = nth_known_correct (i + 1) (a :: l) (_add_one_corr_cons i a l Hi).
Proof.
  intros A i a l Hi;
    generalize dependent i; generalize dependent a; induction l; intros b i Hi; ClearLTZero; simpl; simpl in Hi; auto.
  destruct i; simpl; auto.
  rewrite IHl with (a := a).
  apply nth_known_correct_pf_irr.
Qed.

Lemma nth_known_correct_cons' : forall {A : Type} i a (l : list A) (Hi : i < length l) (Hj : i + 1 < length (a :: l)),
    nth_known_correct i l Hi = nth_known_correct (i + 1) (a :: l) Hj.
Proof.
  intros A i a l Hi Hj;
    generalize dependent i; generalize dependent a; induction l; intros b i Hi Hj; ClearLTZero; simpl;
      simpl in Hi; simpl in Hj; auto.
  destruct i; simpl; auto.
Qed.

Lemma nth_known_correct_error : forall {A : Type} i (l : list A) (Hi : i < length l),
    nth_error l i = Some (nth_known_correct i l Hi).
Proof.
  intros A i l Hi.
  generalize dependent i; induction l; intros i Hi; ClearLTZero; simpl.
  destruct i; [simpl; auto|].
  simpl. apply IHl.
Qed.

Lemma nth_error_some_if_known_correct : forall {A : Type} (l : list A) i (Hi : i < length l),
    exists a, nth_error l i = Some a.
Proof.
  intros A l; induction l; intros i Hi; ClearLTZero; simpl; simpl in Hi.
  destruct i; simpl. exists a; auto.
  assert (i < length l) by (apply Lt.lt_S_n; auto). specialize (IHl i H).
  auto.
Qed.

Lemma nth_known_correct_eq : forall {A : Type} i j (l : list A) (Hi : i < length l) (Hj : j < length l),
    i = j -> nth_known_correct i l Hi = nth_known_correct j l Hj.
Proof.
  intros A i j l Hi Hj H.
  assert (nth_error l i = nth_error l j) by (rewrite H; auto).
  pose (nth_error_some_if_known_correct l i Hi) as e;
    destruct e as [a Ha];
    pose proof Ha as Ha';
    rewrite nth_known_correct_error with (Hi0 := Hi) in Ha'; inversion Ha'.
  pose (nth_error_some_if_known_correct l j Hj);
    destruct e as [b Hb];
    pose proof Hb as Hb';
    rewrite nth_known_correct_error with (Hi0 := Hj) in Hb'; inversion Hb'.
  assert (Some a = Some b)
    by (transitivity (nth_error l i); [symmetry; auto | transitivity (nth_error l j); auto]).
  inversion H1.
  rewrite H2. rewrite H3. auto.
Qed.

Program Fixpoint MoveToFront {A : Type} (AEq : forall a b : A, {a = b} + {a <> b})
        (l : list A) (a : A) : list A :=
  match l with
  | [] => []
  | x :: l' => if AEq a x
              then x :: l'
              else match MoveToFront AEq l' a with
                   | [] => x :: []
                   | y :: l'' =>
                     if AEq y a
                     then y :: x :: l''
                     else l
                   end
  end.

Definition InFront {A : Type} (l : list A) (a : A) : Prop :=
  match l with
  | [] => False
  | x :: _ => a = x
  end.

Lemma MoveToFrontInFront : forall {A : Type} AEq (l : list A) (a : A),
    In a l -> InFront (MoveToFront AEq l a) a.
Proof.
  intros A AEq l a aINl.
  induction l; [inversion aINl|].
  simpl; simpl in aINl. destruct aINl.
  rewrite H; simpl; destruct (AEq a a) as [e | n]; [clear e; simpl | exfalso; apply n]; auto.
  destruct (AEq a a0) as [e | n]; simpl; auto.
  destruct (MoveToFront AEq l a) eqn: e; [destruct (IHl H) | ].
  simpl in IHl; simpl.
  destruct (AEq a1 a). simpl; auto. exfalso; apply n0; symmetry; apply IHl; auto.
Qed.

Lemma MoveToFrontEq : forall {A : Type} AEq (l : list A) (a : A),
    ~In a l -> l = MoveToFront AEq l a.
Proof.
  intros A AEq l; induction l as [| b l']; intros a n; simpl; auto.
  destruct (AEq a b); auto.
  destruct (MoveToFront AEq l' a) eqn:e.
  rewrite (IHl' a); [rewrite e; auto | intro Hcontra; apply n; right; auto].
  destruct (AEq a0 a); auto.
  exfalso; apply n; right;
    rewrite IHl' with (a := a); [ rewrite e; left; auto | intro Hcontra; apply n; right; auto].
Qed.

Lemma MoveToFrontPermuation : forall {A : Type} AEq (l : list A) (a : A),
    Permutation l (MoveToFront AEq l a).
Proof.
  intros A AEq l a.
  induction l; [simpl; auto|].
  simpl. destruct (AEq a a0); [auto|].
  destruct (MoveToFront AEq l a) eqn:e.
  inversion IHl; auto.
  destruct (AEq a1 a); auto.
  transitivity (a0 :: a1 :: l0); constructor; auto; fail.
Qed.

Lemma MoveToFrontLength : forall {A : Type} AEq (l : list A) (a : A),
    length l = length (MoveToFront AEq l a).
Proof.
  intros A AEq l a; apply Permutation_length; exact (MoveToFrontPermuation AEq l a).
Qed.

Lemma OnlyNNumbersLessThanN : forall (n : nat) (l : list nat),
    (forall m, In m l -> m < n) -> length l > n -> ~ NoDup l.
Proof.
  intros n. induction n; intros l all_below length_above nodup.
  destruct l; simpl in length_above. eapply Gt.gt_irrefl; eauto.
  eapply Nat.nlt_0_r; apply all_below; left; eauto.
  remember (MoveToFront Nat.eq_dec l n).
  pose proof (MoveToFrontPermuation Nat.eq_dec l n).
  rewrite <- Heql0 in H.
  pose proof (Permutation_NoDup H nodup) as nodupl0.
  destruct (ListDec.In_dec Nat.eq_dec n l).
  - assert (InFront l0 n) as nInFrontOfl by (rewrite Heql0; apply MoveToFrontInFront; auto).
    destruct l0; simpl in nInFrontOfl; [inversion nInFrontOfl |].
    apply (IHn l0).
    -- intros m mINl0.
       assert (In m l) as mINl
         by (apply Permutation_in with (l := (n0 :: l0)); [symmetry; auto| right; auto]).
       pose proof (Lt.lt_n_Sm_le m n (all_below m mINl)) as mLEn.
       destruct (Lt.le_lt_or_eq m n mLEn); auto.
       exfalso; inversion nodupl0; apply H3; rewrite <- nInFrontOfl; rewrite <- H0; auto.
    -- assert (length l = length (n0 :: l0)) by (apply Permutation_length; auto);
         rewrite H0 in length_above; simpl in length_above; apply Lt.lt_S_n; auto.
    --inversion nodupl0; auto.
  - apply (IHn l).
    -- intros m H0.
       pose proof (Lt.lt_n_Sm_le m n (all_below m H0)).
       destruct (Lt.le_lt_or_eq m n H1); auto.
       exfalso; apply n0; rewrite <- H2; auto.
    -- apply Gt.gt_trans with (m := S n); auto.
    -- auto.
Qed.

Theorem NoDupFilter : forall {A : Type} (l : list A) (f : A -> bool),
    NoDup l -> NoDup (filter f l).
Proof.
  intros A l f H.
  induction l; simpl; auto.
  destruct (f a).
  constructor. inversion H.
  intro Hcontra; apply H2.
  pose proof (proj1 (filter_In f a l)).
  specialize (H4 Hcontra).
  destruct H4; auto.
  all: apply IHl; inversion H; auto.
Qed.

Fixpoint FilterLTs (l : list nat) (n : nat) : list nat :=
  match l with
  | [] => []
  | m :: l' =>
    let fltd := FilterLTs l' n in
    if andb (m <? n) (negb (InBool Nat.eq_dec m fltd))
              then m :: fltd
              else fltd
  end.

Theorem FilterLTs_lt : forall (l : list nat) (n m : nat),
    In m (FilterLTs l n) -> m < n.
Proof.
  intros l n m H.
  induction l.
  inversion H.
  simpl in H.
  destruct ((a <? n) && negb (InBool Nat.eq_dec a (FilterLTs l n)))%bool eqn:e.
  apply andb_prop in e; destruct e as [e1 e2].
  assert (a < n) by (rewrite Nat.ltb_lt in e1; auto).
  assert (~ In a (FilterLTs l n)) by (rewrite Bool.negb_true_iff in e2; rewrite InBoolSpec' in e2; auto).
  destruct H; [rewrite <- H; auto | apply IHl; auto].
  apply IHl; auto.
Qed.

Theorem FilterLTs_length1 : forall (l : list nat) (n : nat),
    length (FilterLTs l n) <= length l.
Proof.
  intros l n.
  induction l; simpl; auto.
  destruct (((a <? n) && negb (InBool Nat.eq_dec a (FilterLTs l n)))%bool).
  simpl. apply le_n_S; auto.
  transitivity (length l); auto.
Qed.

Theorem FilterLTs_NoDup : forall (l : list nat) (n : nat),
    NoDup (FilterLTs l n).
Proof.
  intros l n.
  induction l; simpl; try (constructor; auto; fail); auto.
  destruct ((a <? n) && negb (InBool Nat.eq_dec a (FilterLTs l n)))%bool eqn:e; auto.
  apply andb_prop in e; destruct e as [e1 e2].
  assert (a < n) by (rewrite Nat.ltb_lt in e1; auto).
  assert (~ In a (FilterLTs l n)) by (rewrite Bool.negb_true_iff in e2; rewrite InBoolSpec' in e2; auto).
  constructor; auto.
Qed.

Theorem FilterLTs_in : forall (l : list nat) (n m : nat),
    In m (FilterLTs l n) -> In m l.
Proof.
  intros l n m H.
  induction l. simpl in H; inversion H.
  simpl in H. destruct ((a <? n) && negb (InBool Nat.eq_dec a (FilterLTs l n)))%bool.
  destruct H; [left | right; apply IHl]; auto.
  right; apply IHl; auto.
Qed.

Theorem InFilterLTs : forall (l : list nat) (n m : nat),
    In m l ->  m < n -> In m (FilterLTs l n).
Proof.
  intros l n m H H0; induction l; simpl in H; [inversion H|]; destruct H; simpl;
    destruct ((a <? n) && negb (InBool Nat.eq_dec a (FilterLTs l n)))%bool eqn:e; simpl;
      try (match goal with
           | [ H : ?P |- ?P \/ _ ] => left; auto
           | [ H : ?P, IH : ?P -> ?Q |- _ \/ ?Q] => right; apply IH; auto
           | [ H : ?P, IH : ?P -> ?Q |- ?Q ] => apply IH; auto
           end).
  destruct (Bool.andb_false_elim _ _ e).
  exfalso; apply Nat.ltb_nlt in e0; apply e0; rewrite H; auto.
  rewrite Bool.negb_false_iff in e0; rewrite InBoolSpec in e0; rewrite H in e0; auto.
Qed.

Fixpoint AllBelow (n : nat) : list nat :=
  match n with
  | 0 => []
  | S n => AllBelow n ++ [n]
  end.

Theorem InAllBelow : forall (n m : nat),
    m < n <-> In m (AllBelow n).
Proof.
  intros n; induction n; intros m; split; intro H.
  - inversion H.
  - simpl in H; inversion H.
  - simpl; apply in_or_app; apply Lt.lt_n_Sm_le in H; apply Lt.le_lt_or_eq in H; destruct H.
    left; rewrite <- IHn; auto.
    right; rewrite H; left; auto.
  - simpl in H. apply in_app_or in H. destruct H.
    rewrite <- IHn in H; auto.
    destruct H; [rewrite H; auto | inversion H].
Qed.

Theorem AllBelowLength : forall (n : nat),
    length (AllBelow n) = n.
Proof.
  intros n; induction n; simpl; auto.
  rewrite app_length; simpl; rewrite IHn; rewrite Nat.add_comm; simpl; reflexivity.
Qed.

Program Fixpoint ListDifference {A : Type} (AEq : forall a b : A, {a = b} + {a <> b}) (l1 l2 : list A)
  : list A :=
  match l1 with
  | [] => []
  | a :: l1' => if InBool AEq a l2
               then ListDifference AEq l1' l2
               else a :: ListDifference AEq l1' l2
  end.

Theorem ListDifference_length1 : forall {A : Type} (AEq : forall a b : A, {a = b} + {a <> b}) (l1 l2 : list A),
    length (ListDifference AEq l1 l2) <= length l1.
Proof.
  intros A AEq l1 l2.
  induction l1; simpl; auto.
  destruct (InBool AEq a l2) eqn:e.
  transitivity (length l1); auto.
  simpl; apply le_n_S; auto.
Qed.

Theorem SubsetListLength : forall {A : Type} (AEq : forall a b : A, {a = b} + {a <> b}) (l1 l2 : list A),
    (forall a, In a l1 -> In a l2) -> NoDup l1 -> length l1 <= length l2.
Proof.
  intros A AEq l1.
  induction l1; intros l2 H H0.
  - simpl; apply le_0_n.
  - simpl.
    pose proof (MoveToFrontInFront AEq l2 a (H a (or_introl eq_refl))).
    destruct (MoveToFront AEq l2 a) eqn:e; [inversion H1|].
    pose proof (MoveToFrontLength AEq l2 a).
    rewrite e in H2. simpl in H2.
    rewrite H2. apply Le.le_n_S. apply IHl1; [| inversion H0; auto].
    intros a1 H3.
    specialize (H a1 (or_intror H3)).
    apply Permutation_in with (l' := (MoveToFront AEq l2 a)) in H; [| apply MoveToFrontPermuation].
    rewrite e in H; destruct H; auto; inversion H0;
      exfalso; apply H6; simpl in H1; rewrite H1; rewrite H; auto.
Qed.

Theorem FilterLTs_length2 : forall (l : list nat) (n : nat),
    length (FilterLTs l n) <= n.
Proof.
  intros l n.
  rewrite <- AllBelowLength.
  apply SubsetListLength; [apply Nat.eq_dec| |apply FilterLTs_NoDup].
  intros a H; apply FilterLTs_lt in H; apply InAllBelow; auto.
Qed.
Lemma FilterLTsZero : forall (l : list nat),
    FilterLTs l 0 = [].
Proof.
  intros l; induction l; simpl; auto.
Qed.

Ltac DestructFilterLTs :=
  repeat match goal with
         | [ |- context [if ?b then _ else _] ] =>
           let e := fresh "e" in
           destruct b eqn: e
         | [ H : context [if ?b then _ else _] |- _ ] =>
           let e := fresh "e" in
           destruct b eqn:e
         | [ H1 : ?P |- ?P ] => exact H1
         | [ H1 : ?P, H2 : ~?P |- _ ] => exfalso; apply H2; exact H1
         | [ H : (?a <? ?b) = true |- _ ] =>
           match goal with
           | [ _ : a < b |- _ ] => fail 1
           | _ => assert (a < b) by (rewrite Nat.ltb_lt in H; auto)
           end
         | [ H : (?a <? ?b) = false |- _ ] =>
           match goal with
           | [ _ : ~ a < b |- _ ] => fail 1
           | _ => assert (~ a < b) by (rewrite Nat.ltb_nlt in H; auto)
           end
         | [H : (?a =? ?b) = true |- _ ] =>
           match goal with
           | [_ : a = b |- _ ]=> fail 1
           | _ => assert (a = b) by (rewrite Nat.eqb_eq in H; auto)
           end
         | [H : (?a =? ?b) = false |- _ ] =>
           match goal with
           | [_ : a <> b |- _ ] => fail 1
           | _ => assert (a <> b) by (rewrite Nat.eqb_neq in H; auto)
           end
         | [H : andb ?a ?b = true |- _ ] =>
           match goal with
           | [_ : a = true, _ : b = true |- _ ] => fail 1
           | _ => assert (a = true) by (rewrite Bool.andb_true_iff in H; destruct H; auto);
                 assert (b = true) by (apply Bool.andb_true_iff in H; destruct H; auto)
           end
         | [H : andb ?a ?b = false |- _ ] =>
           match goal with
           | [ _ : a = false |- _ ] => fail 1
           | [ _ : b = false |- _ ] => fail 1
           | _ => let H' := fresh in
                 assert (a = false \/ b = false) as H'
                     by (rewrite Bool.andb_false_iff in H; auto);
                 destruct H'
           end
         | [H : negb ?a = true |- _ ] =>
           match goal with
           | [_ : a = false |- _ ] => fail 1
           | _ => assert (a = false) by (rewrite Bool.negb_true_iff in H; auto)
           end
         | [H : negb ?a = false |- _ ] =>
           match goal with
           | [_ : a = true |- _ ] => fail 1
           | _ => assert (a = true) by (rewrite Bool.negb_false_iff in H; auto)
           end
         | [H : InBool _ ?a ?l = true |- _ ] =>
           match goal with
           | [ _ : In a l |- _ ] => fail 1
           | _ => assert (In a l) by (rewrite InBoolSpec in H; auto)
           end
         | [H : InBool _ ?a ?l = false |- _ ] =>
           match goal with
           | [_ : ~(In a l) |- _ ] => fail 1
           | _ => assert (~In a l) by (rewrite InBoolSpec' in H; auto)
           end
         end.

Lemma FilterLTs_length_NotInZero : forall (l : list nat) (n : nat),
    ~ In 0 l ->
    length (FilterLTs (map (fun x => x - 1) l) n) = length (FilterLTs l (S n)).
Proof.
  intros l; induction l; intros n ni; simpl; auto.
  DestructFilterLTs.
  - simpl. simpl.
    rewrite IHl; auto. intro Hcontra; apply ni; right; auto.
  - exfalso; apply H3; destruct a; [apply Nat.lt_0_succ |].
    simpl in H1; rewrite Nat.sub_0_r in H1; apply Lt.lt_n_S; auto.
  - exfalso. pose proof (FilterLTs_lt _ _ _ H5).
    pose proof (FilterLTs_in _ _ _ H5).
    apply H6. apply InFilterLTs. pose proof (in_map (fun x => x - 1) _ _ H8).
    simpl in H9. auto.
    destruct a; [exfalso; apply ni; left; auto | simpl; rewrite Nat.sub_0_r; apply Lt.lt_S_n; auto].
  - exfalso; apply H3; destruct a.
    exfalso; apply ni; left; auto.
    simpl; rewrite Nat.sub_0_r; apply Lt.lt_S_n; auto.
  - apply FilterLTs_in in H5. apply map_preservesIn in H5.
    destruct H5 as [b Hb]; destruct Hb.
    assert (a = b)
      by (destruct a; [exfalso; apply ni; left; auto |]; destruct b;[exfalso; apply ni; right; auto|];
          simpl in H7; rewrite Nat.sub_0_r in H7; rewrite Nat.sub_0_r in H7; rewrite H7; auto).
    exfalso; apply H6; apply InFilterLTs; [rewrite H8 |]; auto.
  - apply IHl; intro Hcontra; apply ni; right; auto.
  - destruct a; [exfalso; apply ni; left; auto|].
    simpl in H3. rewrite Nat.sub_0_r in H3. apply FilterLTs_lt in H3.
    exfalso; apply H0; apply Lt.lt_n_S; auto.
  - apply IHl; intro Hcontra; apply ni; right; auto.
  - apply IHl; intro Hcontra; apply ni; right; auto.
Qed.

Lemma FilterLTs_remove_zeros : forall (l : list nat) (n : nat),
    FilterLTs (RemoveZeros l) n = RemoveZeros (FilterLTs l n).
Proof.
  intros l n. induction l.
  simpl. auto.
  simpl; DestructFilterLTs; simpl; DestructFilterLTs.
  - rewrite IHl; auto.
  - exfalso. rewrite IHl in H7. apply InRemoveZeros in H7. destruct H7. apply H4; auto.
  - exfalso. apply H7. rewrite IHl. apply InRemoveZeros'; auto.
Qed.

Lemma FilterLTs_length_remove_zeros : forall (l : list nat) (n : nat),
    In 0 l -> length (FilterLTs (RemoveZeros l) n) = length (FilterLTs l n) - 1.
Proof.
  intros l n H.
  rewrite FilterLTs_remove_zeros.
  induction l; simpl; auto.
  simpl; DestructFilterLTs.
  simpl. DestructFilterLTs.
  - rewrite Nat.sub_0_r; rewrite RemoveZerosWithoutZerosInv; [auto | rewrite H5 in H4; auto].
  - simpl. destruct H; [exfalso; apply H5; auto | ]. rewrite IHl; auto. apply Minus.minus_Sn_m.
    clear IHl H3 H1 H4 e e0 H0. induction l; [inversion H | simpl; auto].
    DestructFilterLTs; simpl.
    -- simpl. apply OneLES.
    -- destruct H.
       exfalso; apply H1; rewrite H; destruct n; [inversion H2 | apply Nat.lt_0_succ].
       apply IHl; auto.
    -- destruct (FilterLTs l n); [inversion H3 | simpl; apply OneLES].
  - destruct H; [| apply IHl; auto].
    destruct n; [rewrite FilterLTsZero; simpl; auto
                | exfalso; apply H1; rewrite H; apply Nat.lt_0_succ].
  - destruct H; [apply FilterLTs_in in H2; apply IHl; rewrite <- H; auto |apply IHl; auto].
Qed.

Lemma FilterLTs_length_S_InZero : forall (l : list nat) (n : nat),
    In 0 l ->
    length (FilterLTs (map (fun x => x - 1) (RemoveZeros l)) n) = length (FilterLTs l (S n)) - 1.
Proof.
  intros l n H.
  pose proof (FilterLTs_length_NotInZero (RemoveZeros l) n (ZeroNotInRemoveZeros l)).
  rewrite H0.
  apply FilterLTs_length_remove_zeros; auto.
Qed.

Fixpoint AllBelowMinusZero (n : nat) : list nat :=
  match n with
  | 0 => []
  | 1 => []
  | S n => (AllBelowMinusZero n) ++ [n]
  end.

Lemma InAllBelowMinusZero : forall (n m : nat),
    m < n -> m <> 0 -> In m (AllBelowMinusZero n).
Proof.
  intros n; induction n; intros m H H0.
  inversion H.
  simpl; destruct n.
  destruct m; [exfalso; apply H0; auto | apply Lt.lt_S_n in H; inversion H].
  inversion H; apply in_or_app.
  right; left; auto.
  left. apply IHn; auto.
Qed.

Lemma AllBelowMinusZeroLength : forall (n : nat),
    length (AllBelowMinusZero n) = n - 1.
Proof.
  intros n; induction n; simpl; auto.
  destruct n. simpl. auto.
  rewrite app_length; rewrite IHn; simpl; rewrite Nat.sub_0_r; rewrite Nat.add_comm; simpl; auto.
Qed.

Lemma FilterLTs_everything : forall (l : list nat) (n : nat),
    length (FilterLTs l (S n)) = (S n) -> In 0 (FilterLTs l (S n)).
Proof.
  intros l n H.
  destruct (ListDec.In_dec Nat.eq_dec 0 (FilterLTs l (S n))); auto.
  assert (forall x, In x (FilterLTs l (S n)) -> In x (AllBelowMinusZero (S n))).
  intros x H0. pose proof (FilterLTs_in _ _ _ H0). pose proof (FilterLTs_lt _ _ _ H0).
  apply InAllBelowMinusZero; auto.
  intro Hcontra; apply n0; apply InFilterLTs; [rewrite <- Hcontra; auto | apply Nat.lt_0_succ].
  assert (NoDup (FilterLTs l (S n))) by apply FilterLTs_NoDup.
  pose proof (SubsetListLength Nat.eq_dec _ _ H0 H1).
  rewrite AllBelowMinusZeroLength in H2. simpl in H2. rewrite Nat.sub_0_r in H2.
  rewrite H in H2. exfalso; eapply Nat.nle_succ_diag_l; eauto.
Qed.

Fixpoint nub {A : Type} (ADec : forall a b : A, {a = b} + {a <> b}) (l : list A) : list A :=
  match l with
  | [] => []
  | x :: xs => if InBool ADec x xs
              then nub ADec xs
              else x :: (nub ADec xs)
  end.

Lemma nub_In : forall {A : Type} ADec (l : list A) (a : A),
    In a l <-> In a (nub ADec l).
Proof.
  intros A ADec l a.
  induction l. simpl; split; auto.
  simpl. destruct (InBool ADec a0 l) eqn:e.
  split; intro H; auto.
  destruct H; [rewrite H in e; rewrite InBoolSpec in e|]; apply IHl; auto.
  right; apply IHl; auto.
  simpl. split; intro H.
  all: destruct H; [left; auto| right; apply IHl; auto].
Qed.

Lemma nub_count_occ_01 : forall {A : Type} ADec (l : list A) (a : A),
    count_occ ADec (nub ADec l) a = 1 \/ count_occ ADec (nub ADec l) a = 0.
Proof.
  intros A ADec l a.
  induction l; simpl. right; auto.
  destruct (InBool ADec a0 l) eqn:e; auto.
  simpl. destruct (ADec a0 a); auto.
  assert (~ In a0 (nub ADec l))
    by (intro H; rewrite InBoolSpec' in e; apply e; rewrite nub_In; exact H).
  left; rewrite e0 in H; pose proof (proj1 (count_occ_not_In ADec (nub ADec l) a) H);
    rewrite H0; auto.
Qed.

Lemma nub_count_occ: forall {A : Type} ADec (l : list A) (a : A),
    In a l <-> count_occ ADec (nub ADec l) a = 1.
Proof.
  intros A ADec l a; split; intro H.
  - destruct (nub_count_occ_01 ADec l a); auto; exfalso.
    rewrite (nub_In ADec) in H.
    pose proof ((proj1 (count_occ_In ADec (nub ADec l) a)) H).
    rewrite H0 in H1; inversion H1.
  - rewrite (nub_In ADec); rewrite (count_occ_In ADec); rewrite H; auto.
Qed.

Program Fixpoint WithoutPath {A : Set}
        {a : A} (l : list A) (p : Path a l) {struct p}: list A :=
  match p with
  | Here _ l => l
  | There b pth' => b :: (WithoutPath _ pth')
  end.

Inductive PathToSamePlace {A : Set} : forall (l1 l2 : list A) (a b : A),
    Path a l1 -> Path b l2 -> Prop :=
| BothHere : forall (l : list A) (a : A), PathToSamePlace (a :: l) (a :: l) a a (Here a l) (Here a l)
| BothThere : forall (l1 l2 : list A) (a b c : A) (p1 : Path b l1) (p2 : Path c l2),
    PathToSamePlace l1 l2 b c p1 p2 -> PathToSamePlace (a :: l1) (a :: l2) b c (There a p1) (There a p2).

Lemma PathToSamePlaceSameA : forall {A : Set} (l1 l2 : list A) (a b : A)
                               (p1 : Path a l1) (p2 : Path b l2),
    PathToSamePlace l1 l2 a b p1 p2 -> a = b.
Proof.
  intros A l1 l2 a b p1 p2 H.
  induction H; auto.
Qed.

Lemma PathToSamePlaceSameL : forall {A : Set} (l1 l2 : list A) (a b : A)
                               (p1 : Path a l1) (p2 : Path b l2),
    PathToSamePlace l1 l2 a b p1 p2 -> l1 = l2.
Proof.
  intros A l1 l2 a b p1 p2 H.
  induction H; auto.
  rewrite IHPathToSamePlace; auto.
Qed.

Lemma PathToSamePlaceRefl : forall {A : Set} (l : list A) (a : A) (p : Path a l),
    PathToSamePlace l l a a p p.
Proof.
  intros A l a p.
  induction p; try (constructor; auto; fail).
Qed.

Lemma PathToSamePlaceIndexEq : forall {A : Set} (l1 l2 : list A) (a b : A)
                                 (p1 : Path a l1) (p2 : Path b l2),
    PathToSamePlace l1 l2 a b p1 p2 -> PathToIndex p1 = PathToIndex p2.
Proof.
  intros A l1 l2 a b p1 p2 ptsp.
  induction ptsp; simpl; auto.
Qed.

Lemma PathToIndexEqToSamePlace : forall {A : Set} (l : list A) (a b : A)
                                 (p1 : Path a l) (p2 : Path b l),
    PathToIndex p1 = PathToIndex p2 -> PathToSamePlace l l a b p1 p2.
Proof.
  intros A l a b p1 p2 indexEq.
  induction p1 eqn:e; simpl in *.
  - destruct (PathToIndex0_Here p2 (eq_sym indexEq)).
    generalize dependent p2. rewrite H. intros p2 indexEq H0.
    apply JMeq_eq in H0. rewrite H0. constructor.
  - remember (PathToIndexS_There p2 (PathToIndex p) (eq_sym indexEq)).
    clear Heqe0. destruct e0 as [b1 e0]; destruct e0 as [l' e0]; destruct e0 as [pth' H];
                   destruct H as [e1 e2].
    inversion e1. clear e1. generalize dependent p2.
    rewrite H0. generalize dependent pth'. rewrite <- H1.
    intros pth' p2 indexEq e2.
    apply JMeq_eq in e2. rewrite e2. constructor.
    apply IHp with (p1 := p). reflexivity. rewrite e2 in indexEq. simpl in indexEq.
    inversion indexEq; auto.
Qed.

Lemma PathToSamePlaceRecursive :
  forall {A : Set} (l l' : list A) (a b c d : A)  (p1 : Path a l) (p2 : Path b l')
    (Adec : forall a b : A, {a = b} + {a <> b}),
    PathToSamePlace (c :: l) (d :: l') a b (There c p1) (There d p2) ->
    PathToSamePlace l l' a b p1 p2.
Proof.
  intros A l l' a b c d p1 p2 Adec p3.
  inversion p3.
  apply Eqdep_dec.inj_pair2_eq_dec in H6; auto.
  apply Eqdep_dec.inj_pair2_eq_dec in H6; [| apply list_eq_dec; auto].
  apply Eqdep_dec.inj_pair2_eq_dec in H7; auto.
  apply Eqdep_dec.inj_pair2_eq_dec in H7; [| apply list_eq_dec; auto].
  rewrite <- H6. rewrite <- H7. exact H5.
Qed.

Program Fixpoint PathToSamePlaceDec
  {A : Set} {l1 l2 : list A} {a b : A} (p1 : Path a l1) (p2 : Path b l2) (Adec : forall x y : A, {x = y} + {x <> y})
  : {PathToSamePlace l1 l2 a b p1 p2} + {~ PathToSamePlace l1 l2 a b p1 p2} :=
  match p1 with
  | Here x l1' => match p2 with
                 | Here y l2' =>
                   match Adec x y with
                   | left e =>
                     match list_eq_dec Adec l1' l2' with
                     | left e => left _
                     | right n => right _
                     end
                   | right n => right _
                   end
                 | There _ _ => right _
                 end
  | There x p1' => match p2 with
                | Here _ _ => right _
                | There y p2' =>
                  match (Adec x y) with
                  | left e =>
                    match (PathToSamePlaceDec p1' p2' Adec) with
                    | left e' => left _
                    | right n => right _
                    end
                  | right n => right _
                  end

                  end
  end.
Next Obligation.
  constructor.
Defined.
Next Obligation.
  intro H; apply n. apply PathToSamePlaceSameL in H.
  inversion H; auto.
Defined.
Next Obligation.
  intro H; apply n. eapply PathToSamePlaceSameA; exact H.
Defined.
Next Obligation.
  intro H; inversion H.
Defined.
Next Obligation.
  intro H; inversion H.
Defined.
Next Obligation.
  constructor; auto.
Defined.
Next Obligation.
  intro H. apply PathToSamePlaceRecursive in H; auto.
Defined.
Next Obligation.
  intro H. apply PathToSamePlaceSameL in H. inversion H. apply n; auto.
Defined.

  Lemma withoutLiftPath : forall {A : Set} (l : list A) (a b : A) (pth : Path a l), Path b (WithoutPath l pth) -> Path b l.
  Proof.
    induction pth; simpl; intros.
    apply There; auto.
    inversion H; subst.
    apply Here.
    apply There; auto.
  Qed.

  Program Fixpoint RemoveIndex {A : Set} (l : list A) (n : nat) (corr : n < length l) : list A :=
    match n with
    | 0 => match l with
          | [] => _
          | _ :: l' => l'
          end
    | S m => match l with
            | [] => _
            | a :: l' => a :: (RemoveIndex l' m _)
            end
    end.
  Next Obligation.
    exfalso; inversion corr.
  Defined.
  Next Obligation.
    exfalso; inversion corr.
  Defined.
  Next Obligation.
    simpl in corr; apply Lt.lt_S_n; auto.
  Defined.

  Definition Reindex (n m : nat) : nat :=
    if n <? m
    then m - 1
    else m.

  Fixpoint RemoveIndex' {A : Set} (l : list A) (n : nat) : list A :=
    match l with
    | [] => []
    | a :: l' => match n with
               | 0 => l'
               | S m => a :: (RemoveIndex' l' m)
               end
    end.

  Theorem RemoveIndexWhenCorr : forall {A : Set} (l : list A) (n : nat) (corr : n < length l),
      RemoveIndex l n corr = RemoveIndex' l n.
  Proof.
    intros A l n corr.
    generalize dependent n.
    induction l; intros. inversion corr.
    destruct n. simpl. reflexivity.
    simpl. rewrite IHl. reflexivity.
  Qed.

  Theorem RemoveIndex'Nil : forall {A : Set} (n : nat),
      @RemoveIndex' A [] n = [].
  Proof.
    auto.
  Qed.

  Theorem RemoveIndexNil : forall (A : Set) (n : nat) (corr : n < 0),
      @RemoveIndex A [] n corr = [].
  Proof.
    intros A n corr.
    inversion corr.
  Qed.

  Theorem Reindex'_correct_m_lt : forall {A : Set} (l : list A) (n m : nat),
      m < n -> nth_error l m = nth_error (RemoveIndex' l n) (Reindex n m).
  Proof.
    intros A l n m H.
    unfold Reindex. destruct (n <? m) eqn: n_lt_m.
    apply Nat.ltb_lt in n_lt_m.
    exfalso. eapply Nat.lt_asymm; [exact H | exact n_lt_m].
    apply Nat.ltb_nlt in n_lt_m.
    generalize dependent m. generalize dependent n.
    induction l; intros n m H n_lt_m.
    - simpl. reflexivity.
    - simpl. destruct n. inversion H.
      destruct m. simpl. reflexivity.
      simpl; apply IHl;
        [apply Lt.lt_S_n; exact H| intro H'; apply n_lt_m; apply Lt.lt_n_S; exact H'].
  Qed.

Program Fixpoint RepathWithoutPath {A : Set} {a1 a2 : A}
        {l : list A} (p1 : Path a1 l) (p2 : Path a2 l)
  (n : ~ PathToSamePlace l l a1 a2 p1 p2) : Path a2 (WithoutPath l p1) :=
  match p1 with
  | Here b l =>
    match p2 with
    | Here _ _ => _
    | There c pth' => pth'
    end
  | There b pth' =>
    match p2 with
    | Here _ l' => Here a2 (WithoutPath l' pth')
    | There c pth'' => There b (RepathWithoutPath pth' pth'' _)
    end
  end.
Next Obligation.
  exfalso; apply n; clear n.
  apply JMeq_eq in Heq_l0.
  apply JMeq_eq in Heq_l.
  pose proof (eq_trans Heq_l0 (eq_sym Heq_l)) as e.
  inversion e.
  assert (PathToIndex p1 = 0)
  by (clear Heq_p2 Heq_l p2 H1 e H0 a2;
      generalize dependent p1;
      rewrite <- Heq_l0; intros p1 Heq_p1; apply JMeq_eq in Heq_p1;
      rewrite <- Heq_p1; simpl; reflexivity).
  assert (PathToIndex p2 = 0)
    by (clear Heq_p1 Heq_l0 p1 H1 e H0 a1 H;
        generalize dependent p2;
        rewrite <- Heq_l;
        intros p2 Heq_p2; apply JMeq_eq in Heq_p2;
        rewrite <- Heq_p2; simpl; reflexivity).
  apply PathToIndexEqToSamePlace; rewrite H; rewrite H2; reflexivity.
Defined.
Next Obligation.
  apply JMeq_eq in Heq_l0.
  apply JMeq_eq in Heq_l.
  pose (eq_trans Heq_l0 (eq_sym Heq_l)).
  inversion e; auto.
Defined.
Next Obligation.
  apply JMeq_eq in Heq_l0.
  apply JMeq_eq in Heq_l.
  pose (eq_trans Heq_l0 (eq_sym Heq_l)).
  inversion e; auto.
Defined.
Next Obligation.
  unfold eq_rect; simpl.
  destruct (RepathWithoutPath_obligation_3 A a1 a2 l p1 p2 a1 b wildcard'0 pth' eq_refl
                                            Heq_l0 Heq_p1 a2 l' eq_refl Heq_l Heq_p2).
  apply JMeq_eq in Heq_l0. apply JMeq_eq in Heq_l.
  pose proof (eq_trans Heq_l0 (eq_sym Heq_l)) as e.
  inversion e. reflexivity.
Defined.
Next Obligation.
  apply JMeq_eq in Heq_l0. apply JMeq_eq in Heq_l.
  pose proof (eq_trans Heq_l0 (eq_sym Heq_l)) as e. inversion e; reflexivity.
Defined.
Next Obligation.
  destruct (RepathWithoutPath_obligation_6 A a1 a2 l p1 p2 a1 b wildcard'2 pth' eq_refl
                                           Heq_l0 Heq_p1 a2 c wildcard'0 pth'' eq_refl Heq_l Heq_p2).
  simpl.
  assert (PathToIndex p2 = S (PathToIndex pth''))
    by (clear Heq_p1 Heq_l0 n b p1 pth';
        generalize dependent p2; apply JMeq_eq in Heq_l; rewrite <- Heq_l;
        intros p2 Heq_p2; apply JMeq_eq in Heq_p2; rewrite <- Heq_p2; simpl; reflexivity).
  assert (PathToIndex p1 = S (PathToIndex pth'))
    by (clear Heq_p2 Heq_l n c p2 pth'' H;
        generalize dependent p1; apply JMeq_eq in Heq_l0; rewrite <- Heq_l0;
        intros p1 Heq_p1; apply JMeq_eq in Heq_p1; rewrite <- Heq_p1; simpl; reflexivity).
  intro Hsame. apply PathToSamePlaceIndexEq in Hsame.
  apply n. apply PathToIndexEqToSamePlace.
  transitivity (S (PathToIndex pth')); auto.
  rewrite Hsame. symmetry; auto.
Defined.

Lemma PathToFront : forall {A : Set} {a : A} {l : list A} (pth : Path a l),
    Permutation l (a :: WithoutPath l pth).
Proof.
  intros A a l pth.
  induction pth; simpl. apply Permutation_refl.
  apply perm_trans with (l' := b :: a :: WithoutPath l pth);
    [apply perm_skip; auto | apply perm_swap].
Qed.

Lemma combine_nil_l : forall {A : Type} {B : Type} (l : list B), @combine A B [] l = [].
Proof.
  intros A B l; reflexivity.
Qed.
Lemma combine_nil_r : forall {A : Type} {B : Type} (l : list A), @combine A B l [] = [].
Proof.
  intros A B l; induction l; reflexivity.
Qed.


Require Import Arith Div2 Wf_nat Omega.

Hint Constructors Even.even Even.odd.

Lemma sqrt2 : forall n p, n * n = 2 * p * p -> p = 0.
Proof.
  intros n.
  induction n as [[| n] IHn] using (well_founded_induction lt_wf);
    intros p H.
  - destruct p; simpl in *; inversion H; auto.
  - destruct (Even.even_odd_dec (S n)).
    + replace (S n) with (double (div2 (S n))) in H
        by (rewrite even_double; eauto).
      rewrite NPeano.double_twice in *.
      apply f_equal with (f := div2) in H.
      repeat rewrite <- mult_assoc in H.
      repeat rewrite div2_double in H.
      replace (div2 (S n) * (2 * div2 (S n)))
        with (2 * div2 (S n) * div2 (S n)) in H by apply mult_comm.
      destruct (Even.even_odd_dec p).
      * { replace p with (double (div2 p)) in H
            by (rewrite even_double; eauto).
          rewrite NPeano.double_twice in *.
          replace (div2 (S n) * (2 * div2 (S n)))
            with (2 * div2 (S n) * div2 (S n)) in H by apply mult_comm.
          repeat rewrite <- mult_assoc in H.
          apply f_equal with (f := div2) in H.
          repeat rewrite div2_double in H.
          replace (div2 p * (2 * div2 p))
            with (2 * div2 p * div2 p) in H by apply mult_comm.
          assert (div2 p = 0).
          - eapply IHn.
            + apply lt_div2.
              omega.
            + eauto.
          - destruct p; eauto.
            rewrite even_div2 in H0 by eauto.
            simpl in *.
            congruence. }
      * exfalso.
        assert (Even.odd (p * p)) by (apply Even.odd_mult; eauto).
        assert (Even.even (2 * div2 (S n) * div2 (S n)))
          by (rewrite <- mult_assoc; apply Even.even_mult_l; eauto).
        rewrite H in *.
        eapply Even.not_even_and_odd; eauto.
    + exfalso.
      assert (Even.odd (S n * S n)) by (apply Even.odd_mult; eauto).
      assert (Even.even (2 * p * p)) by (rewrite <- mult_assoc; apply Even.even_mult_l; eauto).
      rewrite H in *.
      eapply Even.not_even_and_odd; eauto.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.Rfunctions.
Require BuiltIn.
Require int.Int.
Require real.Real.
Require real.RealInfix.

Require Import Exponentiation.
Import Rfunctions.

(* Why3 comment *)
(* power is replaced with (Reals.Rfunctions.powerRZ x x1) by the coq driver *)

Lemma power_is_exponentiation :
  forall x n, (0 <= n)%Z -> powerRZ x n = Exponentiation.power _ R1 Rmult x n.
Proof.
intros x [|n|n] H.
easy.
2: now elim H.
unfold Exponentiation.power, powerRZ.
simpl.
induction (nat_of_P n).
easy.
simpl.
now rewrite IHn0.
Qed.

(* Why3 goal *)
Lemma Power_0 : forall (x:R), ((Reals.Rfunctions.powerRZ x 0%Z) = 1%R).
Proof.
intros x.
easy.
Qed.

(* Why3 goal *)
Lemma Power_s : forall (x:R) (n:Z), (0%Z <= n)%Z ->
  ((Reals.Rfunctions.powerRZ x (n + 1%Z)%Z) = (x * (Reals.Rfunctions.powerRZ x n))%R).
Proof.
intros x n h1.
rewrite 2!power_is_exponentiation by auto with zarith.
now apply Power_s.
Qed.

(* Why3 goal *)
Lemma Power_s_alt : forall (x:R) (n:Z), (0%Z < n)%Z ->
  ((Reals.Rfunctions.powerRZ x n) = (x * (Reals.Rfunctions.powerRZ x (n - 1%Z)%Z))%R).
intros x n h1.
rewrite <- Power_s.
f_equal; omega.
omega.
Qed.

(* Why3 goal *)
Lemma Power_1 : forall (x:R), ((Reals.Rfunctions.powerRZ x 1%Z) = x).
Proof.
exact Rmult_1_r.
Qed.

(* Why3 goal *)
Lemma Power_sum : forall (x:R) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((Reals.Rfunctions.powerRZ x (n + m)%Z) = ((Reals.Rfunctions.powerRZ x n) * (Reals.Rfunctions.powerRZ x m))%R)).
Proof.
intros x n m h1 h2.
rewrite 3!power_is_exponentiation by auto with zarith.
apply Power_sum ; auto with real.
Qed.

(* Why3 goal *)
Lemma Power_mult : forall (x:R) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((Reals.Rfunctions.powerRZ x (n * m)%Z) = (Reals.Rfunctions.powerRZ (Reals.Rfunctions.powerRZ x n) m))).
Proof.
intros x n m h1 h2.
rewrite 3!power_is_exponentiation by auto with zarith.
apply Power_mult ; auto with real.
Qed.

(* Why3 goal *)
Lemma Power_mult2 : forall (x:R) (y:R) (n:Z), (0%Z <= n)%Z ->
  ((Reals.Rfunctions.powerRZ (x * y)%R n) = ((Reals.Rfunctions.powerRZ x n) * (Reals.Rfunctions.powerRZ y n))%R).
Proof.
intros x y n h1.
rewrite 3!power_is_exponentiation by auto with zarith.
apply Power_mult2 ; auto with real.
Qed.

(* Why3 goal *)
Lemma Pow_ge_one : forall (x:R) (n:Z), ((0%Z <= n)%Z /\ (1%R <= x)%R) ->
  (1%R <= (Reals.Rfunctions.powerRZ x n))%R.
intros x n (h1,h2).
generalize h1.
pattern n; apply Z_lt_induction; auto.
clear n h1; intros n Hind h1.
assert (h: (n = 0 \/ 0 < n)%Z) by omega.
destruct h.
subst n; rewrite Power_0; auto with *.
replace n with ((n-1)+1)%Z by omega.
rewrite Power_s; auto with zarith.
assert (h : (1 <= powerRZ x (n-1))%R).
apply Hind; omega.
replace 1%R with (1*1)%R by auto with real.
apply Rmult_le_compat; auto with real.
Qed.


From mathcomp Require Import all_ssreflect.

Module Lesson6.

Lemma addC : commutative addn.
Proof.
elim => [| x' IHx] y.
  by rewrite addn0.
Search (_ + _.+1).
by rewrite addSn IHx addnS.
Qed.

Lemma addC2 : commutative addn.
Proof.
elim => [| x' IHx] y; first by rewrite addn0.
by rewrite addSn IHx addnS.
Qed.

Locate "`!".
Print factorial.
Print nosimpl.
Print fact_rec.

(* /=  - simpl *)

Fixpoint factorial_helper n acc :=
  if n is n'.+1 then factorial_helper n' (n * acc) else acc.

Definition my_factorial n := factorial_helper n 1.

Compute (my_factorial 5).

Lemma my_factorial_correct: forall n, my_factorial n = n`!.
Proof.
elim => [|n' IHn] //.
rewrite /my_factorial /factorial /= muln1.
rewrite /my_factorial /factorial in IHn.
rewrite -{}IHn.       (* {}  - remove hypotesis from context *)
rewrite /factorial_helper /=.
case: n'; first by done.
Abort.

Lemma factorial_helper_correct:
  forall n a, factorial_helper n a = n`! * a.
Proof.
elim => [| n' IHn] a /=.
  by rewrite /factorial /= mul1n.
rewrite {}IHn.
by rewrite factS mulnCA mulnA.
Qed.

Lemma my_factorial_correct: forall n, my_factorial n = n`!.
Proof.
rewrite /my_factorial => n.
by rewrite factorial_helper_correct muln1.
Qed.

Search (_ * 1).
Search left_id muln.
Search right_id muln.

Fixpoint fib (n: nat) :=
  if n is (n''.+1 as n').+1
    then fib n'' + fib n'
    else n.

Lemma tst1 n: fib n.+2 = 0.
Proof. move=> /=. Abort.

Arguments fib n : simpl nomatch. (* don't simpl unti matches *)

Lemma tst1 n: fib n.+2 = 0.
Proof. move=> /=. Abort.

Fixpoint fib_iter n f0 f1 :=
  if n is n'.+1 then fib_iter n' f1 (f0 + f1) else f0.
Arguments fib_iter n : simpl nomatch.

Lemma fib_iterS n f0 f1: fib_iter (n.+1) f0 f1 = fib_iter n f1 (f0 + f1).
Proof. done. Qed.

Lemma fib_iter_sum n f0 f1:
  fib_iter n.+2 f0 f1 = fib_iter n f0 f1 + fib_iter n.+1 f0 f1.
Proof.
elim: n f0 f1 => [//| n' IHn] f0 f1. (* :  - generalize n f0 f1 and then elim top (n) *)
(* : n f0 f1 = gen f1, gen f0, gen n *)
rewrite fib_iterS {}IHn.
done.
Qed.

Lemma fib_iter_correct n:
  fib_iter n 0 1 = fib n.
Proof.
elim: n => [//|n' IHn].
rewrite fib_iterS.
Abort.

Lemma nat_ind2 (P: nat -> Prop) :
  P 0 ->
  P 1 ->
  (forall n, P n -> P n.+1 -> P n.+2) ->
  (forall n, P n).
Proof.
move=> p0 p1 pstep n.
have: P n /\ P n.+1; last by case.
elim: n => [//| n' [IHn' IHSn']].
split=> //.
apply (pstep n' IHn' IHSn').
Qed.

Lemma nat_ind2' (P: nat -> Prop) :
  P 0 ->
  P 1 ->
  (forall n, P n -> P n.+1 -> P n.+2) ->
  (forall n, P n).
Proof.
move=> p0 p1 pstep n.
suff: P n /\ P n.+1 by case. (* like have but swaps goals *)
elim: n => [//| n' [IHn' IHSn']].
split=> //.
apply (pstep n' IHn' IHSn').
Qed.

Lemma nat_ind3' (P: nat -> Prop) :
  P 0 ->
  P 1 ->
  (forall n, P n -> P n.+1 -> P n.+2) ->
  (forall n, P n).
Proof.
move=> p0 p1 pstep n.
suff: P n /\ P n.+1 by case. (* like have but swaps goals *)
elim: n => // n.
case.
move /pstep. (* Apply something to head *)
move => p12.
move /[dup].
move /p12.
done.
Qed.

Lemma fib_iter_correct n:
  fib_iter n 0 1 = fib n.
Proof.
(*elim/nat_ind2: n => [//|//| n' IHn1 IHn2].*)
elim/nat_ind2: n => // n' IHn1 IHn2.
rewrite fib_iter_sum {}IHn1 {}IHn2.
done.
Qed.

About ltn_ind.

Lemma fib_iter_correct' n:
  fib_iter n 0 1 = fib n.
Proof.
elim/ltn_ind: n => n IHn.
Fail case: n. (* IHn depends on n *)
case: n IHn => // n IHn.
case: n IHn => // n IHn.
rewrite fib_iter_sum.
(*case n' => // n.*)
rewrite !IHn. (* ! - repeat *)
- done.
- done.
done.
Restart.
elim/ltn_ind: n => [] // [] // [] // n IHn.
by rewrite fib_iter_sum !IHn.
Qed.

(* {1}<-  - rewrite first entry backwards *)

End Lesson6.


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 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 len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

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

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
  induction l1.
  - intros. simpl. f_equal. apply IHl1.
  - intros. reflexivity.
Qed.

Lemma lem2 : forall l, len l = len (append l Nil).
Proof.
  induction l.
  - simpl. f_equal. apply IHl.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (len (rev x)) (len x).
Proof.
induction x.
  - simpl. rewrite <- IHx. rewrite <- (lem (rev x) Nil n).
    rewrite <- lem2. reflexivity.
  - reflexivity.
Qed.


Require Import Arith Nat Lia List Extraction.

Set Implicit Arguments.

Fixpoint list_snoc_rect {X:Type} (P:list X -> Type)
     (HP0 : P nil)
     (HP1 : forall l x,  P l -> P (l++x::nil))
     l : P l.
Proof.
  destruct l as [ | x l ].
  + apply HP0.
  + apply list_snoc_rect with (P := fun l => P (x::l)) (l := l).
    * apply (HP1 nil), HP0.
    * intros; apply (HP1 (x::_)); auto.
Qed.

Inductive pos3 := ZZ | OO | TT.

Definition pos3_nat p :=
  match p with
    | ZZ => 0
    | OO => 1
    | TT => 2
  end.

Fact pos3_nat_le p : pos3_nat p <= 2.
Proof. destruct p; auto. Qed.

(*

1 2 3 4 5 6 7 8 9 a b c d e f
  1   2   3   4   5   6   7
      1       2       3
              1

N []   = 1
N l++x = 2*N l + (x-1)

*)

Fixpoint N_rec a l :=
  match l with
    | nil  => a
    | x::l => N_rec (2*a+(pos3_nat x)-1) l
  end.

Definition N l := N_rec 1 l.

Fact N_nil : N nil = 1.
Proof. trivial. Qed.

Fixpoint N_app a l m : N_rec a (l++m) = N_rec (N_rec a l) m.
Proof. destruct l; simpl; auto. Qed.

Fact N_snoc l x : N (l++x::nil) = 2*N l+pos3_nat x-1.
Proof.
  unfold N; rewrite N_app; simpl; auto.
Qed.

Fact N_bound l : 1 <= N l <= 2^(1+length l)-1.
Proof.
  induction l as [ | l x IHl ] using list_snoc_rect.
  + rewrite N_nil; simpl; lia.
  + rewrite N_snoc, app_length; simpl length.
    generalize (pos3_nat_le x).
    replace (1+(length l+1)) with (S (1+length l)) by lia.
    rewrite Nat.pow_succ_r'.
    lia.
Qed.

Eval compute in N (ZZ::OO::TT::nil).
Eval compute in N (TT::TT::TT::nil).

Fact N_ZZ l : N (ZZ::l) < 2*2^(length l).
Proof.
  induction l as [ | l x IHl ] using list_snoc_rect.
  + cbv; auto.
  + change (ZZ::l++x::nil) with ((ZZ::l)++x::nil).
    rewrite N_snoc, app_length.
    simpl length.
    rewrite Nat.pow_add_r.
    revert IHl.
    generalize (pos3_nat x) (N (ZZ::l)) (2^length l) (pos3_nat_le x).
    intros a b c H1 H2; simpl; lia.
Qed.

Fact N_OO l : 2^(length l) < N (OO::l) < 3*2^(length l).
Proof.
  induction l as [ | l x IHl ] using list_snoc_rect.
  + cbv; auto.
  + change (OO::l++x::nil) with ((OO::l)++x::nil).
    rewrite N_snoc, app_length.
    simpl length.
    rewrite Nat.pow_add_r.
    revert IHl.
    generalize (pos3_nat x) (N (OO::l)) (2^length l) (pos3_nat_le x).
    intros a b c H1 H2; simpl; lia.
Qed.

Fact N_TT l : 2*2^(length l) < N (TT::l).
Proof.
  induction l as [ | l x IHl ] using list_snoc_rect.
  + cbv; auto.
  + change (TT::l++x::nil) with ((TT::l)++x::nil).
    rewrite N_snoc, app_length.
    simpl length.
    rewrite Nat.pow_add_r.
    revert IHl.
    generalize (pos3_nat x) (N (TT::l)) (2^length l) (pos3_nat_le x).
    intros a b c H1 H2; simpl; lia.
Qed.

CoInductive stream := lcons : pos3 -> stream -> stream.

CoFixpoint lcst x := lcons x (lcst x).

Fixpoint prefix n s :=
  match n, s with
    | 0  , _         => nil
    | S n, lcons x s => x::prefix n s
  end.

Fixpoint ltail n s :=
  match n, s with
    | 0  , s         => s
    | S n, lcons x s => ltail n s
  end.

Fixpoint lapp l s :=
  match l with
    | nil  => s
    | x::l => lcons x (lapp l s)
  end.

Fact ltail_cst n x : ltail n (lcst x) = lcst x.
Proof.
  induction n; auto.
Qed.

Fact prefix_ltail n s : lapp (prefix n s) (ltail n s) = s.
Proof.
  revert s; induction n as [ | n IHn ]; intros s; auto.
  destruct s as [ x s ]; simpl; f_equal; auto.
Qed.

Fact prefix_add n m s : prefix (n+m) s = prefix n s ++ prefix m (ltail n s).
Proof.
  revert s; induction n as [ | n IHn ]; intros s; auto.
  destruct s; simpl; f_equal; auto.
Qed.

Fact prefix_length n s : length (prefix n s) = n.
Proof.
  revert s; induction n as [ | n IHn ]; intros []; simpl; f_equal; auto.
Qed.

Fact pow2_ge_1 n : 1 <= 2^n.
Proof.
  change 1 with (2^0).
  apply Nat.pow_le_mono_r_iff; simpl; lia.
Qed.

Eval compute in N (prefix 3 (lcst TT)).

Fact N_ZZZ n : N (prefix n (lcst ZZ)) = 1.
Proof.
  induction n; auto.
Qed.

Fact N_OOO n : N (prefix n (lcst OO)) = 2^n.
Proof.
  induction n as [ | n IHn ]; auto.
  replace (S n) with (n+1) by lia.
  rewrite prefix_add, ltail_cst.
  simpl prefix; rewrite N_snoc, IHn.
  simpl pos3_nat.
  rewrite Nat.pow_add_r; simpl; lia.
Qed.

Fact N_TTT n : N (prefix n (lcst TT)) = 2*2^n-1.
Proof.
  induction n as [ | n IHn ]; auto.
  replace (S n) with (n+1) by lia.
  rewrite prefix_add, ltail_cst.
  simpl prefix; rewrite N_snoc, IHn.
  simpl pos3_nat.
  rewrite Nat.pow_add_r.
  generalize (2^n) (pow2_ge_1 n).
  intros; simpl; lia.
Qed.

(** Every stream s represents a real which is the limit
    of fun n => N (prefix n s) / 2*2^n)

    ZZZ = lcst ZZ ~~~> 0
    OOO = lcst OO ~~~> 1/2
    TTT = lcst TT ~~~> 1

*)

(** Looking at the first value in the stream s allows to
    position s either in [ 0 .. 3/4 ] or in [ 1/4 .. 1 ] *)

Theorem stream_choose s : { m : _ & (forall n, m <= n -> N (prefix n s) <= 3*2^(n-1))
                                  + (forall n, m <= n -> 2^(n-1) <= N (prefix n s))  }%type.
Proof.
  destruct s as [ [] s ].
  + exists 1; left; intros n Hn.
    replace n with (1+(n-1)) at 1 by lia.
    generalize (n-1); intros a; clear n Hn.
    simpl prefix.
    generalize (N_ZZ (prefix a s)).
    rewrite prefix_length; lia.
  + exists 1; left; intros n Hn.
    replace n with (1+(n-1)) at 1 by lia.
    generalize (n-1); intros a; clear n Hn.
    simpl prefix.
    generalize (N_OO (prefix a s)).
    rewrite prefix_length; lia.
  + exists 1; right; intros n Hn.
    replace n with (1+(n-1)) at 2 by lia.
    generalize (n-1); intros a; clear n Hn.
    simpl prefix.
    generalize (N_TT (prefix a s)).
    rewrite prefix_length; lia.
Qed.

Recursive Extraction stream_choose.

Section on_the_fly_update.

  Variable f : pos3 * pos3 * pos3 -> pos3 * pos3 * pos3.

  CoFixpoint otf_update s :=
    match s with lcons a (lcons b (lcons c s)) =>
      match f (a,b,c) with
        | (x,y,z) =>  lcons x (otf_update (lcons y (lcons z s)))
      end
    end.

End on_the_fly_update.

Recursive Extraction otf_update.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) (lf1 : natural) : natural :=
  plus Zero (Succ y).


Require Import HoTT.
From GR.groupoid.grpd_bicategory Require Import
     grpd_bicategory.

(** ** Some equational theory for groupoids *)
(** [e⁻¹ = e] *)
Definition inv_e
           {G : groupoid}
           (a : G)
  : inv (e a) = e a
  := (grpd_left_identity (inv (e a)))^ @ grpd_right_inverse (e a).

(** [(g⁻¹)⁻¹ = g] *)
Definition inv_involutive
           {G : groupoid}
           {a₁ a₂ : G}
           (g : G a₁ a₂)
  : inv (inv g) = g.
Proof.
  refine ((grpd_right_identity (inv (inv g)))^ @ _).
  refine (ap (fun p => _ ● p) (grpd_left_inverse g)^ @ _).
  refine (grpd_right_assoc _ _ _ @ _).
  refine (ap (fun p => p ● _) (grpd_left_inverse _) @ _).
  apply grpd_left_identity.
Defined.

(** [(g h)⁻¹ = h⁻¹ g ⁻¹] *)
Definition inv_prod
           {G : groupoid}
           {a₁ a₂ a₃ : G}
           (g₁ : G a₁ a₂)
           (g₂ : G a₂ a₃)
  : inv (g₁ ● g₂) = inv g₂ ● inv g₁.
Proof.
  refine (_ @ (grpd_right_identity (inv g₂ ● inv g₁))).
  refine (_ @ ap (fun p => _ ● p) (grpd_right_inverse (g₁ ● g₂))).
  refine (_ @ grpd_left_assoc _ _ _).
  refine (_ @ ap (fun p => p ● _) (grpd_right_assoc (inv g₂ ● inv g₁) g₁ g₂)^).
  refine (_ @ ap (fun p => (p ● _) ● _) (grpd_right_assoc (inv g₂) (inv g₁) g₁)).
  refine (_ @ (ap (fun p => ((_ ● p) ● _) ● _) (grpd_left_inverse _))^).
  refine (_ @ (ap (fun p => (p ● _) ● _) (grpd_right_identity _))^).
  refine (_ @ (ap (fun p => p ● _) (grpd_left_inverse _))^).
  exact (grpd_left_identity _)^.
Defined.


(***************************************************************************************)
(**                                 Diagonalization.v                                 **)
(**                                                                                **)
(** Defining and proving facts about Hermitian and diagonalizable matrices, including **)
(** on the exponentiation of diagonalizable matrices.                                 **)
(**                                                                                **)
(***************************************************************************************)

(*
*)
Require Import Reals.
Require Import QWIRE.Matrix.
Require Import MatrixExponential.
Require Import Init.Tauto.

(**********************************)
(** Linear Algebraic Definitions **)
(**********************************)

(* Element-wise definition of Hermitian *)
Definition Herm {n : nat} (A : Square n) : Prop :=
  forall i j, (A i j) = Cconj (A j i).

(* Adjoint definition of Hermitian *)
Definition Herm_alternate {n : nat} (A : Square n) :=
  A = A †.

(* D is a diagonal matrix if the following conditions are met *)
Definition Diagonal {n : nat} (D : Square n) :=
  forall i j, i <> j ->  D i j = 0.

(* Tinv × D × T is a diagonalization of M if the following conditions are met *)
Definition Diagonalization {n : nat} (Tinv D T M : Square n) : Prop :=
  Diagonal D /\ Minv T Tinv /\ M = Tinv × D × T /\
  WF_Matrix Tinv /\ WF_Matrix D /\ WF_Matrix T.

Definition Diagonalizable {n : nat} (A : Square n) :=
  exists (Tinv D T : Square n),
    Diagonalization Tinv D T A.

(* Element-wise exponentiation of a diagonal matrix *)
Definition exp_diag {n : nat} (D : Square n) :=
  (fun i j => if (i <? n) && (i =? j) then exp (fst (D i j)) else 0).

(* Exponentiation of a diagonalizable matrix *)
Definition is_exp_diag {n : nat} (M M_exp : Square n) : Prop :=
  exists (Tinv D T : Square n),
    Diagonalization Tinv D T M /\ Diagonalization Tinv (exp_diag D) T M_exp.

(* Two matrices are simultaneously diagonalizable if the following conditions are met *)
Definition Sim_diag {n : nat} (A B : Square n) :=
  exists (T Tinv M1 M2 : Square n),
    Diagonalization Tinv A T M1 /\ Diagonalization Tinv B T M2.

(* Definition of matrix commutation *)
Definition Mat_commute {n : nat} (A B : Square n) :=
  A × B = B × A.

(************************************************)
(** Lemmas on properties of Hermitian matrices **)
(************************************************)

(* Element-wise and matrix definitions of Hermitian are equivalent *)
Lemma herm_defs_equivalent {n : nat} (A : Square n) :
  WF_Matrix A -> Herm A <-> Herm_alternate A.
Proof.
  intros HWF. split; intros H; unfold Herm, Herm_alternate in *.
  - apply mat_equiv_eq; auto.
    + apply WF_adjoint; auto.
    + intros i j Hi Hj.
      unfold adjoint. apply H.
  - intros i j. unfold adjoint in H.
    remember (equal_f (equal_f H i) j) as E. clear HeqE.
    rewrite E. reflexivity.
Qed.

(* Helper lemma for herm_diag_real *)
Lemma real_neg_neq : forall (x : R), x <> 0 -> x <> Ropp x.
Proof.
  intros. intros H1.
  destruct (Rlt_dec x 0).
  - assert (H2 : Ropp x > 0). {
      apply Ropp_gt_lt_0_contravar in r. assumption. }
    rewrite <- H1 in H2.
    apply Rlt_le in r. apply Rle_not_gt in r. contradiction.
  - apply Rnot_lt_ge in n. apply Rge_le in n.
    assert (H2 : 0 >= Ropp x). {
      apply Ropp_0_le_ge_contravar in n. assumption. }
    assert (H3 : 0 < x). {
      inversion n. assumption. symmetry in H0. contradiction. }
    rewrite <- H1 in H2. apply Rge_not_lt in H2.
    contradiction.
Qed.

(* Hermitian matrices have real elements on the main diagonal *)
Lemma herm_diag_real {n : nat} (A : Square n) :
  forall (i : nat) (x : C), Herm A -> (i < n)%nat -> A i i = x -> snd x = 0.
Proof.
  intros. unfold Herm in H. unfold Cconj in H.
  remember (H i i) as H2.
  clear HeqH2. rewrite surjective_pairing in H1.
  rewrite H1 in H2. inversion H2.
  destruct (Req_dec (snd x) 0).
  - assumption.
  - apply real_neg_neq in H3. contradiction.
Qed.

(* Zero matrix is Hermitian *)
Lemma herm_Zero {n : nat} : Herm (@Zero n n).
Proof.
  intros i j. unfold Cconj. unfold Zero. simpl.
  rewrite Ropp_0. reflexivity.
Qed.

(* Identity matrix is Hermitian *)
Lemma herm_I {n : nat} : Herm (I n).
Proof.
  unfold Herm. unfold Cconj. unfold I.
  intros i j. rewrite <- (Nat.eqb_sym i j).
  destruct (i =? j) eqn:E.
  - assert (Hij : i = j). apply Nat.eqb_eq. assumption. subst.
    destruct (j <? n); simpl; rewrite Ropp_0; reflexivity.
  - simpl. rewrite Ropp_0; reflexivity.
Qed.

(* Real scalar times Hermitian matrix is Hermitian *)
Lemma herm_scale {n : nat} : forall (M : Square n) (r : R),
    Herm M -> Herm (r .* M).
Proof.
  intros M r H. unfold ".*". unfold Herm in *.
  intros i j. rewrite Cconj_mult_distr.
  rewrite <- H. rewrite Cconj_R.
  reflexivity.
Qed.

(* Sum of Hermitian matrices is Hermitian *)
Lemma herm_plus {n : nat} : forall (A B : Square n), Herm A -> Herm B -> Herm (A .+ B).
Proof.
  intros. unfold Herm in *. intros i j.
  unfold ".+". rewrite Cconj_plus_distr.
  rewrite <- H. rewrite <- H0. reflexivity.
Qed.

(* Product of Hermitian matrices is Hermitian if they commute *)
(* The converse of this is also true *)
Lemma herm_mult {n : nat} : forall (A B : Square n),
    WF_Matrix A -> WF_Matrix B ->
    Herm A -> Herm B ->
    Mat_commute A B ->
    Herm (A × B).
Proof.
  intros A B WFA WFB HA HB Hcomm. rewrite herm_defs_equivalent.
  - unfold Herm_alternate. rewrite Mmult_adjoint.
    rewrite herm_defs_equivalent in HA, HB; auto.
    rewrite <- HA. rewrite <- HB. apply Hcomm.
  - apply WF_mult; auto.
Qed.

(* Kronecker product of Hermitian matrices is Hermitian *)
Lemma herm_kron {n m : nat} : forall (A : Square n) (B : Square m),
    Herm A -> Herm B -> Herm (A ⊗ B).
Proof.
  intros A B HA HB.
  unfold Herm in *. intros i j.
  unfold kron. rewrite Cconj_mult_distr.
  rewrite <- (HA (i / m)%nat (j / m)%nat).
  rewrite <- (HB (i mod m)%nat (j mod m)%nat).
  reflexivity.
Qed.

(* Kronecker product of many Hermitian matrices is Hermitian *)
Lemma herm_big_kron {n : nat} : forall (L : list (Square n)),
    Forall Herm L -> Herm (⨂ L).
Proof.
  intros L H.
  induction L as [|A L'].
  - apply herm_I.
  - simpl. apply herm_kron.
    + apply Forall_inv in H. assumption.
    + apply IHL'. apply Forall_inv_tail with A. assumption.
Qed.

(* Hermitian matrices are diagonalizable *)
(* Tricky proof because it involves eigenvalues and eigenvectors; ran out of time to
   support these *)
Theorem herm_diagonalizable {n : nat} (A : Square n) :
  Herm A -> Diagonalizable A.
Proof.
Admitted.

(*******************************************)
(** Lemmas on diagonalization of matrices **)
(*******************************************)

(* Scalar times diagonal matrix is diagonal *)
Lemma diagonal_scale {n : nat} : forall (M : Square n) (c : C),
    Diagonal M -> Diagonal (c .* M).
Proof.
  intros. unfold Diagonal in *. intros i j Hij.
  unfold ".*". assert (H1 : M i j = 0). apply H. apply Hij.
  rewrite H1. apply Cmult_0_r.
Qed.

(* Scalar times diagonalizable matrix is diagonalizable *)
Lemma diag_scale {n : nat} : forall (M : Square n) (c : C),
    Diagonalizable M -> Diagonalizable (c .* M).
Proof.
  intros. unfold Diagonalizable in *.
  destruct H as [Tinv [D [T [H1 [H2 [H3 [H4 [H5 H6]]]]]]]].
  exists Tinv, (c .* D), T. unfold Diagonalization.
  repeat (split; try tauto).
  - apply diagonal_scale. auto.
  - rewrite Mscale_mult_dist_r. rewrite Mscale_mult_dist_l.
    rewrite <- H3. reflexivity.
  - apply WF_scale. auto.
Qed.

(* Commuting diagonalizable matrices are simultaneously diagonalizable *)
(* This proof is currently not needed so we have not attempted to prove it; however, we
   expect to need it in the future *)
Theorem Commute_sim_diag {n : nat} :
  forall (A B : Square n),
  Mat_commute A B ->
  Diagonalizable A ->
  Diagonalizable B ->
  (* We might need the explicit diagonalizations for the proof :
  forall TAinv TBinv DA DB TA TB
  Diagonalization TAinv DA TA A ->
  Diagonalization TBinv DB TB B ->
  *)
  Sim_diag A B.
Proof.
  (* This is gonna be tricky *)
  Admitted.

(* If a matrix M is diagonalizable as M = T^t * D * T, then e^M = T^t * e^D * T *)
(* This fact is true, but difficult to show because matrix_exponential is defined in terms
   of an infinite sum. This theorem was crucial however in simplifying many other proofs
   involving matrix exponentials *)
Theorem exp_diag_correct {n : nat} (M M_exp : Square n) :
    Diagonalizable M -> matrix_exponential M M_exp <-> is_exp_diag M M_exp.
Proof. Admitted.
(* We only really need to show the -> direction *)

(* e^D for diagonal matrix D is well-formed *)
Lemma exp_diag_preserves_WF {n : nat} :
  forall (D : Square n), WF_Matrix D -> Diagonal D -> @WF_Matrix n n (exp_diag D).
Proof.
  intros D HWF HD i j H. unfold exp_diag.
  destruct (i =? j) eqn:E.
  - apply beq_nat_true in E. subst. destruct (j <? n) eqn:F.
    + exfalso. apply Nat.ltb_lt in F. lia.
    + auto.
  - rewrite andb_false_r. auto.
Qed.

(* e^D for diagonal matrix D is diagonal *)
Lemma exp_diag_preserves_diag {n : nat} :
  forall (D : Square n), Diagonal D -> @Diagonal n (exp_diag D).
Proof.
  intros D H i j Hij. unfold exp_diag. apply eqb_neq in Hij.
  rewrite Hij. rewrite andb_false_r. reflexivity.
Qed.

(* 2 diagonalizations of the same matrix represent the same matrix *)
Lemma equivalent_diagonalizations {n : nat}:
  forall (T1inv D1 T1 T2inv D2 T2 M : Square n),
    Diagonalization T1inv D1 T1 M ->
    Diagonalization T2inv D2 T2 M ->
    T1inv × D1 × T1 = T2inv × D2 × T2.
Proof.
  intros T1inv D1 T1 T2inv D2 T2 M Hd1 Hd2.
  destruct Hd1 as [_ [_ [H1 _]]].
  destruct Hd2 as [_ [_ [H2 _]]].
  subst. auto.
Qed.

(* T1inv × D1 × T1 = T2inv × D2 × T2 implies T1inv × e^D1 × T1 = T2inv × e^D2 × T2 *)
Lemma exp_diag_preserves_equality {n : nat} :
  forall (T1inv D1 T1 T2inv D2 T2 M : Square n),
    Diagonalization T1inv D1 T1 M -> Diagonalization T2inv D2 T2 M ->
    T1inv × (exp_diag D1) × T1 = T2inv × (exp_diag D2) × T2.
Proof.
  intros T1inv D1 T1 T2inv D2 T2 M H1 H2.
  remember (equivalent_diagonalizations T1inv D1 T1 T2inv D2 T2 M H1 H2) as H. clear HeqH.
Admitted.

(***********************************)
(** Main diagonalization theorems **)
(***********************************)

(* For any diagonalizable matrix M, there is at least one matrix Mexp s.t. e^M = Mexp *)
Theorem mat_exp_well_defined_diag {n : nat} : forall (M : Square n),
    Diagonalizable M -> exists (Mexp : Square n), matrix_exponential M Mexp.
Proof.
  intros M H. remember H as Hd. clear HeqHd.
  unfold Diagonalizable in Hd.
  destruct Hd as [Tinv [D [T [H1 [H2 [H3 [H4 [H5 H6]]]]]]]].
  exists (Tinv × (exp_diag D) × T).
  rewrite exp_diag_correct; auto.
  unfold is_exp_diag.
  exists Tinv. exists D. exists T. split.
  - unfold Diagonalization; tauto.
  - unfold Diagonalization. repeat (try split; try tauto).
    + apply exp_diag_preserves_diag; auto.
    + apply exp_diag_preserves_WF; auto.
Qed.

Corollary mat_exp_well_defined_herm {n : nat} : forall (M : Square n),
    Herm M -> exists (Mexp : Square n), matrix_exponential M Mexp.
Proof.
  intros M H. apply mat_exp_well_defined_diag. apply herm_diagonalizable. auto.
Qed.

(* For any diagonalizable matrix M, there is at most one matrix Mexp s.t. e^M = Mexp *)
Theorem mat_exp_unique_diag {n : nat} : forall (M Mexp1 Mexp2 : Square n),
    Diagonalizable M ->
    matrix_exponential M Mexp1 ->
    matrix_exponential M Mexp2 ->
    Mexp1 = Mexp2.
Proof.
  intros M Mexp1 Mexp2 Hdiag H1 H2.
  rewrite (exp_diag_correct M Mexp1) in H1; auto.
  destruct H1 as [T1inv [D1 [T1 [HD1 HeD1]]]].
  rewrite (exp_diag_correct M Mexp2) in H2; auto.
  destruct H2 as [T2inv [D2 [T2 [HD2 HeD2]]]].
  assert (H : T1inv × D1 × T1 = T2inv × D2 × T2). {
    apply equivalent_diagonalizations with M; assumption.
  }
  destruct HeD1 as [_ [_ [H2 [_ [_ _]]]]].
  destruct HeD2 as [_ [_ [H3 [_ [_ _]]]]].
  rewrite H2. rewrite H3.
  apply exp_diag_preserves_equality with M; unfold Diagonalization in *; tauto.
Qed.

Corollary mat_exp_unique_herm {n : nat} : forall (M Mexp1 Mexp2 : Square n) (c : C),
    Herm M ->
    matrix_exponential (c .* M) Mexp1 ->
    matrix_exponential (c .* M) Mexp2 ->
    Mexp1 = Mexp2.
Proof.
  intros M Mexp1 Mexp2 c Hdiag H1 H2.
  apply mat_exp_unique_diag with (c .* M); auto.
  apply diag_scale. apply herm_diagonalizable. apply Hdiag.
Qed.

(* For any diagonalizable matrix M, e^M is well-formed *)
Theorem mat_exp_WF_diag {n : nat} : forall (M Mexp : Square n),
    Diagonalizable M -> matrix_exponential M Mexp -> WF_Matrix M -> WF_Matrix Mexp.
Proof.
  intros M Mexp Hherm HM H_WF.
  rewrite (exp_diag_correct M Mexp) in HM.
  - destruct HM as [Tinv [D [T [HD HeD]]]].
    destruct HD as  [H1 [H2 [H3 [H4 [H5 H6]]]]].
    destruct HeD as [H7 [H8 [H9 [H10 [H11 H12]]]]].
    rewrite H9. apply WF_mult; auto.
    apply WF_mult; auto.
  - auto.
Qed.

Corollary mat_exp_WF_herm {n : nat} : forall (M Mexp : Square n) (c : C),
    Herm M -> matrix_exponential (c .* M) Mexp -> WF_Matrix M -> WF_Matrix Mexp.
Proof.
  intros M Mexp c Hherm HM H_WF.
  apply mat_exp_WF_diag with (c .* M); auto.
  - apply diag_scale. apply herm_diagonalizable. auto.
  - apply WF_scale. auto.
Qed.

(* For any diagonalizable matrices M and N, if M and N commute then e^M × e^N = e^{M+N} *)
Theorem mat_exp_commute_add_diag {n : nat} : forall (M N SM SN SMN : Square n),
    Diagonalizable M ->
    Diagonalizable N ->
    matrix_exponential M SM ->
    matrix_exponential N SN ->
    matrix_exponential (M .+ N) SMN ->
    Mat_commute M N ->
    SM × SN = SMN.
Proof. Admitted.
  (* This theorem statement is mathematically true, but it is currently not provable using
     the lemmas we have so far, because Diagonalizable (M + N) is not true in general.

  intros M N SM SN SMN HM HN HSM HSN HSMN Hcomm.
  rewrite (exp_diag_correct M SM) in HSM; auto.
  rewrite (exp_diag_correct N SN) in HSN; auto.
  rewrite (exp_diag_correct (M .+ N) SMN) in HSMN. try (apply diag_plus; auto).
  destruct HSM as [TMinv [DM [TM [HDM [HeDM [_ [_ _]]]]]]].
  destruct HSN as [TNinv [DN [TN [HDN [HeDN [_ [_ _]]]]]]].
  destruct HSMN as [TMNinv [DMN [TMN [HDMN [HeDMN [_ [_ _]]]]]]].
  Admitted.
*)


Require Import Arith.
Require Import Omega.
Require Import Recdef.
Require Import List.
Require Import Program.Tactics.
Import ListNotations.

Section Lecture6.

  (* True iff the list’s elements are in decreasing order *)
  Inductive Dec : list nat -> Prop :=
  | DNil : Dec []
  | DCons : forall a l,
      (forall b, In b l -> a <= b) ->
      Dec l ->
      Dec (a :: l).
  Hint Constructors Dec.

  (* True iff the list’s elements are in INcreasing order *)
  Inductive Inc : list nat -> Prop :=
  | INil : Inc []
  | ICons : forall a l,
      (forall b, In b l -> b <= a) ->
      Inc l ->
      Inc (a :: l).
  Hint Constructors Inc.

  (* A fact about appending increasing lists *)
  Lemma Inc_app xs ys:
    Inc xs -> Inc ys ->
    (forall x y, In x xs -> In y ys -> y <= x) ->
    Inc (xs ++ ys).
  Admitted.

  Lemma Dec_rev xs: Dec (rev xs) -> Inc xs.
  Abort.

End Lecture6.


(** * Reasoning About Distributions *)

Require Export Intervals.

Inductive dist T:Type : Type :=
  | Unit : T -> dist T
  | Combine : forall (p:R), 0 < p < 1 -> dist T -> dist T -> dist T.

Arguments Unit {T} _.
Arguments Combine {T} p v d1 d2.

Notation "~ X" := (fun t => negb (X t)).
Notation "X1 && X2 " := (fun t => andb (X1 t) (X2 t)).
Notation "X1 || X2 " := (fun t => orb (X1 t) (X2 t)).

Fixpoint probability {T:Type} (d:dist T) (X: T -> bool): R :=
  match d with
  | Unit t => if X t then 1 else 0
  | Combine p v d1 d2 =>
    p * (probability d1 X) + (1-p) * (probability d2 X)
  end.

Notation "'Pr' X 'in' d"  := (probability d X) (at level 40).

(** ** Basic Theorems of Probability Theory *)

(** Lemma 2.4: Normality *)
Theorem pr_normality : forall {T:Type} (d : dist T) X,
  0 <= Pr X in d <= 1.
Proof.
  intros.
  induction d as [t |].
  + simpl.
    destruct (X t); lra.
  + simpl.
    apply in_0_1_closed. assumption.
    apply IHd1.
    apply IHd2.
Qed.

(** Lemma 2.5: Tautology *)
Lemma pr_tautology : forall {T:Type} (d : dist T) X,
  (forall t, X t = true) ->
  Pr X in d = 1.
Proof.
  intros.
  induction d as [t |].
  + simpl.
    rewrite H.
    reflexivity.
  + simpl in *.
    rewrite IHd1, IHd2.
    lra.
Qed.

(** Lemma 2.6: Contradiction *)
Lemma pr_contradiction : forall {T:Type} (d : dist T) X,
  (forall t, X t = false) ->
  Pr X in d = 0.
Proof.
  intros.
  induction d as [t |].
  + simpl.
    rewrite H.
    reflexivity.
  + simpl in *.
    rewrite IHd1, IHd2.
    lra.
Qed.

(** Lemma 2.7 Equivalence *)
Lemma pr_equivalence: forall {T:Type} (d : dist T) X X',
  (forall t, X t = X' t) ->
  Pr X in d = Pr X' in d.
Proof.
  intros.
  induction d.
  simpl.
  rewrite H.
  reflexivity.
  simpl.
  rewrite IHd1, IHd2.
  reflexivity.
Qed.

Lemma pr_totality : forall {T:Type} (d : dist T) X,
  probability d X + probability d (~X) = 1.
Proof.
  intros.
  induction d.
  + simpl.
    destruct (X t); simpl; lra.
  + simpl in *.
    rewrite <- Rplus_assoc.
    rewrite Rplus_assoc with (r1 := p * (Pr X in d1))
                             (r2 := (1 - p) * (Pr X in d2))
                             (r3 := p * (Pr ~X in d1)).
    rewrite Rplus_comm with (r1 := (1 - p) * (Pr X in d2))
                            (r2 := p * (Pr ~X in d1)).
    rewrite <- Rplus_assoc.
    rewrite Rplus_assoc.
    rewrite <- Rmult_plus_distr_l.
    rewrite <- Rmult_plus_distr_l.
    rewrite IHd1.
    rewrite IHd2.
    lra.
Qed.

(** Lemma 2.8: Complement *)
Lemma pr_complement : forall {T:Type} (d : dist T) X,
  Pr (~X) in d = 1 - Pr X in d.
Proof.
  intros.
  specialize (pr_totality d X). intros Eq.
  lra.
Qed.

(** Lemma 2.9: Disjunction *)
Lemma pr_disjunction : forall {T:Type} (d : dist T) X1 X2,
  Pr (X1 || X2) in d = Pr X1 in d + Pr X2 in d - Pr (X1 && X2) in d.
Proof.
  induction d; intros.
  + simpl in *.
    destruct (X1 t), (X2 t); simpl; lra.
  + simpl in *.
    rewrite IHd1; trivial.
    rewrite IHd2; trivial.
    lra.
Qed.

Lemma pr_addition : forall {T:Type} (d : dist T) X1 X2,
  (forall t, (X1 && X2) t = false) ->
  Pr (X1 || X2) in d = Pr X1 in d + Pr X2 in d.
Proof.
  intros.
  rewrite <- Rminus_0_r.
  replace 0 with (Pr (X1 && X2) in d).
  Focus 2.  apply pr_contradiction. assumption.
  apply pr_disjunction.
Qed.

(** ** Rules for Bounding Probabilities *)

Lemma pr_union_bound : forall {T:Type} (d : dist T) X1 X2,
  Pr (X1 || X2) in d <= Pr X1 in d + Pr X2 in d.
Proof.
  intros.
  specialize (pr_disjunction d X1 X2); intros.
  specialize (pr_normality d (X1 && X2)); intros.
  lra.
Qed.

Lemma pr_weaken : forall {T:Type} (d : dist T) X X',
  (forall t, X t = true -> X' t = true) ->
  Pr X in d <= Pr X' in d.
Proof.
  intros.
  induction d.
  + simpl.
    specialize (H t).
    destruct (X t), (X' t); try lra.
    assert (false=true) as contra by (apply H; reflexivity).
    inversion contra.
  + simpl.
    apply Rmult_le_compat_l with (r:=p) in IHd1; try lra.
    apply Rmult_le_compat_l with (r:=(1-p)) in IHd2; lra.
Qed.

Lemma pr_strengthen : forall {T:Type} (d : dist T) X X',
  (forall t, X' t = true -> X t = true) ->
  Pr X in d >= Pr X' in d.
Proof.
  intros.
  induction d.
  + simpl.
    specialize (H t).
    destruct (X t), (X' t); try lra.
    assert (false=true) as contra by (apply H; reflexivity).
    inversion contra.
  + simpl.
    apply Rmult_ge_compat_l with (r:=p) in IHd1; try lra.
    apply Rmult_ge_compat_l with (r:=(1-p)) in IHd2; lra.
Qed.

Lemma pr_disj_ge_l : forall {T:Type} (d : dist T) X1 X2,
  Pr (X1 || X2) in d >= Pr X1 in d.
Proof.
  intros; simpl.
  apply pr_strengthen.
  simpl; intros.
  destruct (X1 t), (X2 t); trivial; inversion H.
Qed.

Lemma pr_disj_ge_r : forall {T:Type} (d : dist T) X1 X2,
  Pr (X1 || X2) in d >= Pr X2 in d.
Proof.
  intros; simpl.
  apply pr_strengthen.
  simpl; intros.
  destruct (X1 t), (X2 t); trivial; inversion H.
Qed.

Lemma pr_conj_le_l : forall {T:Type} (d : dist T) X1 X2,
  Pr (X1 && X2) in d <= Pr X1 in d.
Proof.
  intros; simpl.
  apply pr_weaken.
  simpl; intros.
  destruct (X1 t), (X2 t); trivial; inversion H.
Qed.

Lemma pr_conj_le_r : forall {T:Type} (d : dist T) X1 X2,
  Pr (X1 && X2) in d <= Pr X2 in d.
Proof.
  intros; simpl.
  apply pr_weaken.
  simpl; intros.
  destruct (X1 t), (X2 t); trivial; inversion H.
Qed.

Lemma pr_ge_bound : forall {T:Type} (d : dist T) X1 X2 p1 p2,
  (forall t, (X1 && X2) t = false) ->
  Pr X1 in d >= p1 ->
  Pr X2 in d >= p2 ->
  p1 + p2 = 1 ->
  Pr X1 in d = p1 /\ Pr X2 in d = p2.
Proof.
  intros.
  specialize (pr_addition d X1 X2 H); intros.
  assert (Pr (X1 || X2) in d >= p1 + p2) by lra.
  specialize (pr_normality d (X1 || X2)). intros.
  lra.
Qed.

(** *** The base states are deterministic *)

Theorem pr_unit : forall {T:Type} (t:T) X,
  Pr X in (Unit t) = 0 \/ Pr X in (Unit t) = 1.
Proof.
  intros.
  simpl.
  destruct (X t); lra.
Qed.

(** *** Combining and Splitting Distributions *)

(** Lemma 2.10: Combine *)
Lemma pr_combine : forall {T:Type} (d1 d2 : dist T) X p v r,
  Pr X in d1 = r ->
  Pr X in d2 = r ->
  Pr X in Combine p v d1 d2 = r.
Proof.
  intros.
  simpl in *.
  rewrite H, H0.
  lra.
Qed.

(** Lemma 2.11: Split (0) *)
Lemma pr_split_0 : forall {T:Type} (d1 d2 : dist T) X p v,
  Pr X in Combine p v d1 d2 = 0 ->
  Pr X in d1 = 0 /\ Pr X in d2 = 0.
Proof.
  intros.
  apply sum_to_0 with (p:=p); trivial; try apply pr_normality.
Qed.

(** Lemma 2.11: Split (1) *)
Lemma pr_split_1 : forall {T:Type} (d1 d2 : dist T) X p v,
  Pr X in Combine p v d1 d2 = 1 ->
  Pr X in d1 = 1 /\ Pr X in d2 = 1.
Proof.
  intros.
  apply sum_to_1 with (p:=p); trivial; try apply pr_normality.
Qed.

(** *** Useful Rules for Zero and One *)

Lemma pr_complement_1 : forall {T:Type} (d : dist T) X,
  Pr X in d = 1 <-> Pr (~X) in d = 0.
Proof. intros. rewrite pr_complement. lra. Qed.

Lemma pr_complement_0 : forall {T:Type} (d : dist T) X,
  Pr X in d = 0 <-> Pr (~X) in d = 1.
Proof. intros. rewrite pr_complement. lra. Qed.

Lemma pr_weaken_1: forall {T:Type} (d : dist T) X X',
  (forall t, X t = true -> X' t = true) ->
  Pr X in d = 1 ->
  Pr X' in d = 1.
Proof.
  intros.
  induction d.
  + simpl in *.
    destruct (X t) eqn:Eqx, (X' t) eqn:Eqx'; trivial.
    apply H in Eqx. rewrite Eqx in Eqx'. inversion Eqx'.
  + apply pr_split_1 in H0 as (H1 & H2).
    simpl. rewrite IHd1, IHd2; trivial. lra.
Qed.

Lemma pr_strengthen_0: forall {T:Type} (d : dist T) X X',
  (forall t, X' t = true -> X t = true) ->
  Pr X in d = 0 ->
  Pr X' in d = 0.
Proof.
  intros.
  induction d.
  + simpl in *.
    destruct (X t) eqn:Eqx, (X' t) eqn:Eqx'; trivial.
    apply H in Eqx'. rewrite Eqx in Eqx'. inversion Eqx'.
  + apply pr_split_0 in H0 as (H1 & H2).
    simpl. rewrite IHd1, IHd2; trivial. lra.
Qed.

Lemma pr_conj_0_l : forall {T:Type} (d : dist T) X1 X2,
  Pr X1 in d = 0 -> Pr (X1 && X2) in d = 0.
Proof.
  intros.
  specialize (pr_conj_le_l d X1 X2).
  specialize (pr_normality d (X1 && X2)).
  intros.
  lra.
Qed.

Lemma pr_conj_0_r : forall {T:Type} (d : dist T) X1 X2,
  Pr X2 in d = 0 -> Pr (X1 && X2) in d = 0.
Proof.
  intros.
  specialize (pr_conj_le_r d X1 X2).
  specialize (pr_normality d (X1 && X2)).
  intros.
  lra.
Qed.

Lemma pr_conj_1_l : forall {T:Type} (d : dist T) X1 X2,
  Pr X1 in d = 1 -> Pr (X1 && X2) in d = Pr X2 in d.
Proof.
  intros.
  induction d.
  + simpl in *.
    destruct (X1 t), (X2 t); trivial; lra.
  + simpl.
    simpl in H.
    apply sum_to_1 in H; trivial; try apply pr_normality.
    destruct H.
    rewrite IHd1, IHd2; trivial.
Qed.

Lemma pr_conj_1_r : forall {T:Type} (d : dist T) X1 X2,
  Pr X2 in d = 1 -> Pr (X1 && X2) in d = Pr X1 in d.
Proof.
  intros.
  rewrite pr_equivalence with (X' := (X2 && X1)).
  apply pr_conj_1_l. assumption.
  intros.
  destruct (X1 t), (X2 t); reflexivity.
Qed.

Lemma pr_conj_1 : forall {T:Type} (d : dist T) X1 X2,
  Pr X1 in d = 1 ->
  Pr X2 in d = 1 ->
  Pr (X1 && X2) in d = 1.
Proof.
  intros.
  rewrite <- H.
  apply pr_conj_1_r.
  assumption.
Qed.


Require Import List NArith.
Import N.

Local Open Scope list_scope.
Local Open Scope N_scope.

Module BV.

  Definition t := (list bool * N)%type.

  Definition empty : t := (nil, 0).

  Definition concat (b1 b2 : t) : t :=
    let (b1, n1) := b1 in
    let (b2, n2) := b2 in
    (b1 ++ b2, n1 + n2).

  Definition bvnot (bv1 : t) : t :=
    let (b1, n1) := bv1 in
    (List.map negb b1, n1).

  (* how to ensure they have same N? *)
  Fixpoint bl_map2 (l1 : list bool) (l2 : list bool)
                   (f : bool -> bool -> bool) : list bool :=
    match l1 with
      | nil => nil
      | cons b1 tl1 =>
        match l2 with
          | nil => nil
          | cons b2 tl2 => cons (f b1 b2) (bl_map2 tl1 tl2 f)
        end
    end.

  Definition bvand (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    (bl_map2 b1 b2 andb, n1).

  Definition bvor (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    (bl_map2 b1 b2 orb, n1).

  Definition bvxor (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    (bl_map2 b1 b2 xorb, n1).

  Definition bvlow (bv1 : t) : bool :=
    let (b1, n1) := bv1 in
    match b1 with
      | nil => false
      | x :: _ => x
    end.

  Definition bvhigh (bv1 : t) : bool :=
    let (b1, n1) := bv1 in
    (List.last b1 false).

  Definition bvshiftleft (bv1 : t) : t :=
    let (b1, n1) := bv1 in
    (cons false (List.removelast b1), n1).

  Definition bvshiftright (bv1 : t) : t :=
    let (b1, n1) := bv1 in
    ((List.tl b1) ++ (cons false nil), n1).

  Fixpoint bvshiftleft_n (bv1 : t) (n1 : nat) : t :=
    match n1 with
      | O => bv1
      | S n2 => bvshiftleft_n (bvshiftleft bv1) n2
    end.

  Fixpoint bvshiftright_n (bv1 : t) (n1 : nat) : t :=
    match n1 with
      | O => bv1
      | S n2 => bvshiftright_n (bvshiftright bv1) n2
    end.

  Fixpoint bl2n (l : list bool) (c : N) (c2 : N) : N :=
    match l with
      | nil => c
      | cons true l2 => bl2n l2 (c + c2) (c2 + c2)
      | cons false l2 => bl2n l2 c (c2 + c2)
    end.

  Definition bv2n (bv1 : t) : N :=
    let (b1, n1) := bv1 in
    (bl2n b1 0 1).

  Fixpoint nb2bl (n : positive) : list bool :=
    match n with
      | xO p => false :: nb2bl p
      | xI p => true :: nb2bl p
      | xH => true :: nil
    end.

  Definition n2bl (n : N) : list bool :=
    match n with
      | 0 => cons false nil
      | 1 => cons true nil
      | pos p => nb2bl p
    end.

  Definition bvadd (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n3 := (bv2n bv1) in
    let n4 := (bv2n bv2) in
    let n5 := (n3 + n4) in
    let b3 := (n2bl n5) in
    (b3, n1).

  Definition bvsub (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n3 := (bv2n bv1) in
    let n4 := (bv2n bv2) in
    let n5 := (n3 - n4) in
    let b3 := (n2bl n5) in
    (b3, n1).

  Definition bvmul (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n3 := (bv2n bv1) in
    let n4 := (bv2n bv2) in
    let n5 := (n3 * n4) in
    let b3 := (n2bl n5) in
    (b3, n1).

  Definition bvneg (bv1 : t) (n : N) : t :=
    let (b1, n1) := bv1 in
    let n2 := 2 ^ n in
    let n3 := (bv2n bv1) in
    let n4 := n2 - n3 in
    ((n2bl n4), n).

  Definition bvudiv (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n4 := (bv2n bv2) in
    match n4 with
      | 0 => (nil, 0)
      | _ =>
      let n3 := (bv2n bv1) in
      ((n2bl (n3 / n4)), n1)
    end.

  Definition bvurem (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n4 := (bv2n bv2) in
    match n4 with
      | 0 => (nil, 0)
      | _ =>
      let n3 := (bv2n bv1) in
      ((n2bl (n3 mod n4)), n1)
    end.

  Definition bvult (bv1 : t) (bv2 : t) :=
    let n1 := (bv2n bv1) in
    let n2 := (bv2n bv2) in
    (n1 < n2).

  Fixpoint drop_n (l : list bool) (n : nat) : list bool :=
    match n with
      | O => l
      | S n2 => drop_n (@List.tl bool l) n2
    end.

  Fixpoint first_n (l : list bool) (n : nat) : list bool :=
    match n with
      | O => nil
      | S n2 =>
      match l with
        | nil => nil
        | x :: l2 => x :: (first_n l2 n2)
      end
    end.

  Definition extract (l : list bool) (i : nat) (j : nat) : list bool :=
    let l2 := drop_n l i in
    (first_n l2 j).

  (* Check nth. *)
  Definition bb_nth (i : nat) (bv1 : t) : bool :=
    let (b1, n1) := bv1 in
    nth i b1 false.

End BV.

Module BVProof.

  Import BV.

  Definition bitof (bv : t)(m : nat) :=
    bb_nth m bv.

  Definition bblt_len (bv : t) :=
    let (b, n) := bv in
    n.

  Definition wf (bv:t) : Prop :=
     let (b,n) := bv in N.of_nat (length b) = n.

  Check N.of_nat.
  Print N.of_nat.
  SearchAbout N.of_nat.
  Search (N.of_nat (_ + _) = (N.of_nat _) + (N.of_nat _)).

  Lemma concat_wf : forall (bv1 bv2:t), wf bv1 -> wf bv2 -> wf (concat bv1 bv2).
  Proof.
    intros [b1 n1] [b2 n2] H1 H2.
    simpl.
    Search ((length (_ ++ _)) = ((length _) + (length _))%nat).
    SearchAbout length.
    rewrite app_length.
    rewrite Nat2N.inj_add.
    simpl in H1. simpl in H2.
    rewrite H1. rewrite H2.
    reflexivity.
  Qed.

  Lemma nth_append1 : forall A (l1 l2:list A) (i:nat) (d:A),
    (i < length l1)%nat -> nth i (l1 ++ l2) d = nth i l1 d.
  Proof.
    intros A. induction l1.
    - simpl. Search (~ ((_ < 0)%nat)).
      intros l2 i d H. elim (Lt.lt_n_0 _ H).
    - simpl. intros l2 [ |i] d Hi.
      * reflexivity.
      * apply IHl1. apply Lt.lt_S_n. assumption.
  Qed.

  Lemma of_nat_lt : forall i j,
    (of_nat i < of_nat j) -> (i < j)%nat.
  Admitted.

  Check nth.
  Lemma nth_wf : forall(bv1 bv2:t) (i : nat),
   let (b1, n1) := bv1 in
   wf bv1 -> wf bv2 -> (of_nat i < n1) -> bb_nth i (concat bv1 bv2) = bb_nth i bv1.
  Proof.
   intros [b1 n1] [b2 n2]. simpl. intros i H1 H2 Hi.
   rewrite nth_append1.
     - reflexivity.
     - rewrite <- H1 in Hi.
       apply of_nat_lt.
       assumption.
  Qed.

(* term *)
Definition formula := Type.
Definition sort := Type.
Definition term := sort -> Type.

Definition BitVec := nat -> sort.

Inductive bit :=
| b0
| b1.

(*
Definition const_bv := Type.
Definition bvn := const_bv.
Definition bvc := (bool * const_bv)
*)

Inductive const_bv :=
| bvn : const_bv
| bvc : bit -> const_bv ->const_bv.

Definition toBV (n : nat) (v : const_bv) :=
  (term (BitVec n)).
(* SC := n = bv_len v *)

Definition concat (t1 :term) (t2 :term) :=
  let (term (BitVec n)) := t1 in
  let (term (BitVec m)) := t2 in
  let m' := n + m in
  (term (BitVec m')).

Inductive bblt :=
| bbltn : bblt
| bbltc : formula -> bblt ->bblt.

Definition bblast_term := nat -> term -> bblt -> Type.

Definition var_bv := Type.

Definition bitof := var_bv -> nat -> formula.

Definition a_var_bv (n :nat) :=
  (term (BitVec n)).

Fixpoint bblt_len (v :bblt) : nat :=
  match v with
  | bbltn => 0
  | bbltc b v' => (bblt_len v') + 1
  end.

Definition decl_bblast (n :nat) (b : bblt)
  (t : term (BitVec n)) (bb : bblast_term) :=
  match (bblt_len b) with
  | n => (* (bblast_term n t b)?? *) abort
  | _ => abort
  end.

Definition bblast_var (x : var_bv) (n :nat) : bblt :=
  (bbltc (bitof x n) (bblast_var x (n - 1))).

Definition bv_bbl_var (n : nat)(x : var_bv)(f : bblt) :=
  match (bblast_var x (n - 1)) with
  | f => (bblast_term n (a_var_bv n x) f)
  | _ => abort
  end.

Definition bblast_bvand (x : bblt) (y : bblt) : bblt :=
  match x with
  | bbltn =>
    match y with
    | bbltn => bbltn
    | bbltc y''' y'' => abort
    end
  | bbltc bx x' =>
    match y with
    | bbltn => abort
    | bbltc by y' => (bbltc (and bx by) (bblast_bvand x' y'))
    end
  end.

Definition bv_bbl_bvand (n : nat) (x : (term (BitVec n))) (y : (term (BitVec n)))
  (xb : bblt) (yb : bblt) (rb : bblt)
  (xbb : (bblast_term n x xb)) (ybb : (bblast_term n y yb)) :=
  match (bblast_bvadd xb yb) with
  | rb => (bblast_term n (bvadd n x y) rb)
  | _ => abort
  end.

Fixpoint bblt_bvand_carry (a : bblt) (b : bblt) (c : formula) : formula :=
  match a with
  | bbltn =>
    match b with
    | bbltn => c
    | _ => abort
    end
  | bbltc ai a' =>
    match b with
    | bbltn => abort
    | bbltc bi b' => (or (and ai bi) (and xor ai bi) (bblt_bvand_carry a' b' c))
    end
  end.

Fixpoint bblast_bvand (a : bblt) (b : bblt) (carry : formula) : bblt :=
  match a with
  | bbltn =>
    match b with
    | bbltn => bbltn
    | _ => abort
    end
  | bbltc ai a' =>
    match b with
    | bbltn => abort
    | bbltc bi b' =>
      (bbltc (xor ai (xor bi (bblt_bvadd_carry a' b' carry))) (bblast_bvadd a' b' carry))
    end
  end.

Definition bv_bbl_bvadd (n : nat) (x : (term (BitVec n))) (y : (term (BitVec n)))
  (xb : bblt) (yb : bblt) (rb : bblt)
  (xbb : (bblast_term n x xb)) (ybb : (bblast_term n y yb)) :=
  match (bblast_bvadd xb yb) with
  | rb => (bblast_term n (bvadd n x y) rb)
  | _ => abort
  end.

End BVProof.