(* Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
   Jean-Baptiste Tristan, and Edward Gan.

   This file is part of RockSalt.

   This file 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 2 of
   the License, or (at your option) any later version.
*)

Require Export Coq.micromega.Psatz.

Require Coqlib.
Require Import CommonTacs.
Require Import Bits.
Export Word.

Local Open Scope Z_scope.

(** * Data structures *)
Require Coq.Sets.Ensembles.
Definition Int32Ensemble := Ensembles.Ensemble int32.
Definition w32add := @Word.add 31.
Definition w32sub := @Word.sub 31.
Definition w32neg := @Word.neg 31.
Notation w32modulus := (modulus 31).

(** * Abbreviations *)
Infix "+32" := w32add (at level 50, left associativity).
Notation "i +32_z z" := (i +32 (repr z))
  (at level 50, left associativity).
Notation "i +32_p p" := (i +32 (repr (Zpos p)))
  (at level 50, left associativity).
Notation "i +32_n n" := (i +32 (repr (Z_of_nat n)))
  (at level 50, left associativity).

Infix "-32" := w32sub (at level 50, left associativity).
Notation "i -32_z z" := (i -32 (repr z))
  (at level 50, left associativity).
Notation "i -32_p p" := (i -32 (repr (Zpos p)))
  (at level 50, left associativity).
Notation "i -32_n n" := (i -32 (repr (Z_of_nat n)))
  (at level 50, left associativity).

Notation "-32" := w32neg (at level 35, right associativity).

Notation int32_zero := (@Word.zero 31).
(*Notation int32_max := (@repr 31 (Word.max_unsigned 31))*)
Notation int32_max := (@Word.mone 31).
Notation int32_of_nat n := (@repr 31 (Z_of_nat n)).
Notation nat_of_int32 i := (Zabs_nat (unsigned i)).

Definition int32_ltu_bool := @Word.ltu 31.
Definition int32_eq_bool := @Word.eq 31.
Definition int32_lequ_bool := @Word.lequ 31.
Definition int32_gtu_bool i1 i2 := (int32_ltu_bool i2 i1).
Definition int32_gequ_bool i1 i2 := (int32_lequ_bool i2 i1).

Notation "i1 =32 i2" := (int32_eq_bool i1 i2 = true) (at level 70).
Notation "i1 <>32 i2" := (int32_eq_bool i1 i2 = false) (at level 70).
Notation "i1 <32 i2" := (int32_ltu_bool i1 i2 = true) (at level 70).
Notation "i1 <=32 i2" := (int32_lequ_bool i1 i2 = true) (at level 70).
Notation "i1 >32 i2" := (int32_gtu_bool i1 i2 = true) (at level 70).
Notation "i1 >=32 i2" := (int32_gequ_bool i1 i2 = true) (at level 70).

(** * Basic lemmas *)

Lemma add32_zero_r : forall i, i +32_n 0 = i.
Proof. simpl. apply add_zero. Qed.

Lemma int32_modulus_constant:
  w32modulus = 4294967296.
Proof. unfold modulus. unfold Word.wordsize.
  trivial.
Qed.

Lemma int32_eq_rewrite :
  forall i1 i2, i1 = i2 -> i1 =32 i2.
Proof. apply int_eq_true_iff2. Qed.

Lemma int32_neq_rewrite :
  forall i1 i2, i1 <> i2 -> i1 <>32 i2.
Proof. apply int_eq_false_iff2. Qed.

Lemma int32_minus_rewrite : forall x y,
  unsigned x >= unsigned y -> unsigned (x -32 y) = unsigned x - unsigned y.
Proof. intros. unfold w32sub, sub. rewrite unsigned_repr2. trivial.
  generalize (unsigned_range x), (unsigned_range y). lia.
Qed.

Remark Zmod_plus_eq_self : forall a b c, (a + b) mod c = a mod c -> b mod c = 0.
Proof. intros.
  assert (b = (a+b-a)) as H2 by ring.
  rewrite H2. rewrite Zminus_mod. rewrite H. rewrite Zminus_diag.
  apply Zmod_0_l.
Qed.

Lemma int32_plus_eq_zero : forall x y, x = x +32 y -> y = int32_zero.
Proof. intros x y Hc.
  destruct x as [xv Hx]. destruct y as [yv Hy].
  unfold Word.add, repr in Hc. simpl in Hc.
  injection Hc. intro H4.
  apply mkint_eq.
  assert (xv = xv mod w32modulus) as H6.
    apply eq_sym. apply Zmod_small. assumption.
  rewrite H6 in H4 at 1.
  apply eq_sym in H4. apply Zmod_plus_eq_self in H4.
  rewrite Zmod_small in H4 by assumption. rewrite H4.
  rewrite Zmod_0_l. trivial.
Qed.

Lemma int32_add_add_sub :
  forall i1 i2 i3:int32, (i1 +32 i3) +32 (i2 -32 i3) = i1 +32 i2.
Proof. intros; unfold w32add. rewrite add_assoc.
       rewrite (@add_commut 31 i3 (i2 -32 i3)).
       rewrite <- sub_add_l.
       rewrite add_sub_assoc. rewrite sub_idem.
       rewrite add_zero. trivial.
Qed.

Lemma int32_of_nat_of_int32 : forall x,
                                int32_of_nat (nat_of_int32 x) = x.
Proof. intros. rewrite inj_Zabs_nat.
       generalize (unsigned_range x); intros.
       rewrite Zabs_eq by omega.
       apply repr_unsigned.
Qed.

(** ** Tactics for int32 *)

(** Convert operations on int32 to operations on Z *)

(* converting x=y to unsigned x = unsigned y, when x and y are of type int32 *)
Ltac elim_int32_eq :=
  repeat match goal with
    | [H: ?X = ?Y |- _] =>
      match type of X with
        | int 31 => assert (unsigned X = unsigned Y) by congruence; clear H
        | _ => idtac
      end
  end.

Ltac int32_to_Z_tac :=
  unfold int32_gtu_bool, int32_gequ_bool,
    int32_lequ_bool, int32_ltu_bool, int32_eq_bool in *;
  autorewrite with int_to_Z in *;
  elim_int32_eq.

(** convert nat to Z *)
Hint Rewrite inj_plus inj_mult : nat_to_Z.
Hint Rewrite inj_minus1 using omega : nat_to_Z.
Hint Rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P : nat_to_Z.

Lemma Z_of_nat_0 : Z_of_nat 0%nat = 0. trivial. Qed.
Lemma Z_of_nat_1 : Z_of_nat 1%nat = 1. trivial. Qed.
Hint Rewrite Z_of_nat_0 Z_of_nat_1 : nat_to_Z.

Lemma inj_S2 : forall n, (Z_of_nat (S n) = Z_of_nat n + 1).
Proof. intros. apply inj_S. Qed.
Hint Rewrite inj_S2 : nat_to_Z.

Hint Rewrite inj_Zabs_nat : nat_to_Z.
Hint Rewrite Zabs_eq using lia : nat_to_Z.

(* Converting hypothesis about nats to Z:
     * n1 = n2 ===> Z_of_nat n1 = Z_of_nat n2
     * n1 > n2 ===> Z_of_nat n1 > Z_of_nat n2
     * ...
   This would not be necessary if we used omega instead of lia.
   Since lia cannot mix facts of Z and nat, we have to
   convert every equality and inquality between nat to Z;
   we also have to add hypothesis (Z_of_nat n >=0) for every
   nat n.
*)
Ltac nat_hyp_to_Z_tac :=
  repeat match goal with
           | [H : ?X = ?Y |- _] =>
             match type of X with
               | nat => apply inj_eq in H
               | _ => fail 1
             end
           | [H: le ?X ?Y |- _] =>  apply inj_le in H
           | [H: Peano.gt ?X ?Y |- _] =>  apply inj_gt in H
           | [H: ge ?X ?Y |- _] =>  apply inj_ge in H
           | [H: Peano.lt ?X ?Y |- _] =>  apply inj_lt in H
           | [n: nat |- _] => extend (Zle_0_nat n)
         end.

(* need to repeat autorewrite below because rewritng rules such as inj_minus1 might
   depend on the results of other rewriting rules so that omega will succeed *)
Ltac nat_to_Z_tac :=  nat_hyp_to_Z_tac; repeat autorewrite with nat_to_Z in *.
Ltac nat_to_Z_in_goal :=  autorewrite with nat_to_Z.
Ltac nat_to_Z_in H :=  autorewrite with nat_to_Z in H.

(** convert Z to nat *)
Hint Rewrite <- inj_plus inj_mult: Z_to_nat.
Hint Rewrite <- inj_minus1 using omega : Z_to_nat.
Hint Rewrite <- Z_of_nat_0 Z_of_nat_1 : Z_to_nat.

Ltac Z_to_nat_in_goal := autorewrite with Z_to_nat.
Ltac Z_to_nat_in H := autorewrite with Z_to_nat in H.

(** * Definition and properties of noOverflow *)
Definition addZ_list (l:list int32) : Z :=
  List.fold_right (fun (a:int32) (z:Z) => unsigned a + z) 0 l.

(** A semantic definition that adding a list of int32s does not overflow *)
Definition noOverflow (l:list int32) : Prop := addZ_list l < w32modulus.

Ltac noOverflow_simpl :=
  unfold noOverflow; cbv [addZ_list List.fold_right].
Ltac noOverflow_simpl_in H :=
  unfold noOverflow in H; cbv [addZ_list List.fold_right] in H.

(** Check a +32 b does not overflow; it is equivalent to a + b < 2^32
    and also equivalent to a +32 b = a + b; this formulation is easy to
    convert to checks in real programs. *)
Definition checkNoOverflow (a b:int32) : bool :=
  int32_lequ_bool a (a +32 b).

(** ** Properties of noOverflow *)
Lemma checkNoOverflow_equiv_noOverflow : forall a b,
  checkNoOverflow a b = true <-> noOverflow (a :: b :: nil).
Proof. intros; generalize (unsigned_range a), (unsigned_range b);
  intros Ha Hb; unfold checkNoOverflow, noOverflow; split.
  intros. int32_to_Z_tac. simpl. rewrite Zplus_0_r.
    apply Znot_ge_lt; intro Hc.
    unfold "+32", repr in H. simpl in H.
    assert ((unsigned a + unsigned b) mod w32modulus =
              unsigned a + unsigned b - w32modulus) as H5.
      apply Coqlib.Zmod_unique with (a:=1) ; lia.
    rewrite H5 in H. lia.
  intros. simpl in H. rewrite Zplus_0_r in H.
    int32_to_Z_tac. unfold "+32", repr. simpl.
    assert (0 <= unsigned a + unsigned b < w32modulus) by lia.
    rewrite (Zmod_small _ _ H0). lia.
Qed.

Lemma noOverflow_2_iff : forall a b,
  noOverflow (a::b::nil) <-> unsigned (a +32 b) = unsigned a + unsigned b.
Proof. intros; generalize (unsigned_range a), (unsigned_range b);
  intros Ha Hb; unfold noOverflow; split; unfold "+32", repr; simpl.
  intros. apply Zmod_small. simpl in H.
    lia.
  intros.
    assert (0 <= unsigned a + unsigned b < w32modulus).
      rewrite <- H; apply Z_mod_lt. apply Word.modulus_pos.
    lia.
Qed.

Lemma int32_add_rewrite : forall (a b:int32),
  unsigned a + unsigned b < w32modulus
    -> unsigned (a +32 b) = unsigned a + unsigned b.
Proof. intros. unfold "+32", repr. simpl.
  generalize (unsigned_range a) (unsigned_range b); intros.
  rewrite Zmod_small by lia. trivial.
Qed.

(** ** Tactics for noOverflow *)

(** Eliminate checkNoOverflow *)
Ltac checkNoOverflow_elim :=
  repeat match goal with
           | [H: checkNoOverflow _ _ = true |- _] =>
             apply checkNoOverflow_equiv_noOverflow in H
           | [ |- checkNoOverflow _ _ = true] =>
             apply checkNoOverflow_equiv_noOverflow
         end.

(* For any occurence of "unsigned x" in the context, add the
   assumption (0 <= unsigned x < 2^32)*)
Ltac add_unsigned_rng_tac :=
  repeat match goal with
           | [H:context[unsigned ?X] |- _] =>
             extend (unsigned_range X)
         end.

(* converting everything to Z so that lia can be used. *)

Require RTL.

Ltac pos_to_Z_tac := autorewrite with pos_to_Z_db in *.

Hint Rewrite Zpos_plus_distr : pos_to_Z_db.

Ltac all_to_Z_tac :=
  unfold noOverflow in *; cbv [addZ_list List.fold_right] in *;
  int32_to_Z_tac; add_unsigned_rng_tac; nat_to_Z_tac; pos_to_Z_tac;
  unfold RTL.size32 in *.

Ltac int32_simplify := all_to_Z_tac; repeat autorewrite with int32_simpl_db in *.
Ltac int32_prover := int32_simplify; lia.

Ltac int32_simplify_in_goal :=
  nat_to_Z_in_goal; autorewrite with int32_simpl_db.
Ltac int32_simplify_in H :=
  nat_to_Z_in H; autorewrite with int32_simpl_db in H.

(** A rewrite tactic that
    (1) rewrites to (unsigned a + unsigned b) when
        (unsigned a + unsigned b < 2^32 holds
    (3) rewrites unsigned (repr z) to z when 0 <= z < 2^32 *)
Hint Rewrite int32_add_rewrite using (lia || (int32_simplify_in_goal; lia))
  : int32_simpl_db.
Hint Rewrite int32_minus_rewrite using lia : int32_simpl_db.
Hint Rewrite Word.unsigned_repr2 using lia : int32_simpl_db.

(** ** More lemmas about noOverflow *)
Lemma checkNoOverflow_3_sound : forall (a b c:int32),
  checkNoOverflow a b = true -> checkNoOverflow (a +32 b) c = true
    -> noOverflow (a::b::c::nil).
Proof. intros. checkNoOverflow_elim. int32_prover. Qed.

(** * addrRegion *)

Definition addrRegion (start limit:int32):Int32Ensemble :=
  fun x:int32 => exists i:int32, x = start +32 i /\ i <=32 limit.

Lemma addrRegion_start_in : forall start limit,
  Ensembles.In _ (addrRegion start limit) start.
Proof. autounfold with sets. intros.
  unfold addrRegion.
  exists int32_zero.
  split. rewrite add32_zero_r. trivial.
  apply Word.int_lequ_zero.
Qed.

(** * disjointRegions *)
(** Check region [start1, start1+limit1] is disjoint from
    [start2, start2+limit2]; For simplicity, neither region can wrap
    around the 32-bit address space. *)
Definition disjointRegions (start1 limit1 start2 limit2:int32) : bool :=
  (int32_ltu_bool (start1 +32 limit1) start2 ||
   int32_ltu_bool (start2 +32 limit2) start1)%bool.

Lemma disjointRegions_sound :
  forall (s1 l1 s2 l2:int32),
    checkNoOverflow s1 l1 = true
      -> checkNoOverflow s2 l2 = true
      -> disjointRegions s1 l1 s2 l2 = true
      -> Ensembles.Disjoint _ (addrRegion s1 l1) (addrRegion s2 l2).
Proof. intros. split; intros. autounfold with sets. intro Hc.
  destruct Hc as [x [i1 [H10 H11]] [i2 [H12 H13]]].
  unfold disjointRegions in H1.
  checkNoOverflow_elim.
  rewrite H10 in H12; clear H10.
  bool_elim_tac; int32_prover.
Qed.

(** * Some properties about ensembles *)
(* not sure where to put these lemmas *)
Lemma included_disjoint : forall A r1 r2 r3,
  Ensembles.Included A r1 r2 -> Ensembles.Disjoint A r2 r3
    -> Ensembles.Disjoint A r1 r3.
Proof. intros. destruct H0. split.
  autounfold with sets in *. intros. intro Hc.
  apply (H0 x).
  destruct Hc. split; auto with sets.
Qed.

Lemma included_trans : forall A r1 r2 r3,
  Ensembles.Included A r1 r2 -> Ensembles.Included A r2 r3
    -> Ensembles.Included A r1 r3.
Proof. auto with sets. Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  An attempt at a variable module in a context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.
Require Import Coq.Setoids.Setoid.

Require Export BoolEqualitySigDef.
Require Export TVarModuleDef.
Require Export EVarModuleDef.
Require Export KappaModuleDef.
Require Export PhiModuleDef.
Require Export PathModuleDef.
Require Export TauModuleDef.
Require Export CpdtTactics.
Require Export Case.
Require Export MoreTacticals.

Module TermModule <: BoolEqualitySig.
  Module EV   := EVarModule.
  Definition EVar := EV.t.

  Module Path := PathModule.
  Include Path.Types.

  Module T := TauModule.
  Include TauModule.Types.

  Definition TVar := TV.t.

Module Types.
Inductive I  : Type :=
 | i_i       : Z -> I.                         (* An integer value in an expression or statement. *)

Inductive St : Type :=                        (* Terms for statements. *)
 | e_s       : E   -> St                      (* An expression in a statement. *)
 | retn      : E   -> St                      (* Returns are required in this syntax. *)
 | seq       : St  -> St -> St                (* Statement sequencing. *)
 | if_s      : E   -> St -> St   -> St        (* if expression in a statement. *)
 | while     : E   -> St -> St                (* A while statement. *)
 | letx      : EVar -> E -> St   -> St        (* A let expression. *)
 | open      : E -> TVar -> EVar -> St -> St  (* open an existential package (elimination) to a value. *)
 | openstar  : E -> TVar -> EVar -> St -> St  (* open an existential package (elimination) with a pointer to the value. *)
with E : Type :=                              (* Terms for expressions. *)
 | i_e       : I -> E                         (* An integer value in an expression. *)
 | p_e       : EVar -> list PE -> E           (* This is a term that derefences a path into the value of the variable. *)
 | f_e       : F -> E                         (* A function identifier in an expression or statement. *)
 | amp       : E -> E                         (* Take the address of an expression. *)
 | star      : E -> E                         (* Derefence an expression of a pointer type. *)
 | cpair     : E -> E -> E                    (* A pair in an expression. *)
 | dot       : E -> IPE -> E                  (* A deference of a pair. *)
 | assign    : E -> E -> E                    (* Assignment. *)
 | appl      : E -> E -> E                    (* Application expression. app is append. *)
 | call      : St -> E                        (* A call expression for the semantics use. *)
 | inst      : E -> Tau -> E                  (* Type instantiation, e[\tau]. *)
 | pack      : Tau -> E -> Tau -> E           (* Existential type introduction. *)
with F : Type :=
 | dfun      : Tau -> EVar -> Tau -> St -> F  (* Function definition. *)
 | ufun      : TVar -> Kappa -> F -> F.       (* Univerally quantified polymorphic function definition.  *)

End Types.
Include Types.

Scheme St_ind_mutual := Induction for St Sort Prop
with    E_ind_mutual := Induction for E Sort Prop
with    F_ind_mutual := Induction for F Sort Prop.
Combined Scheme Term_ind_mutual from St_ind_mutual, E_ind_mutual, F_ind_mutual.

Function beq_i (i i' : I) : bool :=
  match i, i' with
    | i_i i, i_i i' => Zeq_bool i i'
 end.
Hint Unfold  beq_i.
Hint Resolve beq_i.

Function beq_st (s s' : St) : bool :=
  match s, s' with
    | (e_s e), (e_s e') => beq_e e e'
    | retn e, retn e'   => beq_e e e'
    | seq s1 s2, seq s1' s2' => andb (beq_st s1 s1') (beq_st s2 s2')
    | if_s e s1 s2, if_s e' s1' s2' =>
      andb (andb (beq_e e e') (beq_st s1 s1'))
           (beq_st s2 s2')
    | while e s, while e' s' => andb (beq_e e e') (beq_st s s')
    | letx x e s, letx x' e' s' =>
       andb (andb (EV.eqb x x') (beq_e e e')) (beq_st s s')
    | open e alpha x s, open e' beta x' s' =>
      andb (andb (beq_e e e')    (TV.eqb alpha beta))
           (andb (EV.eqb x x') (beq_st s s'))
    | openstar e alpha x s, openstar e' beta x' s' =>
      andb (andb (beq_e e e')    (TV.eqb alpha beta))
           (andb (EV.eqb x x') (beq_st s s'))
    | _, _ => false
  end
with beq_e (e e' : E) : bool :=
 match e, e' with
 | i_e i, i_e i'                 => beq_i i i'
 | p_e x p, p_e x' p'            => andb (EV.eqb x x') (Path.beq_path p p')
 | f_e f, f_e f'                 => beq_f f f'
 | amp e, amp e'                 => beq_e e e'
 | star e, star e'               => beq_e e e'
 | cpair e0 e1, cpair e0' e1'    => andb (beq_e e0 e0') (beq_e e1 e1')
 | dot e ipe, dot e' ipe'        => andb (beq_e e e')   (Path.beq_ipe ipe ipe')
 | assign e1 e2, assign e1' e2'  => andb (beq_e e1 e1') (beq_e e2 e2')
 | appl e1 e2, appl e1' e2'      => andb (beq_e e1 e1') (beq_e e2 e2')
 | call s, call s'               => beq_st s s'
 | inst e t, inst e' t'          => andb (beq_e e e') (T.eqb t t')
 | pack t0 e t1, pack t0' e' t1' => andb (andb (T.eqb t0 t0') (beq_e e e'))
                                         (T.eqb t1 t1')
 | _, _ => false
end
with beq_f (f f' : F) : bool :=
 match  f, f' with
 | dfun t0 x t1 s, dfun t0' x' t1' s' =>
   (andb (andb (T.eqb t0 t0') (EV.eqb x x'))
         (andb (T.eqb t1 t1') (beq_st s s')))
 | ufun a k f, ufun a' k' f'     => (andb (andb (TV.eqb a a') (K.eqb k k'))
                                          (beq_f f f'))
 | _, _ => false
end.

Hint Unfold  beq_st.
Hint Resolve beq_st.
Hint Unfold  beq_e.
Hint Resolve beq_e.
Hint Unfold  beq_f.
Hint Resolve beq_f.

Hint Resolve beq_i.
Hint Resolve beq_st.
Hint Resolve beq_e.
Hint Resolve beq_f.

Fixpoint eq (a b : E) : Prop :=
    match beq_e a b with
     | false => False
     | true => True
    end.

Lemma beq_i_refl:
 forall i,
   beq_i i i = true.
Proof.
  intros.
  induction i; crush.
Qed.
Hint Resolve beq_i_refl.

(* not quite sure why I have to change the proof structure here at all. *)
Lemma beq_i_sym : forall i i', beq_i i i' = beq_i i' i.
Proof.
  induction i; induction i'; auto.
  unfold beq_i.
  apply Zeq_bool_sym.
Qed.
Hint Resolve beq_i_sym.

Lemma beq_i_to_eq:
  forall i i', beq_i i i' = true -> i = i'.
Proof.
  induction i; induction i'.
  unfold beq_i.
  intros.
  apply Zeq_bool_eq in H.
  subst.
  reflexivity.
Qed.
Hint Resolve beq_i_to_eq.

Lemma beq_i_to_neq:
  forall i i', beq_i i i' = false -> i <> i'.
Proof.
  induction i; induction i'; crush.
  rewrite Zeq_bool_refl in H.
  inversion H.
Qed.
Hint Resolve beq_i_to_neq.

Lemma beq_i_trans:
  forall i i0 i1,
    beq_i i i0 = true ->
    beq_i i0 i1 = true ->
    beq_i i i1 = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply beq_i_to_eq in H.
  apply beq_i_to_eq in H0.
  subst.
  assumption.
Qed.
Hint Resolve beq_i_trans.

Lemma beq_st_refl:
  forall s, beq_st s s = true.
Proof.
  intros s.
  apply (St_ind_mutual
           (fun s : St => beq_st s s = true)
           (fun e : E  => beq_e e e = true)
           (fun f : F  => beq_f f f = true));
    try solve[crush].
Qed.
Hint Resolve beq_st_refl.

Lemma beq_e_refl:
  forall e, beq_e e e = true.
Proof.
  intros s.
  apply (E_ind_mutual
           (fun s : St => beq_st s s = true)
           (fun e : E  => beq_e e e = true)
           (fun f : F  => beq_f f f = true));
    try solve[crush].
Qed.
Hint Resolve beq_e_refl.

Lemma beq_f_refl:
  forall f, beq_f f f = true.
Proof.
  intros s.
  apply (F_ind_mutual
           (fun s : St => beq_st s s = true)
           (fun e : E  => beq_e e e = true)
           (fun f : F  => beq_f f f = true));
    try solve[crush].
Qed.
Hint Resolve beq_f_refl.

(* The modules are causing name identity issues on fold/unfold. *)
Ltac refold_term := unfold beq_st; unfold beq_e; unfold beq_f; fold beq_st; fold beq_e; fold beq_f.
Ltac refold_term_in H := unfold beq_st in H; unfold beq_e in H; unfold beq_f in H; fold beq_st in H; fold beq_e in H; fold beq_f in H.

Lemma beq_st_sym:
  forall s s', beq_st s s' = beq_st s' s.
Proof.
  apply (St_ind_mutual
           (fun s : St => forall s', beq_st s s' = beq_st s' s)
           (fun e : E  => forall e', beq_e e e' = beq_e e' e)
           (fun f : F  => forall f', beq_f f f' = beq_f f' f));
    try solve[intros; destruct s'; try solve[crush]];
    try solve[intros; destruct e'; try solve[crush]];
    try solve[intros; destruct f'; try solve[crush]];
    try solve [intros;
              try destruct s';
              try destruct e';
              try destruct f';
              try solve[crush];
              refold_term;
              try rewrite H;
              try rewrite H0;
              try rewrite EV.eqb_sym;
              try rewrite TV.eqb_sym;
              try rewrite Path.eqb_sym;
              try rewrite TV.eqb_sym;
              try rewrite K.eqb_sym;
              try rewrite Path.beq_ipe_sym;
              try rewrite T.eqb_sym;
              try reflexivity;
              try setoid_rewrite T.eqb_sym at 2;
              try reflexivity].
Qed.
Hint Resolve beq_st_refl.

Lemma beq_e_sym:
  forall e e', beq_e e e' = beq_e e' e.
Proof.
  apply (E_ind_mutual
           (fun s : St => forall s', beq_st s s' = beq_st s' s)
           (fun e : E  => forall e', beq_e e e' = beq_e e' e)
           (fun f : F  => forall f', beq_f f f' = beq_f f' f));
    try solve[intros; destruct s'; try solve[simpl]];
    try solve[intros; destruct e'; try solve[simpl]];
    try solve[intros; destruct f'; try solve[simpl]];
    try solve [intros;
              try destruct s';
              try destruct e';
              try destruct f';
              try solve[crush];
              refold_term;
              try rewrite H;
              try rewrite H0;
              try rewrite EV.eqb_sym;
              try rewrite T.eqb_sym;
              try rewrite Path.eqb_sym;
              try rewrite TV.eqb_sym;
              try rewrite K.eqb_sym;
              try rewrite Path.beq_ipe_sym;
              try rewrite T.eqb_sym;
              try reflexivity;
              try setoid_rewrite T.eqb_sym at 2;
              try reflexivity].
Qed.
Hint Resolve beq_e_refl.

Lemma beq_f_sym:
  forall f f', beq_f f f' = beq_f f' f.
Proof.
  intros s.
  apply (F_ind_mutual
           (fun s : St => forall s', beq_st s s' = beq_st s' s)
           (fun e : E  => forall e', beq_e e e' = beq_e e' e)
           (fun f : F  => forall f', beq_f f f' = beq_f f' f));
    try solve[intros; destruct s'; try solve[simpl]];
    try solve[intros; destruct e'; try solve[simpl]];
    try solve[intros; destruct f'; try solve[simpl]];
    try solve [intros;
              try destruct s';
              try destruct e';
              try destruct f';
              try solve[crush];
              refold_term;
              try rewrite H;
              try rewrite H0;
              try rewrite EV.eqb_sym;
              try rewrite T.eqb_sym;
              try rewrite Path.eqb_sym;
              try rewrite TV.eqb_sym;
              try rewrite K.eqb_sym;
              try rewrite Path.beq_ipe_sym;
              try rewrite T.eqb_sym;
              try reflexivity;
              try setoid_rewrite T.eqb_sym at 2;
              try reflexivity].
Qed.
Hint Resolve beq_f_refl.

Ltac apply_beq_eqs_terms :=
  repeat match goal with
    | [ H : forall _ , beq_e _ _ = true -> _ = _ ,
        I : beq_e _ _ = true
        |- _ ] => apply H in I; subst
    | [ H : forall _ , beq_st _ _ = true -> _ = _ ,
        I : beq_st _ _ = true
        |- _ ] => apply H in I; subst
    | [ H : forall _ , beq_f _ _ = true -> _ = _ ,
        I : beq_f _ _ = true
        |- _ ] => apply H in I; subst
    | [ I : EV.eqb _ _ = true
        |- _ ] => apply EV.eqb_to_eq in I; subst
    | [ I : TV.eqb _ _ = true
        |- _ ] => apply TV.eqb_to_eq in I; subst
    | [ I : beq_i _ _ = true
        |- _ ] => apply beq_i_to_eq in I; subst
    | [ I : Path.beq_ipe _ _ = true
        |- _ ] => apply Path.beq_ipe_to_eq in I; subst
    | [ I : Path.eqb  _ _ = true
        |- _ ] => apply Path.eqb_to_eq in I; subst
    | [ I : Path.beq_path  _ _ = true
        |- _ ] => apply Path.eqb_to_eq in I; subst
    | [ I : T.eqb _ _ = true
        |- _ ] => apply T.eqb_to_eq in I; subst
    | [ I : K.eqb _ _ = true
        |- _ ] => apply K.eqb_to_eq in I; subst
end.

Lemma beq_st_to_eq:
  forall s s', beq_st s s' = true -> s = s'.
Proof.
  intros s.
  apply (St_ind_mutual
           (fun s : St => forall s', beq_st s s' = true -> s = s')
           (fun e : E  => forall e', beq_e e e'  = true -> e = e')
           (fun f : F  => forall f', beq_f f f'  = true -> f = f'));
    intros;
    try destruct s';
    try destruct e';
    try destruct f';
    try solve[inversion H0];
    try solve[inversion H1];
    try solve[simpl in H2; inversion H2];
    try solve[crush];
    try solve[
          try refold_term_in H;
          try refold_term_in H0;
          try refold_term_in H1;
          try refold_term_in H2;
          simplify_boolean_and_true;
          apply_beq_eqs_terms;
          reflexivity].
Qed.

Hint Resolve beq_st_to_eq.

Lemma beq_e_to_eq:
  forall e e', beq_e e e' = true -> e = e'.
Proof.
  intros s.
  apply (E_ind_mutual
           (fun s : St => forall s', beq_st s s' = true -> s = s')
           (fun e : E  => forall e', beq_e e e'  = true -> e = e')
           (fun f : F  => forall f', beq_f f f'  = true -> f = f'));
    intros;
    try destruct s';
    try destruct e';
    try destruct f';
    try solve[inversion H0];
    try solve[inversion H1];
    try solve[crush];
    try solve[
          try refold_term_in H;
          try refold_term_in H0;
          try refold_term_in H1;
          try refold_term_in H2;
          simplify_boolean_and_true;
          apply_beq_eqs_terms;
          reflexivity].
Qed.
Hint Resolve beq_e_to_eq.

Lemma beq_f_to_eq:
  forall f f', beq_f f f' = true -> f = f'.
Proof.
  intros s.
  apply (F_ind_mutual
           (fun s : St => forall s', beq_st s s' = true -> s = s')
           (fun e : E  => forall e', beq_e e e'  = true -> e = e')
           (fun f : F  => forall f', beq_f f f'  = true -> f = f'));
    intros;
    try destruct s';
    try destruct e';
    try destruct f';
    try solve[inversion H0];
    try solve[inversion H1];
    try solve[crush];
    try solve[
          try refold_term_in H;
          try refold_term_in H0;
          try refold_term_in H1;
          try refold_term_in H2;
          simplify_boolean_and_true;
          apply_beq_eqs_terms;
          reflexivity].
Qed.
Hint Resolve beq_f_to_eq.

Ltac apply_beq_neqs :=
  repeat match goal with
    | [ H : forall _ , beq_e _ _ = false -> _ <> _ ,
        I : beq_e _ _ = false
        |- _ ] => apply H in I; subst
    | [ H : forall _ , beq_st _ _ = false -> _ <> _ ,
        I : beq_st _ _ = false
        |- _ ] => apply H in I; subst
    | [ H : forall _ , beq_f _ _ = false -> _ <> _ ,
        I : beq_f _ _ = false
        |- _ ] => apply H in I; subst
    | [ I : EV.eqb _ _ = false
        |- _ ] => apply EV.eqb_to_neq in I; subst
    | [ I : T.eqb _ _ = false
        |- _ ] => apply T.eqb_to_neq in I; subst
    | [ I : beq_i _ _ = false
        |- _ ] => apply beq_i_to_neq in I; subst
    | [ I : Path.beq_ipe _ _ = false
        |- _ ] => apply Path.beq_ipe_to_neq in I; subst
    | [ I : Path.eqb _ _ = false
        |- _ ] => apply Path.eqb_to_neq in I; subst
    | [ I : Path.beq_path _ _ = false
        |- _ ] => apply Path.eqb_to_neq in I; subst
    | [ I : TV.eqb _ _ = false
        |- _ ] => apply TV.eqb_to_neq in I; subst
    | [ I : K.eqb _ _ = false
        |- _ ] => apply K.eqb_to_neq in I; subst
end.

Lemma beq_st_neq:
  forall s s', beq_st s s' = false -> s <> s'.
Proof.
  intros s.
  apply (St_ind_mutual
           (fun s : St => forall s', beq_st s s' = false -> s <> s')
           (fun e : E  => forall e', beq_e e e'  = false -> e <> e')
           (fun f : F  => forall f', beq_f f f'  = false -> f <> f'));
    intros;
    try destruct s';
    try destruct e';
    try destruct f';
    try solve[inversion H0];
    try solve[inversion H1];
    try solve[discriminate];
    try solve [
          try refold_term_in H;
          try refold_term_in H0;
          try refold_term_in H1;
          try refold_term_in H2;
          simplify_boolean_and_false;
          apply_beq_neqs;
          congruence].
Qed.
Hint Resolve beq_st_neq.

Lemma beq_e_to_neq:
  forall e e', beq_e e e' = false -> e <> e'.
Proof.
  intros s.
  apply (E_ind_mutual
           (fun s : St => forall s', beq_st s s' = false -> s <> s')
           (fun e : E  => forall e', beq_e e e'  = false -> e <> e')
           (fun f : F  => forall f', beq_f f f'  = false -> f <> f'));
    intros;
    try destruct s';
    try destruct e';
    try destruct f';
    try solve[inversion H0];
    try solve[inversion H1];
    try solve[discriminate];
    try solve [
          try refold_term_in H;
          try refold_term_in H0;
          try refold_term_in H1;
          try refold_term_in H2;
          simplify_boolean_and_false;
          apply_beq_neqs;
          congruence].
Qed.
Hint Resolve beq_e_to_neq.

Lemma beq_f_neq:
  forall f f', beq_f f f' = false -> f <> f'.
Proof.
  intros s.
  apply (F_ind_mutual
           (fun s : St => forall s', beq_st s s' = false -> s <> s')
           (fun e : E  => forall e', beq_e e e'  = false -> e <> e')
           (fun f : F  => forall f', beq_f f f'  = false -> f <> f'));
    intros;
    try destruct s';
    try destruct e';
    try destruct f';
    try solve[inversion H0];
    try solve[inversion H1];
    try solve[discriminate];
    try solve [
          try refold_term_in H;
          try refold_term_in H0;
          try refold_term_in H1;
          try refold_term_in H2;
          simplify_boolean_and_false;
          apply_beq_neqs;
          congruence].
Qed.
Hint Resolve beq_st_neq.

Lemma beq_st_trans:
  forall s s0 s1,
    beq_st s s0 = true ->
    beq_st s0 s1 = true ->
    beq_st s s1 = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply beq_st_to_eq in H.
  apply beq_st_to_eq in H0.
  subst.
  assumption.
Qed.
Hint Resolve beq_st_trans.

Lemma beq_e_trans:
  forall e e0 e1,
    beq_e e e0 = true ->
    beq_e e0 e1 = true ->
    beq_e e e1 = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply beq_e_to_eq in H.
  apply beq_e_to_eq in H0.
  subst.
  assumption.
Qed.
Hint Resolve beq_e_trans.

Lemma beq_f_trans:
  forall f f0 f1,
    beq_f f f0 = true ->
    beq_f f0 f1 = true ->
    beq_f f f1 = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply beq_f_to_eq in H.
  apply beq_f_to_eq in H0.
  subst.
  assumption.
Qed.
Hint Resolve beq_f_trans.

Lemma beq_e_iff_eq:    forall a b, beq_e a b = true <-> a = b.
Proof.
  intros.
  split.
  apply beq_e_to_eq.
  intros.
  rewrite H.
  apply beq_e_refl.
Qed.
Hint Resolve beq_e_iff_eq.

Lemma beq_e_iff_neq:   forall a b, beq_e a b = false <-> a <> b.
Proof.
  intros.
  split.
  apply beq_e_to_neq.
  intros.
  destruct a; destruct b; simpl; try reflexivity.
  admit.
Admitted.

Hint Resolve beq_e_iff_neq.

Inductive Value : E -> Prop :=
 | IIsAValue    : forall (i : I),              Value (i_e i)

 | AmpIsAValue  : forall (x : EVar) (p : Path),   Value (amp (p_e x p))

 | DfunIsAValue : forall (t1 t2 : Tau) (x : EVar) (s : St),
                        Value (f_e (dfun t1 x t2 s))
 | UfunIsAValue :
     forall (t : TVar) (k : Kappa) (f : F),
       Value (f_e (ufun t k f))

 | PairIsAValue :
     forall (v0 v1 : E),
       Value v0 ->
       Value v1 ->
       Value (cpair v0 v1)

(* Bug 40, forget a subvalue here. *)
 | PackIsAValue :
     forall (tau tau': Tau) (v : E),
       Value v ->
       Value (pack tau v tau').

Definition t := E.
Definition eqb := beq_e.
Definition eqb_refl := beq_e_refl.
Definition eqb_sym := beq_e_sym.
Definition eqb_trans := beq_e_trans.
Definition eqb_to_eq := beq_e_to_eq.
Definition eqb_to_neq := beq_e_to_neq.
Definition eqb_iff_eq := beq_e_iff_eq.
Definition eqb_iff_neq := beq_e_iff_neq.

Ltac destruct_away :=
  repeat match goal with
    | [ |- ?X = true <-> _ ] => destruct X; try solve[crush]
         end.

Lemma eqb_eq : forall x y : t, eqb x y = true <-> eq x y.
Proof.
  induction x; induction y;
  try solve[
        unfold eq;
        unfold eqb;
        destruct_away;
        crush].
Qed.

Lemma eq_refl:
 forall (a : t),
   eq a a.
Proof.
  intros.
  rewrite <- eqb_eq.
  apply beq_e_refl.
Qed.

Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof.
  intros.
  rewrite <- eqb_eq.
  rewrite <- eqb_eq in H.
  rewrite beq_e_sym.
  assumption.
Qed.

Lemma eq_trans :
  forall x y z,
    eq x y -> eq y z -> eq x z.
Proof.
  intros.
  rewrite <- eqb_eq.
  rewrite <- eqb_eq in H.
  rewrite <- eqb_eq in H0.
  apply beq_e_trans with (e:= x) (e0:= y) (e1:= z); try assumption.
Qed.

Instance eq_equiv : Equivalence eq.
Proof.
  split.
  exact eq_refl.
  exact eq_sym.
  exact eq_trans.
Defined.

Ltac destruct_evidence :=
  repeat match goal with
    | [ |- {(if ?X then True else False)} + { _ } ] =>
      destruct X; try solve[simpl; right; congruence];
      try solve[simpl; left; trivial]
 end.

Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
Proof.
  intros.
  destruct x; destruct y;  unfold eq; unfold eqb; destruct_evidence; crush.
Qed.

End TermModule.


Require Import Coq.ZArith.BinInt Coq.NArith.BinNat Coq.QArith.QArith_base.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String Coq.Strings.Ascii.
Require Crypto.Util.Strings.String.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Coq.Strings.HexString.
Require Import Crypto.Util.Strings.Decimal.
Require Export Crypto.Util.Level.
Import ListNotations. Local Open Scope Z_scope. Local Open Scope list_scope. Local Open Scope string_scope.
Local Open Scope level_scope.

Class ShowLevel T := show_lvl : T -> Level -> string.
Class ShowLevel2 A B := show_lvl2 : A -> B -> Level -> string.
Class ShowLevel3 A B C := show_lvl3 : A -> B -> C -> Level -> string.
Class Show T := show : T -> string.
Class ShowLines T := show_lines : T -> list string.
Definition show_lvl2_explicit (F : ShowLevel unit -> ShowLevel unit -> ShowLevel2 unit unit)
  : (Level -> string) -> (Level -> string) -> (Level -> string)
  := fun show_f show_x => F (fun 'tt => show_f) (fun 'tt => show_x) tt tt.
Notation app_lvl := (Level.level 10) (only parsing).
Notation term_lvl := (Level.level 200) (only parsing).
Notation pair_lvl := (Level.prev term_lvl) (only parsing).
Notation pair_assoc := LeftAssoc (only parsing).
Notation opp_lvl := (Level.level 35) (only parsing).
Notation impl_lvl := (Level.level 99) (only parsing).
Notation impl_assoc := RightAssoc (only parsing).
Notation iff_lvl := (Level.level 95) (only parsing).
Notation iff_assoc := RightAssoc (only parsing).
Notation lneg_lvl := (Level.level 75) (only parsing).
Notation rel_lvl := (Level.level 70) (only parsing).
Notation rel_assoc := RightAssoc (only parsing).
Notation add_lvl := (Level.level 50) (only parsing).
Notation add_assoc := FullyAssoc (only parsing).
Notation sub_lvl := (Level.level 50) (only parsing).
Notation sub_assoc := LeftAssoc (only parsing).
Notation mul_lvl := (Level.level 40) (only parsing).
Notation mul_assoc := FullyAssoc (only parsing).
Notation div_lvl := (Level.level 40) (only parsing).
Notation div_assoc := NoAssoc (only parsing).
Notation mod_lvl := (Level.level 40) (only parsing).
Notation mod_assoc := NoAssoc (only parsing).
Notation andb_lvl := (Level.level 40) (only parsing).
Notation andb_assoc := FullyAssoc (only parsing).
Notation orb_lvl := (Level.level 40) (only parsing).
Notation orb_assoc := FullyAssoc (only parsing).
Notation pow_lvl := (Level.level 30) (only parsing).
Notation pow_assoc := RightAssoc (only parsing).

Global Instance Show_of_ShowLevel {T} `{ShowLevel T} : Show T | 1000 := fun t => show_lvl t term_lvl.
Definition ShowLevel_of_Show {T} `{Show T} : ShowLevel T := fun t _ => show t.
Definition ShowLines_of_Show {T} `{Show T} : ShowLines T := fun t => [show t].
Global Instance Show_of_ShowLines {T} `{ShowLines T} : Show T | 1000 := fun t => String.concat String.NewLine (show_lines t).
Global Coercion Show_of_ShowLevel : ShowLevel >-> Show.
Global Coercion ShowLevel_of_Show : Show >-> ShowLevel.

Global Instance show_lvl_const : ShowLevel (unit -> string) := fun f _ => f tt.
Global Instance show_lvl_id : ShowLevel (Level -> string) := fun f lvl => f lvl.

Definition maybe_wrap_parens (parens : bool) (s : string)
  := if parens then "(" ++ s ++ ")" else s.
Definition show_wrap_parens (plvl : Level) {A} `{ShowLevel A} : ShowLevel A
  := fun a lvl => if lvl <? plvl then "(" ++ show_lvl a term_lvl ++ ")" else show_lvl a lvl.
Definition lvl_wrap_parens (plvl : Level) (s : string) : Level -> string
  := show_wrap_parens plvl (fun 'tt => s).
(** wrap with parentheses if the level is negative *)
Definition neg_wrap_parens_with_lvl (f : Level -> string) : Level -> string
  := show_wrap_parens 0 f.
Definition neg_wrap_parens (f : string) : Level -> string
  := neg_wrap_parens_with_lvl (fun _ => f).
Definition ShowLevel2_binop_assoc (assoc : Associativity) (binop_lvl : Level) (binop : string) {A B}
           `{ShowLevel A, ShowLevel B}
  : ShowLevel2 A B
  := fun a b
     => lvl_wrap_parens
          binop_lvl
          (let lvl := binop_lvl in
           match assoc with
           | LeftAssoc => show_lvl a lvl ++ binop ++ show_lvl b (Level.next lvl)
           | RightAssoc => show_lvl a (Level.next lvl) ++ binop ++ show_lvl b lvl
           | NoAssoc => show_lvl a (Level.next lvl) ++ binop ++ show_lvl b (Level.next lvl)
           | FullyAssoc => show_lvl a lvl ++ binop ++ show_lvl b lvl
           | ExplicitAssoc lvl_l lvl_r => show_lvl a lvl_l ++ binop ++ show_lvl b lvl_r
           end).
Definition show_lvl_binop (assoc : Associativity) (binop_lvl : Level) {A B} `{SA : ShowLevel A, SB : ShowLevel B}
  : A -> string -> B -> Level -> string
  := fun a binop b => ShowLevel2_binop_assoc assoc binop_lvl binop a b.
Definition show_lvl_app {A B} `{ShowLevel A, ShowLevel B} : ShowLevel2 A B
  := ShowLevel2_binop_assoc LeftAssoc app_lvl " ".
Definition show_lvl_app2 {A B C} `{ShowLevel A, ShowLevel B, ShowLevel C} : ShowLevel3 A B C
  := fun a b c => show_lvl_app (show_lvl_app a b) c.
Definition show_lvl_preop_assoc (assoc : Associativity) (op_lvl : Level) {A}
           `{ShowLevel A}
  : string -> A -> Level -> string
  := fun preop a => show_lvl_binop assoc op_lvl (fun 'tt => "") preop a.
Definition show_lvl_postop_assoc (assoc : Associativity) (op_lvl : Level) {A}
           `{ShowLevel A}
  : A -> string -> Level -> string
  := fun a postop => show_lvl_binop assoc op_lvl a postop (fun 'tt => "").
Definition show_lvl_unop (unop_lvl : Level) (unop : string) {A}
           `{ShowLevel A}
  : ShowLevel A
  := fun a => show_lvl_preop_assoc RightAssoc unop_lvl unop a.
Definition show_lvl_postop (postop_lvl : Level) {A}
           `{ShowLevel A}
  : A -> string -> Level -> string
  := fun a postop => show_lvl_postop_assoc LeftAssoc postop_lvl a postop.

Definition maybe_wrap_parens_lines (parens : bool) (s : list string)
  := match s, parens with
     | s, false => s
     | nil, _ => nil
     | [s], _ => [maybe_wrap_parens parens s]
     | s, true => "(" :: List.map (String " ") s ++ [")"]
     end%list.

Global Instance show_lvl_unit : ShowLevel unit := fun 'tt => neg_wrap_parens "tt".
Global Instance show_lvl_True : ShowLevel True := fun 'I => neg_wrap_parens "I".
Global Instance show_lvl_False : ShowLevel False := fun pf => match pf with end.
Global Instance show_lvl_Empty_set : ShowLevel Empty_set := fun pf => match pf with end.
Global Instance show_lvl_bool : ShowLevel bool := fun b => neg_wrap_parens (if b then "true" else "false").
Global Instance show_lvl_option {T} `{ShowLevel T} : ShowLevel (option T)
  := fun v
     => match v with
        | Some v
          => show_lvl_app (fun 'tt => "Some") (show_lvl v)
        | None => neg_wrap_parens "None"
        end.
Global Instance show_option {T} `{Show T} : Show (option T) | 2000 := let _ := @ShowLevel_of_Show T in _.
Global Instance show_lvl_list {T} `{ShowLevel T} : ShowLevel (list T)
  := fun ls => neg_wrap_parens
                 ("[" ++ String.concat ", " (List.map (fun v => show_lvl v term_lvl) ls) ++ "]").
Global Instance show_list {T} `{Show T} : Show (list T) | 2000 := let _ := @ShowLevel_of_Show T in _.
Global Instance show_lvl_prod {A B} `{ShowLevel A, ShowLevel B} : ShowLevel (A * B)
  := fun '(a, b) => show_lvl_binop pair_assoc pair_lvl a ", " b.
Global Instance show_prod {A B} `{Show A, Show B} : Show (A * B) | 2000 :=
  let _ := @ShowLevel_of_Show A in
  let _ := @ShowLevel_of_Show B in
  _.
Global Instance show_lvl_sum {A B} `{ShowLevel A, ShowLevel B} : ShowLevel (A + B)
  := fun ab => match ab with
               | inl v => show_lvl_app (fun 'tt => "inl") (show_lvl v)
               | inr v => show_lvl_app (fun 'tt => "inr") (show_lvl v)
               end.
Global Instance show_sum {A B} `{Show A, Show B} : Show (A + B) | 2000
  := let _ := @ShowLevel_of_Show A in
     let _ := @ShowLevel_of_Show B in
     _.
Global Instance show_lvl_sigT {A B} `{ShowLevel A, forall a, ShowLevel (B a)} : ShowLevel (@sigT A B)
  := fun '(existT a b) => show_lvl_binop pair_assoc pair_lvl a "; " b.
Global Instance show_sigT {A B} `{Show A, forall a, Show (B a)} : Show (@sigT A B) | 2000 :=
  let _ := @ShowLevel_of_Show A in
  let _ := fun a => @ShowLevel_of_Show (B a) in
  _.
Global Instance show_lvl_sig {A} {B : A -> Prop} `{ShowLevel A, forall a, ShowLevel (B a)} : ShowLevel (@sig A B)
  := fun '(exist a b) => show_lvl_binop pair_assoc pair_lvl a "; " b.
Global Instance show_sig {A} {B : A -> Prop} `{Show A, forall a, Show (B a)} : Show (@sig A B) | 2000 :=
  let _ := @ShowLevel_of_Show A in
  let _ := fun a => @ShowLevel_of_Show (B a) in
  _.
Global Instance show_lvl_string : ShowLevel string := fun s => neg_wrap_parens ("""" ++ (String.replace """" """""" s) ++ """").
Global Instance show_lvl_ascii : ShowLevel ascii := fun ch => neg_wrap_parens (String "'" (String ch "'")).

Global Instance show_lines_option {T} `{ShowLines T} : ShowLines (option T)
  := fun v
     => match v with
        | Some v
          => match show_lines v with
             | [s] => ["Show " ++ s]
             | s => "Show"::List.map (String " ") s
               end
        | None => ["None"]
        end.
Global Instance show_lines_list {T} `{ShowLines T} : ShowLines (list T)
  := fun ls
     => let ls := List.map show_lines ls in
        (if List.forallb
              (fun lines => Nat.eqb (List.length lines) 1)
              ls
         then ["[" ++ String.concat ", " (List.map (String.concat String.NewLine) ls) ++ "]"]%string
         else ["["] ++ match ls with
                       | nil => ["]"]
                       | x :: xs
                         => (List.map (String " ") x)
                              ++ (List.flat_map
                                    (fun x' => "," :: List.map (String " ") x')
                                    xs)
                              ++ ["]"]
                       end)%list.
Global Instance show_lines_prod {A B} `{ShowLines A, ShowLines B} : ShowLines (A * B)
  := fun '(a, b)
     => match show_lines a, show_lines b with
        | [a], [b] => ["(" ++ a ++ ", " ++ b ++ ")"]%string
        | a, b => ["("] ++ a ++ [", "] ++ b ++ [")"]
        end%list.

Module Export Decimal.
  Global Instance show_lvl_positive : ShowLevel positive
    := fun p => neg_wrap_parens (Decimal.Pos.to_string p).
  Global Instance show_positive : Show positive := show_lvl_positive.
  Global Instance show_lvl_N : ShowLevel N
    := fun n => neg_wrap_parens
                  match n with
                  | N0 => "0"
                  | Npos p => show p
                  end.
  Global Instance show_N : Show N := show_lvl_N.
  Global Instance show_lvl_nat : ShowLevel nat
    := fun n => show_lvl (N.of_nat n).
  Global Instance show_nat : Show nat := show_lvl_nat.
  Global Instance show_lvl_Z : ShowLevel Z
    := fun z
       => match z with
          | Zneg p => show_lvl_unop opp_lvl "-" p
          | Z0 => neg_wrap_parens "0"
          | Zpos p => show_lvl p
          end.
  Global Instance show_Z : Show Z := show_lvl_Z.
  Definition show_lvl_Q_frac : ShowLevel Q
    := fun q
       => if (Qden q =? 1)%positive
          then show_lvl (Qnum q)
          else show_lvl_binop
                 div_assoc div_lvl
                 (Qnum q) " / " (Qden q).
  Definition show_Q_frac : Show Q := show_lvl_Q_frac.
  Global Instance show_lvl_Q : ShowLevel Q
    := fun q
       => if (Qden q =? 1)%positive
          then show_lvl (Qnum q)
          else let lg10 := Z.log10 (Z.pos (Qden q)) in
               if (10^lg10 =? Z.pos (Qden q))%Z
               then let lg10 := Z.to_nat lg10 in
                    let int_part := show_Z (Z.abs (Qnum q) / Z.pos (Qden q))%Z in
                    let dec_part := show_Z (Z.abs (Qnum q) mod (Z.pos (Qden q)))%Z in
                    let abs_part
                        := int_part
                             ++ "."
                             ++ String.string_of_list_ascii (List.repeat "0"%char (lg10 - length dec_part)) ++ dec_part in
                    if (Qnum q <? 0)%Z
                    then show_lvl_unop opp_lvl "-" (fun 'tt => abs_part)
                    else neg_wrap_parens abs_part
               else
                 show_lvl_Q_frac q.
  Global Instance show_Q : Show Q := show_lvl_Q.
End Decimal.

Module Hex.
  Definition show_lvl_positive : ShowLevel positive
    := fun p => neg_wrap_parens (HexString.of_pos p).
  Definition show_positive : Show positive := show_lvl_positive.
  Definition show_lvl_Z : ShowLevel Z
    := fun z => let s := HexString.of_Z (Z.abs z) in
                if z <? 0
                then show_lvl_unop opp_lvl "-" (fun 'tt => s)
                else neg_wrap_parens s.
  Definition show_Z : Show Z := show_lvl_Z.
  Definition show_lvl_N : ShowLevel N
    := fun n
       => match n with
         | N0 => neg_wrap_parens "0"
         | Npos p => show_lvl_positive p
          end.
  Definition show_N : Show N := show_lvl_N.
  Definition show_lvl_nat : ShowLevel nat
    := fun n => show_lvl_N (N.of_nat n).
  Definition show_nat : Show nat := show_lvl_nat.
  Definition show_lvl_Q : ShowLevel Q
    := fun q
       => if (Qden q =? 1)%positive
          then show_lvl_Z (Qnum q)
          else show_lvl_binop
                 div_assoc div_lvl
                 (show_lvl_Z (Qnum q)) " / " (show_lvl_positive (Qden q)).
  Definition show_Q : Show Q := show_lvl_Q.
End Hex.

Module PowersOfTwo.
  Fixpoint show_lvl_Z_up_to' (max : nat) (max_dec : Z) (neg : bool) : ShowLevel Z
    := match max with
       | O => Hex.show_lvl_Z
       | S n'
         => fun z
            => if z <? max_dec
               then Decimal.show_lvl_Z z
               else if Z.abs (2^Z.log2_up z - z) <=? Z.abs (z - 2^Z.log2 z)
                    then let log2z := Z.log2_up z in
                         let z := 2^log2z - z in
                         if z =? 0
                         then show_lvl_binop
                                pow_assoc pow_lvl
                                2 "^" (Decimal.show_lvl_Z log2z)
                         else show_lvl_binop
                                FullyAssoc add_lvl
                                (show_lvl_binop
                                   pow_assoc pow_lvl
                                   2 "^" (Decimal.show_lvl_Z log2z))
                                (if neg then "+" else "-")
                                (show_lvl_Z_up_to' n' max_dec (negb neg) z)
                    else let log2z := Z.log2 z in
                         let z := z - 2^log2z in
                         if z =? 0
                         then show_lvl_binop
                                pow_assoc pow_lvl
                                2 "^" (Decimal.show_lvl_Z log2z)
                         else show_lvl_binop
                                FullyAssoc add_lvl
                                (show_lvl_binop
                                   pow_assoc pow_lvl
                                   2 "^" (Decimal.show_lvl_Z log2z))
                                (if neg then "-" else "+")
                                (show_lvl_Z_up_to' n' max_dec neg z)
       end%Z%string.

  Definition show_lvl_Z_up_to (max : nat) (max_dec : Z) : ShowLevel Z
    := fun z
       => (if z <? 0
           then lvl_wrap_parens
                  add_lvl
                  ("-" ++ show_lvl_Z_up_to' max max_dec false (-z) add_lvl)
           else if z =? 0
                then neg_wrap_parens "0"
                else show_lvl_Z_up_to' max max_dec false z)%Z.
  Definition show_Z_up_to (max : nat) (max_dec : Z) : Show Z
    := show_lvl_Z_up_to max max_dec.
  Definition show_lvl_Z : ShowLevel Z
    := fun z => show_lvl_Z_up_to (S (Z.to_nat (Z.log2_up (Z.abs z)))) 32 z.
  Definition show_Z : Show Z
    := show_lvl_Z.
End PowersOfTwo.


Require Import Msg Sty Shape Var.

Create HintDb contractive discriminated.

Inductive Contractive : Sty -> Prop :=
| Contractive_unit :
    Contractive unit
| Contractive_send :
    forall S B,
    Contractive S ->
    Contractive (send B S)
| Contractive_recv :
    forall S B,
    Contractive S ->
    Contractive (recv B S)
| Contractive_echoice :
    forall S1 S2,
    Contractive S1 ->
    Contractive S2 ->
    Contractive (echoice S1 S2)
| Contractive_ichoice :
    forall S1 S2,
    Contractive S1 ->
    Contractive S2 ->
    Contractive (ichoice S1 S2)
| Contractive_mu :
    forall S X,
    Contractive S ->
    shape S <> varS ->
    Contractive (mu X S)
| Contractive_var :
    forall X,
    Contractive (var X)
.
Hint Constructors Contractive : contractive.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* Negative occurrence *)
Fail Inductive t : Type :=
  c : (t -> nat) -> t.

(* Non-strictely positive occurrence *)
Fail Inductive t : Type :=
  c : ((t -> nat) -> nat) -> t.

(* Self-nested type (no proof of
   soundness yet *)
Fail Inductive t (A:Type) : Type :=
  c : t (t A) -> t A.

(* Nested inductive types *)

Inductive pos (A:Type) :=
  p : pos A -> pos A.

Inductive nnpos (A:Type) :=
  nnp : ((A -> nat) -> nat) -> nnpos A.

Inductive neg (A:Type) :=
  n : (A->neg A) -> neg A.

Inductive arg : Type -> Prop :=
  a : forall A, arg A -> arg A.

(* Strictly covariant parameter: accepted. *)
Fail Fail Inductive t :=
  c : pos t -> t.

(* Non-strictly covariant parameter: not
   strictly positive. *)
Fail Inductive t :=
  c : nnpos t -> t.

(* Contravariant parameter: not positive. *)
Fail Inductive t :=
  c : neg t -> t.

(* Strict index: not positive. *)
Fail Inductive t :=
  c : arg t -> t.


Require Import Cases.
Require Import Definitions.
Require Import Axioms.
Require Import Lemma5_Lemmas.
Require Import Lemma5.

Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Program.Tactics.
Require Import Operational_Semantics.
Require Import Coq.Arith.Minus.
Require Import Coq.Arith.Lt.

(*-------------------------------------------------------------------------------------------------------*)
(*If hbo holds, then hb holds! *)
Lemma HBO_HB : forall(Ex:Exec)(a b:Effect), Ex-hbo a b -> Ex-hb a b.
Proof.
  intros Ex a b Hbo. induction Hbo.
  +Case"base case:".
   inversion H; try(unfold hb; apply t_step).
   right; apply H0 . left; apply H0.

  +Case"inductive step".
   apply t_trans with (y:=y). apply IHHbo1. apply IHHbo2.
Qed.

(*-------------------------------------------------------------------------------------------------------*)
(* hbo(a,b) AND vis(b,c) Will Result in : hbo(a,c)*)
Lemma  HBO'_newEff_help : forall (Ex:Exec) (a b c:Effect),
                            Ex-hbo a b -> Ex-vis  b c -> Ex-hbo a c.
Proof.
  intros Ex a b c HBO VIS.
  apply t_trans with (y:= b). apply HBO.
  apply t_step. right. apply VIS.
Qed.

(*-------------------------------------------------------------------------------------------------------*)
(* In a reduction, if hbo(a,b) holds, then η is not equal to either a or b*)
Lemma HBO'_newEff: forall (Ex Ex':Exec)(a b η:Effect) (r:ReplID) (i:SeqNo)(s:SessID)(op:OperName)(θ:Store),
                     [ θ |- Ex, < s, i, op > ~ r ~> Ex', η] -> WF Ex -> Ex'-hbo a b ->
                     Ex'-A a -> Ex'-A b  ->~((a=η)/\ (b=η)).

Proof. intros Ex Ex' a b η r i s op θ Hreduct HWF HBO'  Ha Hb .
       intro H.  inversion H.
       rewrite H0 in HBO'. rewrite H1 in HBO'.
       assert (WF Ex') as WF'. { apply Lemma5 in Hreduct. apply Hreduct. apply HWF. }
                               apply WellFormed_res1 in WF'.
       destruct_conjs. clear H2 H3; rename H4 into HBcyc. specialize (HBcyc η).
       apply HBcyc.
       assert ((Ex') -A η \/ ~(Ex') -A η) as Hcomp. apply Soup_comp.
       inversion Hcomp. apply H2. apply WF_Relation with (a:=η)(b:=η)(r:=Ex'-hbo) in HBO'.
       inversion HBO'. apply Hbo_Domain in H3. apply H3. apply HBO_HB. apply HBO'.
Qed.

(*-------------------------------------------------------------------------------------------------------*)
(*A trivial fact about natural numbers: Sn is not less than n! *)
Lemma triv_nat : forall (n:nat), ~(lt (S n) n).
Proof.
  intros n H.
  induction n as [|n'].
  +Case"Induction Base:".
   inversion H.
  +Case"Induction Step:".
   inversion H. apply IHn'. unfold lt. rewrite H1. apply le_n.
   subst.  unfold lt in H. apply le_S_n in H. apply le_lt_n_Sm in H.
   apply lt_S_n in H. intuition.
Qed.

(*-------------------------------------------------------------------------------------------------------*)
(*If E ~> E', then there is not a z, such that   hbo'(η,z) *)
Lemma HBO'_HBO_help : forall (Ex Ex':Exec)(η:Effect) (r:ReplID) (i:SeqNo)(s:SessID)(op:OperName)(θ:Store),
                        [ θ |- Ex, < s, i, op > ~ r ~> Ex', η] ->
                        ~(exists z:Effect, Ex'-A z /\ Ex'-hbo η z).

Proof.
  intros Ex Ex' η r u s op θ H Hc.
  destruct Hc as [k G]. intuition. rename H0 into HAk. rename H1 into Hbo'.
  assert ( [ θ |- Ex, < s, u, op > ~ r ~> Ex', η]) as Hreduct. apply H.
  apply CorrectFreshness with (ex1:=Ex)(ex2:=Ex')(opk :=  < s, u, op >) (eff:=η) (r:=r) in H. rename H into Hfresh.
  induction Hbo'.
  -Case"Induction Base".
   rename H into Htemp.
   inversion Htemp as [Hsoo'|Hvis'].
   +SCase"soo'".
    inversion Hsoo'; clear Hsoo'; clear Htemp; rename H into Hso'; rename H0 into Hsameobj'; rename x into η.
    inversion Hreduct; subst. rename H13 into Hi. simpl in Hso'. remember (E A vis so sameobj) as Ex;
      remember (E A' vis' so' sameobj') as Ex'. rename  H9 into H11.  rename H7 into H8.
    specialize (H11 η y). rewrite H11 in Hso'.
    inversion Hso'.
    *SSCase"new effect". inversion H.  clear H. rename H0 into Hso. subst y.
     inversion Hso. assert (seq η = u). intuition. assert (seq η'=u-1). specialize (H5 η'). intuition.
     replace so with Ex-so in H. rewrite  SO_Seq_General  in H. rewrite H0 in H. rewrite H1 in H.
     induction u. simpl in H. inversion H.
     simpl in H. rewrite <-  minus_n_O in H.  apply  triv_nat in  H. apply H.
     rewrite HeqEx. auto. subst. rename η' into η. specialize (H5 η). intuition.
    *SSCase"Same as so". apply WF_Relation with (a:=η) (b:=y) (r:=so) in H. inversion H.
     replace so with Ex-so in H0. apply So_Domain in H0. contradiction.
     rewrite HeqEx. auto.
   +SCase"vis'". clear Htemp. inversion Hreduct. subst. rename x into η.
    rename  H9 into H11.  rename H7 into H8.
    specialize (H8 η y). simpl in Hvis'. apply H8 in Hvis'.
    inversion Hvis'.
    *SSCase"θ r η /\ y = η". inversion H. apply Freshness with (r0:=r) in Hreduct; auto.
    *SSCase"(A η /\ A y) /\ vis η y". apply CorrectFreshness in Hreduct. simpl in  Hreduct. inversion H.
     inversion H0. contradiction.

  -Case"Induction Step". rename x into  η.  intuition. apply H.
   assert ((Ex') -A y \/ ~(Ex') -A y) as Hcomp. apply Soup_comp. inversion Hcomp.
   apply H0. apply WF_Relation with (a:=η)(b:=y)(r:=Ex'-hbo) in Hbo'1 . inversion Hbo'1.
   apply Hbo_Domain in H2. contradiction.
   apply Hreduct.
Qed.

(*-------------------------------------------------------------------------------------------------------*)
(*In a reduction, if x<>η and y<>η then:   hbo'(x,y) -> hbo(x,y)  *)
Lemma HBO'_HBO: forall (Ex Ex':Exec)(a b η:Effect) (r:ReplID) (i:SeqNo)(s:SessID)(op:OperName)(θ:Store),
                  [ θ |- Ex, < s, i, op > ~ r ~> Ex', η] -> WF Ex -> ~(b=η)-> Ex'-hbo a b -> Ex-hbo a b.
Proof.
  intros Ex Ex' a b η r i s op θ H HWF Hbη Hbo'.
  induction Hbo'.
  -Case"induction base".
   subst. inversion H0.
   inversion H1.
   apply t_step. left.
   +SCase"Proof from soo".
    unfold soo. split.
    *SSCase"Proof of so".
     inversion H. subst. specialize (H14 x y). apply H14 in H2.
     inversion H2. inversion H4.  contradiction. apply H4.
    *SSCase"Porof of saemobj".
     assert (~(x=η)).  intro.
     subst. inversion H. subst η0 op0 i0 s0. specialize (H14 η y). replace Ex'-so with so' in H2.
     rewrite H14 in H2. inversion H2. inversion H4. contradiction.
     replace so with Ex-so in H4. apply CorrectFreshness in H.
     apply WF_Relation with (a:=η)(b:=y)(r:=Ex-so) in H4.  inversion H4. apply So_Domain in H5.
     contradiction.
     rewrite<- H13. auto. rewrite<- H15. auto.
     apply WF_Relation with (a:=x)(b:=y)(r:=Ex'-so) in H2. inversion H2.
     apply So_Domain in H6.  apply So_Domain in H5. inversion H.
     subst η0 op0 i0 s0. assert (Ex-A x). specialize (H14 x). simpl in H5. subst.
     rewrite <- H14 in H5. simpl. inversion H5. apply H7. contradiction.
     assert (Ex-A y).  specialize (H14 y). simpl in H6. subst. rewrite <- H14 in H6.
     simpl. inversion H6. apply H8. contradiction.
     apply Sameobj_Def with (a:=x)(b:=y) in H.
     rewrite<-H16 in H. apply H. apply H7. apply H8.
   +SCase"Proof from vis".
    apply t_step. right. inversion H. subst. specialize (H10 x y). apply H10 in H1.
    inversion H1. inversion H2. contradiction. apply H2.

  -Case "induction step".
   apply t_trans with (y:=y).
   apply IHHbo'1; try (auto). intro.
   subst. apply  HBO'_HBO_help in H. apply H. exists z.
   split.
   assert (forall (Ex:Exec)(eff:Effect), (Ex-A eff)\/(~ Ex-A eff)) as Hcomp. apply Soup_comp.
   specialize (Hcomp Ex' z). inversion Hcomp.
   apply H0. apply WF_Relation with (r:=Ex'-hbo) (a:=η)(b:=z) in Hbo'2.
   inversion Hbo'2. apply Hbo_Domain in H2. contradiction. apply Hbo'2.
   apply IHHbo'2; try (auto).
Qed.

(*-------------------------------------------------------------------------------------------------------*)
Lemma Inversion_HBO_Help: forall (Ex:Exec)(a b:Effect)(A: Exec_A)(vis so sameobj :Relation),
                            (Ex = (E A vis so sameobj))->
                            (Ex-hbo a b) -> (exists c, (Ex-hbo a c) /\ ((Ex-vis) ∪ (Ex-soo)) c b )\/ (((Ex-soo) ∪ (Ex-vis) ) a b) .
Proof.
  intros Ex a b A vis so sameobj HExec. intro HBO.
  induction HBO.
  -Case"direct hbo".
   right. apply H.
  -Case"indirect hbo".
   destruct IHHBO2.
   +SCase"left2".
    left. destruct H as [k G]. exists k. split.
    apply t_trans with (y:=y)(z:=k). apply HBO1.
    apply G. apply G.
   +SCase"right2".
    left. exists y. split. apply HBO1. unfold Rel_Union. destruct H. auto. auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable supp_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable rT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.

Variable deftworightangles_1 : (forall A B C D E F : Universe, (exists X Y Z U V : Universe, (rT_ A B C D E F -> (supp_ X Y U V Z /\ (congA_ A B C X Y U /\ congA_ D E F V Y Z))))).
Variable deftworightangles2_2 : (forall A B C D E F X Y Z U V : Universe, ((supp_ X Y U V Z /\ (congA_ A B C X Y U /\ congA_ D E F V Y Z)) -> rT_ A B C D E F)).
Variable lemma_equalanglessymmetric_3 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_equalanglestransitive_4 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_supplements_5 : (forall A B C D F Xa Xb Xc Xd Xf : Universe, ((congA_ A B C Xa Xb Xc /\ (supp_ A B C D F /\ supp_ Xa Xb Xc Xd Xf)) -> congA_ D B F Xd Xb Xf)).

Theorem lemma_supplements2_6 : (forall A B C D E F J K L P Q R : Universe, ((rT_ A B C P Q R /\ (congA_ A B C J K L /\ rT_ J K L D E F)) -> (congA_ P Q R D E F /\ congA_ D E F P Q R))).
Proof.
  time tac.
Qed.

End FOFProblem.


From Hammer Require Import Hammer.

Require Import Recdef.
From compcert Require Import Coqlib.
From compcert Require Import Maps.
From compcert Require Import Errors.

Local Open Scope nat_scope.
Local Open Scope error_monad_scope.

Module Type TYPE_ALGEBRA.

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

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

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

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

Parameter low_bound: t -> t.
Parameter high_bound: t -> t.
Axiom low_bound_sub: forall t, sub (low_bound t) t.
Axiom low_bound_minorant: forall x y, sub x y -> sub (low_bound y) x.
Axiom high_bound_sub: forall t, sub t (high_bound t).
Axiom high_bound_majorant: forall x y, sub x y -> sub y (high_bound x).

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

End TYPE_ALGEBRA.

Module SubSolver (T: TYPE_ALGEBRA).

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;
te_sub: list constraint
}.

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

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.

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.

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

OK (false, e)
else match T.sub_dec lo1 hi2 with
| left s =>

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.

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.

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. hammer_hook "Subtyping" "Subtyping.SubSolver.weight_bounds_1".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.weight_bounds_2".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.weight_type_move".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.weight_constraints_tighter".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.weight_solve_rec".
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).

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
| OK(e', true)  => solve_constraints e'
| Error msg => Error msg
end.
Proof. hammer_hook "Subtyping" "Subtyping.SubSolver.weight_typenv".
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').

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. hammer_hook "Subtyping" "Subtyping.SubSolver.satisf_initial".
unfold initial; intros; split; simpl; intros.
rewrite PTree.gempty in H; discriminate.
contradiction.
Qed.

Lemma type_def_incr:
forall te x ty e e', type_def e x ty = OK e' -> satisf te e' -> satisf te e.
Proof. hammer_hook "Subtyping" "Subtyping.SubSolver.type_def_incr".
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.
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_def_sound".
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.
+ 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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_defs_incr".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_defs_sound".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_use_incr".
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.
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_use_sound".
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.
+ 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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_uses_incr".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_uses_sound".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_move_incr".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_move_sound".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.solve_rec_incr".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.solve_rec_sound".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_move_false".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.solve_rec_false".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.solve_constraints_incr".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.solve_constraints_sound".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.solve_sound".
unfold solve; intros. monadInv H.
eapply solve_constraints_incr. eauto. eapply solve_constraints_sound; eauto.
Qed.

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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_def_complete".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_defs_complete".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_use_complete".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_uses_complete".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.type_move_complete".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.solve_rec_complete".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.solve_constraints_complete".
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. hammer_hook "Subtyping" "Subtyping.SubSolver.solve_complete".
intros. unfold solve.
destruct (solve_constraints_complete te e H) as (e' & P & Q).
econstructor. rewrite P. simpl. eauto.
Qed.

End SubSolver.