From Coq Require Import Arith ZArith Psatz Bool String List Program.Equality.
Require Import Sequences IMP.
Import ListNotations.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope list_scope.

(** The target language: a stack machine *)

(** Instruction set *)
Inductive instr : Type :=
  | Iconst (n: Z)           (** push the integer [n] *)
  | Ivar (x: ident)         (** push the current value of variable [x] *)
  | Isetvar (x: ident)      (** pop an integer and assign it to variable [x] *)
  | Iadd                    (** pop two integers, push their sum *)
  | Iopp                    (** pop one integer, push its opposite *)
  | Ibranch (d: Z)          (** skip forward or backward [d] instructions *)
  | Ibeq (d1: Z) (d0: Z)    (** pop two integers, skip [d1] instructions if equal, [d0] if not equal *)
  | Ible (d1: Z) (d0: Z)    (** pop two integer, skip [d1] instructions if less or equal, [d0] if greater *)
  | Iinput                  (** read input and push it *)
  | Ioutput                 (** pop an integer and output it *)
  | Ihalt.                  (** stop execution *)

Definition code := list instr.

Definition codelen (c: code) : Z := Z.of_nat (List.length c).

(** Operational semantics *)

Definition stack : Type := list Z.

(** [instr_at C pc = Some i] if [i] is the instruction at position [pc] in [C]. *)
Fixpoint instr_at (C: code) (pc: Z) : option instr :=
  match C with
  | nil => None
  | i :: C' => if pc =? 0 then Some i else instr_at C' (pc - 1)
  end.

(** The compilation scheme *)

(** The code for an arithmetic expression [a] executes in sequence (no branches),
  and deposits the value of [a] at the top of the stack.
  This is the familiar translation to "reverse Polish notation".
  The only twist here is that the machine has no "subtract" instruction.
  However, it can compute the difference [a - b] by adding [a] and the opposite of [b].
*)

Fixpoint compile_aexp (a: aexp) : code :=
  match a with
  | CONST n => Iconst n :: nil
  | VAR x => Ivar x :: nil
  | PLUS a1 a2  => compile_aexp a1 ++ compile_aexp a2 ++ Iadd :: nil
  | MINUS a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Iopp :: Iadd :: nil
  end.

(** For Boolean expressions [b], we could produce code that deposits [1] or [0]
  at the top of the stack, depending on whether [b] is true or false.
  The compiled code for [IFTHENELSE] and [WHILE] commands would, then,
  compare this 0/1 value against 0 and branch to the appropriate piece of code.

  However, it is simpler and more efficient to compile a Boolean expression [b]
  to a piece of code that directly jumps [d1] or [d0] instructions forward,
  depending on whether [b] is true or false.  The actual value of [b] is
  never computed as an integer, and the stack is unchanged.
*)

Fixpoint compile_bexp (b: bexp) (d1: Z) (d0: Z) : code :=
  match b with
  | TRUE => if d1 =? 0 then nil else Ibranch d1 :: nil
  | FALSE => if d0 =? 0 then nil else Ibranch d0 :: nil
  | EQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Ibeq d1 d0 :: nil
  | LESSEQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Ible d1 d0 :: nil
  | NOT b1 => compile_bexp b1 d0 d1
  | AND b1 b2 =>
      let code2 := compile_bexp b2 d1 d0 in
      let code1 := compile_bexp b1 0 (codelen code2 + d0) in
      code1 ++ code2
  end.

(** See the slides for an explanation of the mysterious offsets in the [AND] case. *)

(** The code for a command [c]:
  - updates the store (the values of variables) as prescribed by [c]
  - preserves the stack
  - finishes "at the end" of the generated code: the next instruction
    executed is the instruction that will follow the generated code.
  Again, see the slides for explanations of the generated branch offsets.
*)

Fixpoint compile_com (c: com) : code :=
  match c with
  | SKIP =>
      nil
  | ASSIGN x a =>
      compile_aexp a ++ Isetvar x :: nil
  | SEQ c1 c2 =>
      compile_com c1 ++ compile_com c2
  | IFTHENELSE b ifso ifnot =>
      let code_ifso := compile_com ifso in
      let code_ifnot := compile_com ifnot in
      compile_bexp b 0 (codelen code_ifso + 1)
      ++ code_ifso
      ++ Ibranch (codelen code_ifnot)
      :: code_ifnot
  | WHILE b body =>
      let code_body := compile_com body in
      let code_test := compile_bexp b 0 (codelen code_body + 1) in
      code_test
      ++ code_body
      ++ Ibranch (- (codelen code_test + codelen code_body + 1)) :: nil
  | INPUT x =>
      Iinput :: Isetvar x :: nil
  | OUTPUT a =>
      compile_aexp a ++ Ioutput :: nil
  end.

(** The code for a program [p] (a command) is similar, but terminates
  cleanly on an [Ihalt] instruction. *)

Definition compile_program (p: com) : code :=
  compile_com p ++ Ihalt :: nil.

(** Defining the relation between IMP states and stack machine states. *)
Inductive code_at: code -> Z -> code -> Prop :=
  | code_at_intro: forall C1 C2 C3 pc,
      pc = codelen C1 ->
      code_at (C1 ++ C2 ++ C3) pc C2.

Inductive compile_cont (C: code): cont -> Z -> Prop :=
  | ccont_stop: forall pc,
      instr_at C pc = Some Ihalt ->
      compile_cont C Kstop pc
  | ccont_seq: forall c k pc pc',
      code_at C pc (compile_com c) ->
      pc' = pc + codelen (compile_com c) ->
      compile_cont C k pc' ->
      compile_cont C (Kseq c k) pc
  | ccont_while: forall b c k pc d pc' pc'',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      code_at C pc' (compile_com (WHILE b c)) ->
      pc'' = pc' + codelen (compile_com (WHILE b c)) ->
      compile_cont C k pc'' ->
      compile_cont C (Kwhile b c k) pc
  | ccont_branch: forall d k pc pc',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      compile_cont C k pc' ->
      compile_cont C k pc.

Lemma codelen_cons:
  forall i c, codelen (i :: c) = codelen c + 1.
Proof.
  unfold codelen; intros; cbn; lia.
Qed.

Lemma codelen_app:
  forall c1 c2, codelen (c1 ++ c2) = codelen c1 + codelen c2.
Proof.
  induction c1; intros.
- auto.
- cbn [app]. rewrite ! codelen_cons. rewrite IHc1. lia.
Qed.

Lemma instr_at_app:
  forall i c2 c1 pc,
  pc = codelen c1 ->
  instr_at (c1 ++ i :: c2) pc = Some i.
Proof.
  induction c1; simpl; intros; subst pc.
- auto.
- assert (A: codelen (a :: c1) =? 0 = false).
  { apply Z.eqb_neq. unfold codelen. cbn [length]. lia. }
  rewrite A. rewrite codelen_cons. apply IHc1. lia.
Qed.

Lemma code_at_head:
  forall C pc i C',
  code_at C pc (i :: C') ->
  instr_at C pc = Some i.
Proof.
  intros. inversion H. simpl. apply instr_at_app. auto.
Qed.

Lemma code_at_tail:
  forall C pc i C',
  code_at C pc (i :: C') ->
  code_at C (pc + 1) C'.
Proof.
  intros. inversion H.
  change (C1 ++ (i :: C') ++ C3)
    with (C1 ++ (i :: nil) ++ C' ++ C3).
  rewrite <- app_ass. constructor. rewrite codelen_app. subst pc. auto.
Qed.

Lemma code_at_app_left:
  forall C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C pc C1.
Proof.
  intros. inversion H. rewrite app_ass. constructor. auto.
Qed.

Lemma code_at_app_right:
  forall C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C (pc + codelen C1) C2.
Proof.
  intros. inversion H. rewrite app_ass. rewrite <- app_ass. constructor. rewrite codelen_app. subst pc. auto.
Qed.

Lemma code_at_app_right2:
  forall C pc C1 C2 C3,
  code_at C pc (C1 ++ C2 ++ C3) ->
  code_at C (pc + codelen C1) C2.
Proof.
  intros. apply code_at_app_right. apply code_at_app_left with (C2 := C3). rewrite app_ass; auto.
Qed.

Lemma code_at_nil:
  forall C pc C1,
  code_at C pc C1 -> code_at C pc nil.
Proof.
  intros. inversion H. subst. change (C1 ++ C3) with (nil ++ C1 ++ C3).
  constructor. auto.
Qed.

Lemma instr_at_code_at_nil:
  forall C pc i, instr_at C pc = Some i -> code_at C pc nil.
Proof.
  induction C; cbn; intros.
- discriminate.
- destruct (pc =? 0) eqn:PC.
+ assert (pc = 0) by (apply Z.eqb_eq; auto). subst pc.
  change (a :: C) with (nil ++ nil ++ (a :: C)). constructor. auto.
+ assert (A: code_at C (pc - 1) nil) by eauto.
  inversion A; subst.
  apply code_at_intro with (C1 := a :: C1) (C3 := C3). rewrite codelen_cons. lia.
Qed.

Global Hint Resolve code_at_head code_at_tail code_at_app_left code_at_app_right
      code_at_app_right2 code_at_nil instr_at_code_at_nil: code.
Hint Rewrite codelen_app codelen_cons Z.add_assoc Z.add_0_r : code.


(** * Proof by reflection **)

(** The idea of proof by reflection is to prove a class of theorems using
certified decision procedures, that is, Coq functions that have a theorem
showing their correctness. *)

(** ** Overview **)

(** Reflection applies to small, self-contained cases of using decision
procedures. However, in practice, the most common way to use reflection is both
more involved and follows a common structure:
- 1. Write down the syntax of the expressions you want to prove something about,
  say in an inductive type [term].
- 2. Interpret the terms back into what they represent, say [denote : term -> A].
  The type [A] might be a different expression or directly a [Prop].
- 3. Implement some procedure over terms; maybe [simplifier: term -> term] or
  [check: term -> bool].
- 4. Prove a soundness property of this procedure over what the terms denote,
  maybe [forall t, equivalent t (simplifier t)] or [forall t, check t = true -> denote t].
- 5. Reify the target language [A] into [term]. Typically this is implemented in
  Ltac since we need to turn calls like [add x y] into a constructor, which can't
  be implemented in Gallina.

This step is occasionally called "reflection", though "reification" is a clearer
term since "relection" can refer to the whole approach or just the use of a
certified decision procedure.

Now, given a goal that uses the target language (here values of type [A]), the
user can use reification to produce a term [t], then apply the soundness
property to get some proof about [denote t], which after simplification will be
a proof about some [a:A] that appears in the goal. *)

(** ** A motivating example **)

(** The best way to understand proof by reflection is to look at an example.
We'll use reflection to normalize an addition expression. *)

Require Import Coq.Arith.PeanoNat.

Inductive term :=
| Const (n:nat)
| Add (e1 e2:term).

Fixpoint denote (t:term) : nat :=
  match t with
  | Const n => n
  | Add e1 e2 => denote e1 + denote e2
  end.

Fixpoint flatten (x0:term) (t:term) : term :=
  match t with
  | Const n => Add x0 (Const n)
  | Add e1 e2 => flatten (flatten x0 e1) e2
  end.

Eval cbn [denote flatten] in
    fun x y z w => denote (flatten (Const 0)
                                (Add (Add (Const x) (Const y))
                                     (Add (Const z) (Const w)))).

(* the property we'll prove is that flattening does not change the denotation of
a term; to do so we need to first prove a more general property to get the
induction to go through *)

Theorem flatten_sound_general t : forall x,
  denote (flatten x t) = denote x + denote t.
Proof.
  induction t; simpl; intros; auto.
  rewrite IHt2, IHt1.
  rewrite Nat.add_assoc; auto.
Qed.

Theorem flatten_sound t :
  denote t = denote (flatten (Const 0) t).
Proof.
  rewrite flatten_sound_general; simpl; auto.
Qed.

Ltac reify e :=
  match e with
  | ?x + ?y =>
    let r_x := reify x in
    let r_y := reify y in
    constr:(Add r_x r_y)
  | _ => constr:(Const e)
  end.

Theorem demo x y z :
  x + (y + z) = x + y + z.
Proof.
  match goal with
  | |- ?e = ?e' => let t := reify e in
                 let t' := reify e' in
                 change (denote t = denote t')
  end.
  match goal with
  | |- denote ?t = denote ?t' =>
    rewrite (flatten_sound t), (flatten_sound t')
  end.
  (* this is where the magic becomes apparent: the soundness theorem applies to
  any term, but flatten computes to a particular expression when applied to
  these concrete terms *)
  cbn [denote flatten].
  reflexivity.
Qed.

(* we can wrap up the process of simplifying expressions in a tactic *)
Ltac canonical_assoc e :=
  let t := reify e in
  change e with (denote t);
  rewrite (flatten_sound t);
  cbn [denote flatten].

Theorem larger_demo x y z w :
  x + (y + z + w) + x + (y + z) =
  x + (y + z) + (w + (x + y)) + z.
Proof.
  match goal with
  | |- ?e = ?e' => canonical_assoc e;
                   canonical_assoc e'
  end.
  reflexivity.
Qed.

(** ** Why use reflection? **)

(** Reflection offers a number of benefits.

I think the most important aspect of reflection is robustness. A reflective
tactic defines an explicit syntax for the goals it handles and then implements
the rest of the work in a certified decision procedure. Now instead of reasoning
about what some Ltac procedure might do, you can just focus on what the
soundness theorem says. In some cases the certified procedure is partial (that
is, it might fail and not prove anything); in these cases you might also want to
check to see where it fails.

*)

(** ** A more abstract introduction **)

(** Computational reflection is a technique for proving theorems using
computation in the meta-language (that is, computation in Coq), as opposed to
building a proof term using only logical rules (eg, constructors in an inductive
type).

It relies on the conversion rule of dependent theory:

<<
x : A    A ≡ B
------------- conv
    x : B
>>

The judgement A ≡ B is where the magic happens: in dependent type theory, this
equivalence allows _computation_, and so this rule is what allows type-checking
to simplify computations appearing in types. *)

(** For example, we can write the following in Coq: *)
Definition bool_or_nat : bool :=
  (fun x => match x return (if x then bool else nat) with
         | true => x
         | false => 0
         end) true.

(** the type of the right-hand side is [if true then bool else nat], but Coq
simplifies this expression and can also give it the type bool *)

(** Recall that Coq propositions are types and the proof of a proposition P is a
term (pf:P) (this is the Curry-Howard isomorphism). In that light, we can use
the conv rule with theorem statements that are computed. This is what proof by
reflection is.

 I believe the "reflection" is reflection of the desired proof into the
 computation, but I must confess I'm not sure what the original intention is and
 it's possible the writing on proof by reflection has gotten confused over time.
 *)


Require Export ssreflect ssrfun.
Require Import Logic.ProofIrrelevance Logic.FunctionalExtensionality Logic.PropExtensionality.

Export EqNotations.

Set Bullet Behavior "Strict Subproofs".
Set Primitive Projections.
Set Universe Polymorphism.

Notation prfE := proof_irrelevance.
Notation funE := (functional_extensionality _ _).
Notation dfunE := functional_extensionality_dep.
Notation propE := propositional_extensionality.

Lemma unfunE {A B : Type} (f g : A -> B) : f = g -> forall x, f x = g x.
Proof. by move=> ->. Qed.

Global Hint Resolve prfE : core.

Ltac build := unshelve esplit=>//=.

Scheme eq_ind := Induction for eq Sort Type.
Arguments eq_ind [A] x P f y e.

Record sig (A : Type) (B : A -> Type) : Type :=
  Sig {pi1 : A; pi2 : B pi1}.

Arguments Sig [A] [B] pi1 pi2.
Arguments pi1 {A B} _ /.
Arguments pi2 {A B} _ /.

Definition sub (A : Type) (P : A -> Prop) : Type :=
  sig A P.

Set Warnings "-notation-overridden".
Notation "{ x : A & B }" := (sig A (fun x:A => B)) : type_scope.
Notation "{ x : A | B }" := (sub A (fun x:A => (B : Prop))) : type_scope.
Notation "( x , y , .. , z )" := (Sig .. (Sig x y) .. z) : core_scope.
Set Warnings "default".

Definition prod (A B : Type) := {_:A & B}.
Infix "×" := prod (at level 60).

Definition pair {A B} (a : A) (b : B) : A × B :=
  Sig a b.

Lemma sigE {A} {B : A -> Type} : forall (p q : {x : A & B x}) (u : pi1 p = pi1 q) (v : rew u in pi2 p = pi2 q), p = q.
Proof.
  move=> [a +] [x +] //= h; move: x h.
  by apply: eq_ind=> b1 b2//= ->.
Qed.

Lemma subE {A} {P : A -> Prop} : forall (p q : {x : A | P x}), pi1 p = pi1 q -> p = q.
Proof. by move=>???; apply: sigE. Qed.

Lemma prodE {A B} : forall (p q : A × B), pi1 p = pi1 q -> pi2 p = pi2 q -> p = q.
Proof.
  move=> [a1 +] [a2 +] //= h; move: a2 h.
  by apply: eq_ind=> b1 b2 ->.
Qed.

Record iso (A B : Type) :=
  {fwd : A -> B;
   bwd : B -> A;
   fwd_bwd : forall x, fwd (bwd x) = x;
   bwd_fwd : forall x, bwd (fwd x) = x}.

Arguments fwd [_] [_] _.
Arguments bwd [_] [_] _.
Arguments bwd_fwd [_] [_] _.
Arguments fwd_bwd [_] [_] _.

Infix "≅" := iso (at level 100).

Lemma push_iso {A B C} (α : A ≅ B) : (forall x : A, C (fwd α x)) -> forall x : B, C x.
Proof.
  move=> H x.
  by rewrite -[x](fwd_bwd α).
Defined.

Definition iso_fun {A A' B B'} (α : A ≅ A') (β : B ≅ B') : (A -> B) ≅ (A' -> B').
Proof.
  unshelve esplit.
  - by move=> f x; apply/(fwd β)/f/(bwd α)/x.
  - by move=> f x; apply/(bwd β)/f/(fwd α)/x.
  - abstract (by move=> f; apply: funE => ?; rewrite ? fwd_bwd).
  - abstract (by move=> f; apply: funE => ?; rewrite ? bwd_fwd).
Defined.

Definition iso_trans {A B C} (α : A ≅ B) (β : B ≅ C) : A ≅ C.
Proof.
  build.
  - move=> x; apply/(fwd β)/(fwd α)/x.
  - move=> x; apply/(bwd α)/(bwd β)/x.
  - abstract (by move=> f /=; rewrite ? fwd_bwd).
  - abstract (by move=> f /=; rewrite ? bwd_fwd).
Defined.

Definition iso_id {A} : A ≅ A.
Proof. build; by []. Defined.

Class Connective (A A' : Type) :=
  {conn_def : A' ≅ A}.

#[export] Hint Mode Connective + - : core.

Section Rules.
  Context {A A'} `{Connective A A'}.
  Definition intro : A' -> A := fwd conn_def.
  Definition elim : A -> A' := bwd conn_def.
  Definition beta : forall x, elim (intro x) = x := bwd_fwd conn_def.
  Definition eta : forall x, intro (elim x) = x := fwd_bwd conn_def.
End Rules.

Lemma push_conn {A B C} `{Connective B A} : (forall x : A, C (intro x)) -> forall x : B, C x.
Proof.
  move=> K x.
  by rewrite -[x](@eta B A).
Defined.


Set Warnings "-notation-overridden,-parsing".
From LF Require Import Maps.
From LF Require Import Imp.

Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - reflexivity.
  - reflexivity.
  -
    assert (st' = st'0) as EQ1.
    { apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  -
    apply IHE1. assumption.
  -
    rewrite H in H5. inversion H5.
  -
    rewrite H in H5. inversion H5.
  -
    apply IHE1. assumption.
  -
    reflexivity.
  -
    rewrite H in H2. inversion H2.
  -
    rewrite H in H4. inversion H4.
  -
    assert (st' = st'0) as EQ1.
    { apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption. Qed.

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  auto.
  auto 6.
Qed.

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto. Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto. Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof. auto. Qed.

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  -
    +
      rewrite H in H5. inversion H5.
  -
    +
      rewrite H in H5. inversion H5.
  -
    +
      rewrite H in H2. inversion H2.
  -
    rewrite H in H4. inversion H4.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

Theorem ceval_deterministic'_alt: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
           intros st2 E2; inv E2...
  -
    assert (st' = st'0) as EQ1...
    subst st'0...
  -
    +
      rewrite H in H5. inversion H5.
  -
    +
      rewrite H in H5. inversion H5.
  -
    +
      rewrite H in H2. inversion H2.
  -
    rewrite H in H4. inversion H4.
  -
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  -
    +
      rwinv H H5.
  -
    +
      rwinv H H5.
  -
    +
      rwinv H H2.
  -
    rwinv H H4.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwinv H1 H2
  end.

Theorem ceval_deterministic''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  -
    +
      assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

Theorem ceval_deterministic'''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  -
    rewrite (IHE1_1 st'0 H1) in *. auto.
  -
    +
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

Theorem ceval_deterministic''''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

Module Repeat.

Inductive com : Type :=
  | CSkip
  | CAsgn (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com)
  | CRepeat (c : com) (b : bexp).

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.

Notation "st '=[' c ']=>' st'" := (ceval st c st')
                                 (at level 40).

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  -
    +
       find_rwinv.
  -
     +
        find_rwinv.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.

End Repeat.

Example ceval_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  apply E_Seq with (X !-> 2).
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

Example ceval'_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  eapply E_Seq.   - apply E_Ass.     reflexivity.   - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := (Y !-> 2 ; X !-> 1).
Definition st21 := (Y !-> 1 ; X !-> 2).

Example eauto_example : exists s',
  st21 =[
    TEST X <= Y
      THEN Z ::= Y - X
      ELSE Y ::= X + Z
    FI
  ]=> s'.
Proof. eauto. Qed.


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

Require Import ssreflect.
Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.
Require Import FunctionalExtensionality.
Set Automatic Coercions Import.
Require Import relations.

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

Section Functional.
Variable n : nat.
Variable A : 'I_n -> Set.
Variable B : 'I_n -> Set.
Variable C : Set.

Definition FuncType : Type :=
  forall (T : monadType), nProd (fun i => A i -> T (B i)) -> T C.
End Functional.

Section Purity.
Variable n : nat.
Variable A : 'I_n -> Set.
Variable B : 'I_n -> Set.
Variable C : Set.

Definition isPure (F : FuncType A B C) : Prop
  := forall (T T' : monadType) (TRacc : TRaccType T T'),
       (nProdR (fun i =>
         IdR (X := A i) =R=> (TR TRacc) _ _ (IdR (X := B i))) =R=>
          (TR TRacc) _ _ (IdR (X := C))) (F T) (F T').
End Purity.

Section Strategy.
Variable n : nat.
Variable A : 'I_n -> Set.
Variable B : 'I_n -> Set.
Variable C : Set.

Inductive Tree :=
  | Ans : C -> Tree
  | Que : forall i, A i -> (B i -> Tree) -> Tree.

Definition fun2tree (F : FuncType A B C)
  := F (Cont Tree) (tuple Que) Ans.

Fixpoint tree2funT (T : monadType) (t : Tree) :=
  match t with
    | Ans c => fun _ => @tval T _ c
    | Que i a f =>
        fun (k : nProd (fun i => A i -> T (B i))) =>
          tbind ((proj i k) a) (fun b => tree2funT T (f b) k)
  end.

Definition tree2fun (t : Tree) : FuncType A B C.
move => T. by refine (tree2funT t).
Defined.

Lemma tree2fun_simpl (t : Tree) (T : monadType) :
  @tree2fun t T = tree2funT t.
Proof.
by rewrite /tree2fun.
Qed.

Lemma tree2fun_pure (t : Tree) : isPure (@tree2fun t).
Proof.
rewrite /isPure.
elim: t => [ | i a f Hind].
- rewrite /ArrR. by intuition; apply TRacc.
- rewrite /ArrR /=. rewrite /ArrR /= in Hind.
  move => T T' TRacc k k' H /=.
  have Htmp := nProdR_elim H i.
  eapply (proj2 (Acc TRacc)); first by apply Htmp.
  rewrite /ArrR => b b' /=; elim. by apply: Hind.
Qed.

Lemma tree2fun2tree (t : Tree) : fun2tree (tree2fun t) = t.
Proof.
rewrite /fun2tree.
elim: t => [// | i a f Hind /=].
- f_equal. by apply: functional_extensionality.
Qed.

Section conversion.
Variable S : Type.
Variable q : nProd (fun i => A i -> (B i -> S) -> S).
Variable a : C -> S.

Definition conv (t : Tree) := @tree2funT (Cont S) t q a.

Definition TRacc1 : TRaccType (Cont Tree) (Cont S).
exists
  (fun X X' (R : Rel X X') => fun H H' =>
    forall h h', (R =R=> Gr conv) h h' -> Gr conv (H h) (H' h')).
split.
- by move => /=; intuition.
- move => X X' Y Y' Q R f f' t t' H H0.
  move => h h' Hhh'. apply: H => x x' Hxx'. by firstorder.
Defined.
End conversion.

Lemma fun2tree2fun_Cont S (F : FuncType A B C) (Hpure : isPure F) :
  @tree2funT (Cont S) (fun2tree F) = F (Cont S).
Proof.
extensionality q.
extensionality a.
suff H : Gr (conv q a) (F (Cont Tree) (tuple Que) Ans) (F (Cont S) q a); first by elim H.
have H := @Hpure _ _ (TRacc1 q a) => {Hpure}.
apply: H.
- elim: q => q i.
  move => a1 a1' /=; elim.
  move => h h' Hhh'.
  rewrite /Gr /conv /=.
  f_equal. extensionality b. by firstorder.
- by move => c c'; elim.
Qed.

Definition Phi (T : monadType)
               (F : nProd (fun i => A i -> Cont (T C) (B i)) -> Cont (T C) C)
  : nProd (fun i => A i -> T (B i)) -> T C.
elim => h.
by refine (F (tuple (fun i => (@tbind _ _ _) \o h i)) (@tval _ _)).
Defined.

Definition TRacc2 (T : monadType) : TRaccType (Cont (T C)) T.
exists
  (fun X X' (R : Rel X X') => fun H H' =>
    forall h h', (R =R=> @IdR (T C)) h h' ->
      (@IdR (T C) (H h) (tbind H' h'))).
split.
- move => X X' R x x' H h h' H1 /=. rewrite taxiom0. by intuition.
- move => X X' Y Y' Q R f f' t t' H H0.
  move => h h' Hhh'. rewrite taxiom2 //. apply: H => x x' Hxx'. by apply: H0.
Defined.

Lemma lem_Phi (T : monadType)
            (F : FuncType A B C) (Hpure : isPure F) :
  Phi (F (Cont (T C))) = F T.
Proof.
apply: functional_extensionality; case => g.
rewrite /Phi -[X in _ = X]taxiom1 /=.
have H := @Hpure _ _ (TRacc2 T) => {Hpure}.
apply: H.
- move => i a a'. elim. move => h h' Hhh'.
  suff Htmp: h = h'; first by rewrite Htmp.
  by extensionality x; apply: Hhh'.
- by move => c c'; elim.
Qed.

Theorem fun2tree2tree (F : FuncType A B C) (Hpure : isPure F) :
  forall (T : monadType), @tree2fun (fun2tree F) T = @F T.
Proof.
move => T.
rewrite -lem_Phi; last by apply: tree2fun_pure.
rewrite /tree2fun. rewrite fun2tree2fun_Cont //=.
by apply: lem_Phi.
Qed.

End Strategy.


Require Export Basics.

Require Export EnvListAux7.
Require Export EnvListAuxT1.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import Coq.Logic.ProofIrrelevance.

Require Import TPipStaticM2.
Require Import TPipDynamicM2.
Require Import TRInductM2.
Require Import WeakM2.
Require Import TSoundnessM2.
Require Import IdModType.

Module Hardware_bis (IdT: IdModType) <: IdModType.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Module TSoundnessC := TSoundness IdT.
Export TSoundnessC.

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

Definition HoareTriple_Step
           (P : W -> Prop) (Q : Exp -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (e': Exp),
    EStep fenv env (Conf Exp s e) (Conf Exp s' e') ->
    P s -> Q e' s'.

Definition HoareTriple_Eval
           (P : W -> Prop) (Q : Value -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)) ->
    P s -> Q v s'.

Definition hoareTriple_ExtendedStep
           (P : W -> Prop) (fenv: funEnv) (env: valEnv)
           (e: Exp) (Q : Exp -> W -> Prop) : Prop :=
  forall (s s': W) (e': Exp),
    EClosure fenv env (Conf Exp s e) (Conf Exp s' e') ->
    P s -> Q e' s'.

Notation "{{ P }} fenv >> env >> e {{ Q }}" := (hoareTriple_ExtendedStep P fenv env e Q)
(at level 90) : state_scope.

Open Scope state_scope.

Lemma conjProp (P R : W -> Prop) (Q : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
{{ P }} fenv >> env >> e  {{ Q }}
-> {{ R }} fenv >> env >> e {{fun _ => R}}
-> {{fun s => P s/\ R s}} fenv >> env >> e {{fun a s => Q a s/\ R s}}.
Proof.
intros H1 H2.
intros s s' e'.
intros H3 H4.
destruct H4 as [H4 H5].
split.
-unfold hoareTriple_ExtendedStep in H1.
 apply H1 in H3.
 assumption. assumption.
-unfold hoareTriple_ExtendedStep in H2.
 apply H2 in H3.
 assumption. assumption.
Qed.

Definition wp (P : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  W -> Prop := fun s => forall (e':Exp) (s': W),
       EClosure fenv env (Conf Exp s e) (Conf Exp s' e') -> P e' s'.

Lemma wpIsPrecondition (P : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  {{ wp P fenv env e }} fenv >> env >> e {{ P }}.
Proof.
unfold hoareTriple_ExtendedStep.
intros s s' e' H1 H2.
unfold wp in H2.
apply H2 in H1.
auto.
Qed.

Lemma wpIsWeakestPrecondition(P : Exp -> W -> Prop) (Q : W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  {{ Q }} fenv >> env >> e {{ P }} -> forall s, Q s -> (wp P fenv env e) s.
Proof.
intros H1 s H2.
unfold wp.
intros e' s' H3.
apply H1 in H3.
auto.
Qed.

Lemma postAnd :
forall (P : W -> Prop) (Q R : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
  {{ P }} fenv >> env >> e {{ Q }}
-> {{ P }} fenv >> env >> e {{ R }}
-> {{ P }} fenv >> env >> e {{ fun a s => Q a s /\ R a s }}.
Proof.
intros P Q R fenv env e H1 H2.
intros a s.
intros e' H3 H4.
split.
-unfold hoareTriple_ExtendedStep in H1.
 apply H1 in H3.
 assumption. assumption.
-apply H2 in H3.
 auto.
Qed.

Lemma preOr :
  forall (P Q : W -> Prop) (R : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
  {{ P }} fenv >> env >> e {{ R }}
-> {{ Q }} fenv >> env >> e {{ R }}
-> {{ fun s => P s \/ Q s }} fenv >> env >> e {{ R }}.
Proof.
intros P Q R fenv env e H1 H2 s.
intros s' e' H3 H4.
destruct H4.
-apply H1 in H3 .
 auto.
-apply H2 in H3.
 auto.
Qed.

Lemma preAndPost :
forall (P1 Q1 : W -> Prop) (P2  : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
{{P1}} fenv >> env >> e {{P2}} ->
{{fun s => P1 s /\ Q1 s}} fenv >> env >> e {{fun a => Q1 }} ->
{{fun s => P1 s /\ Q1 s}} fenv >> env >> e {{fun a s => P2 a s /\ Q1 s}}.
Proof.
intros P1 Q1 P2 fenv env e H1 H2 s s'.
intros e' H3 [H4 H5].
split.
-apply H1 in H3.
 auto.
-apply H2 in H3.
 apply H3.
 auto.
Qed.

Lemma andAssocHT  :
forall (P1 P2 P3 : W -> Prop) (R  : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
{{ fun s => (P1 s /\ P2 s) /\ P3 s }} fenv >> env >> e {{ R }}
<-> {{ fun s => P1 s /\ P2 s /\ P3 s }} fenv >> env >> e {{ R }}.
Proof.
intros P1 P2 P3 R fenv env e.
split.
-intro H.
 unfold hoareTriple_ExtendedStep.
 intros s s' e' H1 [H2 [H3 H4]].
 apply H in H1.
 apply H1.
 auto.
-intro s.
 unfold hoareTriple_ExtendedStep.
 intros s0 s' e' H1 [[H2 H3] H4].
 apply s in H1.
 auto.
Qed.

Lemma permutHT :
forall (P1 P2 P3 : W -> Prop) (R  : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
{{ fun s => P1 s /\ P2 s /\ P3 s }} fenv >> env >> e {{ R }}
<-> {{ fun s => P1 s /\ P3 s /\ P2 s }} fenv >> env >> e {{ R }}.
Proof.
intros P1 P2 P3 R fenv env e.
split.
-intro s.
 unfold hoareTriple_ExtendedStep.
 intros s0 s' e' H1 [H2 [H3 H4]].
 apply s in H1.
 auto.
-intro s.
 unfold hoareTriple_ExtendedStep.
 intros s0 s' e' H1 [H2 [H3 H4]].
 apply s in H1.
 auto.
Qed.
(*
split;
intro s;
unfold hoareTriple_ExtendedStep;
intros s0 s' e' H1 [H2 [H3 H4]];
apply s in H1;
auto.*)

Lemma preAnd:
 forall (P1 Q : W -> Prop) (P2  : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e: Exp),
{{P1}} fenv >> env >> e {{P2}}
-> {{fun s => P1 s /\ Q s}} fenv >> env >> e {{P2}}.
Proof.
intros P1 Q P2 fenv env e H s.
intros s' e' H1 [H2 H3].
apply H in H1.
apply H1.
auto.
Qed.

Lemma conjPrePost :
forall (P1 Q1 : W -> Prop) (P2 Q2 : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
{{P1}} fenv >> env >> e {{P2}} ->
{{Q1}} fenv >> env >> e {{Q2}} ->
{{fun s => P1 s /\ Q1 s}} fenv >> env >> e {{fun a s => P2 a s /\ Q2 a s}}.
Proof.
intros P1 Q1 P2 Q2 fenv env e H1 H2 s.
intros s' e' H3 [H4 H5].
split.
-apply H1 in H3.
 auto.
-apply H2 in H3.
 auto.
Qed.

End Hardware_bis.


(** * MSets.GenTree : maps via generic trees

    This module factorizes common parts in implementations
    of finite maps as AVL trees and as Red-Black trees. The nodes
    of the trees defined here include an generic information
    parameter, that will be the height in AVL trees and the color
    in Red-Black trees. Without more details here about these
    information parameters, trees here are not known to be
    well-balanced, but simply binary-search-trees.

    The operations we could define and prove correct here are the
    ones that do not modify the informations on the nodes :

     - empty is_empty
     - find mem
     - equal compare
     - fold cardinal bindings
     - map mapi
*)

From Coq Require Import Bool PeanoNat BinInt FunInd.
From Coq Require Import Orders OrdersFacts OrdersLists.
From Tries.MMaps Require Import Comparisons Interface OrdList.

Local Open Scope list_scope.
Local Open Scope lazy_bool_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(* For nicer extraction, we create induction principles
   only when needed *)
Local Unset Elimination Schemes.

Module PairNotations.
Notation "s #1" := (fst s) (at level 9, format "s '#1'").
Notation "s #2" := (snd s) (at level 9, format "s '#2'").
End PairNotations.

Module Type InfoTyp.
 Parameter t : Set.
End InfoTyp.

(** * Ops : the pure functions *)

Module Type Ops (K:OrderedType)(Info:InfoTyp).

Definition key := K.t.

Section Elt.

Variable elt : Type.

(** * Trees *)

Inductive tree  : Type :=
| Leaf : tree
| Node : Info.t -> tree -> K.t -> elt -> tree -> tree.

Definition t := tree.

(** ** The empty map and emptyness test *)

Definition empty := Leaf.

Definition is_empty t :=
 match t with
 | Leaf => true
 | _ => false
 end.

(** ** Membership test *)

(** The [mem] function is deciding membership. It exploits the
    binary search tree invariant to achieve logarithmic complexity. *)

Fixpoint mem x t :=
 match t with
 | Leaf => false
 | Node _ l k _ r =>
   match K.compare x k with
     | Lt => mem x l
     | Eq => true
     | Gt => mem x r
   end
 end.

Fixpoint find x m : option elt :=
  match m with
    |  Leaf => None
    |  Node _ l y v r =>
       match K.compare x y with
         | Eq => Some v
         | Lt => find x l
         | Gt => find x r
       end
   end.

(** ** Minimal, maximal, arbitrary bindings *)

Fixpoint min_binding (t : tree) : option (key * elt) :=
 match t with
 | Leaf => None
 | Node _ Leaf x e r => Some (x,e)
 | Node _ l x e r => min_binding l
 end.

Fixpoint max_binding (t : tree) : option (key * elt) :=
  match t with
  | Leaf => None
  | Node _ l x e Leaf => Some (x,e)
  | Node _ l x e r => max_binding r
  end.

Definition choose := min_binding.

(** ** Iteration on elements *)

Fixpoint fold {A: Type} (f: key -> elt -> A -> A) (t: tree) (base: A) : A :=
  match t with
  | Leaf => base
  | Node _ l x e r => fold f r (f x e (fold f l base))
 end.

Fixpoint bindings_aux acc s :=
  match s with
   | Leaf => acc
   | Node _ l x e r => bindings_aux ((x,e) :: bindings_aux acc r) l
  end.

Definition bindings := bindings_aux nil.

Fixpoint rev_bindings_aux acc s :=
  match s with
   | Leaf => acc
   | Node _ l x e r => rev_bindings_aux ((x,e) :: rev_bindings_aux acc l) r
  end.

Definition rev_bindings := rev_bindings_aux nil.

Fixpoint cardinal (s : tree) : nat :=
  match s with
   | Leaf => 0
   | Node _ l _ _ r => S (cardinal l + cardinal r)
  end.

Fixpoint maxdepth s :=
 match s with
 | Leaf => 0
 | Node _ l _ _ r => S (max (maxdepth l) (maxdepth r))
 end.

Fixpoint mindepth s :=
 match s with
 | Leaf => 0
 | Node _ l _ _ r => S (min (mindepth l) (mindepth r))
 end.

(** ** Testing universal or existential properties. *)

(** We do not use the standard boolean operators of Coq,
    but lazy ones. *)

Fixpoint for_all (f:key->elt->bool) s := match s with
  | Leaf => true
  | Node _ l x e r => f x e &&& for_all f l &&& for_all f r
end.

Fixpoint exists_ (f:key->elt->bool) s := match s with
  | Leaf => false
  | Node _ l x e r => f x e ||| exists_ f l ||| exists_ f r
end.

(** ** Comparison of trees *)

(** The algorithm here has been suggested by Xavier Leroy,
    and transformed into c.p.s. by Benjamin Grégoire.
    The original ocaml code (with non-structural recursive calls)
    has also been formalized (thanks to Function+measure), see
    [ocaml_compare] in [MSetFullAVL]. The following code with
    continuations computes dramatically faster in Coq, and
    should be almost as efficient after extraction.
*)

(** * Comparison *)

(** Enumeration of the elements of a tree. This corresponds
    to the "samefringe" notion in the litterature. *)

Inductive enumeration :=
 | End : enumeration
 | More : key -> elt -> tree -> enumeration -> enumeration.

(** [cons t e] adds the elements of tree [t] on the head of
    enumeration [e]. *)

Fixpoint cons s e : enumeration :=
 match s with
  | Leaf => e
  | Node _ l x v r => cons l (More x v r e)
 end.

(** One step of comparison of elements *)

Variable eqb : elt->elt->bool.

Definition equal_more x1 v1 (cont:enumeration->bool) e2 :=
 match e2 with
 | End => false
 | More x2 v2 r2 e2 =>
     match K.compare x1 x2 with
      | Eq => eqb v1 v2 &&& cont (cons r2 e2)
      | _ => false
     end
 end.

(** Comparison of left tree, middle element, then right tree *)

Fixpoint equal_cont m1 (cont:enumeration->bool) e2 :=
 match m1 with
  | Leaf => cont e2
  | Node _ l1 x1 v1 r1 =>
     equal_cont l1 (equal_more x1 v1 (equal_cont r1 cont)) e2
  end.

(** Initial continuation *)

Definition equal_end e2 := match e2 with End => true | _ => false end.

(** The complete boolean comparison *)

Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End).

(** Ternary comparison *)

Variable cmp : elt -> elt -> comparison.

(** One step of comparison of bindings *)

Definition compare_more x1 d1 (cont:enumeration -> comparison) e2 :=
  match e2 with
  | End => Gt
  | More x2 d2 r2 e2 =>
    lex (K.compare x1 x2) (lex (cmp d1 d2) (cont (cons r2 e2)))
  end.

(** Comparison of left tree, middle element, then right tree *)

Fixpoint compare_cont s1 (cont:enumeration -> comparison) e2 :=
  match s1 with
  | Leaf => cont e2
  | Node _ l1 x1 d1 r1 =>
    compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2
  end.

(** Initial continuation *)

Definition compare_end (e2:enumeration) :=
  match e2 with End => Eq | _ => Lt end.

(** The complete comparison *)

Definition compare m1 m2 :=
  compare_cont m1 compare_end (cons m2 End).

End Elt.

(** ** Map *)

Fixpoint map {elt elt'}(f : elt -> elt')(m : t elt) : t elt' :=
  match m with
   | Leaf _  => Leaf _
   | Node h l x d r => Node h (map f l) x (f d) (map f r)
  end.

(* ** Mapi *)

Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
  match m with
   | Leaf _ => Leaf _
   | Node h l x d r => Node h (mapi f l) x (f x d) (mapi f r)
  end.

End Ops.

(** * Props : correctness proofs of these generic operations *)

Module Type Props (K:OrderedType)(Info:InfoTyp)(Import M:Ops K Info).

Implicit Types x y k : K.t.

Local Infix "==" := K.eq (at level 70).

(** Overloaded "<" notation *)

Class LessThan (A B : Type) := lessthan : A -> B -> Prop.
Local Infix "<" := lessthan.

Instance lt_key_key : LessThan K.t K.t := K.lt.

(** ** Occurrence in a tree *)

Module Ind. (* Module allowing a "Definition" of MapsTo below. *)

Inductive MapsTo elt (x : key)(e : elt) : t elt -> Prop :=
| MapsRoot l r h y : x == y -> MapsTo x e (Node h l y e r)
| MapsLeft l r h y e' : MapsTo x e l -> MapsTo x e (Node h l y e' r)
| MapsRight l r h y e' : MapsTo x e r -> MapsTo x e (Node h l y e' r).

End Ind.
Definition MapsTo := Ind.MapsTo.
Import Ind. (* In the proofs below, let's work with Ind.MapsTo. *)

Local Notation "m @ x ↦ e" := (MapsTo x e m)
 (at level 9, format "m '@' x  '↦'  e").

Definition In elt k m := exists e:elt, m@k ↦ e.
Local Infix "∈" := In (at level 70).

Definition Eqdom elt (m m' : t elt) := forall k, k ∈ m <-> k ∈ m'.
Definition Equal elt (m m' : t elt) := forall k, find k m = find k m'.
Definition Equiv elt (R:elt->elt->Prop) m m' :=
 Eqdom m m' /\ (forall k e e', m@k ↦ e -> m'@k ↦ e' -> R e e').
Definition Equivb elt cmp := @Equiv elt (Cmp cmp).

Definition AllKeys elt (P:key->Prop) (m : t elt) :=
 forall x, x ∈ m -> P x.

(** ** Binary search trees *)

(** Strict order between keys and trees:
    [x < m] when [x] is strictly smaller than any key in [m].
    [m < x] when [x] is strictly greater than any key in [m].
    [m < m'] when all keys in [m] are lower than all keys in [m']. *)

Instance lt_key_map elt : LessThan K.t (t elt) :=
 fun x => AllKeys (lessthan x).
Instance lt_map_key elt : LessThan (t elt) K.t :=
 fun m x => AllKeys (fun y => y < x) m.
Instance lt_map_map elt : LessThan (t elt) (t elt) :=
 fun m m' => AllKeys (fun x => x < m') m.

(** [Bst t] : [t] is a binary search tree *)

Inductive Bst elt : t elt -> Prop :=
| BSLeaf : Bst (Leaf _)
| BSNode h x e l r : Bst l -> Bst r -> l < x -> x < r ->
  Bst (Node h l x e r).

(** [Bst] is the (decidable) invariant our trees will have to satisfy. *)

Definition IsOk := Bst.
Class Ok elt (m:t elt) : Prop := ok : Bst m.

Module F := OrderedTypeFacts K.
Module O := KeyOrderedType K.
Module L := Tries.MMaps.OrdList.MakeRaw K.

Scheme tree_ind := Induction for tree Sort Prop.

(** * Automation and dedicated tactics. *)

Local Hint Constructors tree MapsTo Bst : map.
Local Hint Unfold Ok In : map.
Local Hint Immediate F.eq_sym : map.
Local Hint Resolve F.eq_refl : map.

Tactic Notation "factornode" ident(s) :=
 try clear s;
 match goal with
   | |- context [Node ?h ?l ?x ?e ?r] =>
       set (s:=Node h l x e r) in *; clearbody s; clear l x e r; try clear h
   | _ : context [Node ?h ?l ?x ?e ?r] |- _ =>
       set (s:=Node h l x e r) in *; clearbody s; clear l x e r; try clear h
 end.

(** A tactic for cleaning hypothesis after use of functional induction. *)

Ltac cleanf :=
 match goal with
  | H : K.compare _ _ = Eq |- _ =>
    rewrite ?H; apply F.compare_eq in H; cleanf
  | H : K.compare _ _ = Lt |- _ =>
    rewrite ?H; apply F.compare_lt_iff in H; cleanf
  | H : K.compare _ _ = Gt |- _ =>
    rewrite ?H; apply F.compare_gt_iff in H; cleanf
  | _ => idtac
 end.

(** A tactic to repeat [inversion_clear] on all hyps of the
    form [(f (Node ...))] *)

Ltac inv f :=
  match goal with
     | H:f (Leaf _) |- _ => inversion_clear H; inv f
     | H:f _ (Leaf _) |- _ => inversion_clear H; inv f
     | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f
     | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f
     | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
     | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
     | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
     | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
     | _ => idtac
  end.

Ltac inv_all :=
  match goal with
     | H:_ (Leaf _) |- _ => inversion_clear H; inv_all
     | H:_ _ (Leaf _) |- _ => inversion_clear H; inv_all
     | H:_ _ _ (Leaf _) |- _ => inversion_clear H; inv_all
     | H:_ _ _ _ (Leaf _) |- _ => inversion_clear H; inv_all
     | H:_ (Node _ _ _ _ _) |- _ => inversion_clear H; inv_all
     | H:_ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv_all
     | H:_ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv_all
     | H:_ _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv_all
     | _ => idtac
  end.

Ltac chok := change Bst with Ok in *.
Ltac autok := chok; auto with typeclass_instances map.
Ltac invok := inv_all; chok.
Ltac autom := auto with map.
Ltac eautom := eauto with map.

Ltac intuition_m := repeat (intuition; inv MapsTo).

Ltac redk :=
  match goal with
  | |- context [ O.eqke ?p ?q ] =>
    change (O.eqke p q) with (fst p == fst q /\ snd p = snd q); simpl
  | H : context [ O.eqke ?p ?q] |- _ =>
    change (O.eqke p q) with (fst p == fst q /\ snd p = snd q) in H;
    simpl in H
  end.

Arguments Ok {elt} m.
Arguments Equal {elt} m m'.
Arguments Eqdom {elt} m m'.

Global Instance Equal_equiv {elt} : Equivalence (@Equal elt).
Proof. split; congruence. Qed.
Global Instance Eqdom_equiv {elt} : Equivalence (@Eqdom elt).
Proof.
 split; try firstorder. intros x y z E E' k. now rewrite (E k), (E' k).
Qed.

(** Facts about [MapsTo] and [In]. *)

Lemma mapsto_in {elt} k (e:elt) m : m@k ↦ e -> k ∈ m.
Proof.
 eauto with map.
Qed.
Local Hint Resolve mapsto_in : map.

Lemma in_mapsto {elt} k m : k ∈ m -> exists e:elt, m@k ↦ e.
Proof.
 auto with map.
Qed.

Lemma mapsto_eq {elt} m x y (e:elt) :
  x == y -> m@x ↦ e -> m@y ↦ e.
Proof.
 induction m; simpl; intuition_m; eauto. constructor. F.order.
Qed.
Local Hint Immediate mapsto_eq : map.

Global Instance MapsTo_compat {elt} :
  Proper (K.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt).
Proof.
 split; subst; now apply mapsto_eq.
Qed.

Lemma leaf_mapsto {elt} y e : (Leaf elt)@y ↦ e <-> False.
Proof.
 now split.
Qed.

Lemma node_mapsto {elt} l x (e:elt) r h y v :
 (Node h l x e r)@y ↦ v <->
   l@y ↦ v \/ (y == x /\ v = e) \/ r@y ↦ v.
Proof.
 intuition_m; subst; auto with map.
Qed.

Global Instance in_compat {elt} :
  Proper (K.eq==>Logic.eq==>iff) (@In elt).
Proof.
 intros x x' E m m' <-.
 split; intros (e,M); exists e. now rewrite <-E. now rewrite E.
Qed.

Lemma in_leaf {elt} y : y ∈ (@Leaf elt) <-> False.
Proof.
 unfold In. setoid_rewrite leaf_mapsto. firstorder.
Qed.

Lemma in_node {elt} l x (e:elt) r h y :
  y ∈ (Node h l x e r) <-> y ∈ l \/ y == x \/ y ∈ r.
Proof.
 unfold In. setoid_rewrite node_mapsto. firstorder.
 exists e. intuition.
Qed.

Ltac intuition_in := rewrite ?in_node, ?in_leaf; intuition.

Lemma in_left {elt} l x (e:elt) r h y : y ∈ l -> y ∈ (Node h l x e r).
Proof.
 intuition_in.
Qed.

Lemma in_right {elt} l x (e:elt) r h y : y ∈ r -> y ∈ (Node h l x e r).
Proof.
 intuition_in.
Qed.
Local Hint Resolve in_left in_right : map.

(** Results about [AllKeys] *)

Lemma allkeys_leaf {elt} P : AllKeys P (@Leaf elt).
Proof.
 intros y (e,M). inversion M.
Qed.

Lemma allkeys_node {elt} P h l x (e:elt) r :
  Proper (K.eq ==> iff) P ->
  AllKeys P (Node h l x e r) <-> AllKeys P l /\ P x /\ AllKeys P r.
Proof.
 unfold AllKeys. setoid_rewrite in_node. firstorder. apply H0; autom.
Qed.

Global Instance allkeys_m {elt} :
 Proper ((K.eq ==> iff) ==> Eqdom ==> iff) (@AllKeys elt).
Proof.
 intros P P' HP m m' Hm. unfold AllKeys.
 split; intros H x IN.
 - rewrite <- (HP x); autom. apply H, Hm; autom.
 - rewrite (HP x); autom. apply H, Hm; autom.
Qed.

(** Results about [<] *)

Lemma above_leaf {elt} x : @Leaf elt < x.
Proof.
 apply allkeys_leaf.
Qed.

Lemma above_node {elt} x h l y (e:elt) r :
 Node h l y e r < x <-> l < x /\ y < x /\ r < x.
Proof.
 apply allkeys_node with (P := fun z => z < x). now intros ? ? ->.
Qed.

Global Instance above_m {elt} :
  Proper (@Eqdom elt ==> K.eq ==> iff) lessthan.
Proof.
 intros until 2. apply allkeys_m; auto. split; F.order.
Qed.

Lemma below_leaf {elt} x : x < @Leaf elt.
Proof.
 apply allkeys_leaf.
Qed.

Lemma below_node {elt} x h l y (e:elt) r :
 x < Node h l y e r <-> x < l /\ x < y /\ x < r.
Proof.
 apply allkeys_node. now intros ? ? ->.
Qed.

Global Instance below_m {elt} :
  Proper (K.eq ==> @Eqdom elt ==> iff) lessthan.
Proof.
 intros until 2. apply allkeys_m; auto. split; F.order.
Qed.

Global Instance apart_m {elt} :
 Proper (@Eqdom elt ==> @Eqdom elt ==> iff) lessthan.
Proof.
 intros until 2. apply allkeys_m; auto.
 intros until 1. now apply below_m.
Qed.

(** Helper tactic concerning order of keys. *)

Ltac invlt :=
  match goal with
  | H : _ < Node _ _ _ _ _ |- _ => rewrite !below_node in H; invlt
  | H : Node _ _ _ _ _ < _ |- _ => rewrite !above_node in H; invlt
  | _ => idtac
  end.

Ltac ok :=
 invok;
 match goal with
   | |- Ok (Node _ _ _ _ _) => constructor; autok; ok
   | |- _ < Node _ _ _ _ _ => rewrite !below_node; repeat split; ok
   | |- Node _ _ _ _ _ < _ => rewrite !above_node; repeat split; ok
   | _ => eauto with typeclass_instances map
 end.

Ltac order := intros; match goal with
 | IN: _ ∈ ?m, LT: ?m < _ |- _ => specialize (LT _ IN); order
 | IN: _ ∈ ?m, LT: _ < ?m |- _ => specialize (LT _ IN); order
 | M: ?m @ _ ↦ _, LT: ?m < _ |- _ => specialize (LT _ (mapsto_in M)); order
 | M: ?m @ _ ↦ _, LT: _ < ?m |- _ => specialize (LT _ (mapsto_in M)); order
 | _ => simpl in *; F.order
end.

Lemma above_notin {elt} (m:t elt) x : m < x -> ~ x ∈ m.
Proof.
 intros until 2; order.
Qed.

Lemma below_notin {elt} (m:t elt) x : x < m -> ~ x ∈ m.
Proof.
 intros until 2; order.
Qed.

Lemma above_trans {elt} (m:t elt) x y : x < y -> m < x -> m < y.
Proof.
 intros until 3; order.
Qed.

Lemma below_trans {elt} (m:t elt) x y : y < x -> x < m -> y < m.
Proof.
 intros until 3; order.
Qed.

Local Hint Resolve above_notin above_trans below_notin below_trans : map.

Lemma between {elt} (m m':t elt) x :
  m < x -> x < m' -> m < m'.
Proof.
 intros until 4; order.
Qed.

Lemma apart_node_l {elt} h l x v r (m:t elt) :
  (Node h l x v r) < m <-> l < m /\ x < m /\ r < m.
Proof.
 apply allkeys_node. now intros ? ? ->.
Qed.

Lemma apart_node_r {elt} h l x v r (m:t elt) :
  m < (Node h l x v r) <-> m < l /\ m < x /\ m < r.
Proof.
 unfold "<"; unfold lt_map_map, lt_map_key, AllKeys.
 setoid_rewrite below_node. split; [ | intuition].
 intros H; repeat split; intros y IN; now specialize (H y IN).
Qed.

(** Bst is decidable *)

Instance Bst_Ok {elt} (m : t elt) (B : Bst m) : Ok m := B.

Fixpoint above {elt} x (m : t elt) :=
 match m with
  | Leaf _ => true
  | Node _ l y _ r =>
     match K.compare x y with
      | Gt => above x l && above x r
      | _ => false
     end
 end.

Fixpoint below {elt} x (m : t elt) :=
 match m with
  | Leaf _ => true
  | Node _ l y _ r =>
     match K.compare x y with
      | Lt => below x l && below x r
      | _ => false
     end
 end.

Fixpoint isok {elt} (m : t elt) :=
 match m with
  | Leaf _ => true
  | Node _  l x _ r => isok l && isok r && above x l && below x r
 end.

Lemma above_iff {elt} x (m:t elt) :
  m < x <-> above x m = true.
Proof.
 induction m as [|c l IHl y v r IHr]; simpl.
 - intuition. apply above_leaf.
 - rewrite above_node.
   case K.compare_spec.
   + split; intros; try easy. intuition. order.
   + split; intros; try easy. intuition. order.
   + rewrite andb_true_iff; intuition.
Qed.

Lemma below_iff {elt} x (m:t elt) :
  x < m <-> below x m = true.
Proof.
 induction m as [|c l IHl y v r IHr]; simpl.
 - intuition. apply below_leaf.
 - rewrite below_node.
   case K.compare_spec.
   + split; intros; try easy. intuition. order.
   + rewrite !andb_true_iff. intuition.
   + split; intros; try easy. intuition. order.
Qed.

Lemma isok_iff {elt} (m:t elt) : Ok m <-> isok m = true.
Proof.
 induction m as [|c l IHl y v r IHr]; simpl.
 - intuition.
 - rewrite !andb_true_iff, <- IHl, <-IHr, <- below_iff, <- above_iff.
   intuition; invok; auto.
Qed.

Lemma isok_spec {elt} (m:t elt) : reflect (Ok m) (isok m).
Proof.
 apply iff_reflect, isok_iff.
Qed.

Lemma isok_Ok {elt} (m:t elt) : isok m = true -> Ok m.
Proof. apply isok_iff. Qed.

Section Elt.
Variable elt:Type.
Implicit Types m r : t elt.

(** * Membership *)

Lemma find_1 m x e `{!Ok m} : m@x ↦ e -> find x m = Some e.
Proof.
 induction m; simpl; invok.
 - intuition_m.
 - rewrite node_mapsto.
   case K.compare_spec; intuition_m; subst; auto; order.
Qed.

Lemma find_2 m x e : find x m = Some e -> m@x ↦ e.
Proof.
 induction m; simpl; try easy.
 case K.compare_spec; [ intros -> [= ->] | .. ]; intuition_m.
Qed.

Lemma find_spec m x e `{!Ok m} : find x m = Some e <-> m@x ↦ e.
Proof.
 split; auto using find_1, find_2.
Qed.

Lemma find_in m x : find x m <> None -> x ∈ m.
Proof.
 destruct (find x m) eqn:F; intros H.
 - exists e. now apply find_2.
 - now elim H.
Qed.

Lemma in_find m x `{!Ok m} : x ∈ m -> find x m <> None.
Proof.
 intros (e,M). now rewrite (find_1 M).
Qed.

Lemma find_in_iff m x `{!Ok m} :
 find x m <> None <-> x ∈ m.
Proof.
 split; auto using find_in, in_find.
Qed.

Lemma not_find_iff m x `{!Ok m} :
 find x m = None <-> ~ x ∈ m.
Proof.
 rewrite <- find_in_iff; trivial.
 destruct (find x m); split; try easy. now destruct 1.
Qed.

Lemma eq_option_alt (o o':option elt) :
 o=o' <-> (forall e, o=Some e <-> o'=Some e).
Proof.
split; intros.
- now subst.
- destruct o, o'; rewrite ?H; auto. symmetry; now apply H.
Qed.

Lemma find_mapsto_equiv m m' x `{!Ok m, !Ok m'} :
 find x m = find x m' <->
  (forall d, m@x ↦ d <-> m'@x ↦ d).
Proof.
 rewrite eq_option_alt.
 split; intros H d. now rewrite <- 2 find_spec. now rewrite 2 find_spec.
Qed.

Lemma find_in_equiv m m' x `{!Ok m, !Ok m'} :
 find x m = find x m' ->
  (x ∈ m <-> x ∈ m').
Proof.
 intros E. split; intros; apply find_in; [ rewrite <- E | rewrite E ];
  apply in_find; auto.
Qed.

Lemma find_compat m x x' `{!Ok m} : x == x' -> find x m = find x' m.
Proof.
 intros E.
 destruct (find x' m) eqn:H.
 - apply find_1; trivial. rewrite E. now apply find_2.
 - rewrite not_find_iff in *; trivial. now rewrite E.
Qed.

Lemma mem_spec m x `{!Ok m} : mem x m = true <-> x ∈ m.
Proof.
 induction m; simpl.
 - now rewrite in_leaf.
 - invok. rewrite in_node. case K.compare_spec; intuition; order.
Qed.

(** * Empty map *)

Global Instance empty_ok : Ok (empty elt).
Proof.
 constructor.
Qed.

Lemma empty_spec x : find x (empty elt) = None.
Proof.
 reflexivity.
Qed.

(** * Emptyness test *)

Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None.
Proof.
 destruct m as [|h r x e l]; simpl; split; try easy.
 intros H. specialize (H x). now rewrite F.compare_refl in H.
Qed.

(** * Elements *)

Definition eq_key : (key*elt) -> (key*elt) -> Prop := @O.eqk elt.
Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @O.eqke elt.
Definition lt_key : (key*elt) -> (key*elt) -> Prop := @O.ltk elt.

Notation eqk := (O.eqk (elt:= elt)).
Notation eqke := (O.eqke (elt:= elt)).
Notation ltk := (O.ltk (elt:= elt)).

Lemma bindings_aux_mapsto m acc x e :
 InA eqke (x,e) (bindings_aux acc m) <-> m@x ↦ e \/ InA eqke (x,e) acc.
Proof.
 revert acc.
 induction m as [ | h l Hl y e' r Hr ]; intros acc; simpl; auto.
 - intuition_m.
 - rewrite Hl, InA_cons, Hr. redk. intuition_m. subst; autom.
Qed.

Lemma bindings_spec1 m x e :
 InA eqke (x,e) (bindings m) <-> m@x ↦ e.
Proof.
 unfold bindings. rewrite bindings_aux_mapsto. rewrite InA_nil. intuition.
Qed.

Lemma bindings_in m x : L.PX.In x (bindings m) <-> x ∈ m.
Proof.
 unfold L.PX.In.
 split; intros (y,H); exists y.
 - now rewrite <- bindings_spec1.
 - unfold L.PX.MapsTo; now rewrite bindings_spec1.
Qed.

Lemma bindings_aux_sort m acc `{!Ok m} :
 sort ltk acc ->
 (forall x e y, InA eqke (x,e) acc -> y ∈ m -> y < x) ->
 sort ltk (bindings_aux acc m).
Proof.
 revert acc.
 induction m as [ | h l Hl y e r Hr ]; intros acc; simpl; intuition.
 invok.
 apply Hl; auto.
 - constructor.
   + apply Hr; eautom.
   + clear Hl Hr.
     apply InA_InfA with (eqA:=eqke); auto with *.
     intros (y',e') Hy'.
     apply bindings_aux_mapsto in Hy'. change (y < y'). intuition; eautom.
 - clear Hl Hr. intros x e' y' Hx Hy'.
   rewrite InA_cons in Hx. redk. destruct Hx as [(Hx,->)|Hx].
   + order.
   + apply bindings_aux_mapsto in Hx. intuition. order. eautom.
Qed.

Lemma bindings_spec2 m `{!Ok m} : sort ltk (bindings m).
Proof.
 unfold bindings; apply bindings_aux_sort; auto. inversion 1.
Qed.
Local Hint Resolve bindings_spec2 : map.

Lemma bindings_spec2w m `{!Ok m} : NoDupA eqk (bindings m).
Proof.
 intros; apply O.Sort_NoDupA; autom.
Qed.

Lemma bindings_aux_cardinal m acc :
 length acc + cardinal m = length (bindings_aux acc m).
Proof.
 revert acc. induction m; simpl; intuition.
 rewrite <- IHm1; simpl.
 rewrite <- IHm2. rewrite Nat.add_succ_r, <- Nat.add_assoc.
 f_equal. f_equal. apply Nat.add_comm.
Qed.

Lemma cardinal_spec m : cardinal m = length (bindings m).
Proof.
 exact (bindings_aux_cardinal m nil).
Qed.

Lemma bindings_app :
 forall (s:t elt) acc, bindings_aux acc s = bindings s ++ acc.
Proof.
 induction s; simpl; intros; auto.
 rewrite IHs1, IHs2.
 unfold bindings; simpl.
 rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
Qed.

Lemma bindings_node_acc (t1 t2:t elt) x e z acc :
 bindings (Node z t1 x e t2) ++ acc =
 bindings t1 ++ (x,e) :: bindings t2 ++ acc.
Proof.
 unfold bindings; simpl; intros.
 rewrite !bindings_app, !app_nil_r, !app_ass; auto.
Qed.

Lemma bindings_node (t1 t2:t elt) x e z :
 bindings (Node z t1 x e t2) =
 bindings t1 ++ (x,e) :: bindings t2.
Proof.
 rewrite <- (app_nil_r (bindings _)), bindings_node_acc.
 now rewrite app_nil_r.
Qed.

Lemma rev_bindings_aux_rev m acc :
 rev_bindings_aux acc m = rev (bindings m) ++ acc.
Proof.
 revert acc. induction m; simpl; intros; auto.
 rewrite IHm2, IHm1, bindings_node, !rev_app_distr. simpl.
 now rewrite <- !app_assoc.
Qed.

Lemma rev_bindings_rev m : rev_bindings m = rev (bindings m).
Proof.
 unfold rev_bindings. rewrite rev_bindings_aux_rev. apply app_nil_r.
Qed.

Lemma in_bindings k v (m:t elt) : List.In (k,v) (bindings m) -> In k m.
Proof.
 intros IN. exists v. apply bindings_spec1, In_InA; eauto with *.
Qed.

Lemma in_bindings_uniq k k' v v' (m:t elt) `{!Ok m}:
 List.In (k,v) (bindings m) ->
 List.In (k',v') (bindings m) ->
 k == k' -> k = k' /\ v = v'.
Proof.
 induction m as [|c l IHl x e r IHr].
 - now cbn.
 - rewrite !bindings_node, !in_app_iff. simpl. invok.
   intros [INl|[[= <- <-]|INl]] [INr|[[= <- <-]|INr]] E; eauto;
   try apply in_bindings in INl; try apply in_bindings in INr; order.
Qed.

(** * Fold *)

Definition fold' {A} (f : key -> elt -> A -> A) m :=
  L.fold f (bindings m).

Lemma fold_equiv_aux {A} m (f : key -> elt -> A -> A) (a : A) acc :
 L.fold f (bindings_aux acc m) a = L.fold f acc (fold f m a).
Proof.
 revert a acc.
 induction m; simpl; trivial.
 intros. rewrite IHm1. simpl. apply IHm2.
Qed.

Lemma fold_equiv {A} m (f : key -> elt -> A -> A) (a : A) :
 fold f m a = fold' f m a.
Proof.
 unfold fold', bindings. now rewrite fold_equiv_aux.
Qed.

Lemma fold_spec m {A} (i:A)(f : key -> elt -> A -> A) :
 fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
Proof.
 rewrite fold_equiv. unfold fold'. now rewrite L.fold_spec.
Qed.

(** * For_all / exists *)

Lemma for_all_spec (f:key->elt->bool) m :
  for_all f m = List.forallb (fun '(k,e) => f k e) (bindings m).
Proof.
induction m; simpl; auto.
rewrite bindings_node, forallb_app; simpl.
rewrite <- !andb_lazy_alt, andb_assoc, (andb_comm (f _ _)).
f_equal; auto. f_equal; auto.
Qed.

Lemma exists_spec (f:key->elt->bool) m :
  exists_ f m = List.existsb (fun '(k,e) => f k e) (bindings m).
Proof.
induction m; simpl; auto.
rewrite bindings_node, existsb_app; simpl.
rewrite <- !orb_lazy_alt, orb_assoc, (orb_comm (f _ _)).
f_equal; auto. f_equal; auto.
Qed.

(** * Comparison *)

(** [flatten_e e] returns the list of bindings of the enumeration [e]
    i.e. the list of bindings actually compared *)

Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with
  | End _ => nil
  | More x e t r => (x,e) :: bindings t ++ flatten_e r
 end.

Lemma flatten_e_bindings :
 forall (l:t elt) r x d z e,
 bindings l ++ flatten_e (More x d r e) =
 bindings (Node z l x d r) ++ flatten_e e.
Proof.
 intros. now rewrite bindings_node, <- app_assoc.
Qed.

Lemma cons_1 : forall (s:t elt) e,
  flatten_e (cons s e) = bindings s ++ flatten_e e.
Proof.
  induction s; auto; intros.
  simpl flatten_e; rewrite IHs1; apply flatten_e_bindings; auto.
Qed.

(** Proof of correction for the comparisons *)

Variable eqb : elt->elt->bool.

Local Notation Leq := (L.equal eqb).

Lemma equal_cont_Leq : forall m1 cont e2 l,
  (forall e, cont e = Leq l (flatten_e e)) ->
  equal_cont eqb m1 cont e2 = Leq (bindings m1 ++ l) (flatten_e e2).
Proof.
 induction m1 as [|h1 l1 Hl1 x1 d1 r1 Hr1]; intros; auto.
 rewrite bindings_node_acc; simpl.
 apply Hl1; auto.
 clear e2; intros [|x2 d2 r2 e2]; simpl; auto.
 case K.compare; auto. rewrite <- andb_lazy_alt. f_equal.
 rewrite <- cons_1; auto.
Qed.

Lemma equal_Leq m1 m2 :
  equal eqb m1 m2 = Leq (bindings m1) (bindings m2).
Proof.
 unfold equal.
 rewrite <- (app_nil_r (bindings m1)).
 replace (bindings m2) with (flatten_e (cons m2 (End _)))
  by (rewrite cons_1; simpl; rewrite app_nil_r; auto).
 apply equal_cont_Leq. now destruct e.
Qed.

Lemma Equivb_bindings m m' :
 Equivb eqb m m' <-> L.Equivb eqb (bindings m) (bindings m').
Proof.
unfold Equivb, L.Equivb; split; split; try red; intros.
do 2 rewrite bindings_in; firstorder.
destruct H.
apply (H2 k); rewrite <- bindings_spec1; auto.
do 2 rewrite <- bindings_in; firstorder.
destruct H.
apply (H2 k); unfold L.PX.MapsTo; rewrite bindings_spec1; auto.
Qed.

Lemma equal_spec (m m':t elt)`{!Ok m, !Ok m'} :
  equal eqb m m' = true <-> Equivb eqb m m'.
Proof.
 rewrite Equivb_bindings, equal_Leq.
 split; [apply L.equal_2 | apply L.equal_1];
   unfold L.Ok; apply bindings_spec2.
Qed.

Variable cmp : elt -> elt -> comparison.

Local Notation Lcmp := (L.compare cmp).

Lemma compare_cont_Lcmp : forall s1 cont e2 l,
  (forall e, cont e = Lcmp l (flatten_e e)) ->
  compare_cont cmp s1 cont e2 =
   Lcmp (bindings s1 ++ l) (flatten_e e2).
Proof.
 induction s1 as [|h1 l1 Hl1 x1 d1 r1 Hr1]; intros; simpl; auto.
 rewrite bindings_node_acc; simpl.
 apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2]; simpl; auto.
 case K.compare; auto. case cmp; auto. rewrite <- cons_1; auto.
Qed.

Lemma compare_Lcmp m1 m2 :
 compare cmp m1 m2 = Lcmp (bindings m1) (bindings m2).
Proof.
 unfold compare; simpl.
 rewrite <- (app_nil_r (bindings m1)).
 replace (bindings m2) with (flatten_e (cons m2 (End _))) by
 (rewrite cons_1; simpl; rewrite app_nil_r; auto).
 apply compare_cont_Lcmp. now destruct e.
Qed.

Lemma compare_spec (m m':t elt)`{!Ok m, !Ok m'} :
  compare cmp m m' =
  list_compare (pair_compare K.compare cmp) (bindings m) (bindings m').
Proof. apply compare_Lcmp. Qed.

End Elt.

Section Map.
Variable elt elt' : Type.
Variable f : elt -> elt'.

Lemma map_spec m :
 bindings (map f m) = List.map (fun '(k,e) => (k,f e)) (bindings m).
Proof.
induction m; simpl; auto.
now rewrite !bindings_node, !map_app, IHm1, IHm2.
Qed.

Lemma map_in m x : x ∈ (map f m) <-> x ∈ m.
Proof.
induction m; simpl; intuition_in.
Qed.

Global Instance map_ok m `{!Ok m} : Ok (map f m).
Proof.
induction m; simpl; ok; intro; rewrite map_in; order.
Qed.

End Map.
Section Mapi.
Variable elt elt' : Type.
Variable f : key -> elt -> elt'.

Lemma mapi_spec m :
 bindings (mapi f m) = List.map (fun '(k,e) => (k,f k e)) (bindings m).
Proof.
induction m; simpl; auto.
now rewrite !bindings_node, !map_app, IHm1, IHm2.
Qed.

Lemma mapi_in m x : x ∈ (mapi f m) <-> x ∈ m.
Proof.
induction m; simpl; intuition_in.
Qed.

Global Instance mapi_ok m `{!Ok m} : Ok (mapi f m).
Proof.
induction m; simpl; ok; intro; rewrite mapi_in; order.
Qed.

End Mapi.

Section Elt.
Variable elt : Type.
Implicit Type m : t elt.

(** mindepth / maxdepth (used later in AVLproofs and RBTproofs *)

Local Open Scope nat.

Lemma mindepth_maxdepth m : mindepth m <= maxdepth m.
Proof.
 induction m; simpl; auto.
 rewrite <- Nat.succ_le_mono.
 transitivity (mindepth m1). apply Nat.le_min_l.
 transitivity (maxdepth m1). trivial. apply Nat.le_max_l.
Qed.

Lemma maxdepth_cardinal m : cardinal m < 2^(maxdepth m).
Proof.
 unfold Peano.lt.
 induction m as [|c l IHl x e r IHr].
 - auto.
 - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
   apply Nat.add_le_mono; etransitivity;
   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
   * apply Nat.le_max_l.
   * apply Nat.le_max_r.
Qed.

Lemma mindepth_cardinal m : 2^(mindepth m) <= S (cardinal m).
Proof.
 unfold Peano.lt.
 induction m as [|c l IHl x e r IHr].
 - auto.
 - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
   apply Nat.add_le_mono; etransitivity;
   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
   * apply Nat.le_min_l.
   * apply Nat.le_min_r.
Qed.

Lemma maxdepth_log_cardinal m : m <> Leaf _ ->
 Nat.log2 (cardinal m) < maxdepth m.
Proof.
 intros H.
 apply Nat.log2_lt_pow2. destruct m; simpl; intuition.
 apply maxdepth_cardinal.
Qed.

Lemma mindepth_log_cardinal m : mindepth m <= Nat.log2 (S (cardinal m)).
Proof.
 apply Nat.log2_le_pow2. auto with arith.
 apply mindepth_cardinal.
Qed.

End Elt.

End Props.


Require Import VST.floyd.proofauto.

Require Import min2.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition ssl_is_valid_int (x: val) := exists y, x = Vint (Int.repr y) /\  Int.min_signed <= y <= Int.max_signed.

Ltac ssl_open_context :=
  lazymatch goal with
  | [ H:  ssl_is_valid_int ?x |- _ ] =>
    let x1 := fresh x in
    rename x into x1;
    let H2 := fresh H in
    let H3 := fresh H in
    destruct H as [x [H2 H3]]; rewrite H2; ssl_open_context
  | _ => idtac
  end.

Definition min2_spec :=
  DECLARE _min2
   WITH r: val, x: val, y: val
   PRE [ (tptr (Tunion _sslval noattr)), tint, tint ]
   PROP( is_pointer_or_null(r); ssl_is_valid_int(x); ssl_is_valid_int(y) )
   PARAMS(r; x; y)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [inl (Vint (Int.repr 0))] r))
   POST[ tvoid ]
   EX m: Z,
   PROP( (m <= (force_signed_int x)); (m <= (force_signed_int y)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [inl (Vint (Int.repr m))] r)).

(* Packaging the API spec all together. *)
Definition Gprog : funspecs :=
  ltac:(with_library prog [min2_spec]).

From mathcomp Require Import ssreflect ssrbool.

(** Proof that f_swap, the body of the swap() function,
 ** satisfies swap_spec, in the global context (Vprog,Gprog).
 **)
Lemma min2_swap: semax_body Vprog Gprog f_min2 min2_spec.
Proof.
  start_function.
  ssl_open_context.
  forward_if.
  - forward.
    forward.
    Exists x.
    entailer.
  - forward.
    forward.
    Exists y.
    entailer!.
Qed.


(* coq-prelude
 * Copyright (C) 2018–2019 ANSSI
 *
 * Contributors:
 * 2018–2019 Thomas Letan <thomas.letan@ssi.gouv.fr>
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program. If not, see <http://www.gnu.org/licenses/>.
 *)

Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Program.Equality.

Require Import Prelude.Control.Sum.
Require Import Prelude.Data.Void.

Import ListNotations.
Local Open Scope list_scope.

(** If you use polymorphic definition, do no use function from the
    standard library. Define your own. *)
#[universes(polymorphic)]
Fixpoint cardinal
         {a:  Type}
         (l:  list a)
  : nat :=
  match l with
  | _ :: rst
    => S (cardinal rst)
  | nil
    => O
  end.

#[universes(polymorphic)]
Fixpoint get
         (set:  list Type)
         (n:    nat)
         {struct n}
  : Type :=
  match n, set with
  | 0, t :: _
    => t
  | S n, _ :: set'
    => get set' n
  | _, _
    => Void
  end.

(** The open [union] type. For instance, a value [(v: union [nat;
    bool])] will be either of type [nat] or [bool]. *)
#[universes(polymorphic)]
Inductive union
          (set:  list Type)
  : Type :=
| OneOf {t:  Type}
        (n:  nat)
        (Ht: get set n = t)
        (Hn: n < cardinal set )
        (x:  t)
  : union set.

Arguments OneOf [set t] (n Ht Hn x).

(** An “open product”. Similarly to [union], it is parameterized by a
    list of types. *)
#[universes(polymorphic)]
Inductive product
  : list Type -> Type :=
| Acons (a:    Type)
        (x:    a)
        (set:  list Type)
        (rst:  product set)
  : product (a :: set)
| Anil
  : product [].

Arguments Acons [a] (x) [set] (rst).

(** Given an open product [(x: product set)], get the [n]th element of
    type [get set n]. *)
#[universes(polymorphic)]
Fixpoint fetch
         {set:  list Type}
         (x:    product set)
         (n:    nat)
         (H:    n < cardinal set)
  : get set n.
case_eq set.
+ intros Heq.
  subst.
  cbn in H.
  omega.
+ intros T l Heq.
  subst.
  dependent induction x.
  induction n.
  exact x.
  cbn.
  apply fetch.
  ++ exact x0.
  ++ cbn in H.
     omega.
Defined.

(** Given an open product [(x: product set)], change the [n]th element
    of type [get set n] by a new value [v]. *)
#[universes(polymorphic)]
Fixpoint swap
         {set:  list Type}
         (x:    product set)
         (n:    nat)
         (H:    n < cardinal set)
         (v:    get set n)
         {struct x}
  : product set.
case_eq set.
+ intros Heq.
  subst.
  cbn in H.
  omega.
+ intros T l Heq.
  subst.
  dependent induction x.
  induction n.
  ++ exact (Acons v x0).
  ++ refine (Acons x _).
     apply (swap l x0 n).
     +++ cbn in H.
         omega.
     +++ exact v.
Defined.

(** Given a list of type [set] and a natural number [n], returns a
    list of type wherein the [n]th element of [set] is absent. *)
#[universes(polymorphic)]
Fixpoint remove
         (set:  list Type)
         (n:    nat)
  : list Type :=
  match set, n with
  | _ :: rst, 0
    => rst
  | x :: rst, S n
    => x :: remove rst n
  | _, _
    => []
  end.

(** Given an arbitrary list of types [set], we want to be able to tell
    whether or not it contains the type [t]. This is what the
    [Contains] typeclass is for. *)
#[universes(polymorphic)]
Class Contains
      (t:    Type)
      (set:  list Type)
  := { rank:            nat
     ; rank_get_t:      get set rank = t
     ; rank_bound:      rank < cardinal set
     }.

Arguments rank (t set) {_}.
Arguments rank_get_t (t set) {_}.
Arguments rank_bound (t set) {_}.

(** One obvious instance of [Contains] is that the type [get set n] is
    contains in [set]. *)
#[universes(polymorphic)]
Instance Contains_nat
         (set:  list Type)
         (n:    nat)
         (H:    n < cardinal set)
  : Contains (get set n) set :=
  { rank        := n
  ; rank_get_t  := eq_refl
  ; rank_bound  := H
  }.

(** Then, following what is often done in Haskell in this context, we
    can define two instances of [Contains]:

    First, a list contains its head. *)
#[program, universes(polymorphic)]
Instance Contains_head
         (t:    Type)
         (set:  list Type)
  : Contains t (cons t set) :=
  { rank        := 0
  ; rank_get_t  := eq_refl
  }.

Next Obligation.
  apply Nat.lt_0_succ.
Defined.

(** Then, if a list [set] contains a type [t], then any list
    constructed by appending an element to [set] also contains [t]. *)
#[universes(polymorphic), program]
Instance Contains_tail
         (t any:  Type)
         (set:    list Type)
         (H:      Contains t set)
  : Contains t (cons any set) :=
  { rank       := S (rank t set)
  }.

Next Obligation.
  apply rank_get_t.
Defined.

Next Obligation.
  cbn.
  apply lt_n_S.
  apply rank_bound.
Defined.

(** Using the [Contains] typeclass, we can define a useful function
    [inj] to easily construct values of arbitrary open unions. *)
#[universes(polymorphic), program]
Definition inj
           {t:    Type}
           {set:  list Type} `{Contains t set}
           (x:    t)
  : union set :=
  OneOf (rank t set) (rank_get_t t set) (rank_bound t set) x.

(** The aim of the [visit] function is two fold. Given an open product
    [x] and a function [(f: t -> a * t)] such that a value of type [t]
    is present in [x] (as enforced by the [Contains] constraint). It
    returns the result of type [a] produced by [f] along with an open
    union such that the value of type [t] has been [swap]ped with the
    value of type [t] produced by [f]. *)
Definition visit
           {t:    Type}
           {set:  list Type} `{Contains t set}
           {a:    Type}
           (x:    product set)
           (f:    t -> a * t)
  : a * product set.
  refine (match fetch x (rank t set) (rank_bound t set)
                return get set (rank t set) = t -> a * product set
          with
          | v
            => fun (H: get set (rank t set) = t)
               => _
          end (rank_get_t t set)).
  remember (f (eq_rect (get set (rank t set)) (fun X => X) v t H)) as p.
  induction p as [v' u].
  refine (v', swap x (rank t set) (rank_bound t set) _).
  refine (eq_rect t (fun X => X) u (get set (rank t set)) _).
  symmetry.
  exact H.
Defined.


(** NetKAT Automata & Language Theory *)

Require Import List Coq.Program.Equality Bool Omega FunctionalExtensionality Recdef.
Import ListNotations.
Require Export NetKAT InductiveNETKAT Sets Misc Classes Tactics.

Ltac invert H := inversion H; subst; clear H.

(** NetKAT language model.  ********************************************)
(* See the original NetKAT paper *)

Module Automata (F : FIELDSPEC) (V : VALUESPEC(F)).

Include  InductiveNETKAT.NetKAT(F)(V).

(** Guarded NetKAT Strings *******************************************)

(* P ; (P;dup)* ; P *)
Inductive gs :=
  | GS : P.t -> list P.t -> P.t -> gs.

Hint Constructors gs.

Global Arguments GS a w b : rename.

Notation "a ~( w )~ b" := (GS a w b) (at level 1, format "a ~( w )~ b").

(* equality on guarded NetKAT strings is decidable, since equality on packets
   is decidable *)
Global Program Instance : EqType gs := fun x y => match x,y with
  a~(w)~b, a'~(w')~b' => if (a,w,b) =d= (a',w',b') then left _ else right _
end.

Definition gs_length (gs : gs) :=
  let '_~(w)~_ := gs in length w.

(* Dexter also calls this the "fusion product",
   see "Automata on Guarded Strings and Applications" *)
Definition gs_conc (s1 s2 : gs) :=
  let 'a~(w)~b := s1 in
  let 'b'~(v)~c := s2 in
  if b =d= b' then Some (a~(w++v)~c) else None.

Definition take (n:nat) (s:gs) (c : P.t) : gs :=
  let 'a~(w)~b := s in
  let w' := firstn n w in
  a~(w')~c.

Definition drop (n:nat) (c : P.t) (s:gs) : gs :=
  let 'a~(w)~b := s in
  let w' := skipn n w in
  c~(w')~b.

Theorem conc_take_drop (s: gs) (n : nat) c :
  gs_conc (take n s c) (drop n c s) = Some s.
Proof.
  destruct s as [a w b]. destruct n; simpl.
  + split_if; intuition idtac.
  + split_if; intuition idtac.
    destruct w; intuition simpl.
    rewrite firstn_skipn. reflexivity.
Qed.

(** End Guarded NetKAT Strings #######################################*)

(** decidable languages over guarded NetKAT strings *****************************)

Definition gs_lang := gs -> bool.

(** UNION ****)

Definition gs_lang_union L1 L2 := [$ s : gs | s \in L1 || s \in L2 ].

Theorem lang_union_correct L1 L2 s :
  (s \in L1 = true \/ s \in L2 = true) <-> s \in gs_lang_union L1 L2 = true.
Proof. rewrite <- orb_true_iff. unfold gs_lang_union. intuition. Qed.

(** CONC ****)

Definition gs_lang_conc L1 L2 := [$ s : gs | [$ exists a |
  existsb (fun n => take n s a \in L1 && drop n a s \in L2) (seq 0 (S (gs_length s))) ] ].

Lemma firstn_app {X} (xs ys : list X) : firstn (length xs) (xs ++ ys) = xs.
Proof. induction xs; intros; intuition simpl. congruence. Qed.

Lemma skipn_app {X} (xs ys : list X) : skipn (length xs) (xs ++ ys) = ys.
Proof. induction xs; intros; intuition simpl. Qed.

Theorem lang_conc_correct L1 L2 s :
  (exists s1 s2, (Some s = gs_conc s1 s2) /\ (s1 \in L1 = true) /\ (s2 \in L2 = true))
  <-> (s \in gs_lang_conc L1 L2 = true).
Proof.
  split; intro H.
  + steffen.
    destruct s1 as [a w b]; destruct s2 as [b' v c].
    simpl in H. split_if; invert H.
    unfold gs_lang_conc. apply exists_iff. exists b'.
    apply existsb_exists. exists (length w).
    split.
    - clear H1; clear H0; induction w; simpl; intuition auto.
      simpl in IHw; destruct IHw; intuition auto.
      repeat right. rewrite <- seq_shift. apply in_map. assumption.
    - simpl. rewrite firstn_app; rewrite skipn_app.
      rewrite H1; rewrite H0. auto.
  + unfold gs_lang_conc in H; rewrite existsb_exists in H.
    steffen.
    exists (take x0 s x). exists (drop x0 x s).
    intuition idtac. symmetry. apply conc_take_drop.
Qed.

(* missing: kleene star *)
Definition gs_lang_id := [$ s : gs | let 'a~(w)~b := s in (a =b= b) && (w =b= []) ].

Fixpoint gs_lang_power L n :=
match n with
  | O => gs_lang_id
  | S n => gs_lang_conc L (gs_lang_power L n)
end.

(*
Parameter gs_lang_star : gs_lang -> gs_lang.
Axiom lang_star_correct : forall L s,
  (exists n, gs_lang_power L n s = true) <-> (gs_lang_star L s = true).
*)

(** End languages over guarded strings ########################*)

(** NetKAT NFAs over guarded strings **************************************)
(* See "A Coalgebraic Decision Procedure for NetKAT" for details *)

Record nfa := {
  nfa_state :> Type;
  nfa_finite :> Finite nfa_state;
  nfa_eqtype :> EqType nfa_state;
  nfa_s : nfa_state;
  nfa_accept : nfa_state -> P.t -> P.t -> bool;
  nfa_trans : nfa_state -> P.t -> P.t -> nfa_state -> bool
}.

Global Instance nfa_is_finite (A : nfa) : Finite (nfa_state A) := nfa_finite A.
Global Instance nfa_is_eqtype (A : nfa) : EqType (nfa_state A) := nfa_eqtype A.

Arguments nfa_accept {A} q a b : rename.
Arguments nfa_trans {A} q a b q' : rename.

(* We must define acceptance with "fuel" n as otherwise Coq cannot be convinced
   that accept terminates. *)
Fixpoint accept_n {A : nfa} (q : A) gs n :=
match gs with
  | a~([])~b => nfa_accept q a b
  | a~(b::w)~c =>
    match n with
      | O => false
      | S n => [$ exists q' | nfa_trans q a b q' && accept_n q' b~(w)~c n ]
    end
end.

Definition accept {A : nfa} (q : A) gs := accept_n q gs (gs_length gs).
Hint Unfold accept.

Inductive accept_prop {A : nfa} (q : A) : gs -> Prop :=
  | accept_atom : forall a b,
      nfa_accept q a b = true -> accept_prop q a~([])~b
  (* - - -  - - - - - - -  - - - - - - - - - - - - - - - - *)
  | accept_trans : forall a b c w q',
     nfa_trans q a b q' = true -> accept_prop q' b~(w)~c ->
        accept_prop q a~(b::w)~c.

Hint Constructors accept_prop.

Theorem accept_correct (A : nfa) (q : A) gs : accept_prop q gs <-> accept q gs = true.
Proof.
  destruct gs as [a w b].
  split; intro H; gd q; gd a; gd b; induction w; intros;
  unfold accept in *; simpl;  try invert H; steffen; eauto.
  + exists q'. steffen. intuition eauto.
Qed.

Definition nfa_lang (A : nfa) := [$ gs | accept (nfa_s A) gs ].
Hint Unfold nfa_lang.

(** primitive automata ****************************************************)

Definition nfa_pred p :=
  {| nfa_s := tt;
     nfa_accept q a b := p a b;
     nfa_trans q a b q' := false |}.

Lemma nfa_pred_correct p :
  nfa_lang (nfa_pred p) = [$ s | let 'a~(w)~b := s in (p a b) && (w =b= [])].
Proof.
  apply pred_eq_intro. intro s; destruct s as [a w b]; unfold nfa_lang.
  rewrite <- accept_correct.
  split; intro H; invert H; simpl in *; intuition; steffen.
  subst w. auto.
Qed.

Definition nfa_dup :=
  {| nfa_s := false;
     nfa_accept q a b := q && (a =b= b);
     nfa_trans q a b q' := (negb q) && q' && (a =b= b) |}.

Lemma nfa_dup_correct :
  nfa_lang nfa_dup = [$ s | let 'a~(w)~b := s in (a =b= b) && (w =b= [a])].
Proof.
  apply pred_eq_intro; intro s; destruct s as [a w b]; unfold nfa_lang;
  rewrite <- accept_correct; split; intro H; steffen.
  + invert H. invert H1. invert H2. invert H4. invert H1.
    steffen. subst. split; congruence.
    invert H2. steffen. congruence.
  + subst. right with (q':=true); intuition; simpl.
    apply eqb_refl. left. simpl. apply eqb_refl.
Qed.

(** nfa_union *****************************************************************)

Definition nfa_union (A B : nfa) :=
  {| nfa_s := None;
     nfa_accept q a b :=
       match q with
         | None => nfa_accept (nfa_s A) a b || nfa_accept (nfa_s B) a b
         | Some (inl q) => @nfa_accept A q a b
         | Some (inr q) => @nfa_accept B q a b
       end;
     nfa_trans q a b q' :=
       match q,q' with
         | _, None | Some (inl _), Some (inr _) | Some (inr _), Some (inl _) => false
         | None, Some (inl q') => nfa_trans (nfa_s A) a b q'
         | None, Some (inr q') => nfa_trans (nfa_s B) a b q'
         | Some (inl q), Some (inl q') => @nfa_trans A q a b q'
         | Some (inr q), Some (inr q') => @nfa_trans B q a b q'
       end
  |}.

Lemma nfa_union_correct_left (A B : nfa) (q:A) gs :
  @accept_prop (nfa_union A B) (Some (inl q)) gs <-> accept_prop q gs.
Proof.
  destruct gs as [a w b].
  gd a; gd b; gd q; induction w; intros;
  split; intro H; inversion H; simpl in *; eauto 2.
  + destruct q' as [[q'|q']| ]; inversion H2. econstructor; eauto.
    apply IHw. assumption.
  + econstructor. instantiate (1 := Some (inl q')). simpl. assumption.
    rewrite IHw. assumption.
Qed.

Lemma nfa_union_correct_left' (A B : nfa) (q:A) :
  [$ gs | @accept (nfa_union A B) (Some (inl q)) gs ] = [$ gs | accept q gs].
Proof.
  apply pred_eq_intro.
  intro gs. repeat rewrite <- accept_correct. apply nfa_union_correct_left.
Qed.

Lemma nfa_union_correct_right (A B : nfa) (q:B)  gs :
  @accept_prop (nfa_union A B) (Some (inr q)) gs <-> accept_prop q gs.
Proof.
  destruct gs as [a w b].
  gd a; gd b; gd q; induction w; intros;
  split; intro H; inversion H; simpl in *; eauto 2.
  + destruct q' as [[q'|q']| ]; inversion H2. econstructor; eauto.
    apply IHw. assumption.
  + econstructor. instantiate (1 := Some (inr q')). simpl. assumption.
    rewrite IHw. assumption.
Qed.

Lemma nfa_union_correct_right' (A B : nfa) (q:B) :
  [$ gs | @accept (nfa_union A B) (Some (inr q)) gs ] = [$ gs | accept q gs].
Proof.
  apply pred_eq_intro.
  intro gs. repeat rewrite <- accept_correct. apply nfa_union_correct_right.
Qed.

Lemma nfa_union_correct A B :
  nfa_lang (nfa_union A B) = gs_lang_union (nfa_lang A) (nfa_lang B).
Proof.
  unfold nfa_lang.
  apply pred_eq_intro.
  intro gs. rewrite <- lang_union_correct.
  repeat rewrite <- accept_correct.
  destruct gs as [a [ | b w] c];
  split; intro H; [ |destruct H as [H|H]| |destruct H as [H|H]];
  inversion H; simpl in *.
  - destruct (orb_prop _ _ H1) as [H3|H3]; eauto.
  - constructor. simpl. rewrite H1; simpl; reflexivity.
  - constructor. simpl. apply orb_true_intro; auto.
  - destruct q' as [[q'|q']| ]; inversion H2; [left|right];
    [rewrite nfa_union_correct_left in H5 | rewrite nfa_union_correct_right in H5];
    eauto.
  - econstructor. instantiate (1 := Some (inl q')); simpl; assumption.
    apply nfa_union_correct_left. assumption.
  - econstructor. instantiate (1 := Some (inr q')); simpl; assumption.
    apply nfa_union_correct_right. assumption.
Qed.

(** nfa_seq *****************************************************************************)

Section nfa_seq.

Definition nfa_seq A1 A2 : nfa :=
 {| nfa_s := inl (nfa_s A1);
    nfa_accept q a b :=
      match q with
        | inl q => [$ exists c | (nfa_accept q a c) && (nfa_accept (nfa_s A2) c b)]
        | inr q => nfa_accept q a b
      end;
    nfa_trans q a b q' :=
      match q,q' with
        | inl q, inl q' => nfa_trans q a b q'
        | inl q, inr q' => [$ exists c | (nfa_accept q a c) && (nfa_trans (nfa_s A2) c b q')]
        | inr q, inr q' => nfa_trans q a b q'
        | inr q, inl q' => false
      end
 |}.

Lemma bool_iff P1 P2 B1 B2 :
  (P1 <-> B1 = true) -> (P2 <-> B2 = true) -> (P1 <-> P2) -> B1=B2.
Proof.
  intros H1 H2 H.
  assert(B1 = true <-> B2 = true) by (rewrite <- H1; rewrite <- H2; assumption).
  case_eq B1; case_eq B2; intuition congruence.
Qed.

Lemma seq_inr A1 A2 q gs :
  @accept (nfa_seq A1 A2) (inr q) gs = accept q gs.
Proof.
  apply (bool_iff (@accept_prop (nfa_seq A1 A2) (inr q) gs) (accept_prop q gs));
  try apply accept_correct.
  destruct gs as [a w b].
  split; intro H; gd a; gd b; gd q; induction w; intros; invert H; simpl in *; auto.
  - destruct q'; eauto 4. invert H2.
  - econstructor. instantiate (1 := inr q'). simpl. assumption. eauto.
Qed.

Lemma seq_inl A1 A2 q s :
  (exists s1 s2, Some s = gs_conc s1 s2 /\ accept_prop q s1
                                        /\ accept_prop (nfa_s A2) s2)
  <-> (@accept (nfa_seq A1 A2) (inl q) s = true).
Proof.
  split; intro H.
  + destruct s as [a w c].
    destruct H as [[a' u b] [[b' v c'] [H1 [H2 H3]]]].
    apply accept_correct. gd a; gd w; gd c; gd b'; gd v; induction H2; intros.
    - rewrite <- conc_take_drop with (n:=0) (c:=b') in H1.
      simpl in H1. repeat split_if; invert H1; try congruence.
      invert H3.
      * left. simpl. apply exists_iff. exists b'. intuition.
      * eright. instantiate (1:=inr q'). simpl. apply exists_iff.
        exists b'. intuition. rewrite accept_correct in *. rewrite seq_inr.
        assumption.
   - simpl in H1. split_if; invert H1. eright. instantiate (1 := inl q').
     simpl; assumption. eapply IHaccept_prop. eassumption. simpl.
     split_if; intuition.
 + apply accept_correct in H. dependent induction H; simpl in H.
   - steffen. exists (a~([])~x); exists (x~([])~b). intuition eauto 2.
     simpl. split_if; intuition.
   - destruct q' as [q'|q'].
     * assert (exists s1 s2 : gs,
                  Some b~(w)~c = gs_conc s1 s2 /\
                  accept_prop q' s1 /\ accept_prop (nfa_s A2) s2) by eauto.
       steffen. destruct s1 as [b' u d]; destruct s2 as [d' v c'].
       simpl in H1. split_if; invert H1.
       exists a~(b'::u)~d'; exists d'~(v)~c'; intuition eauto 2.
       simpl. split_if; intuition.
     * steffen. exists a~([])~x; exists x~(b::w)~c; intuition eauto 2.
       simpl. split_if; intuition. eright with (q':=q'); eauto.
       rewrite accept_correct in *. rewrite <- seq_inr with (A1:=A1).
       assumption.
Qed.

Lemma nfa_seq_correct A1 A2 :
  nfa_lang (nfa_seq A1 A2) = gs_lang_conc (nfa_lang A1) (nfa_lang A2).
Proof.
  apply pred_eq_intro. intro gs. rewrite <- lang_conc_correct.
  unfold nfa_lang. simpl. rewrite <- seq_inl.
  split; intro H; destruct H as [s1 [s2 [H0 [H1 H2]]]];
  exists s1; exists s2; intuition; apply accept_correct; assumption.
Qed.

End nfa_seq.

(** nfa_star *****************************************************************************)
(* TO BE IMPLEMENTED *)

Parameter nfa_star : nfa -> nfa.

Axiom nfa_star_correct : forall A s,
  (exists n, gs_lang_power (nfa_lang A) n s = true) <-> (nfa_lang (nfa_star A) s = true).

(* NetKAT to NFA ***************************************************************)
(* this is Thompson's construction for NetKAT *)

Fixpoint netkat_nfa (p : policy) : nfa :=
match p with
  | Drop  => nfa_pred (fun _ _ => false)
  | Id    => nfa_pred (fun p p' => p =b= p')
  | Dup   => nfa_dup
  | f==n  => nfa_pred (fun p p' => (p =b= p') && ((p f) =b= n))
  | f!=n  => nfa_pred (fun p p' => (p =b= p') && ((p f) <b> n))
  | f<-n  => nfa_pred (fun p p' => p' =b= p[f:=n])
  | q+r   => nfa_union (netkat_nfa q) (netkat_nfa r)
  | q;;r  => nfa_seq (netkat_nfa q) (netkat_nfa r)
  | q*    => nfa_star (netkat_nfa q)
end.

Theorem netkat_nfa_correct (p : policy) a b v w :
  (| p |) (a,v) (b,w++v) <-> (a~(rev w)~b \in nfa_lang (netkat_nfa p) = true).
Proof.
  split; intro H.
  + dependent induction H; simpl;
    try (symmetry in x; rewrite <- app_nil_l in x; apply app_inv_tail in x; subst w);
    first [rewrite nfa_pred_correct | rewrite nfa_dup_correct |
           rewrite nfa_union_correct; apply lang_union_correct |
           rewrite nfa_seq_correct; apply lang_conc_correct | idtac];
    steffen; repeat split; eauto 3.
    - destruct h' as [c u']. destruct (bstep_prefix H) as [u H1]. subst u'.
      destruct (bstep_prefix H0) as [u' H1]. rewrite app_assoc in H1.
      assert (w=u'++u) by eauto using app_inv_tail. subst w. clear H1.
      rewrite rev_app_distr. exists (a~(rev u)~c); exists (c~(rev u')~b).
      simpl. rewrite <- app_assoc in IHbstep2. split_if; intuition eauto 2.
    - (* star case 1 *) admit.
    - (* star case 2 *) admit.
    - replace w with [b]. intuition.
      apply app_inv_tail with (l:=v). auto.
  + gd a; gd b; gd v; gd w; induction p; intros; simpl in *;
    first [rewrite nfa_pred_correct in H | rewrite nfa_dup_correct in H |
           rewrite nfa_union_correct in H; apply lang_union_correct in H |
           rewrite nfa_seq_correct in H; apply lang_conc_correct in H | idtac];
    steffen; intuition;
    try (assert (w=[]) by auto using rev_eq_nil; subst; simpl; eauto).
    - destruct s1 as [a' v' c]; destruct s2 as [c' u' b'].
      unfold gs_conc in H. split_if; invert H.
      assert (w = rev(v'++u')) by (rewrite <- H4; auto using rev_involutive). subst w.
      rewrite <- (rev_involutive v') in H0.
      rewrite <- (rev_involutive u') in H1.
      rewrite rev_app_distr. rewrite <- app_assoc.
      econstructor; eauto.
    - (* star case *) admit.
    - subst b. assert (w=[a]) by auto using rev_eq_singleton; subst w.
      simpl; eauto.
Qed.

End Automata.


Require Import VST.floyd.proofauto.
Require Import apile.
Require Import simple_spec_stdlib.
Require Import simple_spec_pile.
Require Import PileModel.

Instance APileCompSpecs : compspecs. make_compspecs prog. Defined.

Definition apile (sigma: list Z) (gv: globals): mpred :=
  !!(headptr (gv _a_pile)) && pilerep sigma (gv _a_pile).

Local Open Scope assert.

Definition Apile_add_spec :=
 DECLARE _Apile_add
 WITH n: Z, sigma: list Z, gv: globals
 PRE [ tint  ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (Vint (Int.repr n)) GLOBALS (gv)
    SEP(apile sigma gv; mem_mgr gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(apile (n::sigma) gv; mem_mgr gv).

Definition Apile_count_spec :=
 DECLARE _Apile_count
 WITH sigma: list Z, gv: globals
 PRE [  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS () GLOBALS (gv)
    SEP(apile sigma gv; mem_mgr gv)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(apile sigma gv; mem_mgr gv).

Definition ApileASI:funspecs := [ Apile_add_spec; Apile_count_spec].


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Rbase.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Rdefinitions.
Require Export Raxioms.
Require Export RIneq.
Require Export DiscrR.