(* This module defines acylic graphs over functors represented by
containers using Bernardy & Pouillard's 'Names For Free' approach. *)

Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Basics.
Require Export Container.
Require Export Algebra.

Infix "∘" := compose (at level 40, left associativity).

Inductive Vars A V : Type :=
| Old : A -> Vars A V
| New : V -> Vars A V.

Implicit Arguments Old [[A][V]].
Implicit Arguments New [[A][V]].

Infix ":>" := (@Vars) (at level 60, right associativity).

Definition Succ (a : Type) : Type := a :> unit.

Inductive Zero : Type := .

Definition zero (A : Type) (z : Zero) : A :=
  match z with
  end.

Lemma zero_unique {A} (f : Zero -> A) : f = zero A.
Proof.
  apply functional_extensionality. destruct x.
Qed.

Definition Scope (m : Type -> Type)  (A : Type) : Type := m (Succ A).

Section Graph.

Set Implicit Arguments.

Variable C : Cont.

Inductive GraphM : Type -> Type :=
| In : forall A, Ext C (GraphM A) -> GraphM A
| Var : forall A, A -> GraphM A
| Let : forall A, GraphM A -> Scope GraphM A -> GraphM A.

Definition Graph : Type := GraphM Zero.

Implicit Arguments Var [[A]].
Implicit Arguments Let [[A]].
Implicit Arguments In [[A]].

Fixpoint Graph_ind' (P : forall a, GraphM a -> Prop)
         (step : forall a (args : Ext C (GraphM a)),
                   cforall (P a) args -> P a (In args))
         (var : forall a v, P a (Var v))
         (let_ : forall a (g : GraphM a) s, P a g -> P (Succ a) s -> P a (Let g s))
         n t : P n t :=
  match t with
    | In n args => step n args (fun p => Graph_ind' P step var let_ (elems args p))
    | Var n m => var n m
    | Let n g s => let_ n g s (Graph_ind' P step var let_ g)
                        (Graph_ind' P step var let_ s)
  end.

Inductive Env A : Type -> Type :=
  | Empty : forall I, (I -> A) -> Env A I
  | Extend : forall I, A -> Env A I -> Env A (Succ I).

Fixpoint emap {I A B} (f : A -> B) (e : Env A I) : Env B I :=
  match e with
    | Empty _ f' => Empty (fun x => f (f' x))
    | Extend _ b r  => Extend (f b) (emap f r)
  end.

Fixpoint lookupEnv {A I} (e : Env A I) : I -> A :=
  match e with
      | Empty _ f => f
      | Extend _ b r => fun v => match v with
                     | Old v' => lookupEnv r v'
                     | New tt => b
                   end
  end.

Lemma emap_lookup {I A B} {e : Env A I} {i : I} {f : A -> B} : lookupEnv (emap f e) i = f (lookupEnv e i).
Proof.
  induction e.
  reflexivity.
  simpl. destruct i. auto. destruct u. reflexivity.
Qed.

Fixpoint gfoldM {A R V} (var : V -> R) (le : R -> (V -> R) -> R) (alg : Alg C R) (g : GraphM A) : Env R A -> R :=
  match g with
      | Var _ x => fun e => lookupEnv e x
      | In _ args => fun e => alg (cmap (fun g => gfoldM var le alg g e) args)
      | Let _ b s => fun e => le (gfoldM var le alg b e)
                                   (fun r => gfoldM var le alg s (Extend (var r) e))
  end.

Definition gfold {R V} (var : V -> R) (le : R -> (V -> R) -> R) (alg : Alg C R) (g :Graph) : R
  := gfoldM var le alg g (Empty (zero _)).

Definition ufoldM {R A} (env : Env R A) (alg : Alg C R) (g : GraphM A) : R
  :=  gfoldM (fun x => x) (fun b s => s b) alg g env.

Definition ufold {R} : Alg C R -> Graph -> R
  :=  ufoldM (Empty (zero _)).

Theorem gfoldM_fusion
        {R1 R2 R' A}
        (var1 : R' -> R1) (le1 : R1 -> (R' -> R1) -> R1) (alg1 : Alg C R1)
        (var2 : R' -> R2) (le2 : R2 -> (R' -> R2) -> R2) (alg2 : Alg C R2)
        (env1 : Env R1 A) (env2 : Env R2 A)
        (g : GraphM A) (f : R1 -> R2) (f' : R2 -> R1) :
  (forall x, f (alg1 x) = alg2 (cmap f x)) ->
  (forall b s, f (le1 b s) = le2 (f b) (f ∘ s)) ->
  (forall x, f (var1 x) = var2 x) ->
  (forall x, f (lookupEnv env1 x) = lookupEnv env2 x) ->

  f (gfoldM var1 le1 alg1 g env1) = gfoldM var2 le2 alg2 g env2.
Proof.
  intros Hom Le Var En. induction g using Graph_ind'; simpl.

   rewrite Hom. rewrite cmap_cmap. f_equal. apply
  cforall_rewrite. unfold compose.  unfold cforall in *. auto.

   auto.

   rewrite Le. unfold compose. f_equal.
   apply IHg1. apply En.
   apply functional_extensionality. intros. apply IHg2. induction x0.
   simpl. auto. simpl. destruct v. auto.
Qed.

End Graph.

Implicit Arguments Var [[C][A]].
Implicit Arguments Let [[C][A]].
Implicit Arguments In [[C][A]].

Definition letx {A C} (b : GraphM C A) (s : forall V , V -> GraphM C (A :> V)) : GraphM C A
:= Let b (s _ tt).

Class Elem (V A : Type) := {
  inj : V -> A
}.

Infix "∈" := (@Elem) (at level 60, right associativity).

Instance Elem_New {V A} : V ∈ (A :> V) := {
  inj := New
}.

Instance Elem_Old {V V' A} `{V ∈ A} : V ∈ (A :> V') := {
  inj := Old ∘ inj
}.

Definition var {C V A} `{V ∈ A} : V -> GraphM C A := Var ∘ inj.


From Coq Require Import List.

Section Array.
  Context (A:Type).
  Notation list := (list A).
  Implicit Types (l:list) (n:nat) (x:A).

  Fixpoint assign l n x' : list :=
    match l with
    | nil => nil
    | x::xs => match n with
              | 0 => x'::xs
              | S n => x::assign xs n x'
              end
    end.

  Fixpoint index l n : option A :=
    match l with
    | nil => None
    | x::xs => match n with
              | 0 => Some x
              | S n => index xs n
              end
    end.
End Array.

Module ArrayNotations.
  Declare Scope array_scope.
  Delimit Scope array_scope with array.
  Notation "l [ i  :=  v ]" := (assign l i v) (at level 10, left associativity) : array_scope.
  Notation "l [ i ]" := (index l i) (at level 11, no associativity) : array_scope.
End ArrayNotations.

(* to use ArrayNotations: *)
Import ArrayNotations.
Local Open Scope array_scope. (* optional *)


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_3.

Coq < Goal forall r b d:Prop, ((r -> ~b) /\ (d \/ r) /\ b) -> d.
1 subgoal

  ============================
   forall r b d : Prop, (r -> ~ b) /\ (d \/ r) /\ b -> d

Unnamed_thm < intros.
1 subgoal

  r : Prop
  b : Prop
  d : Prop
  H : (r -> ~ b) /\ (d \/ r) /\ b
  ============================
   d

Unnamed_thm < elim H.
1 subgoal

  r : Prop
  b : Prop
  d : Prop
  H : (r -> ~ b) /\ (d \/ r) /\ b
  ============================
   (r -> ~ b) -> (d \/ r) /\ b -> d

Unnamed_thm < intro.
1 subgoal

  r : Prop
  b : Prop
  d : Prop
  H : (r -> ~ b) /\ (d \/ r) /\ b
  H0 : r -> ~ b
  ============================
   (d \/ r) /\ b -> d

Unnamed_thm < intro.
1 subgoal

  r : Prop
  b : Prop
  d : Prop
  H : (r -> ~ b) /\ (d \/ r) /\ b
  H0 : r -> ~ b
  H1 : (d \/ r) /\ b
  ============================
   d

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <

*)

Section Exercise_3.
Goal forall r b d:Prop, ((r -> ~b) /\ (d \/ r) /\ b) -> d.
intros.
elim H.
intro.
intro.
firstorder.
Qed.


From Sail Require Import TypeCasts.
From Sail Require MachineWordInterface.
From bbv Require Word.
Require Arith.
Require Import ZArith NArith.
Require Lia.
Require String.
Require Strings.Ascii.

Module MachineWord <: MachineWordInterface.MachineWordInterface.

Import List.ListNotations.

Definition dummy {T:Type} (t:T) : T.
exact t.
Qed.

Definition word := Word.word.
Definition zeros n : word n := @Word.wzero n.
Definition ones n : word n := @Word.wones n.
Fixpoint get_bit [n] (w : word n) : nat -> bool :=
  match w with
  | Word.WO => fun i => dummy false
  | Word.WS b w' => fun i =>
             match i with
             | O => b
             | S i' => get_bit w' i'
             end
  end.

Lemma get_bit_eq [n] (w v : word n) :
  (forall i, i < n -> get_bit w i = get_bit v i) -> w = v.
intro H.
induction w.
* rewrite (Word.word0 v).
  reflexivity.
* unfold word in v.
  rewrite (Word.shatter_word v) in *.
  f_equal.
  + apply (H 0).
    Lia.lia.
  + apply IHw.
    intros i LT.
    specialize (H (S i) ltac:(Lia.lia)).
    apply H.
Qed.

(* An alternative definition in the style of set_bit below. *)
Definition get_bit_by_shift [n] : word n -> nat -> bool :=
  match n with
  | O => fun (w : Word.word O) i => dummy false
  | S n => fun (w : Word.word (S n)) i => Word.wlsb (Word.wrshift' w i)
  end.

Lemma combine_bit_low : forall m n (w : word m) (v : word n) i,
  i < m -> get_bit (Word.combine w v) i = get_bit w i.
induction w.
* intros.
  Lia.lia.
* intros v [|i] LT.
  + reflexivity.
  + apply IHw.
    Lia.lia.
Qed.

Lemma combine_bit_high : forall m n (w : word m) (v : word n) i,
  get_bit (Word.combine w v) (i + m) = get_bit v i.
induction w.
* intros.
  simpl.
  rewrite Nat.add_0_r.
  reflexivity.
* intros.
  rewrite Nat.add_succ_r.
  apply IHw.
Qed.

Lemma split2_bit : forall m n w i,
get_bit (Word.split2 m n w) i = get_bit w (i + m).
induction m.
* intros.
  rewrite Nat.add_0_r.
  reflexivity.
* simpl. intros.
  rewrite (Word.shatter_word w) at 2.
  rewrite Nat.add_succ_r.
  apply IHm.
Qed.

Lemma nat_cast_bit : forall m n (w : word m) (H : m = n) i,
  get_bit (DepEqNat.nat_cast Word.word H w) i = get_bit w i.
intros.
subst.
rewrite DepEqNat.nat_cast_same.
reflexivity.
Qed.

Lemma wrshift_bit : forall n (w : word n) i j,
  i + j < n ->
  get_bit (Word.wrshift' w i) j = get_bit w (i + j).
intros.
unfold Word.wrshift'.
rewrite split2_bit.
rewrite nat_cast_bit.
rewrite (Nat.add_comm j i).
apply combine_bit_low.
assumption.
Qed.

Lemma wlsb_bit : forall n (w : word (S n)),
  Word.wlsb w = get_bit w 0.
intros.
rewrite (Word.shatter_word w).
reflexivity.
Qed.

Lemma get_bit_equiv : forall n (w : word n) i, i < n -> get_bit w i = get_bit_by_shift w i.
destruct w.
* intros.
  reflexivity.
* intros.
  simpl (get_bit_by_shift _ _).
  rewrite wlsb_bit.
  rewrite wrshift_bit; auto.
  Lia.lia.
Qed.

Definition set_bit [n] : word n -> nat -> bool -> word n :=
match n with
| O => fun (w : Word.word O) i b => w
| S n => fun (w : Word.word (S n)) i (b : bool) =>
  let bit : Word.word (S n) := Word.wlshift' (Word.natToWord _ 1) i in
  let mask : Word.word (S n) := Word.wnot bit in
  let masked := Word.wand mask w in
  if b then Word.wor masked bit else masked
end.

Definition word_to_Z [n] (w : word n) : Z := Word.wordToZ w.
Definition word_to_N [n] (w : word n) : N := Word.wordToN w.
Definition Z_to_word n z : word n := Word.ZToWord n z.
Definition N_to_word m n : word m := Word.NToWord m n.

Lemma word_to_N_range : forall [n] (w : word n), (word_to_N w < 2 ^ N.of_nat n)%N.
intros.
change 2%N with (N.of_nat 2).
rewrite <- Nat2N.inj_pow.
rewrite <- NatLib.pow2_N.
apply Word.wordToN_bound.
Qed.

Lemma word_to_Z_range : forall [n] (w : word (S n)), (- 2 ^ Z.of_nat n <= word_to_Z w < 2 ^ Z.of_nat n)%Z.
intros.
change 2%Z with (Z.of_nat 2).
rewrite <- Nat2Z.inj_pow.
apply Word.wordToZ_size'.
Qed.

Local Fixpoint word_to_bools_aux {n} (w:word n) acc :=
match w with
| Word.WO => acc
| Word.WS b w => word_to_bools_aux w (b::acc)%list
end.

Definition word_to_bools [n] (w : word n) : list bool := word_to_bools_aux w [].

Local Lemma word_to_bools_aux_nth : forall n (w : word n) l i,
  List.nth_error (word_to_bools_aux w l) (n + i) = List.nth_error l i.
induction w.
* reflexivity.
* intros.
  simpl (word_to_bools_aux _ _).
  rewrite Nat.add_succ_comm.
  rewrite IHw.
  reflexivity.
Qed.

Lemma word_to_bools_length : forall [n] (w : word n), List.length (word_to_bools w) = n.
intros.
unfold word_to_bools.
rewrite plus_n_O.
change 0 with (List.length ([] : list bool)).
generalize (@nil bool).
induction n.
* dependent inversion w.
  reflexivity.
* intro.
  dependent inversion w; subst.
  simpl.
  rewrite IHn.
  simpl.
  apply Nat.add_succ_r.
Qed.

Lemma word_to_bools_get_bit : forall [n] (w : word n) (i : nat) x,
  List.nth_error (word_to_bools w) i = Some x <-> get_bit w (n - i - 1) = x /\ i < n.
intros.
split.
- intro H.
  specialize (List.nth_error_Some (word_to_bools w) i) as [LEN _].
  rewrite H in LEN.
  specialize (LEN ltac:(congruence)).
  rewrite word_to_bools_length in LEN.
  split; [|assumption].

  unfold word_to_bools in H.
  revert H.
  generalize (@nil bool).
  induction w.
  * Lia.lia.
  * destruct (Nat.eq_dec i n).
    + subst.
      intros.
      assert (x = b). {
        clear -H.
        revert H.
        simpl.
        rewrite (plus_n_O n) at 2.
        rewrite word_to_bools_aux_nth.
        simpl. congruence.
      }
      subst.
      replace (S n - n - 1) with 0 by Lia.lia.
      reflexivity.
    + replace (S n - i - 1) with (S (n - i - 1)) by Lia.lia.
      simpl.
      intros.
      apply IHw with (l := List.cons b l); [Lia.lia|].
      assumption.
- intros [GET LT].
  unfold word_to_bools.
  generalize (@nil bool).
  induction w.
  * Lia.lia.
  * destruct (Nat.eq_dec i n).
    + subst.
      intro.
      rewrite (plus_n_O n) at 3.
      simpl (word_to_bools_aux _ _).
      rewrite word_to_bools_aux_nth.
      replace (S n - n - 1) with 0 by Lia.lia.
      reflexivity.
    + intro.
      simpl (word_to_bools_aux _ _).
      apply IHw; [|Lia.lia].
      replace (S n - i - 1) with (S (n - i - 1)) in GET by Lia.lia.
      apply GET.
Qed.

Fixpoint bools_to_word_rev l : word (length l) :=
match l with
| [] => Word.WO
| b::t => Word.WS b (bools_to_word_rev t)
end%list.
Definition bools_to_word l : word (length l) :=
  cast_nat (bools_to_word_rev (List.rev l)) (List.rev_length l).

Lemma get_bit_cast_word m n (w : word m) (E : m = n) i :
  get_bit (cast_nat w E) i = get_bit w i.
subst.
rewrite cast_nat_refl.
reflexivity.
Qed.

Local Lemma bools_to_word_rev_get_bit : forall l i b,
  List.nth_error l i = Some b <-> get_bit (bools_to_word_rev l) i = b /\ i < length l.
induction l.
* destruct i; intros; split; simpl; intro; solve [congruence|Lia.lia].
* intros.
  destruct i.
  - simpl. intuition; solve [ congruence | Lia.lia ].
  - simpl. rewrite IHl.
    intuition.
Qed.

Lemma nth_error_rev A (l : list A) i x :
  List.nth_error l i = Some x <-> List.nth_error (List.rev l) (length l - i - 1) = Some x /\ i < length l.
destruct (lt_dec i (length l)) as [H|H].
* rewrite List.nth_error_nth' with (d := x); auto.
  rewrite List.nth_error_nth' with (d := x). 2: {
    rewrite List.rev_length.
    Lia.lia.
  }
  rewrite List.rev_nth. 2: Lia.lia.
  replace (length l - S (length l - i - 1)) with i by Lia.lia.
  tauto.
* apply not_lt in H.
  specialize (List.nth_error_None l i) as H'.
  intuition; solve [congruence | Lia.lia].
Qed.

Lemma bools_to_word_get_bit : forall l i b,
  List.nth_error l i = Some b <-> get_bit (bools_to_word l) (length l - i - 1) = b /\ i < length l.
intros.
unfold bools_to_word.
rewrite get_bit_cast_word.
rewrite nth_error_rev.
rewrite bools_to_word_rev_get_bit.
intuition.
rewrite List.rev_length.
Lia.lia.
Qed.

Lemma wrshift_alt : forall sz (w: word sz) n, Word.wrshift' w n = Word.wrshift w n.
intros.
unfold Word.wrshift, Word.wrshift'.
f_equal.
generalize (Word.combine w (Word.wzero n)).
generalize (Nat.add_comm sz n).
generalize (Nat.add_comm n sz).
generalize (sz + n).
intros n' e.
subst.
intros.
rewrite DepEqNat.nat_cast_proof_irrel with (e2 := eq_refl).
rewrite DepEqNat.nat_cast_same.
reflexivity.
Qed.

Lemma wzero_msb : forall sz H, Word.wzero (S sz) = eq_rect _ _ (Word.combine (Word.wzero sz) (Word.wzero 1)) _ H.
induction sz.
* simpl. intros [].
  reflexivity.
* intros H.
  change (Word.wzero (S (S sz))) with (Word.WS false (Word.wzero (S sz))).
  erewrite IHsz at 1.
  erewrite <- Word.WS_eq_rect.
  eapply eq_refl.
  Unshelve.
  Lia.lia.
Qed.

Lemma word_to_N_get_bit : forall [n] (w: word n) i, i < n -> get_bit w i = N.testbit (word_to_N w) (N.of_nat i).
unfold word_to_N.
intros n w i; revert n w.
induction i.
* intros.
  dependent inversion w as [|b n' w']; subst.
  + Lia.lia.
  + simpl.
    destruct b; destruct (Word.wordToN w'); reflexivity.
* intros n w LT.
  dependent inversion w as [|b n' w']; subst.
  + Lia.lia.
  + simpl (get_bit _ _).
    simpl (Word.wordToN _).
    rewrite IHi; [|Lia.lia].
    rewrite Nat2N.inj_succ.
    destruct b.
    - destruct (Word.wordToN w');
      rewrite N.testbit_succ_r_div2; auto; Lia.lia.
    - destruct (Word.wordToN w');
      rewrite N.testbit_succ_r_div2; auto; Lia.lia.
Qed.

Lemma testbit_word_to_N_high : forall [n] (w: word n) i, (i >= N.of_nat n)%N ->
  N.testbit (word_to_N w) i = false.
induction w.
* reflexivity.
* intros i I.
  replace (word_to_N (Word.WS b w)) with (2 * (word_to_N w) + N.b2n b)%N. 2: {
    destruct b; simpl; destruct (word_to_N w); reflexivity.
  }
  destruct (N.zero_or_succ i) as [|[j J]]. Lia.lia.
  subst.
  rewrite N.testbit_succ_r.
  apply IHw.
  Lia.lia.
Qed.

Lemma word_to_bools_nth_Some : forall [n] (w : word n) (i : nat) x, n > 0 ->
  List.nth_error (word_to_bools w) i = Some x <-> x = N.testbit (word_to_N w) (N.of_nat (n - i - 1)) /\ i < n.
intros.
rewrite word_to_bools_get_bit.
rewrite word_to_N_get_bit.
intuition.
Lia.lia.
Qed.

Lemma bools_to_word_nth_Some : forall (l : list bool) i b,
  List.nth_error l i = Some b <-> b = N.testbit (word_to_N (bools_to_word l)) (N.of_nat (length l - i - 1)) /\ i < length l.
intros.
destruct l.
* destruct i; simpl; intuition; congruence.
* rewrite bools_to_word_get_bit.
  rewrite word_to_N_get_bit.
  intuition.
  simpl (length _).
  Lia.lia.
Qed.

Local Lemma slice_equality {i n m} : i + n <= m -> m = i + (n + (m - n -i)).
Lia.lia.
Qed.

Definition slice [m] n (w : word m) (i : nat) : word n :=
  match Compare_dec.le_lt_dec (i + n) m with
  | left H =>
      let w : word (i + (n + (m - n - i))) := cast_nat w (slice_equality H) in
      Word.split1 n _ (Word.split2 i _ w)
  | right _ => dummy (zeros _)
  end.

Definition update_slice [m] [n] (w : word m) (i : nat) (v : word n) : word m :=
  match Compare_dec.le_lt_dec (i + n) m with
  | left H =>
    let w : word (i + (n + (m - n - i))) := cast_nat w (slice_equality H) in
    let pre := Word.split1 i _ w in
    let post := Word.split2 n _ (Word.split2 i _ w) in
    let w' := Word.combine pre (Word.combine v post) in
    cast_nat w' (eq_sym (slice_equality H))
  | right _ => dummy (zeros _)
  end.

Definition zero_extend [m] n (w : word m) : word n :=
  match Compare_dec.le_lt_dec m n with
  | left H =>
      cast_nat (Word.zext w (n - m)) (Arith_prebase.le_plus_minus_r_stt _ _ H)
  | right _ => dummy (zeros _)
  end.

Definition sign_extend [m] n (w : word m) : word n :=
  match Compare_dec.le_lt_dec m n with
  | left H =>
      cast_nat (Word.sext w (n - m)) (Arith_prebase.le_plus_minus_r_stt _ _ H)
  | right _ => dummy (zeros _)
  end.

Definition concat [m n] (w: word m) (v: word n) : word (m + n) :=
  cast_nat (Word.combine v w) (Nat.add_comm _ _).

Definition and : forall [n], word n -> word n -> word n := Word.wand.
Definition or  : forall [n], word n -> word n -> word n := Word.wor.
Definition xor : forall [n], word n -> word n -> word n := Word.wxor.
Definition not : forall [n], word n -> word n := Word.wnot.

Definition add : forall [n], word n -> word n -> word n := Word.wplus.
Definition sub : forall [n], word n -> word n -> word n := Word.wminus.
Definition mul : forall [n], word n -> word n -> word n := Word.wmult.

Definition logical_shift_left  [n] (w : word n) i : word n := Word.wlshift' w i.
Definition logical_shift_right [n] (w : word n) i : word n := Word.wrshift' w i.
Definition arith_shift_right   [n] (w : word n) i : word n := Word.wrshifta' w i.

Fixpoint replicate (n : nat) [a] (w : Word.word a) : Word.word (n * a) :=
match n with
| O => Word.WO
| S m => Word.combine w (replicate m w)
end.

Definition eqb [n] (w v : word n) : bool := Word.weqb w v.

Lemma eqb_true_iff [n] (v w : word n) : eqb v w = true <-> v = w.
apply Word.weqb_true_iff.
Qed.

Definition eq_dec [n] (w v : word n) : {w = v} + {w <> v} := Word.weq w v.

Fixpoint reverse_endian [n] (bits : word n) : word n :=
  match n return word n -> word n with
  | S (S (S (S (S (S (S (S m))))))) => fun bits =>
    cast_nat
      (Word.combine
         (reverse_endian (Word.split2 8 m bits))
         (Word.split1 8 m bits))
      (PeanoNat.Nat.add_comm _ _)
  | _ => fun bits => bits
  end bits.

Import String.
Import Strings.Ascii.

Local Fixpoint word_to_binary_string_acc [n] (w : Word.word n) (s : string) :=
  match w with
  | Word.WO => s
  | Word.WS b w' => word_to_binary_string_acc w' (String (if b then "1" else "0")%char s)
  end.
Definition word_to_binary_string [n] (bv : word n) : string := String "0" (String "b" (word_to_binary_string_acc bv "")).

End MachineWord.


Require Import floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Local Open Scope nat.
Local Open Scope logic.

Lemma Zlength_list_repeat:
  forall {A} n (x:A), Zlength (list_repeat (Z.to_nat n) x) = Z.max 0 n.
Proof.
intros.
rewrite Zlength_correct, length_list_repeat.
destruct (zlt n 0).
rewrite Z.max_l by omega.
rewrite Z2Nat_neg by auto. reflexivity.
rewrite Z2Nat.id by omega.
rewrite Z.max_r by omega.
auto.
Qed.

Definition splice_into_list (lo hi n : Z) (source target : list val) : list val :=
   sublist 0 lo (target ++ list_repeat (Z.to_nat (lo - Zlength target)) Vundef)
   ++ sublist 0 (hi-lo) (source ++ list_repeat (Z.to_nat (hi-lo)) Vundef)
   ++ sublist hi n (target ++ list_repeat (Z.to_nat (n- Zlength target)) Vundef).

Lemma splice_into_list_simplify0:
  forall n src dst,
    Zlength src = n ->
    Zlength dst = n ->
    splice_into_list 0 n n src dst = src.
Proof.
 intros.
 unfold splice_into_list.
rewrite !sublist_nil.
rewrite <- app_nil_end, app_nil_l.
pose proof (Zlength_nonneg src).
rewrite sublist_app by (rewrite ?Zlength_list_repeat, ?Z.max_r; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
apply sublist_same; omega.
Qed.

Lemma splice_into_list_simplify1:
  forall lo hi src tgt,
    lo = Zlength tgt ->
    (hi-lo = Zlength src)%Z ->
    splice_into_list lo hi hi src tgt = tgt++src.
Proof.
intros; subst; unfold splice_into_list.
pose proof (Zlength_nonneg tgt).
pose proof (Zlength_nonneg src).
rewrite H0.
rewrite Z.sub_diag.
change (Z.to_nat 0) with 0%nat; simpl.
rewrite <- app_nil_end.
rewrite sublist_same by omega.
f_equal.
rewrite (sublist_nil hi), <- app_nil_end.
rewrite sublist_app by (rewrite ?Zlength_list_repeat, ?Z.max_r; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end.
apply sublist_same; omega.
Qed.

Lemma splice_into_list_simplify2:
  forall lo hi src tgt,
    lo = Zlength tgt ->
    (lo <= hi)%Z ->
    (hi-lo <= Zlength src)%Z ->
    splice_into_list lo hi hi src tgt = tgt++ sublist 0 (hi-lo) src.
Proof.
intros; subst; unfold splice_into_list.
pose proof (Zlength_nonneg tgt).
pose proof (Zlength_nonneg src).
repeat rewrite Z.sub_diag.
change (Z.to_nat 0) with 0.
unfold list_repeat at 1.
rewrite <- app_nil_end.
rewrite sublist_same by omega.
f_equal.
rewrite sublist_nil, <- app_nil_end by omega.
rewrite sublist_app by (rewrite ?Zlength_list_repeat, ?Z.max_r; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
auto.
Qed.

Lemma JMeq_skipn:
  forall ta tb n (la: list ta) (lb: list tb),
     ta=tb ->
     JMeq la lb ->
     JMeq (skipn n la) (skipn n lb).
Proof.
intros. subst tb. apply JMeq_eq in H0. subst lb. auto.
Qed.

Lemma JMeq_firstn:
  forall ta tb n (la: list ta) (lb: list tb),
    ta=tb -> JMeq la lb -> JMeq (firstn n la) (firstn n lb).
Proof.
intros. subst tb. apply JMeq_eq in H0. subst lb. auto.
Qed.

Lemma JMeq_length:
  forall ta tb (la: list ta) (lb: list tb),
     ta=tb -> JMeq la lb -> length la = length lb.
Proof.
intros. subst tb.  apply JMeq_eq in H0. subst lb. auto.
Qed.

Lemma JMeq_sublist:
  forall ta tb lo hi (la: list ta) (lb: list tb),
    ta=tb -> JMeq la lb -> JMeq (sublist lo hi la) (sublist lo hi lb).
Proof.
intros. subst tb. apply JMeq_eq in H0. subst lb. auto.
Qed.

 Definition fsig_of_funspec (fs: funspec)  :=
  match fs with mk_funspec fsig _ _ _ _ _ _=> fsig end.

Lemma part1_splice_into_list:
  forall lo hi n al bl,
    (0 <= lo <= Zlength bl)%Z ->
    sublist 0 lo (splice_into_list lo hi n al bl) = sublist 0 lo bl.
Proof.
 intros.
 unfold splice_into_list.
 rewrite (sublist_app 0 lo bl) by (rewrite ?Zlength_list_repeat, ?Z.max_l; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
 rewrite (sublist_app); rewrite ?Zlength_list_repeat, ?Z.max_l by omega; try omega;
 rewrite ?Zlength_sublist by omega;
 try (rewrite ?Zlength_correct; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
rewrite sublist_same; auto.
rewrite Zlength_sublist; omega.
Qed.

Lemma part3_splice_into_list:
  forall lo hi n al bl,
    (0 <= lo <= hi)%Z -> (hi <= n)%Z ->
   (Zlength bl = n)%Z ->
   (Zlength al = hi-lo)%Z ->
    sublist hi n (splice_into_list lo hi n al bl) = sublist hi n bl.
Proof.
 intros.
 unfold splice_into_list.
 rewrite (sublist_app 0 lo bl) by (rewrite ?Zlength_list_repeat, ?Z.max_l; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
 rewrite (sublist_app 0 (hi-lo) al) by (rewrite ?Zlength_list_repeat, ?Z.max_r; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
rewrite (sublist_app hi n bl); try (rewrite ?Zlength_list_repeat, ?Z.max_r,  ?Z.max_l; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
rewrite <- app_ass.
 rewrite (sublist_app); rewrite ?Zlength_list_repeat, ?Z.max_r, ?Z.max_l by omega; try omega;
 rewrite ?Zlength_sublist by omega;
 try (rewrite ?Zlength_correct; omega).
rewrite !Zlength_app.
rewrite Zlength_sublist; try omega.
rewrite Zlength_sublist; try omega.
rewrite ?Z.min_r by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil by omega.
simpl.
rewrite Z.max_l by omega.
rewrite sublist_sublist by omega.
f_equal. omega.
rewrite !Zlength_app.
rewrite !Zlength_sublist; omega.
Qed.

Lemma Zlength_splice_into_list:
  forall lo hi n al bl,
    (0 <= lo <= hi)%Z -> (hi <= n)%Z ->
    Zlength (splice_into_list lo hi n al bl) = n.
Proof.
intros.
unfold splice_into_list.
rewrite !Zlength_app.
rewrite !Zlength_sublist; rewrite ?Zlength_app; rewrite ?Zlength_list_repeat; try omega.
destruct (zlt n (Zlength bl)).
rewrite Zmax_l by omega; omega.
rewrite Z.max_r; omega.
rewrite Z.max_r by omega.
rewrite Zlength_correct; omega.
destruct (zlt lo (Zlength bl)).
rewrite Zmax_l by omega; omega.
rewrite Z.max_r; omega.
Qed.

Local Arguments nested_field_type cs t gfs : simpl never.

(* Qinxiang:  look at the admits in this file.
 They are all about rerooting data_at and arrays.
*)

Lemma semax_call_id0_alt:
 forall Espec {cs: compspecs} Delta P Q R id bl argsig tfun retty cc A x Pre Post
   (GLBL: (var_types Delta) ! id = None),
       (glob_specs Delta) ! id = Some (NDmk_funspec (argsig, retty) cc A Pre Post) ->
       (glob_types Delta) ! id = Some (type_of_funspec (NDmk_funspec (argsig, retty) cc A Pre Post)) ->
   tfun = type_of_params argsig ->
  @semax cs Espec Delta (tc_exprlist Delta (argtypes argsig) bl
                  && (`(Pre x) (make_args' (argsig,retty) (eval_exprlist (argtypes argsig) bl))
                         * PROPx P (LOCALx Q (SEPx R))))
    (Scall None (Evar id (Tfunction tfun retty cc)) bl)
    (normal_ret_assert
       ((ifvoid retty (`(Post x) (make_args nil nil))
                                                   (EX v:val, `(Post x) (make_args (ret_temp::nil) (v::nil))))
         * PROPx P (LOCALx Q (SEPx R)))).
Proof.
intros.
subst tfun.
apply (@semax_call_id0 Espec cs Delta P Q R id bl argsig retty cc (rmaps.ConstType A) nil x
                  (fun _ => Pre) (fun _ => Post)
               (const_super_non_expansive _ _)
               (const_super_non_expansive _ _)); auto.
Qed.

Lemma call_memcpy_tuchar:  (* Uses CompSpecs from sha. *)
  forall (shp : share) (tp: type) (pathp: list gfield) (lop: Z) (vp': list val) (p: val)
           (shq: share) (tq: type) (pathq: list gfield) (loq: Z) (contents: list int) (q: val)
           (len : Z)
           (R': list mpred)
           (np nq : Z)
           (vp vp'': reptype (nested_field_type tp pathp))
           (vq : reptype (nested_field_type tq pathq))
           (e_p e_q e_n : expr)
           Espec Delta P Q R,
      typeof e_p = tptr tuchar ->
      typeof e_q = tptr tuchar ->
      typeof e_n = tuint ->
      (var_types Delta) ! _memcpy = None ->
     (glob_specs Delta) ! _memcpy = Some (snd memcpy_spec) ->
     (glob_types Delta) ! _memcpy = Some (type_of_funspec (snd memcpy_spec)) ->
     writable_share shp ->  readable_share shq ->
     nested_field_type tp pathp = tarray tuchar np ->
     nested_field_type tq pathq = tarray tuchar nq ->
     (0 <= lop)%Z ->
     (0 <= len <= Int.max_unsigned)%Z ->
     (lop + len <= np)%Z ->
     (0 <= loq)%Z ->  (loq + len <=  (*Zlength contents <=*) nq)%Z ->
     JMeq vq (map Vint contents) ->
     JMeq vp vp' ->
     JMeq vp'' (splice_into_list lop (lop+len) np (sublist loq (Zlength contents) (map Vint contents)) vp') ->
     ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |--
         tc_exprlist Delta [tptr tvoid; tptr tvoid; tuint] [e_p; e_q; e_n]  &&
         local (`(eq (field_address0 tp (ArraySubsc lop :: pathp) p)) (eval_expr e_p)) &&
         local (`(eq (field_address0 tq (ArraySubsc loq :: pathq) q)) (eval_expr e_q)) &&
         local (`(eq (Vint (Int.repr len))) (eval_expr e_n)) &&
         PROP () (LOCALx Q (SEPx (field_at shp tp pathp vp p ::
                                                 field_at shq tq pathq vq q :: R'))) ->
   @semax _ Espec Delta
    (PROPx P (LOCALx Q (SEPx R)))
    (Scall None
             (Evar _memcpy
               (Tfunction
                (Tcons (tptr tvoid) (Tcons (tptr tvoid) (Tcons tuint Tnil)))
                  (tptr tvoid) cc_default))
              [e_p; e_q; e_n])
    (normal_ret_assert (PROPx P (LOCALx Q
     (SEPx (field_at shp tp pathp vp'' p ::
               field_at shq tq pathq vq q :: R'))))).
Proof.
intros until R.
intros TCp TCq TCn Hvar Hspec Hglob ? SHq ? ? Hlop Hlen Hnp Hloq Hnq; intros.
assert_PROP (fold_right and True P); [ old_go_lower; entailer! | ].
apply semax_post' with
   (PROPx nil   (LOCALx Q
           (SEPx
              (field_at shp tp pathp vp'' p
               :: field_at shq tq pathq vq q :: R'))));
 [ old_go_lower; entailer! | ].
clear H6. rename H5 into Hpre.
assert_PROP (Zlength vp' = np /\ Zlength contents = nq). {
eapply derives_trans; [apply Hpre |].
apply andp_left2.
old_go_lower; entailer!.
clear - H7 H9 H0 H1 H2 H3 H Hlop Hloq Hnp Hnq Hlen.
forget (nested_field_type tp pathp) as t0.
forget (nested_field_type tq pathq) as t1.
subst t0 t1.
simplify_value_fits in H7. destruct H7 as [H7 _].
simplify_value_fits in H9. destruct H9 as [H9 _].
apply JMeq_eq in H3. subst vp; auto.
apply JMeq_eq in H2. subst vq; auto.
rewrite Zlength_map in H9.
split; auto.
} destruct H5 as [Hvp' Hvq'].

assert (reptype (tarray tuchar np) = list val) by reflexivity.
rewrite <- H0 in H5.
assert (H99: reptype (nested_field_type tp (ArraySubsc 0 :: pathp)) = val)
  by (rewrite nested_field_type_ind, H0; reflexivity).
assert (exists vpx : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp))),
                    JMeq vp vpx)
  by (rewrite H99, <- H5; exists vp; auto).
destruct H6 as [vpx Hvpx].
assert_PROP (legal_nested_field tp pathp /\ legal_nested_field tq pathq). {
  eapply derives_trans; [apply Hpre | apply andp_left2].
old_go_lower; entailer!.
} destruct H6 as [LNFp LNFq].
erewrite field_at_Tarray in Hpre; try apply JMeq_refl; try eassumption; auto; try omega.

assert (H98: reptype (nested_field_type tq (ArraySubsc 0 :: pathq)) = val).
 clear - H1. unfold nested_field_type in *; simpl in *.
  destruct (nested_field_rec tq pathq); inv H1. destruct p. subst.
 reflexivity.
assert (exists vqx : list (reptype (nested_field_type tq (ArraySubsc 0 :: pathq))),
                    JMeq vq vqx).
 rewrite H98. exists (map Vint contents); auto.
destruct H6 as [vqx Hvqx].
assert (JMeq vqx (map Vint contents)) by (eapply JMeq_trans; try eassumption; auto).
assert (LENvqx: Zlength vqx = nq). {
clear - H98 H6 Hvq'.
transitivity (Zlength (map Vint contents)).
forget (map Vint contents) as l.
forget val as t. subst t.
apply JMeq_eq in H6. subst; auto.
rewrite Zlength_map; auto.
}
assert (LENvpx: Zlength vpx = np). {
clear - H99 H5 H3 Hvp' Hvpx.
assert (JMeq vp' vpx) by (eapply JMeq_trans; [apply @JMeq_sym |]; eassumption).
clear Hvpx vp H3.
forget val as t. subst t.
apply JMeq_eq in H. subst; auto.
}
erewrite (field_at_Tarray shq) in Hpre|-*; try apply JMeq_refl; try eassumption; auto; try omega.
rewrite (split3seg_array_at shp tp pathp 0 lop (lop+len)) in Hpre by omega.
rewrite (split3seg_array_at shq tq pathq 0 loq (loq+len)) in Hpre|-* by omega.

rewrite !Z.sub_0_r in *.

normalize in Hpre. normalize.
assert_PROP (field_compatible0 tp (pathp SUB lop) p /\
            field_compatible0 tp (pathp SUB (lop + len)) p /\
            field_compatible0 tq (pathq SUB loq) q /\
            field_compatible0 tq (pathq SUB (loq + len)) q)
  as FC. {
 eapply derives_trans; [apply Hpre | clear Hpre].
 go_lowerx. apply andp_left2. normalize.
 saturate_local.
 apply prop_right.
 split3; auto.
}

pose (witness := ((shq,shp),
                              field_address0 tp (ArraySubsc lop :: pathp) p,
                              field_address0 tq (ArraySubsc loq :: pathq) q,
                              len,  sublist loq (loq+len) contents)).
pose (Frame :=
         array_at shp tp pathp 0 lop
              (sublist 0 lop vpx) p
          :: array_at shp tp pathp (lop+len) np
                 (sublist (lop + len) (Zlength vpx) vpx) p
             :: array_at shq tq pathq 0 loq (sublist 0 loq vqx) q *
                array_at shq tq pathq (loq + len) nq
                    (sublist (loq+len) (Zlength vqx) vqx) q :: R').
eapply semax_pre_post;
  [ | | eapply semax_call_id0_alt with (x:=witness)(P:=nil)(Q:=Q);
       try eassumption;
       try (rewrite ?Hspec, ?Hglob; reflexivity)].
*
 eapply derives_trans; [ apply Hpre | ].
 rewrite !andp_assoc.
 apply andp_derives; auto.
 subst witness. cbv beta iota. simpl @fst; simpl @snd.
 clear Hpre.
 autorewrite with norm1 norm2.
 rewrite PROP_combine.
 unfold app at 1.
 instantiate (1:=Frame).
 unfold app at 2.
 go_lowerx.
 apply andp_right.
 apply prop_right.
 unfold make_args'. simpl.
 unfold eval_id, env_set.
 rewrite TCp, TCq, TCn.  simpl.
 unfold_lift; simpl.
 rewrite <- H7, <- H8, <- H9.
 split3; auto.
 unfold field_address0; if_tac; try reflexivity.
 destruct H12; normalize.
 unfold field_address0; if_tac; try reflexivity.
 destruct H12; normalize.
 apply andp_right.
 apply prop_right; split3; auto.
 apply andp_right.
 apply prop_right; auto.
 subst Frame.
 rewrite LENvqx, LENvpx; cancel.
 rewrite sepcon_comm.
 apply sepcon_derives.
 rewrite array_at_data_at_rec by (try solve [clear - FC; intuition]; omega).
 apply derives_refl'.
 apply equal_f. apply data_at_type_changable.
 unfold nested_field_array_type.
 rewrite nested_field_type_ind. rewrite H1. simpl.
 unfold tarray; f_equal; clear; omega.
 eapply JMeq_trans; [apply fold_reptype_JMeq |].
   rewrite <- sublist_map.
   apply JMeq_sublist; auto.
 rewrite array_at_data_at_rec by (try solve [clear - FC; intuition]; omega).
 replace (memory_block shp len) with
    (memory_block shp (sizeof (nested_field_array_type tp pathp lop (lop + len)))).
 eapply derives_trans; [ | apply data_at__memory_block_cancel]; cancel.
 f_equal. unfold nested_field_array_type.
 rewrite nested_field_type_ind. rewrite H0. simpl.
 rewrite Z.max_r by omega. rewrite Z.mul_1_l. clear; omega.
*
 intros. apply andp_left2. apply normal_ret_assert_derives'.
 go_lowerx. unfold_lift.
 simpl.
 Intros x. rewrite prop_true_andp by auto.
 rewrite map_sublist.
 rewrite LENvqx; cancel.
 clear witness Frame.
 normalize in H8.
 subst x.
 simpl.
 clear Hpre H7 P Q rho .
assert (exists (vpy : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp)))),
                  JMeq vp'' vpy)
  by (rewrite H99; eauto).
destruct H7 as [vpy H8].
assert (Zlength vpy = np). {
 assert (JMeq vpy  (splice_into_list lop (lop + len) np
          (sublist loq (Zlength contents) (map Vint contents)) vp')) by (eapply JMeq_trans; [apply @JMeq_sym |]; eassumption).
 transitivity (Zlength  (splice_into_list lop (lop + len) np
          (sublist loq (Zlength contents) (map Vint contents)) vp')).
 clear - H7 H99 H5.
 forget (splice_into_list lop (lop + len) np
          (sublist loq (Zlength contents) (map Vint contents)) vp') as vv.
 forget val as t. subst t. apply JMeq_eq in H7. subst; auto.
 rewrite Zlength_splice_into_list; try omega.
}
 erewrite field_at_Tarray; try eassumption; try omega.
 rewrite (split3seg_array_at shp tp pathp 0 lop (lop+len) np) by omega.
 rewrite Z.sub_0_r.
 replace (lop+len-lop)%Z with len by omega.
 autorewrite with sublist.

match goal with |- ?A * ?B * ?C * ?D |-- _ =>
 apply derives_trans with (C * B * D * A); [solve [cancel] | ]
end.
repeat apply sepcon_derives.
+
 apply array_at_ext_derives.
 rewrite !Zlength_sublist; omega.
 intros.
 replace u0 with u1; auto.
 forget  (default_val (nested_field_type tp (ArraySubsc 0 :: pathp))) as d.
 apply JMeq_eq.
 eapply JMeq_trans; [exact H11 |].
 eapply JMeq_trans; [| apply @JMeq_sym; exact H10].

 rewrite Z.sub_0_r.
 admit.  (* tedious *)
+
 rewrite array_at_data_at_rec by (try solve [clear - FC; intuition]; omega).
   apply derives_refl'.
   apply equal_f. apply data_at_type_changable.
   unfold nested_field_array_type.
   rewrite nested_field_type_ind, H0.
   unfold tarray; f_equal. clear; omega.
   eapply JMeq_trans; [| apply @JMeq_sym, fold_reptype_JMeq].
  admit. (* tedious *)
+
 apply array_at_ext_derives.
 rewrite !Zlength_sublist; omega.
 intros.
 replace u0 with u1; auto.
 forget  (default_val (nested_field_type tp (ArraySubsc 0 :: pathp))) as d.
 apply JMeq_eq.
 eapply JMeq_trans; [exact H11 |].
 eapply JMeq_trans; [| apply @JMeq_sym; exact H10].
 clear u0 u1 H10 H11.
 rewrite LENvpx.
 admit.  (* tedious *)
+
 rewrite array_at_data_at_rec by (try solve [clear - FC; intuition]; omega).
   apply derives_refl'.
   apply equal_f. apply data_at_type_changable.
   unfold nested_field_array_type.
   rewrite nested_field_type_ind, H1.
   unfold tarray; f_equal. clear; omega.
   eapply JMeq_trans; [| apply @JMeq_sym, fold_reptype_JMeq].
   apply JMeq_sublist.
   rewrite nested_field_type_ind, H1. reflexivity.
   apply @JMeq_sym; auto.
Admitted.

Lemma call_memset_tuchar:
  forall (shp : share) (tp: type) (pathp: list gfield) (lop: Z) (vp': list val) (p: val)
           (c: int) (len : Z)
           (R': list mpred)
           (np : Z)
           (vp vp'': reptype (nested_field_type tp pathp))
           (e_p e_c e_n : expr)
           Espec Delta P Q R (s: signedness)
   (TCp : typeof e_p = tptr tuchar)
   (TCc : typeof e_c = tint)
   (TCn : typeof e_n = Tint I32 s noattr)
   (Hvar : (var_types Delta) ! _memset = None)
   (Hspec : (glob_specs Delta) ! _memset = Some (snd memset_spec))
   (Hglob : (glob_types Delta) ! _memset =
        Some (type_of_funspec (snd memset_spec)))
   (H:  writable_share shp)
   (Hlop : (0 <= lop)%Z)
   (Hlen: (0 <= len <= Int.max_unsigned)%Z)
   (H0:  nested_field_type tp pathp = tarray tuchar np)
   (Hnp : (lop + len <= np)%Z)
   (H3:  JMeq vp vp')
   (H4:  JMeq vp'' (splice_into_list lop (lop+len) np (list_repeat (Z.to_nat len) (Vint c)) vp'))
   (H5: ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |--
         tc_exprlist Delta [tptr tvoid; tint; tuint] [e_p; e_c; e_n] &&
         local (`(eq (field_address0 tp (ArraySubsc lop :: pathp) p)) (eval_expr e_p)) &&
         local (`(eq (Vint c)) (eval_expr e_c)) &&
         local (`(eq (Vint (Int.repr len))) (eval_expr e_n)) &&
         PROP () (LOCALx Q (SEPx (field_at shp tp pathp vp p :: R')))),
   @semax _ Espec Delta
    (PROPx P (LOCALx Q (SEPx R)))
    (Scall None
             (Evar _memset
               (Tfunction
                (Tcons (tptr tvoid) (Tcons tint (Tcons tuint Tnil)))
                  (tptr tvoid) cc_default))
              [e_p; e_c; e_n])
    (normal_ret_assert (PROPx P (LOCALx Q
     (SEPx (field_at shp tp pathp vp'' p :: R'))))).
Proof.
intros.
assert_PROP (fold_right and True P)
  by (old_go_lower; entailer!).
apply semax_post' with
   (PROPx nil   (LOCALx Q
           (SEPx (field_at shp tp pathp vp'' p :: R'))));
 [ old_go_lower; entailer! | ].
rename H5 into Hpre.
clear H1.
assert_PROP (Zlength vp' = np). {
eapply derives_trans; [apply Hpre | apply andp_left2].
old_go_lower; entailer!.
clear - H5 H4 H3 Hnp H0 Hlen Hlop.
forget (nested_field_type tp pathp) as t0.
subst t0.
simplify_value_fits in H5. destruct H5 as [H5 _].
apply JMeq_eq in H3. subst vp; auto.
} rename H1 into Hvp'.
assert (H5: reptype (tarray tuchar np) = list val) by reflexivity.
rewrite <- H0 in H5.
assert (H99: reptype (nested_field_type tp (ArraySubsc 0 :: pathp)) = val).
 clear - H0. unfold nested_field_type in *; simpl in *.
  destruct (nested_field_rec tp pathp); inv H0. destruct p. subst.
 reflexivity.
assert (H6: exists vpx : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp))),
                    JMeq vp' vpx).
rewrite H99. eauto.
destruct H6 as [vpx Hvpx].
assert_PROP (legal_nested_field tp pathp). {
  eapply derives_trans; [apply Hpre | apply andp_left2].
old_go_lower; entailer!.
} rename H1 into LNFp.
apply (fun H => JMeq_trans H Hvpx) in H3.
assert (LENvpx: Zlength vpx = np). {
clear - H99 Hvp' Hvpx.
forget val as t. subst t.
apply JMeq_eq in Hvpx. subst; auto.
}
erewrite field_at_Tarray in Hpre; try eassumption; auto; try omega.
rewrite (split3seg_array_at shp tp pathp 0 lop (lop+len)) in Hpre by omega.
rewrite !Z.sub_0_r in Hpre.

assert_PROP (field_compatible0 tp (pathp SUB lop) p /\
            field_compatible0 tp (pathp SUB (lop + len)) p)
  as FC. {
 eapply derives_trans; [apply Hpre | clear Hpre].
 go_lowerx. apply andp_left2. normalize.
 saturate_local.
 apply prop_right.
 split; auto.
}
pose (witness := (shp,
                              field_address0 tp (ArraySubsc lop :: pathp) p,
                              len,  c)).
pose (Frame :=
         array_at shp tp pathp (lop + len) np
              (sublist (lop+len) np vpx) p
          :: array_at shp tp pathp 0 lop (sublist 0 lop vpx) p
              :: R').
eapply semax_pre_post;
  [ | | eapply semax_call_id0_alt with (x:=witness)(P:=nil)(Q:=Q);
       try eassumption;
       try (rewrite ?Hspec, ?Hglob; reflexivity)].
*
 eapply derives_trans; [ apply Hpre | ].
 rewrite !andp_assoc.
 apply andp_derives; auto.
 subst witness. cbv beta iota. simpl @fst; simpl @snd.
 clear Hpre.
 autorewrite with norm1 norm2.
 rewrite PROP_combine.
 unfold app at 1.
 instantiate (1:=Frame).
 unfold app at 2.
 simpl argtypes. unfold eval_exprlist.
 unfold make_args'. simpl map at 2.
 rewrite TCp, TCc, TCn.
 go_lowerx. unfold env_set, eval_id. unfold_lift. simpl.
 autorewrite with gather_prop.
 apply andp_right.
 apply prop_right. split3; auto.
 rewrite <- H1.
 unfold field_address0; if_tac; try reflexivity.
 destruct H1; normalize.
 rewrite <- H2; simpl. split3; auto.
 rewrite <- H6; reflexivity.
 subst Frame.
 cancel.
 rewrite array_at_data_at_rec by  (try solve [clear - FC; intuition]; omega).
 eapply derives_trans; [apply data_at_data_at_ | ].
 eapply derives_trans; [apply data_at__memory_block_cancel | ].
 apply derives_refl'; f_equal.
  unfold nested_field_array_type.
   rewrite nested_field_type_ind, H0. simpl.
  rewrite Z.max_r by omega. omega.
*
 intros. apply andp_left2. apply normal_ret_assert_derives'.
 unfold ifvoid. unfold tptr at 1.
 Intros v. subst witness. cbv beta zeta iota.
 clear Hpre.
 autorewrite with norm1 norm2.
 rewrite PROP_combine.
 unfold app at 1.
 subst Frame.
 simpl map.
 old_go_lower. normalize.
 cancel.
 clear H1.
 assert (H2: exists (vpy : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp)))),
                  JMeq vp'' vpy).
 rewrite H99. eauto.
destruct H2 as [vpy H8].
erewrite field_at_Tarray; try eassumption; auto; try omega.
apply (JMeq_trans (JMeq_sym H4)) in H8.
clear dependent vp''. clear dependent e_c. clear dependent e_p. clear dependent e_n.
clear dependent Delta.
assert (Zlength vpy = np). {
clear - H0 H8 Hvp' Hnp Hlop Hlen.
generalize dependent vpy.
rewrite nested_field_type_ind, H0. simpl. rewrite reptype_eq; simpl.
intros.
apply JMeq_eq in H8.
subst.
clear H0.
rewrite Zlength_splice_into_list by omega.
auto.
}
rewrite (split3seg_array_at shp tp pathp 0 lop (lop+len) np) by omega.
rewrite !Z.sub_0_r.
replace (sublist 0 lop vpx) with (sublist 0 lop vpy).
Focus 2. {
generalize dependent vpy.
generalize dependent vpx.
rewrite H99.
intros.
apply JMeq_eq in H8. apply JMeq_eq in Hvpx.
subst.
apply part1_splice_into_list; omega.
} Unfocus.
replace (sublist (lop+len) np vpx) with (sublist (lop+len) np vpy).
Focus 2. {
generalize dependent vpy.
generalize dependent vpx.
rewrite H99.
intros.
apply JMeq_eq in H8. apply JMeq_eq in Hvpx.
subst.
apply part3_splice_into_list; try omega.
rewrite Zlength_list_repeat. rewrite Z.max_r by omega. omega.
} Unfocus.
cancel.
 rewrite array_at_data_at_rec by  (try solve [clear - FC; intuition]; omega).
   apply derives_refl'.
   apply equal_f. apply data_at_type_changable.
   unfold nested_field_array_type.
   rewrite nested_field_type_ind, H0.
   unfold tarray; f_equal. clear; omega.
   eapply JMeq_trans; [| apply @JMeq_sym, fold_reptype_JMeq].
   eapply JMeq_trans; [ | apply JMeq_sublist; [ | apply H8]; now auto].
   apply eq_JMeq.
   unfold splice_into_list.
   autorewrite with sublist. auto.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Finite sets                                                             *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibList.
Require Import LibSet LibLogic LibEqual LibReflect.

(** DISCLAIMER: under construction *)

(* ********************************************************************** *)
(** * Abstract interface for finite sets *)

Module Type FsetSig.

(** Definitions and operations on finite sets *)

Section Operations.
Variables (A:Type).

Parameter fset : Type -> Type.
Parameter mem : A -> fset A -> Prop.
Parameter empty : fset A.
Parameter singleton : A -> fset A.
Parameter union : fset A -> fset A -> fset A.
Parameter inter : fset A -> fset A -> fset A.
Parameter remove : fset A -> fset A -> fset A.

(** Equality on these sets is extensional *)

Definition subset E F :=
  forall x, mem x E -> mem x F.

Definition notin x E :=
  ~ mem x E.

Definition disjoint E F :=
  inter E F = empty.

Definition from_list L :=
  fold_right (fun x acc => union (singleton x) acc) empty L.

End Operations.

Implicit Arguments empty [[A]].

(** Notations *)

Notation "\{}" := (empty) : fset_scope.

Notation "\{ x }" := (singleton x) : fset_scope.

Notation "E \u F" := (union E F)
  (at level 37, right associativity) : fset_scope.

Notation "E \n F" := (inter E F)
  (at level 36, right associativity) : fset_scope.

Notation "E \- F" := (remove E F)
  (at level 35) : fset_scope.

Notation "x \in E" := (mem x E) (at level 39) : fset_scope.

Notation "x \notin E" := (notin x E) (at level 39) : fset_scope.

Notation "E \c F" := (subset E F)
  (at level 38) : fset_scope.

Delimit Scope fset_scope with fset.
Bind Scope fset_scope with fset.
Open Scope fset_scope.

Section Properties.
Variables A : Type.
Implicit Types x : A.
Implicit Types E : fset A.

(** Extensionality *)

Parameter fset_extens : forall E F,
  subset E F -> subset F E -> E = F.

(** Finiteness *)

Parameter fset_finite : forall E,
  exists L, E = from_list L.

(** Semantics of basic operations *)

Parameter in_empty : forall x,
  x \in \{} = False.

Parameter in_singleton : forall x y,
  x \in \{y} = (x = y).

Parameter in_union : forall x E F,
  x \in (E \u F) = ((x \in E) \/ (x \in F)).

Parameter in_inter : forall x E F,
  x \in (E \n F) = ((x \in E) /\ (x \in F)).

Parameter in_remove : forall x E F,
  x \in (E \- F) = ((x \in E) /\ (x \notin F)).

End Properties.

End FsetSig.

(* ********************************************************************** *)
(** * Implementation of finite sets *)

Module Export FsetImpl : FsetSig.

(** Note: most of the material contained in this module will ultimately
    be moved into the TLC library in a file called LibFset. *)

Close Scope container_scope.

Definition finite A (U:set A) :=
  exists L, forall x, is_in x U -> Mem x L.

Definition fset A := sig (@finite A).

Definition build_fset A (U:set A) (F:finite U) :=
  exist (@finite A) U F.

Section Operations.
Variables (A:Type).

Definition mem (x:A) (E:fset A) :=
  is_in x (proj1_sig E).

Lemma finite_empty : @finite A LibBag.empty.
Proof using. exists (@nil A). intros x. rewrite in_empty_eq. auto_false. Qed.

Definition empty : fset A :=
  build_fset finite_empty.

Lemma singleton_finite : forall (x:A),
  finite (LibBag.single x).
Proof using.
  intros. exists (x::nil). intros y.
  rewrite in_single_eq. intro_subst. constructor.
Qed.

Definition singleton (x : A) :=
  build_fset (singleton_finite x).

Lemma union_finite : forall U V : set A,
  finite U -> finite V -> finite (union U V).
Proof using.
  introv [L1 E1] [L2 E2]. exists (L1 ++ L2). intros x.
  rewrite in_union_eq. rewrite Mem_app_or_eq. introv [H|H]; auto.
Qed.

Definition union (E F : fset A) :=
  build_fset (union_finite (proj2_sig E) (proj2_sig F)).

Lemma inter_finite : forall U V : set A,
  finite U -> finite V -> finite (inter U V).
Proof using.
  introv [L1 E1] [L2 E2]. exists (L1 ++ L2). intros x.
  rewrite in_inter_eq. rewrite Mem_app_or_eq. autos*.
Qed.

Definition inter (E F : fset A) :=
  build_fset (inter_finite (proj2_sig E) (proj2_sig F)).

Lemma remove_finite : forall U V : set A,
  finite U -> finite V -> finite (remove U V).
Proof using.
  introv [L1 E1] [L2 E2]. exists L1. intros x.
  rewrite in_remove_eq. introv [H1 H2]; auto.
Qed.

Definition remove (E F : fset A) :=
  build_fset (remove_finite (proj2_sig E) (proj2_sig F)).

Definition subset E F :=
  forall x, mem x E -> mem x F.

Definition notin x E :=
  ~ mem x E.

Definition disjoint E F :=
  inter E F = empty.

Definition from_list L :=
  fold_right (fun x acc => union (singleton x) acc) empty L.

End Operations.

Implicit Arguments empty [[A]].

(** Notations *)

Notation "\{}" := (empty) : fset_scope.

Notation "\{ x }" := (singleton x) : fset_scope.

Notation "E \u F" := (union E F)
  (at level 37, right associativity) : fset_scope.

Notation "E \n F" := (inter E F)
  (at level 36, right associativity) : fset_scope.

Notation "E \- F" := (remove E F)
  (at level 35) : fset_scope.

Notation "x \in E" := (mem x E) (at level 39) : fset_scope.

Notation "x \notin E" := (notin x E) (at level 39) : fset_scope.

Notation "E \c F" := (subset E F)
  (at level 38) : fset_scope.

Delimit Scope fset_scope with fset.
Bind Scope fset_scope with fset.
Open Scope fset_scope.

Section Properties.
Variables A : Type.
Implicit Types x : A.
Implicit Types E : fset A.

Lemma fset_extens_eq : forall E F,
  (forall x, x \in E = x \in F) -> E = F.
Proof using.
  unfold mem. intros [U FU] [V FV] H. simpls.
  apply exist_eq. apply in_extens. intros. rewrite* H.
Qed.

Lemma fset_extens : forall E F,
  subset E F -> subset F E -> E = F.
Proof using. intros. apply fset_extens_eq. extens*. Qed.

Lemma in_empty : forall x,
  x \in \{} = False.
Proof using. unfold mem, empty. simpl. intros. rewrite in_empty_eq. autos*. Qed.

Lemma in_singleton : forall x y,
  x \in \{y} = (x = y).
Proof using. unfold mem, singleton. simpl. intros. rewrite in_single_eq. autos*. Qed.

Lemma in_union : forall x E F,
  x \in (E \u F) = ((x \in E) \/ (x \in F)).
Proof using. unfold mem, union. simpl. intros. rewrite in_union_eq. autos*. Qed.

Lemma in_inter : forall x E F,
  x \in (E \n F) = ((x \in E) /\ (x \in F)).
Proof using. unfold mem, inter. simpl. intros. rewrite in_inter_eq. autos*. Qed.

Lemma in_remove : forall x E F,
  x \in (E \- F) = ((x \in E) /\ (x \notin F)).
Proof using. unfold mem, remove. simpl. intros. rewrite in_remove_eq. autos*. Qed.

Lemma from_list_spec : forall x L,
  x \in from_list L = Mem x L.
Proof using.
  unfold from_list. induction L; rew_list.
  rewrite in_empty. rewrite~ Mem_nil_eq.
  rewrite in_union, in_singleton. rewrite~ Mem_cons_eq. congruence.
Qed.

Hint Constructors Mem.

Lemma fset_finite : forall E,
  exists L, E = from_list L.
Proof using.
  intros [U [L' H]]. exists (filter (fun x => isTrue (is_in x U)) L').
  apply fset_extens_eq. intros x. rewrite from_list_spec.
  unfold mem at 1. simpl. extens. iff M.
    specializes H M. induction L'.
      inverts H.
      rewrite filter_cons. inverts H.
        rewrite (is_True M). rewrite~ isTrue_True.
        case_if; fold_bool; fold_prop; auto.
    clear H. induction L'.
      rewrite filter_nil in M. inverts M.
      rewrite filter_cons in M. cases_if; fold_bool; fold_prop.
        inverts~ M.
        apply~ IHL'.
Qed.

End Properties.

End FsetImpl.

(* ********************************************************************** *)
(** * Derivable properties about finite sets *)

Section Properties.
Variables A : Type.
Implicit Types x : A.
Implicit Types E : fset A.

(** Properties of [in] *)

Lemma in_empty_elim : forall x,
  x \in \{} -> False.
Proof using. introv H. rewrite~ in_empty in H. Qed.

Lemma in_singleton_self : forall x,
  x \in \{x}.
Proof using. intros. rewrite~ in_singleton. Qed.

(** Properties of [union] *)

Lemma union_same : forall E,
  E \u E = E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_union.
Qed.

Lemma union_comm : forall E F,
  E \u F = F \u E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_union.
Qed.

Lemma union_assoc : forall E F G,
  E \u (F \u G) = (E \u F) \u G.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_union.
Qed.

Lemma union_empty_l : forall E,
  \{} \u E = E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all in_union.
    intros [ H | H ]. false. rewrite~ in_empty in H. auto.
    autos*.
Qed.

Lemma union_empty_r : forall E,
  E \u \{} = E.
Proof using. intros. rewrite union_comm. apply union_empty_l. Qed.

Lemma union_comm_assoc : forall E F G,
  E \u (F \u G) = F \u (E \u G).
Proof using.
  intros. rewrite union_assoc.
  rewrite (union_comm E F).
  rewrite~ <- union_assoc.
Qed.

(** Properties of [inter] *)

Lemma inter_same : forall E,
  E \n E = E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_inter.
Qed.

Lemma inter_comm : forall E F,
  E \n F = F \n E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_inter.
Qed.

Lemma inter_assoc : forall E F G,
  E \n (F \n G) = (E \n F) \n G.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_inter.
Qed.

Lemma inter_empty_l : forall E,
  \{} \n E = \{}.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all in_inter.
    intros. false* in_empty_elim.
    intros. false* in_empty_elim.
Qed.

Lemma inter_empty_r : forall E,
  E \n \{} = \{}.
Proof using. intros. rewrite inter_comm. apply inter_empty_l. Qed.

Lemma inter_comm_assoc : forall E F G,
  E \n (F \n G) = F \n (E \n G).
Proof using.
  intros. rewrite inter_assoc.
  rewrite (inter_comm E F).
  rewrite~ <- inter_assoc.
Qed.

(* Properties of [from_list] *)

Lemma from_list_nil :
  from_list (@nil A) = \{}.
Proof using. auto. Qed.

Lemma from_list_cons : forall x l,
  from_list (x::l) = \{x} \u (from_list l).
Proof using. auto. Qed.

(* Properties of [disjoint] *)

Lemma disjoint_comm : forall E F,
  disjoint E F -> disjoint F E.
Proof using. unfold disjoint. intros. rewrite~ inter_comm. Qed.

Lemma disjoint_in_notin : forall E F x,
  disjoint E F -> x \in E -> x \notin F.
Proof using.
  unfold disjoint. introv H InE InF. applys in_empty_elim x.
  rewrite <- H. rewrite in_inter. auto.
Qed.

(** Properties of [notin] *)

Lemma notin_empty : forall x,
  x \notin \{}.
Proof using. intros_all. rewrite~ in_empty in H. Qed.

Lemma notin_singleton : forall x y,
  x \notin \{y} <-> x <> y.
Proof using. unfold notin. intros. rewrite* <- in_singleton. Qed.

Lemma notin_same : forall x,
  x \notin \{x} -> False.
Proof using. intros. apply H. apply* in_singleton_self. Qed.

Lemma notin_union : forall x E F,
  x \notin (E \u F) <-> (x \notin E) /\ (x \notin F).
Proof using. unfold notin. intros. rewrite* in_union. Qed.

(** Properties of [subset] *)

Lemma subset_refl : forall E,
  E \c E.
Proof using. intros_all. auto. Qed.

Lemma subset_empty_l : forall E,
  \{} \c E.
Proof using. intros_all. rewrite* in_empty in H. Qed.

Lemma subset_union_weak_l : forall E F,
  E \c (E \u F).
Proof using. intros_all. rewrite* in_union. Qed.

Lemma subset_union_weak_r : forall E F,
  F \c (E \u F).
Proof using. intros_all. rewrite* in_union. Qed.

Lemma subset_union_2 : forall E1 E2 F1 F2,
  E1 \c F1 -> E2 \c F2 -> (E1 \u E2) \c (F1 \u F2).
Proof using. introv H1 H2. intros x. do 2 rewrite* in_union. Qed.

(** Properties of [remove] *)

Lemma union_remove : forall E F G,
  (E \u F) \- G = (E \- G) \u (F \- G).
Proof using.
  intros. apply fset_extens; intros x;
  repeat (first [ rewrite in_remove | rewrite in_union ]); autos*.
Qed.

End Properties.


Inductive T := Leaf : T | Node : T -> T -> T.

Definition task := forall x y z w, Node x y = Node z w -> x = z /\ y = w.


(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

From Coq Require Import Setoid Relations Arith FunInd.

Inductive comp : Type :=
  | Equivalent : comp
  | Less_than : comp
  | Greater_than : comp
  | Uncomparable : comp.

Module Type S.

Parameter A : Type.
Parameter eq_bool : A -> A -> bool.
Parameter eq_bool_ok : forall a1 a2, match eq_bool a1 a2 with true => a1 = a2 | false => ~ a1 = a2 end.

Parameter o : relation A.
Parameter o_bool : A -> A -> bool.
Parameter o_bool_ok : forall a1 a2, match o_bool a1 a2 with true => o a1 a2 | false => ~ o a1 a2 end.
Parameter o_proof : order A o.
Parameter o_total : forall e1 e2 : A, {o e1 e2} + {o e2 e1}.

End S.

Module Type ES.

Parameter A : Type.
Parameter eq_A : relation A.
Parameter eq_bool : A -> A -> bool.
Parameter eq_bool_ok : forall a1 a2, match eq_bool a1 a2 with true => eq_A a1 a2 | false => ~eq_A a1 a2 end.
Parameter eq_proof : equivalence A eq_A.

Parameter o : relation A.
Parameter o_compat :
  forall e1 e1' e2 e2', eq_A e1 e1' -> eq_A e2 e2' -> o e1 e2 -> o e1' e2'.
Parameter o_bool : A -> A -> bool.
Parameter o_bool_ok : forall a1 a2, match o_bool a1 a2 with true => o a1 a2 | false => ~ o a1 a2 end.
Parameter o_proof : order A o.
Parameter o_total : forall e1 e2 : A, {o e1 e2} + {o e2 e1}.

  Add Relation A eq_A
  reflexivity proved by (equiv_refl _ _ eq_proof)
    symmetry proved by (equiv_sym _ _ eq_proof)
      transitivity proved by (equiv_trans _ _ eq_proof) as EQA.

End ES.

(*
Lemma toto : forall (A : Type) (R : relation A),
  (order A R) ->
  (forall e1 e2 : A, {R e1 e2} + {~ R e1 e2}) ->
  (forall e1 e2 : A, {R e1 e2} + {R e2 e1}) ->
  forall e1 e2 : A, {e1 = e2} + {e1 <> e2}.
Proof.
intros A R Ord Dec Tot e1 e2; destruct Ord.
destruct (Tot e1 e2) as [e1_le_e2 | e2_le_e1].
destruct (Dec e2 e1) as [e2_le_e1 | not_e2_le_e1].
left; apply ord_antisym; trivial.
right; intro; apply not_e2_le_e1; subst; trivial.
destruct (Dec e1 e2) as [e1_le_e2 | not_e1_le_e2].
left; apply ord_antisym; trivial.
right; intro; apply not_e1_le_e2; subst; trivial.
Qed.
*)

Module Nat <: S with Definition A:=nat.

Definition A := nat.
Definition o : relation A := le.

Lemma o_proof : order A o.
Proof.
unfold o; constructor; auto.
unfold reflexive; auto.
unfold transitive; intros n1 n2 n3 H1 H2; apply le_trans with n2; trivial.
unfold antisymmetric; auto with arith.
Qed.

Lemma o_dec : forall e1 e2 : A, {o e1 e2} + {~ o e1 e2}.
Proof.
unfold o.
induction e1; induction e2.
left; trivial.
left; auto with arith.
right; auto with arith.
destruct (IHe1 e2); destruct IHe2; auto with arith.
Defined.

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

Lemma eq_bool_ok : forall a1 a2, match eq_bool a1 a2 with true => a1 = a2 | false => ~a1 = a2 end.
fix eq_bool_ok 1.
intros [ | n] [ | m]; simpl.
reflexivity.
discriminate.
discriminate.
generalize (eq_bool_ok n m); case (eq_bool n m).
intros; subst; reflexivity.
intros n_diff_m Sn_eq_Sm; apply n_diff_m; injection Sn_eq_Sm; intro; assumption.
Defined.

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

Lemma o_bool_ok : forall a1 a2, match o_bool a1 a2 with true => o a1 a2 | false => ~ o a1 a2 end.
unfold o; fix o_bool_ok 1.
intros [ | n] [ | m]; simpl.
apply le_n.
apply le_O_n.
intro H; inversion H.
generalize (o_bool_ok n m); case (o_bool n m).
intro H; apply (le_n_S _ _ H).
intros H H'; apply H; apply (le_S_n _ _ H').
Defined.

Lemma o_total : forall e1 e2 : A, {o e1 e2} + {o e2 e1}.
Proof.
intros.
unfold o.
change ({e1<=e2}+{e1>=e2}).
apply le_ge_dec.
Qed.

End Nat.


Require Import NAxioms NProperties OrdersFacts.

Module Nat
 <: NAxiomsSig
 <: UsualDecidableTypeFull
 <: OrderedTypeFull
 <: TotalOrder.

Include Coq.Init.Nat.

Set Inline Level 50.

Definition eq_equiv : Equivalence (@eq nat) := eq_equivalence.
Local Obligation Tactic := simpl_relation.
Program Instance succ_wd : Proper (eq==>eq) S.
Program Instance pred_wd : Proper (eq==>eq) pred.
Program Instance add_wd : Proper (eq==>eq==>eq) plus.
Program Instance sub_wd : Proper (eq==>eq==>eq) minus.
Program Instance mul_wd : Proper (eq==>eq==>eq) mult.
Program Instance pow_wd : Proper (eq==>eq==>eq) pow.
Program Instance div_wd : Proper (eq==>eq==>eq) div.
Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
Program Instance testbit_wd : Proper (eq==>eq==>eq) testbit.

Theorem bi_induction :
  forall A : nat -> Prop, Proper (eq==>iff) A ->
    A 0 -> (forall n : nat, A n <-> A (S n)) -> forall n : nat, A n.
Proof.
intro prop.
unfold Proper.

intros A A_wd A0 AS. apply nat_ind. assumption. intros; now apply -> AS.
Qed.

(** Recursion fonction *)

Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A :=
  nat_rect (fun _ => A).

Instance recursion_wd {A} (Aeq : relation A) :
 Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion.
Proof.
intros a a' Ha f f' Hf n n' Hn. subst n'.
induction n; simpl; auto. apply Hf; auto.
Qed.

Theorem recursion_0 :
  forall {A} (a : A) (f : nat -> A -> A), recursion a f 0 = a.
Proof.
reflexivity.
Qed.

Theorem recursion_succ :
  forall {A} (Aeq : relation A) (a : A) (f : nat -> A -> A),
    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
      forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)).
Proof.
unfold Proper, respectful in *; induction n; simpl; auto.
Qed.

(** ** Remaining constants not defined in Coq.Init.Nat *)

(** NB: Aliasing [le] is mandatory, since only a Definition can implement
    an interface Parameter... *)

Definition eq := @Logic.eq nat.
Definition le := Peano.le.
Definition lt := Peano.lt.

(** ** Basic specifications : pred add sub mul *)

Lemma pred_succ n : pred (S n) = n.
Proof.
reflexivity.
Qed.

Lemma pred_0 : pred 0 = 0.
Proof.
reflexivity.
Qed.

Lemma one_succ : 1 = S 0.
Proof.
reflexivity.
Qed.

Lemma two_succ : 2 = S 1.
Proof.
reflexivity.
Qed.

Lemma add_0_l n : 0 + n = n.
Proof.
reflexivity.
Qed.

Lemma add_succ_l n m : (S n) + m = S (n + m).
Proof.
reflexivity.
Qed.

Lemma sub_0_r n : n - 0 = n.
Proof.
now destruct n.
Qed.

Lemma sub_succ_r n m : n - (S m) = pred (n - m).
Proof.
revert m. induction n; destruct m; simpl; auto. apply sub_0_r.
Qed.

Lemma mul_0_l n : 0 * n = 0.
Proof.
reflexivity.
Qed.

Lemma mul_succ_l n m : S n * m = n * m + m.
Proof.
assert (succ_r : forall x y, x+S y = S(x+y)) by now induction x.
assert (comm : forall x y, x+y = y+x).
{ induction x; simpl; auto. intros; rewrite succ_r; now f_equal. }
now rewrite comm.
Qed.

Lemma lt_succ_r n m : n < S m <-> n <= m.
Proof.
split. apply Peano.le_S_n. induction 1; auto.
Qed.

(** ** Boolean comparisons *)

Lemma eqb_eq n m : eqb n m = true <-> n = m.
Proof.
 revert m.
 induction n; destruct m; simpl; rewrite ?IHn; split; try easy.
 - now intros ->.
 - now injection 1.
Qed.

Lemma leb_le n m : (n <=? m) = true <-> n <= m.
Proof.
 revert m.
 induction n; destruct m; simpl.
 - now split.
 - split; trivial. intros; apply Peano.le_0_n.
 - now split.
 - rewrite IHn; split.
   + apply Peano.le_n_S.
   + apply Peano.le_S_n.
Qed.

Lemma ltb_lt n m : (n <? m) = true <-> n < m.
Proof.
 apply leb_le.
Qed.

(** ** Decidability of equality over [nat]. *)

Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}.
Proof.
  induction n; destruct m.
  - now left.
  - now right.
  - now right.
  - destruct (IHn m); [left|right]; auto.
Defined.

(** ** Ternary comparison *)

(** With [nat], it would be easier to prove first [compare_spec],
    then the properties below. But then we wouldn't be able to
    benefit from functor [BoolOrderFacts] *)

Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m.
Proof.
 revert m; induction n; destruct m; simpl; rewrite ?IHn; split; auto; easy.
Qed.

Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m.
Proof.
 revert m; induction n; destruct m; simpl; rewrite ?IHn; split; try easy.
 - intros _. apply Peano.le_n_S, Peano.le_0_n.
 - apply Peano.le_n_S.
 - apply Peano.le_S_n.
Qed.

Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m.
Proof.
 revert m; induction n; destruct m; simpl; rewrite ?IHn.
 - now split.
 - split; intros. apply Peano.le_0_n. easy.
 - split. now destruct 1. inversion 1.
 - split; intros. now apply Peano.le_n_S. now apply Peano.le_S_n.
Qed.

Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m).
Proof.
 revert m; induction n; destruct m; simpl; trivial.
Qed.

Lemma compare_succ n m : (S n ?= S m) = (n ?= m).
Proof.
 reflexivity.
Qed.

(* BUG: Ajout d'un cas * après preuve finie (deuxième niveau +++*** ) :
    *  --->   Anomaly: Uncaught exception Proofview.IndexOutOfRange(_). Please report. *)

(** ** Minimum, maximum *)

Lemma max_l : forall n m, m <= n -> max n m = n.
Proof.
 exact Peano.max_l.
Qed.

Lemma max_r : forall n m, n <= m -> max n m = m.
Proof.
 exact Peano.max_r.
Qed.

Lemma min_l : forall n m, n <= m -> min n m = n.
Proof.
 exact Peano.min_l.
Qed.

Lemma min_r : forall n m, m <= n -> min n m = m.
Proof.
 exact Peano.min_r.
Qed.

(** Some more advanced properties of comparison and orders,
    including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *)

Include BoolOrderFacts.

(** We can now derive all properties of basic functions and orders,
    and use these properties for proving the specs of more advanced
    functions. *)

Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.

(** ** Power *)

Lemma pow_neg_r a b : b<0 -> a^b = 0. inversion 1. Qed.

Lemma pow_0_r a : a^0 = 1.
Proof. reflexivity. Qed.

Lemma pow_succ_r a b : 0<=b -> a^(S b) = a * a^b.
Proof. reflexivity. Qed.

(** ** Square *)

Lemma square_spec n : square n = n * n.
Proof. reflexivity. Qed.

(** ** Parity *)

Definition Even n := exists m, n = 2*m.
Definition Odd n := exists m, n = 2*m+1.

Module Private_Parity.

Lemma Even_1 : ~ Even 1.
Proof.
 intros ([|], H); try discriminate.
 simpl in H. now rewrite <- plus_n_Sm in H.
Qed.

Lemma Even_2 n : Even n <-> Even (S (S n)).
Proof.
 split; intros (m,H).
 - exists (S m). rewrite H. simpl. now rewrite plus_n_Sm.
 - destruct m; try discriminate.
   exists m. simpl in H. rewrite <- plus_n_Sm in H. now inversion H.
Qed.

Lemma Odd_0 : ~ Odd 0.
Proof.
 now intros ([|], H).
Qed.

Lemma Odd_2 n : Odd n <-> Odd (S (S n)).
Proof.
 split; intros (m,H).
 - exists (S m). rewrite H. simpl. now rewrite <- (plus_n_Sm m).
 - destruct m; try discriminate.
   exists m. simpl in H. rewrite <- plus_n_Sm in H. inversion H.
   simpl. now rewrite <- !plus_n_Sm, <- !plus_n_O.
Qed.

End Private_Parity.
Import Private_Parity.

Lemma even_spec : forall n, even n = true <-> Even n.
Proof.
 fix 1.
  destruct n as [|[|n]]; simpl.
  - split; [ now exists 0 | trivial ].
  - split; [ discriminate | intro H; elim (Even_1 H) ].
  - rewrite even_spec. apply Even_2.
Qed.

Lemma odd_spec : forall n, odd n = true <-> Odd n.
Proof.
 unfold odd.
 fix 1.
  destruct n as [|[|n]]; simpl.
  - split; [ discriminate | intro H; elim (Odd_0 H) ].
  - split; [ now exists 0 | trivial ].
  - rewrite odd_spec. apply Odd_2.
Qed.

(** ** Division *)

Lemma divmod_spec : forall x y q u, u <= y ->
 let (q',u') := divmod x y q u in
 x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y.
Proof.
 induction x.
 - simpl; intuition.
 - intros y q u H. destruct u; simpl divmod.
   + generalize (IHx y (S q) y (le_n y)). destruct divmod as (q',u').
     intros (EQ,LE); split; trivial.
     rewrite <- EQ, sub_0_r, sub_diag, add_0_r.
     now rewrite !add_succ_l, <- add_succ_r, <- add_assoc, mul_succ_r.
   + assert (H' : u <= y).
     { apply le_trans with (S u); trivial. do 2 constructor. }
     generalize (IHx y q u H'). destruct divmod as (q',u').
     intros (EQ,LE); split; trivial.
     rewrite <- EQ.
     rewrite !add_succ_l, <- add_succ_r. f_equal. now rewrite <- sub_succ_l.
Qed.

Lemma div_mod x y : y<>0 -> x = y*(x/y) + x mod y.
Proof.
 intros Hy.
 destruct y; [ now elim Hy | clear Hy ].
 unfold div, modulo.
 generalize (divmod_spec x y 0 y (le_n y)).
 destruct divmod as (q,u).
 intros (U,V).
 simpl in *.
 now rewrite mul_0_r, sub_diag, !add_0_r in U.
Qed.

Lemma mod_bound_pos x y : 0<=x -> 0<y -> 0 <= x mod y < y.
Proof.
 intros Hx Hy. split. apply le_0_l.
 destruct y; [ now elim Hy | clear Hy ].
 unfold modulo.
 apply lt_succ_r, le_sub_l.
Qed.

(** ** Square root *)

Lemma sqrt_iter_spec : forall k p q r,
 q = p+p -> r<=q ->
 let s := sqrt_iter k p q r in
 s*s <= k + p*p + (q - r) < (S s)*(S s).
Proof.
 induction k.
 - (* k = 0 *)
   simpl; intros p q r Hq Hr.
   split.
   + apply le_add_r.
   + apply lt_succ_r.
     rewrite mul_succ_r.
     rewrite add_assoc, (add_comm p), <- add_assoc.
     apply add_le_mono_l.
     rewrite <- Hq. apply le_sub_l.
 - (* k = S k' *)
   destruct r.
   + (* r = 0 *)
     intros Hq _.
     replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))).
     * apply IHk.
       simpl. now rewrite add_succ_r, Hq. apply le_n.
     * rewrite sub_diag, sub_0_r, add_0_r. simpl.
       rewrite add_succ_r; f_equal. rewrite <- add_assoc; f_equal.
       rewrite mul_succ_r, (add_comm p), <- add_assoc. now f_equal.
   + (* r = S r' *)
     intros Hq Hr.
     replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)).
     * apply IHk; trivial. apply le_trans with (S r); trivial. do 2 constructor.
     * simpl. rewrite <- add_succ_r. f_equal. rewrite <- sub_succ_l; trivial.
Qed.

Lemma sqrt_specif n : (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n).
Proof.
 set (s:=sqrt n).
 replace n with (n + 0*0 + (0-0)).
 apply sqrt_iter_spec; auto.
 simpl. now rewrite !add_0_r.
Qed.

Definition sqrt_spec a (Ha:0<=a) := sqrt_specif a.

Lemma sqrt_neg a : a<0 -> sqrt a = 0.
Proof. inversion 1. Qed.

(** ** Logarithm *)

Lemma log2_iter_spec : forall k p q r,
 2^(S p) = q + S r -> r < 2^p ->
 let s := log2_iter k p q r in
 2^s <= k + q < 2^(S s).
Proof.
 induction k.
 - (* k = 0 *)
   intros p q r EQ LT. simpl log2_iter. cbv zeta.
   split.
   + rewrite add_0_l.
     rewrite (add_le_mono_l _ _ (2^p)).
     simpl pow in EQ. rewrite add_0_r in EQ. rewrite EQ.
     rewrite add_comm. apply add_le_mono_r. apply LT.
   + rewrite EQ, add_comm. apply add_lt_mono_l.
     apply lt_succ_r, le_0_l.
 - (* k = S k' *)
   intros p q r EQ LT. destruct r.
   + (* r = 0 *)
     rewrite add_succ_r, add_0_r in EQ.
     rewrite add_succ_l, <- add_succ_r. apply IHk.
     * rewrite <- EQ. remember (S p) as p'; simpl. now rewrite add_0_r.
     * rewrite EQ. constructor.
   + (* r = S r' *)
     rewrite add_succ_l, <- add_succ_r. apply IHk.
     * now rewrite add_succ_l, <- add_succ_r.
     * apply le_lt_trans with (S r); trivial. do 2 constructor.
Qed.

Lemma log2_spec n : 0<n ->
 2^(log2 n) <= n < 2^(S (log2 n)).
Proof.
 intros.
 set (s:=log2 n).
 replace n with (pred n + 1).
 apply log2_iter_spec; auto.
 rewrite add_1_r.
 apply succ_pred. now apply neq_sym, lt_neq.
Qed.

Lemma log2_nonpos n : n<=0 -> log2 n = 0.
Proof.
 inversion 1; now subst.
Qed.

(** ** Gcd *)

Definition divide x y := exists z, y=z*x.
Notation "( x | y )" := (divide x y) (at level 0) : nat_scope.

Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b).
Proof.
 fix 1.
 intros [|a] b; simpl.
 split.
  now exists 0.
  exists 1. simpl. now rewrite <- plus_n_O.
 fold (b mod (S a)).
 destruct (gcd_divide (b mod (S a)) (S a)) as (H,H').
 set (a':=S a) in *.
 split; auto.
 rewrite (div_mod b a') at 2 by discriminate.
 destruct H as (u,Hu), H' as (v,Hv).
 rewrite mul_comm.
 exists ((b/a')*v + u).
 rewrite mul_add_distr_r.
 now rewrite <- mul_assoc, <- Hv, <- Hu.
Qed.

Lemma gcd_divide_l : forall a b, (gcd a b | a).
Proof.
 intros. apply gcd_divide.
Qed.

Lemma gcd_divide_r : forall a b, (gcd a b | b).
Proof.
 intros. apply gcd_divide.
Qed.

Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b).
Proof.
 fix 1.
 intros [|a] b; simpl; auto.
 fold (b mod (S a)).
 intros c H H'. apply gcd_greatest; auto.
 set (a':=S a) in *.
 rewrite (div_mod b a') in H' by discriminate.
 destruct H as (u,Hu), H' as (v,Hv).
 exists (v - (b/a')*u).
 rewrite mul_comm in Hv.
 rewrite mul_sub_distr_r, <- Hv, <- mul_assoc, <-Hu.
 now rewrite add_comm, add_sub.
Qed.

Lemma gcd_nonneg a b : 0<=gcd a b.
Proof. apply le_0_l. Qed.

(** ** Bitwise operations *)

Lemma div2_double n : div2 (2*n) = n.
Proof.
 induction n; trivial.
 simpl mul. rewrite add_succ_r. simpl. now f_equal.
Qed.

Lemma div2_succ_double n : div2 (S (2*n)) = n.
Proof.
 induction n; trivial.
 simpl. f_equal. now rewrite add_succ_r.
Qed.

Lemma le_div2 n : div2 (S n) <= n.
Proof.
 revert n.
 fix 1.
 destruct n; simpl; trivial. apply lt_succ_r.
 destruct n; [simpl|]; trivial. now constructor.
Qed.

Lemma lt_div2 n : 0 < n -> div2 n < n.
Proof.
 destruct n.
 - inversion 1.
 - intros _. apply lt_succ_r, le_div2.
Qed.

Lemma div2_decr a n : a <= S n -> div2 a <= n.
Proof.
 destruct a; intros H.
 - simpl. apply le_0_l.
 - apply succ_le_mono in H.
   apply le_trans with a; [ apply le_div2 | trivial ].
Qed.

Lemma double_twice : forall n, double n = 2*n.
Proof.
 simpl; intros. now rewrite add_0_r.
Qed.

Lemma testbit_0_l : forall n, testbit 0 n = false.
Proof.
 now induction n.
Qed.

Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true.
Proof.
 unfold testbit. rewrite odd_spec. now exists a.
Qed.

Lemma testbit_even_0 a : testbit (2*a) 0 = false.
Proof.
 unfold testbit, odd. rewrite (proj2 (even_spec _)); trivial.
 now exists a.
Qed.

Lemma testbit_odd_succ' a n : testbit (2*a+1) (S n) = testbit a n.
Proof.
 unfold testbit; fold testbit.
 rewrite add_1_r. f_equal.
 apply div2_succ_double.
Qed.

Lemma testbit_even_succ' a n : testbit (2*a) (S n) = testbit a n.
Proof.
 unfold testbit; fold testbit. f_equal. apply div2_double.
Qed.

Lemma shiftr_specif : forall a n m,
 testbit (shiftr a n) m = testbit a (m+n).
Proof.
 induction n; intros m. trivial.
 now rewrite add_0_r.
 now rewrite add_succ_r, <- add_succ_l, <- IHn.
Qed.

Lemma shiftl_specif_high : forall a n m, n<=m ->
 testbit (shiftl a n) m = testbit a (m-n).
Proof.
 induction n; intros m H. trivial.
 now rewrite sub_0_r.
 destruct m. inversion H.
 simpl. apply succ_le_mono in H.
 change (shiftl a (S n)) with (double (shiftl a n)).
 rewrite double_twice, div2_double. now apply IHn.
Qed.

Lemma shiftl_spec_low : forall a n m, m<n ->
 testbit (shiftl a n) m = false.
Proof.
 induction n; intros m H. inversion H.
 change (shiftl a (S n)) with (double (shiftl a n)).
 destruct m; simpl.
 unfold odd. apply negb_false_iff.
 apply even_spec. exists (shiftl a n). apply double_twice.
 rewrite double_twice, div2_double. apply IHn.
 now apply succ_le_mono.
Qed.

Lemma div2_bitwise : forall op n a b,
 div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b).
Proof.
 intros. unfold bitwise; fold bitwise.
 destruct (op (odd a) (odd b)).
 now rewrite div2_succ_double.
 now rewrite add_0_l, div2_double.
Qed.

Lemma odd_bitwise : forall op n a b,
 odd (bitwise op (S n) a b) = op (odd a) (odd b).
Proof.
 intros. unfold bitwise; fold bitwise.
 destruct (op (odd a) (odd b)).
 apply odd_spec. rewrite add_comm. eexists; eauto.
 unfold odd. apply negb_false_iff. apply even_spec.
 rewrite add_0_l; eexists; eauto.
Qed.

Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) ->
 forall n m a b, a<=n ->
 testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
Proof.
 intros op Hop.
 induction n; intros m a b Ha.
 simpl. inversion Ha; subst. now rewrite testbit_0_l.
 destruct m.
 apply odd_bitwise.
 unfold testbit; fold testbit. rewrite div2_bitwise.
 apply IHn. now apply div2_decr.
Qed.

Lemma testbit_bitwise_2 : forall op, op false false = false ->
 forall n m a b, a<=n -> b<=n ->
 testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
Proof.
 intros op Hop.
 induction n; intros m a b Ha Hb.
 simpl. inversion Ha; inversion Hb; subst. now rewrite testbit_0_l.
 destruct m.
 apply odd_bitwise.
 unfold testbit; fold testbit. rewrite div2_bitwise.
 apply IHn; now apply div2_decr.
Qed.

Lemma land_spec a b n :
 testbit (land a b) n = testbit a n && testbit b n.
Proof.
 unfold land. apply testbit_bitwise_1; trivial.
Qed.

Lemma ldiff_spec a b n :
 testbit (ldiff a b) n = testbit a n && negb (testbit b n).
Proof.
 unfold ldiff. apply testbit_bitwise_1; trivial.
Qed.

Lemma lor_spec a b n :
 testbit (lor a b) n = testbit a n || testbit b n.
Proof.
 unfold lor. apply testbit_bitwise_2.
 - trivial.
 - destruct (compare_spec a b).
   + rewrite max_l; subst; trivial.
   + apply lt_le_incl in H. now rewrite max_r.
   + apply lt_le_incl in H. now rewrite max_l.
 - destruct (compare_spec a b).
   + rewrite max_r; subst; trivial.
   + apply lt_le_incl in H. now rewrite max_r.
   + apply lt_le_incl in H. now rewrite max_l.
Qed.

Lemma lxor_spec a b n :
 testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
Proof.
 unfold lxor. apply testbit_bitwise_2.
 - trivial.
 - destruct (compare_spec a b).
   + rewrite max_l; subst; trivial.
   + apply lt_le_incl in H. now rewrite max_r.
   + apply lt_le_incl in H. now rewrite max_l.
 - destruct (compare_spec a b).
   + rewrite max_r; subst; trivial.
   + apply lt_le_incl in H. now rewrite max_r.
   + apply lt_le_incl in H. now rewrite max_l.
Qed.

Lemma div2_spec a : div2 a = shiftr a 1.
Proof.
 reflexivity.
Qed.

(** Aliases with extra dummy hypothesis, to fulfil the interface *)

Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ' a n.
Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ' a n.
Lemma testbit_neg_r a n (H:n<0) : testbit a n = false.
Proof. inversion H. Qed.

Definition shiftl_spec_high a n m (_:0<=m) := shiftl_specif_high a n m.
Definition shiftr_spec a n m (_:0<=m) := shiftr_specif a n m.

(** Properties of advanced functions (pow, sqrt, log2, ...) *)

Include NExtraProp.

End Nat.

(** Re-export notations that should be available even when
    the [Nat] module is not imported. *)

Bind Scope nat_scope with Nat.t nat.

Infix "^" := Nat.pow : nat_scope.
Infix "=?" := Nat.eqb (at level 70) : nat_scope.
Infix "<=?" := Nat.leb (at level 70) : nat_scope.
Infix "<?" := Nat.ltb (at level 70) : nat_scope.
Infix "?=" := Nat.compare (at level 70) : nat_scope.
Infix "/" := Nat.div : nat_scope.
Infix "mod" := Nat.modulo (at level 40, no associativity) : nat_scope.

Hint Unfold Nat.le : core.
Hint Unfold Nat.lt : core.

(** [Nat] contains an [order] tactic for natural numbers *)

(** Note that [Nat.order] is domain-agnostic: it will not prove
    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)

Section TestOrder.
 Let test : forall x y, x<=y -> y<=x -> x=y.
 Proof.
 Nat.order.
 Qed.
End TestOrder.


Require Export P01.

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are values (i.e., not stuck). *)

(** **** Exercise: 3 stars (finish_progress)  *)
(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the informal proof fragment in the following
    exercise before starting -- this will save you a lot of time.) *)

Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t ==> t'.
Proof with auto.
  intros t T HT.
  induction HT...
  (* The cases that were obviously values, like T_True and
     T_False, were eliminated immediately by auto *)
  - (* T_If *)
    right. inversion IHHT1; clear IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2...
      exists t3...
    + (* t1 can take a step *)
      inversion H as [t1' H1].
      exists (tif t1' t2 t3)...
  - (* T_Succ *)
    exact FILL_IN_HERE.
  - (* T_Pred *)
    exact FILL_IN_HERE.
  - (* T_Iszero *)
    exact FILL_IN_HERE.
Qed.