(*
(precise)administrator@localhost:~$ coqtop
Welcome to Coq 8.3pl4 (April 2012)

Coq < Section Practice_03.

Coq < Goal forall a b c:Prop, ((a /\ b) /\ (b /\ c)) -> ( b ).
1 subgoal

  ============================
   forall a b c : Prop, (a /\ b) /\ b /\ c -> b

Unnamed_thm < intros.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a /\ b) /\ b /\ c
  ============================
   b

Unnamed_thm < elim H.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a /\ b) /\ b /\ c
  ============================
   a /\ b -> b /\ c -> b

Unnamed_thm < intro.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a /\ b) /\ b /\ c
  H0 : a /\ b
  ============================
   b /\ c -> b

Unnamed_thm < intro.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a /\ b) /\ b /\ c
  H0 : a /\ b
  H1 : b /\ c
  ============================
   b

Unnamed_thm < apply H1.
Proof completed.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
apply H1.

Unnamed_thm is defined

Coq <
*)

Section Practice_03.
Goal forall a b c:Prop, ((a /\ b) /\ (b /\ c)) -> ( b ).
intros.
elim H.
intro.
intro.
 apply H1.
 Qed.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Omega.
Require Export Zwf.
Require Export Relations.
Require Export Inverse_Image.
Require Export Transitive_Closure.
Require Export Zdiv.

Ltac caseEq f := generalize (refl_equal f); pattern f at -1; case f.

Open Scope nat_scope.

Section abstract_refl.
 Variable T : Set.
 Definition f (x:T) := true.
 Variable C : T->Prop.
 Variable x : T.
 Variable f_correct : forall x:T, f x = true -> C x.

Check (fun t:T => f_correct t (refl_equal true):C t).
End abstract_refl.

Theorem verif_divide :
    forall m p:nat, 0 < m -> 0 < p ->
    (exists q:nat, m = q*p)->(Z_of_nat m mod Z_of_nat p = 0)%Z.
Proof.
 intros m p Hltm Hltp (q, Heq); rewrite Heq.
 rewrite inj_mult.
 replace (Z_of_nat q * Z_of_nat p)%Z with (0 + Z_of_nat q * Z_of_nat p)%Z;
    try ring.
 rewrite Z_mod_plus.
 auto.
 omega.
Qed.

Theorem divisor_smaller :
    forall m p:nat, 0 < m -> forall q:nat, m = q*p -> q <= m.
Proof.
 intros m p Hlt; case p.
 intros q Heq; rewrite Heq in Hlt; rewrite mult_comm in Hlt.
 elim (lt_irrefl 0);exact Hlt.
 intros p' q; case q.
 intros Heq; rewrite Heq in Hlt.
 elim (lt_irrefl 0);exact Hlt.
 intros q' Heq; rewrite Heq.
 rewrite mult_comm; simpl.
 auto with arith.
Qed.

Fixpoint check_range (v:Z)(r:nat)(sr:Z){struct r} : bool :=
  match r with
    O => true
  | S r' =>
    match (v mod sr)%Z with
      Z0 => false
    | _ => check_range v r' (Zpred sr)
    end
  end.

Definition check_primality (n:nat) :=
  check_range (Z_of_nat n)(pred (pred n))(Z_of_nat (pred n)).

Eval compute in (check_primality 2333).

Eval compute in (check_primality 2330).

Fixpoint check_range' (v:Z)(r:nat){struct r} : bool :=
  match r with
    0 => true | 1 => true
  | S r' =>
      match (v mod Z_of_nat r)%Z with
      | 0%Z => false
      | _ => check_range' v r'
      end
  end.

Definition check_primality' (n:nat) :=
  check_range' (Zpos (P_of_succ_nat (pred n)))(pred (pred n)).

Theorem Zabs_nat_0 : forall x:Z, Zabs_nat x = 0 -> (x = 0)%Z.
Proof.
 intros x; case x.
 simpl; auto.
 intros p Heq; elim (lt_irrefl 0).
 pattern 0 at 2; rewrite <- Heq.
 simpl; apply lt_O_nat_of_P.
 intros p Heq; elim (lt_irrefl 0).
 pattern 0 at 2; rewrite <- Heq.
 simpl; apply lt_O_nat_of_P.
Qed.

Theorem Z_to_nat_and_back :
 forall x:Z, (0 <= x)%Z -> (Z_of_nat (Zabs_nat x))=x.
Proof.
 intros x; case x.
 auto.
 intros p Hd; elim p.
 unfold Zabs_nat.
 intros p' Hrec; rewrite nat_of_P_xI.
 rewrite inj_S.
 rewrite inj_mult.
 rewrite Zpos_xI.
 unfold Zsucc.
 rewrite Hrec.
 simpl; auto.
 unfold Zabs_nat.
 intros p' Hrec; rewrite nat_of_P_xO.
 rewrite inj_mult.
 rewrite Zpos_xO.
 unfold Zsucc.
 rewrite Hrec.
 simpl; auto.
 simpl; auto.
 intros p' Hd; elim Hd;auto.
Qed.

Theorem check_range_correct :
  forall (v:Z)(r:nat)(rz:Z),
  (0 < v)%Z ->
  Z_of_nat (S r) = rz -> check_range v r rz = true ->
  ~(exists k:nat, k <= (S r) /\ k <> 1 /\
                       (exists q:nat, Zabs_nat v = q*k)).
Proof.
 intros v r; elim r.
 intros rz Hlt H1 H2 Hex; case Hex; intros k; case k.
 intros (Hle, (Hne1, (q, Heq))).
 rewrite mult_comm in Heq; simpl in Heq.
 rewrite (Zabs_nat_0 _ Heq) in Hlt.
 elim (Zlt_irrefl 0); assumption.
 intros k' (Hle, (Hne1, (q, Heq))).
 inversion Hle.
 assert (H':k'=0).
 assumption.
 rewrite H' in Hne1; elim Hne1;auto.
 assert (H': S k' <= 0).
 assumption.
 inversion H'.
 intros r' Hrec rz Hlt H1 H2 Hex; case Hex; intros k; case k.
 intros (Hle, (Hne1, (q, Heq))).
 rewrite mult_comm in Heq; simpl in Heq.
 rewrite (Zabs_nat_0 _ Heq) in Hlt.
 elim (Zlt_irrefl 0); assumption.
 intros k' (Hle, (Hne1, (q, Heq))).
 inversion Hle.
 rewrite <- H1 in H2.
 rewrite <- (Z_to_nat_and_back v) in H2.
 assert (Hmod:(Z_of_nat (Zabs_nat v) mod Z_of_nat (S (S r')) = 0)%Z).
 apply verif_divide.
 replace 0 with (Zabs_nat 0%Z).
 apply Zabs_nat_lt.
 omega.
 simpl; auto.
 auto with arith.
 exists q.
 assert (H': k' = S r').
 assumption.
 rewrite <- H'.
 assumption.
 unfold check_range in H2.
 rewrite Hmod in H2.
 discriminate H2.
 omega.
 unfold check_range in H2; fold check_range in H2.
 caseEq ((v mod rz)%Z).
 intros Heqmod.
 rewrite Heqmod in H2.
 discriminate H2.
 intros pmod Heqmod; rewrite Heqmod in H2.
 elim (Hrec (Zpred rz) Hlt).
 rewrite <- H1.
 rewrite inj_S.
 rewrite inj_S.
 rewrite inj_S.
 rewrite <- Zpred_succ.
 auto.
 assumption.
 exists (S k').
 repeat split;auto.
 exists q; assumption.
 intros p Hmod.
 elim (Z_mod_lt v rz).
 rewrite Hmod.
 unfold Zle; simpl; intros Hle'; elim Hle';auto.
 rewrite <- H1.
 rewrite inj_S.
 unfold Zsucc.
 generalize (Zle_0_nat (S r')).
 intros; omega.
Qed.

Theorem nat_of_P_Psucc :
 forall p:positive, nat_of_P (Psucc p) = S (nat_of_P p).
Proof.
 intros p; elim p.
 simpl.
 intros p'.
 rewrite nat_of_P_xO.
 intros Heq; rewrite Heq.
 rewrite nat_of_P_xI.
 ring.
 intros p' Heq; simpl.
 rewrite nat_of_P_xI.
 rewrite nat_of_P_xO.
 auto.
 auto.
Qed.

Theorem nat_to_Z_and_back:
 forall n:nat, Zabs_nat (Z_of_nat n) = n.
Proof.
 intros n; elim n.
 auto.
 intros n'.
 simpl.
 case n'.
 simpl.
 auto.
 intros n''.
 simpl.
 rewrite nat_of_P_Psucc.
 intros Heq; rewrite Heq.
 auto.
Qed.

Theorem check_correct :
  forall p:nat, 0 < p -> check_primality p = true ->
  ~(exists k:nat, k <> 1 /\ k <> p /\ (exists q:nat, p = q*k)).
Proof.
 unfold lt.
 intros p Hle; elim Hle.
 intros Hcp (k, (Hne1, (Hne1bis, (q, Heq)))).
 rewrite mult_comm in Heq.
 assert (Hle' : k < 1).
 elim (le_lt_or_eq k 1); try(intuition; fail).
 apply divisor_smaller with (2:= Heq).
 auto.
 caseEq k.
 intros Heq'; rewrite Heq' in Heq; simpl in Heq; discriminate Heq.
 intros; omega.
 intros p' Hlep' Hrec; unfold check_primality.
 assert (H':(exists p'':nat, p' = (S p''))).
 inversion Hlep'.
 exists 0.
 auto.
 eapply ex_intro;eauto.
 elim H'; intros p'' Hp''; rewrite Hp''.
 repeat rewrite <- pred_Sn.
 intros Hcr Hex.
 elim check_range_correct with (3:= Hcr).
 rewrite inj_S; generalize (Zle_0_nat (S p'')).
 intros; omega.
 auto.
 elim Hex; intros k (Hne1, (HneSSp'', (q, Heq))); exists k.
 split.
 assert (HkleSSp'': k <= S (S p'')).
 apply (divisor_smaller (S (S p'')) q).
 auto with arith.
 rewrite mult_comm.
 assumption.
 omega.
 split.
 assumption.
 exists q.
 rewrite nat_to_Z_and_back.
 assumption.
Qed.

Theorem prime_2333 :
 ~(exists k:nat, k <> 1 /\ k <> 2333 /\ (exists q:nat, 2333 = q*k)).
 Time apply check_correct; auto with arith.
(**Finished transaction in 132. secs (131.01u,0.62s)*)
Time Qed.

Theorem reflection_test :
 forall x y z t u:nat, x+(y+z+(t+u)) = x+y+(z+(t+u)).
Proof.
 intros; repeat rewrite plus_assoc; auto.
Qed.

Inductive bin : Set := node : bin->bin->bin | leaf : nat->bin.

Fixpoint flatten_aux (t fin:bin){struct t} : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten_aux t2 fin)
  | x => node x fin
  end.

Fixpoint flatten (t:bin) : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten t2)
  | x => x
  end.

Eval compute in
  (flatten
     (node (leaf 1) (node (node (leaf 2)(leaf 3)) (leaf 4)))).

Fixpoint bin_nat (t:bin) : nat :=
  match t with
  | node t1 t2 => bin_nat t1 + bin_nat t2
  | leaf n => n
  end.

Eval lazy beta iota delta [bin_nat] in
 (bin_nat
   (node (leaf 1) (node (node (leaf 2) (leaf 3)) (leaf 4)))).

Theorem flatten_aux_valid :
 forall t t':bin, bin_nat t + bin_nat t' = bin_nat (flatten_aux t t').
Proof.
 intros t; elim t; simpl; auto.
 intros t1 IHt1 t2 IHt2 t'; rewrite <- IHt1; rewrite <- IHt2.
 rewrite plus_assoc; trivial.
Qed.

Theorem flatten_valid : forall t:bin, bin_nat t = bin_nat (flatten t).
Proof.
 intros t; elim t; simpl; auto.
 intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid; rewrite <- IHt2.
 trivial.
Qed.

Theorem flatten_valid_2 :
  forall t t':bin, bin_nat (flatten t) = bin_nat (flatten t')->
  bin_nat t = bin_nat t'.
Proof.
 intros; rewrite (flatten_valid t); rewrite (flatten_valid t');
 auto.
Qed.

Theorem reflection_test' :
 forall x y z t u:nat, x+(y+z+(t+u))=x+y+(z+(t+u)).
Proof.
 intros.
 change
   (bin_nat
      (node (leaf x)
         (node (node (leaf y) (leaf z))
               (node (leaf t)(leaf u)))) =
    bin_nat
      (node (node (leaf x)(leaf y))
         (node (leaf z)
               (node (leaf t)(leaf u))))).
 apply flatten_valid_2; auto.
Qed.

Ltac model v :=
  match v with
  | (?X1 + ?X2) =>
    let r1 := model X1
              with r2 := model X2 in constr:(node r1 r2)
  | ?X1 => constr:(leaf X1)
  end.

Ltac assoc_eq_nat :=
  match goal with
  | [ |- (?X1 = ?X2 :>nat) ] =>
   let term1 := model X1 with term2 := model X2 in
   (change (bin_nat term1 = bin_nat term2);
    apply flatten_valid_2;
    lazy beta iota zeta delta [flatten flatten_aux bin_nat];
    auto)
  end.

Theorem reflection_test'' :
 forall x y z t u:nat, x+(y+z+(t+u)) = x+y+(z+(t+u)).
Proof.
 intros; assoc_eq_nat.
Qed.

Section assoc_eq.
Variables (A : Set)(f : A->A->A)
  (assoc : forall x y z:A, f x (f y z) = f (f x y) z).

Fixpoint bin_A (l:list A)(def:A)(t:bin){struct t} : A :=
  match t with
  | node t1 t2 => f (bin_A l def t1)(bin_A l def t2)
  | leaf n => nth n l def
  end.

Theorem flatten_aux_valid_A :
 forall (l:list A)(def:A)(t t':bin),
 f (bin_A l def t)(bin_A l def t') = bin_A l def (flatten_aux t t').
Proof.
 intros l def t; elim t; simpl; auto.
 intros t1 IHt1 t2 IHt2 t';  rewrite <- IHt1; rewrite <- IHt2.
 symmetry; apply assoc.
Qed.

Theorem flatten_valid_A :
 forall (l:list A)(def:A)(t:bin),
   bin_A l def t = bin_A l def (flatten t).
Proof.
 intros l def t; elim t; simpl; trivial.
 intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid_A; rewrite <- IHt2.
 trivial.
Qed.

Theorem flatten_valid_A_2 :
 forall (t t':bin)(l:list A)(def:A),
   bin_A l def (flatten t) = bin_A l def (flatten t')->
   bin_A l def t = bin_A l def t'.
Proof.
 intros t t' l def Heq.
 rewrite (flatten_valid_A l def t); rewrite (flatten_valid_A l def t').
 trivial.
Qed.

End assoc_eq.

Check flatten_valid_A_2.

Ltac term_list f l v :=
  match v with
  | (f ?X1 ?X2) =>
    let l1 := term_list f l X2 in term_list f l1 X1
  | ?X1 => constr:(cons X1 l)
  end.

Ltac compute_rank l n v :=
  match l with
  | (cons ?X1 ?X2) =>
    let tl := constr:X2 in
    match constr:(X1 = v) with
    | (?X1 = ?X1) => n
    | _ => compute_rank tl (S n) v
    end
  end.

Ltac model_aux l f v :=
  match v with
  | (f ?X1 ?X2) =>
    let r1 := model_aux l f X1 with r2 := model_aux l f X2 in
      constr:(node r1 r2)
  | ?X1 => let n := compute_rank l 0 X1 in constr:(leaf n)
  | _ => constr:(leaf 0)
  end.

Ltac model_A A f def v :=
  let l := term_list f (nil (A:=A)) v in
  let t := model_aux l f v in
  constr:(bin_A A f l def t).

Ltac assoc_eq A f assoc_thm :=
  match goal with
  | [ |- (@eq A ?X1 ?X2) ] =>
  let term1 := model_A A f X1 X1
  with term2 := model_A A f X1 X2 in
  (change (term1 = term2);
   apply flatten_valid_A_2 with (1 := assoc_thm); auto)
  end.

Theorem reflection_test3 :
 forall x y z t u:Z, (x*(y*z*(t*u)) = x*y*(z*(t*u)))%Z.
Proof.
 intros; assoc_eq Z Zmult Zmult_assoc.
Qed.

Reset bin_nat.

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

Fixpoint insert_bin (n:nat)(t:bin){struct t} : bin :=
  match t with
  | leaf m => match nat_le_bool n m with
              | true => node (leaf n)(leaf m)
              | false => node (leaf m)(leaf n)
              end
  | node (leaf m) t' => match nat_le_bool n m with
                        | true => node (leaf n) t
                        | false =>
                            node (leaf m)(insert_bin n t')
                        end
  | t => node (leaf n) t
  end.

Fixpoint sort_bin (t:bin) : bin :=
  match t with
  | node (leaf n) t' => insert_bin n (sort_bin t')
  | t => t
  end.

Section commut_eq.
 Variables (A : Set)(f : A->A->A).
 Hypothesis comm : forall x y:A, f x y = f y x.
 Hypothesis assoc : forall x y z:A, f x (f y z) = f (f x y) z.

 Fixpoint bin_A (l:list A)(def:A)(t:bin){struct t} : A :=
   match t with
   | node t1 t2 => f (bin_A l def t1)(bin_A l def t2)
   | leaf n => nth n l def
   end.

 Theorem flatten_aux_valid_A :
  forall (l:list A)(def:A)(t t':bin),
   f (bin_A l def t)(bin_A l def t') = bin_A l def (flatten_aux t t').
 Proof.
  intros l def t; elim t; simpl; auto.
  intros t1 IHt1 t2 IHt2 t';  rewrite <- IHt1; rewrite <- IHt2.
  symmetry; apply assoc.
 Qed.

 Theorem flatten_valid_A :
  forall (l:list A)(def:A)(t:bin),
    bin_A l def t = bin_A l def (flatten t).
 Proof.
  intros l def t; elim t; simpl; trivial.
  intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid_A; rewrite <- IHt2.
  trivial.
 Qed.

Theorem flatten_valid_A_2 :
 forall (t t':bin)(l:list A)(def:A),
   bin_A l def (flatten t) = bin_A l def (flatten t')->
   bin_A l def t = bin_A l def t'.
Proof.
 intros t t' l def Heq.
 rewrite (flatten_valid_A l def t); rewrite (flatten_valid_A l def t').
 trivial.
Qed.

Theorem insert_is_f : forall (l:list A)(def:A)(n:nat)(t:bin),
   bin_A l def (insert_bin n t) =
   f (nth n l def) (bin_A l def t).
Proof.
 intros l def n t; elim t.
 intros t1; case t1.
 intros t1' t1'' IHt1 t2 IHt2.
 simpl.
 auto.
 intros n0 IHt1 t2 IHt2.
 simpl.
 case (nat_le_bool n n0).
 simpl.
 auto.
 simpl.
 rewrite IHt2.
 repeat rewrite assoc; rewrite (comm (nth n l def)); auto.
 simpl.
 intros n0; case (nat_le_bool n n0); auto.
 rewrite comm; auto.
Qed.

Theorem sort_eq : forall (l:list A)(def:A)(t:bin),
    bin_A l def (sort_bin t) = bin_A l def t.
Proof.
 intros l def t; elim t.
 intros t1 IHt1; case t1.
 auto.
 intros n t2 IHt2; simpl; rewrite insert_is_f.
 rewrite IHt2; auto.
 auto.
Qed.

Theorem sort_eq_2 :
 forall (l:list A)(def:A)(t1 t2:bin),
   bin_A l def (sort_bin t1) = bin_A l def (sort_bin t2)->
   bin_A l def t1 = bin_A l def t2.
Proof.
 intros l def t1 t2.
 rewrite <- (sort_eq l def t1); rewrite <- (sort_eq l def t2).
 trivial.
Qed.

End commut_eq.

Ltac term_list f l v :=
  match v with
  | (f ?X1 ?X2) =>
    let l1 := term_list f l X2 in term_list f l1 X1
  | ?X1 => constr:(cons X1 l)
  end.

Ltac compute_rank l n v :=
  match l with
  | (cons ?X1 ?X2) =>
    let tl := constr:X2 in
    match constr:(X1 = v) with
    | (?X1 = ?X1) => n
    | _ => compute_rank tl (S n) v
    end
  end.

Ltac model_aux l f v :=
  match v with
  | (f ?X1 ?X2) =>
    let r1 := model_aux l f X1 with r2 := model_aux l f X2 in
      constr:(node r1 r2)
  | ?X1 => let n := compute_rank l 0 X1 in constr:(leaf n)
  | _ => constr:(leaf 0)
  end.

Ltac comm_eq A f assoc_thm comm_thm :=
  match goal with
  | [ |- (?X1 = ?X2 :>A) ] =>
    let l := term_list f (nil (A:=A)) X1 in
    let term1 := model_aux l f X1
    with term2 := model_aux l f X2 in
    (change (bin_A A f l X1 term1 = bin_A A f l X1 term2);
      apply flatten_valid_A_2 with (1 := assoc_thm);
      apply sort_eq_2 with (1 := comm_thm)(2 := assoc_thm);
      auto)
  end.
Theorem reflection_test4 : forall x y z:Z, (x+(y+z) = (z+x)+y)%Z.
Proof.
 intros x y z. comm_eq Z Zplus Zplus_assoc Zplus_comm.
Qed.


Require Import Coq.Structures.OrdersAlt.
Require Import CommonTacs.
Require Import Xform.
Require Import ParserArg.
Import MIPS_PARSER_ARG.

Set Implicit Arguments.

Inductive regexp : Set :=
| rEps : regexp
| rZero : regexp
| rChar : char_p -> regexp
| rAny : regexp
| rCat : regexp -> regexp -> regexp
| rAlt : regexp -> regexp -> regexp
| rStar : regexp -> regexp.

(** Compute the return [xtype] of an [regexp]. *)
Fixpoint regexp_type (pg : regexp) : xtype :=
  match pg with
    | rEps => xUnit_t
    | rZero => xVoid_t
    | rChar _ => xChar_t
    | rAny => xChar_t
    | rCat pg1 pg2 => xPair_t (regexp_type pg1) (regexp_type pg2)
    | rAlt pg1 pg2 => xSum_t (regexp_type pg1) (regexp_type pg2)
    | rStar pg => xList_t (regexp_type pg)
  end.

Inductive in_regexp : forall a, list char_p -> xt_interp (regexp_type a) -> Prop :=
| InrEps : forall s v, s = nil -> v = tt -> in_regexp rEps s v
| InrChar : forall c s v, s = c::nil -> v = c -> in_regexp (rChar c) s v
| InrAny : forall c s v, s = c::nil -> v = c -> in_regexp rAny s v
| InrCat :
    forall a1 a2 s1 s2 v1 v2 s v,
      in_regexp a1 s1 v1 -> in_regexp a2 s2 v2 -> s = s1 ++ s2 -> v = (v1,v2) ->
      in_regexp (rCat a1 a2) s v
| InrAlt_l :
    forall a1 a2 s v1 v,
      in_regexp a1 s v1 -> v = inl _ v1 -> in_regexp (rAlt a1 a2) s v
| InrAlt_r :
    forall a1 a2 s v2 v,
      in_regexp a2 s v2 -> v = inr _ v2 -> in_regexp (rAlt a1 a2) s v
| InrStar_eps : forall a s v, s = nil -> v = nil -> in_regexp (rStar a) s v
| InrStar_cons :
    forall a s1 v1 s2 v2 s v,
      in_regexp a s1 v1 -> in_regexp (rStar a) s2 v2 ->
      s1 <> nil -> s = s1 ++ s2 -> v = v1::v2 -> in_regexp (rStar a) s v.
Hint Constructors in_regexp.

(** * Inversion principles for [regexp]s. *)

Lemma inv_eps : forall s v, in_regexp rEps s v -> s = nil /\ v = tt.
Proof. intros. inversion H. crush. Qed.

Lemma inv_zero : forall s v, in_regexp rZero s v -> False.
Proof. intros. inversion H. Qed.

Lemma inv_char : forall c s v, in_regexp (rChar c) s v -> s = c::nil /\ v = c.
Proof.  intros. inversion H. subst. crush. Qed.

Lemma inv_any : forall s v, in_regexp rAny s v -> s = v::nil.
Proof.  intros. inversion H. crush. Qed.

Lemma inv_cat : forall r1 r2 s v, in_regexp (rCat r1 r2) s v ->
  exists s1, exists s2, exists v1, exists v2,
    in_regexp r1 s1 v1 /\ in_regexp r2 s2 v2 /\ s = s1++s2 /\ v = (v1,v2).
Proof.
  intros ; inversion H ; subst ; crush. exists s1. exists s2. exists v1. exists v2.
  auto.
Qed.

Lemma inv_cat_nil : forall r1 r2 v, in_regexp (rCat r1 r2) nil v ->
  exists v1, exists v2, in_regexp r1 nil v1 /\ in_regexp r2 nil v2 /\ v = (v1,v2).
Proof. intros. apply inv_cat in H.
  destruct H as [s1 [s2 [v1 [v2 H1]]]].
  sim. exists v1, v2.
  symmetry in H1. apply app_eq_nil in H1.
  crush.
Qed.

Lemma inv_alt : forall r1 r2 s v, in_regexp (rAlt r1 r2) s v ->
  (exists v1, in_regexp r1 s v1 /\ v = inl _ v1) \/
  (exists v2, in_regexp r2 s v2 /\ v = inr _ v2) .
Proof. intros ; inversion H ; subst ; crush. Qed.

Lemma inv_star: forall r s v, in_regexp (rStar r) s v ->
  (s = nil /\ v = nil) \/
  (exists s1 s2 v1 v2,
     in_regexp r s1 v1 /\ in_regexp (rStar r) s2 v2 /\
     s1 <> nil /\ s = s1++s2 /\ v=v1::v2).
Proof. intros. inversion H; try crush.
  right. exists s1, s2, v1, v2. crush.
Qed.

Lemma inv_star_nil: forall r v, in_regexp (rStar r) nil v -> v = nil.
Proof. intros. apply inv_star in H.
  destruct H. crush.
  sim. destruct x; crush.
Qed.

(** Inversion tactic for [regexp]. *)
Ltac in_regexp_inv :=
  match goal with
    | [ H: in_regexp rZero _ _ |- _ ] => contradiction (inv_zero H)
    | [ H : in_regexp rEps _ _ |- _ ] =>
      generalize (inv_eps H) ; clear H ; crush
    | [ H : in_regexp (rChar _) _ _ |- _] =>
      generalize (inv_char H) ; clear H ; crush
    | [ H : in_regexp rAny _ _ |- _] =>
      generalize (inv_any H) ; clear H ; crush
    | [ H : in_regexp (rCat _ _) nil _ |- _] =>
      generalize (inv_cat_nil H) ; clear H ; crush
    | [ H : in_regexp (rCat _ _) _ _ |- _] =>
      generalize (inv_cat H) ; clear H ; crush
    | [ H : in_regexp (rAlt _ _) _ _ |- _] =>
      generalize (inv_alt H) ; clear H ;  crush
    | [ H : in_regexp (rStar _) nil _ |- _] =>
      generalize (inv_star_nil H) ; clear H ;  crush
    | [ H : in_regexp (rStar _) _ _ |- _] =>
      generalize (inv_star H) ; clear H ;  crush
  end.

(** This function computes the list of all values v, such that
    [in_regexp nil v] holds. *)
Fixpoint regexp_extract_nil (r:regexp) : list (xt_interp (regexp_type r)) :=
  match r return list (xt_interp (regexp_type r)) with
    | rEps => tt::nil
    | rZero => nil
    | rChar _ => nil
    | rAny => nil
    | rCat ag1 ag2 => list_prod (regexp_extract_nil ag1) (regexp_extract_nil ag2)
    | rAlt ag1 ag2 =>
      (List.map (fun x => inl _ x) (regexp_extract_nil ag1)) ++
      (List.map (fun x => inr _ x) (regexp_extract_nil ag2))
    | rStar ag => nil::nil
  end.

(** Nullable (r) returns true iff r can match the empty string *)
Fixpoint regexp_nullable (r:regexp) : bool :=
  match r with
    | rZero | rChar _ | rAny => false
    | rEps => true
    | rCat r1 r2 => regexp_nullable r1 && regexp_nullable r2
    | rAlt r1 r2 => regexp_nullable r1 || regexp_nullable r2
    | rStar r1 => true
  end.

Fixpoint regexp_always_rejects (r:regexp) : bool :=
  match r with
    | rEps => false
    | rChar _ => false
    | rAny => false
    | rZero => true
    | rAlt r1 r2 => regexp_always_rejects r1 && regexp_always_rejects r2
    | rCat r1 r2 => regexp_always_rejects r1 || regexp_always_rejects r2
    | rStar _ => false
  end.

(** * Ordering for regexps *)

(** Use lexicographic ordering when ordering two regexps. *)
Fixpoint compare_re (r1 r2:regexp) : comparison :=
  match r1 with
    | rEps => match r2 with
                | rEps => Eq
                | _ => Lt
              end
    | rZero => match r2 with
                 | rEps => Gt
                 | rZero => Eq
                 | _ => Lt
               end
    | rChar c1 =>
      match r2 with
        | rEps | rZero => Gt
        | rChar c2 => char_cmp c1 c2
        | _ => Lt
      end
    | rAny => match r2 with
                | rEps | rZero | rChar _ => Gt
                | rAny => Eq
                | _ => Lt
              end
    | rCat r11 r12 =>
      match r2 with
        | rEps | rZero | rChar _ | rAny => Gt
        | rCat r21 r22 =>
          let cp := compare_re r11 r21 in
          match cp with
            | Eq => compare_re r12 r22
            | _ => cp
          end
        | _ => Lt
      end
    | rAlt r11 r12 =>
      match r2 with
        | rEps | rZero | rChar _ | rAny | rCat _ _ => Gt
        | rAlt r21 r22 =>
          let cp := compare_re r11 r21 in
          match cp with
            | Eq => compare_re r12 r22
            | _ => cp
          end
        | _ => Lt
      end
    | rStar r11 =>
      match r2 with
        | rEps | rZero | rChar _ | rAny | rCat _ _ | rAlt _ _ => Gt
        | rStar r21 => compare_re r11 r21
      end
  end.

Lemma compare_re_eq_leibniz:
  forall r1 r2, compare_re r1 r2 = Eq -> r1 = r2.
Proof. induction r1; try (destruct r2; simpl; congruence; fail).
       Case "rChar".
       destruct r2; simpl; try congruence. intros.
       rewrite (char_eq_leibniz c c0) ; auto.
       Case "rCat".
       destruct r2; simpl; try congruence.
       remember_rev (compare_re r1_1 r2_1) as cmp.
       destruct cmp; crush_hyp.
       Case "rAlt".
       destruct r2; simpl; try congruence.
       remember_rev (compare_re r1_1 r2_1) as cmp.
       destruct cmp; crush_hyp.
       Case "rStar".
       destruct r2; simpl; try congruence.
       crush_hyp.
Qed.

Module REOrderedTypeAlt <: OrderedTypeAlt.
  Definition t:=regexp.
  Definition compare := compare_re.

  Lemma compare_sym : forall r1 r2, compare r2 r1 = CompOpp (compare r1 r2).
  Proof. induction r1; try (destruct r2; trivial; fail).
    Case "rChar".
      destruct r2; trivial.
      generalize (CharOrderedTypeAlt.compare_sym c c0). simpl. auto.
    Case "rCat".
      destruct r2; trivial. simpl.
        rewrite (IHr1_1 r2_1). destruct (compare r1_1 r2_1); simpl; eauto.
    Case "rAlt".
      destruct r2; trivial. simpl.
        rewrite (IHr1_1 r2_1). destruct (compare r1_1 r2_1); simpl; eauto.
    Case "rStar".
      destruct r2; trivial. simpl. eauto.
  Qed.

  Lemma compare_trans:
    forall cmp r1 r2 r3,
      compare r1 r2 = cmp -> compare r2 r3 = cmp -> compare r1 r3 = cmp.
  Proof. intros cmp r1. generalize cmp.
    induction r1;
    try (destruct r2; destruct r3; simpl; congruence; fail).
    Local Ltac trans_simp :=
      match goal with
        | [H:compare ?R1 ?R2 = Eq |- _] =>
          apply compare_re_eq_leibniz in H; subst R2
      end.
    Case "rChar".
      destruct r2; destruct r3; simpl; try congruence.
      apply (CharOrderedTypeAlt.compare_trans).
    Case "rCat".
      destruct r2; destruct r3; simpl; try congruence.
      remember_rev (compare r1_1 r2_1) as cmp1.
      remember_rev (compare r2_1 r3_1) as cmp2.
      destruct cmp1; destruct cmp2;
        try (repeat trans_simp; crush; fail).
        assert (H10:compare r1_1 r3_1 = Eq) by eauto.
        rewrite H10. eauto.
        assert (H10:compare r1_1 r3_1 = Lt) by eauto.
        rewrite H10. eauto.
        assert (H10:compare r1_1 r3_1 = Gt) by eauto.
        rewrite H10. eauto.
    Case "rAlt".
      destruct r2; destruct r3; simpl; try congruence.
      remember_rev (compare r1_1 r2_1) as cmp1.
      remember_rev (compare r2_1 r3_1) as cmp2.
      destruct cmp1; destruct cmp2;
        try (repeat trans_simp; crush; fail).
        assert (H10:compare r1_1 r3_1 = Eq) by eauto.
        rewrite H10. eauto.
        assert (H10:compare r1_1 r3_1 = Lt) by eauto.
        rewrite H10. eauto.
        assert (H10:compare r1_1 r3_1 = Gt) by eauto.
        rewrite H10. eauto.
    Case "rStar".
      destruct r2; destruct r3; simpl; (congruence || eauto).
  Qed.

End REOrderedTypeAlt.

Module REOrderedType := OT_from_Alt REOrderedTypeAlt.


Require Import Vec.

(* SIMPLIFICATIONS
 * ~~~~~~~~~~~~~~~
 * Single class parameter
 * Single method for each class
 * Methods have a monotype
 * No recursion (yet)
 * No let-bindings (yet)
 *)

(* Monotype *)
Inductive Mono : Set :=
  | TyVar (a : nat)
  | TyArr (τ₁ τ₂ : Mono).

(* Class Constraint *)
Inductive Ct : Set :=
  | MkCt (cn : nat) (τ : Mono).

(* Qualified Type *)
Inductive Qual : Set :=
  | QMono (τ : Mono)
  | QQual (π : Ct) (ρ : Qual).

(* Polytype *)
Inductive Poly : Set :=
  | PQual (π : Qual)
  | PPoly (σ : Poly).

(* Term *)
(* TODO: ADD LET BINDINGS *)
Inductive HsTm : Set :=
  | TmVar (x : nat)
  | TmAbs (e : HsTm)
  | TmApp (e₁ e₂ : HsTm).

(* Class Declaration *)
Inductive Cls : Set :=
  | MkCls n (scs : Vec Ct n) (md : Mono).

(* Instance Declaration *)
Inductive Ins : Set :=
  | MkIns (bnds : nat) n (ctx : Vec Ct n) (cn : nat) (τ : Mono) (e : HsTm).

(* Top-level Value Binding *)
Inductive Val : Set :=
  | MkVal (e : HsTm).

(* Top-level Value Binding with a Signature *)
Inductive Sig : Set :=
  | MkSig (e : HsTm) (σ : Poly).

(* Source Program *)
Inductive Pgm : Set :=
  | PgmEmpty
  | PgmCls (cls : Cls) (pgm : Pgm)
  | PgmIns (ins : Ins) (pgm : Pgm)
  | PgmVal (val : Val) (pgm : Pgm)
  | PgmSig (sig : Sig) (pgm : Pgm).


Require Import Arith.

Set Implicit Arguments.

Fixpoint ack n :=
  match n with
    | 0 => S
    | S n' =>
      let fix f m :=
        match m with
          | 0 => ack n' 1
          | S m' => ack n' (f m')
        end
        in f
  end.

Fixpoint fin n : Set :=
  match n with
    | 0 => Empty_set
    | S n' => (unit + fin n')%type
  end.

Inductive prim_rec : nat -> Set :=
| pr_proj : forall n, fin n -> prim_rec n
| pr_succ : prim_rec 1
| pr_const : forall n, nat -> prim_rec n
| pr_compose :
  forall m n, (fin n -> prim_rec m) -> prim_rec n -> prim_rec m
| pr_primrec :
  forall n, prim_rec n -> prim_rec (S (S n)) -> prim_rec (S n).

Notation F0 := (inl _ tt).
Notation FS x := (inr _ x).

Definition hd n (ns : fin (S n) -> nat) := ns F0.
Definition tl n (ns : fin (S n) -> nat) := fun i => ns (FS i).

Notation "[ x , y ]" := (fun i => match i with inl _ => x | inr i' => y i' end).

Fixpoint eval n (f : prim_rec n) : (fin n -> nat) -> nat :=
  match f with
    | pr_proj n i => fun ns => ns i
    | pr_succ => fun ns => S (ns F0)
    | pr_const n k => fun _ => k
    | pr_compose m n fs g => fun ns => eval g (fun i => eval (fs i) ns)
    | pr_primrec n f g => fun ns =>
      let fix h m :=
        match m with
          | 0 => eval f (tl ns)
          | S m' => eval g [m', [h m', tl ns]]
        end
        in h (ns F0)
  end.

Theorem ack_is_not_primitive_recursive :
  forall f : prim_rec 2, exists m:nat, exists n:nat,
    (eval f (fun i:fin 2 => if i then m else n:nat)) <> ack m n.
fix f 1.
intro.
refine match f0 as xyz return exists m : nat,
  exists n : nat, eval f0 (fun i : fin 2 => if i then m else n:nat) <> ack m n
with
|pr_proj n i=> _
|pr_succ => _
|pr_const n k=> _
|pr_compose m n fs g => _
|pr_primrec n f g => _
end.
Guarded.
unfold eval.

simpl.
inversion f as [| n0 | n1 arg0| m2 n2 f0 f1 | n3 f2 f3 ].
simpl.
unfold eval.
simpl.
Admitted.
Print ack_is_not_primitive_recursive.


Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  (* WORKED IN CLASS *)
  intros P H. unfold not. intros G. apply G. apply H.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e152m17_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e158m15_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(* by Evelyne Contejean *)
Require Import List.
From Cyclic_PA.Casteran Require Import more_list.
From Cyclic_PA.Casteran Require Import list_permut.
From Cyclic_PA.Casteran Require Import dickson.
Require Import Relations.
Require Import Wellfounded.
Require Import Arith.
Require Import Wf_nat.
From Cyclic_PA.Casteran Require Import term.

(** A non-dependant version of lexicographic extension. *)
Definition lex (A B : Set) (eq_A_dec : forall a1 a2, {a1=a2}+{a1<>a2})
(o1 : relation A) (o2 : relation B) (s t : _ * _) :=
  match s with
  | (s1,s2) =>
    match t with
    | (t1,t2) =>
       if eq_A_dec s1 t1
       then o2 s2 t2
       else o1 s1 t1
     end
   end.

(** Transitivity of  lexicographic extension. *)
Lemma lex_trans :
 forall (A B : Set) eq_A_dec o1 o2,
 antisymmetric A o1 -> transitive A o1 -> transitive B o2 ->
 transitive _ (lex _ _ eq_A_dec o1 o2).
Proof.
unfold transitive, lex;
intros A B eq_A_dec o1 o2 A1 T1 T2 p1 p2 p3;
destruct p1 as [a1 b1]; destruct p2 as [a2 b2]; destruct p3 as [a3 b3];
elim (eq_A_dec a1 a2); intro eq1.
subst a2; elim (eq_A_dec a1 a3); intro eq2; trivial; apply T2.
intro lt1; elim (eq_A_dec a1 a3); intro eq3.
subst a3; elim (eq_A_dec a2 a1); intro eq2.
subst a2; absurd (a1=a1); trivial.
intro lt2; generalize (A1 _ _ lt1 lt2); contradiction.
elim (eq_A_dec a2 a3); intro eq4.
subst a3; trivial.
intro lt2; apply T1 with a2; trivial.
Qed.

(** Well-foundedness of  lexicographic extension. *)
Lemma wf_lex :
  forall A B eq_A_dec o1 o2, well_founded o1 -> well_founded o2 ->
  well_founded (lex A B eq_A_dec o1 o2).
Proof.
intros A B eq_A_dec o1 o2 W1 W2; unfold well_founded in *; destruct a.
generalize b; clear b; pattern a; refine (well_founded_ind W1 _ _ a);
clear a; intros a IH1 b; pattern b; refine (well_founded_ind W2 _ _ b).
clear b; intros b IH2; apply Acc_intro.
destruct y; simpl; elim (eq_A_dec a0 a); intro a0_eq_a.
subst a0; apply IH2.
intro; apply IH1; trivial.
Qed.

(** ** Module Type Precedence,
** Definition of a precedence. *)
Module Type Precedence.
Parameter A : Set.
Parameter prec : relation A.

Inductive status_type : Set :=
  | Lex : status_type
  | Mul : status_type.

Parameter status : A -> status_type.

Axiom prec_dec : forall a1 a2 : A, {prec a1 a2} + {~ prec a1 a2}.
Axiom prec_antisym : forall s, prec s s -> False.
Axiom prec_transitive : transitive A prec.

End Precedence.

(** ** Module Type RPO,
** Definition of RPO from a precedence on symbols. *)

Module Type RPO.

Declare Module T : term.Term.
Declare Module P : Precedence with Definition A:= T.symbol.

Import T.
Import P.
Declare Module LP : list_permut.Permut with Definition DS.A:=term.
Import LP.

(** ** Definition of rpo.*)
Inductive rpo : term -> term -> Prop :=
  | Subterm : forall f l t s, In s l -> rpo_eq t s -> rpo t (Term f l)
  | Top_gt :
       forall f g l l', prec g f ->
       (forall s', In s' l' -> rpo s' (Term f l)) ->
       rpo (Term g l') (Term f l)
  | Top_eq_lex :
        forall f l l', status f = Lex -> rpo_lex l' l ->
        (forall s', In s' l' -> rpo s' (Term f l)) ->
        rpo (Term f l') (Term f l)

  | Top_eq_mul :
        forall f l l', status f = Mul -> rpo_mul l' l ->
        rpo (Term f l') (Term f l)

with rpo_eq : term -> term -> Prop :=
  | Eq : forall t, rpo_eq t t
  | Lt : forall s t, rpo s t -> rpo_eq s t

with rpo_lex : list term -> list term -> Prop :=
  | List_gt :
      forall s t l l', rpo s t -> length l = length l' ->
      rpo_lex (s :: l) (t :: l')
  | List_eq : forall s l l', rpo_lex l l' -> rpo_lex (s :: l) (s :: l')

with rpo_mul : list term -> list term -> Prop :=
  | List_mul :
       forall a lg ls lc l l',
       list_permut l' (ls ++ lc) ->
       list_permut l (a :: lg ++ lc) ->
       (forall b, In b ls -> exists a', In a' (a :: lg) /\ rpo b a') ->
       rpo_mul l' l.

(** ** rpo is a preorder, and its reflexive closure is an ordering. *)
Axiom rpo_closure :
  forall s t u,
  (rpo t s -> rpo u t -> rpo u s) /\
  (rpo s t -> rpo t s -> False) /\
  (rpo s s -> False) /\
  (rpo_eq s t -> rpo_eq t s -> s = t).

Axiom rpo_trans : forall s t u, rpo t s -> rpo u t -> rpo u s.

(** ** Main theorem: when the precedence is well-founded, so is the rpo. *)
Axiom wf_rpo : well_founded prec -> well_founded rpo.

(** ** RPO is compatible with the instanciation by a substitution. *)
Axiom rpo_subst :
  forall t s, rpo s t ->
  forall sigma, rpo (apply_subst sigma s) (apply_subst sigma t).

(** ** RPO is compatible with adding context. *)
Axiom rpo_add_context :
 forall p ctx s t, rpo s t -> is_a_pos ctx p = true ->
  rpo (replace_at_pos ctx s p) (replace_at_pos ctx t p).

End RPO.

Module Make (T1: term.Term)
                    (P1 : Precedence with Definition A := T1.symbol)
<: RPO. (* with Module T := T1 with Module P:=P1. *)

Module T := T1.
Module P := P1.

Import T.
Import P.

Module LP := list_permut.Make (Term_eq_dec).
Import LP.

(** ** Definition of size-based well-founded orderings for induction.*)
Definition o_size s t := size s < size t.

Lemma wf_size :  well_founded o_size.
Proof.
generalize (well_founded_ltof _ size); unfold ltof; trivial.
Qed.

Definition size2 s := match s with (s1,s2) => (size s1, size s2) end.
Definition o_size2 s t := lex _ _ eq_nat_dec lt lt (size2 s) (size2 t).
Lemma wf_size2 : well_founded o_size2.
Proof.
refine (wf_inverse_image _ _ (lex _ _ eq_nat_dec lt lt) size2 _);
apply wf_lex; apply lt_wf.
Qed.

Definition size3 s := match s with (s1,s2) => (size s1, size2 s2) end.
Definition o_size3 s t :=
  lex _ _ eq_nat_dec lt (lex _ _ eq_nat_dec lt lt) (size3 s) (size3 t).
Lemma wf_size3 : well_founded o_size3.
Proof.
refine (wf_inverse_image _ _
  (lex _ _ eq_nat_dec lt (lex _ _ eq_nat_dec lt lt)) size3 _);
apply wf_lex; [ idtac | apply wf_lex ]; apply lt_wf.
Qed.

Lemma lex1 :
 forall s f l t1 u1 t2 u2, In s l -> o_size3 (s,(t1,u1)) (Term f l,(t2,u2)).
Proof.
intros s f l t1 u1 t2 u2 In_s; unfold o_size3, size3, size2, lex;
elim (eq_nat_dec (size s) (size (Term f l))).
intro eq1; absurd (size (Term f l) < size (Term f l)); auto with arith;
generalize (size_direct_subterm s (Term f l) In_s); rewrite eq1; trivial.
intros; apply (size_direct_subterm s (Term f l) In_s).
Qed.

Lemma lex1_bis :
 forall a f l t1 u1 t2 u2, o_size3 (Term f l,(t1,u1)) (Term f (a::l),(t2,u2)).
Proof.
intros a f l t1 u1 t2 u2; unfold o_size3, size3, size2, lex;
elim (eq_nat_dec (size (Term f l)) (size (Term f (a :: l)))); intro eq1.
do 2 rewrite size_unfold in eq1; injection eq1; clear eq1; intro eq1;
absurd (list_size size l < list_size size l); auto with arith;
generalize (plus_le_compat_r _ _ (list_size size l) (size_ge_one a)).
(*replace (size a + list_size size l) with (list_size size (a::l)).*)
rewrite <- eq1; trivial.

do 2 rewrite size_unfold;
simpl; apply lt_n_S; apply lt_le_trans with (1 + list_size size l);
auto with arith;
apply plus_le_compat_r; apply size_ge_one.
Qed.

Lemma lex2 :
  forall t f l s u1 u2, In t l -> o_size3 (s,(t,u1)) (s,(Term f l, u2)).
Proof.
intros t f l s u1 u2 In_t;
unfold o_size3, size3, size2, lex;
elim (eq_nat_dec (size s) (size s)); intro eq1.
elim (eq_nat_dec (size t) (size (Term f l))); intro eq2.
absurd (size (Term f l) < size (Term f l)); auto with arith;
generalize (size_direct_subterm t (Term f l) In_t); rewrite eq2; trivial.
apply (size_direct_subterm t (Term f l) In_t).
absurd (size s = size s); trivial.
Qed.

Lemma lex3 :
  forall u f l s t, In u l -> o_size3 (s,(t,u)) (s,(t,Term f l)).
Proof.
intros u f l s t In_u;
unfold o_size3, size3, size2, lex;
elim (eq_nat_dec (size s) (size s)); intro eq1.
elim (eq_nat_dec (size t) (size t)); intro eq2.
apply (size_direct_subterm u (Term f l) In_u).
absurd (size t = size t); trivial.
absurd (size s = size s); trivial.
Qed.

Lemma o_size3_trans : transitive _ o_size3.
Proof.
generalize (lex_trans _ _ eq_nat_dec lt (lex _ _ eq_nat_dec lt lt));
unfold transitive, o_size3, size3, o_size2; intros H x y z lt1 lt2;
destruct x; destruct p; rename t into x1; rename t0 into x2; rename t1 into x3;
destruct y; destruct p; rename t into y1; rename t0 into y2; rename t1 into y3;
destruct z; destruct p; rename t into z1; rename t0 into z2; rename z1 into z3.
apply H with (size y1, size2 (y2,y3)); trivial.
unfold antisymmetric;
intros n m lt' lt''; generalize (lt_asym n m lt' lt''); contradiction.
apply lt_trans.
fold transitive; apply lex_trans.
unfold antisymmetric;
intros n m lt' lt''; generalize (lt_asym n m lt' lt''); contradiction.
unfold transitive; apply lt_trans.
unfold transitive; apply lt_trans.
Qed.

(** ** Definition of rpo.*)

Inductive rpo : term -> term -> Prop :=
  | Subterm : forall f l t s, In s l -> rpo_eq t s -> rpo t (Term f l)
  | Top_gt :
       forall f g l l', prec g f ->
       (forall s', In s' l' -> rpo s' (Term f l)) ->
       rpo (Term g l') (Term f l)
  | Top_eq_lex :
        forall f l l', status f = Lex -> rpo_lex l' l ->
        (forall s', In s' l' -> rpo s' (Term f l)) ->
        rpo (Term f l') (Term f l)

  | Top_eq_mul :
        forall f l l', status f = Mul -> rpo_mul l' l ->
        rpo (Term f l') (Term f l)

with rpo_eq : term -> term -> Prop :=
  | Eq : forall t, rpo_eq t t
  | Lt : forall s t, rpo s t -> rpo_eq s t

with rpo_lex : list term -> list term -> Prop :=
  | List_gt :
      forall s t l l', rpo s t -> length l = length l' ->
      rpo_lex (s :: l) (t :: l')
  | List_eq : forall s l l', rpo_lex l l' -> rpo_lex (s :: l) (s :: l')

with rpo_mul : list term -> list term -> Prop :=
  | List_mul :
       forall a lg ls lc l l',
       list_permut l' (ls ++ lc) ->
       list_permut l (a :: lg ++ lc) ->
       (forall b, In b ls -> exists a', In a' (a :: lg) /\ rpo b a') ->
       rpo_mul l' l.

Lemma rpo_lex_same_length :
  forall l l', rpo_lex l l' -> length l = length l'.
Proof.
induction l; intros l' rpo_lex_l; inversion rpo_lex_l.
simpl; rewrite H3; trivial.
simpl; rewrite (IHl l'0); trivial.
Qed.

Lemma rpo_subterm :
 forall s t, rpo t s -> forall tj, direct_subterm tj t -> rpo tj s.
Proof.
intros s t;
cut (forall p : term * term,
       match p with
       | (s,t) => rpo t s -> forall tj, direct_subterm tj t -> rpo tj s
       end).
intros H; apply (H (s,t)).
clear s t; intro p; pattern p; refine (well_founded_ind wf_size2 _ _ _);
clear p; intro p; destruct p; rename t into s; rename t0 into t;
intros IH H tj In_tj; inversion H; clear H.
subst s t0; inversion H1; clear H1.
subst s0 t0; apply (Subterm f l tj t); trivial;
apply Lt; destruct t; try contradiction;
apply (Subterm s l0 tj tj); trivial; apply Eq; trivial.
subst t t0; apply (Subterm f l tj s0); trivial;
apply Lt; refine (IH (s0, s) _ _ tj _); trivial.
unfold o_size2, size2, lex;
elim (eq_nat_dec (size s0) (size (Term f l))); intro eq1.
absurd (size (Term f l) < size (Term f l)); auto with arith;
generalize (size_direct_subterm s0 (Term f l) H0); rewrite eq1; trivial.
apply size_direct_subterm; trivial.

subst t s; apply H1; trivial.

subst t s; apply H2; trivial.

subst t s; inversion H1; clear H1.
subst l'0 l0; simpl in In_tj;
elim (in_app_or _ _ _ (in_permut_in tj In_tj H)); clear In_tj; intro In_tj.
elim (H3 tj In_tj); intros a' H4; elim H4; clear H4; intros H4 H5.
apply (Subterm f l tj a');
[ refine (in_permut_in a' _ (list_permut_sym H2));
rewrite app_comm_cons; apply in_or_app;  left
| apply Lt; apply H5 ]; trivial.
apply (Subterm f l tj tj);
[ refine (in_permut_in tj _ (list_permut_sym H2)); right;
apply in_or_app; right
| apply Eq ]; trivial.
Qed.

(** ** rpo is a preorder, and its reflexive closure is an ordering. *)
Lemma rpo_closure :
  forall s t u,
  (rpo t s -> rpo u t -> rpo u s) /\
  (rpo s t -> rpo t s -> False) /\
  (rpo s s -> False) /\
  (rpo_eq s t -> rpo_eq t s -> s = t).
Proof.
intros s t u;
cut (forall triple : term * (term * term),
       match triple with
       | (s,(t,u)) =>
         (rpo t s -> rpo u t -> rpo u s) /\
         (rpo s t -> rpo t s -> False) /\
         (rpo s s -> False) /\
         (rpo_eq s t -> rpo_eq t s -> s = t)
       end).
intros H; apply (H (s,(t,u))).
clear s t u; intro triple; pattern triple;
refine (well_founded_ind wf_size3 _ _ triple); clear triple.
intros x IH; destruct x; rename t into s; destruct p; rename t0 into u;
destruct s.
intuition.
inversion H.
inversion H0.
inversion H.
inversion_clear H0; trivial; inversion H1.

rename s into f; cut (rpo (Term f l)  (Term f l) -> False).
intro Anti0; cut (rpo (Term f l) t -> rpo t (Term f l) -> False).
intro Anti; intuition.

inversion H.
subst t0 f0 l0; inversion H5; clear H5.
subst t t0; apply (Subterm f l u s); trivial; apply Lt; trivial.
subst s0 t0; apply (Subterm f l u s); trivial; elim (IH (s,(t,u))); intuition.
apply Lt; trivial.
apply lex1; trivial.

subst t f0 l0; inversion H0.
subst u f0 l0; inversion H7; clear H7.
subst t t0; apply (rpo_subterm _ _ H); trivial.
subst s0 t0; elim (IH (Term f l,(s,t))); intuition; apply lex2; trivial.

subst u f0 l0; rename g0 into h; rename l'0 into l''; apply Top_gt.
apply prec_transitive with g; trivial.
intros; elim (IH (Term f l,(Term g l',s'))); intuition;  apply lex3; trivial.

subst f0 l0 u; rename l'0 into l''; apply Top_gt; trivial.
intros; elim (IH (Term f l, (Term g l',s'))); intuition; apply lex3; trivial.
subst u f0 l0; rename l'0 into l''; apply Top_gt; trivial.
inversion H7; subst l0 l'0.
intros s' In_s'; generalize (in_permut_in s' In_s' H1); clear In_s';
intro In_s'; elim (in_app_or _ _ _ In_s'); clear In_s';
intro In_s'.
elim (IH (Term f l, (Term g l', s'))); intuition.
apply H11; elim (H3 s' In_s'); intros tj H'; elim H'; clear H';
intros In_tj H'; apply (Subterm g l' s' tj);
[ refine (in_permut_in tj _ (list_permut_sym H2));
  rewrite app_comm_cons; apply in_or_app; left
| apply Lt ]; trivial.
apply lex3; refine (in_permut_in s' _ (list_permut_sym H1));
apply in_or_app; left; trivial.
apply (rpo_subterm _ _ H);
refine (in_permut_in s' _ (list_permut_sym H2));
rewrite app_comm_cons; apply in_or_app; right; trivial.

subst f0 l0 t; inversion H0.
subst t f0 l0; inversion H8; clear H8.
subst s t; apply H6; trivial.
subst s s0; elim (IH (Term f l, (t,u))); intuition; apply lex2; trivial.
subst u f0 l0; rename l'0 into l''; apply Top_gt; trivial;
intros; elim (IH (Term f l, (Term f l', s'))); intuition; apply lex3; trivial.
subst f0 l0 u; rename l'0 into l''; apply Top_eq_lex; trivial.
generalize l' l'' H5 H8 IH; clear l' l'' H3 H5 H6 Anti Anti0 H H4 H8 H9 IH H0;
induction l; intros l' l'' H4 H6 IH; inversion H4.
subst l' t l'0; inversion H6.
subst l'' t l0; apply List_gt; elim (IH (a,(s,s0))); intuition.
apply lex1; trivial; left; trivial.
rewrite H7; trivial.
apply lex1; trivial; left; trivial.
apply List_gt; trivial.
subst l'' s0 l'; rewrite (rpo_lex_same_length _ _ H1); trivial.
subst l' l'0 s; inversion H6.
apply List_gt; trivial; rewrite H5; apply rpo_lex_same_length; trivial.
subst l'' s l'; apply List_eq; apply IHl with l0; trivial;
intros; apply IH;
apply o_size3_trans with (Term f l, (Term f l0, Term f l1)); trivial;
apply lex1_bis.
intros; elim (IH (Term f l,(Term f l', s'))); intuition; apply lex3; trivial.

absurd (Lex = Mul); [ discriminate | rewrite <- H3; rewrite <- H7; trivial ].

subst t f0 l0; inversion H0.
subst t f0 l0; inversion H7; clear H7.
subst s t; apply (rpo_subterm _ _ H); trivial.
subst s0 t; elim (IH (Term f l, (s, u))); intuition;
[ apply H2; trivial; apply (rpo_subterm _ _ H) | apply lex2 ]; trivial.
apply Top_gt; trivial;
subst u l0 f0; intros s' In_s';
elim (IH (Term f l, (Term f l', s'))); intuition; apply lex3; trivial.
absurd (Lex = Mul); [ discriminate | rewrite <- H3; rewrite <- H4; trivial ].
subst u f0 l0; apply Top_eq_mul; trivial;
inversion H5; subst l'1 l0; inversion H7; subst l'1 l0; rename l'0 into l'';
rewrite app_comm_cons in H9;
elim (ac_syntactic _ _ _ _ (list_permut_trans (list_permut_sym H1) H9));
intros lcc H'; elim H'; clear H';
intros lcg H'; elim H'; clear H';
intros lsc H'; elim H'; clear H';
intros lsg H'; elim H'; clear H';
intros P1 H'; elim H'; clear H';
intros P2 H'; elim H'; clear H';
intros P3 P4; apply (List_mul a (lg ++ lcg) (ls0 ++ lsc) lcc).
rewrite <- ass_app; apply list_permut_trans with (ls0 ++ lc0); trivial;
apply context_list_permut_app1; trivial.
apply list_permut_trans with (lcc ++ lsc); trivial; apply list_permut_app_app.
apply list_permut_trans with (a :: lg ++ lc); trivial;
apply context_list_permut_cons; rewrite <- ass_app;
apply context_list_permut_app1;
apply list_permut_trans with (lcc ++ lcg); trivial; apply list_permut_app_app.
intros b In_b; elim (in_app_or _ _ _ In_b); clear In_b; intro In_b.
elim (H10 b In_b); intros a' H'; elim H'; clear H';
intros In_a' H'; elim (in_app_or _ _ _ (in_permut_in a' In_a' P4)); clear In_a';
intro In_a'.
exists a'; split; trivial; rewrite app_comm_cons; apply in_or_app; right; trivial.
assert (In a' ls).
refine (in_permut_in a' _ (list_permut_sym P2)); apply in_or_app; right; trivial.
elim (H3 a' H11); intros a'' H''; elim H''; intros; exists a'';
assert (In a'' (a :: lg ++ lcg)).
rewrite app_comm_cons; apply in_or_app; left; trivial.
split; trivial;
elim (IH (a'',(a',b))); intuition; apply lex1;
refine (in_permut_in a'' _ (list_permut_sym H2)); trivial;
rewrite app_comm_cons; apply in_or_app; left; trivial.
assert (In b ls).
refine (in_permut_in b _ (list_permut_sym P2));
apply in_or_app; left; trivial.
elim (H3 b H11); intros a'' H''; elim H''; intros; exists a''; split; trivial.
rewrite app_comm_cons; apply in_or_app; left; trivial.

inversion_clear H; trivial;
inversion_clear H0; trivial;
generalize (Anti H1 H); contradiction.

intros lt_s_t lt_t_s; inversion lt_t_s; clear lt_t_s.
subst t0 f0 l0; inversion H3; clear H3.
subst t t0; elim (IH (s, (Term f l, u))); intuition;
[ apply H1; trivial; apply (Subterm f l s s); trivial; apply Eq
| apply lex1 ]; trivial.
subst s0 t0; elim (IH (s,(t,(Term f l)))); intuition.
apply Anti0; apply (Subterm f l (Term f l) s); trivial; apply Lt; trivial.
apply lex1; trivial.
subst t f0 l0; inversion lt_s_t; clear lt_s_t.
subst t f0 l0; inversion H5; clear H5.
subst t s; apply Anti0; apply H3; trivial.
subst s s0; elim (IH (Term f l, (t,u))); intuition; apply lex2; trivial.
subst g0 l'0 f0 l0; apply prec_antisym with f; trivial;
apply prec_transitive with g; trivial.
subst f0 l'0 g l0; apply prec_antisym with f; trivial.
subst f0 l'0 g l0; apply prec_antisym with f; trivial.
subst t f0 l0; inversion lt_s_t; clear lt_s_t.
subst t f0 l0; inversion H6; clear H6.
subst s t; apply Anti0; trivial; apply H4; trivial.
subst s s0; elim (IH (Term f l, (t,u))); intuition; apply lex2; trivial.
apply prec_antisym with f; trivial.
generalize l' IH H3 H6; subst f0 l'0 l0; clear Anti0 H1 H3 H4 IH H5 H6 H7;
induction l; intros; inversion H3; clear H3.
subst t l'0 l'1; inversion H6; clear H6.
subst s0 l1 t l0; elim (IH (a,(s,u))); intuition; apply lex1; left; trivial.
subst s; elim (IH (a, (Term f (a::l0),u))); intuition; apply lex1; left; trivial.
subst s l'0 l'1; inversion H6; clear H6.
elim (IH (a, (Term f (a::l0),u))); intuition; apply lex1; left; trivial.
subst l'0 s l1; apply IHl with l0; trivial;
intros; apply IH;
apply o_size3_trans with (Term f l, (Term f l0, u)); trivial; apply lex1_bis.

absurd (Lex = Mul); [ discriminate | rewrite <- H1; rewrite <- H5; trivial ].

subst t f0 l0; inversion lt_s_t.
subst t f0 l0; inversion H3; subst l0 l'0.
elim (in_app_or _ _ _ (in_permut_in s H4 H)); intro In_s.
elim (H1 s In_s); intros a' H'; elim H'; clear H';
intros In_a' H'; apply Anti0; apply (Subterm f l (Term f l) a').
refine (in_permut_in a' _ (list_permut_sym H0));
 rewrite app_comm_cons; apply in_or_app; left; trivial.
inversion H5; subst s; apply Lt; trivial;
elim (IH (a',(t,(Term f l)))); intuition; apply lex1;
refine (in_permut_in a' _ (list_permut_sym H0));
rewrite app_comm_cons; apply in_or_app; left; trivial.
apply Anti0; apply (Subterm f l (Term f l) s); trivial;
refine (in_permut_in s _ (list_permut_sym H0));
 rewrite app_comm_cons; apply in_or_app; right; trivial.
apply prec_antisym with f; trivial.
absurd (Lex = Mul); [ discriminate | rewrite <- H2; rewrite <- H4; trivial ].

subst f0 l'0 l0; apply Anti0; apply Top_eq_mul; trivial;
inversion H3; subst l'0 l0; inversion H5; subst l'0 l0.
rewrite app_comm_cons in H7;
elim (ac_syntactic _ _ _ _ (list_permut_trans (list_permut_sym H) H7));
intros lcc H'; elim H'; clear H';
intros lcg H'; elim H'; clear H';
intros lsc H'; elim H'; clear H';
intros lsg H'; elim H'; clear H';
intros P1 H'; elim H'; clear H';
intros P2 H'; elim H'; clear H';
intros P3 P4; apply (List_mul a (lg ++ lcg) (ls0 ++ lsc) lcc).
rewrite <- ass_app; apply list_permut_trans with (ls0 ++ lc0); trivial;
apply context_list_permut_app1; trivial;
apply list_permut_trans with (lcc ++ lsc); trivial; apply list_permut_app_app.
apply list_permut_trans with (a :: lg ++ lc); trivial;
apply context_list_permut_cons; rewrite <- ass_app;
apply context_list_permut_app1;
apply list_permut_trans with (lcc ++ lcg); trivial; apply list_permut_app_app.
intros b In_b; elim (in_app_or _ _ _ In_b); clear In_b; intro In_b.
elim (H8 b In_b); intros a' H'; elim H'; clear H';
intros In_a' H'; elim (in_app_or _ _ _ (in_permut_in a' In_a' P4)); clear In_a';
intro In_a'.
exists a'; split; trivial; rewrite app_comm_cons; apply in_or_app; right; trivial.
assert (In a' ls).
refine (in_permut_in a' _ (list_permut_sym P2)); apply in_or_app; right; trivial.
elim (H1 a' H9); intros a'' H''; elim H''; intros; exists a'';
assert (In a'' (a :: lg ++ lcg)).
rewrite app_comm_cons; apply in_or_app; left; trivial.
split; trivial;
elim (IH (a'',(a',b))); intuition; apply lex1;
refine (in_permut_in a'' _ (list_permut_sym H0)); trivial;
rewrite app_comm_cons; apply in_or_app; left; trivial.
assert (In b ls).
refine (in_permut_in b _ (list_permut_sym P2));
apply in_or_app; left; trivial.
elim (H1 b H9); intros a'' H''; elim H''; intros; exists a''; split; trivial.
rewrite app_comm_cons; apply in_or_app; left; trivial.

intro lt_s_s; inversion lt_s_s; clear lt_s_s.
inversion H3; clear H3.
subst t0 f0 l0 t1 s;
absurd (size (Term f l) < size (Term f l)); auto with arith;
apply (size_direct_subterm (Term f l) (Term f l) H2).
subst t0 f0 l0 s0 t1.
elim (IH (s,(Term f l, s))); intuition.
apply H1; trivial; apply (Subterm f l s s); trivial; apply Eq; trivial.
apply lex1; trivial.
apply prec_antisym with f; trivial.
subst f0 l' l0; clear H4; induction l; inversion H3.
elim (IH (a,(t,u))); intuition; apply lex1; left; trivial.
subst s l0 l'; apply IHl; trivial; intros; apply IH;
apply o_size3_trans with (Term f l, (t, u)); trivial; apply lex1_bis.

subst f0 l0 l'; inversion H3.
subst l' l0; assert (list_permut ls (a :: lg)).
apply remove_context_list_permut_app2 with lc; rewrite <- app_comm_cons;
apply list_permut_trans with l; trivial;
apply list_permut_sym; trivial.
assert (forall b, In b ls -> (exists a', In a' ls /\ rpo b a')).
intros b In_b; elim (H1 b In_b); intros a' H'; exists a'; intuition;
refine (in_permut_in _ _ (list_permut_sym H4)); trivial.
assert (forall v, In v ls -> In v l).
intros; refine (in_permut_in _ _ (list_permut_sym H));
apply in_or_app; left; trivial.
assert (1 <= length ls).
rewrite (list_permut_length H4); simpl; auto with arith.
generalize H5 H6; clear a lg H4 H5 H6 H2 H3 H0 H1 H;
induction ls; intros.
absurd (1 <= 0); auto with arith.
destruct ls.
elim (H5 a (or_introl _ (refl_equal _))); intros a' H';
elim H'; clear H'; intros In_a' lt_a_a'; elim In_a'; clear In_a'; intro In_a'.
subst a'; elim (IH (a,(t,u))); intuition; apply lex1; apply H6; left; trivial.
contradiction.
apply IHls.
simpl; auto with arith.
intros b In_b; elim (H5 b).
intros a' H'; elim H'; clear H';
intros In_a' lt_b_a'; elim In_a'; clear In_a';
intro In_a'.
subst a'; elim (H5 a (or_introl _ (refl_equal _)));
intros a'' H''; elim H''; clear H'';
intros In_a'' lt_a_a''; elim In_a''; clear In_a'';
intros In_a''.
subst a''; elim (IH (a,(t,u))); intuition; apply lex1; apply H6; left; trivial.
exists a''; split; trivial.
elim (IH (a'',(a,b))); intuition; apply lex1; apply H6; right; trivial.
exists a'; split; trivial.
right; trivial.
intros; apply H6; right; trivial.
Qed.

Lemma rpo_trans : forall s t u, rpo t s -> rpo u t -> rpo u s.
Proof.
intros s t u lt_t_s lt_u_t; elim (rpo_closure s t u); intuition.
Qed.

Record SN_term : Set :=
  mk_sn
  {
    tt : term;
    sn : Acc rpo tt
    }.

(** ** Well-foundedness of rpo.
How to build a built a list of pairs (terms, proof of accessibility) from
a global of accessibility on the list. *)
Definition build_list_of_SN_terms :
 forall l (proof : forall t, In t l -> Acc rpo t), list SN_term.
Proof.
intro l; induction l.
intros _; exact nil.
intro Acc_subterm; assert (Acc rpo a).
apply Acc_subterm; left; trivial.
assert (forall t, In t l -> Acc rpo t).
intros; apply Acc_subterm; right; trivial.
exact ((mk_sn a H) :: (IHl H0)).
Defined.

(** Projection on the first element of the pairs after building the
pairs as above is the identity. *)
Lemma projection_list_of_SN_terms :
  forall l proof, map tt (build_list_of_SN_terms l proof) = l.
Proof.
intro l; induction l; simpl; trivial.
intros proof; apply (f_equal (fun l => a :: l)); apply IHl.
Qed.

Lemma in_sn_sn :
 forall l s, In s (map tt l) -> Acc rpo s.
Proof.
intro l; induction l.
contradiction.
intros s In_s; elim In_s; clear In_s; intro In_s.
subst s; destruct a; trivial.
apply IHl; trivial.
Qed.

(** Definition of rpo on accessible terms. *)
Definition rpo_rest := fun s t => rpo (tt s) (tt t).

(** Extension of [rpo_lex] to the accessible terms. *)
Inductive rpo_lex_rest : list SN_term -> list SN_term -> Prop :=
  | List_gt_rest :
       forall s t l l', rpo_rest s t -> length l = length l' ->
       rpo_lex_rest (s :: l) (t :: l')
  | List_eq_rest : forall s t l l', tt s = tt t -> rpo_lex_rest l l' ->
        rpo_lex_rest (s :: l) (t :: l').

(** A triviality: rpo on accessible terms is well-founded. *)
Lemma wf_on_rest : well_founded rpo_rest.
Proof.
unfold well_founded, rpo_rest; intro s;
apply (Acc_inverse_image SN_term term rpo tt).
destruct s; simpl; trivial.
Qed.

Lemma rpo_lex_rest_same_length :
  forall l l', rpo_lex_rest l l' -> length l = length l'.
Proof.
induction l; intros l' rpo_lex_l; inversion rpo_lex_l.
simpl; rewrite H3; trivial.
simpl; rewrite (IHl l'0); trivial.
Qed.

(** Proof of accessibility does not actually matter, provided at least
one exists. *)
Lemma acc_lex_drop_proof :
  forall s t l, tt s = tt t -> Acc rpo_lex_rest (s::l) -> Acc rpo_lex_rest (t::l).
Proof.
intros s t l s_eq_t Acc_s.
apply Acc_intro; intros l' lt_l'_l;
apply Acc_inv with (s :: l); trivial; inversion lt_l'_l.

subst l' t0 l'0; apply List_gt_rest; trivial;
unfold rpo_rest in *; rewrite s_eq_t; trivial.

subst l' t0 l'0; apply List_eq_rest; trivial;
rewrite s_eq_t; trivial.
Qed.

(** Lexicographic extension of rpo on accessible terms lists is well-founded. *)
Lemma wf_on_lex_rest : well_founded rpo_lex_rest.
Proof.
unfold well_founded; intro a; pattern a; apply list_rec2; clear a;
induction n;
intros l L; destruct l.
apply Acc_intro; intros l' lt_l'_l; inversion lt_l'_l.
simpl in L; absurd (S(length l) <= 0); auto with arith.
apply Acc_intro; intros l' lt_l'_l; inversion lt_l'_l.
simpl in L; generalize (le_S_n _ _ L); clear L; intro L.
generalize l L; clear l L; pattern s;
apply (well_founded_induction_type wf_on_rest);
clear s; intros s IH l L.
generalize (IHn l L); intro Acc_l; induction Acc_l; rename x into l.
apply Acc_intro; intros l' lt_l'_l; inversion lt_l'_l.
subst l' t l'0; apply IH; trivial; rewrite H5; trivial.
subst l' t l'0; apply acc_lex_drop_proof with s.
apply sym_eq; trivial.
apply H0; trivial; rewrite (rpo_lex_rest_same_length _ _ H5); trivial.
Qed.

(** Extension of [rpo_mul] to the accessible terms. *)
Inductive rpo_mul_rest : list SN_term -> list SN_term -> Prop :=
  | List_mul_rest :
       forall a lg ls lc l l',
       list_permut (map tt l') (map tt (ls ++ lc)) ->
       list_permut (map tt l) (map tt (a :: lg ++ lc)) ->
       (forall b, In b ls -> exists a', In a' (a :: lg) /\ rpo_rest b a') ->
       rpo_mul_rest l' l.

(** Definition of a finer grain for multiset extension. *)
Inductive rpo_mul_rest_step : list SN_term -> list SN_term -> Prop :=
  | List_mul_rest_step :
       forall a ls lc l l',
       list_permut (map tt l') (map tt (ls ++ lc)) ->
       list_permut (map tt l) (map tt (a :: lc)) ->
       (forall b, In b ls -> rpo_rest b a) ->
       rpo_mul_rest_step l' l.

(** The plain multiset extension is in the transitive closure of
the finer grain extension. *)
Lemma rpo_mul_trans_clos :
  inclusion _ rpo_mul_rest (clos_trans _ rpo_mul_rest_step).
Proof.
unfold inclusion; intros l' l H; inversion H; clear H; subst l0 l'0;
generalize l' l a ls lc H0 H1 H2; clear l' l a ls lc H0 H1 H2;
induction lg.
intros l' l a ls lc H0 H1 H2;
apply t_step; apply (List_mul_rest_step a ls lc); trivial;
intros b In_b; elim (H2 b In_b);
intros a' H'; elim H'; clear H';
intros In_a' lt_b; elim In_a'; clear In_a';
intro In_a'; [subst a'; trivial | contradiction ].
intros l' l a0 ls lc H0 H1 H2.
assert (exists ls1, exists ls2,
 list_permut (map tt ls) (map tt (ls1 ++ ls2)) /\
 (forall b, In b ls1 -> rpo_rest b a0) /\
 (forall b, In b ls2 -> exists a', In a' ( a:: lg) /\ rpo_rest b a')).
clear H0; induction ls.
exists (nil : list SN_term); exists (nil : list SN_term); intuition.
contradiction.
contradiction.
elim IHls.
intros ls1 H; elim H; clear H;
intros ls2 H; elim (H2 a1 (or_introl _ (refl_equal _)));
intros a' H'; elim H'; clear H';
intros In_a' H'; elim In_a'; clear In_a';
intro In_a'.
subst a'; exists (a1 :: ls1); exists ls2; intuition.
rewrite <- app_comm_cons; simpl; apply context_list_permut_cons; trivial.
elim H3; clear H3; intro H3.
subst b; trivial.
apply H; trivial.
exists ls1; exists (a1 :: ls2); intuition.
rewrite map_app; simpl; apply (list_permut_add_cons_inside);
rewrite <- map_app; trivial.
elim H3; clear H3; intro H3.
subst b; exists a'; intuition.
apply H4; trivial.
intros; apply H2; trivial; right; trivial.
elim H; clear H;
intros ls1 H; elim H; clear H;
intros ls2 H; apply t_trans with (a0 :: ls2 ++ lc).
apply t_step; apply (List_mul_rest_step a0 ls1 (ls2 ++ lc)).
apply list_permut_trans with (map tt (ls ++ lc)); trivial.
rewrite <- app_ass; do 2 rewrite map_app; apply context_list_permut_app2; intuition.
apply list_permut_refl.
intuition.
apply (IHlg (a0 :: ls2 ++ lc) l a ls2 (a0 :: lc)).
rewrite map_app; simpl; apply list_permut_add_cons_inside;
rewrite map_app; apply list_permut_refl.
apply list_permut_trans with (map tt (a0 :: (a :: lg) ++ lc)); trivial.
do 2 rewrite app_comm_cons; generalize (a :: lg); intro l0.
do 2 rewrite map_app; simpl; apply list_permut_add_cons_inside;
apply list_permut_refl.
intuition.
Qed.

(** Splitting in two disjoint cases. *)
Lemma two_cases_rpo :
 forall a m n,
 rpo_mul_rest_step n (a :: m) ->
 (exists n', list_permut (map tt n) (map tt (a :: n')) /\
             rpo_mul_rest_step n' m) \/
 (exists k, (forall b, In b k -> rpo_rest b a) /\
            list_permut (map tt n) (map tt (k ++ m))).
Proof.
intros a m n M; inversion_clear M;
destruct a; destruct a0; elim (eq_term_dec tt0 tt1).
intro; subst tt1; right; exists ls; intuition;
apply list_permut_trans with (map tt (ls ++ lc)); trivial;
do 2 rewrite map_app; apply context_list_permut_app1;
apply remove_context_list_permut_cons with tt0;
apply list_permut_sym; trivial.
intro a_diff_a0; left;
elim (In_dec eq_term_dec tt1 (map tt m)); intro In_a0.
generalize (split_list_app_cons eq_term_dec _ _ In_a0); clear In_a0;
destruct (split_list eq_term_dec (map tt m) tt1).
intro; assert (forall s, In s l -> Acc rpo s).
intros s In_s; apply in_sn_sn with m; rewrite H2; apply in_or_app; left; trivial.
assert (forall s, In s l0 -> Acc rpo s).
intros s In_s; apply in_sn_sn with m; rewrite H2; apply in_or_app; do 2 right; trivial.
exists ((build_list_of_SN_terms l H3) ++ ls ++ (build_list_of_SN_terms l0 H4));
intuition.
apply list_permut_trans with (map tt (ls ++ lc)) ; trivial;
apply remove_context_list_permut_cons with tt1;
apply list_permut_trans with ((map tt ls) ++ tt1 :: (map tt lc)).
apply list_permut_add_cons_inside; rewrite map_app; apply list_permut_refl.
apply list_permut_trans with (map tt ls ++ (tt0 :: l ++ tt1 :: l0)).
apply context_list_permut_app1; apply list_permut_sym; rewrite <- H2; trivial.
rewrite app_comm_cons; rewrite <- app_ass; apply list_permut_sym;
apply list_permut_add_cons_inside;
rewrite app_ass; rewrite <- app_comm_cons; simpl;
apply list_permut_add_cons_inside;
do 2 rewrite map_app; do 2 rewrite projection_list_of_SN_terms;
do 2 rewrite <- app_ass; apply context_list_permut_app2;
apply list_permut_app_app.
apply (List_mul_rest_step (mk_sn tt1 sn1) ls
(build_list_of_SN_terms l H3 ++ build_list_of_SN_terms l0 H4)); intuition.
do 2 rewrite ass_app; do 4 rewrite map_app;
apply context_list_permut_app2; apply list_permut_app_app.
rewrite H2; simpl; rewrite map_app; do 2 rewrite projection_list_of_SN_terms;
apply list_permut_sym; apply list_permut_add_cons_inside;
apply list_permut_refl.
absurd (In tt1 (map tt (mk_sn tt0 sn0 :: m))).
unfold not; intro H2; elim H2; clear H2; intro H2.
apply a_diff_a0; trivial.
apply In_a0; trivial.
refine (in_permut_in tt1 _ (list_permut_sym H0)); left; trivial.
Qed.

Lemma list_permut_map_acc :
 forall l l', list_permut (map tt l) (map tt l') ->
 Acc rpo_mul_rest_step l ->  Acc rpo_mul_rest_step l'.
Proof.
intros l l' P A1; apply Acc_intro;
intros l'' M2.
inversion A1; apply H; inversion M2.
subst l'0 l0; apply (List_mul_rest_step a ls lc); trivial.
apply list_permut_trans with (map tt l'); trivial.
Qed.

(** Multiset extension of rpo on accessible terms lists is well-founded. *)
Lemma wf_on_mul_rest : well_founded rpo_mul_rest.
Proof.
apply wf_incl with (clos_trans _ rpo_mul_rest_step).
apply rpo_mul_trans_clos.
apply wf_clos_trans.
unfold well_founded; intro a; induction a.
apply Acc_intro; intros m H; inversion_clear H.
generalize (list_permut_length H1); intro Abs; simpl in Abs;
absurd (0 = S (length (map tt (a :: lc)))); trivial; discriminate.
generalize a0 IHa; clear a0 IHa; pattern a;
refine (well_founded_ind wf_on_rest _ _ a); clear a.
intros;
apply (Acc_iter  (R:= rpo_rest)
(fun a => Acc rpo_rest a -> forall m, Acc rpo_mul_rest_step m ->
Acc rpo_mul_rest_step (a :: m))); trivial.
destruct x; rename tt0 into s; rename sn0 into Acc_s;
clear a0 IHa; intros b IH Acc_b m Acc_m.
apply (Acc_iter  (R:= rpo_mul_rest_step)
        (fun m => Acc rpo_mul_rest_step m -> Acc rpo_mul_rest_step (b :: m))); trivial.
clear m Acc_m; intros m IHm Acc_m; apply Acc_intro.
intros y lt_y; elim (two_cases_rpo _ _ _ lt_y); clear lt_y; intro lt_y.
elim lt_y; clear lt_y;
intros n' H'; elim H'; clear H';
intros P M; apply list_permut_map_acc with (b :: n').
apply list_permut_sym; trivial.
apply IHm; trivial; apply Acc_inv with m; trivial.
elim lt_y; clear lt_y;
intros k H'; elim H'; clear H';
intros M P; apply list_permut_map_acc with (k ++ m).
apply list_permut_sym; trivial.
clear P; induction k; trivial.
simpl; apply IH.
apply M; left; trivial.
apply Acc_inv with b; trivial; apply M; left; trivial.
apply IHk;
intros; apply M; right; trivial.
apply wf_on_rest.
apply wf_on_rest.
Qed.

(** Another definition of rpo, only on scheme of accessible terms. *)
Definition rpo_term : relation (symbol * list SN_term) :=
 fun f_l g_l' =>
  match f_l with
  | (f,l) =>
  match g_l' with
  | (g,l') =>
    if F.eq_symbol_dec f g
    then
      match status f with
      | Lex => rpo_lex_rest l l'
      | Mul => rpo_mul_rest l l'
      end
    else prec f g
  end
  end.

Lemma  wf_rpo_term : well_founded prec -> well_founded rpo_term.
Proof.
intro wf_prec; unfold well_founded in *; destruct a; rename s into f;
generalize l; clear l; pattern f; refine (well_founded_ind wf_prec _ _ f);
clear f; intros f IHf l; pattern l;
assert (forall g, f=g -> status g = status f).
intros; subst f; trivial.
destruct (status f); generalize (H f (refl_equal _)); clear H; intro H.
pattern l; refine (well_founded_ind wf_on_lex_rest _ _ l); clear l;
intros l IHl; apply Acc_intro; intros y; destruct y; simpl;
elim (F.eq_symbol_dec s f); intro eq1.
subst s; rewrite H; intros; apply IHl; trivial.
intros; apply IHf; trivial.
pattern l; refine (well_founded_ind wf_on_mul_rest _ _ l); clear l;
intros l IHl; apply Acc_intro; intros y; destruct y; simpl;
elim (F.eq_symbol_dec s f); intro eq1.
subst s; rewrite H; intros; apply IHl; trivial.
intros; apply IHf; trivial.
Qed.

Lemma acc_build :
  well_founded prec -> forall f l,
  Acc rpo (Term f (map (fun sn_tt => tt sn_tt) l)).
Proof.
intros wf_prec f l;
refine (well_founded_induction_type (wf_rpo_term wf_prec)
(fun f_l =>
  match f_l with
  | (f,l) => Acc rpo (Term f (map (fun sn_tt : SN_term => tt sn_tt) l))
  end) _ (f,l)).
clear f l; intros x IH; destruct x; rename s into f.
apply Acc_intro; intros t; pattern t; apply term_rec3; clear t.
intros v _; apply Acc_intro; intros u lt_u_t; inversion lt_u_t.
intros g l' IH' lt_t_s; inversion lt_t_s.

subst t f0 l0; assert (Acc rpo s).
apply (in_sn_sn _ _ H2).
inversion H3; subst s; trivial; apply Acc_inv with t; trivial.

subst g0 l'0 f0 l0; assert (forall s', In s' l' -> Acc rpo s').
intros s' In_s'; apply IH'; trivial; apply H4; trivial.
rewrite <- (projection_list_of_SN_terms l' H);
apply (IH (g,(build_list_of_SN_terms l' H)));
simpl; elim (F.eq_symbol_dec g f); intro eq1; trivial;
subst g; generalize (prec_antisym _ H2); contradiction.

subst f0 l'0 g l0; assert (forall s', In s' l' -> Acc rpo s').
intros s' In_s'; apply IH'; trivial; apply H5; trivial.

rewrite <- (projection_list_of_SN_terms l' H);
apply (IH (f,(build_list_of_SN_terms l' H)));
simpl; elim (F.eq_symbol_dec f f); intro eq1.
rewrite H3; generalize l' H H4; clear l' H H4 H5 IH IH' lt_t_s eq1;
induction l; intros l' H H4; inversion H4; clear H4.
subst l' t l'0; simpl; apply List_gt_rest.
unfold rpo_rest; trivial.
rewrite <- (projection_list_of_SN_terms l0
              (fun (t : term) (H0 : In t l0) => H t (or_intror (s = t) H0))) in H6.
About length_map.
replace (length  ((fix map (l : list SN_term) : list term :=
             match l with
             | nil => nil (A:=term)
             | a :: t => tt a :: map t
             end) l))
with (length (map tt l)) in H6.

do 2 rewrite length_map in H6; trivial.
trivial.

subst l' s l'0; simpl; apply List_eq_rest; trivial;
apply IHl; trivial.

absurd (f=f); trivial.

subst f0 l'0 g l0; assert (forall s', In s' l' -> Acc rpo s').
intros s' In_s'; apply IH'; trivial; apply (rpo_subterm _ _ lt_t_s); simpl; trivial.

rewrite <- (projection_list_of_SN_terms l' H);
apply (IH (f,(build_list_of_SN_terms l' H)));
simpl; elim (F.eq_symbol_dec f f); intro eq1.
rewrite H2; inversion H4; subst l'0 l0; assert (Acc rpo a).
apply in_sn_sn with l; refine (in_permut_in a _ (list_permut_sym H1));
left; trivial.
assert (forall t, In t lg -> Acc rpo t).
intros; apply in_sn_sn with l; refine (in_permut_in _ _ (list_permut_sym H1));
right; apply in_or_app; left; trivial.
assert (forall t, In t ls -> Acc rpo t).
intros; apply H; refine (in_permut_in _ _ (list_permut_sym H0));
apply in_or_app; left; trivial.
assert (forall t, In t lc -> Acc rpo t).
intros; apply H; refine (in_permut_in _ _ (list_permut_sym H0));
apply in_or_app; right; trivial.
apply (List_mul_rest (mk_sn a H5) (build_list_of_SN_terms lg H6)
(build_list_of_SN_terms ls H7) (build_list_of_SN_terms lc H8)).
rewrite map_app; do 3 rewrite projection_list_of_SN_terms; trivial.
simpl; rewrite map_app; do 2 rewrite projection_list_of_SN_terms; trivial.
intros b In_b; destruct b; elim (H3 tt0).
intros x H'; elim H'; clear H'; intros In_x H';
elim In_x; clear In_x; intro In_x.
subst x; exists (mk_sn a H5); intuition.
assert (exists a', In a' (build_list_of_SN_terms lg H6) /\ tt a' = x).
generalize lg H6 In_x; clear lg H1 H3 H6 In_x; induction lg.
contradiction.
intros H6 In_x; elim In_x; clear In_x; intro In_x; simpl.
subst a0; econstructor; intuition.
elim (IHlg (fun (t : term) (H1 : In t lg) => H6 t (or_intror (a0 = t) H1)) In_x);
intros a' H''; elim H''; clear H''; intros In_a' H''.
exists a'; split; trivial; right; trivial.
elim H9; clear H9;
intros a' H9; elim H9; clear H9;
intros In_a' H9; exists a'; split;
[ right | unfold rpo_rest; simpl; rewrite H9 ]; trivial.
clear H0 H3; induction ls.
contradiction.
elim In_b; clear In_b; intro In_b;
[ left; injection In_b; trivial | right; refine (IHls _ In_b)].

absurd (f=f); trivial.
Qed.

(** ** Main theorem: when the precedence is well-founded, so is the rpo. *)
Lemma wf_rpo : well_founded prec -> well_founded rpo.
Proof.
intro wf_prec;
unfold well_founded; intro t; pattern t; apply term_rec3; clear t.
intro v; apply Acc_intro; intros t lt_t_s; inversion lt_t_s.
intros f l Acc_subterm;
rewrite <- (projection_list_of_SN_terms l Acc_subterm).
apply acc_build; trivial.
Qed.

(** ** RPO is compatible with the instanciation by a substitution. *)
Lemma rpo_subst :
  forall t s, rpo s t ->
  forall sigma, rpo (apply_subst sigma s) (apply_subst sigma t).
Proof.
intro t; pattern t; apply term_rec3; clear t.
intros v s H; inversion H.
intros f l IHl s; simpl; pattern s; apply term_rec3; clear s.
(* case s = Var v; rpo by Subterm *)
intros v R; inversion R as [ f' l' s' t In_t_l R' H1 H2 | | | ]; subst;
intro sigma; simpl; apply Subterm with (apply_subst sigma t).
apply in_in_map; trivial.
inversion R' as [ s' R'' | s' t' R'' ]; subst; simpl;
[ apply Eq| apply Lt; refine (IHl _ In_t_l _ R'' sigma) ].
(* case s = Term f l *)
intros g k IHl' R sigma;
inversion R as [ f' l' s' t In_t_l R' H1 H2
                       | f' g' l' l'' R' R'' H1 H2
                       | g' l' k' f_lex Rlex R' H2 H3
                       | g' l' k' f_mul Rmul R' H2 ]; subst.
(* case Subterm *)
apply Subterm with (apply_subst sigma t).
apply in_in_map; trivial.
inversion R' as [ s' R'' | s' t' R'' ]; subst;
[ apply Eq | apply Lt; apply IHl; trivial ].
(* case Top_gt *)
simpl; apply Top_gt; trivial.
intros s' In_s'; elim (in_map_in _ s' _ In_s'); intros s [H1 H2]; subst.
apply IHl'; trivial; apply R''; trivial.
(* case Top_eq_lex *)
simpl; apply Top_eq_lex; trivial.
generalize l Rlex IHl; clear l R Rlex R' IHl IHl';
induction k as [ | s' k ]; intros l Rlex IHl; inversion Rlex; subst; simpl.
apply List_gt; [ apply IHl; trivial; left | do 2 (rewrite length_map) ]; trivial.
apply List_eq; apply IHk; trivial;
intros; apply IHl; trivial; right; trivial.
intros s' In_s'; elim (in_map_in _ s' _ In_s');
intros s [In_s H1]; subst; apply IHl'; trivial;
apply rpo_trans with (Term f k); trivial;
apply Subterm with s; trivial; apply Eq.
(* case Top_eq_mul *)
simpl; apply Top_eq_mul; trivial.
inversion Rmul as [ a lg ls lc l0 k0 Pk Pl H]; subst.
apply (List_mul (apply_subst sigma a) (map (apply_subst sigma) lg)
(map (apply_subst sigma) ls) (map (apply_subst sigma) lc)).
rewrite <- map_app; apply list_permut_map; trivial.
rewrite <- map_app;
generalize (list_permut_map (apply_subst sigma) Pl); simpl; trivial.
intros b' In_b'; elim (in_map_in _ b' _ In_b');
intros b [In_b H1]; subst; elim (H b In_b); intros a' [ In_a' H1 ];
exists (apply_subst sigma a'); split.
generalize (in_in_map (apply_subst sigma) _ _ In_a'); simpl; trivial.
apply IHl; trivial;
apply in_permut_in with (a :: lg ++ lc).
elim In_a'; clear In_a'; intro In_a'; subst.
left; trivial.
right; apply in_or_app; left; trivial.
apply list_permut_sym; trivial.
Qed.

(** ** RPO is compatible with adding context. *)
Lemma rpo_add_context :
 forall p ctx s t, rpo s t -> is_a_pos ctx p = true ->
  rpo (replace_at_pos ctx s p) (replace_at_pos ctx t p).
Proof.
intro p; induction p as [ | i p ]; intros ctx s t R H; trivial;
destruct ctx as [ v | f l ].
discriminate.
assert (Status : forall g, g = f -> status g = status f).
intros; subst; trivial.
do 2 (rewrite replace_at_pos_unfold);
destruct (status f); generalize (Status f (refl_equal _)); clear Status;
intro Status.
apply Top_eq_lex; trivial.
generalize l i H; clear l i H; induction l as [ | u1 l ]; intros i H.
destruct i; discriminate.
destruct i; simpl in H; simpl.
apply List_gt; trivial; apply IHp; trivial.
apply List_eq; apply IHl; trivial.
intros s' In_s';
assert (H' : exists t', In t' (replace_at_pos_list l t i p) /\ rpo_eq s' t').
generalize l i H In_s'; clear l i H In_s';
induction l as [ | u1 l ]; intros i H In_s'.
destruct i; discriminate.
destruct i; elim In_s'; clear In_s'; intro In_s'; subst.
exists (replace_at_pos u1 t p); split; [ left | apply Lt; apply IHp ]; trivial.
exists s'; split; [ right; trivial | apply Eq ].
exists s'; split; [ left; trivial | apply Eq ].
elim (IHl i H In_s'); intros t' [H1 H2]; exists t'; split; [ right | idtac ]; trivial.
elim H'; clear H'; intros t' [H1 H2]; apply Subterm with t'; trivial.

apply Top_eq_mul; trivial.
assert (H' : exists l1, exists ui, exists l2, l = l1 ++ ui :: l2 /\ length l1 = i).
generalize i H; clear i H; induction l as [ | u1 l ]; intros i H.
destruct i; discriminate.
destruct i as [ | i ].
exists (nil (A:= term)); exists u1; exists l; split; trivial.
elim (IHl i H); intros l1 [ ui [ l2 [ H1 H2]]].
exists (u1 :: l1); exists ui; exists l2; split; subst; trivial.
elim H'; clear H';  intros l1 [ ui [ l2 [ H1 H' ]]]; subst l.
do 2 (rewrite replace_at_pos_list_replace_at_pos_in_subterm; trivial).
apply (List_mul (replace_at_pos ui t p) nil (replace_at_pos ui s p :: nil)
          (l1 ++ l2)).
simpl; apply list_permut_sym;
apply list_permut_add_cons_inside; apply list_permut_refl.
simpl; apply list_permut_sym;
apply list_permut_add_cons_inside; apply list_permut_refl.
intros b In_b; elim In_b; clear In_b; intro In_b; subst.
exists (replace_at_pos ui t p); split; [ left | apply IHp ]; trivial.
induction l1 as [ | u1 l1 ]; trivial; apply IHl1; trivial.
contradiction.
Qed.

End Make.


Require Import Coq.ZArith.ZArith.
Require Import Coq.ZArith.Znumtheory.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import compcert.cfrontend.Ctypes.

Definition in_eq: forall {A: Type} (a:A) l, In a (a::l) :=
  fun A a l => or_introl eq_refl.

Definition Forall_forall: forall {A : Type} (P : A -> Prop) (l : list A),
       Forall P l <-> (forall x : A, In x l -> P x)   :=
fun (A : Type) (P : A -> Prop) (l : list A) =>
conj
  (fun H : Forall P l =>
   Forall_ind (fun l0 : list A => forall x : A, In x l0 -> P x)
     (fun (x : A) (H0 : In x nil) => False_ind (P x) H0)
     (fun (x : A) (l0 : list A) (H0 : P x) (_ : Forall P l0)
        (IHForall : forall x0 : A, In x0 l0 -> P x0) (x0 : A)
        (H2 : In x0 (x :: l0)) =>
      or_ind
        (fun H3 : x = x0 =>
         eq_ind_r (fun x1 : A => P x1 -> P x0) (fun H4 : P x0 => H4) H3 H0)
        (fun H3 : In x0 l0 =>
         (fun H4 : In x0 l0 -> P x0 => (fun H5 : P x0 => H5) (H4 H3))
           (IHForall x0)) H2) H)
  (list_ind
     (fun l0 : list A => (forall x : A, In x l0 -> P x) -> Forall P l0)
     (fun _ : forall x : A, In x nil -> P x => Forall_nil P)
     (fun (a : A) (l0 : list A)
        (IHl : (forall x : A, In x l0 -> P x) -> Forall P l0)
        (H : forall x : A, In x (a :: l0) -> P x) =>
      (fun H0 : forall x : A, In x l0 -> P x =>
       (fun H1 : forall x : A, In x l0 -> P x =>
        (fun H2 : Forall P l0 =>
         (fun H3 : A =>
          (fun X : A =>
           (fun H4 : In X (a :: l0) -> P X =>
            (fun (_ : a = X -> P X)
               (_ : (fix In (a0 : A) (l1 : list A) {struct l1} : Prop :=
                       match l1 with
                       | nil => False
                       | b :: m => b = a0 \/ In a0 m
                       end) X l0 -> P X) =>
             Forall_cons a (H a (in_eq a l0)) H2)
              (fun H5 : a = X => H4 (or_introl H5))
              (fun
                 H5 : (fix In (a0 : A) (l1 : list A) {struct l1} : Prop :=
                         match l1 with
                         | nil => False
                         | b :: m => b = a0 \/ In a0 m
                         end) X l0 => H4 (or_intror H5))) (H X)) H3) a)
          (IHl H1)) H0)
        (fun (x : A) (H0 : In x l0) =>
         (fun H1 : In x (a :: l0) -> P x =>
          (fun (_ : a = x -> P x)
             (H3 : (fix In (a0 : A) (l1 : list A) {struct l1} : Prop :=
                      match l1 with
                      | nil => False
                      | b :: m => b = a0 \/ In a0 m
                      end) x l0 -> P x) => (fun H4 : P x => H4) (H3 H0))
            (fun H2 : a = x => H1 (or_introl H2))
            (fun
               H2 : (fix In (a0 : A) (l1 : list A) {struct l1} : Prop :=
                       match l1 with
                       | nil => False
                       | b :: m => b = a0 \/ In a0 m
                       end) x l0 => H1 (or_intror H2))) (H x))) l).

Lemma Forall_forall1: forall {A : Type} (P : A -> Prop) (l : list A),
       Forall P l -> (forall x : A, In x l -> P x).
Proof.
intros until 1.
destruct (@Forall_forall A P l).
apply H0. auto.
Defined.

Lemma Zcompare_refl: forall n, Z.compare n n = Eq.
Proof.
intros.
destruct n; simpl.
apply eq_refl.
unfold Pos.compare.
induction p; simpl; auto.
unfold Pos.compare.
induction p; simpl; auto.
Defined.

Lemma Zle_refl: forall n, Z.le n n.
Proof.
intros.
unfold Z.le. rewrite Zcompare_refl. intro; discriminate.
Defined.

Lemma Zle_max_l: forall n m : Z, n <= Z.max n m.
Proof.
intros.
unfold Z.max.
unfold Z.le.
destruct (n?=m) eqn:H.
rewrite Zcompare_refl; intro; discriminate.
rewrite H. intro; discriminate.
rewrite Zcompare_refl; intro; discriminate.
Defined.

Definition Pos_compare_cont_antisym :
  forall (p q : positive) (c : comparison),
       eq (CompOpp (Pos.compare_cont c p q))
         (Pos.compare_cont (CompOpp c) q p ) :=
fun (p q : positive) (c : comparison) =>
positive_ind
  (fun p0 : positive =>
   forall (q0 : positive) (c0 : comparison),
   CompOpp (Pos.compare_cont c0 p0 q0) =
   Pos.compare_cont (CompOpp c0) q0 p0)
  (fun (p0 : positive)
     (IHp : forall (q0 : positive) (c0 : comparison),
            CompOpp (Pos.compare_cont c0 p0 q0) =
            Pos.compare_cont (CompOpp c0) q0 p0)
     (q0 : positive) =>
   match
     q0 as p1
     return
       (forall c0 : comparison,
        CompOpp (Pos.compare_cont c0 p0~1 p1) =
        Pos.compare_cont (CompOpp c0) p1 p0~1)
   with
   | (q1~1)%positive =>
       fun c0 : comparison => IHp q1 c0
   | (q1~0)%positive =>
       fun c0 : comparison => IHp q1 Gt
   | 1%positive => fun c0 : comparison => eq_refl
   end)
  (fun (p0 : positive)
     (IHp : forall (q0 : positive) (c0 : comparison),
            CompOpp (Pos.compare_cont c0 p0 q0) =
            Pos.compare_cont (CompOpp c0) q0 p0)
     (q0 : positive) =>
   match
     q0 as p1
     return
       (forall c0 : comparison,
        CompOpp (Pos.compare_cont c0 p0~0 p1) =
        Pos.compare_cont (CompOpp c0) p1 p0~0)
   with
   | (q1~1)%positive =>
       fun c0 : comparison => IHp q1 Lt
   | (q1~0)%positive =>
       fun c0 : comparison => IHp q1 c0
   | 1%positive => fun c0 : comparison => eq_refl
   end)
  (fun q0 : positive =>
   match
     q0 as p0
     return
       (forall c0 : comparison,
        CompOpp (Pos.compare_cont c0 1 p0) =
        Pos.compare_cont (CompOpp c0) p0 1)
   with
   | (q1~1)%positive =>
       fun c0 : comparison => eq_refl
   | (q1~0)%positive =>
       fun c0 : comparison => eq_refl
   | 1%positive => fun c0 : comparison => eq_refl
   end) p q c.

Definition Pos_compare_antisym:
  forall p q : positive,
       eq (Pos.compare q p) (CompOpp (Pos.compare p q)) :=
  fun p q : positive =>
eq_ind_r (fun c : comparison => eq (Pos.compare_cont Eq q p) c) eq_refl
  (Pos_compare_cont_antisym p q Eq).

Lemma Pos_compare_absurd:
  forall x y c, (eq (Pos.compare_cont c x y) Eq) -> c=Eq.
Proof.
induction x; destruct y; simpl; intros; eauto; try discriminate.
apply IHx in H; discriminate.
apply IHx in H; discriminate.
Defined.

Lemma Pos_compare_cont_eq:
  forall x y c, eq (Pos.compare_cont c x y) Eq -> eq x y.
Proof.
induction x; destruct y; simpl; intros; auto; try discriminate.
f_equal. eauto.
apply Pos_compare_absurd in H; inversion H.
apply Pos_compare_absurd in H; inversion H.
f_equal. eauto.
Defined.

Lemma Pos_compare_eq:
  forall x y, eq (Pos.compare x y) Eq -> eq x y.
Proof.
intros.
apply Pos_compare_cont_eq in H; auto.
Defined.

Lemma Zmax_comm: forall n m, Z.max n m = Z.max m n.
Proof.
destruct n, m; simpl; try apply eq_refl.
*
 unfold Z.max; simpl.
 rename p0 into q.
 rewrite Pos_compare_antisym.
 destruct (Pos.compare q p) eqn:?; simpl; try reflexivity.
 apply Pos_compare_eq in Heqc.
 apply f_equal. symmetry; auto.
*
 unfold Z.max; simpl.
 rename p0 into q.
 rewrite Pos_compare_antisym.
 destruct (Pos.compare q p) eqn:?; simpl; try reflexivity.
 apply Pos_compare_eq in Heqc.
 apply f_equal. symmetry; auto.
Defined.

Lemma Zle_max_r: forall n m : Z, m <= Z.max n m.
Proof.
intros.
rewrite Z.max_comm. apply Zle_max_l.
Defined.

Local Open Scope nat.

Definition le_pred: forall n m : nat, n <= m -> pred n <= pred m :=
fun (n m : nat) (H : n <= m) =>
le_ind n (fun m0 : nat => pred n <= pred m0) (le_n (pred n))
  (fun (m0 : nat) (H0 : n <= m0) (IHle : pred n <= pred m0) =>
   match
     m0 as n0 return (n <= n0 -> pred n <= pred n0 -> pred n <= pred (S n0))
   with
   | 0 => fun (_ : n <= 0) (IHle0 : pred n <= pred 0) => IHle0
   | S m1 =>
       fun (_ : n <= S m1) (IHle0 : pred n <= pred (S m1)) =>
       le_S (pred n) m1 IHle0
   end H0 IHle) m H.

Definition le_S_n : forall n m : nat, S n <= S m -> n <= m  :=
   fun n m => le_pred (S n) (S m).

Definition max_l: forall n m : nat, m <= n -> max n m = n :=
fun n : nat =>
nat_ind (fun n0 : nat => forall m : nat, m <= n0 -> max n0 m = n0)
  (fun m : nat =>
   match m as n0 return (n0 <= 0 -> max 0 n0 = 0) with
   | 0 => fun _ : 0 <= 0 => eq_refl
   | S m0 =>
       fun H : S m0 <= 0 =>
       (fun H0 : 0 = 0 -> S m0 = 0 => H0 eq_refl)
         match H in (_ <= n0) return (n0 = 0 -> S m0 = 0) with
         | le_n =>
             fun H0 : S m0 = 0 =>
             (fun H1 : S m0 = 0 =>
              (fun H2 : False =>
               (fun H3 : False => False_ind (S m0 = 0) H3) H2)
                (eq_ind (S m0)
                   (fun e : nat =>
                    match e with
                    | 0 => False
                    | S _ => True
                    end) I 0 H1)) H0
         | le_S m1 H0 =>
             fun H1 : S m1 = 0 =>
             (fun H2 : S m1 = 0 =>
              (fun H3 : False =>
               (fun H4 : False => False_ind (S m0 <= m1 -> S m0 = 0) H4) H3)
                (eq_ind (S m1)
                   (fun e : nat =>
                    match e with
                    | 0 => False
                    | S _ => True
                    end) I 0 H2)) H1 H0
         end
   end)
  (fun (n0 : nat) (IHn : forall m : nat, m <= n0 -> max n0 m = n0) (m : nat) =>
   match m as n1 return (n1 <= S n0 -> max (S n0) n1 = S n0) with
   | 0 => fun _ : 0 <= S n0 => eq_refl
   | S m0 =>
       fun H : S m0 <= S n0 => f_equal S (IHn m0 (le_S_n m0 n0 H))
   end) n.

Definition max_r     : forall n m : nat, n <= m -> max n m = m :=
fun n : nat =>
nat_ind (fun n0 : nat => forall m : nat, n0 <= m -> max n0 m = m)
  (fun m : nat =>
   match m as n0 return (0 <= n0 -> max 0 n0 = n0) with
   | 0 => fun _ : 0 <= 0 => eq_refl
   | S m0 => fun _ : 0 <= S m0 => eq_refl
   end)
  (fun (n0 : nat) (IHn : forall m : nat, n0 <= m -> max n0 m = m) (m : nat) =>
   match m as n1 return (S n0 <= n1 -> max (S n0) n1 = n1) with
   | 0 =>
       fun H : S n0 <= 0 =>
       (fun H0 : 0 = 0 -> S n0 = 0 => H0 eq_refl)
         match H in (_ <= n1) return (n1 = 0 -> S n0 = 0) with
         | le_n =>
             fun H0 : S n0 = 0 =>
             (fun H1 : S n0 = 0 =>
              (fun H2 : False =>
               (fun H3 : False => False_ind (S n0 = 0) H3) H2)
                (eq_ind (S n0)
                   (fun e : nat =>
                    match e with
                    | 0 => False
                    | S _ => True
                    end) I 0 H1)) H0
         | le_S m0 H0 =>
             fun H1 : S m0 = 0 =>
             (fun H2 : S m0 = 0 =>
              (fun H3 : False =>
               (fun H4 : False => False_ind (S n0 <= m0 -> S n0 = 0) H4) H3)
                (eq_ind (S m0)
                   (fun e : nat =>
                    match e with
                    | 0 => False
                    | S _ => True
                    end) I 0 H2)) H1 H0
         end
   | S m0 =>
       fun H : S n0 <= S m0 => f_equal S (IHn m0 (le_S_n n0 m0 H))
   end) n.

Definition le_n_S : forall n m : nat, n <= m -> S n <= S m :=
fun (n m : nat) (H : n <= m) =>
le_ind n (fun m0 : nat => S n <= S m0) (le_n (S n))
  (fun (m0 : nat) (_ : n <= m0) (IHle : S n <= S m0) =>
   le_S (S n) (S m0) IHle) m H.

Definition lt_n_S: forall n m : nat, n < m -> S n < S m :=
fun (n m : nat) (H : n < m) => le_n_S (S n) m H.

Definition le_trans: forall n m p : nat, n <= m -> m <= p -> n <= p :=
fun (n m p : nat) (H : n <= m) (H0 : m <= p) =>
le_ind m (fun p0 : nat => n <= p0) H
  (fun (m0 : nat) (_ : m <= m0) (IHle : n <= m0) => le_S n m0 IHle) p H0.

Definition le_Sn_le: forall n m : nat, S n <= m -> n <= m :=
fun (n m : nat) (H : S n <= m) => le_trans n (S n) m (le_S n n (le_n n)) H.

Definition lt_le_weak: forall n m : nat, n < m -> n <= m :=
fun (n m : nat) (H : n < m) => le_Sn_le n m H.

Lemma le_or_lt: forall n m : nat, n <= m \/ m < n.
Proof.
induction n; intros.
left. induction m; simpl; auto.
destruct m.
right. unfold lt. clear. induction n; simpl; auto.
destruct (IHn m); [left | right].
apply le_n_S. auto.
apply lt_n_S. auto.
Defined.

Lemma le_max_l: forall n m : nat, n <= max n m.
Proof.
intros.
destruct (le_or_lt n m).
rewrite max_r; auto.
rewrite max_l; auto.
apply lt_le_weak; auto.
Defined.

Lemma le_max_r: forall n m : nat, m <= max n m.
Proof.
intros.
destruct (le_or_lt n m).
rewrite max_r; auto.
rewrite max_l; auto.
apply lt_le_weak; auto.
apply lt_le_weak; auto.
Defined.

Lemma rank_type_members:
  forall ce id t m, In (id, t) m -> (rank_type ce t <= rank_members ce m)%nat.
Proof.
  induction m; simpl; intros; intuition auto.
  subst a.
  apply le_max_l.
  eapply le_trans; [eassumption | ].
  apply le_max_r.
Defined.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops.
Require Import Basic_Cons.Terminal.
Require Import Cat.Cat Cat.Cat_Iso.

(** In this section we show that if a category C has a terminal object and D is
a category isomorphic to C, then D also has a terminal object. *)
Section Term_IsoCat.
  Context {C D : Category}
          (I : (C ≃≃ D ::> Cat)%isomorphism) (trm : (𝟙_ C)%object).

  Program Definition Term_IsoCat : (𝟙_ D)%object
    :=
      {|
        terminal := ((iso_morphism I) _o)%object trm;
        t_morph :=
          fun c =>
            match
              f_equal (fun w : (D –≻ D)%functor => (w _o)%object c)
                      (right_inverse I)
              in _ = u return
              (u –≻ _)%morphism
            with
              eq_refl => ((iso_morphism I) _a ((t_morph
                                                 trm ((I⁻¹)%morphism _o c)))
                        )%morphism
            end;
        t_morph_unique :=
          fun c f g => _
      |}
  .

  Next Obligation.
  Proof.
    assert (H := f_equal
                   (fun w : (C –≻ C)%functor => (w _o)%object (terminal trm))
                   (left_inverse I)).
    cbn in H.
    cut (
        match H in _ = u return
              (_ –≻ u)%morphism
        with
        | eq_refl => ((I ⁻¹) _a f)%morphism
        end
        =
        match H in _ = u return
              (_ –≻ u)%morphism
        with
        | eq_refl => ((I ⁻¹) _a g)%morphism
        end
    ).
    {
      intros H2.
      destruct H.
      match type of H2 with
        ?A = ?B =>
        assert (((iso_morphism I) _a A) = ((iso_morphism I) _a B))%morphism
          by (rewrite H2; trivial)
      end.
      rewrite <- (Cat_Iso_conv_inv_I_inv_I (Inverse_Isomorphism I) f).
      rewrite <- (Cat_Iso_conv_inv_I_inv_I (Inverse_Isomorphism I) g).
      apply f_equal.
      trivial.
    }
    {
      apply t_morph_unique.
    }
  Qed.

End Term_IsoCat.


Require Export BPlusTree.
Require Export InductiveDataTypes.
Require Export ValidBPlusTree.
Require Export HelperProofs.
Require Export SortingProofs.

Lemma valid_splits_elim_tail: forall (X: Type) (b k: nat) (kpl': list (nat * bplustree b X)) (subtree: bplustree b X),
  valid_splits b X (kpl' ++ [(k, subtree)]) ->
  all (above k) (keys subtree).
Proof.
  intros.
  induction kpl'.
  Case "kpl' = []".
    simpl in H. inversion H.
    apply H1.
  Case "kpl' = a::kpl'".
    destruct a.
    simpl in H.
    destruct kpl'.
    SCase "kpl' = [a]".
      simpl in H. inversion H. inversion H6.
      apply H8.
    SCase "kpl' = a::p::kpl'".
      destruct p. simpl in H.
      inversion H.
      apply IHkpl'.
      apply H6.
Qed.

Lemma valid_splits_elim_middle: forall (X: Type) (b k1 k2: nat) (kpl' kpl'': list (nat * bplustree b X)) (t1 t2: bplustree b X),
  valid_splits b X (kpl' ++ (k1, t1)::(k2, t2)::kpl'') ->
  all (between k1 k2) (keys t1).
Proof.
  intros.
  induction kpl'.
  Case "kpl' = []".
    simpl in H. inversion H.
    apply H2.
  Case "kpl' = a::kpl'".
    destruct a.
    simpl in H.
    destruct kpl'.
    SCase "kpl' = [a]".
      simpl in H. inversion H. inversion H6.
      apply H9.
    SCase "kpl' = a::p::kpl'".
      destruct p. simpl in H.
      inversion H.
      apply IHkpl'.
      apply H6.
Qed.

Lemma valid_splits_elim_last: forall (X: Type) (b k: nat) (kpl: list (nat * bplustree b X)) (t: bplustree b X),
  valid_splits b X (kpl ++ [(k, t)]) ->
  all (above k) (keys t).
Proof.
  intros.
  induction kpl.
  Case "kpl = []".
    simpl in H. inversion H. assumption.
  Case "kpl = a::kpl".
    destruct a. simpl in *.
    destruct kpl.
    SCase "kpl = [a]".
      simpl in *.
      inversion H. inversion H6.
      assumption.
    SCase "kpl = a::p::kpl".
      destruct p.
      inversion H.
      apply IHkpl. assumption.
Qed.

Lemma insert_into_list_preserves_all__keys': forall (X: Type) (P: nat -> Prop) (k: nat) (v: X) (l: list (nat * X)),
  all P (keys' l) ->
  P k ->

  all P (keys' (insert_into_list k v l)).
Proof.
  intros.
  induction l.
  Case "l = []".
    simpl. repeat constructor. apply H0.
  Case "l = a::l".
    destruct a.
    destruct l.
    SCase "l = [a]".
      simpl.
      remember (ble_nat k n) as klen.
      destruct klen; symmetry in Heqklen; [ apply ble_nat_true in Heqklen | apply ble_nat_false in Heqklen ].
      SSCase "k <= n".
        remember (beq_nat k n) as keqn.
        destruct keqn; symmetry in Heqkeqn; [ apply beq_nat_true_iff in Heqkeqn | apply beq_nat_false_iff in Heqkeqn ].
        SSSCase "k = n".
          repeat constructor. apply H0.
        SSSCase "k < n".
          constructor. simpl in H. apply H. apply H0.
      SSCase "k > n".
        inversion H. repeat constructor; assumption.
    SCase "l = a::p::l".
      destruct p.
      simpl.
      remember (ble_nat k n) as klen.
      destruct klen; symmetry in Heqklen; [ apply ble_nat_true in Heqklen | apply ble_nat_false in Heqklen ].
      SSCase "k <= n".
        remember (beq_nat k n) as keqn.
        destruct keqn; symmetry in Heqkeqn; [ apply beq_nat_true_iff in Heqkeqn | apply beq_nat_false_iff in Heqkeqn ].
        SSSCase "k = n".
          simpl. simpl in H.
          constructor. inversion H. apply H3. apply H0.
        SSSCase "k < n".
          simpl. simpl in H.
          constructor. apply H. apply H0.
      SSCase "k > n".
        simpl in IHl.
        remember (ble_nat k n0) as klen0.
        destruct klen0; symmetry in Heqklen0; [ apply ble_nat_true in Heqklen0 | apply ble_nat_false in Heqklen0 ].
        SSSCase "k <= n0".
          remember (beq_nat k n0) as keqn0.
          destruct keqn0; symmetry in Heqkeqn0; [ apply beq_nat_true_iff in Heqkeqn0 | apply beq_nat_false_iff in Heqkeqn0 ].
          SSSSCase "k = n0".
            simpl. simpl in H.
            inversion H.
            constructor; try assumption.
            constructor; try assumption.
            inversion H3. assumption.
          SSSSCase "k < n0".
            simpl. simpl in H.
            inversion H.
            constructor; try assumption.
            constructor; try assumption.
        SSSCase "k > n0".
          simpl. simpl in IHl.
          constructor. apply IHl.
          simpl in H. inversion H. assumption.
          simpl in H. inversion H. assumption.
Qed.

Lemma all__keys'_sorted_app_holds: forall (X: Type) (low high k1 k2 k3: nat) (v1 v2 v3: X) (l1 l2: list (nat * X)),
  all (between low high) (keys' (l1 ++ (k1, v1)::(k3, v3)::l2)) ->
  kvl_sorted (l1++(k1,v1)::(k2, v2)::(k3, v3)::l2) ->

  all (between low high) (keys' (l1 ++ (k1,v1)::(k2,v2)::(k3,v3)::l2)).
Proof.
  intros.
  induction l1.
  Case "l1 = []".
    simpl in *.
    inversion H0. apply blt_nat_true in H7.
    inversion H3. apply blt_nat_true in H14.
    inversion H. inversion H17.
    constructor. constructor.
    apply H17.
    apply between__le_and_lt in H18.
    apply between__le_and_lt in H22.
    apply between__le_and_lt. omega.
    assumption.
  Case "l1 = a::l1".
    destruct a. simpl.
    simpl in H.
    inversion H.
    simpl in H0. apply list_tail_is_sorted in H0.
    constructor. apply IHl1; assumption.
    assumption.
Qed.

Lemma all__keys'_ignores_values: forall (X: Type) (k: nat) (P: nat -> Prop) (v1 v2: X) (l1 l2: list (nat * X)),
  all P (keys' (l1 ++ (k, v1)::l2)) ->
  all P (keys' (l1 ++ (k, v2)::l2)).
Proof.
  intros.
  induction l1.
  Case "l1 = []".
    simpl in *. apply H.
  Case "l1 = a::l1".
    destruct a.
    simpl in *.
    inversion H.
    constructor.
    apply IHl1. assumption.
    assumption.
Qed.

Lemma all__between_impl_all__above: forall (X: Type) (b low high: nat) (t: bplustree b X),
  all (between low high) (keys t) ->
  all (above low) (keys t).
Proof.
  intros.
  induction H.
  apply a_empty.
  constructor. apply IHall.
  apply between__le_and_lt in H0.
  apply above__le.
  omega.
Qed.

Lemma all__above_snoc: forall (X: Type) (low k1 k2: nat) (v1 v2: X) (kpl: list (nat * X)),
  all (above low) (keys' (kpl ++ [(k1, v1)])) ->
  k1 < k2 ->

  all (above low) (keys' (kpl ++ [(k1, v1), (k2, v2)])).
Proof.
  intros.
  induction kpl.
  Case "kpl = []".
    simpl. simpl in H. constructor. inversion H.
    apply above__le in H4. constructor. apply a_empty.
    apply above__le. omega. inversion H. apply H4.
  Case "kpl = a::kpl".
    destruct a.
    simpl. simpl in H.
    constructor.
    apply IHkpl. inversion H. apply H3.
    inversion H. assumption.
Qed.


Require Import List.

Definition partialMapping {A B: Type} := ((@list ((A*B)%type)) * (A -> A -> bool))%type.

Definition lookup {A B: Type} (map: (@partialMapping A B)) (key : A): option B :=
    let (list, equiv) := map in
    let fix look list :=
        match list with
        | (k,v)::rest => if (equiv key k)
            then Some v
            else look rest
        | nil => None
        end
    in
    look list.

Definition update {A B: Type} (map: (@partialMapping A B)) (key: A) (value: B) :=
    let (list, equiv) := map in
    ((key,value)::list,equiv)
.