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

(** Extraction of breadth-first numbering algorithm from Coq to Ocaml

       see http://okasaki.blogspot.com/2008/07/breadth-first-numbering-algorithm-in.html
       and https://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/jfp95queue.pdf
       and https://www.cs.cmu.edu/~rwh/theses/okasaki.pdf
       and https://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/icfp00bfn.pdf

*)

Require Import List Arith Omega Extraction.
Require Import list_utils wf_utils bt bft bft_spec fifo.

Set Implicit Arguments.

Section seq_an.

  (* seq_an a n = [a;a+1;...;a+(n-1)] *)

  Fixpoint seq_an a n : list nat :=
    match n with
      | 0    => nil
      | S n  => a::seq_an (S a) n
    end.

  Fact seq_an_length a n : length (seq_an a n) = n.
  Proof. revert a; induction n; simpl; intros; f_equal; auto. Qed.

  Fact seq_an_spec a n x : In x (seq_an a n) <-> a <= x < a+n.
  Proof.
    revert x a; induction n as [ | n IHn ]; intros x a; simpl;
      [ | rewrite IHn ]; omega.
  Qed.

  Fixpoint is_seq_from n (l : list nat) { struct l }: Prop :=
    match l with
      | nil  => True
      | x::l => n = x /\ is_seq_from (S n) l
    end.

  Theorem is_seq_from_spec a l : is_seq_from a l <-> exists n, l = seq_an a n.
  Proof.
    revert a; induction l as [ | x l IH ]; intros a; simpl.
    + split; auto; exists 0; auto.
    + rewrite IH; split.
      * intros (? & n & Hn); subst x; exists (S n); subst; auto.
      * intros ([ | n ] & ?); subst; try discriminate.
        simpl in H; inversion H; subst; split; auto.
        exists n; auto.
  Qed.

End seq_an.

Section bfn.

  Let fifo_3q_sum { X } (q : fifo_3q (bt X)) := lsum (fifo_3q_list q).

  Variable (X : Type).

  Notation fX := (fifo_3q (bt X)).
  Notation fN := (fifo_3q (bt nat)).

  (* the forest (list of bt nat) is a breadth first numbering from n if
     its breadth first traversal yields [n;n+1;....;m[ for some m
   *)

  Let fX_spec := fifo_3q_spec (bt X).
  Let fN_spec := fifo_3q_spec (bt nat).

  Definition is_bfn_from n l := is_seq_from n (bft_f l).

  (* Breath First Numbering: maps a forest X to a forest nat such that
          1) the two forests are of the same shape
          2) the result is a breadth first numbering from n

     Beware that the output is a reversed queue compared to the input
   *)

  Definition bfn_3q_f n (p : fX) : { q : fN | fifo_3q_list p ~lt rev (fifo_3q_list q) /\ is_bfn_from n (rev (fifo_3q_list q)) }.
  Proof.
    induction on n p as bfn_3q_f with measure (fifo_3q_sum p).
    refine (match fifo_3q_void p as b return fifo_3q_void p = b -> _ with
      | true  => fun H1 => exist _ fifo_3q_nil _
      | false => fun H1 => _
    end eq_refl).
    { apply fifo_3q_void_spec in H1.
      rewrite H1, fifo_3q_nil_spec; split; simpl; auto.
      red; rewrite bft_f_fix_0; simpl; auto. }
    assert (fifo_3q_list p <> nil) as H2.
    { intro E; apply fifo_3q_void_spec in E; rewrite E in H1; discriminate. }
    refine (match fifo_3q_deq p H2 as k return fifo_3q_deq p H2 = k -> _ with
      | (leaf x ,p') => _
      | (node a x b, p') => _
    end eq_refl); intros H3.
    + generalize (fifo_3q_deq_spec _ H2); rewrite H3; intros H4.
      refine (let (q,Hq) := bfn_3q_f (S n) p' _ in exist _ (fifo_3q_enq q (leaf n)) _).
      { unfold fifo_3q_sum; rewrite H4; simpl; omega. }
      destruct Hq as (H5 & H6).
      rewrite H4, fifo_3q_enq_spec.
      subst; split; auto.
      rewrite rev_app_distr; simpl; auto.
      rewrite rev_app_distr; simpl; red.
      rewrite bft_f_fix_3; simpl; rewrite <- app_nil_end; auto.
    + generalize (fifo_3q_deq_spec _ H2); rewrite H3; intros H4.
      refine (let (q,Hq) := bfn_3q_f (S n) (fifo_3q_enq (fifo_3q_enq p' a) b) _ in _).
      { unfold fifo_3q_sum.
        rewrite fifo_3q_enq_spec, fifo_3q_enq_spec, app_ass; simpl.
        rewrite lsum_app, H4; simpl; omega. }
      destruct Hq as (H5 & H6).
      rewrite fifo_3q_enq_spec, fifo_3q_enq_spec, app_ass in H5; simpl in H5.
      assert (2 <= length (fifo_3q_list q)) as H7.
      { apply Forall2_length in H5.
        rewrite app_length, rev_length in H5.
        simpl in H5; omega. }
      assert (fifo_3q_list q <> nil) as H8.
      { revert H7; destruct (fifo_3q_list q); simpl; try discriminate; intro; omega. }
      generalize (fifo_3q_deq_spec _ H8).
      refine (match fifo_3q_deq _ H8 with (u,q') => _ end); intros H9.
      assert (fifo_3q_list q' <> nil) as H10.
      { revert H7; rewrite H9; destruct (fifo_3q_list q'); simpl; try discriminate; intro; omega. }
      generalize (fifo_3q_deq_spec _ H10).
      refine (match fifo_3q_deq _ H10 with (v,q'') => _ end); intros H11.
      exists (fifo_3q_enq q'' (node v n u)).
      rewrite H4, fifo_3q_enq_spec, rev_app_distr; simpl.
      rewrite H9, H11 in H5; simpl in H5; rewrite app_ass in H5; simpl in H5.
      rewrite H9, H11 in H6; simpl in H6; rewrite app_ass in H6; simpl in H6.
      unfold is_bfn_from in H6 |- *.
      apply Forall2_2snoc_inv in H5.
      destruct H5 as (G1 & G2 & H5).
      rewrite bft_f_fix_3; simpl; split; auto.
  Defined.

  Section bfn.

    Let bfn_3q_full (t : bt X) : { t' | t ~t t' /\ is_seq_from 0 (bft_std t') }.
    Proof.
      refine (match @bfn_3q_f 0 (fifo_3q_enq fifo_3q_nil t) with exist _ q Hq => _ end).
      rewrite fifo_3q_enq_spec, fifo_3q_nil_spec in Hq; simpl in Hq.
      destruct Hq as (H1 & H2).
      assert (fifo_3q_list q <> nil) as H3.
      { apply Forall2_length in H1; rewrite rev_length in H1.
        destruct (fifo_3q_list q); discriminate. }
      generalize (fifo_3q_deq_spec _ H3).
      refine (match fifo_3q_deq _ H3 with (x,q') => _ end); intros H4.
      exists x.
      rewrite <- bft_std_eq_bft.
      rewrite H4 in H1; simpl in H1.
      apply Forall2_snoc_inv with (l := nil) in H1.
      destruct H1 as (G1 & H1).
      apply Forall2_nil_inv_right in H1.
      apply f_equal with (f := @rev _) in H1.
      rewrite rev_involutive in H1; simpl in H1.
      rewrite H4, H1 in H2; simpl in H2.
      auto.
    Qed.

    Definition bfn_3q t := proj1_sig (bfn_3q_full t).

    Fact bfn_3q_spec_1 t : t ~t bfn_3q t.
    Proof. apply (proj2_sig (bfn_3q_full t)). Qed.

    Fact bfn_3q_spec_2 t : exists n, bft_std (bfn_3q t) = seq_an 0 n.
    Proof. apply is_seq_from_spec, (proj2_sig (bfn_3q_full t)). Qed.

    Corollary bfn_3q_spec_3 t : bft_std (bfn_3q t) = seq_an 0 (m_bt t).
    Proof.
      destruct (bfn_3q_spec_2 t) as (n & Hn).
      rewrite Hn.
      apply f_equal with (f := @length _) in Hn.
      rewrite seq_an_length, bft_std_length in Hn.
      generalize (bfn_3q_spec_1 t); intros E.
      apply bt_eq_m in E.
      rewrite <- Hn, <- E; trivial.
    Qed.

  End bfn.

End bfn.

(* Notice that fifo_3q_deq is extracted to a function that loops forever
   if the input is the empty queue, ie does not following the spec *)

Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Inductive nat => int [ "0" "succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))".

Recursive Extraction bfn_3q.

Check bfn_3q.
Check bfn_3q_spec_1.
Check bfn_3q_spec_2.
Check bfn_3q_spec_3.


Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Definition left_two : nat + nat := inl _ 2.
Print left_two.

Definition left_two' := inl nat 2.
Print left_two'.

Context (A B C : Type).

Definition compose : (A -> B) -> (B -> C) -> (A -> C)
  := fun f g => (fun x => g (f x)).

Definition addtwo_or_subtractone : nat + nat -> nat
  := fun x_or_y => match x_or_y with
                     | inl x => x + 2
                     | inr y => y - 1
                   end.

Eval simpl in (addtwo_or_subtractone (inl _ 5)).

Definition swap : (A * B) -> (B * A) :=
  fun f => match f with
  | (x, y) => (y, x)
  end.

Definition mutate3 :=
  fun x y z => x * z + y.

Definition mutate3' x := mutate3 x 5 2.

Check (fun _ : False => I).

Theorem unit_singleton : forall x : unit, x = tt.
  induction x.
  reflexivity.
Qed.

Check unit_ind.

Inductive Empty_set : Set := .

Theorem empty_set_is_empty : forall x : Empty_set, 2 + 2 = 5.
  destruct 1.
Qed.

Inductive bool : Set :=
| true
| false.

Definition negb (b: bool) : bool :=
  match b with
  | true => false
  | false => true
end.

Theorem neg_negb : forall b : bool, negb (negb b) = b.
  destruct b; reflexivity.
Qed.

Fixpoint plus (m n : nat) : nat :=
  match m with
  | O => n
  | S n' => S (plus n' n)
  end.

Theorem n_plus_O : forall n : nat, plus n O = n.
  induction n.
  reflexivity.
  induction n; crush.
Qed.

Check nat_ind.

Inductive nat_list : Set :=
| NNil : nat_list
| NCons : nat -> nat_list -> nat_list.

Fixpoint nlength (ls : nat_list) : nat :=
  match ls with
  | NNil => O
  | NCons _ ls' => S (nlength ls')
  end.

Fixpoint napp (ls1 ls2 : nat_list) : nat_list :=
  match ls1 with
  | NNil => ls2
  | NCons n ls1' => NCons n (napp ls1' ls2)
  end.

Theorem nlength_napp :
  forall ls1 ls2 : nat_list, nlength (napp ls1 ls2)
                             = plus (nlength ls1) (nlength ls2).
  induction ls1; crush.
Qed.

Check nat_list_ind.

Inductive nat_btree : Set :=
| NLeaf : nat_btree
| NNode : nat_btree -> nat -> nat_btree -> nat_btree.

Fixpoint nsize (tr : nat_btree) : nat :=
  match tr with
  | NLeaf => S O
  | NNode trl _ trr => plus (nsize trl) (nsize trr)
  end.

Fixpoint nsplice (tr1 tr2 : nat_btree) : nat_btree :=
  match tr1 with
  | NLeaf => NNode tr2 O NLeaf
  | NNode tr1' n tr2' => NNode (nsplice tr1' tr2) n tr2'
  end.

Theorem plus_assoc : forall n1 n2 n3 : nat,
    plus (plus n1 n2) n3 = plus n1 (plus n2 n3).
  induction n1; crush.
Qed.

Hint Rewrite n_plus_O plus_assoc.

Theorem nsize_nsplice :
  forall tr1 tr2 : nat_btree, nsize (nsplice tr1 tr2)
                              = plus (nsize tr2) (nsize tr1).
  induction tr1; crush.
Qed.

Check nat_btree_ind.

Inductive list (T : Set) : Set :=
| Nil : list T
| Cons : T -> list T -> list T.

Fixpoint length T (ls : list T) : nat :=
  match ls with
  | Nil => O
  | Cons _ ls' => S (length ls')
  end.

Fixpoint app T (ls1 ls2 : list T) : list T :=
  match ls1 with
  | Nil => ls2
  | Cons x ls1' => Cons x (app ls1' ls2)
  end.

Theorem length_app : forall T (ls1 ls2 : list T),
    length (app ls1 ls2) = plus (length ls1) (length ls2).
  induction ls1; crush.
Qed.

Print list.

Inductive even_list : Set :=
| ENil : even_list
| ECons : nat -> odd_list -> even_list
with odd_list : Set :=
     | OCons : nat -> even_list -> odd_list.

Fixpoint elength (el : even_list) : nat :=
  match el with
  | ENil => O
  | ECons _ ol => S (olength ol)
  end

with olength (ol : odd_list) : nat :=
       match ol with
       | OCons _ el => S (elength el)
       end.

Fixpoint eapp (el1 el2 : even_list) : even_list :=
  match el1 with
  | ENil => el2
  | ECons n ol => ECons n (oapp ol el2)
  end

with oapp (ol : odd_list) (el : even_list) : odd_list :=
       match ol with
       | OCons n el' => OCons n (eapp el' el)
       end.

Theorem elength_eapp : forall el1 el2 : even_list,
    elength (eapp el1 el2) = plus (elength el1) (elength el2).
  induction el1; crush.
Abort.

Check even_list_ind.


Require Import List.

Definition two_first {A:Type}(l:list A) : list A :=
 match l with a :: b :: l' => a :: b :: nil
            | _ => nil
 end.

(** Tests :

Compute two_first  (true::false::true::nil).

Compute  two_first  (6 * 6::nil).
*)

Fixpoint firsts {A:Type}(n:nat)(l:list A){struct n}: list A :=
   match n,l  with
   | 0, l' => nil
   | S n', nil => nil
   | S n', a::l' => a::firsts  n' l'
  end.


(** 116297 - Tópicos Avançados em Computadores - 2017/2           **)
(** Provas Formais: Uma Introdução à Teoria de Tipos - Turma B    **)
(** Prof. Flávio L. C. de Moura                                   **)
(** Email: contato@flaviomoura.mat.br                             **)
(** Homepage: http://flaviomoura.mat.br                           **)

(** Aluno:  Gabriel F P Araujo                                    **)
(** Matrícula: 12/0050943                                         **)

(** Atividade: Formalizar um algoritmo ordenação de sua preferência. *)

(** Esta atividade pode ser realizada individualmente ou em dupla. *)

(** Algumas dicas:
    1. Utilize a biblioteca Arith do Coq. Com isto você terá diversas propriedades sobre os números naturais, e listas de números naturais para utilizar. *)

(** Bubble Sort **)

Require Import Arith.
Require Import Nat.
Require Import Peano.
Require Import Recdef.
Require Import Coq.Lists.SetoidList.
Require Import Coq.Sorting.Sorting.
Require Import Coq.Structures.OrderedType.

Print list.
Print pair.

Function borb(l: list nat) {measure length l}: list nat :=
  match l with
  | nil => nil
  | cons h tl =>
    match tl with
    | nil => cons h nil
    | cons h' tl' =>
      match (le_lt_dec h h') with
      | left _ => cons h (borb tl)
      | right _ => cons h' (borb (cons h tl'))
      end
    end
  end.
Proof.
 - intros; subst.
   simpl.
   apply Nat.lt_succ_diag_r.
 - intros.
   simpl.
   auto.
Defined.

Print le_lt_dec.

Function borb_once(n:nat) (l: list nat) {measure length l}: list nat :=
  match l with
  | nil => (cons n nil)
  | cons h tl =>
    match (le_lt_dec n h) with
    | left _ _ => cons n (cons h tl)
    | right _ _ => cons h (cons n tl)
    end
  end.

Print borb_F.
Print borb_ind.
Print borb_rec.
Print borb_tcc.
Check borb_equation.

Fixpoint num_oc (n:nat) (l:list nat) : nat :=
  match l with
    | nil => 0
    | cons h tl =>
      match le_lt_dec n h with
        | left _ _ => S (num_oc n tl)
        | right _ _ => num_oc n tl
      end
  end.

Definition equiv l l' := forall n, num_oc n l = num_oc n l'.

Lemma Sorted_sub: forall l n, Sorted le (cons n l) -> Sorted le l.
Proof.
  intros.
  induction l.
  - apply Sorted_nil.
  - inversion H; subst.
    assumption.
Qed.

Lemma le_nm_falso: forall n m, (~ (n <= m)) -> (m < n).
Proof.
  induction n.
    - intros m H.
      assert (le 0 m).
      { apply (le_0_n). }
      apply False_ind.
      apply H; assumption.
    - intro m. case m.
      + intro H.
        apply le_n_S.
        apply le_0_n.
      + intros n' Hfalso.
        apply lt_n_S.
        apply IHn.
        intro Hle.
        apply Hfalso.
        apply le_n_S.
        assumption.
Qed.

Lemma Sorted_l_once: forall n l, Sorted le (n :: l) -> ((n :: l) = (borb_once n l)).
Proof.
  induction l.
  - intro H.
    reflexivity.
  - intro H.
    rewrite borb_once_equation.
    destruct (le_lt_dec n a).
    + reflexivity.
    + inversion H; subst.
      inversion H3; subst.
      assert ((~ (n <= a))).
      { apply lt_not_le. assumption. }
      contradiction.
Qed.

Lemma Sorted_l: forall l, Sorted le (l) -> (l = (borb l)).
Proof.
  induction l.
  - intro H.
    reflexivity.
  - intro H.
    rewrite borb_equation.
    destruct (l).
    + reflexivity.
    + destruct (le_lt_dec a n).
      * rewrite <- IHl.
        reflexivity.
        inversion H; subst.
        assumption.
      * inversion H; subst.
        inversion H3; subst.
        assert ((~ (a <= n))).
        { apply lt_not_le. assumption. }
        contradiction.
Qed.

Lemma Sorted_n_l_once: forall h tl, Sorted le (h :: tl) -> ((h :: tl) = borb_once h  tl).
Proof.
  intros.
  functional induction (borb_once h  tl).
  - reflexivity.
  - reflexivity.
  - inversion H; subst.
    inversion H3; subst.
    assert ((~ (h <= h0))).
    { apply lt_not_le. assumption. }
    contradiction.
Qed.

Lemma Sorted_n_l: forall h tl, Sorted le (h :: tl) -> ((h :: tl) = borb (h :: tl)).
Proof.
  intros h tl H.
  functional induction (borb (tl)).
  - reflexivity.
  - rewrite borb_equation.
    destruct (le_lt_dec h h0).
    + reflexivity.
    + inversion H; subst.
      inversion H3; subst.
      assert ((~ (h <= h0))).
      { apply lt_not_le. assumption. }
      contradiction.
  - rewrite <- Sorted_l.
    + reflexivity.
    + assumption.
  - rewrite <- Sorted_l.
    + reflexivity.
    + assumption.
Qed.

(**deveria ser <->**)
(*functional induction (brob l).*)
Lemma borb_preserva_ordem : forall l: list nat, Sorted le l -> Sorted le (borb l).
Proof.
  induction l.
  - intro.
    rewrite borb_equation.
    apply Sorted_nil.
  - intro.
    rewrite <- Sorted_n_l.
    + assumption.
    + assumption.
Qed.

Lemma num_oc_borb: forall l n, num_oc n (l) = num_oc n (borb (l)).
Proof.
  intros l n.
  functional induction (borb l).
  - reflexivity.
  - reflexivity.
  - simpl num_oc.
    case (le_lt_dec n h).
    + intro nh.
      case (le_lt_dec n h').
      * intro nh'.
        rewrite <- IHl0.
        simpl num_oc.
        destruct (le_lt_dec n h').
        **tauto.
        **assert ((~ (n <= h'))).
          { apply lt_not_le. assumption. }
          contradiction.
      * intro h'n.
        rewrite <- IHl0.
        simpl num_oc.
        destruct (le_lt_dec n h').
        **assert ((~ (n <= h'))).
          { apply lt_not_le. assumption. }
          contradiction.
        **auto.
    + intro.
      destruct (le_lt_dec n h').
      * rewrite <- IHl0.
        simpl num_oc.
        destruct (le_lt_dec n h').
        **reflexivity.
        **assert ((~ (n <= h'))).
          { apply lt_not_le. assumption. }
          contradiction.
      * rewrite <- IHl0.
        simpl num_oc.
        destruct (le_lt_dec n h').
        **assert ((~ (n <= h'))).
          { apply lt_not_le. assumption. }
          contradiction.
        **reflexivity.
  - simpl num_oc.
    case (le_lt_dec n h).
    + intro nh.
      case (le_lt_dec n h').
      * intro nh'.
        rewrite <- IHl0.
        simpl num_oc.
        destruct (le_lt_dec n h).
        **reflexivity.
        **assert ((~ (n <= h))).
          { apply lt_not_le. assumption. }
          contradiction.
      * intro h'n.
        rewrite <- IHl0.
        simpl num_oc.
        destruct (le_lt_dec n h).
        **reflexivity.
        **assert ((~ (n <= h))).
          { apply lt_not_le. assumption. }
          contradiction.
    + intro hn.
      case (le_lt_dec n h').
      * intro nh'.
        rewrite <- IHl0.
        simpl num_oc.
        destruct (le_lt_dec n h).
        **assert ((~ (n <= h))).
          { apply lt_not_le. assumption. }
          contradiction.
        **reflexivity.
      * intro h'n.
        rewrite <- IHl0.
        simpl num_oc.
        destruct (le_lt_dec n h).
        **assert ((~ (n <= h))).
          { apply lt_not_le. assumption. }
          contradiction.
        **reflexivity.
Qed.

Lemma num_oc_borb_once_seq: forall l n n', (num_oc n (borb_once n' l)) =  (num_oc n (n' :: l)).
Proof.
  induction l.
  - intros n n'.
    rewrite borb_once_equation.
    reflexivity.
  - intros n n'.
    rewrite borb_once_equation.
    case (le_lt_dec n' a).
    + intro H.
      reflexivity.
    + intro H.
      apply lt_not_le in H.
      simpl.
      case (le_lt_dec n a).
      * intro H'.
        case (le_lt_dec n n').
        ** intro Hle.
           reflexivity.
        ** intro Hlt.
           reflexivity.
      * intro H'.
        case (le_lt_dec n n').
        ** intro Hle.
           reflexivity.
        ** intro Hlt.
           reflexivity.
Qed.

Lemma num_oc_borb_seq: forall l n, (num_oc n (borb l)) =  (num_oc n l).
Proof.
  induction l.
  - intros n.
    rewrite borb_equation.
    reflexivity.
  - intros n.
    rewrite <- num_oc_borb.
    reflexivity.
Qed.

Lemma borb_sorts: forall l a, Sorted le (borb l) -> Sorted le (borb (a :: l)).
Proof.
  intros l a.
  intro H.
  functional induction (borb (l)).
Admitted.

(**
    2. Utilize a formalização do algoritmo de ordenação por inserção desenvolvida em sala como parâmetro. *)

Theorem correcao: forall l, (equiv l (borb l)) /\ Sorted le (borb l).
Proof.
  (* induction l. *)
  intro l.
  functional induction (borb l).
  - split.
    * unfold equiv.
      intro n.
      reflexivity.
    * apply Sorted_nil.
  - split.
    * unfold equiv.
      intro n.
      rewrite -> num_oc_borb.
      reflexivity.
    * apply Sorted_cons.
      ** apply Sorted_nil.
      ** apply HdRel_nil.
  - unfold equiv in *.
    remember (h' :: tl') as l eqn: H.
    split.
    + intro n.
      destruct IHl0 as [Hequiv Hord].
      simpl num_oc.
      destruct (le_lt_dec n h).
      * rewrite <- num_oc_borb.
        reflexivity.
      * rewrite <- num_oc_borb.
        reflexivity.
    + destruct IHl0 as [Hequiv Hord].
      apply Sorted_cons.
      * assumption.
      * inversion Hord.
        ** apply HdRel_nil.
        **
  - split.
    * unfold equiv.
      intro n.
      destruct IHl0 as [Hequiv Hord].
      simpl num_oc.
      destruct (le_lt_dec n h).
      ** destruct (le_lt_dec n h').
         *** rewrite <- num_oc_borb.
             simpl num_oc.
             destruct (le_lt_dec n h).
             **** reflexivity.
             **** assert ((~ (n <= h))).
                  { apply lt_not_le. assumption. }
                  contradiction.
         *** rewrite <- num_oc_borb.
             simpl num_oc.
             destruct (le_lt_dec n h).
             **** reflexivity.
             **** assert ((~ (n <= h))).
                  { apply lt_not_le. assumption. }
                  contradiction.
      ** destruct (le_lt_dec n h').
         *** rewrite <- num_oc_borb.
             simpl num_oc.
             destruct (le_lt_dec n h).
             **** assert ((~ (n <= h))).
                  { apply lt_not_le. assumption. }
                  contradiction.
             **** reflexivity.
         *** rewrite <- num_oc_borb.
             simpl num_oc.
             destruct (le_lt_dec n h).
             **** assert ((~ (n <= h))).
                  { apply lt_not_le. assumption. }
                  contradiction.
             **** reflexivity.
    * destruct IHl0 as [Hequiv Hord].
      inversion Hord; subst.
      ** apply Sorted_cons.
         *** apply Sorted_nil.
         *** apply HdRel_nil.
      ** apply Sorted_cons.
         *** auto.
         *** apply HdRel_cons.
             admit.
Admitted.

Theorem correcao_comp: forall (l:list nat), {l' | equiv l l' /\ Sorted le l'}.
Proof.
  intro l.
  exists (borb l).
  apply correcao.
Qed.


(* begin snippet membersDef:: no-out *)
Require Import primRec cPair Arith.
From Equations Require Import  Equations.

Equations members (a:nat): list nat by wf a:=
  members 0 := List.nil;
  members (S z) := cPairPi1 z:: members (cPairPi2 z).
(* end snippet membersDef *)
Next Obligation.
  apply Nat.le_lt_trans with z.
  apply cPairLe2A.
  apply le_n.
Defined.

Lemma membersOk n : n = codeList (members n).
Proof.
     pattern n, (members n); apply members_elim.
      -  reflexivity.
      -  intros; simpl; f_equal; rewrite <- H.
         now rewrite cPairProjections.
Qed.

Lemma membersOk' l : l = members (codeList l).
Proof.
  induction l.
  - reflexivity.
   - cbn; rewrite IHl.
     rewrite members_equation_2.
     now rewrite cPairProjections1, cPairProjections2, <- !IHl.
Qed.


(** 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 (lf2 : natural) : natural := mult lf2 lf2.


(** 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 (lf3 : natural) (z : natural) : natural := plus z lf3.


(* TPPmark 2017 DP version by Mitsuharu Yamamoto *)
From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section DynamicProgramming.

Variables X Y Z : Type.

Variable z00 : Z.
Variable zc0 : X -> seq X -> Z -> Z.
Variable z0c : Y -> seq Y -> Z -> Z.
Variable zcc : X -> seq X -> Y -> seq Y -> Z -> Z -> Z -> Z.

Fixpoint dp0t t :=
  if t is y :: t' then let: (z, zs) := dp0t t' in (z0c y t' z, z :: zs)
  else (z00, [::]).

Fixpoint dpt x s t zs :=
  match t, zs with
  | y :: t', (z, z' :: zs') => let: (zy, zt') := dpt x s t' (z', zs') in
                               (zcc x s y t' z' z zy, zy :: zt')
  | _, (z, _) => (zc0 x s z, [::])
  end.

Fixpoint dps s t := if s is x :: s' then dpt x s' t (dps s' t) else dp0t t.

Definition dp s t := (dps s t).1.

Lemma dp00 : dp [::] [::] = z00.
Proof.  by [].  Qed.

Lemma dp0c y t : dp [::] (y :: t) = z0c y t (dp [::] t).
Proof.  by rewrite /dp /=; case: dp0t.  Qed.

Lemma dpc0 x s : dp (x :: s) [::] = zc0 x s (dp s [::]).
Proof.
  by rewrite /dp; elim: s => [| x' s ->] //= in x *; case: dps => ? [| ? ?].
Qed.

Lemma dpscc x y s t :
  dps (x :: s) (y :: t) = (zcc x s y t (dp s t) (dp s (y :: t)) (dp (x :: s) t),
                           dp (x :: s) t :: (dps (x :: s) t).2).
Proof.
  rewrite /dp; elim: s => /= [| x' s ->] in x *.
  - by case: dp0t => ? [| ? ?]; case: dpt.
  - by rewrite -surjective_pairing; case: dpt.
Qed.

Lemma dpcc x y s t :
  dp (x :: s) (y :: t) = zcc x s y t (dp s t) (dp s (y :: t)) (dp (x :: s) t).
Proof.  by rewrite /dp dpscc.  Qed.

End DynamicProgramming.

Section LongestCommonSubsequence.

Definition argmax (X : Type) f (x y : X) := if f x < f y then y else x.

Lemma argmax_maxn (X : Type) f (x y : X) : f (argmax f x y) = maxn (f x) (f y).
Proof.  by rewrite /argmax fun_if.  Qed.

Variable T : eqType.

Definition LCS : seq T -> seq T -> seq T :=
  dp [::] (fun _ _ _ => [::]) (fun _ _ _ => [::])
     (fun x _ y _ st syt xst =>
        if x == y then x :: st else argmax size syt xst).

Lemma lcs_nil_l s : LCS [::] s = [::].
Proof.  by rewrite /LCS; case: s => [| ? ?]; rewrite ?dp00 ?dp0c.  Qed.

Lemma lcs_nil_r s : LCS s [::] = [::].
Proof.  by rewrite /LCS; case: s => [| ? ?]; rewrite ?dp00 ?dpc0.  Qed.

Lemma lcs_cons x s y t :
  LCS (x :: s) (y :: t) = if x == y then x :: LCS s t
                          else argmax size (LCS s (y :: t)) (LCS (x :: s) t).
Proof.  by rewrite /LCS dpcc.  Qed.

(* Alternatively,
Fixpoint LCS2 x us t : seq (seq T) :=
  if t is y :: t' then let p := LCS2 x (behead us) t' in
                         (if x == y then x :: head [::] (behead us)
                          else argmax size (head [::] us) (head [::] p)) :: p
  else [::].

Fixpoint LCS1 s t : seq (seq T) :=
  if s is x :: s' then LCS2 x (LCS1 s' t) t else [::].

Definition LCS s t := head [::] (LCS1 s t).

Lemma lcs_nil_l s : LCS [::] s = [::].
Proof.  by [].  Qed.

Lemma lcs_nil_r s : LCS s [::] = [::].
Proof.  by rewrite /LCS; case: s => [| x s] //=; case: LCS1.  Qed.

Lemma lcs_cons_aux x s y t :
  LCS1 (x :: s) (y :: t) = (if x == y then x :: (LCS s t)
                            else argmax size (LCS s (y :: t)) (LCS (x :: s) t))
                             :: LCS1 (x :: s) t.
Proof.  by rewrite /LCS; elim: s => [| x' s /= /(_ x') [-> ->]] // in x *.  Qed.

Lemma lcs_cons x s y t :
  LCS (x :: s) (y :: t) = if x == y then x :: LCS s t
                          else argmax size (LCS s (y :: t)) (LCS (x :: s) t).
Proof.  by rewrite /LCS lcs_cons_aux.  Qed.
*)

Lemma lcs_subseq s t : subseq (LCS s t) s /\ subseq (LCS s t) t.
Proof.
  elim: s => [| x s IHs] in t *; first by rewrite lcs_nil_l !sub0seq.
  elim: t => [| y t [IHts IHtt]]; first by rewrite lcs_nil_r sub0seq.
  rewrite lcs_cons; case: ifP => [/eqP -> | Hxy]; first by rewrite /= eqxx.
  case/IHs: (y :: t) => IHss IHst; rewrite /argmax; split; case: ifP => _ //.
  - by rewrite (subseq_trans IHss) // subseq_cons.
  - by rewrite (subseq_trans IHtt) // subseq_cons.
Qed.

Lemma lcs_longest s t u : subseq u s -> subseq u t -> size u <= size (LCS s t).
Proof.
  elim: s => [| x s IHs] in u t *; first by move=> /eqP ->.
  elim: t => [| y t IHt] in u *; first by move=> _ /eqP ->.
  case: u => [| z u] //; rewrite lcs_cons; case: ifP => [/eqP <- {y} | Hxy] /=.
  - by move=> Hs Ht; move: (IHs _ _ Hs Ht); case: ifP => _ // /leqW.
  - rewrite argmax_maxn leq_max; case: ifP => [/eqP -> | _] Hs.
    + by rewrite Hxy => Ht; rewrite (IHt (x :: u)) ?orbT //= eqxx.
    + by move=> Ht; rewrite (IHs (z :: u)).
Qed.

End LongestCommonSubsequence.

Section LongestCommonSubsequenceForList.  (* !!! NOT COMPLETED !!! *)

Fixpoint argmaxl (X : Type) f (x : X) ys :=
  if ys is y :: ys' then argmaxl f (if f x < f y then y else x) ys'
  else x.

Lemma argmaxl_sup (X : Type) f (x : X) ys m :
  (m <= f x) || has (fun y => m <= f y) ys -> m <= f (argmaxl f x ys).
Proof.
  elim: ys => [| y ys IHys] /= in x *; first by rewrite orbF.
  move=> H; case: ifP => Hxy.
  - by apply IHys; case/orP: H => // H; rewrite (ltnW (leq_ltn_trans H Hxy)).
  - apply IHys; rewrite orbCA in H; case/orP: H => // H.
    by rewrite (leq_trans H) // leqNgt Hxy.
Qed.

Lemma argmaxl_mem (X : eqType) f (x : X) ys :
  (argmaxl f x ys == x) || (argmaxl f x ys \in ys).
Proof.
  elim: ys => [| y ys IHys] in x *; first by rewrite eqxx.
  rewrite /=; case: ifP => H; first by rewrite inE (IHys y) orbT.
  move/predU1P: (IHys x) => [-> | H']; first by rewrite eqxx.
  by rewrite inE H' !orbT.
Qed.

Variable T : eqType.

Fixpoint nhead_simpl (X : Type) (d : X) n : iter n seq X -> X :=
  if n is n'.+1 then
    fun s => if s is x :: s' then nhead_simpl d x else d
  else
    id.

Definition nhead := nosimpl nhead_simpl.

Arguments nhead [X] d n s.

Lemma nhead_nil (X : Type) (d : X) n : nhead d n.+1 [::] = d.
Proof.  by [].  Qed.

Lemma nhead_cons (X : Type) (d : X) n x s : nhead d n.+1 (x :: s) = nhead d n x.
Proof.  by [].  Qed.

Definition nheadE := (nhead_nil, nhead_cons).

Fixpoint LCSLs s ys diag neighbors : seq (seq T) :=
  if s is x :: s' then
    let prev := LCSLs s' ys (omap behead diag) (map behead neighbors) in
    (if all (pred1 x) ys then x :: head [::] (oapp behead prev diag)
     else argmaxl size (head [::] prev) (map (head [::]) neighbors)) :: prev
  else [::].

Fixpoint LCSLts_simpl s ts ys :
  option (iter (size ts).+1 seq (seq T)) -> (* diag *)
  seq (iter (size ts).+1 seq (seq T)) -> (* neighbors *)
  iter (size ts).+1 seq (seq T) :=
  if ts is t :: ts' then
    fun diag neighbors =>
      let fix LCSLt t neighbors :=
          if t is y :: t' then
            let prev := LCSLt t' (map behead neighbors) in
            (@LCSLts_simpl s ts' (y :: ys)
                           (Some (head [::] (oapp behead prev diag)))
                           (head [::] prev :: map (head [::]) neighbors))
              :: prev
          else [::]
      in LCSLt t neighbors
  else fun diag neighbors => LCSLs s ys diag neighbors.

Definition LCSLts := nosimpl LCSLts_simpl.

Arguments LCSLts : clear implicits.

Lemma LCSLts_nil s ys diag neighbors:
  LCSLts s [::] ys diag neighbors = LCSLs s ys diag neighbors.
Proof.  by [].  Qed.

Lemma LCSLts_cons_nil s ts ys diag neighbors:
  LCSLts s ([::] :: ts) ys diag neighbors = [::].
Proof.  by [].  Qed.

Lemma LCSLts_cons_cons s y t ts ys diag neighbors:
  LCSLts s ((y :: t) :: ts) ys diag neighbors =
  let prev := LCSLts s (t :: ts) ys diag (map behead neighbors) in
  (LCSLts s ts (y :: ys) (Some (head [::] (oapp behead prev diag)))
          (head [::] prev :: map (head [::]) neighbors)) :: prev.
Proof.  by [].  Qed.

Definition LCSLtsE := (LCSLts_nil, LCSLts_cons_nil, LCSLts_cons_cons).

Definition LCSL s ts := nhead [::] _ (LCSLts s ts [::] None [::]).

Lemma lcsl_nil_l ts : LCSL [::] ts = [::].
Proof.
  rewrite /LCSL; move: {3}[::] (Nil (iter (size ts).+1 seq (seq T))) None.
  by rewrite /nhead /LCSLts; elim: ts => //= t ts IHts; case: t.
Qed.

Lemma lcsl_nil_r s ts : [::] \in ts -> LCSL s ts = [::].
Proof.
  rewrite /LCSL; move: {3}[::] (Nil (iter (size ts).+1 seq (seq T))) None.
  rewrite /nhead; elim: ts => //= t ts IHts ys diag neighbors.
  rewrite inE => /predU1P [<- | Hts] //.
  by case: t => [| y t] // in diag neighbors *; rewrite IHts.
Qed.

Fixpoint nmap (X : Type) n (f : seq X -> seq X) : iter n.+1 seq X -> iter n.+1 seq X :=
  if n is n'.+1 then map (nmap f) else f.

Lemma nmap_behead_nil X n : nmap behead (Nil (iter n seq X)) = [::].
Proof.  by elim: n.  Qed.

Lemma nmap_behead_head X n (s : iter n.+2 seq X) :
  nmap behead (head [::] s) = head [::] (map (nmap behead) s).
Proof.  by case: s => //=; rewrite nmap_behead_nil.  Qed.

Lemma lcsl_cons_behead x s ts ys diag neighbors :
  size ys = size neighbors ->
  nmap behead (LCSLts (x :: s) ts ys diag neighbors) =
  LCSLts s ts ys (omap (nmap behead) diag) (map (nmap behead) neighbors).
Proof.
  elim: ts => [| t ts IHts] in ys diag neighbors *; first by rewrite !LCSLtsE.
  elim: t => [| y t IHt] // in diag neighbors *.
  move=> Hsize; move/(_ diag (map behead neighbors)): IHt.
  rewrite Hsize size_map -map_comp => /(_ erefl) IHt; rewrite /= in IHt.
  rewrite !LCSLtsE /= IHts //; last by rewrite /= size_map Hsize.
  congr cons.
  - congr LCSLts.
    + case: diag => [d |] /= in IHt *; rewrite nmap_behead_head.
      * by congr (Some (head _ _)); case: d {IHt}.
      * congr (Some (head _ _)); rewrite IHt -map_comp.
        by congr (LCSLts _ (_ :: _)); apply: eq_map => -[].
    + rewrite /=; congr cons.
      * rewrite nmap_behead_head IHt -map_comp.
        by congr (head [::] (LCSLts _ (_ :: _) _ _ _)); apply: eq_map => -[].
      * by rewrite -!map_comp; apply: eq_map => ?; rewrite /= nmap_behead_head.
  - by rewrite IHt -map_comp; congr (LCSLts _ (_ :: _)); apply: eq_map => -[].
Qed.

Lemma lcsl_cons x s ts :
  [::] \notin ts ->
  LCSL (x :: s) ts =
  if all (pred1 (Some x)) (map ohead ts) then x :: LCSL s (map behead ts)
  else argmaxl size (LCSL s ts)
               (rev [tuple LCSL (x :: s) (set_nth [::] ts i
                                                  (behead (nth [::] ts i)))
                    | i < size ts]).
Proof.
Admitted.

Definition LCSL_spec s ts (lcsl : seq T) :=
  [/\ subseq lcsl s, all (subseq lcsl) ts &
      forall u, subseq u s -> all (subseq u) ts -> size u <= size lcsl].

Lemma lcsl_correct_nil_l ts : LCSL_spec [::] ts (LCSL [::] ts).
Proof.
  rewrite lcsl_nil_l; split; first by rewrite sub0seq.
  - by apply/allP => ?; rewrite sub0seq.
  - by move=> ?; rewrite subseq0 => /eqP ->.
Qed.

Lemma lcsl_correct_nil_r s ts : [::] \in ts -> LCSL_spec s ts (LCSL s ts).
Proof.
  move=> Hts; rewrite lcsl_nil_r //; split; first by rewrite sub0seq.
  - by apply/allP => ?; rewrite sub0seq.
  - by move=> ? _ /allP /(_ _ Hts); rewrite subseq0 => /eqP ->.
Qed.

Lemma lcsl_correct s ts : LCSL_spec s ts (LCSL s ts).
Proof.
  pose mes (s : seq T) (ts : seq (seq T)) := size s + (\sum_(t <- ts) size t).
  elim: {s ts}(mes s ts) {-2}s {-2}ts (leqnn (mes s ts)) => [| n IHn] s ts.
  - rewrite leqn0 addn_eq0 size_eq0 => /andP [/eqP -> _].
    exact: lcsl_correct_nil_l.
  - case: s => [| x s] Hmes; first by apply: lcsl_correct_nil_l.
    case: (boolP ([::] \in ts)) => [| Hts]; first by apply: lcsl_correct_nil_r.
    rewrite lcsl_cons //. case: ifP => Hx.
    + have /IHn [IH1 IH2 IH3] : mes s [seq behead i | i <- ts] <= n.
      { move: Hmes; rewrite /mes /= addSn ltnS; apply: leq_trans.
        rewrite leq_add2l big_map leq_sum // => t.
        by rewrite size_behead leq_pred. }
      split; first by rewrite /= eqxx.
      * apply/allP => t Ht; move/allP/(_ (ohead t)): Hx.
        rewrite map_f //= => /(_ isT) H; case: t H => // _ t /eqP [] -> in Ht *.
        by rewrite /= eqxx (allP IH2) // (map_f behead Ht).
      * { case=> // z u; rewrite [subseq _ _] /=.
          case: ifP => [/eqP |] Hzx Hus Hzuts.
          - apply: IH3 => //; apply/allP => _ /mapP [t Ht ->].
            move/allP/(_ (ohead t)): Hx.
            rewrite map_f //= => /(_ isT) H; case: t H Ht => // _ t /eqP [] ->.
            by move/(allP Hzuts); rewrite Hzx /= eqxx.
          - apply: leqW; apply: IH3 => //; apply/allP => _ /mapP [t Ht ->].
            move/allP/(_ (ohead t)): Hx.
            rewrite map_f //= => /(_ isT) H; case: t H Ht => // y t /eqP [] ->.
            by move/(allP Hzuts); rewrite /= Hzx.
        }
    + have /IHn [IHs1 IHs2 IHs3] : mes s ts <= n
        by move: Hmes; rewrite /mes /= addSn ltnS.
      have Htsi (i : 'I_(size ts)) :
        mes (x :: s) (set_nth [::] ts i (behead (nth [::] ts i))) <= n.
      {
        move: Hmes; rewrite /mes /= addSn ltnS; apply: leq_trans.
        rewrite addSn -addnS leq_add2l; set ts' := set_nth _ _ _ _.
        have Hsize: size ts' = size ts by rewrite size_set_nth; apply/maxn_idPr.
        have Hts' i0 : i0 != i :> nat -> nth [::] ts' i0 = nth [::] ts i0
          by move=> Hi0; rewrite nth_set_nth /= (negPf Hi0).
        rewrite !(big_nth [::]) (@big_cat_nat _ _ _ i.+1) //= Hsize //.
        rewrite [X in _ < X](@big_cat_nat _ _ _ i.+1) //=.
        rewrite !big_nat_recr //= -addSn -addnS !big_nat !leq_add //.
        - apply: eq_leq; apply: eq_bigr => i0 Hi0; rewrite Hts' //.
          by apply/negP => /eqP Hi0i; rewrite Hi0i ltnn andbF in Hi0.
        - rewrite nth_set_nth /= eqxx size_behead prednK //.
          case E: nth => //; case/negP: Hts; rewrite -E; apply/nthP.
          by exists i.
        - apply: eq_leq; apply: eq_bigr => i0 Hi0; rewrite Hts' //.
          by apply/negP => /eqP Hi0i; rewrite Hi0i ltnn in Hi0.
      }
      set lts' := rev _; split.
      * { move/predU1P: (argmaxl_mem size (LCSL s ts) lts') => [-> |].
          - by rewrite (subseq_trans IHs1) ?subseq_cons.
          - rewrite /lts' [rev _]/= -!map_rev.
            by case/mapP => i Hi ->; case/IHn: (Htsi i).
        }
      * move/predU1P: (argmaxl_mem size (LCSL s ts) lts') => [-> |] //.
        rewrite /lts' [rev _]/= -!map_rev.
        case/mapP => i Hi ->; set ts' := set_nth _ _ _ _; set lt' := LCSL _ _.
        have Hts' : size ts' = size ts
          by rewrite size_set_nth; apply: maxn_idPr.
        apply/allP => _ /(nthP [::]) [j Hj <-].
        case/IHn: (Htsi i) => _ /allP /(_ (nth [::] ts' j)).
        rewrite mem_nth ?Hts' // nth_set_nth => /(_ isT) H _.
        rewrite /= in H; case: ifP H => // /eqP ->; rewrite /lt' /ts'.
        by case: nth => // y t /subseq_trans -> //; rewrite subseq_cons.
      * { case=> // z u Hzuxs Hzuts; apply: argmaxl_sup; rewrite /= in Hzuxs.
          move: Hzuxs; case: ifP => [/eqP {z}-> | Hzx] in Hzuts *.
          - move=> Hus'; case/allPn: Hx => _ /mapP [t Ht ->].
            case: t Ht => [/(negP Hts) | y t Hyt] // => Hyx.
            rewrite /= /eq_op /= in Hyx; case/(nthP [::]): (Hyt) => i Hi Hnthi.
            apply/orP; right; apply/hasP.
            exists (nth [::] lts' (rev_ord (Ordinal Hi))).
            + by rewrite mem_nth // size_rev size_map size_enum_ord.
            + rewrite /lts' (nth_rev [::]) size_tuple.
              rewrite -[size _ - _]/(rev_ord _ : nat) rev_ordK nth_mktuple.
              case/IHn: (Htsi (Ordinal Hi)) => _ _ -> //.
              * by rewrite /= eqxx.
              * { apply/allP => t' /(nthP [::]) [j].
                  rewrite size_set_nth (maxn_idPr Hi) nth_set_nth /= => Hj <-.
                  case: ifP => [_ | Hij].
                  - move/allP/(_ (nth [::] ts i)): Hzuts.
                    by rewrite Hnthi /= eq_sym (negPf Hyx) => ->.
                  - move/allP/(_ (nth [::] ts j)): Hzuts => -> //.
                    by rewrite mem_nth.
                }
              * by rewrite ltn_ord.
          - by move/IHs3 => ->.
        }
Qed.

End LongestCommonSubsequenceForList.

Eval compute in @LCSLts _ [:: 1; 2; 3; 4; 5] [:: [:: 2; 1; 3; 5] ] [::] None [::].
     (* = [:: [:: [:: 2; 3; 5]; [:: 2; 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*       [:: [:: 1; 3; 5]; [:: 3; 5];    [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*       [:: [:: 3; 5];    [:: 3; 5];    [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*       [:: [:: 5];       [:: 5];       [:: 5];    [:: 5]; [:: 5]]] *)
     (* : iter (size [:: [:: 2; 1; 3; 5]]).+1 seq (seq nat_eqType) *)
Eval compute in @LCSLts _ [:: 1; 3; 4; 5] [:: [:: 2; 1; 3; 5] ] [::] None [::].
     (* = [:: [:: [:: 1; 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*       [:: [:: 1; 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*       [:: [:: 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*       [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]]] *)
     (* : iter (size [:: [:: 2; 1; 3; 5]]).+1 seq (seq nat_eqType) *)
Eval compute in @LCSLts _ [::] [:: [:: 2; 1; 3; 5] ] [::] None [::].
     (* = [:: [::]; [::]; [::]; [::]] *)
     (* : iter (size [:: [:: 2; 1; 3; 5]]).+1 seq (seq nat_eqType) *)
Eval compute in @LCSLts _ [:: 1; 2; 3; 4; 5] [:: [:: 1; 3; 4; 5]; [:: 2; 1; 3; 5] ] [::] None [::].
     (* = [:: [:: [:: [:: 1; 3; 5]; [:: 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 1; 3; 5]; [:: 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 3; 5]; [:: 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]]; *)
     (*       [:: [:: [:: 3; 5]; [:: 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 3; 5]; [:: 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 3; 5]; [:: 3; 5]; [:: 3; 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]]; *)
     (*       [:: [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]]; *)
     (*       [:: [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]; *)
     (*           [:: [:: 5]; [:: 5]; [:: 5]; [:: 5]; [:: 5]]]] *)
     (* : iter (size [:: [:: 1; 3; 4; 5]; [:: 2; 1; 3; 5]]).+1 seq *)
     (*     (seq nat_eqType) *)
Eval compute in @LCSLts _ [:: 1; 2; 3; 4; 5] [:: [:: 1; 3; 4]; [:: 2; 1; 3; 5] ] [::] None [::].
     (* = [:: [:: [:: [:: 1; 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*           [:: [:: 1; 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*           [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*           [:: [::]; [::]; [::]; [::]; [::]]]; *)
     (*       [:: [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*           [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*           [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*           [:: [::]; [::]; [::]; [::]; [::]]]; *)
     (*       [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*           [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*           [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*           [:: [::]; [::]; [::]; [::]; [::]]]] *)
     (* : iter (size [:: [:: 1; 3; 4]; [:: 2; 1; 3; 5]]).+1 seq (seq nat_eqType) *)
Eval compute in @LCSLts _ [:: 1; 2; 3; 4; 5] [:: [:: 1; 3; 4; 5]; [:: 2; 1; 3; 5]; [:: 2; 1; 3]] [::] None [::].
     (* = [:: [:: [:: [:: [:: 1; 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 1; 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]]; *)
     (*           [:: [:: [:: 1; 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 1; 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]]; *)
     (*           [:: [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]]; *)
     (*           [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]]; *)
     (*       [:: [:: [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]]; *)
     (*           [:: [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]]; *)
     (*           [:: [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]; *)
     (*               [:: [:: 3]; [:: 3]; [:: 3]; [::]; [::]]]; *)
     (*           [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]]; *)
     (*       [:: [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]; *)
     (*           [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]; *)
     (*           [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]; *)
     (*           [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]]; *)
     (*       [:: [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]; *)
     (*           [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]; *)
     (*           [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]; *)
     (*           [:: [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]; *)
     (*               [:: [::]; [::]; [::]; [::]; [::]]]]] *)
     (* : iter (size [:: [:: 1; 3; 4; 5]; [:: 2; 1; 3; 5]; [:: 2; 1; 3]]).+1 seq *)
     (*     (seq nat_eqType) *)
Eval compute in @LCSLts _ [:: 1; 2; 3; 4; 5] [:: [:: 1; 3; 4; 5]; [:: 2; 1; 3; 5]; [::]] [::] None [::].
     (* = [:: [:: [::]; [::]; [::]; [::]]; [:: [::]; [::]; [::]; [::]]; *)
     (*       [:: [::]; [::]; [::]; [::]]; [:: [::]; [::]; [::]; [::]]] *)
     (* : iter (size [:: [:: 1; 3; 4; 5]; [:: 2; 1; 3; 5]; [::]]).+1 seq *)
     (*     (seq nat_eqType) *)
Eval compute in @LCSLts _ [:: 1; 2; 3; 4; 5] [:: [::]; [:: 1; 3; 4; 5]; [:: 2; 1; 3; 5]] [::] None [::].
     (* = [::] *)
     (* : iter (size [:: [::]; [:: 1; 3; 4; 5]; [:: 2; 1; 3; 5]]).+1 seq *)
     (*     (seq nat_eqType) *)
Eval compute in @LCSLts _ [:: 1; 2; 3; 4; 5] [::] [::] None [::].
     (* = [:: [:: 1; 2; 3; 4; 5]; [:: 2; 3; 4; 5]; [:: *)
     (*       3; 4; 5]; [:: 4; 5]; [:: 5]] *)
     (* : iter (size [::]).+1 seq (seq nat_eqType) *)


(* BinTree the type of binary trees that store values at each node, and nothing at the leaves *)
Inductive BinTree {A : Type} := Leaf : BinTree | Branch : A -> BinTree -> BinTree -> BinTree.

(* (Bin_elem x t) is a proof that x is in t, and the structure of the proof is the path taken to reach it *)
Inductive Bin_elem {A : Type} : A -> BinTree -> Prop :=
    | Bin_elem_exact : forall x l r, Bin_elem x (Branch x l r)
    | Bin_elem_left : forall x y l r, Bin_elem x l -> Bin_elem x (Branch y l r)
    | Bin_elem_right : forall x y l r, Bin_elem x r -> Bin_elem x (Branch y l r).

(* Bin_elem' makes use of a decideable equality procedure, and computes whether or not the element is in the tree, returning a type.
    It doesn't explicitly store the path in a traversable form, the path is implicit in the structure of its computation. *)
Fixpoint Bin_elem' {A : Type} {eq_dec : forall x y : A, {x = y} + {x <> y}} (x : A) (t : BinTree) : Prop :=
    match t with
    | Leaf => False
    | Branch y l r => match eq_dec x y with
        | left _ => True
        | right _ => @ Bin_elem' A eq_dec x l \/ @ Bin_elem' A eq_dec x r
        end
    end.

(* Both formulations are equivalent, but Bin_elem has fewer dependencies (since it doesn't need eq_dec) *)
Theorem Bin_elems_equiv : forall A eq_dec (x : A) t, Bin_elem x t <-> @ Bin_elem' A eq_dec x t.
    (* manual proof *)
    intros a eq_dec x t.
    induction t.
    - split; inversion 1.
    - simpl. destruct (eq_dec x a0).
        + split.
            * tauto.
            * intro. rewrite e. apply Bin_elem_exact.
        + split.
            * inversion 1; tauto.
            * inversion 1.
                -- apply Bin_elem_left. exact (proj2 IHt1 H0).
                -- apply Bin_elem_right. exact (proj2 IHt2 H0).
    Restart.
    (* proof with match goal and explicit inversion *)
    intros a eq_dec x t.
    induction t; split; simpl; match goal with
    | |- Bin_elem _ Leaf -> _ => inversion 1
    | |- False -> _ => inversion 1
    | |- context[eq_dec ?x ?y] => destruct (eq_dec x y); match goal with
        | |- _ -> True => exact (fun _ => I)
        | |- Bin_elem x (Branch y ?l ?r) -> _ => inversion 1; tauto
        | e:(x = y) |- _ -> Bin_elem x (Branch y _ _) => intro; rewrite e; apply Bin_elem_exact
        | |- Bin_elem' x ?l \/ Bin_elem' x ?r -> _ => destruct 1; [apply Bin_elem_left | apply Bin_elem_right]; tauto
        end
    end.
    Restart.
    (* more automated proof *)
    intros a eq_dec x t.
    induction t; split; simpl; try easy; match goal with
    | |- context[eq_dec ?x ?y] => destruct (eq_dec x y); match goal with
        | |- Bin_elem x (Branch y ?l ?r) -> _ => inversion 1; tauto
        | e:(x = y) |- _ -> Bin_elem x (Branch y _ _) => intro; rewrite e; apply Bin_elem_exact
        | |- Bin_elem' x ?l \/ Bin_elem' x ?r -> _ => destruct 1; [apply Bin_elem_left | apply Bin_elem_right]; tauto
        end
    end.
    Qed.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*                                                                            *)
(* ************************************************************************** *)

(* Version 0.1 *)

Require Export Bool.
Require Import Arith.

(* *********************************************************** *)

Theorem nat_eq_dec : forall a b : nat, {a = b} + {a <> b}.
Proof.
  intros; compare a b; auto.
Qed.

(* *********************************************************** *)

Fixpoint blt_nat (n m : nat) {struct n} : bool :=
  match n, m with
  | O, O => false
  | O, S _ => true
  | S _, O => false
  | S n', S m' => blt_nat n' m'
  end.

Lemma blt_irrefl :
  forall a : nat, blt_nat a a = false.
Proof.
  induction a; simpl; auto.
Qed.

Lemma blt_irrefl_Prop :
  forall a : nat, ~ (blt_nat a a = true).
Proof.
  induction a; simpl; auto.
Qed.

Lemma blt_asym :
  forall a b : nat, blt_nat a b = true
    -> blt_nat b a = false.
Proof.
  double induction a b; simpl; intros; auto.
Qed.

Lemma blt_O_Sn :
  forall n : nat, blt_nat O (S n) = true.
Proof.
  induction n; simpl; auto.
Qed.

Lemma blt_n_O : forall n,
  blt_nat n O = false.
Proof.
  induction n; simpl; auto.
Qed.

Lemma not_blt_n_O :
  forall n : nat, ~ (blt_nat n 0 = true).
Proof.
  induction n; simpl; auto.
Qed.

Lemma blt_true_lt :
  forall a b : nat, blt_nat a b = true -> a < b.
Proof.
  double induction a b; simpl; intros;
    auto with arith; try discriminate.
Qed.

Lemma blt_false_le :
  forall n m, blt_nat n m = false -> m <= n.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma le_blt_false :
  forall n m, n <= m -> blt_nat m n = false.
Proof.
  double induction n m; simpl; intros;
    auto with arith.
  destruct (lt_n_O _ H0).
Qed.

Lemma lt_blt_true :
  forall a b : nat, a < b -> blt_nat a b = true.
Proof.
  double induction a b; simpl; intros;
    auto with arith.
  destruct (lt_irrefl 0 H).
  destruct (lt_n_O (S n) H0).
Qed.

Lemma blt_n_Sn :
  forall n : nat, blt_nat n (S n) = true.
Proof.
  induction n; simpl; intros; auto with arith.
Qed.

Lemma blt_S_eq :
  forall a b, blt_nat a b = blt_nat (S a) (S b).
Proof.
  trivial.
Qed.

Lemma blt_n_Sm :
  forall n m, blt_nat n m = true
    -> blt_nat n (S m) = true.
Proof.
  double induction n m; simpl; intros; auto with arith.
  discriminate.
Qed.

Lemma blt_n_mk :
  forall n m k, blt_nat n m = true
    -> blt_nat n (m + k) = true.
Proof.
  double induction n m; simpl; intros;
    auto with arith;  discriminate.
Qed.

Lemma blt_n_km :
  forall n m k, blt_nat n m = true
    -> blt_nat n (k + m) = true.
Proof.
  double induction n m; simpl; intros;
    auto with arith; try discriminate.
  replace (k + (S n0)) with ((S n0) + k);
    [idtac | auto with arith].
  simpl. trivial.
  replace (k + (S n0)) with ((S n0) + k);
    [idtac | auto with arith].
  simpl.
  replace (n0 + k) with (k + n0);
    [idtac | auto with arith].
  apply H0; trivial.
Qed.

Lemma blt_nat_dec : forall a b,
  {blt_nat a b = true} + {blt_nat a b = false}.
Proof.
  double induction a b; simpl; intros; try tauto || auto.
Qed.

(* *********************************************************** *)

Definition ble_nat (n m : nat) : bool :=
  match blt_nat m n with
    | true => false
    | false => true
  end.

(* *********************************************************** *)

Fixpoint beq_nat (n m : nat)  {struct n} : bool :=
  match n, m with
  | O, O => true
  | O, S _ => false
  | S _, O => false
  | S n1, S m1 => beq_nat n1 m1
  end.

Lemma beq_refl : forall m, beq_nat m m = true.
Proof.
  induction m; simpl; intros; auto.
Qed.

Lemma beq_trans : forall m n k, beq_nat m n = true
  -> beq_nat n k = true
  -> beq_nat m k = true.
Proof.
  induction m; induction n; destruct k;
    simpl; intros; discriminate || auto.
  eapply IHm; eauto.
Qed.

Lemma beq_sym : forall m n b,
  beq_nat m n = b -> beq_nat n m = b.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma beq_sym2 : forall m n,
  beq_nat m n = beq_nat n m.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma beq_true_eq :
  forall n m, beq_nat n m = true
    -> n = m.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma beq_false_neq :
  forall n m, beq_nat n m = false
    -> ~ (n = m).
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma eq_beq_true :
  forall n m, n = m
    -> beq_nat n m = true.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma neq_beq_false :
  forall n m, ~ (n = m)
    -> beq_nat n m = false.
Proof.
  double induction n m; simpl; intros;
    auto with arith.
  destruct (H (refl_equal _)).
Qed.

Lemma beq_nat_dec : forall a b,
  {beq_nat a b = true} + {beq_nat a b = false}.
Proof.
  double induction a b; simpl; intros; try tauto || auto.
Qed.

(* *********************************************************** *)

Lemma blt_t_beq_f :
  forall m n, blt_nat m n = true
    -> beq_nat m n = false.
Proof.
  double induction n m; simpl; intros; auto with arith.
Qed.

Lemma bgt_t_beq_f :
  forall m n, blt_nat n m = true
    -> beq_nat m n = false.
Proof.
  double induction m n; simpl; intros; auto with arith.
Qed.

Lemma beq_t_blt_f :
  forall m n, beq_nat m n = true
    -> blt_nat m n = false.
Proof.
  double induction m n; simpl; intros; auto with arith.
Qed.

Lemma beq_t_bgt_f :
  forall m n, beq_nat m n = true
    -> blt_nat n m = false.
Proof.
  double induction n m; simpl; intros; auto with arith.
Qed.

Lemma blt_S_dec :
  forall n m,
    blt_nat n (S m) = true
    -> blt_nat n m = true \/ beq_nat n m = true.
Proof.
  intros n m H.
  assert (Hx:=blt_true_lt _ _ H).
  apply lt_n_Sm_le in Hx.
  apply le_lt_or_eq_iff in Hx.
  destruct Hx.
    left.
    apply lt_blt_true; trivial.
  right.
  apply eq_beq_true; trivial.
Qed.

(* *********************************************************** *)

Definition max_nat (m n : nat) : nat :=
  if blt_nat m n then n else m.

Lemma max_nat_elim_l : forall m n : nat,
  m <= max_nat m n.
Proof.
  unfold max_nat; intros m n.
  destruct (blt_nat_dec m n) as [Hb | Hb]; rewrite Hb.
  assert (Hb' := blt_true_lt m n Hb).
  auto with arith.
  auto with arith.
Qed.

Lemma max_nat_elim_r : forall m n : nat,
  n <= max_nat m n.
Proof.
  unfold max_nat; intros m n.
  destruct (blt_nat_dec m n) as [Hb | Hb]; rewrite Hb.
  auto with arith.
  assert (Hb' := blt_false_le m n Hb).
  auto with arith.
Qed.

(* *********************************************************** *)

Ltac rewrite_bnat t :=
  match type of t with
    | blt_nat ?a ?b = ?c => rewrite t
    | beq_nat ?a ?b = ?c => rewrite t
  end.

Ltac rewrite_bnat_H t H :=
  match type of t with
    | blt_nat ?a ?b = ?c => rewrite t in H
    | beq_nat ?a ?b = ?c => rewrite t in H
  end.

Ltac rewrite_bnat_all t :=
  match goal with
    | |- context[(blt_nat ?a ?b)] => rewrite_bnat t; rewrite_bnat_all t
    | H : context[(blt_nat ?a ?b)] |- _ => rewrite_bnat_H t H; rewrite_bnat_all t
    | |- context[(beq_nat ?a ?b)] => rewrite_bnat t; rewrite_bnat_all t
    | H : context[(beq_nat ?a ?b)] |- _ => rewrite_bnat_H t H; rewrite_bnat_all t
    | _ => idtac
  end.

Ltac simplbnat :=
  match goal with
    (* blt rewrite directly *)
    | [H : blt_nat ?x ?y = ?f
      |- context [(blt_nat ?x ?y)]] =>
       rewrite H; simplbnat
    | [H : blt_nat ?x ?y = ?f,
       H0 : context [(blt_nat ?x ?y)]
      |- _ ] =>
       rewrite H in H0; simplbnat

    (* beq rewrite directly *)
    | [H : beq_nat ?x ?y = ?f
      |- context [(beq_nat ?x ?y)]] =>
       rewrite H; simplbnat
    | [H : beq_nat ?x ?y = ?f,
       H0 : context [(beq_nat ?x ?y)] |- _ ] =>
       rewrite H in H0; simplbnat

    (* blt -> beq *)
    | [H : blt_nat ?x ?y = true
      |- context[(beq_nat ?x ?y)]] =>
      rewrite (blt_t_beq_f x y H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context[(beq_nat ?x ?y)] |- _ ] =>
      rewrite (blt_t_beq_f x y H) in H0; simplbnat

    (* bgt -> beq *)
    | [H : blt_nat ?y ?x = true
      |- context[(beq_nat ?x ?y)]] =>
      rewrite (bgt_t_beq_f x y H); simplbnat
    | [H : blt_nat ?y ?x = true,
       H0 : context[(beq_nat ?x ?y)] |- _ ] =>
      rewrite (bgt_t_beq_f x y H) in H0; simplbnat

    (* beq -> blt *)
    | [H : beq_nat ?y ?x = true
      |- context[(blt_nat ?x ?y)]] =>
      rewrite (beq_t_blt_f x y H); simplbnat
    | [H : beq_nat ?y ?x = true,
       H0 : context[(blt_nat ?x ?y)] |- _ ] =>
      rewrite (beq_t_blt_f x y H) in H0; simplbnat

    (* beq -> bgt *)
    | [H : beq_nat ?y ?x = true
      |- context[(blt_nat ?y ?x)]] =>
      rewrite (beq_t_bgt_f x y H); simplbnat
    | [H : beq_nat ?y ?x = true,
       H0 : context[(blt_nat ?y ?x)] |- _ ] =>
      rewrite (beq_t_bgt_f x y H) in H0; simplbnat

    (* blt_irrefl *)
    | [ |- context [blt_nat ?x ?x]] =>
      rewrite (blt_irrefl x); simplbnat
    | [H : context [blt_nat ?x ?x] |- _ ] =>
      rewrite (blt_irrefl x) in H; simplbnat

    (* blt_asym *)
    | [H : blt_nat ?x ?y = true
      |- context [blt_nat ?y ?x]] =>
      rewrite (blt_asym x y H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context [blt_nat ?y ?x] |- _ ] =>
      rewrite (blt_asym x y H) in H0; simplbnat

    (* blt_O_Sn *)
    | [ |- context [(blt_nat O (S ?x))]] =>
      rewrite (blt_O_Sn x); simplbnat
    | [H : context [(blt_nat O (S ?x))] |- _ ] =>
      rewrite (blt_O_Sn x) in H; simplbnat

    (* blt_n_O *)
    | [ |- context [(blt_nat ?x O)]] =>
      rewrite (blt_n_O x); simplbnat
    | [H : context [(blt_nat ?x O)] |- _ ] =>
      rewrite (blt_n_O x) in H; simplbnat

    (* blt_n_Sn *)
    | [ |- context [(blt_nat ?x (S ?x))]] =>
      rewrite (blt_n_Sn x); simplbnat
    | [H : context [(blt_nat ?x (S ?x))] |- _ ] =>
      rewrite (blt_n_Sn x) in H; simplbnat

    (* blt_S_eq *)
    | [ |- context [(blt_nat (S ?x) (S ?y))]] =>
      rewrite <- (blt_S_eq x y); simplbnat
    | [H : context [(blt_nat (S ?x) (S ?y))] |- _ ] =>
      rewrite <- (blt_S_eq x y) in H; simplbnat

    (* blt_n_Sm *)
    | [H : blt_nat ?x ?y = true
      |- context [(blt_nat ?x (S ?y))]] =>
      rewrite (blt_n_Sm x y H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context [(blt_nat ?x (S ?y))] |- _ ] =>
      rewrite <- (blt_n_Sm x y H) in H0; simplbnat

    (* blt_n_mk *)
    | [H : blt_nat ?x ?y = true
      |- context [(blt_nat ?x (?y + ?k))]] =>
      rewrite (blt_n_mk x y k H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context [(blt_nat ?x (?y + ?k))] |- _ ] =>
      rewrite <- (blt_n_mk x y k H) in H0; simplbnat

    (* blt_n_km *)
    | [H : blt_nat ?x ?y = true
      |- context [(blt_nat ?x (?k + ?y))]] =>
      rewrite (blt_n_km x y k H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context [(blt_nat ?x (?k + ?y))] |- _ ] =>
      rewrite <- (blt_n_km x y k H) in H0; simplbnat

    (* beq_refl *)
    | [ |- context [(beq_nat ?x ?x)] ] =>
      rewrite (beq_refl x); simplbnat
    | [H : context [(beq_nat ?x ?x)] |- _ ] =>
      rewrite (beq_refl x) in H; simplbnat

    (* beq_sym *)
    | [ H : beq_nat ?x ?y = ?b
        |- context [(beq_nat ?y ?x)] ] =>
      rewrite (beq_sym x y b H); simplbnat
    | [H : beq_nat ?x ?y = ?b,
       H0 : context [(beq_nat ?y ?x)] |- _ ] =>
      rewrite (beq_sym x y b H) in H0; simplbnat

    | [ H : ?x <> ?y |- context [(beq_nat ?x ?y)] ] =>
      rewrite (neq_beq_false x y H); simplbnat
    | [ H : ?x <> ?y,
        H0 : context [(beq_nat ?x ?y)] |- _ ] =>
      rewrite (neq_beq_false x y H) in H0; simplbnat

    | [ H : ?y <> ?x |- context [(beq_nat ?x ?y)] ] =>
      rewrite (neq_beq_false x y (sym_not_eq H)); simplbnat
    | [ H : ?y <> ?x,
        H0 : context [(beq_nat ?x ?y)] |- _ ] =>
      rewrite (neq_beq_false x y (sym_not_eq H)) in H0; simplbnat

    | [H : ?x = ?x |- _ ] => clear H; simplbnat
    | [H : true = false |- _ ] => discriminate H
    | [H : false = true |- _ ] => discriminate H
    | _ => idtac
  end.

Tactic Notation "bnat simpl" := simplbnat.

Ltac desbnatH H :=
  match goal with
    | H : blt_nat ?a ?b = true |- _ =>
        generalize (blt_true_lt a b H); clear H; intro H

    | H : blt_nat ?a ?b = false |- _ =>
        generalize (blt_false_le a b H); clear H; intro H

    | H : beq_nat ?a ?b = true |- _ =>
        generalize (beq_true_eq a b H); clear H; intro H

    | H : beq_nat ?a ?b = false |- _ =>
        generalize (beq_false_neq a b H); clear H; intro H

    | _ => fail 1 "not bnat found"
  end.

Ltac desbnat :=
  match goal with
    | H : blt_nat ?a ?b = true |- _ =>
        generalize (blt_true_lt a b H); clear H; intro H; desbnat

    | H : blt_nat ?a ?b = false |- _ =>
        generalize (blt_false_le a b H); clear H; intro H; desbnat

    | H : beq_nat ?a ?b = true |- _ =>
        generalize (beq_true_eq a b H); clear H; intro H; desbnat

    | H : beq_nat ?a ?b = false |- _ =>
        generalize (beq_false_neq a b H); clear H; intro H; desbnat

    | _ => idtac
  end.

Ltac conbnat :=
  match goal with
    | |- blt_nat ?a ?b = true =>
        apply (lt_blt_true a b)

    | |- blt_nat ?a ?b = false =>
        apply (le_blt_false b a)

    | |- beq_nat ?a ?b = true =>
        apply (eq_beq_true a b)

    | |- beq_nat ?a ?b = false =>
        apply (neq_beq_false a b)

    | _ => fail 1 "the goal is not bnat"
  end.

Ltac solvebnat :=
  desbnat; conbnat; auto with arith.

(* *********************************************************** *)

Tactic Notation "rewbnat" constr (t) :=
  match t with
    | beq_nat ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [solvebnat | rewrite Hb; clear Hb])
    | blt_nat ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [solvebnat | rewrite Hb; clear Hb])
    | _ =>
      match type of t with
        | beq_nat ?x ?y = true => rewrite (beq_true_eq x y t)
        | _ => rewrite t
      end
  end.

Tactic Notation "rewbnat" constr (t) "in" hyp (H) :=
  match t with
    | beq_nat ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [solvebnat | rewrite Hb in H; clear Hb])
    | blt_nat ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [solvebnat | rewrite Hb in H; clear Hb])
    | _ =>
      match type of t with
        | beq_nat ?x ?y = true => rewrite (beq_true_eq x y t) in H
        | _ => rewrite t in H
      end
  end.

Tactic Notation "assertbnat" constr (t) :=
  let Hb := fresh "Hb" in (
    match t with
      | beq_nat ?x ?y = ?f =>
        (assert (Hb : t);
            [solvebnat | idtac])
      | blt_nat ?x ?y = ?f =>
        (assert (Hb : t);
            [solvebnat | idtac])
      | _ => fail 1 "t must be a blt_nat or beq_nat equation"
    end).

Ltac discribnat :=
  desbnat; subst;
  match goal with
    | H : ?x <> ?x |- _ => destruct (H (refl_equal x))
    | H : ?x = ?y |- _ => discriminate
    | H : ?x < ?x |- _ => destruct (lt_irrefl x H)
    | H : ?x < O |- _ => destruct (lt_n_O x H)
    | H : beq_nat ?x ?x = false |- _ =>
      desbnatH H; destruct (H (refl_equal x))
    | _ => elimtype False;
        auto with arith || fail 1 "no discriminatable hypothesis"
  end.

Ltac substbnat_all := desbnat; subst.

Ltac substbnat_one f := desbnat; subst f.

Tactic Notation "substbnat" := substbnat_all.

Tactic Notation "substbnat" constr (f) := substbnat_one f.

(*
Section test.

Variables (a b c d e f g : nat).
Hypotheses
  (H0 : beq_nat a b = true)
  (H1 : blt_nat c b = true)
  (H2 : blt_nat b a = true)
  (H3 : beq_nat a b = true)
  (H4 : beq_nat a b = true)
  (H5 : if beq_nat a b then True else False)
.

Goal if beq_nat a b then True else False.
simplbnat.
rewrite_bnat_all H0.
substbnat.
rewbnat H0 in H3.
invbnat.
bnat2nat.
omega.
simplbnat.

End test. *)

(* *********************************************************** *)

Ltac decbeqnat x y :=
  let Hb := fresh "Hb" in
    (destruct (beq_nat_dec x y) as [Hb | Hb]; simplbnat).

Ltac decbltnat x y :=
  let Hb := fresh "Hb" in
    (destruct (blt_nat_dec x y) as [Hb | Hb]; simplbnat).

(* *********************************************************** *)
(* deprecate *)

Tactic Notation "repbnat" constr (t1) "with" constr (t2) :=
  replace t1 with t2; [idtac | desbnat; auto with arith].

Tactic Notation "repbnat" constr (t1) "with" constr (t2) "in" hyp (H) :=
  replace t1 with t2 in H; [idtac | desbnat; auto with arith].

Tactic Notation "bool_destruct" hyp (H) "as" simple_intropattern (pat) :=
  let H0 := fresh "H" in
    (rename H into H0;
    match type of (H0) with
      | (andb ?a ?b = true) =>
        destruct (andb_prop a b H0) as pat; clear H0
      | (orb ?a ?b = true) =>
        destruct (orb_prop a b H0) as pat; clear H0
      | _ => fail "not destructable"
    end).


(********************************************************************)
(*                                                                  *)
(*  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 BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Append.
Require list.Reverse.

(* Why3 goal *)
Definition num_occ: forall {a:Type} {a_WT:WhyType a}, a -> (list a) -> Z.
intros a a_WT x.
exact (fix num_occ (l : list a) : int :=
  match l with
  | nil => 0
  | cons y r => (if why_decidable_eq x y then 1 else 0) + num_occ r
  end)%Z.
Defined.

(* Why3 goal *)
Lemma num_occ_def : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)),
  match l with
  | Init.Datatypes.nil => ((num_occ x l) = 0%Z)
  | (Init.Datatypes.cons y r) => ((x = y) -> ((num_occ x
      l) = (1%Z + (num_occ x r))%Z)) /\ ((~ (x = y)) -> ((num_occ x
      l) = (0%Z + (num_occ x r))%Z))
  end.
Proof.
intros a a_WT x [|y r].
easy.
split ; intros H.
change ((if why_decidable_eq x y then 1 else 0) + num_occ x r = 1 + num_occ x r)%Z.
now case why_decidable_eq.
change ((if why_decidable_eq x y then 1 else 0) + num_occ x r = 0 + num_occ x r)%Z.
now case why_decidable_eq.
Qed.

(* Why3 goal *)
Lemma Num_Occ_NonNeg : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), (0%Z <= (num_occ x l))%Z.
intros a a_WT x l.
induction l as [|lh lt IHl].
easy.
simpl.
case why_decidable_eq ; intros H.
omega.
easy.
Qed.

(* Why3 goal *)
Lemma Mem_Num_Occ : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), (list.Mem.mem x l) <-> (0%Z < (num_occ x l))%Z.
Proof.
intros a a_WT x l.
induction l as [|lh lt IHl].
now split.
simpl.
case why_decidable_eq ; intros H ; split.
intros _.
clear.
generalize (Num_Occ_NonNeg x lt).
omega.
now left.
intros [H'|H'] ; try easy.
now apply IHl.
right.
now apply IHl.
Qed.

(* Why3 goal *)
Lemma Append_Num_Occ : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l1:(list a)) (l2:(list a)), ((num_occ x
  (Init.Datatypes.app l1 l2)) = ((num_occ x l1) + (num_occ x l2))%Z).
Proof.
intros a a_WT x l1 l2.
induction l1 as [|l1h l1t IHl1].
easy.
simpl.
rewrite IHl1.
rewrite Zplus_assoc.
now case why_decidable_eq.
Qed.

(* Why3 goal *)
Lemma reverse_num_occ : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), ((num_occ x l) = (num_occ x (Lists.List.rev l))).
intros a a_WT x l.
induction l; simpl.
auto.
rewrite Append_Num_Occ.
rewrite <- IHl.
ring_simplify.
simpl (num_occ x (a0 :: nil))%list.
ring.
Qed.