Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Rewriter.Util.Decidable.
Require Import Rewriter.Util.Tactics.DestructHead.
Require Import Rewriter.Util.Tactics.SetoidSubst.
Require Import Rewriter.Util.GlobalSettings.

Scheme Equality for sum.

Definition sumwise {A B} (RA:relation A) (RB : relation B) : relation (A + B)
  := fun x y => match x, y with
                | inl x', inl y' => RA x' y'
                | inr x', inr y' => RB x' y'
                | _, _ => False
                end.

Arguments sumwise {A B} _ _ _ _.

Global Instance inl_Proper_sumwise {A B RA RB}
  : Proper (RA ==> sumwise RA RB) (@inl A B) | 10.
Proof. repeat intro; cbv; assumption. Qed.
Global Instance inr_Proper_sumwise {A B RA RB}
  : Proper (RB ==> sumwise RA RB) (@inr A B) | 10.
Proof. repeat intro; cbv; assumption. Qed.

Global Instance Equivalence_sumwise
  : forall {A B} {RA:relation A} {RB:relation B}
           {RA_equiv:Equivalence RA} {RB_equiv:Equivalence RB},
    Equivalence (sumwise RA RB) | 10.
Proof.
  intros A B RA RB RA_equiv RB_equiv.
  split; repeat intros [?|?]; simpl; trivial; destruct RA_equiv, RB_equiv; try tauto; eauto.
Qed.

Lemma sumwise_beq_bp {A B} {A_beq B_beq} {A_le : relation A} {B_le : relation B}
      (A_bp : forall x y, A_beq x y = true -> A_le x y)
      (B_bp : forall x y, B_beq x y = true -> B_le x y)
  : forall x y, sum_beq _ _ A_beq B_beq x y = true -> sumwise A_le B_le x y.
Proof.
  intros [x|x] [y|y]; cbn; auto using Bool.diff_false_true.
Defined.

Lemma sumwise_beq_pb {A B} {A_beq B_beq} {A_le : relation A} {B_le : relation B}
      (A_pb : forall x y, A_le x y -> A_beq x y = true)
      (B_pb : forall x y, B_le x y -> B_beq x y = true)
  : forall x y, sumwise A_le B_le x y -> sum_beq _ _ A_beq B_beq x y = true.
Proof.
  intros [x|x] [y|y]; cbn; auto using Bool.diff_false_true.
Defined.

Definition sum_le {A B} (RA:relation A) (RB : relation B) : relation (A + B)
  := fun x y => match x, y with
                | inl x', inl y' => RA x' y'
                | inr x', inr y' => RB x' y'
                | inl _, inr _ => True
                | inr _, inl _ => False
                end.

Arguments sum_le {A B} _ _ _ _.

Global Instance inl_Proper_sum_le {A B RA RB}
  : Proper (RA ==> sum_le RA RB) (@inl A B) | 10.
Proof. repeat intro; cbv; assumption. Qed.
Global Instance inr_Proper_sum_le {A B RA RB}
  : Proper (RB ==> sum_le RA RB) (@inr A B) | 10.
Proof. repeat intro; cbv; assumption. Qed.

Global Instance sum_le_Reflexive {A B RA RB}
       `{@Reflexive A RA,@Reflexive B RB}
  : Reflexive (sum_le RA RB) | 10.
Proof. repeat intro; destruct_head'_sum; cbn; reflexivity. Defined.

Global Instance sum_le_Transitive {A B RA RB}
       `{@Transitive A RA,@Transitive B RB}
  : Transitive (sum_le RA RB) | 10.
Proof.
  repeat intro; destruct_head'_sum; cbn in *.
  all: try ((idtac + exfalso); assumption).
  all: etransitivity; eassumption.
Defined.

Global Instance sum_le_Irreflexive {A B RA RB}
       `{@Irreflexive A RA,@Irreflexive B RB}
  : Irreflexive (sum_le RA RB) | 10.
Proof.
  intros [?|?] H'; cbn in H'; apply irreflexivity in H'; assumption.
Qed.

Definition sum_leb {A B} (A_leb : A -> A -> bool) (B_leb : B -> B -> bool)
  : A + B -> A + B -> bool
  := fun x y => match x, y with
                | inl x', inl y' => A_leb x' y'
                | inr x', inr y' => B_leb x' y'
                | inl _, inr _ => true
                | inr _, inl _ => false
                end.

Arguments sum_leb {A B} _ _ _ _.

Lemma sum_leb_bp {A B} {A_leb B_leb} {A_le : relation A} {B_le : relation B}
      (A_bp : forall x y, A_leb x y = true -> A_le x y)
      (B_bp : forall x y, B_leb x y = true -> B_le x y)
  : forall x y, sum_leb A_leb B_leb x y = true -> sum_le A_le B_le x y.
Proof.
  intros [x|x] [y|y]; cbn; auto using Bool.diff_false_true.
Defined.

Lemma sum_leb_pb {A B} {A_leb B_leb} {A_le : relation A} {B_le : relation B}
      (A_pb : forall x y, A_le x y -> A_leb x y = true)
      (B_pb : forall x y, B_le x y -> B_leb x y = true)
  : forall x y, sum_le A_le B_le x y -> sum_leb A_leb B_leb x y = true.
Proof.
  intros [x|x] [y|y]; cbn; auto using Bool.diff_false_true.
Defined.

Ltac congruence_sum_step :=
  match goal with
  | [ H : inl _ = inr _ |- _ ] => solve [ inversion H ]
  | [ H : inr _ = inl _ |- _ ] => solve [ inversion H ]
  | [ H : inl _ = inl _ |- _ ] => inversion H; clear H
  | [ H : inr _ = inr _ |- _ ] => inversion H; clear H
  end.
Ltac congruence_sum := repeat congruence_sum_step.

Local Hint Extern 0 => solve [ solve_decidable_transparent ] : typeclass_instances.
Global Instance dec_sumwise {A B RA RB} {HA : DecidableRel RA} {HB : DecidableRel RB} : DecidableRel (@sumwise A B RA RB) | 10.
Proof.
  intros [x|x] [y|y]; exact _.
Defined.

Global Instance dec_sum_le {A B RA RB} {HA : DecidableRel RA} {HB : DecidableRel RB} : DecidableRel (@sum_le A B RA RB) | 10.
Proof.
  intros [x|x] [y|y]; exact _.
Defined.

Global Instance sum_le_StrictOrder {A B RA RB} `{@StrictOrder A RA,@StrictOrder B RB} : StrictOrder (sum_le RA RB) | 10.
Proof. split; exact _. Defined.

Global Instance sumwise_Proper_iff {A B eqA eqB leA leB}
       {A_Proper : Proper (eqA ==> eqA ==> iff) leA}
       {B_Proper : Proper (eqB ==> eqB ==> iff) leB}
  : Proper (@sumwise A B eqA eqB ==> @sumwise A B eqA eqB ==> iff)
           (@sumwise A B leA leB) | 5.
Proof.
  cbv [Proper respectful] in *; repeat intro; destruct_head'_sum; cbn in *.
  all: try (exfalso; assumption).
  all: try reflexivity.
  all: eauto with nocore.
Qed.

Global Instance sum_le_Proper_iff {A B eqA eqB leA leB}
       {A_Proper : Proper (eqA ==> eqA ==> iff) leA}
       {B_Proper : Proper (eqB ==> eqB ==> iff) leB}
  : Proper (@sumwise A B eqA eqB ==> @sumwise A B eqA eqB ==> iff)
           (@sum_le A B leA leB) | 5.
Proof.
  cbv [Proper respectful] in *; repeat intro; destruct_head'_sum; cbn in *.
  all: try (exfalso; assumption).
  all: try reflexivity.
  all: eauto with nocore.
Qed.

Global Instance sum_le_Proper_le {A B leA leB}
       {A_Proper : Proper (Basics.flip leA ==> leA ==> Basics.impl) leA}
       {B_Proper : Proper (Basics.flip leB ==> leB ==> Basics.impl) leB}
  : Proper (Basics.flip (@sum_le A B leA leB) ==> @sum_le A B leA leB ==> Basics.impl)
           (@sum_le A B leA leB) | 10.
Proof.
  cbv [Basics.flip Basics.impl Proper respectful] in *; repeat intro; destruct_head'_sum; cbn in *.
  all: try (exfalso; assumption).
  all: try exact I.
  all: eauto with nocore.
Qed.

Global Instance sum_le_Proper_le_flip {A B leA leB}
       {A_Proper : Proper (leA ==> Basics.flip leA ==> Basics.flip Basics.impl) leA}
       {B_Proper : Proper (leB ==> Basics.flip leB ==> Basics.flip Basics.impl) leB}
  : Proper (@sum_le A B leA leB ==> Basics.flip (@sum_le A B leA leB) ==> Basics.flip Basics.impl)
           (@sum_le A B leA leB) | 10.
Proof.
  cbv [Basics.flip Basics.impl Proper respectful] in *; repeat intro; destruct_head'_sum; cbn in *.
  all: try (exfalso; assumption).
  all: try exact I.
  all: eauto with nocore.
Qed.

Module Sum.
  Notation eqb := sum_beq.
  Notation eqb_bl := internal_sum_dec_bl.
  Notation eqb_lb := internal_sum_dec_lb.

  Definition compare {A B}
             (A_compare : A -> A -> comparison)
             (B_compare : B -> B -> comparison)
             (x y : A + B)
    : comparison
    := match x, y with
       | inl x, inl y => A_compare x y
       | inr x, inr y => B_compare x y
       | inl _, inr _ => Lt
       | inr _, inl _ => Gt
       end.
End Sum.

(** ** Equality for [sum] *)
Section sum.
  Local Notation sum_code u v
    := (match u, v with
        | inl u', inl v'
        | inr u', inr v'
          => u' = v'
        | inl _, _
        | inr _, _
          => False
        end).

  (** *** Equality of [sum] is a [match] *)
  Definition path_sum {A B} (u v : sum A B) (p : sum_code u v)
    : u = v.
  Proof. destruct u, v; first [ apply f_equal | exfalso ]; exact p. Defined.

  (** *** Equivalence of equality of [sum] with [sum_code] *)
  Definition unpath_sum {A B} {u v : sum A B} (p : u = v)
    : sum_code u v.
  Proof. subst v; destruct u; reflexivity. Defined.

  Definition path_sum_iff {A B}
             (u v : @sum A B)
    : u = v <-> sum_code u v.
  Proof.
    split; [ apply unpath_sum | apply path_sum ].
  Defined.

  (** *** Eta-expansion of [@eq (sum _ _)] *)
  Definition path_sum_eta {A B} {u v : @sum A B} (p : u = v)
    : p = path_sum u v (unpath_sum p).
  Proof. destruct u, p; reflexivity. Defined.

  (** *** Induction principle for [@eq (sum _ _)] *)
  Definition path_sum_rect {A B} {u v : @sum A B} (P : u = v -> Type)
             (f : forall p, P (path_sum u v p))
    : forall p, P p.
  Proof. intro p; specialize (f (unpath_sum p)); destruct u, p; exact f. Defined.
  Definition path_sum_rec {A B u v} (P : u = v :> @sum A B -> Set) := path_sum_rect P.
  Definition path_sum_ind {A B u v} (P : u = v :> @sum A B -> Prop) := path_sum_rec P.
End sum.

(** ** Useful Tactics *)
(** *** [inversion_sum] *)
Ltac induction_path_sum H :=
  induction H as [H] using path_sum_rect;
  try match type of H with
      | False => exfalso; exact H
      end.
Ltac inversion_sum_step :=
  match goal with
  | [ H : inl _ = inl _ |- _ ]
    => induction_path_sum H
  | [ H : inl _ = inr _ |- _ ]
    => induction_path_sum H
  | [ H : inr _ = inl _ |- _ ]
    => induction_path_sum H
  | [ H : inr _ = inr _ |- _ ]
    => induction_path_sum H
  end.
Ltac inversion_sum := repeat inversion_sum_step.


(* Intended for use without Import. *)

Set Implicit Arguments.

Require ne_list.
Require Import Setoid.
Require Import util.
Require List.

Section contents.

  Variable E: Set.

  Unset Elimination Schemes.

  Inductive T: Set :=
    | Leaf: E -> T
    | Node: ne_list.L T -> T.

  Set Elimination Schemes.

  Definition fold (Y: Set) (f: E -> Y) (g: ne_list.L Y -> Y): T -> Y :=
    fix F (t: T) :=
      match t with
      | Leaf e => f e
      | Node l => g (ne_list.map F l)
      end.

  Definition T_rect (P: T -> Type) (Pleaf: forall n, P (Leaf n)) (Pone: forall t, P t -> P (Node (ne_list.one t))) (Pcons: forall t l, P t -> P (Node l) -> P (Node (ne_list.cons t l))): forall t, P t :=
    fix F (t: T) :=
      match t return P t with
      | Leaf n => Pleaf n
      | Node l => (fix G (r: ne_list.L T) :=
        match r return P (Node r) with
        | ne_list.one x => Pone x (F x)
        | ne_list.cons x y => Pcons x y (F x) (G y)
        end) l
      end.

  Definition T_ind (P: T -> Prop) (Pleaf: forall n, P (Leaf n)) (Pone: forall t, P t -> P (Node (ne_list.one t))) (Pcons: forall t l, P t -> P (Node l) -> P (Node (ne_list.cons t l))): forall t, P t := T_rect P Pleaf Pone Pcons.

  Definition T_rec (P: T -> Set) (Pleaf: forall n, P (Leaf n)) (Pone: forall t, P t -> P (Node (ne_list.one t))) (Pcons: forall t l, P t -> P (Node l) -> P (Node (ne_list.cons t l))): forall t, P t := T_rect P Pleaf Pone Pcons.

  Definition alt_ind (P: T -> Prop) (Pleaf: forall n, P (Leaf n)) (Pnode: forall l:ne_list.L T, (forall t, List.In t l -> P t) -> P (Node l)) (t: T): P t.
  Proof with auto.
    revert P Pleaf Pnode t.
    intros P Hbase Hrcd.
    refine (fix IH (t:T) {struct t} : P t := _).
    destruct t.
      apply Hbase.
    apply Hrcd.
    induction l.
      simpl.
      intros.
      destruct H.
        rewrite <- H.
        apply IH.
      elimtype False.
      exact H.
    simpl.
    intros.
    destruct H.
      rewrite <- H.
      apply IH.
    apply IHl.
    assumption.
  Qed.

  Section alt_rect2.

    Variable P: T -> Type.
    Variable Q: ne_list.L T -> Type.
    Variable Pleaf: forall n, P (Leaf n).
    Variable Pnode: forall l, Q l -> P (Node l).
    Variable Qone: forall t, P t -> Q (ne_list.one t).
    Variable Qcons: forall t l, P t -> Q l -> Q (ne_list.cons t l).

    Fixpoint alt_rect2 (t: T): P t :=
      match t return P t with
      | Leaf x => Pleaf x
      | Node l => Pnode ((fix F (l: ne_list.L T) :=
        match l return Q l with
        | ne_list.one t => Qone (alt_rect2 t)
        | ne_list.cons x y => @Qcons x y (alt_rect2 x) (F y)
        end) l)
      end.

  End alt_rect2.

  Definition alt_ind2
    (P: T -> Prop) (Q: ne_list.L T -> Prop)
    (Pleaf: forall n, P (Leaf n))
    (Pnode: forall l, Q l -> P (Node l))
    (Qone: forall t, P t -> Q (ne_list.one t))
    (Qcons: forall t l, P t -> Q l -> Q (ne_list.cons t l)): forall t, P t
  := alt_rect2 P Q Pleaf Pnode Qone Qcons.

  Definition alt_rec2
    (P: T -> Set) (Q: ne_list.L T -> Set)
    (Pleaf: forall n, P (Leaf n))
    (Pnode: forall l, Q l -> P (Node l))
    (Qone: forall t, P t -> Q (ne_list.one t))
    (Qcons: forall t l, P t -> Q l -> Q (ne_list.cons t l)): forall t, P t
  := alt_rect2 P Q Pleaf Pnode Qone Qcons.

 Fixpoint head (t: T): E :=
    match t with
    | Leaf e => e
    | Node l => head (ne_list.head l)
    end.

  Inductive In (e: E): T -> Prop :=
    | InLeaf: In e (Leaf e)
    | InNode l: InL e l -> In e (Node l)
  with InL (e: E): ne_list.L T -> Prop :=
    | InOne t: In e t -> InL e (ne_list.one t)
    | InHead t l: In e t -> InL e (ne_list.cons t l)
    | InTail t l: InL e l -> InL e (ne_list.cons t l).

  Lemma InL_map_inv (Q: Set) (e: E) (f: Q -> T) (l: ne_list.L Q):
    InL e (ne_list.map f l) -> exists e', In e (f e') /\ List.In e' l.
  Proof with auto.
    induction l.
      simpl.
      intros.
      inversion_clear H.
      exists t.
      split...
    simpl.
    intros.
    inversion_clear H.
      exists t.
      split...
    destruct (IHl H0).
    destruct H.
    exists x.
    split...
  Qed.

End contents.

Hint Constructors In.

Hint Resolve InLeaf.
Hint Resolve InNode.
Hint Resolve InOne.
Hint Resolve InHead.
Hint Resolve InTail.
  (* todo: why don't the ctor hints remove the need for these? *)

Definition map (A B: Set) (f: A -> B): T A -> T B := fold (@Leaf _ ∘ f) (@Node _).

Add Parametric Morphism (A B: Set): (@map A B)
  with signature (@ext_eq A B) ==> (@ext_eq (T A) (T B))
  as map_ext_morph.
Proof with try reflexivity.
  unfold ext_eq.
  intros.
  induction x0; simpl.
      unfold compose.
      rewrite H...
    rewrite IHx0...
  rewrite IHx0...
  simpl in IHx1.
  inversion_clear IHx1...
Qed.

Lemma In_map_inv (A B: Set) (e: B) (f: A -> B) (t: T A):
  In e (map f t) -> exists e', e = f e' /\ In e' t.
Proof with auto.
  induction t.
      simpl.
      rewrite comp_apply.
      intros.
      inversion_clear H.
      eauto.
    simpl.
    intros.
    inversion_clear H.
    inversion_clear H0.
    destruct (IHt H).
    destruct H0.
    subst.
    eauto.
  simpl.
  intros.
  inversion_clear H.
  inversion_clear H0.
    destruct (IHt H).
    destruct H0.
    subst.
    eauto.
  simpl in IHt0.
  assert (In e (Node (ne_list.map (map f) l)))...
  destruct (IHt0 H0).
  destruct H1.
  subst.
  exists x.
  split...
  right.
  inversion_clear H2...
Qed.

Lemma map_ext (A B: Set) (f g: A -> B): ext_eq f g -> forall x, map f x = map g x.
Proof. intros. apply map_ext_morph. assumption. Qed.

Lemma map_map (A B C: Set) (f: A -> B) (g: B -> C) (t: T A):
  map g (map f t) = map (g ∘ f) t.
Proof with auto.
  induction t...
    simpl.
    rewrite IHt...
  simpl.
  rewrite IHt.
  simpl in IHt0.
  inversion_clear IHt0...
Qed.

Lemma map_map_ext (A B C: Set) (f: A -> B) (g: B -> C):
  ext_eq (map g ∘ map f) (map (g ∘ f)).
Proof. intros. intro. rewrite comp_apply. apply map_map. Qed.

Lemma map_id_ext (A: Set): ext_eq (map (@id A)) id.
Proof.
  intros. intro.
  induction x.
      simpl.
      auto.
    simpl.
    rewrite IHx.
    auto.
  simpl in *.
  unfold id at 2 in IHx0.
  inversion_clear IHx0.
  rewrite IHx. clear IHx.
  unfold id at 1.
  unfold id at 3.
  rewrite ne_list.map_map.
  do 2 f_equal.
  apply ne_list.map_ext.
  rewrite map_map_ext.
  reflexivity.
Qed.

Lemma In_head (X: Set) (t: T X): In (head t) t.
Proof. induction t; auto. Qed.

Lemma map_Node (X Y: Set) (f: X -> Y) l: map f (Node l) = Node (ne_list.map (map f) l).
Proof. auto. Qed.


Require Import ChargeCore.Logics.ILogic.
Require Import ChargeCore.Logics.ILInsts.
Require Import ChargeCore.Logics.BILInsts.
Require Import ChargeCore.Logics.Later.

Require Import Setoid.
Require Import Omega.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Local Existing Instance ILPre_Ops.
Local Existing Instance ILPre_ILogic.
Local Existing Instance ILFun_Ops.
Local Existing Instance ILFun_ILogic.
(*Local Existing Instance EquivPreorder.*)

Local Transparent ILPre_Ops.
Local Transparent ILFun_Ops.
Local Transparent BILPre_Ops.
Local Transparent BILFun_Ops.
Local Transparent ILLaterPreOps.
Local Transparent ILLaterNatOps.

Section ILogic_Pre.
  Context T (ord: relation T) {HPre : PreOrder ord}.
  Context {A : Type} `{IL: ILogic A}.

  Lemma ILPreFrm_fold_entails x y (P Q : ILPreFrm ord _) (Hord : ord x y) (H : P |-- Q) :
    P x |-- Q y.
  Proof.
    etransitivity.
    apply ILPreFrm_closed.
    eassumption.
    apply H.
  Qed.

  Lemma ILPreFrm_intro (P Q : ILPreFrm ord _) (H : forall x, P x |-- Q x) :
  	P |-- Q.
  Proof.
    intros x; apply H.
  Qed.

  Lemma ILPreFrm_apply {P Q : ILPreFrm ord _} (x : T) (H : P |-- Q) : P x |-- Q x.
  Proof.
    apply H.
  Qed.

End ILogic_Pre.

Section ILogic_Fun.
  Context (T: Type).
  Context {A : Type} {IL: ILogicOps A}.

  Lemma ILFun_fold_entails x y (P Q : Fun T A) (Hxy : x = y) (HPQ : P |-- Q) :
    P x |-- Q y.
  Proof.
    rewrite Hxy; apply HPQ.
  Qed.

  Lemma ILFun_intro (P Q : Fun T A) (H : forall x, P x |-- Q x) :
    P |-- Q.
  Proof.
    intros x; apply H.
  Qed.

  Lemma ILFun_apply {P Q : Fun T A} (x : T) (H : P |-- Q) : P x |-- Q x.
  Proof.
    apply H.
  Qed.

End ILogic_Fun.

Ltac solve_atom :=
	match goal with
		| |- ?P => first [has_evar P | reflexivity | omega | assumption | idtac]
	end.

Ltac solve_model_aux :=
	match goal with
		| |- ?P ?a |-- ?Q ?b =>
			 first [apply ILPreFrm_fold_entails; [solve_atom|solve_model_aux] |
			        apply ILFun_fold_entails; [solve_atom|solve_model_aux]]
	    | |- ?P |-- ?Q => try reflexivity
	end.

Ltac solve_model x :=
	let H := fresh "H" in
	match goal with
		| |- ?Q => let P := type of x in
						assert (P |-- Q) as H; [solve_model_aux|apply H; apply x]

    end.

Ltac ilapply_aux t H :=
	match t with
    	| ?f ?x => ilapply_aux f H; first [apply (ILPreFrm_apply x) in H |
    	                                   apply (ILFun_apply x) in H]
    	| _ => idtac
    end.

Ltac ilapply H :=
	let H1 := fresh "H" in
	  pose proof H as H1;
	  match goal with
	  	| |- ?f ?x => ilapply_aux (f x) H1; apply H1; clear H1
	  end.

Ltac lintros_aux n := first [apply ILPreFrm_intro | apply ILFun_intro]; intro n.

Tactic Notation "lintros" ident(n) := lintros_aux n.
Tactic Notation "lintros" ident(n1) ident(n2) := lintros n1; lintros n2.
Tactic Notation "lintros" ident(n1) ident(n2) ident(n3) := lintros n1 n2; lintros n3.
Tactic Notation "lintros" ident(n1) ident(n2) ident(n3) ident(n4) :=
	lintros n1 n2 n3; lintros n4.
Tactic Notation "lintros" ident(n1) ident(n2) ident(n3) ident(n4) ident(n5) :=
	lintros n1 n2 n3 n4; lintros n5.
Tactic Notation "lintros" ident(n1) ident(n2) ident(n3) ident(n4) ident(n5)
                          ident(n6) :=
	lintros n1 n2 n3 n4 n5; lintros n6.
Tactic Notation "lintros" ident(n1) ident(n2) ident(n3) ident(n4) ident(n5)
                          ident(n6) ident(n7) :=
	lintros n1 n2 n3 n4 n5 n6; lintros n7.
Tactic Notation "lintros" ident(n1) ident(n2) ident(n3) ident(n4) ident(n5)
                          ident(n6) ident(n7) ident(n8) :=
	lintros n1 n2 n3 n4 n5 n6 n7; lintros n8.
Tactic Notation "lintros" ident(n1) ident(n2) ident(n3) ident(n4) ident(n5)
                          ident(n6) ident(n7) ident(n8) ident(n9) :=
	lintros n1 n2 n3 n4 n5 n6 n7 n8; lintros n9.
Tactic Notation "lintros" ident(n1) ident(n2) ident(n3) ident(n4) ident(n5)
                          ident(n6) ident(n7) ident(n8) ident(n9) ident(n10) :=
	lintros n1 n2 n3 n4 n5 n6 n7 n8 n9; lintros n10.


From Hammer Require Import Hammer.

Require Export ZAddOrder.

Module Type ZMulOrderProp (Import Z : ZAxiomsMiniSig').
Include ZAddOrderProp Z.

Theorem mul_lt_mono_nonpos :
forall n m p q, m <= 0 -> n < m -> q <= 0 -> p < q ->  m * q < n * p.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.mul_lt_mono_nonpos".
intros n m p q H1 H2 H3 H4.
apply le_lt_trans with (m * p).
apply mul_le_mono_nonpos_l; [assumption | now apply lt_le_incl].
apply -> mul_lt_mono_neg_r; [assumption | now apply lt_le_trans with q].
Qed.

Theorem mul_le_mono_nonpos :
forall n m p q, m <= 0 -> n <= m -> q <= 0 -> p <= q ->  m * q <= n * p.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.mul_le_mono_nonpos".
intros n m p q H1 H2 H3 H4.
apply le_trans with (m * p).
now apply mul_le_mono_nonpos_l.
apply mul_le_mono_nonpos_r; [now apply le_trans with q | assumption].
Qed.

Theorem mul_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> 0 <= n * m.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.mul_nonpos_nonpos".
intros n m H1 H2.
rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r.
Qed.

Theorem mul_nonneg_nonpos : forall n m, 0 <= n -> m <= 0 -> n * m <= 0.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.mul_nonneg_nonpos".
intros n m H1 H2.
rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r.
Qed.

Theorem mul_nonpos_nonneg : forall n m, n <= 0 -> 0 <= m -> n * m <= 0.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.mul_nonpos_nonneg".
intros; rewrite mul_comm; now apply mul_nonneg_nonpos.
Qed.

Notation mul_pos := lt_0_mul (only parsing).

Theorem lt_mul_0 :
forall n m, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.lt_mul_0".
intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]].
destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]];
[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |];
(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]];
[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]);
try (left; now split); try (right; now split).
assert (H3 : n * m > 0) by now apply mul_neg_neg.
exfalso; now apply (lt_asymm (n * m) 0).
assert (H3 : n * m > 0) by now apply mul_pos_pos.
exfalso; now apply (lt_asymm (n * m) 0).
now apply mul_neg_pos. now apply mul_pos_neg.
Qed.

Notation mul_neg := lt_mul_0 (only parsing).

Theorem le_0_mul :
forall n m, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.le_0_mul".
assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym).
intros n m. repeat rewrite lt_eq_cases. repeat rewrite R.
rewrite lt_0_mul, eq_mul_0.
pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto.
Qed.

Notation mul_nonneg := le_0_mul (only parsing).

Theorem le_mul_0 :
forall n m, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.le_mul_0".
assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym).
intros n m. repeat rewrite lt_eq_cases. repeat rewrite R.
rewrite lt_mul_0, eq_mul_0.
pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto.
Qed.

Notation mul_nonpos := le_mul_0 (only parsing).

Notation le_0_square := square_nonneg (only parsing).

Theorem nlt_square_0 : forall n, ~ n * n < 0.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.nlt_square_0".
intros n H. apply lt_nge in H. apply H. apply square_nonneg.
Qed.

Theorem square_lt_mono_nonpos : forall n m, n <= 0 -> m < n -> n * n < m * m.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.square_lt_mono_nonpos".
intros n m H1 H2. now apply mul_lt_mono_nonpos.
Qed.

Theorem square_le_mono_nonpos : forall n m, n <= 0 -> m <= n -> n * n <= m * m.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.square_le_mono_nonpos".
intros n m H1 H2. now apply mul_le_mono_nonpos.
Qed.

Theorem square_lt_simpl_nonpos : forall n m, m <= 0 -> n * n < m * m -> m < n.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.square_lt_simpl_nonpos".
intros n m H1 H2. destruct (le_gt_cases n 0); [|order].
destruct (lt_ge_cases m n) as [LE|GT]; trivial.
apply square_le_mono_nonpos in GT; order.
Qed.

Theorem square_le_simpl_nonpos : forall n m, m <= 0 -> n * n <= m * m -> m <= n.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.square_le_simpl_nonpos".
intros n m H1 H2. destruct (le_gt_cases n 0); [|order].
destruct (le_gt_cases m n) as [LE|GT]; trivial.
apply square_lt_mono_nonpos in GT; order.
Qed.

Theorem lt_1_mul_neg : forall n m, n < -1 -> m < 0 -> 1 < n * m.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.lt_1_mul_neg".
intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1.
apply opp_pos_neg in H2. rewrite mul_opp_l, mul_1_l in H1.
now apply lt_1_l with (- m).
assumption.
Qed.

Theorem lt_mul_m1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.lt_mul_m1_neg".
intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1.
rewrite mul_1_l in H1. now apply lt_m1_r with m.
assumption.
Qed.

Theorem lt_mul_m1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.lt_mul_m1_pos".
intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1.
rewrite mul_opp_l, mul_1_l in H1.
apply opp_neg_pos in H2. now apply lt_m1_r with (- m).
assumption.
Qed.

Theorem lt_1_mul_l : forall n m, 1 < n ->
n * m < -1 \/ n * m == 0 \/ 1 < n * m.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.lt_1_mul_l".
intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]].
left. now apply lt_mul_m1_neg.
right; left; now rewrite H1, mul_0_r.
right; right; now apply lt_1_mul_pos.
Qed.

Theorem lt_m1_mul_r : forall n m, n < -1 ->
n * m < -1 \/ n * m == 0 \/ 1 < n * m.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.lt_m1_mul_r".
intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]].
right; right. now apply lt_1_mul_neg.
right; left; now rewrite H1, mul_0_r.
left. now apply lt_mul_m1_pos.
Qed.

Theorem eq_mul_1 : forall n m, n * m == 1 -> n == 1 \/ n == -1.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.eq_mul_1".
assert (F := lt_m1_0).
zero_pos_neg n.

intros m. nzsimpl. now left.

intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn.
le_elim Hn; split; intros m H.
destruct (lt_1_mul_l n m) as [|[|]]; order'.
rewrite mul_opp_l, eq_opp_l in H. destruct (lt_1_mul_l n m) as [|[|]]; order'.
now left.
intros; right. now f_equiv.
Qed.

Theorem lt_mul_diag_l : forall n m, n < 0 -> (1 < m <-> n * m < n).
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.lt_mul_diag_l".
intros n m H. stepr (n * m < n * 1) by now rewrite mul_1_r.
now apply mul_lt_mono_neg_l.
Qed.

Theorem lt_mul_diag_r : forall n m, 0 < n -> (1 < m <-> n < n * m).
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.lt_mul_diag_r".
intros n m H. stepr (n * 1 < n * m) by now rewrite mul_1_r.
now apply mul_lt_mono_pos_l.
Qed.

Theorem le_mul_diag_l : forall n m, n < 0 -> (1 <= m <-> n * m <= n).
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.le_mul_diag_l".
intros n m H. stepr (n * m <= n * 1) by now rewrite mul_1_r.
now apply mul_le_mono_neg_l.
Qed.

Theorem le_mul_diag_r : forall n m, 0 < n -> (1 <= m <-> n <= n * m).
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.le_mul_diag_r".
intros n m H. stepr (n * 1 <= n * m) by now rewrite mul_1_r.
now apply mul_le_mono_pos_l.
Qed.

Theorem lt_mul_r : forall n m p, 0 < n -> 1 < p -> n < m -> n < m * p.
Proof. hammer_hook "ZMulOrder" "ZMulOrder.ZMulOrderProp.lt_mul_r".
intros. stepl (n * 1) by now rewrite mul_1_r.
apply mul_lt_mono_nonneg.
now apply lt_le_incl. assumption. apply le_0_1. assumption.
Qed.

Definition mul_eq_1 := eq_mul_1.

End ZMulOrderProp.


(** * 6.887 Formal Reasoning About Programs - Lab 8
    * Using Hoare Logic *)

Require Import Frap.

(* Authors: Peng Wang (wangpeng@csail.mit.edu), Adam Chlipala (adamc@csail.mit.edu) *)

(** * Using Hoare Logic *)

(* In this lab, we will use the Hoare Logic introduced in class to verify some programs. *)

(* This following definitions are copied from class *)
Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Mult (e1 e2 : exp).

Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp).

Definition heap := fmap nat nat.
Definition valuation := fmap var nat.
Definition assertion := heap -> valuation -> Prop.

Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)
| Assert (a : assertion).

Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x => v $! x
  | Read e1 => h $! eval e1 h v
  | Plus e1 e2 => eval e1 h v + eval e2 h v
  | Minus e1 e2 => eval e1 h v - eval e2 h v
  | Mult e1 e2 => eval e1 h v * eval e2 h v
  end.

Fixpoint beval (b : bexp) (h : heap) (v : valuation) : bool :=
  match b with
  | Equal e1 e2 => if eval e1 h v ==n eval e2 h v then true else false
  | Less e1 e2 => if eval e2 h v <=? eval e1 h v then false else true
  end.

Inductive exec : heap -> valuation -> cmd -> heap -> valuation -> Prop :=
| ExSkip : forall h v,
  exec h v Skip h v
| ExAssign : forall h v x e,
  exec h v (Assign x e) h (v $+ (x, eval e h v))
| ExWrite : forall h v e1 e2,
  exec h v (Write e1 e2) (h $+ (eval e1 h v, eval e2 h v)) v
| ExSeq : forall h1 v1 c1 h2 v2 c2 h3 v3,
  exec h1 v1 c1 h2 v2
  -> exec h2 v2 c2 h3 v3
  -> exec h1 v1 (Seq c1 c2) h3 v3
| ExIfTrue : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = true
  -> exec h1 v1 c1 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExIfFalse : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = false
  -> exec h1 v1 c2 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExWhileFalse : forall I h v b c,
  beval b h v = false
  -> exec h v (While_ I b c) h v
| ExWhileTrue : forall I h1 v1 b c h2 v2 h3 v3,
  beval b h1 v1 = true
  -> exec h1 v1 c h2 v2
  -> exec h2 v2 (While_ I b c) h3 v3
  -> exec h1 v1 (While_ I b c) h3 v3
| ExAssert : forall h v (a : assertion),
  a h v
  -> exec h v (Assert a) h v.

Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
| HtSkip : forall P, hoare_triple P Skip P
| HtAssign : forall (P : assertion) x e,
  hoare_triple P (Assign x e) (fun h v => exists v', P h v' /\ v = v' $+ (x, eval e h v'))
| HtWrite : forall (P : assertion) (e1 e2 : exp),
  hoare_triple P (Write e1 e2) (fun h v => exists h', P h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v))
| HtSeq : forall (P Q R : assertion) c1 c2,
  hoare_triple P c1 Q
  -> hoare_triple Q c2 R
  -> hoare_triple P (Seq c1 c2) R
| HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
  hoare_triple (fun h v => P h v /\ beval b h v = true) c1 Q1
  -> hoare_triple (fun h v => P h v /\ beval b h v = false) c2 Q2
  -> hoare_triple P (If_ b c1 c2) (fun h v => Q1 h v \/ Q2 h v)
| HtWhile : forall (I P : assertion) b c,
  (forall h v, P h v -> I h v)
  -> hoare_triple (fun h v => I h v /\ beval b h v = true) c I
  -> hoare_triple P (While_ I b c) (fun h v => I h v /\ beval b h v = false)
| HtAssert : forall P I : assertion,
  (forall h v, P h v -> I h v)
  -> hoare_triple P (Assert I) P
| HtConsequence : forall (P Q P' Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, P' h v -> P h v)
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P' c Q'.

Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Notation "*[ e ]" := (Read e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Mult : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" := (If_ b then_ else_) (at level 75, e at level 0).
Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75).
Notation "'assert' {{ I }}" := (Assert I) (at level 75).
Delimit Scope cmd_scope with cmd.

Infix "+" := plus : reset_scope.
Infix "-" := minus : reset_scope.
Infix "*" := mult : reset_scope.
Infix "=" := eq : reset_scope.
Infix "<" := lt : reset_scope.
Delimit Scope reset_scope with reset.
Open Scope reset_scope.

Notation "h & v ~> e" := (fun h v => e%reset) (at level 85, v at level 0).

Notation "{{ P }} c {{ Q }}" := (hoare_triple P c%cmd Q) (at level 90, c at next level).

Lemma HtStrengthenPost : forall (P Q Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P c Q'.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

Ltac ht1 := apply HtSkip || apply HtAssign || apply HtWrite || eapply HtSeq
            || eapply HtIf || eapply HtWhile || eapply HtAssert
            || eapply HtStrengthenPost.

Ltac t := cbv beta; propositional; subst;
          repeat match goal with
                 | [ H : ex _ |- _ ] => invert H; propositional; subst
                 end;
          simplify;
          repeat match goal with
                 | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
                 | [ H : ?E = ?E |- _ ] => clear H
                 end; simplify; propositional; auto; try equality; try linear_arithmetic.

Ltac ht := simplify; repeat ht1; t.

Inductive step : heap * valuation * cmd -> heap * valuation * cmd -> Prop :=
| StAssign : forall h v x e,
  step (h, v, Assign x e) (h, v $+ (x, eval e h v), Skip)
| StWrite : forall h v e1 e2,
  step (h, v, Write e1 e2) (h $+ (eval e1 h v, eval e2 h v), v, Skip)
| StStepSkip : forall h v c,
  step (h, v, Seq Skip c) (h, v, c)
| StStepRec : forall h1 v1 c1 h2 v2 c1' c2,
  step (h1, v1, c1) (h2, v2, c1')
  -> step (h1, v1, Seq c1 c2) (h2, v2, Seq c1' c2)
| StIfTrue : forall h v b c1 c2,
  beval b h v = true
  -> step (h, v, If_ b c1 c2) (h, v, c1)
| StIfFalse : forall h v b c1 c2,
  beval b h v = false
  -> step (h, v, If_ b c1 c2) (h, v, c2)
| StWhileFalse : forall I h v b c,
  beval b h v = false
  -> step (h, v, While_ I b c) (h, v, Skip)
| StWhileTrue : forall I h v b c,
  beval b h v = true
  -> step (h, v, While_ I b c) (h, v, Seq c (While_ I b c))
| StAssert : forall h v (a : assertion),
  a h v
  -> step (h, v, Assert a) (h, v, Skip).

Hint Constructors step.

Definition trsys_of (st : heap * valuation * cmd) := {|
  Initial := {st};
  Step := step
|}.

Definition unstuck (st : heap * valuation * cmd) :=
  snd st = Skip
  \/ exists st', step st st'.

Lemma hoare_triple_unstuck : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v, P h v
                 -> unstuck (h, v, c).
Proof.
  induct 1; unfold unstuck; simplify; propositional; eauto.

  apply IHhoare_triple1 in H1.
  unfold unstuck in H1; simplify; first_order; subst; eauto.
  cases x.
  cases p.
  eauto.

  cases (beval b h v); eauto.

  cases (beval b h v); eauto.

  apply H0 in H2.
  apply IHhoare_triple in H2.
  unfold unstuck in H2; simplify; first_order.
Qed.

Lemma hoare_triple_Skip : forall P Q,
  {{P}} Skip {{Q}}
  -> forall h v, P h v -> Q h v.
Proof.
  induct 1; auto.
Qed.

Lemma hoare_triple_step : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v h' v' c',
      step (h, v, c) (h', v', c')
      -> P h v
      -> {{h''&v'' ~> h'' = h' /\ v'' = v'}} c' {{Q}}.
Proof.
  induct 1.

  invert 1.

  invert 1; ht; eauto.

  invert 1; ht; eauto.

  invert 1; simplify.

  eapply HtConsequence; eauto.
  propositional; subst.
  eapply hoare_triple_Skip; eauto.

  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto; equality.
  eapply HtConsequence; eauto; equality.

  invert 1; simplify.
  eapply HtConsequence with (P := h'' & v'' ~> h'' = h' /\ v'' = v').
  apply HtSkip.
  auto.
  simplify; propositional; subst; eauto.

  econstructor.
  eapply HtConsequence; eauto.
  simplify; propositional; subst; eauto.
  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto.
  econstructor.
  simplify; propositional; subst; eauto.

  simplify.
  eapply HtConsequence.
  eapply IHhoare_triple; eauto.
  simplify; propositional; subst; eauto.
  auto.
Qed.

Theorem hoare_triple_invariant : forall P c Q h v,
  {{P}} c {{Q}}
  -> P h v
  -> invariantFor (trsys_of (h, v, c)) unstuck.
Proof.
  simplify.
  apply invariant_weaken with (invariant1 := fun st => {{h&v ~> h = fst (fst st)
                                                           /\ v = snd (fst st)}}
                                                         snd st
                                                       {{_&_ ~> True}}).

  apply invariant_induction; simplify.

  propositional; subst; simplify.
  eapply HtConsequence; eauto.
  equality.

  cases s.
  cases s'.
  cases p.
  cases p0.
  simplify.
  eapply hoare_triple_step; eauto.
  simplify; auto.

  simplify.
  cases s.
  cases p.
  simplify.
  eapply hoare_triple_unstuck; eauto.
  simplify; auto.
Qed.

(** * Challenge 1: Infinite loop *)

(* We mentioned this nonterminating program in class.  Now your task is to prove
 * that it won't get stuck during execution, possibly using the
 * [hoare_triple_invariant] theorem. *)

Definition forever := (
  "i" <- 1;;
  "n" <- 1;;
  {{h&v ~> v $! "i" > 0}}
  while 0 < "i" loop
    "i" <- "i" * 2;;
    "n" <- "n" + "i";;
    assert {{h&v ~> v $! "n" >= 1}}
  done;;

  assert {{_&_ ~> False}}
  (* Note that this last assertion implies that the program never terminates! *)
)%cmd.

Theorem forever_invariant : invariantFor (trsys_of ($0, $0, forever)) unstuck.
Proof.
Admitted.

(* Some hint preparation for the following challenges *)

(* One simple lemma turns out to be helpful to guide [eauto] properly. *)
Lemma leq_f : forall A (m : fmap A nat) x y,
  x = y
  -> m $! x <= m $! y.
Proof.
  ht.
Qed.

Hint Resolve leq_f.
Hint Extern 1 (@eq nat _ _) => linear_arithmetic.
Hint Extern 1 (_ < _) => linear_arithmetic.
Hint Extern 1 (_ <= _) => linear_arithmetic.
(* We also register [linear_arithmetic] as a step to try during proof search. *)

(** * Challenge 2: Max of array *)

(* Verify the following 'max of array' program.  See the final postcondition for
 * how we interpret a part of memory as an array.  You can change loop-invariant
 * annotations in the program to facilitate your verification. *)

Theorem maxOfArray_ok :
  {{_&_ ~> True}}
    "max" <- *["a"];;
    "i" <- 0;;
    {{h&v ~> True }}
    while "i" < "n" loop
      when "max" < *["a" + "i"] then
        "max" <- *["a" + "i"]
      else
        Skip
      done;;
      "i" <- "i" + 1
    done
  {{h&v ~> forall i, i < v $! "n" -> h $! (v $! "a" + i) <= v $! "max"}}.
Proof.
Admitted.

(** * Challenge 3: Selection sort *)

(* Verify the following 'selection sort' program. Note that we only prove here
 * that the final array is sorted, *not* that it's a permutation of the original
 * array. *)

Theorem selectionSort_ok :
  {{_&_ ~> True}}
    "i" <- 0;;
    {{h&v ~> True }}
    while "i" < "n" loop
      "j" <- "i"+1;;
      "best" <- "i";;
      {{h&v ~> True }}
      while "j" < "n" loop
        when *["a" + "j"] < *["a" + "best"] then
          "best" <- "j"
        else
          Skip
        done;;
        "j" <- "j" + 1
      done;;
      "tmp" <- *["a" + "best"];;
      *["a" + "best"] <- *["a" + "i"];;
      *["a" + "i"] <- "tmp";;
      "i" <- "i" + 1
    done
  {{h&v ~> forall i j, i < j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)}}.
Proof.
Admitted.


Require Import Program.Equality.
Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import Language
               Infra
               SubDis.

(* -------- properties of typing -------- *)
Lemma check_sub : forall G e m A,
  has_type G e m A -> forall B,
  sub A B ->
  has_type G e chk B.
Proof.
  induction 1; intros; eauto.
Qed.

Lemma chk_inf_sub: forall G e A,
  has_type G e chk A -> exists B,
  has_type G e inf B /\ sub B A.
Proof.
  introv Typ. inductions Typ.
  - exists*.
Qed.

Lemma val_chk_inf_sub: forall G e A,
  value e ->
  has_type G e chk A -> exists B,
  has_type G e inf B /\ sub B A.
Proof.
  introv Val Typ. inductions Typ.
  - exists*.
Qed.
(* ---------------- *)

Lemma genv_progress: forall A,
  toplike A -> exists v,
  genv A v.
Proof.
  introv Ht. inductions Ht; eauto.
  - destruct* IHHt1. destruct* IHHt2.
  - destruct* IHHt.
  - destruct* IHHt.
Qed.

Lemma genv_unique: forall A v1,
  genv A v1 -> forall v2,
  genv A v2 ->
  v1 = v2.
Proof.
  introv Hg1. inductions Hg1; introv Hg2; eauto.
  - inverts* Hg2.
  - inverts* Hg2.
    forwards~: IHHg1 H2. subst*.
  - inverts* Hg2.
    forwards~: IHHg1_1 H1. forwards~: IHHg1_2 H3. subst*.
  - inverts* Hg2. forwards~: IHHg1 H2. subst*.
Qed.

Lemma casting_top_normal : forall (v v': exp),
    casting v top v' -> v' = unit.
Proof.
  intros v v' H.
  remember top.
  induction H;
    try solve [inverts* Heqt].
  - subst*. exfalso. eapply H1. eauto.
  - subst*. inverts* H2.
Qed.

Lemma genv_casting_eq: forall A v1,
  toplike A -> forall v2,
  casting v1 A v2 -> forall v3,
  genv A v3 ->
  v2 = v3.
Proof.
  introv TL Red. inductions Red; introv Hg.
  - inverts* Hg.
  - inverts* Hg.
  - eapply IHRed; eauto.
  - eapply IHRed; eauto.
  - inverts* Hg. inverts* TL.
    forwards~: IHRed1 H2 H1. forwards~: IHRed2 H4 H3. subst*.
  - inverts* Hg. inverts* TL.
    forwards~: IHRed H0 H2. subst*.
  - inverts* TL.
  - eapply genv_unique; eauto.
  - contradiction.
  - eapply genv_unique; eauto.
Qed.

Lemma casting_toplike: forall A,
  toplike A -> forall (v1 v2 v1' v2' : exp),
  casting v1 A v1' ->
  casting v2 A v2' ->
  v1' = v2'.
Proof.
  introv TL R1 R2.
  forwards~ (v'&Hg): genv_progress TL.
  forwards~: genv_casting_eq TL R1 Hg.
  forwards~: genv_casting_eq TL R2 Hg.
  subst*.
Qed.

(* principal types for values *)
Fixpoint principal_type (v:exp) : typ :=
  match v with
  | unit => top
  | lit i5 => int
  | box e1 (ann (lam bl e) (arr A B)) => arr A B
  | box e1 (ann (lam wh e) (arr (rcd l A) B)) => arr A B
  | box e1 (ann (fixp A e) B) => B
  | merge v1 v2 => and (principal_type v1) (principal_type v2)
  | rec l v1 => rcd l (principal_type v1)
  | _ => top
  end.

Lemma principal_type_disjoint: forall v,
  value v -> forall G A B,
  has_type G v inf A ->
  disjoint A B ->
  disjoint (principal_type v) B.
Proof.
  introv Val.
  inductions Val; introv Typ Dis; try solve [inverts* Typ].
  - simpl.
    inverts* Typ.
    + eapply dis_and_inv in Dis. destruct* Dis.
      forwards~: IHVal1 H1 H. forwards~: IHVal2 H2 H0.
      eapply dis_to_inter; eauto.
    + eapply dis_and_inv in Dis. destruct* Dis.
      forwards~: IHVal1 H1 H. forwards~: IHVal2 H2 H0.
      eapply dis_to_inter; eauto.
  - simpl.
    inverts* Typ.
    inductions B.
    + unfold disjoint. intros Hc. eapply costs_int_rcd.
      eapply costs_sym. eauto.
    + unfold disjoint. intros Hc. eapply costs_top_rcd.
      eapply costs_sym. eauto.
    + apply dis_sym in Dis.
      apply dis_and_inv in Dis. destruct* Dis.
      eapply dis_sym in H.
      eapply dis_sym in H0.
      forwards~: IHB1 H H1.
      forwards~: IHB2 H0 H1.
      eapply dis_sym in H2.
      eapply dis_sym in H3.
      eapply dis_sym; eauto.
      eapply dis_to_inter; eauto.
    + destruct* (x == n).
      {
        subst*. eapply disjoint_rcd_build.
        eapply IHVal; eauto. eapply disjoint_rcd_inv. eauto.
      }
      {
        unfold disjoint. intros Hc. eapply costs_rcd_rcd_neq. eauto. eauto.
      }
    + unfold disjoint. intros Hc. eapply costs_arr_rcd. eauto.
  - simpl. inverts* Typ. inverts* H3.
    eapply dis_domain_type. eauto.
  - simpl. inverts* Typ. inverts* H3.
    + eapply dis_domain_type. eauto.
    + eapply dis_domain_type. eauto.
  - simpl. inverts* Typ. inverts* H3.
Qed.

Lemma principal_types_disjoint: forall v1 A v2 B,
  value v1 -> forall G,
  has_type G v1 inf A ->
  value v2 -> forall F,
  has_type F v2 inf B ->
  disjoint A B ->
  disjoint (principal_type v1) (principal_type v2).
Proof.
  introv Val1 Typ1 Val2 Typ2 Dis.
  forwards* D1: principal_type_disjoint Typ1 Dis.
  apply dis_sym in D1.
  forwards* D2: principal_type_disjoint Typ2 D1.
  apply~ dis_sym.
Qed.

Lemma principal_type_sub: forall v A,
  value v -> forall G,
  has_type G v inf A ->
  sub (principal_type v) A.
Proof.
  intros v A Val G H.
  inductions H; inverts Val; simpl.
  - eauto.
  - eauto.
  - assert (S1: sub (and (principal_type e1) (principal_type e2)) A) by (econstructor; eauto).
    assert (S2: sub (and (principal_type e1) (principal_type e2)) B) by (econstructor; eauto).
    forwards*: sand S1 S2.
  - assert (S1: sub (and (principal_type v1) (principal_type v2)) A) by (econstructor; eauto).
    assert (S2: sub (and (principal_type v1) (principal_type v2)) B) by (econstructor; eauto).
    forwards*: sand S1 S2.
  - inverts H0. inverts H4. inverts H0.
    inverts H8. eauto.
  - inverts H0. inverts H4. inverts H0.
    inverts H8. eauto.
  - inverts* H0.
  - eauto.
Qed.

Definition old_dis A B :=
  forall C, sub A C -> sub B C -> toplike C.

Lemma dis_old_spec: forall A B C,
  disjoint A B ->
  sub A C ->
  sub B C ->
  toplike C.
Proof.
  intros A B C. indTypSize (size_typ A + size_typ B + size_typ C).
  lets Sub: H0.
  inverts* H0.
  - eapply dis_sym in H.
    forwards~: dis_super H1 H.
    exfalso. unfold disjoint in H0.
    eapply H0. unfold cost_spec. exists*.
  - forwards~ (C1&C2): and_inversion H1.
    forwards~: IH H H2 C1. elia.
    forwards~: IH H H3 C2. elia.
  - forwards~: IH H2 H1. elia.
    forwards~ (?&?): dis_and_inv H.
  - forwards~: IH H2 H1. elia.
    forwards~ (?&?): dis_and_inv H.
  - inductions B.
    + inverts* H1.
    + inverts* H1.
    + eapply dis_sym in H.
      forwards~ (?&?): dis_and_inv H.
      eapply dis_sym in H0.
      eapply dis_sym in H3.
      inverts H1.

      forwards~: IH H0 Sub H7. elia.
      forwards~: IH H3 Sub H7. elia.
    + inverts* H1.
      forwards~: disjoint_rcd_inv H.
      forwards~: IH H0 H2 H3. elia.
    + inverts* H1.
  - inductions B.
    + inverts* H1.
    + inverts* H1.
    + eapply dis_sym in H.
      forwards~ (?&?): dis_and_inv H.
      eapply dis_sym in H0.
      eapply dis_sym in H4.
      inverts H1.

      forwards~: IH H0 Sub H8. elia.
      forwards~: IH H4 Sub H8. elia.
    + inverts* H1.
    + inverts* H1.
      forwards~: disjoint_arr_inv H.
      forwards~: IH H0 H3 H8. elia.
Qed.

Lemma old_dis_complete: forall A B,
  disjoint A B ->
  old_dis A B.
Proof.
  introv Dis. unfold old_dis. introv S1 S2.
  eapply dis_old_spec; eauto.
Qed.

Lemma gord_not_tl: forall A,
  gord A -> ~ toplike A.
Proof.
  introv H Ht. inductions H; try solve [inverts* Ht].
Qed.

Lemma old_dis_sound: forall A B,
  old_dis A B ->
  disjoint A B.
Proof.
  introv Ho. unfold old_dis in *. unfold disjoint. introv Hc.
  unfold cost_spec in *.
  destruct* Hc. destruct* H. destruct* H0.
  forwards~: Ho H0 H1.
  eapply gord_not_tl; eauto.
Qed.

Lemma sub_casting: forall v v' A,
  value v ->
  casting v A v' ->
  sub (principal_type v) A.
Proof.
  introv Val Red.
  inductions Red.
  - simpl. eauto.
  - simpl. eauto.
  - simpl. inverts* Val.
  - simpl. inverts* Val.
  - simpl. eauto.
  - simpl. inverts* Val.
  - inverts H1.
    + simpl. eauto.
    + simpl. eauto.
  - inverts H1.
    + simpl. eauto.
    + simpl. eauto.
  - simpl. inverts* Val.
  - simpl. inverts* Val.
Qed.

Lemma disjoint_val_consistent: forall A B v1 v2 G F,
  disjoint A B ->
  value v1 ->
  value v2 ->
  has_type G v1 inf A ->
  has_type F v2 inf B ->
  consistencySpec v1 v2.
Proof.
  intros A B v1 v2 G F Dis Val1 Val2 Typ1 Typ2.
  unfold consistencySpec.
  introv Red1 Red2.
  forwards* Sub1': sub_casting Red1.
  forwards* Sub2': sub_casting Red2.
  forwards* Dis': principal_types_disjoint Typ1 Typ2.
  assert (Top: toplike A0). {
    eapply dis_old_spec; eauto.
  }
  forwards*: casting_toplike Top Red1 Red2.
Qed.

Lemma value_closed : forall G e m A,
  has_type G e m A ->
  value e -> forall F,
  has_type F e m A.
Proof.
  induction 1; intros Val K; eauto; try solve [inverts* Val].
  - (* merge *)
    inverts* Val. eapply tcon; try eassumption.
    eapply IHhas_type1; eassumption.
    eapply IHhas_type2; eassumption.
    eapply disjoint_val_consistent.
    eapply H1. eauto. eauto. eauto. eauto.
Qed.

Lemma casting_unique_aux: forall (v v1 v2 : exp) (A: typ),
  value v ->
  (exists G B, has_type G v inf B) ->
  casting v A v1 ->
  casting v A v2 ->
  v1 = v2.
Proof.
  intros v v1 v2 A Val H R1 R2.
  gen v2.
  lets R1': R1.
  induction R1; introv R2.
  - forwards~: casting_toplike R1' R2.
  - inverts* R2.
  - (* mergel *)
    lets [B H']: H.
    lets R2': R2.
    inverts Val.
    inverts* R2.
    + forwards~: casting_toplike R1' R2'.
    + inverts* H'. inverts* H1.
    + inverts* H'. inverts* H1.
      forwards~ Cons: disjoint_val_consistent H11 H3 H4 H7 H9.
      unfold consistencySpec in Cons.
      eapply Cons; try eassumption.
    + inverts* H0.
  - (* merger *)
    lets [B H']: H.
    lets R2': R2.
    inverts Val.
    inverts* R2.
    + forwards~: casting_toplike R1' R2'.
    + inverts* H'. inverts* H1.
      * forwards~: disjoint_val_consistent H11 H3 H4 H7 H9.
      unfold consistencySpec in H1.
        forwards~: H1 H5 R1.
      * unfold consistencySpec in H13.
        forwards~: H13 H5 R1.
    + inverts* H'. inverts* H1.
    + inverts* H0.
  - (* and *)
    inverts~ R2.
    + inverts* H1.
    + inverts* H1.
    + forwards*: IHR1_1.
      forwards*: IHR1_2.
      congruence.
    + inverts* H3.
    + inverts* H3.
  - (* rcd *)
    inverts* R2.
    + inverts* Val. destruct* H. destruct* H. inverts* H. forwards*: IHR1. subst*.
  - inverts* R2.
  - inverts H2.
    + forwards~: genv_casting_eq R2 H5.
    + forwards~: genv_casting_eq R2 H5.
  - inverts* R2.
    + exfalso. eapply H2. eauto.
    + inverts* H3.
  - forwards~: genv_casting_eq R2 H4.
Qed.

Lemma casting_unique: forall (v v1 v2 : exp) (G A B: typ),
  value v ->
  has_type G v inf B ->
  casting v A v1 ->
  casting v A v2 ->
  v1 = v2.
Proof.
  introv Val H R1 R2.
  eapply casting_unique_aux; eauto.
Qed.

Lemma gen_step_unique: forall e m A G,
  has_type G e m A -> forall v e1 e2,
  has_type top v inf G ->
  step v e e1 ->
  step v e e2 ->
  e1 = e2.
Proof.
  intros e m A G H.
  induction H; introv Typv Red1 Red2.
  - inverts* Red1.
  - inverts* Red1.
  - inverts* Red1. inverts* Red2.
  - inverts Red1; inverts Red2.
    + assert (e' = e'0). {
      eapply IHhas_type2; try eapply H7; try eapply H6.
      econstructor; try eassumption; try eauto.
      eapply value_closed; try eassumption.
      unfold disjoint. eapply costs_top_any.
    }
    subst*.
    + exfalso. forwards~: step_not_value H9.
    + exfalso. forwards~: step_not_value H7.
    + forwards~: IHhas_type1 Typv H7 H8. subst*.
  - exfalso. forwards~: step_not_value Red1.
  - inverts Red1; inverts Red2; try solve [inverts H; inverts H0]; try solve [inverts H6]; try solve [inverts H8].
    + forwards~(B&TypI&?): val_chk_inf_sub H.
      forwards~: casting_unique TypI H4 H7.
    + exfalso. forwards~: step_not_value H7.
    + exfalso. forwards~: step_not_value H4.
    + forwards~: IHhas_type Typv H5 H4. subst*.
  - inverts Red1; inverts Red2.
    + inverts* H12.
    + inverts* H9.
    + inverts* H9.
    + inverts* H10.
    + inverts* H7.
    + inverts* H7.
    + inverts* H10.
    + inverts* H7.
    + eauto.
  - (* fixp *)
    inverts Red1; inverts Red2. eauto.
  - inverts Red1; inverts Red2.
    + inverts H3.
      * inverts H. inverts H9. inverts H11. inverts H.
        inverts H14. inverts H10. inverts H20.
        forwards~(D&TypI&?): val_chk_inf_sub H0.
        forwards~: casting_unique TypI H4 H16.
        subst*.
      * inverts H. inverts H9. inverts H11. inverts H.
        inverts H14. inverts H10. inverts H20.
        forwards~(D&TypI&?): val_chk_inf_sub H0.
        forwards~: casting_unique TypI H4 H16.
        subst*.
    + inverts H3; exfalso; forwards~: step_not_value H11.
    + exfalso. forwards~: step_not_value H9.
    + eauto.
    + exfalso. forwards~: step_not_value H8.
    + exfalso. forwards~: step_not_value H6.
    + inverts H3; exfalso; forwards~: step_not_value H5.
    + exfalso. forwards~: step_not_value H5.
    + forwards~: IHhas_type1 Typv H5 H6. subst*.
    + exfalso. forwards~: step_not_value H5.
    + exfalso. forwards~: step_not_value H4.
    + exfalso. forwards~: step_not_value H4.
    + exfalso. forwards~: step_not_value H7.
    + forwards~: IHhas_type2 Typv H4 H5. subst*.
  - inverts Red1; inverts Red2.
    + eauto.
    + exfalso. forwards~: step_not_value H4.
    + exfalso. forwards~: step_not_value H6.
    + exfalso. forwards~: step_not_value H3.
    + forwards~: step_env H3.
      forwards~: value_closed H top.
      forwards~: IHhas_type2 H3 H4. subst*.
    + forwards~: step_env H3.
      exfalso. forwards~: step_not_value H6.
    + exfalso. forwards~: step_not_value H4.
    + forwards~: step_env H3.
      exfalso. forwards~: step_not_value H4.
    + forwards~: IHhas_type1 H4 H5. subst*.
  - inverts* Red1; inverts* Red2.
  - inverts Red1; inverts Red2.
    forwards~: IHhas_type Typv H4 H5. subst*.
  - inverts Red1; inverts Red2.
    + eauto.
    + exfalso. forwards~: step_not_value H6.
    + exfalso. forwards~: step_not_value H4.
    + forwards~: IHhas_type Typv H4 H5. subst*.
    + exfalso. forwards~: step_not_value H4.
    + exfalso. forwards~: step_not_value H6.
    + eauto.
Qed.

Theorem step_unique: forall e m A,
  has_type top e m A -> forall e1 e2,
  step unit e e1 ->
  step unit e e2 ->
  e1 = e2.
Proof.
  introv Typ H1 H2.
  forwards~: gen_step_unique Typ H1 H2.
Qed.


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(*    FullAtomicJl:
        Decidable, Tag-Based Semantic Subtyping
        for Nominal Types, Pairs, and Unions.  *)

(** * FullAtomicJl: Propositions about Matching Relation *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..". (* root directory of the repo *)

Require Import Mechanization.Aux.Identifier.

Require Import Mechanization.FullAtomicJl.BaseDefs.
Require Import Mechanization.FullAtomicJl.BaseProps.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.

Open  Scope btjm_scope.

(* ################################################################# *)
(** ** Basic Properties *)
(* ################################################################# *)

(** Only a _value_ type _matches a type. *)
Lemma match_ty__value_type : forall (v t : ty),
    |- v <$ t ->
    value_type v.
Proof.
  intros v t H; induction H;
    try solve [assumption | constructor; assumption].
Qed.

(** Any value type matches itself. *)
Lemma match_valty__rflxv : forall (v : ty),
    value_type v ->
    |- v <$ v.
Proof.
  intros v Hval; induction Hval; constructor; assumption.
Qed.

(** A value type matches only an eqivalent value type. *)
Lemma valty_match_valty__equal : forall (v1 v2 : ty),
    |- v1 <$ v2 ->
    value_type v2 ->
    v1 = v2.
Proof.
  intros v1 v2 Hm; induction Hm; intros Hval2;
    try solve [inversion Hval2 | reflexivity].
  (* Pair *)
  inversion Hval2; subst.
  apply IHHm1 in H1. apply IHHm2 in H2.
  subst; reflexivity.
Qed.

Lemma matching_valty__exists : forall (t : ty),
    exists (v : ty),
      value_type v  /\  |- v <$ t.
Proof.
  induction t.
  - (* CName *)
    exists (TCName c); repeat constructor.
  - (* AName *)
    exists (TExt a); repeat constructor.
  - (* Pair *)
    destruct IHt1 as [v1 [Hv1 Hm1]]; destruct IHt2 as [v2 [Hv2 Hm2]].
    exists (TPair v1 v2); auto.
  - (* Union *)
    destruct IHt1 as [v1 [Hv1 Hm1]].
    exists v1; auto.
  - (* Ext *)
    exists (TExt a); repeat constructor.
Qed.

(* DEP: matching_valty__exists *)
Lemma matching_valpair__exists : forall (t1 t2 : ty),
    exists (v1 v2 : ty),
      value_type (TPair v1 v2)  /\  |- TPair v1 v2 <$ TPair t1 t2.
Proof.
  intros t1 t2.
  destruct (matching_valty__exists t1) as [v1 [Hv1 Hm1]].
  destruct (matching_valty__exists t2) as [v2 [Hv2 Hm2]].
  exists v1, v2. split;
  constructor; assumption.
Qed.

(* ################################################################# *)
(** ** Decidability *)
(* ################################################################# *)

(* DEP: cname_eq__decidable, valty_match_valty__equal,
        match_ty__value_type *)
Theorem match_ty__dcdbl : forall (v t : ty),
    Decidable.decidable (|- v <$ t).
Proof.
  intros v; induction v; intros t.
  - (* CName *)
    assert (Hval1: value_type (TCName c)) by constructor.
    induction t.
    + (* CName *)
      destruct (cname_eq__decidable c c0).
      * subst; left; constructor.
      * right; intros Hcontra.
        assert (Hval2: value_type (TCName c0)) by constructor.
        pose proof (valty_match_valty__equal _ _ Hcontra Hval2) as Heq.
        inversion Heq; contradiction.
    + (* AName *)
      destruct c; destruct a;
        try solve [
              left; constructor
            | right; intros Hcontra; inversion Hcontra ].
    + (* Pair *)
      right; intros Hcontra; inversion Hcontra.
    + (* Union *)
      destruct IHt1 as [IH1 | IH1]; destruct IHt2 as [IH2 | IH2];
        try solve [ left; apply MT_Union1; assumption
                  | left; apply MT_Union2; assumption ].
      right; intros Hcontra.
      inversion Hcontra; subst; contradiction.
    + (* Ext *)
      right; intros Hcontra; inversion Hcontra.
  - (* AName *)
    right; intros Hcontra.
    apply match_ty__value_type in Hcontra; inversion Hcontra.
  - (* Pair *)
    induction t.
    + (* CName *)
      right; intros Hcontra; inversion Hcontra.
    + (* AName *)
      right; intros Hcontra; inversion Hcontra.
    + (* Pair *)
      destruct (IHv1 t1) as [IH1 | IH1];
        destruct (IHv2 t2) as [IH2 | IH2];
        try solve [right; intros Hcontra;
                   inversion Hcontra; subst; contradiction].
      left; constructor; assumption.
    + (* Union *)
      destruct IHt1 as [IH1 | IH1];
        destruct IHt2 as [IH2 | IH2];
        try solve [
              left; apply MT_Union1; assumption
            | left; apply MT_Union2; assumption ].
      right; intros Hcontra.
      inversion Hcontra; contradiction.
    + (* Ext *)
      right; intros Hcontra; inversion Hcontra.
  - (* Union *)
    right; intros Hcontra.
    apply match_ty__value_type in Hcontra.
    inversion Hcontra.
  - (* Ext *)
    induction t;
      try solve [right; intros Hcontra; inversion Hcontra].
    + (* AName *)
      destruct a; destruct a0;
        try solve [left; constructor].
      right; intros Hcontra; inversion Hcontra.
    + (* Union *)
      destruct IHt1 as [IH1 | IH1];
        destruct IHt2 as [IH2 | IH2];
        try solve [
              left; apply MT_Union1; assumption
            | left; apply MT_Union2; assumption ].
      right; intros Hcontra.
      inversion Hcontra; contradiction.
    + (* Ext *)
      destruct (aname_eq__decidable a a0).
      left; subst; constructor.
      right; intros Hcontra; inversion Hcontra; contradiction.
Qed.