(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(* A solver for subtyping constraints. *)

Require Import Recdef Coqlib Maps Errors.

Local Open Scope nat_scope.
Local Open Scope error_monad_scope.

(** This module provides a solver for sets of subtyping constraints of the
  following kinds: [base-type <: T(x)] or [T(x) <: base-type] or [T(x) <: T(y)].
  The unknowns are the types [T(x)] of every identifier [x]. *)

(** The interface for base types and the subtyping relation. *)

Module Type TYPE_ALGEBRA.

(** Type expressions *)

Variable t: Type.
Variable eq: forall (x y: t), {x=y} + {x<>y}.
Variable default: t.

(** Subtyping *)

Variable sub: t -> t -> Prop.
Hypothesis sub_refl: forall x, sub x x.
Hypothesis sub_trans: forall x y z, sub x y -> sub y z -> sub x z.
Variable sub_dec: forall x y, {sub x y} + {~sub x y}.

(** Least upper bounds. [lub x y] is specified only when [x] and [y] have
  a common supertype; it can be arbitrary otherwise. *)

Variable lub: t -> t -> t.
Hypothesis lub_left: forall x y z, sub x z -> sub y z -> sub x (lub x y).
Hypothesis lub_right: forall x y z, sub x z -> sub y z -> sub y (lub x y).
Hypothesis lub_min: forall x y z, sub x z -> sub y z -> sub (lub x y) z.

(** Greater lower bounds. [glb x y] is specified only when [x] and [y] have
  a common subtype; it can be arbitrary otherwise.*)

Variable glb: t -> t -> t.
Hypothesis glb_left: forall x y z, sub z x -> sub z y -> sub (glb x y) x.
Hypothesis glb_right: forall x y z, sub z x -> sub z y -> sub (glb x y) y.
Hypothesis glb_max: forall x y z, sub z x -> sub z y -> sub z (glb x y).

(** Low and high bounds for a given type. *)
Variable low_bound: t -> t.
Variable high_bound: t -> t.
Hypothesis low_bound_sub: forall t, sub (low_bound t) t.
Hypothesis low_bound_minorant: forall x y, sub x y -> sub (low_bound y) x.
Hypothesis high_bound_sub: forall t, sub t (high_bound t).
Hypothesis high_bound_majorant: forall x y, sub x y -> sub y (high_bound x).

(** Measure over types *)

Variable weight: t -> nat.
Variable max_weight: nat.
Hypothesis weight_range: forall t, weight t <= max_weight.
Hypothesis weight_sub: forall x y, sub x y -> weight x <= weight y.
Hypothesis weight_sub_strict: forall x y, sub x y -> x <> y -> weight x < weight y.

End TYPE_ALGEBRA.

(** The constraint solver. *)

Module SubSolver (T: TYPE_ALGEBRA).

(* The current set of constraints is represented by a record with two components:
- [te_typ]: a partial map from variables to pairs [tlo, thi]
  of types, representing the low and high bounds for this variable.
- [te_sub]: a list of pairs [(x,y)] of variables, indicating that
  the type of [x] must be a subtype of the type of [y].
*)

Inductive bounds : Type := B (lo: T.t) (hi: T.t) (SUB: T.sub lo hi).

Definition constraint : Type := (positive * positive)%type.

Record typenv : Type := Typenv {
  te_typ: PTree.t bounds;    (**r mapping var -> low & high bounds *)
  te_sub: list constraint    (**r additional subtyping constraints *)
}.

Definition initial : typenv := {| te_typ := PTree.empty _; te_sub := nil |}.

(** Add the constraint [ty <: T(x)]. *)

Definition type_def (e: typenv) (x: positive) (ty: T.t) : res typenv :=
  match e.(te_typ)!x with
  | None =>
      let b := B ty (T.high_bound ty) (T.high_bound_sub ty) in
      OK {| te_typ := PTree.set x b e.(te_typ);
            te_sub := e.(te_sub) |}
  | Some(B lo hi s1) =>
      match T.sub_dec ty hi with
      | left s2 =>
          let lo' := T.lub lo ty in
          if T.eq lo lo' then OK e else
            let b := B lo' hi (T.lub_min lo ty hi s1 s2) in
            OK {| te_typ := PTree.set x b e.(te_typ);
                  te_sub := e.(te_sub) |}
      | right _ =>
          Error (MSG "bad definition of variable " :: POS x :: nil)
      end
  end.

Fixpoint type_defs (e: typenv) (rl: list positive) (tyl: list T.t) {struct rl}: res typenv :=
  match rl, tyl with
  | nil, nil => OK e
  | r1::rs, ty1::tys => do e1 <- type_def e r1 ty1; type_defs e1 rs tys
  | _, _ => Error (msg "arity mismatch")
  end.

(** Add the constraint [T(x) <: ty]. *)

Definition type_use (e: typenv) (x: positive) (ty: T.t) : res typenv :=
  match e.(te_typ)!x with
  | None =>
      let b := B (T.low_bound ty) ty (T.low_bound_sub ty) in
      OK {| te_typ := PTree.set x b e.(te_typ);
            te_sub := e.(te_sub) |}
  | Some(B lo hi s1) =>
      match T.sub_dec lo ty with
      | left s2 =>
          let hi' := T.glb hi ty in
          if T.eq hi hi' then OK e else
            let b := B lo hi' (T.glb_max hi ty lo s1 s2) in
            OK {| te_typ := PTree.set x b e.(te_typ);
                  te_sub := e.(te_sub) |}
      | right _ =>
          Error (MSG "bad use of variable " :: POS x :: nil)
      end
  end.

Fixpoint type_uses (e: typenv) (rl: list positive) (tyl: list T.t) {struct rl}: res typenv :=
  match rl, tyl with
  | nil, nil => OK e
  | r1::rs, ty1::tys => do e1 <- type_use e r1 ty1; type_uses e1 rs tys
  | _, _ => Error (msg "arity mismatch")
  end.

(** Add the constraint [T(x) <: T(y)].
    The boolean result is [true] if the types of [r1] and [r2] could be
    made more precise.  Otherwise, [te_typ] does not change and
    [false] is returned. *)

Definition type_move (e: typenv) (r1 r2: positive) : res (bool * typenv) :=
  if peq r1 r2 then OK (false, e) else
  match e.(te_typ)!r1, e.(te_typ)!r2 with
  | None, None =>
      OK (false, {| te_typ := e.(te_typ); te_sub := (r1, r2) :: e.(te_sub) |})
  | Some(B lo1 hi1 s1), None =>
      let b2 := B lo1 (T.high_bound lo1) (T.high_bound_sub lo1) in
      OK (true, {| te_typ := PTree.set r2 b2 e.(te_typ);
                   te_sub := if T.sub_dec hi1 lo1 then e.(te_sub)
                             else (r1, r2) :: e.(te_sub) |})
  | None, Some(B lo2 hi2 s2) =>
      let b1 := B (T.low_bound hi2) hi2 (T.low_bound_sub hi2) in
      OK (true, {| te_typ := PTree.set r1 b1 e.(te_typ);
                   te_sub := if T.sub_dec hi2 lo2 then e.(te_sub)
                             else (r1, r2) :: e.(te_sub) |})
  | Some(B lo1 hi1 s1), Some(B lo2 hi2 s2) =>
      if T.sub_dec hi1 lo2 then
        (* The constraint is always true, don't record it *)
        OK (false, e)
      else match T.sub_dec lo1 hi2 with
      | left s =>
          (* Tighten the bounds on [r1] and [r2] when possible and record
             the constraint. *)
          let lo2' := T.lub lo1 lo2 in
          let hi1' := T.glb hi1 hi2 in
          let b1 := B lo1 hi1' (T.glb_max hi1 hi2 lo1 s1 s) in
          let b2 := B lo2' hi2 (T.lub_min lo1 lo2 hi2 s s2) in
          if T.eq lo2 lo2' then
            if T.eq hi1 hi1' then
              OK (false, {| te_typ := e.(te_typ);
                            te_sub := (r1, r2) :: e.(te_sub) |})
            else
              OK (true, {| te_typ := PTree.set r1 b1 e.(te_typ);
                           te_sub := (r1, r2) :: e.(te_sub) |})
          else
            if T.eq hi1 hi1' then
              OK (true, {| te_typ := PTree.set r2 b2 e.(te_typ);
                           te_sub := (r1, r2) :: e.(te_sub) |})
            else
              OK (true, {| te_typ := PTree.set r2 b2 (PTree.set r1 b1 e.(te_typ));
                           te_sub := (r1, r2) :: e.(te_sub) |})
      | right _ =>
          Error(MSG "ill-typed move from " :: POS r1 :: MSG " to " :: POS r2 :: nil)
      end
  end.

(** Solve the remaining subtyping constraints by iteration. *)

Fixpoint solve_rec (e: typenv) (changed: bool) (q: list constraint) : res (typenv * bool) :=
  match q with
  | nil =>
      OK (e, changed)
  | (r1, r2) :: q' =>
      do (changed1, e1) <- type_move e r1 r2; solve_rec e1 (changed || changed1) q'
  end.

(** Measuring the state *)

Definition weight_bounds (ob: option bounds) : nat :=
  match ob with None => T.max_weight + 1 | Some(B lo hi s) => T.weight hi - T.weight lo end.

Lemma weight_bounds_1:
  forall lo hi s, weight_bounds (Some (B lo hi s)) < weight_bounds None.
Proof.
  intros; simpl. generalize (T.weight_range hi); omega.
Qed.

Lemma weight_bounds_2:
  forall lo1 hi1 s1 lo2 hi2 s2,
  T.sub lo2 lo1 -> T.sub hi1 hi2 -> lo1 <> lo2 \/ hi1 <> hi2 ->
  weight_bounds (Some (B lo1 hi1 s1)) < weight_bounds (Some (B lo2 hi2 s2)).
Proof.
  intros; simpl.
  generalize (T.weight_sub _ _ s1) (T.weight_sub _ _ s2) (T.weight_sub _ _ H) (T.weight_sub _ _ H0); intros.
  destruct H1.
  assert (T.weight lo2 < T.weight lo1) by (apply T.weight_sub_strict; auto). omega.
  assert (T.weight hi1 < T.weight hi2) by (apply T.weight_sub_strict; auto). omega.
Qed.

Hint Resolve T.sub_refl: ty.

Lemma weight_type_move:
  forall e r1 r2 changed e',
  type_move e r1 r2 = OK(changed, e') ->
  (e'.(te_sub) = e.(te_sub) \/ e'.(te_sub) = (r1, r2) :: e.(te_sub))
  /\ (forall r, weight_bounds e'.(te_typ)!r <= weight_bounds e.(te_typ)!r)
  /\ (changed = true ->
        weight_bounds e'.(te_typ)!r1 + weight_bounds e'.(te_typ)!r2
        < weight_bounds e.(te_typ)!r1 + weight_bounds e.(te_typ)!r2).
Proof.
  unfold type_move; intros.
  destruct (peq r1 r2).
  inv H. split; auto. split; intros. omega. discriminate.
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- destruct (T.sub_dec hi1 lo2).
  inv H. split; auto. split; intros. omega. discriminate.
  destruct (T.sub_dec lo1 hi2); try discriminate.
  set (lo2' := T.lub lo1 lo2) in *.
  set (hi1' := T.glb hi1 hi2) in *.
  assert (S1': T.sub hi1' hi1) by (eapply T.glb_left; eauto).
  assert (S2': T.sub lo2 lo2') by (eapply T.lub_right; eauto).
  set (b1 := B lo1 hi1' (T.glb_max hi1 hi2 lo1 s1 s)) in *.
  set (b2 := B lo2' hi2 (T.lub_min lo1 lo2 hi2 s s2)) in *.
Local Opaque weight_bounds.
  destruct (T.eq lo2 lo2'); destruct (T.eq hi1 hi1'); inversion H; clear H; subst changed e'; simpl.
+ split; auto. split; intros. omega. discriminate.
+ assert (weight_bounds (Some b1) < weight_bounds (Some (B lo1 hi1 s1)))
  by (apply weight_bounds_2; auto with ty).
  split; auto. split; intros.
  rewrite PTree.gsspec. destruct (peq r r1). subst r. rewrite E1. omega. omega.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E2. omega.
+ assert (weight_bounds (Some b2) < weight_bounds (Some (B lo2 hi2 s2)))
  by (apply weight_bounds_2; auto with ty).
  split; auto. split; intros.
  rewrite PTree.gsspec. destruct (peq r r2). subst r. rewrite E2. omega. omega.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E1. omega.
+ assert (weight_bounds (Some b1) < weight_bounds (Some (B lo1 hi1 s1)))
  by (apply weight_bounds_2; auto with ty).
  assert (weight_bounds (Some b2) < weight_bounds (Some (B lo2 hi2 s2)))
  by (apply weight_bounds_2; auto with ty).
  split; auto. split; intros.
  rewrite ! PTree.gsspec.
  destruct (peq r r2). subst r. rewrite E2. omega.
  destruct (peq r r1). subst r. rewrite E1. omega.
  omega.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite PTree.gss. omega.

- set (b2 := B lo1 (T.high_bound lo1) (T.high_bound_sub lo1)) in *.
  assert (weight_bounds (Some b2) < weight_bounds None) by (apply weight_bounds_1).
  inv H; simpl.
  split. destruct (T.sub_dec hi1 lo1); auto.
  split; intros.
  rewrite PTree.gsspec. destruct (peq r r2). subst r; rewrite E2; omega. omega.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E1. omega.

- set (b1 := B (T.low_bound hi2) hi2 (T.low_bound_sub hi2)) in *.
  assert (weight_bounds (Some b1) < weight_bounds None) by (apply weight_bounds_1).
  inv H; simpl.
  split. destruct (T.sub_dec hi2 lo2); auto.
  split; intros.
  rewrite PTree.gsspec. destruct (peq r r1). subst r; rewrite E1; omega. omega.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E2. omega.

- inv H. split; auto. simpl; split; intros. omega. congruence.
Qed.

Definition weight_constraints (b: PTree.t bounds) (cstr: list constraint) : nat :=
  List.fold_right (fun xy n => n + weight_bounds b!(fst xy) + weight_bounds b!(snd xy)) 0 cstr.

Remark weight_constraints_tighter:
  forall b1 b2, (forall r, weight_bounds b1!r <= weight_bounds b2!r) ->
  forall q, weight_constraints b1 q <= weight_constraints b2 q.
Proof.
  induction q; simpl. omega. generalize (H (fst a)) (H (snd a)); omega.
Qed.

Lemma weight_solve_rec:
  forall q e changed e' changed',
  solve_rec e changed q = OK(e', changed') ->
  (forall r, weight_bounds e'.(te_typ)!r <= weight_bounds e.(te_typ)!r) /\
  weight_constraints e'.(te_typ) e'.(te_sub) + (if changed' && negb changed then 1 else 0)
     <= weight_constraints e.(te_typ) e.(te_sub) + weight_constraints e.(te_typ) q.
Proof.
  induction q; simpl; intros.
- inv H. split. intros; omega. replace (changed' && negb changed') with false.
  omega. destruct changed'; auto.
- destruct a as [r1 r2]; monadInv H; simpl.
  rename x into changed1. rename x0 into e1.
  exploit weight_type_move; eauto. intros [A [B C]].
  exploit IHq; eauto. intros [D E].
  split. intros. eapply le_trans. eapply D. eapply B.
  assert (P: weight_constraints (te_typ e1) (te_sub e) <=
             weight_constraints (te_typ e) (te_sub e))
  by (apply weight_constraints_tighter; auto).
  assert (Q: weight_constraints (te_typ e1) (te_sub e1) <=
             weight_constraints (te_typ e1) (te_sub e) +
             weight_bounds (te_typ e1)!r1 + weight_bounds (te_typ e1)!r2).
  { destruct A as [Q|Q]; rewrite Q. omega. simpl. omega. }
  assert (R: weight_constraints (te_typ e1) q <= weight_constraints (te_typ e) q)
  by (apply weight_constraints_tighter; auto).
  set (ch1 := if changed' && negb (changed || changed1) then 1 else 0) in *.
  set (ch2 := if changed' && negb changed then 1 else 0) in *.
  destruct changed1.
  assert (ch2 <= ch1 + 1).
  { unfold ch2, ch1. rewrite orb_true_r. simpl. rewrite andb_false_r.
    destruct (changed' && negb changed); omega. }
  exploit C; eauto. omega.
  assert (ch2 <= ch1).
  { unfold ch2, ch1. rewrite orb_false_r. omega. }
  generalize (B r1) (B r2); omega.
Qed.

Definition weight_typenv (e: typenv) : nat :=
  weight_constraints e.(te_typ) e.(te_sub).

(** Iterative solving of the remaining constraints *)

Function solve_constraints (e: typenv) {measure weight_typenv e}: res typenv :=
  match solve_rec {| te_typ := e.(te_typ); te_sub := nil |} false e.(te_sub) with
  | OK(e', false) => OK e                   (**r no more changes, fixpoint reached *)
  | OK(e', true)  => solve_constraints e'   (**r one more iteration *)
  | Error msg => Error msg
  end.
Proof.
  intros. exploit weight_solve_rec; eauto. simpl. intros [A B].
  unfold weight_typenv. omega.
Qed.

Definition typassign := positive -> T.t.

Definition makeassign (e: typenv) : typassign :=
  fun x => match e.(te_typ)!x with Some(B lo hi s) => lo | None => T.default end.

Definition solve (e: typenv) : res typassign :=
  do e' <- solve_constraints e; OK(makeassign e').

(** What it means to be a solution *)

Definition satisf (te: typassign) (e: typenv) : Prop :=
   (forall x lo hi s, e.(te_typ)!x = Some(B lo hi s) -> T.sub lo (te x) /\ T.sub (te x) hi)
/\ (forall x y, In (x, y) e.(te_sub) -> T.sub (te x) (te y)).

Lemma satisf_initial: forall te, satisf te initial.
Proof.
  unfold initial; intros; split; simpl; intros.
  rewrite PTree.gempty in H; discriminate.
  contradiction.
Qed.

(** Soundness proof *)

Lemma type_def_incr:
  forall te x ty e e', type_def e x ty = OK e' -> satisf te e' -> satisf te e.
Proof.
  unfold type_def; intros. destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec ty hi); try discriminate.
  destruct (T.eq lo (T.lub lo ty)); monadInv H.
  subst e'; auto.
  destruct H0 as [P Q]; split; auto; intros.
  destruct (peq x x0).
  + subst x0. rewrite E in H; inv H.
    exploit (P x); simpl. rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.lub lo0 ty); auto. eapply T.lub_left; eauto.
  + eapply P; simpl. rewrite PTree.gso; eauto.
- inv H. destruct H0 as [P Q]; split; auto; intros.
  eapply P; simpl. rewrite PTree.gso; eauto. congruence.
Qed.

Hint Resolve type_def_incr: ty.

Lemma type_def_sound:
  forall te x ty e e', type_def e x ty = OK e' -> satisf te e' -> T.sub ty (te x).
Proof.
  unfold type_def; intros. destruct H0 as [P Q].
  destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec ty hi); try discriminate.
  destruct (T.eq lo (T.lub lo ty)); monadInv H.
  + subst e'. apply T.sub_trans with lo.
    rewrite e0. eapply T.lub_right; eauto. eapply P; eauto.
  + apply T.sub_trans with (T.lub lo ty).
    eapply T.lub_right; eauto.
    eapply (P x). simpl. rewrite PTree.gss; eauto.
- inv H. eapply (P x); simpl. rewrite PTree.gss; eauto.
Qed.

Lemma type_defs_incr:
  forall te xl tyl e e', type_defs e xl tyl = OK e' -> satisf te e' -> satisf te e.
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H; eauto with ty.
Qed.

Hint Resolve type_defs_incr: ty.

Lemma type_defs_sound:
  forall te xl tyl e e', type_defs e xl tyl = OK e' -> satisf te e' -> list_forall2 T.sub tyl (map te xl).
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H.
  constructor.
  constructor; eauto. eapply type_def_sound; eauto with ty.
Qed.

Lemma type_use_incr:
  forall te x ty e e', type_use e x ty = OK e' -> satisf te e' -> satisf te e.
Proof.
  unfold type_use; intros. destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec lo ty); try discriminate.
  destruct (T.eq hi (T.glb hi ty)); monadInv H.
  subst e'; auto.
  destruct H0 as [P Q]; split; auto; intros.
  destruct (peq x x0).
  + subst x0. rewrite E in H; inv H.
    exploit (P x); simpl. rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.glb hi0 ty); auto. eapply T.glb_left; eauto.
  + eapply P; simpl. rewrite PTree.gso; eauto.
- inv H. destruct H0 as [P Q]; split; auto; intros.
  eapply P; simpl. rewrite PTree.gso; eauto. congruence.
Qed.

Hint Resolve type_use_incr: ty.

Lemma type_use_sound:
  forall te x ty e e', type_use e x ty = OK e' -> satisf te e' -> T.sub (te x) ty.
Proof.
  unfold type_use; intros. destruct H0 as [P Q].
  destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec lo ty); try discriminate.
  destruct (T.eq hi (T.glb hi ty)); monadInv H.
  + subst e'. apply T.sub_trans with hi.
    eapply P; eauto. rewrite e0. eapply T.glb_right; eauto.
  + apply T.sub_trans with (T.glb hi ty).
    eapply (P x). simpl. rewrite PTree.gss; eauto.
    eapply T.glb_right; eauto.
- inv H. eapply (P x); simpl. rewrite PTree.gss; eauto.
Qed.

Lemma type_uses_incr:
  forall te xl tyl e e', type_uses e xl tyl = OK e' -> satisf te e' -> satisf te e.
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H; eauto with ty.
Qed.

Hint Resolve type_uses_incr: ty.

Lemma type_uses_sound:
  forall te xl tyl e e', type_uses e xl tyl = OK e' -> satisf te e' -> list_forall2 T.sub (map te xl) tyl.
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H.
  constructor.
  constructor; eauto. eapply type_use_sound; eauto with ty.
Qed.

Lemma type_move_incr:
  forall te e r1 r2 e' changed,
  type_move e r1 r2 = OK(changed, e') -> satisf te e' -> satisf te e.
Proof.
  unfold type_move; intros. destruct H0 as [P Q].
  destruct (peq r1 r2). inv H; split; auto.
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- destruct (T.sub_dec hi1 lo2). inv H; split; auto.
  destruct (T.sub_dec lo1 hi2); try discriminate.
  set (lo := T.lub lo1 lo2) in *. set (hi := T.glb hi1 hi2) in *.
  destruct (T.eq lo2 lo); destruct (T.eq hi1 hi); monadInv H; simpl in *.
  + subst e'; simpl in *. split; auto.
  + subst e'; simpl in *. split; auto. intros. destruct (peq x r1).
    subst x.
    rewrite E1 in H. injection H; intros; subst lo0 hi0.
    exploit (P r1). rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.glb hi1 hi2); auto. eapply T.glb_left; eauto.
    eapply P. rewrite PTree.gso; eauto.
  + subst e'; simpl in *. split; auto. intros. destruct (peq x r2).
    subst x.
    rewrite E2 in H. injection H; intros; subst lo0 hi0.
    exploit (P r2). rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.lub lo1 lo2); auto. eapply T.lub_right; eauto.
    eapply P. rewrite PTree.gso; eauto.
  + split; auto. intros.
    destruct (peq x r1). subst x.
    rewrite E1 in H. injection H; intros; subst lo0 hi0.
    exploit (P r1). rewrite PTree.gso; eauto. rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.glb hi1 hi2); auto. eapply T.glb_left; eauto.
    destruct (peq x r2). subst x.
    rewrite E2 in H. injection H; intros; subst lo0 hi0.
    exploit (P r2). rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.lub lo1 lo2); auto. eapply T.lub_right; eauto.
    eapply P. rewrite ! PTree.gso; eauto.
- inv H; simpl in *. split; intros.
  eapply P. rewrite PTree.gso; eauto. congruence.
  apply Q.   destruct (T.sub_dec hi1 lo1); auto with coqlib.
- inv H; simpl in *. split; intros.
  eapply P. rewrite PTree.gso; eauto. congruence.
  apply Q.   destruct (T.sub_dec hi2 lo2); auto with coqlib.
- inv H; simpl in *. split; auto.
Qed.

Hint Resolve type_move_incr: ty.

Lemma type_move_sound:
  forall te e r1 r2 e' changed,
  type_move e r1 r2 = OK(changed, e') -> satisf te e' -> T.sub (te r1) (te r2).
Proof.
  unfold type_move; intros. destruct H0 as [P Q].
  destruct (peq r1 r2). subst r2. apply T.sub_refl.
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- destruct (T.sub_dec hi1 lo2).
  inv H. apply T.sub_trans with hi1. eapply P; eauto. apply T.sub_trans with lo2; auto. eapply P; eauto.
  destruct (T.sub_dec lo1 hi2); try discriminate.
  set (lo := T.lub lo1 lo2) in *. set (hi := T.glb hi1 hi2) in *.
  destruct (T.eq lo2 lo); destruct (T.eq hi1 hi); monadInv H; simpl in *.
  + subst e'; simpl in *. apply Q; auto.
  + subst e'; simpl in *. apply Q; auto.
  + subst e'; simpl in *. apply Q; auto.
  + apply Q; auto.
- inv H; simpl in *. destruct (T.sub_dec hi1 lo1).
  + apply T.sub_trans with hi1. eapply P; eauto. rewrite PTree.gso; eauto.
    apply T.sub_trans with lo1; auto. eapply P. rewrite PTree.gss; eauto.
  + auto with coqlib.
- inv H; simpl in *. destruct (T.sub_dec hi2 lo2).
  + apply T.sub_trans with hi2. eapply P. rewrite PTree.gss; eauto.
    apply T.sub_trans with lo2; auto. eapply P. rewrite PTree.gso; eauto.
  + auto with coqlib.
- inv H. simpl in Q; auto.
Qed.

Lemma solve_rec_incr:
  forall te q e changed e' changed',
  solve_rec e changed q = OK(e', changed') -> satisf te e' -> satisf te e.
Proof.
  induction q; simpl; intros.
- inv H. auto.
- destruct a as [r1 r2]; monadInv H. eauto with ty.
Qed.

Lemma solve_rec_sound:
  forall te r1 r2 q e changed e' changed',
  solve_rec e changed q = OK(e', changed') -> In (r1, r2) q -> satisf te e' ->
  T.sub (te r1) (te r2).
Proof.
  induction q; simpl; intros.
- contradiction.
- destruct a as [r3 r4]; monadInv H. destruct H0.
  + inv H. eapply type_move_sound; eauto. eapply solve_rec_incr; eauto.
  + eapply IHq; eauto with ty.
Qed.

Lemma type_move_false:
  forall e r1 r2 e',
  type_move e r1 r2 = OK(false, e') ->
  te_typ e' = te_typ e /\ T.sub (makeassign e r1) (makeassign e r2).
Proof.
  unfold type_move; intros.
  destruct (peq r1 r2). inv H. split; auto. apply T.sub_refl.
  unfold makeassign;
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- destruct (T.sub_dec hi1 lo2).
  inv H. split; auto. eapply T.sub_trans; eauto.
  destruct (T.sub_dec lo1 hi2); try discriminate.
  set (lo := T.lub lo1 lo2) in *. set (hi := T.glb hi1 hi2) in *.
  destruct (T.eq lo2 lo); destruct (T.eq hi1 hi); try discriminate.
  monadInv H. split; auto. rewrite e0. unfold lo. eapply T.lub_left; eauto.
- discriminate.
- discriminate.
- inv H. split; auto. apply T.sub_refl.
Qed.

Lemma solve_rec_false:
  forall r1 r2 q e changed e',
  solve_rec e changed q = OK(e', false) ->
  changed = false /\
  (In (r1, r2) q -> T.sub (makeassign e r1) (makeassign e r2)).
Proof.
  induction q; simpl; intros.
- inv H. tauto.
- destruct a as [r3 r4]; monadInv H.
  exploit IHq; eauto. intros [P Q].
  destruct changed; try discriminate. destruct x; try discriminate.
  exploit type_move_false; eauto. intros [U V].
  split. auto. intros [A|A]. inv A. auto. exploit Q; auto.
  unfold makeassign; rewrite U; auto.
Qed.

Lemma solve_constraints_incr:
  forall te e e', solve_constraints e = OK e' -> satisf te e' -> satisf te e.
Proof.
  intros te e; functional induction (solve_constraints e); intros.
- inv H. auto.
- exploit solve_rec_incr; eauto. intros [A B].
  split; auto. intros; eapply solve_rec_sound; eauto.
- discriminate.
Qed.

Lemma solve_constraints_sound:
  forall e e', solve_constraints e = OK e' -> satisf (makeassign e') e'.
Proof.
  intros e0; functional induction (solve_constraints e0); intros.
- inv H. split; intros.
  unfold makeassign; rewrite H. split; auto with ty.
  exploit solve_rec_false. eauto. intros [A B]. eapply B; eauto.
- eauto.
- discriminate.
Qed.

Theorem solve_sound:
  forall e te, solve e = OK te -> satisf te e.
Proof.
  unfold solve; intros. monadInv H.
  eapply solve_constraints_incr. eauto. eapply solve_constraints_sound; eauto.
Qed.

(** Completeness proof *)

Lemma type_def_complete:
  forall te e x ty,
  satisf te e -> T.sub ty (te x) -> exists e', type_def e x ty = OK e' /\ satisf te e'.
Proof.
  unfold type_def; intros. destruct H as [P Q].
  destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec ty hi).
  destruct (T.eq lo (T.lub lo ty)).
  exists e; split; auto. split; auto.
  econstructor; split; eauto. split; simpl; auto; intros.
  rewrite PTree.gsspec in H. destruct (peq x0 x).
  inv H. exploit P; eauto. intuition. eapply T.lub_min; eauto.
  eapply P; eauto.
  elim n. apply T.sub_trans with (te x); auto. eapply P; eauto.
- econstructor; split; eauto. split; simpl; auto; intros.
  rewrite PTree.gsspec in H. destruct (peq x0 x).
  inv H. split; auto. apply T.high_bound_majorant; auto.
  eapply P; eauto.
Qed.

Lemma type_defs_complete:
  forall te xl tyl e,
  satisf te e -> list_forall2 T.sub tyl (map te xl) ->
  exists e', type_defs e xl tyl = OK e' /\ satisf te e'.
Proof.
  induction xl; intros; inv H0; simpl.
  econstructor; eauto.
  exploit (type_def_complete te e a a1); auto. intros (e1 & P & Q).
  exploit (IHxl al e1); auto. intros (e2 & U & V).
  exists e2; split; auto. rewrite P; auto.
Qed.

Lemma type_use_complete:
  forall te e x ty,
  satisf te e -> T.sub (te x) ty -> exists e', type_use e x ty = OK e' /\ satisf te e'.
Proof.
  unfold type_use; intros. destruct H as [P Q].
  destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec lo ty).
  destruct (T.eq hi (T.glb hi ty)).
  exists e; split; auto. split; auto.
  econstructor; split; eauto. split; simpl; auto; intros.
  rewrite PTree.gsspec in H. destruct (peq x0 x).
  inv H. exploit P; eauto. intuition. eapply T.glb_max; eauto.
  eapply P; eauto.
  elim n. apply T.sub_trans with (te x); auto. eapply P; eauto.
- econstructor; split; eauto. split; simpl; auto; intros.
  rewrite PTree.gsspec in H. destruct (peq x0 x).
  inv H. split; auto. apply T.low_bound_minorant; auto.
  eapply P; eauto.
Qed.

Lemma type_uses_complete:
  forall te xl tyl e,
  satisf te e -> list_forall2 T.sub (map te xl) tyl ->
  exists e', type_uses e xl tyl = OK e' /\ satisf te e'.
Proof.
  induction xl; intros; inv H0; simpl.
  econstructor; eauto.
  exploit (type_use_complete te e a b1); auto. intros (e1 & P & Q).
  exploit (IHxl bl e1); auto. intros (e2 & U & V).
  exists e2; split; auto. rewrite P; auto.
Qed.

Lemma type_move_complete:
  forall te e r1 r2,
  satisf te e -> T.sub (te r1) (te r2) ->
  exists changed e', type_move e r1 r2 = OK(changed, e') /\ satisf te e'.
Proof.
  unfold type_move; intros. elim H; intros P Q.
  assert (Q': forall x y, In (x, y) ((r1, r2) :: te_sub e) -> T.sub (te x) (te y)).
  { intros. destruct H1; auto. congruence. }
  destruct (peq r1 r2). econstructor; econstructor; eauto.
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- exploit (P r1); eauto. intros [L1 U1].
  exploit (P r2); eauto. intros [L2 U2].
  destruct (T.sub_dec hi1 lo2). econstructor; econstructor; eauto.
  destruct (T.sub_dec lo1 hi2).
  destruct (T.eq lo2 (T.lub lo1 lo2)); destruct (T.eq hi1 (T.glb hi1 hi2));
  econstructor; econstructor; split; eauto; split; auto; simpl; intros.
  + rewrite PTree.gsspec in H1. destruct (peq x r1).
    clear e0. inv H1. split; auto.
    apply T.glb_max. auto. apply T.sub_trans with (te r2); auto.
    eapply P; eauto.
  + rewrite PTree.gsspec in H1. destruct (peq x r2).
    clear e0. inv H1. split; auto.
    apply T.lub_min. apply T.sub_trans with (te r1); auto. auto.
    eapply P; eauto.
  + rewrite ! PTree.gsspec in H1. destruct (peq x r2).
    inv H1. split; auto. apply T.lub_min; auto. apply T.sub_trans with (te r1); auto.
    destruct (peq x r1).
    inv H1. split; auto. apply T.glb_max; auto. apply T.sub_trans with (te r2); auto.
    eapply P; eauto.
  + elim n1. apply T.sub_trans with (te r1); auto.
    apply T.sub_trans with (te r2); auto.
- econstructor; econstructor; split; eauto; split.
  + simpl; intros. rewrite PTree.gsspec in H1. destruct (peq x r2).
    inv H1. exploit P; eauto. intuition.
    apply T.sub_trans with (te r1); auto.
    apply T.high_bound_majorant. apply T.sub_trans with (te r1); auto.
    eapply P; eauto.
  + destruct (T.sub_dec hi1 lo1); auto.
- econstructor; econstructor; split; eauto; split.
  + simpl; intros. rewrite PTree.gsspec in H1. destruct (peq x r1).
    inv H1. exploit P; eauto. intuition.
    apply T.low_bound_minorant. apply T.sub_trans with (te r2); auto.
    apply T.sub_trans with (te r2); auto.
    eapply P; eauto.
  + destruct (T.sub_dec hi2 lo2); auto.
- econstructor; econstructor; split; eauto; split; auto.
Qed.

Lemma solve_rec_complete:
  forall te q e changed,
  satisf te e ->
  (forall r1 r2, In (r1, r2) q -> T.sub (te r1) (te r2)) ->
  exists e' changed', solve_rec e changed q = OK(e', changed') /\ satisf te e'.
Proof.
  induction q; simpl; intros.
- econstructor; econstructor; eauto.
- destruct a as [r1 r2].
  exploit (type_move_complete te e r1 r2); auto. intros (changed1 & e1 & A & B).
  exploit (IHq e1 (changed || changed1)); auto. intros (e' & changed' & C & D).
  exists e'; exists changed'. rewrite A; simpl; rewrite C; auto.
Qed.

Lemma solve_constraints_complete:
  forall te e, satisf te e -> exists e', solve_constraints e = OK e' /\ satisf te e'.
Proof.
  intros te e. functional induction (solve_constraints e); intros.
- exists e; auto.
- exploit (solve_rec_complete te (te_sub e) {| te_typ := te_typ e; te_sub := nil |} false).
  destruct H; split; auto. simpl; tauto.
  destruct H; auto.
  intros (e1 & changed1 & P & Q).
  apply IHr. congruence.
- exploit (solve_rec_complete te (te_sub e) {| te_typ := te_typ e; te_sub := nil |} false).
  destruct H; split; auto. simpl; tauto.
  destruct H; auto.
  intros (e1 & changed1 & P & Q).
  congruence.
Qed.

Lemma solve_complete:
  forall te e, satisf te e -> exists te', solve e = OK te'.
Proof.
  intros. unfold solve.
  destruct (solve_constraints_complete te e H) as (e' & P & Q).
  econstructor. rewrite P. simpl. eauto.
Qed.

End SubSolver.


Require Import PerformanceExperiments.Harness.

Fixpoint and_True (n : nat)
  := match n with
     | 0 => True
     | S n => True /\ and_True n
     end.

Definition args_of_size (s : size) : list nat
  := match s with
     | Sanity => seq 1 3
     | SuperFast => seq 1 100
     | Fast => seq 100 200
                   ++ List.map (fun x => 200 + x * 2) (seq 0 50)
                   ++ List.map (fun x => 300 + x * 5) (seq 0 20)
                   ++ List.map (fun x => 400 + x * 10) (seq 0 10)
                   ++ List.map (fun x => 500 + x * 50) (seq 0 10)
                   ++ List.map (fun x => 1000 + x * 100) (seq 0 10)
     | Medium => []
     | Slow => []
     | VerySlow => []
     end.

Ltac preshare_pf G cont :=
  lazymatch G with
  | True => cont True I
  | ?L /\ ?R
    => preshare_pf
         L ltac:(
         fun L l
         => preshare_pf
              R ltac:(
              fun R r
              => let H := fresh in
                 pose (and L R) as H;
                 cont H uconstr:(@conj L R l r)))
  | _ => fail 0 "invalid:" G
  end.

Ltac fast_conj :=
  time "pose build and refine"
       (let G := match goal with |- ?G => G end in
        refine (_ : G);
        preshare_pf
          G ltac:(fun G pf => time "refine" refine pf)).

Ltac mkgoal n := constr:(and_True (pred n)).
Ltac redgoal _ := vm_compute.
Ltac time_solve_goal0 n :=
  cut True;
  [ intros _;
    time "abstract-fast_conj"
         abstract
         (cut True;
          [ intros _;
            time "fast_conj" fast_conj
          | restart_timer; exact I ])
  | finish_timing ("Tactic call close-abstract") ].

Ltac run0 sz := Harness.runtests args_of_size default_describe_goal mkgoal redgoal time_solve_goal0 sz.
(*
Goal True. run0 SuperFast.
*)


Require Import VST.floyd.proofauto.
Require Import Core.Core Core.Notations Core.Notations Types.
Require Import ExtLib.Structures.Monad.
Require Import BFT.Exec BFL.Exec VST.floyd.sublist.

(* assuming ctx is not null *)

Open Scope Z.

Definition ASN__STACK_OVERFLOW_CHECK used_stack max_stack_size :=
  if eq_dec max_stack_size 0
  then 0
  else if  max_stack_size <? used_stack
       then -1
       else 0.

Open Scope bool.

Definition ber_check_tags_primitive ts td ctx size sizeofval sizemax:
  option (Z * Z) :=
  if ASN__STACK_OVERFLOW_CHECK 0 ctx =? 0
  then let (tag_len, tlv_tag) := ber_fetch_tags ts size  in
       if (tag_len =? -1) || (tag_len =? 0) then None
       else
         if (Int.unsigned tlv_tag =? nth O (tags td) 0)
         then
           let (len_len, tlv_len) := ber_fetch_len
                                       (sublist 1 (len ts)
                                                (map Int.unsigned ts))
                                                0 0 (size - tag_len)
                                                sizeofval sizemax in
           if (len_len =? -1) || (len_len =? 0) then None
           else
             let limit_len := tlv_len + tag_len + len_len in
             if limit_len <? 0 then None
             else Some (tlv_len, tag_len + len_len)
         else None
  else None.

(*
Parameter ber_fetch_tag : Z -> Z.
Parameter ber_fetch_length : bool-> Z -> Z.
Parameter constructed : list Z -> bool.
Parameter ber_check_tags_loop : Z -> Z -> Z -> option Z.

Open Scope bool.

(* checks the tag, outputs consumed length and expected length *)
Definition ber_check_tags ts td ctx tag_mode size step :
  option Z :=
  if asn_stack_overflow_check ctx
  then Some (-1)
  else
    let tagno := step + (if tag_mode =? 1 then -1 else 0) in
    if (tag_mode =? 0) || (0 <? len (tags td))
    then
      let tag_len := ber_fetch_tag size in
      if (tag_len =? -1) || (tag_len =? 0)
      then None
      else let len_len := ber_fetch_length (constructed ts) (size - tag_len) in
           if (len_len =? -1) || (len_len =? 0)
           then None
           else let size := size - tag_len - len_len in
                ber_check_tags_loop tagno size step
    else ber_check_tags_loop tagno size step.

(*
Theorem ber_check_tags_bool_res : forall td ls,
    decoder_type td = BOOLEAN_t ->
    ber_check_tags td ls = Some (mk_check_tag 2 1)
    \/ ber_check_tags td ls = None.
Proof.
  intros.
  unfold ber_check_tags; rewrite H.
  repeat break_match; auto.
Qed.

Theorem ber_check_tags_bool_Some : forall td ls,
    decoder_type td = BOOLEAN_t ->
    ber_check_tags td (Byte.one::Byte.one::ls) =
    Some (mk_check_tag 2 1).
Proof.
  intros.
  unfold ber_check_tags.
  rewrite H.
  reflexivity.
Qed.

Theorem ber_check_tags_bool_Some_intro : forall td ls,
    decoder_type td = BOOLEAN_t ->
    ber_check_tags td ls = Some (mk_check_tag 2 1) ->
    exists tl, ls = 1%byte::1%byte::tl.
Proof.
  intros td ls DT.
  unfold ber_check_tags.
  repeat break_match; try discriminate.
  intros.
  unfold andb in Heqb; repeat break_match_hyp; try discriminate.
  pose proof Byte.eq_spec i 1%byte as T; rewrite Heqb0 in T.
  pose proof Byte.eq_spec i0 1%byte as T1; rewrite Heqb in T1.
  rewrite T, T1.
  exists l0; reflexivity.
Qed.
*) *)


Set Implicit Arguments.

Require Import Coq.Arith.EqNat.
Require Import NPeano.
Require Import Arith.Peano_dec.
Require Import Bool.Bool.
Require Import Coq.Classes.Equivalence.
Require Import Lists.List.

Require Import Word.WordInterface.
Require Import Network.NetworkPacket.
Require Import Common.Types.
Require Import Pattern.Pattern.
Require Import Pattern.Valid.
Require Import Wildcard.Wildcard.
Require Import Wildcard.Theory.

Open Scope bool_scope.
Open Scope list_scope.
Open Scope equiv_scope.

Create HintDb pattern.

Lemma IP_ARP_frametyp_neq : Const_0x800 <> Const_0x806.
Proof with auto.
  assert ({ Const_0x800 = Const_0x806 } + { Const_0x800 <> Const_0x806 }).
  apply Word16.eq_dec.
  unfold Const_0x800 in *.
  unfold Const_0x806 in *.
  destruct H.
  inversion e.
  trivial.
Qed.

Module PatMatchable.

  Definition t := pattern.

  Definition inter := Pattern.inter.
  Definition empty := Pattern.empty.
  Definition is_empty := Pattern.is_empty.
  Definition is_exact := Pattern.is_exact.

  Hint Unfold inter empty is_empty
    Pattern.inter Pattern.empty Pattern.is_empty.

  Hint Resolve Word8.eq_dec Word16.eq_dec Word32.eq_dec Word48.eq_dec.

  Lemma inter_comm : forall p p', inter p p' = inter p' p.
  Proof with auto.
    intros.
    destruct p.
    destruct p'.
    unfold inter.
    unfold Pattern.inter.
    simpl.
    rewrite -> (inter_comm _ ptrnDlSrc0).
    rewrite -> (inter_comm _ ptrnDlDst0).
    rewrite -> (inter_comm _ ptrnDlType0).
    rewrite -> (inter_comm _ ptrnDlVlan0).
    rewrite -> (inter_comm _ ptrnDlVlanPcp0).
    rewrite -> (inter_comm _ ptrnNwSrc0).
    rewrite -> (inter_comm _ ptrnNwDst0).
    rewrite -> (inter_comm _ ptrnNwTos0).
    rewrite -> (inter_comm _ ptrnTpSrc0).
    rewrite -> (inter_comm _ ptrnTpDst0).
    rewrite -> (inter_comm _ ptrnInPort0).
    rewrite -> (inter_comm _ ptrnNwProto0).
    reflexivity.
  Qed.

  Lemma inter_assoc : forall p p' p'',
    inter p (inter p' p'') = inter (inter p p') p''.
  Proof with simpl; auto.
    intros.
    unfold inter.
    unfold Pattern.inter.
    simpl.
    repeat rewrite -> inter_assoc...
  Qed.

  Lemma is_empty_false_distr_l : forall x y,
    is_empty (inter x y) = false ->
    is_empty x = false .
  Proof with simpl; eauto.
    intros.
    unfold inter in H.
    unfold Pattern.inter in H.
    simpl in H.
    repeat rewrite -> orb_false_iff in H.
    do 11 (destruct H).
    unfold is_empty.
    unfold Pattern.is_empty.
    destruct x.
    destruct y.
    simpl in *.
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    erewrite -> is_empty_false_distr_l; [ idtac | eauto ].
    reflexivity.
  Qed.

  Lemma is_empty_false_distr_r : forall x y,
    is_empty (inter x y) = false ->
    is_empty y = false .
  Proof.
    intros.
    rewrite -> inter_comm in H.
    eapply is_empty_false_distr_l.
    exact H.
  Qed.

  Lemma is_empty_true_l : forall x y,
    is_empty x = true ->
    is_empty (inter x y) = true.
  Proof with auto.
    intros.
    destruct x.
    destruct y.
    simpl in *.
    repeat rewrite -> orb_true_iff in H.
    repeat rewrite -> or_assoc in H.
    repeat rewrite -> orb_true_iff.
    repeat rewrite -> or_assoc.
    repeat (destruct H; auto 13 with wildcard).
  Qed.

  Lemma is_empty_true_r : forall x y,
    is_empty y = true ->
    is_empty (inter x y) = true.
  Proof with auto.
    intros.
    rewrite inter_comm.
    apply is_empty_true_l...
  Qed.

  Lemma is_match_false_inter_l :
    forall (pt : portId) (pkt : packet) pat1 pat2,
      Pattern.match_packet pt pkt pat1 = false ->
      Pattern.match_packet pt pkt (inter pat1 pat2) = false.
  Proof with auto.
    intros.
    unfold Pattern.match_packet in *.
    rewrite -> negb_false_iff in H.
    rewrite -> negb_false_iff.
    rewrite -> inter_assoc.
    apply is_empty_true_l...
  Qed.

  Lemma no_match_subset_r : forall k n t t',
    Pattern.match_packet n k t' = false ->
    Pattern.match_packet n k (inter t t') = false.
  Proof with auto.
    intros.
    rewrite -> inter_comm.
    apply is_match_false_inter_l...
  Qed.

  Lemma exact_match_inter : forall x y,
    is_exact x = true ->
    is_empty (inter x y) = false ->
    inter x y = x.
  Proof with auto.
    intros.
    destruct x. destruct y. simpl in *.
    repeat rewrite -> andb_true_iff in H.
    do 11 (destruct H).
    repeat rewrite -> orb_false_iff in H0.
    do 11 (destruct H0).
    unfold inter.
    unfold Pattern.inter.
    simpl.
    repeat rewrite -> exact_match_inter_l...
  Qed.

  Lemma all_spec : forall pt pk,
    Pattern.match_packet pt pk Pattern.all = true.
  Proof with auto.
    intros.
    unfold Pattern.match_packet.
    rewrite -> negb_true_iff.
    unfold Pattern.all.
    destruct pk.
    unfold Pattern.exact_pattern.
    unfold Pattern.inter.
    unfold Pattern.Wildcard_of_option in *.
    destruct pktTpSrc; destruct pktTpDst; simpl...
  Qed.

  Lemma exact_match_is_exact : forall pk pt,
    Pattern.is_exact (Pattern.exact_pattern pk pt) = true.
  Proof with auto.
    intros.
    unfold Pattern.exact_pattern.
    unfold Pattern.is_exact.
    unfold Wildcard.is_exact.
    simpl.
    unfold Pattern.Wildcard_of_option.
    simpl.
    destruct (pktTpSrc pk); destruct (pktTpDst pk)...
  Qed.

  Lemma exact_intersect : forall k n t,
    Pattern.match_packet k n t = true ->
    Pattern.inter (Pattern.exact_pattern n k) t = Pattern.exact_pattern n k.
  Proof with auto.
    intros.
    unfold Pattern.match_packet in H.
    rewrite -> negb_true_iff in H.
    apply exact_match_inter...
  Qed.

  Lemma is_match_true_inter : forall pat1 pat2 pt pk,
    Pattern.match_packet pt pk pat1 = true ->
    Pattern.match_packet pt pk pat2 = true ->
    Pattern.match_packet pt pk (Pattern.inter pat1 pat2) = true.
  Proof with auto.
    intros.
    apply exact_intersect in H.
    apply exact_intersect in H0.
    unfold Pattern.match_packet.
    rewrite -> negb_true_iff.
    rewrite -> inter_assoc.
    unfold inter.
    rewrite -> H.
    rewrite -> H0.
    unfold Pattern.exact_pattern.
    unfold Pattern.is_empty.
    simpl.
    unfold Pattern.Wildcard_of_option.
    destruct (pktTpSrc pk); destruct (pktTpDst pk)...
  Qed.

  Hint Rewrite inter_assoc : pattern.
  Hint Resolve is_empty_false_distr_l is_empty_false_distr_r : pattern.
  Hint Resolve is_empty_true_l is_empty_true_r : pattern.
  Hint Resolve is_match_false_inter_l : pattern.
  Hint Resolve all_spec : pattern.
  Hint Resolve exact_match_is_exact : pattern.
  Hint Resolve exact_intersect : pattern.
  Hint Resolve is_match_true_inter : pattern.

  Hint Resolve is_empty_true_l is_empty_true_r.

  Hint Constructors ValidPattern.

  Lemma pres0 : forall dlSrc dlDst dlTyp dlVlan dlVlanPcp nwSrc nwDst
    nwProto nwProto' nwTos tpSrc tpDst inPort,
    nwProto <> nwProto' ->
    ValidPattern (Pattern dlSrc dlDst dlTyp dlVlan dlVlanPcp nwSrc nwDst
                            (Wildcard.inter Word8.eq_dec
                                (WildcardExact nwProto)
                                (WildcardExact nwProto'))
                            nwTos tpSrc tpDst inPort).
  Proof with auto with wildcard.
    intros.
    apply ValidPat_None.
    simpl.
    repeat rewrite -> orb_true_iff.
    repeat rewrite -> or_assoc.
    rewrite -> inter_exact_neq...
    simpl.
    auto 13.
  Qed.

  Hint Immediate pres0.

  Lemma pres1 : forall dlSrc dlDst dlTyp dlVlan dlVlanPcp nwSrc nwDst
    nwProto nwProto' nwTos tpSrc tpDst inPort,
    In nwProto SupportedNwProto ->
    ~ In nwProto' SupportedNwProto ->
    ValidPattern (Pattern dlSrc dlDst dlTyp dlVlan dlVlanPcp nwSrc nwDst
                            (Wildcard.inter Word8.eq_dec
                                (WildcardExact nwProto)
                                (WildcardExact nwProto'))
                            nwTos tpSrc tpDst inPort).
  Proof with auto.
    intros.
    pose (X := Word8.eq_dec nwProto nwProto').
    destruct X; subst...
  Qed.

  Hint Immediate pres1.

  Lemma pres1' : forall dlSrc dlDst dlTyp dlVlan dlVlanPcp nwSrc nwDst
    nwProto nwProto' nwTos tpSrc tpDst inPort,
    ~ In nwProto SupportedNwProto ->
    In nwProto' SupportedNwProto ->
    ValidPattern (Pattern dlSrc dlDst dlTyp dlVlan dlVlanPcp nwSrc nwDst
                            (Wildcard.inter Word8.eq_dec
                                (WildcardExact nwProto)
                                (WildcardExact nwProto'))
                            nwTos tpSrc tpDst inPort).
  Proof with auto.
    intros.
    pose (X := Word8.eq_dec nwProto nwProto').
    destruct X; subst...
  Qed.

  Hint Immediate pres1'.

  Lemma pres2 : forall dlSrc dlDst dlTyp dlTyp' dlVlan dlVlanPcp nwSrc nwDst
    nwProto nwTos tpSrc tpDst inPort,
    dlTyp <> dlTyp' ->
    ValidPattern (Pattern dlSrc dlDst
                    (Wildcard.inter Word16.eq_dec
                      (WildcardExact dlTyp)
                      (WildcardExact dlTyp'))
                    dlVlan dlVlanPcp nwSrc nwDst nwProto
                    nwTos tpSrc tpDst inPort).
  Proof with auto.
    intros.
    apply ValidPat_None.
    simpl.
    repeat rewrite -> orb_true_iff.
    repeat rewrite -> or_assoc.
    rewrite -> inter_exact_neq; auto 13.
  Qed.

  Hint Immediate pres2.

  Lemma pres3 : forall dlSrc dlDst dlTyp dlTyp' dlVlan dlVlanPcp nwSrc nwDst
    nwProto nwTos tpSrc tpDst inPort,
    In dlTyp SupportedDlTyp ->
    ~ In dlTyp' SupportedDlTyp ->
    ValidPattern (Pattern dlSrc dlDst
                    (Wildcard.inter Word16.eq_dec
                      (WildcardExact dlTyp)
                      (WildcardExact dlTyp'))
                    dlVlan dlVlanPcp nwSrc nwDst nwProto
                    nwTos tpSrc tpDst inPort).
    Proof with auto.
      intros.
      pose (X := Word16.eq_dec dlTyp dlTyp').
      destruct X; subst...
    Qed.

    Hint Resolve pres3.

  Lemma pres3' : forall dlSrc dlDst dlTyp dlTyp' dlVlan dlVlanPcp nwSrc nwDst
    nwProto nwTos tpSrc tpDst inPort,
    ~ In dlTyp SupportedDlTyp ->
    In dlTyp' SupportedDlTyp ->
    ValidPattern (Pattern dlSrc dlDst
                    (Wildcard.inter Word16.eq_dec
                      (WildcardExact dlTyp)
                      (WildcardExact dlTyp'))
                    dlVlan dlVlanPcp nwSrc nwDst nwProto
                    nwTos tpSrc tpDst inPort).
    Proof with auto.
      intros.
      pose (X := Word16.eq_dec dlTyp dlTyp').
      destruct X; subst...
    Qed.

    Hint Resolve pres3'.

    Lemma pres4 : In Const_0x800 SupportedDlTyp.
    Proof with auto with datatypes.
      intros.
      unfold SupportedDlTyp...
    Qed.

    Hint Resolve pres4.

    Lemma pres4' : In Const_0x806 SupportedDlTyp.
    Proof with auto with datatypes.
      intros.
      unfold SupportedDlTyp...
    Qed.

    Hint Resolve pres4'.

    Lemma pres5 : forall dlSrc dlDst  dlVlan dlVlanPcp nwSrc nwDst
                         nwProto nwTos tpSrc tpDst inPort,
    ValidPattern (Pattern dlSrc dlDst
                    (Wildcard.inter Word16.eq_dec
                      (WildcardExact Const_0x800)
                      (WildcardExact Const_0x806))
                    dlVlan dlVlanPcp nwSrc nwDst nwProto
                    nwTos tpSrc tpDst inPort).
    Proof with auto.
      intros.
      apply pres2.
      exact IP_ARP_frametyp_neq.
    Qed.

    Hint Immediate pres5.

    Lemma pres5' : forall dlSrc dlDst  dlVlan dlVlanPcp nwSrc nwDst
                          nwProto nwTos tpSrc tpDst inPort,
    ValidPattern (Pattern dlSrc dlDst
                    (Wildcard.inter Word16.eq_dec
                      (WildcardExact Const_0x806)
                      (WildcardExact Const_0x800))
                    dlVlan dlVlanPcp nwSrc nwDst nwProto
                    nwTos tpSrc tpDst inPort).
    Proof with auto.
      intros.
      apply pres2.
      unfold not.
      intros.
      symmetry in H.
      apply IP_ARP_frametyp_neq...
    Qed.

    Hint Immediate pres5'.

    Lemma empty_valid_l : forall pat pat',
      is_empty pat = true ->
      ValidPattern (Pattern.inter pat pat').
    Proof with auto.
      intros.
      apply ValidPat_None.
      apply is_empty_true_l...
    Qed.

    Lemma empty_valid_r : forall pat pat',
      is_empty pat' = true ->
      ValidPattern (Pattern.inter pat pat').
    Proof with auto.
      intros.
      apply ValidPat_None.
      apply is_empty_true_r...
    Qed.

  Ltac inter_solve :=
    unfold Pattern.inter; simpl; autorewrite with wildcard using auto.

  Lemma inter_preserves_valid : forall pat1 pat2,
    ValidPattern pat1 ->
    ValidPattern pat2 ->
    ValidPattern (Pattern.inter pat1 pat2).
  Proof with auto.
    intros pat1 pat2 H H0.

    destruct H; destruct H0;
      try solve [ auto using empty_valid_l, empty_valid_r ].

    pose (X := Word8.eq_dec nwProto nwProto0);  destruct X; subst; inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    pose (X := Word8.eq_dec nwProto nwProto0);  destruct X; subst; inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    pose (X := Word16.eq_dec frameTyp frameTyp0);
      destruct X; subst; inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
    inter_solve.
  Qed.

End PatMatchable.

Section Equivalence.

  Inductive Pattern_equiv : pattern -> pattern -> Prop :=
  | Pattern_equiv_match : forall pat1 pat2,
    (forall pt pk,
      Pattern.match_packet pt pk pat1 = Pattern.match_packet pt pk pat2) ->
    Pattern_equiv pat1 pat2.

  Hint Constructors Pattern_equiv.

  Lemma Pattern_equiv_is_Equivalence : Equivalence Pattern_equiv.
  Proof with auto.
    split.
    unfold Reflexive...
    unfold Symmetric. intros. inversion H...
    unfold Transitive. intros. inversion H. inversion H0. subst.
    split. intros. rewrite -> H1...
  Qed.

End Equivalence.

Instance Pattern_Equivalance : Equivalence Pattern_equiv.
  apply Pattern_equiv_is_Equivalence.
Qed.


Require Import Fiat.Parsers.Reflective.Syntax Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Parsers.Reflective.Syntactify.
Require Import Fiat.Common.
Require Import Fiat.Common.NatFacts.
Require Import Fiat.Common.List.Operations.
Set Implicit Arguments.

Local Open Scope list_scope.

Section normalization_by_evaluation.
  Context (var : TypeCode -> Type).

  Fixpoint normalized_of (T : TypeCode) : Type :=
    match T with
    | csimple T' => Term var T'
    | carrow A B => normalized_of A -> normalized_of B
    end.

  Fixpoint reify {T} : normalized_of T -> Term var T
    := match T return normalized_of T -> Term var T with
       | csimple _
         => fun x => x
       | carrow A B => fun f => RLambda (fun x => reify (f (reflect (RVar x))))
       end
  with reflect {T} : Term var T -> normalized_of T
       := match T return Term var T -> normalized_of T with
          | csimple _
            => fun x => x
          | carrow A B => fun e x => reflect (RApp e (reify x))
          end.

  Definition onelevel (T : SimpleTypeCode) : Type
    := interp_SimpleTypeCode_step (Term var) T.

  Definition onelevelG (T : TypeCode) : Type :=
    match T with
    | csimple T' => onelevel T'
    | _ => Empty_set
    end.

  Definition args_for_onelevel : TypeCode -> Type
    := args_for (fun A => option (onelevelG A)).

  Section constantOfs.
    Context (constantOf : forall {T} (t : Term var T), option (onelevelG T)).

    Definition constantOfs {T} (af : args_for (Term var) T) : args_for_onelevel T :=
      map_args_for constantOf af.
  End constantOfs.

  Fixpoint constantOf {T} (t : Term var T) : option (onelevelG T)
    := match t in Term _ T return option (onelevelG T) with
       | RLiteralApp _ l af =>
         match l with
         | RLC l'
           => match l' in RLiteralConstructor T return args_for (Term var) T -> args_for_onelevel T -> option (onelevel (range_of T)) with
              | Rpair _ _ => fun af _ => Some (ahd af, ahd (atl af))
              | RS => fun af afr => option_map S (ahd afr)
              | RO => fun _ _ => Some O
              | Rnil _ => fun _ _ => Some nil
              | Rcons _ => fun af afr => option_map (cons (ahd af)) (ahd (atl afr))
              | Rbool v
              | Rrchar_expr_ascii v
              | Rstring v
              | Rritem_ascii v
                => fun _ _ => Some v
              end
         | RLNC _
           => fun _ _ => None
         end af (constantOfs (@constantOf) af)
       | _ => None
       end.

  Definition arg_meanings_for : TypeCode -> Type :=
    args_for normalized_of.

  Section meanings.
    Context (meaning : forall {T} (t : Term normalized_of T), normalized_of T).

    Definition meanings {T} (af : args_for (Term normalized_of) T) : arg_meanings_for T :=
      map_args_for meaning af.
  End meanings.

  Definition unmeanings {T}
             (args : arg_meanings_for T)
    : args_for (Term var) T
    := map_args_for (fun _ => reify) args.

  Fixpoint apply_meaning_helper {P}
           (af : arg_meanings_for P)
    : forall (f : normalized_of P),
      normalized_of (range_of P)
    := match af in args_for _ P return normalized_of P -> normalized_of (range_of P) with
       | an_arg _ _ arg args
         => fun f => @apply_meaning_helper _ args (f arg)
       | noargs _ => fun v => v
       end.

  Definition specific_meaning_apply1 {A : SimpleTypeCode} {B} {B'}
             (syntactify : B' -> normalized_of (range_of B))
             (f : onelevelG A -> B')
             (args : arg_meanings_for (A --> B))
    : option (normalized_of (range_of (A --> B)))
      := option_map (fun v => syntactify (f v)) (constantOf (ahd args)).
  Global Arguments specific_meaning_apply1 _ _ {_} _ _ _.

  Definition specific_meaning_apply2 {A B : SimpleTypeCode} {C} {C'}
             (syntactify : C' -> normalized_of (range_of C))
             (f : onelevelG A -> onelevelG B -> C')
             (args : arg_meanings_for (A --> B --> C))
    : option (normalized_of (range_of (A --> B --> C)))
      := match constantOf (ahd args), constantOf (ahd (atl args)) with
         | Some v0, Some v1 => Some (syntactify (f v0 v1))
         | _, _ => None
         end.
  Global Arguments specific_meaning_apply2 _ _ _ {_} _ _ _.

  Definition specific_meaning {T} (t : RLiteralNonConstructor T)
    : arg_meanings_for T -> option (normalized_of (range_of T))
    := match t in RLiteralNonConstructor T return arg_meanings_for T -> option (normalized_of (range_of T)) with
       | Rfst _ _ => specific_meaning_apply1 (cprod _ _) (csimple _) (fun x => x) fst
       | Rsnd _ _ => specific_meaning_apply1 (cprod _ _) (csimple _) (fun x => x) snd
       | Rnth' _
         => fun af
            => specific_meaning_apply2
                 cnat (clist _) (_ --> csimple _) (fun x => x)
                 (fun n ls => List.nth' n ls (ahd (atl (atl af))))
                 af
       | Rnth _
         => fun af
            => specific_meaning_apply2
                 cnat (clist _) (_ --> csimple _) (fun x => x)
                 (fun n ls => List.nth n ls (ahd (atl (atl af))))
                 af
       | Rbeq_nat
         => specific_meaning_apply2
              cnat cnat cbool (syntactify_bool _)
              EqNat.beq_nat
       | Rmap A B
         => fun af
            => option_map (@syntactify_list _ _)
                          (option_map (List.map (ahd af))
                                      (constantOf (ahd (atl af))))
       | Rfold_left A B
         => fun af
            => option_map
                 (fun ls =>
                    let init := ahd (atl (atl af)) in
                    let f := ahd af in
                    List.fold_left f ls init)
                 (constantOf (ahd (atl af)))
       | Rorb | Rorbr
         => fun af
            => match constantOf (ahd af), constantOf (ahd (atl af)) with
               | Some b, _
                 => Some (if b then syntactify_bool var true else ahd (atl af))
               | _, Some b
                 => Some (if b then syntactify_bool var true else ahd af)
               | None, None => None
               end
       | Randb | Randbr
         => fun af
            => match constantOf (ahd af), constantOf (ahd (atl af)) with
               | Some b, _
                 => Some (if b then ahd (atl af) else syntactify_bool var false)
               | _, Some b
                 => Some (if b then ahd af else syntactify_bool var false)
               | None, None => None
               end
       | Rminusr
         => fun af
            => match constantOf (ahd af), constantOf (ahd (atl af)) with
               | Some n, Some n'
                 => Some (syntactify_nat var (minusr n n'))
               | _, Some n'
                 => Some (apply_n n' (fun n0 => RLiteralApp Rpred (n0 :: noargs)) (ahd af))
               | _, _ => None
               end
       | Rpred
         => specific_meaning_apply1
              cnat cnat (syntactify_nat _)
              pred
       | Rlength _
         => specific_meaning_apply1
              (clist _) cnat (syntactify_nat _)
              (@List.length _)
       | Rbool_rect_nodep cbool
         => fun af
            => let rtest := ahd (atl (atl af)) in
               let rtrue := ahd af in
               let rfalse := ahd (atl af) in
               match constantOf rtest, constantOf rtrue, constantOf rfalse with
               | Some b, _, _
                 => Some (if b then rtrue else rfalse)
               | None, Some true, Some true
                 => Some (Syntactify.syntactify_bool _ true)
               | None, Some false, Some false
                 => Some (Syntactify.syntactify_bool _ false)
               | None, Some true, Some false
                 => Some rtest
               | None, Some false, Some true
               | None, None, _
               | None, _, None
                 => None
               end
       | Rbool_rect_nodep _
         => fun af
            => option_map (fun b : bool
                           => if b
                              then ahd af
                              else ahd (atl af))
                          (constantOf (ahd (atl (atl af))))
       | Rlist_rect_nodep A P
         => fun af
            => option_map (fun ls
                           => apply_meaning_helper
                                (atl (atl (atl af)))
                                (list_rect_nodep
                                   (ahd af)
                                   (fun x xs => ahd (atl af) x (syntactify_list xs))
                                   ls))
                          (constantOf (ahd (atl (atl af))))
       | Rlist_caset_nodep _ _
         => fun af
            => option_map (fun ls
                           => list_caset_nodep
                                (ahd af)
                                (fun x xs => ahd (atl af) x (syntactify_list xs))
                                ls)
                          (constantOf (ahd (atl (atl af))))
       | Rleb
         => specific_meaning_apply2
              cnat cnat cbool (syntactify_bool _)
              Compare_dec.leb
       | Rcombine _ _
         => specific_meaning_apply2
              (clist _) (clist _) (clist _) (fun ls => syntactify_list (List.map (@syntactify_prod _ _ _) ls))
              (@List.combine _ _)
       | Rrev _
         => specific_meaning_apply1 (clist _) (csimple _) (@syntactify_list _ _) (@List.rev _)
       | Rup_to
         => specific_meaning_apply1
              cnat (clist _) (fun ls => syntactify_list (List.map (@syntactify_nat _) ls))
              List.up_to
       | Rplus
         => fun af
            => match constantOf (ahd af), constantOf (ahd (atl af)) with
               | Some n, Some n'
                 => Some (syntactify_nat var (plus n n'))
               | Some n, _
                 => Some (apply_n n (fun n0 => RLiteralApp RS (n0 :: noargs)) (ahd (atl af)))
               | _, Some n'
                 => Some (apply_n n' (fun n0 => RLiteralApp RS (n0 :: noargs)) (ahd af))
               | None, None => None
               end
       | Rmax
         => specific_meaning_apply2
              cnat cnat cnat (syntactify_nat _)
              max
       | Rritem_rect_nodep _
         => fun af
            => option_map (fun v
                           => Reflective.ritem_rect_nodep
                                (fun x => ahd af (syntactify_rchar_expr_ascii var x))
                                (fun s => ahd (atl af) (syntactify_string var s))
                                v)
                          (constantOf (ahd (atl (atl af))))
       | Rfirst_index_default _
         => fun af
            => match constantOf (ahd (atl af)), constantOf (ahd (atl (atl af))) with
               | Some v, Some ls =>
                 let f := ahd af in
                 option_map (syntactify_nat var)
                            (first_index_default_partial (fun a => constantOf (f a)) v ls)
               | _, _ => None
               end
       | Rstring_beq
         => specific_meaning_apply2
              cstring cstring cbool (syntactify_bool _)
              Equality.string_beq
       | Rinterp_RCharExpr_ascii => fun _ => None
       end.

  Fixpoint meaning {T} (t : Term normalized_of T) : normalized_of T
      := match t in Term _ T return normalized_of T with
         | RLiteralApp _ l af =>
           match l with
           | RLC l'
             => fun af => RLiteralApp l' (unmeanings af)
           | RLNC l'
             => fun af => option_rect (fun _ => _)
                                      (fun x => x)
                                      (RLiteralApp l' (unmeanings af))
                                      (specific_meaning l' af)
           end (meanings (@meaning) af)
         | RLambda _ _ f => fun x => @meaning _ (f x)
         | RVar _ v => v
         | RApp _ _ f x => @meaning _ f (@meaning _ x)
         end.

  Definition normalize {T} (term : Term normalized_of T) : Term var T := reify (meaning term).
End normalization_by_evaluation.

Definition polynormalize {T} (term : polyTerm T) : polyTerm T
  := fun var => normalize (term _).

Section lemmas.
  Definition interp_constantOf {T} : onelevelG interp_TypeCode T -> interp_TypeCode T
    := match T return onelevelG _ T -> interp_TypeCode T with
       | cnat
       | cbool
       | cstring
       | cascii
       | critem_ascii
       | crchar_expr_ascii
         => fun x => x
       | clist T => List.map interp_Term
       | cprod A B => fun xy => (interp_Term (fst xy), interp_Term (snd xy))
       | carrow A B => fun x : Empty_set => match x with end
       end.

  Fixpoint interp_constantOfs_to_values {T}
           (args : args_for_onelevel interp_TypeCode T)
    : args_for (fun T => option (interp_TypeCode T)) T
    := match args in args_for _ T return args_for _ T with
       | an_arg _ _ arg args => an_arg (option_map interp_constantOf arg) (@interp_constantOfs_to_values _ args)
       | noargs T => noargs
       end.
End lemmas.


Require Import dialectica.

Definition markov {A} : ⊢ (!?! A) ⊸ A.
Proof.
intros A; split; simpl.
+ intros f; apply f; intros _; apply C_member.
+ intros x f u; exact x.
Defined.

Lemma Valid_markov : forall A, Valid (@markov A).
Proof.
intros A; split; unfold markov; intros [u x]; apply rel_arr; simpl.
intros Hr; apply rel_not_not in Hr.

Definition em {A B} : ⊢ ?(A ⊕ (A ⊸ ? B)).
Proof.
intros A B [x [u y]]; simpl in *.
destruct (rel_decidable A u x).
+ left; assumption.
+ right; split.
  - intros; apply W_member.
  - intros; assumption.
Defined.

Definition toto {A B} : ⊢ ? A ⊕ ? B ⊸ ? (A ⊕ B).
Proof.
intros A B; split.
+ intros [u|v] [kl kr]; simpl in *.
  - left; apply u, kl.
  - right; apply v, kr.
+ intros [x y]; split; assumption.
Defined.

Lemma Valid_em : forall A B, Valid (@em A B).
Proof.
intros A B; split.
intros [x [u y]]; simpl; intros Hc; apply Hc; clear Hc.
destruct rel_decidable as [Hd|Hd]; simpl.
+ assumption.
+ intros [Hc _]; contradiction.
Qed.

Definition callcc {A B} : ⊢ !(!(!A ⊸ ?! B) ⊸ ?! A) ⊸ ?! A.
Proof.
intros A B; split.
+ intros [fl fr] π.
  simpl in *; apply fl; [|exact π]; split.
  - intros; apply W_member.
  - intro; exact π.
+ intros f [kl kr]; split.
  - simpl; split.
    { intros; apply W_member. }
    { intro; exact f. }
  - exact f.
Defined.

Lemma rel_not_not_stable : forall A u x, ~~ (rel A u x) <-> rel A u x.
Proof.
intros A u x; split; [apply rel_not_not|intuition].
Qed.

Lemma Valid_callcc : forall A B, Valid (@callcc A B).
Proof.
intros A B; exists.
intros [[ul ur] π]; apply rel_arr; intros Hu.
simpl in *.
destruct ur as [u ρ].
simpl in *.
repeat rewrite rel_not_not_stable in *.
(* Definition markov {P} : ⊢ ?!? P ⊸ P.
Proof.
intros P f; split; simpl in *.
+ intros w; apply f.
  admit.
+ intros f; apply f.
  apply C_member.
+ intros x; exact x.
Defined.*)

(* Instance Valid_markov : forall P, Valid (@markov P).
Proof.
intros P; split; intros [w x]; apply rel_arr; intros Hw; simpl in *.
assumption.
Qed. *)

(* Definition markov_nat (T : Inhabited) (P : T -> prp) :
  ⊢ ! (¬ (∀ x : T, ¬ (P x))) ⊸ ∃ x : T, !(P x).
Proof.
intros T P; split.
+ intros; simpl in *; apply H.
  intros x u; apply C_member.
+ simpl; intros w f t u.
  apply (w _ u).
Defined.*)

Inductive pos : prp -> Type :=
| pos_one : pos [true]
| pos_nul : pos [false]
| pos_tns : forall A B, pos A -> pos B -> pos (A ⊗ B)
| pos_sum : forall A B, pos A -> pos B -> pos (A ⊕ B).

Lemma dup_pos : forall A, pos A -> ⊢ A ⊸ A ⊗ A.
Proof.
intros A HA; induction HA as [| |A B HA IHA HB IHB|A B HA IHA HB IHB];
  (split; [intros u|intros [zl zr]]).
+ repeat constructor.
+ apply daimon.
+ repeat constructor.
+ apply daimon.
+ destruct u as [u v]; repeat split; assumption.
+ split.
  - intros u. admit.
  - admit.

+ admit.
+ simpl. admit.
Admitted.

Definition search (p : N -> prp) (m : N) :
  W (p 0) ->
  (forall k : N, W (p k) -> W (p (S k))) ->
  (forall k : N, W (p k) -> C (p k)) ->
  C (p m) ->
  C (p 0) + {n : N & (W (p n) * C (p (S n)))%type}.
Proof.
  intros p m z s b c.
  induction m.
  left; exact c.
  pose (w := nat_rect _ z s m).
  destruct (rel_decidable (p m) w (b m (w))) as [D1|D2].
  right.
  exists m.
  exact (w, c).
  apply IHm.
  exact (b m (w)).
Defined.

Eval simpl in fun A B => ⊣ par A B.
Eval simpl in fun A B (w : ⊢ par A B) (z : ⊣ par A B) => rel (par A B) w z.

(* Definition Nrec {P} : ⊢ !(P 0) ⊗ !(∀ n : N, !(P n) ⊸ P (S n)) ⊸ (∀ m : N, P m).
Proof.
intros P; split.
+ intros [H0 HS] m; induction m.
  - exact H0.
  - apply HS; assumption.
+ simpl; intros [m Hm].
  induction m as [|m]; split.
  - intros u.

split.
  intros H0 HS.
  apply
  Print search.
  Extraction search.
+ intros [m Hm]; induction m as [|m]; split.
  - intros H0 f; specialize (f 0); destruct f as [fl fr].

    exists 0; split; auto.
  - intros H0 f; simpl.
    exists m; split.
    { clear - H0 f; induction m; [assumption|apply f, IHm]. }
    { specialize (f m); destruct f as [_ f].
    *)
(** * Equality

   Next we verify the rules of equality. To keep things simple we only consider equality
   of natural numbers. In the general case we could consider decidable equality on an
   inhabited type. *)

(*

Definition prpEq (m n : N) := [beq_nat m n].

(** Dialectica equality implies equality. *)

Theorem prpEq_eq (m n : N) (p : ⊢ prpEq m n) : Valid p -> m = n.
Proof.
intros m n p [Hp].
specialize (Hp daimon); simpl in Hp.
apply beq_nat_true.
apply Is_true_eq_true.
assumption.
Qed.

(** Equality implies Dialectica equality, of course, but notice how complicated the proofs
   seems to be. We could move the complication into [prpEq_refl] below. *)

Definition eq_prpEq (m n : N) : ⊢ prpEq m n.
Proof.
intros m n; exact tt.
Defined.

Instance Valid_eq_prpEq : forall m n, m = n -> Valid (eq_prpEq m n).
Proof.
intros m n Heq; split; intros x; simpl.
apply Is_true_eq_left.
apply beq_nat_true_iff; assumption.
Qed.

(** Reflexivity. *)

Theorem prpEq_refl (n : N) : Valid (eq_prpEq n n).
Proof.
  intros n; split.
  intros x; simpl.
  rewrite <- beq_nat_refl; constructor.
Qed.

(** Leibniz's law as a rule of inference. *)

Definition Leibniz {P : N -> prp} {m n : N} (e : ⊢ prpEq m n) (p : ⊢ P m) : ⊢ P n.
Proof.
intros P m n [].

Theorem leibniz_rule (p : N -> prp) (m n : N) :
  valid (prpEq m n) -> valid (p m) -> valid (p n).
Proof.
  unfold valid, C, W; simpl; fold C; fold W.
  intros p m n [a H] [b G].
  assert (E := H tt).
  apply Is_true_eq_true in E.
  apply beq_nat_true in E.
  rewrite <- E.
  exists b.
  assumption.
Qed.

(** Proving Leibniz's law as a proposition is more complicated because of type dependency
   that is not present in the usual Dialectica interpretation.

   In fact, it looks like we need UIP (Uniqueness of Identity Proofs) for natural numbers,
   which luckily holds since the natural numbers are decidable. Below we prove UIP for N.
   Coq 8.3 contains a more general proof of UIP for decidable types, see [Logic.Eqdep_dec]. *)

Definition eqN_compose (k m n : N) (p : k = m) (q : k = n) : m = n.
Proof.
  intros k m n p q.
  induction p.
  exact q.
Defined.

Lemma eqN_compose_transitivity (m n : N) (p : m = n) : eqN_compose p p = refl_equal n.
Proof.
  intros m n p.
  case p; trivial.
Qed.

Lemma eqN_decidable (m n : N) : {m = n} + {m <> n}.
Proof.
  induction m; induction n; auto.
  destruct (IHm n) as [E1 | E2].
  rewrite E1.
  left.
  reflexivity.
  right.
  injection.
  contradiction.
Qed.

Definition eqN_nu (m n : N) (p : m = n) : (m = n).
Proof.
  intros m n p.
  destruct (eqN_decidable m n) as [EQ|NEQ].
  exact EQ.
  contradiction.
Defined.

Definition eqN_mu (m n : N) (p : m = n) := eqN_compose (eqN_nu (refl_equal m)) p.

Lemma eqN_mu_nu (n m : N) (p : n = m) : eqN_mu (eqN_nu p) = p.
Proof.
  intros n m p.
  case p.
  unfold eqN_mu.
  apply eqN_compose_transitivity.
Qed.

Theorem UIP_N : forall (m n : N) (p q : m = n), p = q.
Proof.
  intros m n p q.
  elim eqN_mu_nu with (p := p).
  elim eqN_mu_nu with (p := q).
  unfold eqN_nu.
  destruct (eqN_decidable m n) as [EQ|NEQ].
  reflexivity.
  contradiction.
Qed.

Definition W_transfer (p : N -> prp) (m n : N) : W (p m) -> W (p n).
Proof.
  intros p m n w.
  destruct (eqN_decidable m n) as [E1 | E2].
  rewrite <- E1.
  exact w.
  exact (W_member ((p n))).
Defined.

Definition C_transfer (p : N -> prp) (m n : N) : C (p m) -> C (p n).
Proof.
  intros p m n c.
  destruct (eqN_decidable m n) as [E1 | E2].
  rewrite <- E1.
  exact c.
  exact (C_member ((p n))).
Defined.

(** Finally, the validity of Leibniz's law is proved. If someone knows a shortcut,
   I would like to know about it. *)

Theorem leibniz (p : N -> prp) (m n : N) : valid (prpEq m n ==> p m ==> p n).
Proof.
  intros p m n.
  unfold valid, C, W; simpl; fold C; fold W.
  exists ((fun tt => ((fun (w : W (p m)) => W_transfer p m n w),
                      (fun y => C_transfer p n m (snd y)))),
          (fun _ => tt)).
  intros [u [w c]].
  simpl.
  intros E.
  apply Is_true_eq_true in E.
  apply beq_nat_true in E.
  destruct E.
  unfold C_transfer, W_transfer.
  destruct (eqN_decidable m m) as [E1 | E2].
  assert (U := UIP_N E1 (refl_equal m)).
  rewrite U.
  simpl.
  auto.
  assert (F2 : m = m); auto.
  contradiction.
Qed.

(** * Natural numbers

   Next we verify that the natural numbers obey Peano axioms. They are easy, except for
   induction which has two parts: the usual "forward" direction by primitive recursion,
   and a "backwards" direction in which we search for a counter-example, starting from an
   upper bound and going down to 0. *)

Theorem nat_zero_not_succ (n : nat) :
  valid (neg (prpEq (S n) 0)).
Proof.
  intro n.
  unfold valid, C, W; simpl; fold C; fold W.
  exists (fun tt => tt); auto.
Qed.

Theorem succ_injective (m n : nat) :
  valid (prpEq (S m) (S n) ==> prpEq m n).
Proof.
  intros m n.
  unfold valid, C, W; simpl; fold C; fold W.
  exists (fun _ => tt, fun _ => tt); auto.
Qed.

(** Given a propositional function [p : nat -> prp], suppose [p m] is not valid. Then [p
   0] is not valid, or one of induction steps [p k ==> p (S k)] fails. The "backwards"
   direction of the Dialectica interpretation of induction is a search functional which
   looks for a failed base case or failed induction step. We construct it separately from
   the main proof. *)

Definition search (p : N -> prp) (m : N) :
  W (p 0) ->
  (forall k : N, W (p k) -> W (p (S k))) ->
  (forall k : N, W (p k) * C (p (S k)) -> C (p k)) ->
  C (p m) ->
  C (p 0) + {n : N & (W (p n) * C (p (S n)))%type}.
Proof.
  intros p m z s b c.
  induction m.
  left; exact c.
  pose (w := nat_rect _ z s m).
  destruct (rel_decidable (p m) w (b m (w, c))) as [D1|D2].
  right.
  exists m.
  exact (w, c).
  apply IHm.
  exact (b m (w, c)).
Defined.

(** Finally we verify validity of induction. *)

Theorem N_induction (p : nat -> prp) (m : nat) :
  valid (p 0 and (all n : N, p n ==> p (S n)) ==> p m).
Proof.
  intros p m.
  unfold valid, C, W; simpl; fold C; fold W.
  exists (fun x => nat_rect _ (fst x) (fun k => fst (snd x k)) m,
          fun y => search p m (fst (fst y))
                     (fun k => fst (snd (fst y) k))
                     (fun k => snd (snd (fst y) k))
                     (snd y)).
  simpl.
  intros [[z h] c]; simpl.
  set (s := fun k : nat => fst (h k)).
  set (b := fun k : nat => snd (h k)).
  induction m; auto.
  unfold search; simpl.
  set (w := nat_rect (fun k : nat => W (p k)) z s m).
  destruct (rel_decidable (p m) w (b m (w, c))) as [D1|D2]; simpl.
  intro H.
  apply H.
  apply D1.
  intros.
  assert (G:= IHm (b m (w, c))).
  fold w in G.
  elim D2.
  apply G.
  apply H.
Qed.
*)
(** Having done ordinary induction one is tempted to try validating induction for
   W-types... but not here. *)

(** * Markov Principle and Independence of Premise *)

(** The Dialectica interpretation is characterized by two non-intuitionistic reasoning principles,
   namely Markov principle (MP) and Independence of Premise (IP).

   Both MP and IP involve primitive propositional function [N -> bool]. The point of
   these is that their [W] and [C] types are the unit. So instead of actually using
   primitive proposition, we shall use arbitrary propositions whose [W] and [C] types are
   singletons. First we make the relevant definitions. *)

Definition singleton (t : Inhabited) := forall x, x = member t.

Definition trivial_C (p : prp) := singleton (inhabit (C_member p)).
Definition trivial_W (p : prp) := singleton (inhabit (W_member p)).

(** Primitive propositions are trivial, of course. *)

Lemma primitive_trivial_W (b : bool) : trivial_W ([b]).
Proof.
  intros b w.
  case w; auto.
Qed.

Lemma primitive_trivial_C (b : bool) : trivial_C ([b]).
Proof.
  intros b c.
Admitted.

(** Whether there are trivial propositions, other than the primitive ones, depends on what
   extra axioms we have available. For example, in the presence of extensionality of
   functions, implications and negations of trivial propositions are trivial. We do not
   dwell on the exact conditions that give us trivial propositions, but only demonstrate
   how to use extensionality of functions whose codomain is a singleton set to derive
   triviality of implication of trivial propositions.
*)

(** Is there a better way of getting the next lemma? *)

Lemma pair_equal (X Y : Type) (p q : X * Y) :
  fst p = fst q -> snd p = snd q -> p = q.
Proof.
  intros X Y p q G H.
  induction p; induction q.
  simpl in G; simpl in H.
  rewrite G; rewrite H.
  reflexivity.
Qed.

(** We are only interested in extensionality of functions [s -> t] for which
   [t] is a singleton. Such extensionality can be phrased as "any power of a
   singleton is a singleton". *)

Definition singleton_power :=
  forall t, singleton t -> forall s : Type, singleton (inhabit (fun _ : s => member t)).

(** I _think_ there is no way of proving [singleton_power], is there? We can use it to
   show that [W (p ==> q)] is trivial if [C p] and [W q] are trivial. *)

Lemma implication_trivial_W (p q : prp) :
  singleton_power -> trivial_C p -> trivial_W q -> trivial_W (p ⊸ q).
Proof.
  intros p q E TCp TWq.
  unfold trivial_W.
  unfold singleton.
  unfold W_member, C_member; simpl; fold W_member; fold C_member.
  intros [f g].
  apply pair_equal; simpl.
  rewrite (E _ TWq _).
  rewrite (E _ TWq _ f).
  reflexivity.
  rewrite (E _ TCp _).
  rewrite (E _ TCp _ g).
  reflexivity.
Qed.

(** Triviality of [C (p ==> q)] does not require any extra assumptions. *)
Lemma implication_trivial_C (p q : prp) :
  trivial_W p -> trivial_C q -> trivial_C (p ⊸ q).
Proof.
  intros p q TWp TCq.
  unfold trivial_C.
  unfold C, W; simpl; fold C; fold W.
  intros [wp cq].
  rewrite (TWp wp).
  rewrite (TCq cq).
  apply pair_equal; auto.
Qed.

(** ** Markov principle *)

(** Markov principle holds for any inhabited type (not just the natural numbers) and
   a proposition which has trivial [W] and [C] types. *)

Theorem markov_generalized (T : Inhabited) (P : T -> prp) :
  ⊢ ! (neg (∀ t : T, neg (P t))) ⊸ ∃ t : T, ! (P t).
Proof.
  intros T P; split.
  + intros w; simpl in *; apply w.
    intros t u; apply C_member.
  + intros w z t; apply W_member.
Defined.

Lemma Valid_markov_generalized : forall T P,
  (forall x, trivial_C (P x)) ->
  (forall x, trivial_W (P x)) ->
  Valid (markov_generalized T P).
Proof.
intros T P HC HW; split.
intros [w z]; apply rel_arr; simpl in *; intros Hr Hc.
let v := match goal with [ H : context [ w ?t ] |- _ ] => t end in
destruct (w v) as [t Ht].
let v := match goal with [ H : context [ w ?t ] |- _ ] => t end in
destruct (w v) as [u Hu].
simpl in *.
apply rel_not_not in Hr.
Qed.

  simpl in *.
  unfold valid, C, W; simpl; fold C; fold W.
  pose (u := fun (h : _ -> {x : t & W (p x)})  =>
    let y := projT1 (h (fun x (_ : W (p x)) => C_member (p x))) in
      existT (fun x : t => W (p x)) y (W_member (p y))).
  exists (u, fun _ x _ => C_member (p x)); simpl.
  intros [f g].
  simpl.
  set (v := projT1 (f (fun x _ => C_member (p x)))).
  set (w := projT2 (f (fun (x : t) (_ : W (p x)) => C_member (p x)))).
  rewrite (TC v (g v (W_member (p v)))).
  rewrite (TW v w).
  apply rel_not_not_stable.
Qed.

(** The usual Markov principle now follows easily. *)

Theorem markov (p : N -> bool) :
  valid (neg (all n : N, neg [p n]) ==> some n : N, [p n]).
Proof.
  intro p.
  apply markov_generalized with (t := N) (p := fun (n : N) => [p n]).
  intro; apply primitive_trivial_C.
  intro; apply primitive_trivial_W.
Qed.

(** ** The Independence of Premise *)

(** The usual IP relates propositional functions [p : s -> bool] and [q : t -> prp]:

   [((all x : s, p x) ==> some y : t, q y) ==> some y : t, (all x : s, p x) ==> q y]

   It is possible to generalize [p] to [p : s -> prp] with trival [W (p x)]. On the other
   hand, the type-dependencies force us to require that [C (q y)] be trivial. The proof
   below is unnecessarily complicated towards the end because I hit against a bug in
   [rewrite], see http://coq.inria.fr/bugs/show_bug.cgi?id=2061. *)

Theorem ip_generalized (s t : Inhabited) (p : s -> prp) (q : t -> prp) :
  (forall (x : s), trivial_W (p x)) ->
  (forall (y : t), trivial_C (q y)) ->
  valid (((all x : s, p x) ==> some y : t, q y) ==> some y : t, (all x : s, p x) ==> q y).
Proof.
  intros s t p q TW TC.
  unfold valid, C, W; simpl; fold C; fold W.
  pose (u := fun (x : s) => W_member (p x)).
  pose (v := fun (y : t) (w : W (q y)) => C_member (q y)).
  refine (existT _
          ((fun a => existT _ (projT1 (fst a u)) (fun _ => projT2 (fst a u),
                                                 (fun b => snd a (u, v)))),
           (fun _ => (u,v)))
          _).
  simpl.
  intros [[f g] h].
  simpl.
  set (y := projT1 (f u)).
  set (z := projT1 (g (u, v))).
  intros G.
  fold v.
  intro H.
  rewrite (TC y); simpl.
  rewrite (TC y (v y (projT2 (f u)))) in G; simpl in G.
  apply G.
  replace (u z) with (fst (h y (fun _ : forall x : s, W (p x) => projT2 (f u),
                                fun _ : (forall x : s, W (p x)) * C (q y) => g (u, v))) z).
  assumption.
  transitivity (member (inhabit (W_member (p z)))); apply (TW z).
Qed.

(** A special case of our IP occurs when [p] is a primitive propositional function. *)

Theorem ip (s t : Inhabited) (p : s -> bool) (q : t -> prp) :
  (forall (y : t), trivial_C (q y)) ->
  valid (((all x : s, [p x]) ==> some y : t, q y) ==> some y : t, (all x : s, [p x]) ==> q y).
Proof.
  intros s t p q TC.
  apply ip_generalized.
  intro; apply primitive_trivial_W.
  intro; apply TC.
Qed.

(** This concludes the verification of the Dialectica interpretation in Coq. There are at
   least three interesting directions to go:

   - Extract programs from the Dialectica interpretation. It looks like this could be done
     for extraction into Scheme. Extraction into Haskell and Ocaml seem more complicated
     because the [W] and [C] types are dependent and there seems no easy way of
     translating them into a simply-typed programming language. Presumably, concrete
     examples could be extracted with the help of "[Extraction Inline W C.]".

   - Explore other variants, such as the Diller-Nahm interpretation, or perhaps the
     interpretations a la Ulrich Kohlenbach and Paolo Oliva.

   - Explore the possibility of having a fully dependent Dialectica interpretation.
     Initial investigations by Thomas Streicher and myself indicate that it can be done.
     This would give us a way of constructing a two-level type system (with Prop separate
     from Set) that validates MP and IP. *)