(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export cvterm.
Require Export continuity_defs.
Require Export per_props3.
Require Export per_props_nat.

Definition force_int_f_c {o} v (f : @CTerm o) :=
  mkc_lam v (mkcv_cbv
               [v]
               (force_int_cv [v] (mkc_var v))
               v
               (mkcv_apply [v,v] (mk_cv [v,v] f) (mk_cv_app_r [v] [v] (mkc_var v)))).

Definition force_int_F_c {o} v (F f : @CTerm o) :=
  mkc_apply F (force_int_f_c v f).

Definition absolute_value_cv {o} vs (t : @CVTerm o vs) : CVTerm vs :=
  mkcv_less vs t (mkcv_zero vs) (mkcv_minus vs t) t.

Definition less_bound_cv {o} vs b (t e : @CVTerm o vs) : CVTerm vs :=
  mkcv_less vs (absolute_value_cv vs t) (mkcv_nat vs b) t e.

Definition force_int_bound_cv {o} vs v b (t e : @CVTerm o vs) : CVTerm vs :=
  mkcv_cbv
    vs t v
    (less_bound_cv
       (v :: vs)
       b
       (mk_cv_app_r vs [v] (mkc_var v))
       (mk_cv_app_l [v] vs e)).

Definition force_int_bound_f_c {o} v b (f e : @CTerm o) :=
  mkc_lam v (mkcv_cbv
               [v]
               (force_int_bound_cv [v] v b (mkc_var v) (mk_cv [v] e))
               v
               (mkcv_apply
                  [v,v]
                  (mk_cv [v,v] f)
                  (mk_cv_app_r [v] [v] (mkc_var v)))).

Definition force_int_bound_F_c {o} v b (F f e : @CTerm o) :=
  mkc_apply F (force_int_bound_f_c v b f e).

Lemma get_cterm_force_int_f_c {o} :
  forall x (f : @CTerm o),
    get_cterm (force_int_f_c x f)
    = force_int_f x (get_cterm f).
Proof.
  introv; destruct_cterms; simpl; auto.
Qed.

Lemma get_cterm_force_int_F_c {o} :
  forall x (F f : @CTerm o),
    get_cterm (force_int_F_c x F f)
    = force_int_F x (get_cterm F) (get_cterm f).
Proof.
  introv; destruct_cterms; simpl; auto.
Qed.

Lemma get_cterm_force_int_bound_F_c {o} :
  forall x b (F f e : @CTerm o),
    get_cterm (force_int_bound_F_c x b F f e)
    = force_int_bound_F x b (get_cterm F) (get_cterm f) (get_cterm e).
Proof.
  introv; destruct_cterms; simpl; auto.
Qed.

Definition agree_upto_bc {o} lib b (f g : @CTerm o) :=
  forall (i : Z),
    Z.abs_nat i < b
    -> equality_of_int_tt
         lib
         (mkc_apply f (mkc_integer i))
         (mkc_apply g (mkc_integer i)).

Lemma get_cterm_apply {o} :
  forall (a b : @CTerm o),
    get_cterm (mkc_apply a b) = mk_apply (get_cterm a) (get_cterm b).
Proof.
  introv; destruct_cterms; sp.
Qed.

Lemma agree_upto_b_get_cterm {o} :
  forall lib b (f g : @CTerm o),
    agree_upto_bc lib b f g
    -> agree_upto_b lib b (get_cterm f) (get_cterm g).
Proof.
  introv agree l.
  pose proof (agree i l) as h.
  unfold equality_of_int_tt in h; exrepnd.
  allunfold @computes_to_valc; allsimpl.
  allrw @get_cterm_apply; allsimpl.
  allunfold @computes_to_value; repnd.
  exists k; dands; auto.
Qed.
Hint Resolve agree_upto_b_get_cterm : slow.

(* Assume [agree_upto_red_bc] and prove that it implies [agree_upto_bc] *)

Definition agree_upto_red_bc {o} lib b (f g : @CTerm o) :=
  forall (t1 t2 : CTerm) (i : Z),
    reduces_toc lib t1 (mkc_integer i)
    -> reduces_toc lib t2 (mkc_integer i)
    -> Z.abs_nat i < b
    -> equality_of_int_tt lib (mkc_apply f t1) (mkc_apply g t2).

Definition continuous {o} lib (F : @CTerm o) :=
  forall f,
    member lib f (mkc_fun mkc_int mkc_int)
    -> {b : nat
        & forall g,
            member lib g (mkc_fun mkc_int mkc_int)
            -> agree_upto_red_bc lib b f g
            -> equality_of_int_tt lib (mkc_apply F f) (mkc_apply F g)}.

Lemma reduces_toc_refl {o} :
  forall lib (t : @CTerm o),
    reduces_toc lib t t.
Proof.
  introv; unfold reduces_toc; simpl; eauto with slow.
Qed.
Hint Resolve reduces_toc_refl : slow.

Lemma equality_force_int_f_c {o} :
  forall lib (f : @CTerm o),
    member lib f (mkc_fun mkc_int mkc_int)
    -> equality lib f (force_int_f_c nvarx f) (mkc_fun mkc_int mkc_int).
Proof.
  introv m.
  allrw @equality_in_fun; repnd; dands; auto.
  introv e.
  pose proof (m a a' e) as h.
  eapply equality_trans;[exact h|].

  allrw @equality_in_int.
  allunfold @equality_of_int.
  exrepnd.
  exists k0; dands; spcast; auto.

  unfold computes_to_valc.
  rw @get_cterm_apply.
  rw @get_cterm_force_int_f_c.
  simpl.

  unfold computes_to_value; dands; eauto with slow.
  unfold force_int_f.

  apply (reduces_to_if_split2
           _ _ (mk_cbv
                  (force_int (get_cterm a'))
                  nvarx
                  (mk_apply (get_cterm f) (mk_var nvarx)))).

  { csunf; simpl; unfold apply_bterm, lsubst; simpl; boolvar;
    allrw @free_vars_cterm; allsimpl; tcsp;
    allrw @lsubst_aux_nil; tcsp;
    try (complete (provefalse; sp)). }

  pose proof (reduces_to_prinarg
                lib NCbv (force_int (get_cterm a')) (mk_integer k)
                [bterm [nvarx] (mk_apply (get_cterm f) (mk_var nvarx))]) as h.
  autodimp h hyp; fold_terms.
  { allunfold @computes_to_valc; allsimpl.
    allunfold @computes_to_value; sp.
    pose proof (reduces_to_prinarg
                  lib (NArithOp ArithOpAdd) (get_cterm a') (mk_integer k)
                  [bterm [] mk_zero]) as h.
    autodimp h hyp; fold_terms.
    eapply reduces_to_trans;[exact h|clear h].
    apply reduces_to_if_step; csunf; simpl.
    dcwf h; allsimpl.
    rw <- Zplus_0_r_reverse; auto.
  }

  eapply reduces_to_trans;[exact h|clear h].

  apply (reduces_to_if_split2
           _ _ (mk_apply (get_cterm f) (mk_integer k))).

  { csunf; simpl; unfold apply_bterm, lsubst; simpl; boolvar; tcsp;
    try (complete (provefalse; sp)).
    rw @lsubst_aux_trivial_cl_term2; eauto with slow. }

  pose proof (m a' (mkc_integer k)) as q.
  autodimp q hyp.

  { apply equality_in_int.
    unfold equality_of_int.
    exists k; dands; spcast; eauto with slow.
    apply computes_to_valc_refl; eauto with slow. }

  apply equality_in_int in q.
  apply equality_of_int_imp_tt in q.
  unfold equality_of_int_tt in q; exrepnd.
  unfold computes_to_valc in q0; allsimpl.
  unfold computes_to_value in q0; repnd.
  allrw @get_cterm_apply; allsimpl.
  repeat computes_to_eqval; auto.
Qed.

Lemma agree_upto_c_iff {o} :
  forall lib b (f g : @CTerm o),
    member lib f (mkc_fun mkc_int mkc_int)
    -> member lib g (mkc_fun mkc_int mkc_int)
    -> (agree_upto_red_bc lib b f g
        <=> agree_upto_bc lib b f g).
Proof.
  introv mf mg.

  rw @equality_in_fun in mf.
  rw @equality_in_fun in mg.
  repnd.
  clear mf0 mg0 mf1 mg1.

  split; intro agree.

  - unfold agree_upto_bc; introv l.
    unfold agree_upto_red_bc in agree.
    pose proof (agree (mkc_integer i) (mkc_integer i) i) as h.
    repeat (autodimp h hyp); unfold reduces_toc; eauto with slow.

  - unfold agree_upto_red_bc; introv r1 r2 l.
    unfold agree_upto_bc in agree.
    pose proof (agree i l) as h; exrepnd.

    pose proof (mf t1 (mkc_integer i)) as k1.
    autodimp k1 hyp.
    { apply equality_in_int.
      unfold equality_of_int.
      exists i; dands; spcast;
      apply computes_to_valc_iff_reduces_toc;
      dands; eauto with slow. }

    pose proof (mg t2 (mkc_integer i)) as k2.
    autodimp k2 hyp.
    { apply equality_in_int.
      unfold equality_of_int.
      exists i; dands; spcast;
      apply computes_to_valc_iff_reduces_toc;
      dands; eauto with slow. }

    allrw @equality_in_int.
    allapply @equality_of_int_imp_tt.
    allunfold @equality_of_int_tt; exrepnd.
    repeat computes_to_eqval.

    eexists; eauto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


(** * Equational reasoning for Riesz spaces restricted to terms in negative normal form *)

Require Import CMorphisms.

Require Import EqNat.
Require Import PeanoNat.
Require Import Lra.

Require Import Rpos.
Require Import RL.hmr.term.

Local Open Scope R_scope.

(** ** Basic definitions needed for equational reasoning *)
(** Context *)
Inductive context : Type :=
| MRS_hole : context
| MRS_cohole : context
| MRS_TC : term -> context
| MRS_varC : term.V -> context
| MRS_covarC : term.V -> context
| MRS_zeroC : context
| MRS_minC : context -> context -> context
| MRS_maxC : context -> context -> context
| MRS_plusC : context -> context -> context
| MRS_mulC : Rpos -> context -> context
| MRS_oneC : context
| MRS_cooneC : context
| MRS_diamondC : context -> context.

Fixpoint evalContext (c : context) (t : term) : term :=
  match c with
  | MRS_hole => t
  | MRS_cohole => -S t
  | MRS_TC t' => t'
  | MRS_varC n => MRS_var n
  | MRS_covarC n => MRS_covar n
  | MRS_zeroC => MRS_zero
  | MRS_minC c1 c2 => MRS_min (evalContext c1 t) (evalContext c2 t)
  | MRS_maxC c1 c2 => MRS_max (evalContext c1 t) (evalContext c2 t)
  | MRS_plusC c1 c2 => MRS_plus (evalContext c1 t) (evalContext c2 t)
  | MRS_mulC x c => MRS_mul x (evalContext c t)
  | MRS_oneC => MRS_one
  | MRS_cooneC => MRS_coone
  | MRS_diamondC c => MRS_diamond (evalContext c t)
  end.

Fixpoint minusC c :=
  match c with
  | MRS_hole => MRS_cohole
  | MRS_cohole => MRS_hole
  | MRS_TC t => MRS_TC (-S t)
  | MRS_varC n => MRS_covarC n
  | MRS_covarC n => MRS_varC n
  | MRS_zeroC => MRS_zeroC
  | MRS_plusC c1 c2 => MRS_plusC (minusC c1) (minusC c2)
  | MRS_mulC r c1 => MRS_mulC r (minusC c1)
  | MRS_maxC c1 c2 => MRS_minC (minusC c1) (minusC c2)
  | MRS_minC c1 c2 => MRS_maxC (minusC c1) (minusC c2)
  | MRS_oneC => MRS_cooneC
  | MRS_cooneC => MRS_oneC
  | MRS_diamondC c => MRS_diamondC (minusC c)
  end.

(** ** Equational Reasoning *)
Inductive eqMALG : term -> term -> Type :=
(** equational rules *)
| refl t : eqMALG t t
| trans t1 t2 t3 : eqMALG t1 t2 -> eqMALG t2 t3 -> eqMALG t1 t3
| ctxt c t1 t2 : eqMALG t1 t2 -> eqMALG (evalContext c t1) (evalContext c t2)
| sym t1 t2 : eqMALG t1 t2 -> eqMALG t2 t1
| subs_r t1 t2 n t : eqMALG t1 t2 -> eqMALG (subs t1 n t) (subs t2 n t)
(** vector space axioms *)
| asso_plus t1 t2 t3 : eqMALG (t1 +S (t2 +S t3)) ((t1 +S t2) +S t3)
| commu_plus t1 t2 : eqMALG (t1 +S t2) (t2 +S t1)
| neutral_plus t : eqMALG (t +S MRS_zero) t
| opp_plus t : eqMALG (t -S t) MRS_zero
| minus_ax a b t (Hlt: (projT1 b < projT1 a)%R) : eqMALG ((a *S t) +S (b *S (-S t))) ((minus_pos Hlt) *S t)
| mul_1 t  : eqMALG (One *S t) t
| mul_assoc x y t : eqMALG (x *S (y *S t)) ((time_pos x y) *S t)
| mul_distri_term x t1 t2 : eqMALG (x *S (t1 +S t2)) ((x *S t1) +S (x *S t2))
| mul_distri_coeff x y t : eqMALG ((plus_pos x y) *S t) ((x *S t) +S (y *S t))
| mul_minus x t : eqMALG (x *S (-S t)) (-S (x *S t))
(** lattice axioms *)
| asso_max t1 t2 t3 : eqMALG (t1 \/S (t2 \/S t3)) ((t1 \/S t2) \/S t3)
| commu_max t1 t2 : eqMALG (t1 \/S t2) (t2 \/S t1)
| abso_max t1 t2 : eqMALG (t1 \/S (t1 /\S t2)) t1
| asso_min t1 t2 t3 : eqMALG (t1 /\S (t2 /\S t3)) ((t1 /\S t2) /\S t3)
| commu_min t1 t2 : eqMALG (t1 /\S t2) (t2 /\S t1)
| abso_min t1 t2 : eqMALG (t1 /\S (t1 \/S t2)) t1
(** compability axiom *)
| compa_plus_ax t1 t2 t3 : eqMALG (((t1 /\S t2) +S t3) /\S (t2 +S t3)) ((t1 /\S t2) +S t3)
| compa_mul_ax r t : eqMALG (MRS_zero /\S (r *S (t \/S MRS_zero))) MRS_zero
(** modal axioms *)
| diamond_linear t1 t2 : eqMALG (<S> (t1 +S t2)) ((<S> t1) +S (<S> t2))
| diamond_mul r t : eqMALG (<S> (r *S t)) (r *S <S> t)
| diamond_one : eqMALG ((<S> MRS_one) /\S MRS_one) (<S> MRS_one)
| diamond_pos t : eqMALG (MRS_zero /\S <S> (t \/S MRS_zero)) MRS_zero
| one_pos : eqMALG (MRS_zero /\S MRS_one) MRS_zero.

Notation "A === B" := (eqMALG A B) (at level 90, no associativity).
Notation "A <== B" := (eqMALG (A /\S B) A) (at level 90, no associativity).

(** *** === is an equivalence relation **)

Instance eqMALG_Equivalence : Equivalence eqMALG | 10 := {
  Equivalence_Reflexive := refl ;
  Equivalence_Symmetric := sym ;
  Equivalence_Transitive := trans }.

(** *** Proofs of a equalities *)

Hint Constructors eqMALG : core.

Lemma cong_S : forall A B, A = B -> A === B.
Proof.
  intros A B eq.
  subst.
  reflexivity.
Qed.
Hint Resolve cong_S : core.

Lemma plus_left : forall A B C, A === C -> A +S B === C +S B.
Proof.
  intros A B C eq.
  apply (@ctxt (MRS_plusC MRS_hole (MRS_TC B))).
  apply eq.
Qed.

Lemma plus_right : forall A B C, B === C -> A +S B === A +S C.
Proof.
  intros A B C eq.
  apply (@ctxt (MRS_plusC (MRS_TC A) MRS_hole)).
  apply eq.
Qed.

Lemma plus_cong : forall A B C D, A === B -> C === D -> A +S C === B +S D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A +S D); [apply plus_right | apply plus_left]; assumption.
Qed.

Global Instance plus_cong_instance : Proper (eqMALG ==> eqMALG ==> eqMALG) MRS_plus | 10.
Proof. repeat intro; now apply plus_cong. Qed.

Lemma max_left : forall A B C, A === C -> A \/S B === C \/S B.
Proof.
  intros A B C eq.
  apply (@ctxt (MRS_maxC MRS_hole (MRS_TC B))).
  apply eq.
Qed.

Lemma max_right : forall A B C, B === C -> A \/S B === A \/S C.
Proof.
  intros A B C eq.
  apply (@ctxt (MRS_maxC (MRS_TC A) MRS_hole)).
  apply eq.
Qed.

Lemma max_cong : forall A B C D, A === B -> C === D -> A \/S C === B \/S D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A \/S D); [apply max_right | apply max_left]; assumption.
Qed.

Global Instance max_cong_instance : Proper (eqMALG ==> eqMALG ==> eqMALG) MRS_max | 10.
Proof. repeat intro; now apply max_cong. Qed.

Lemma min_left : forall A B C, A === C -> A /\S B === C /\S B.
Proof.
  intros A B C eq.
  apply (@ctxt (MRS_minC MRS_hole (MRS_TC B))).
  apply eq.
Qed.

Lemma min_right : forall A B C, B === C -> A /\S B === A /\S C.
Proof.
  intros A B C eq.
  apply (@ctxt (MRS_minC (MRS_TC A) MRS_hole)).
  apply eq.
Qed.

Lemma mul_left : forall x y A , x = y -> MRS_mul x A === MRS_mul y A.
Proof.
  intros x y A eq.
  rewrite eq.
  auto.
Qed.

Lemma min_cong : forall A B C D, A === B -> C === D -> A /\S C === B /\S D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A /\S D); [apply min_right | apply min_left]; assumption.
Qed.

Global Instance min_cong_instance : Proper (eqMALG ==> eqMALG ==> eqMALG) MRS_min | 10.
Proof. repeat intro; now apply min_cong. Qed.

Lemma mul_right : forall x A B , A === B -> x *S A === x *S B.
Proof.
  intros x A B eq.
  apply (@ctxt (MRS_mulC x MRS_hole)).
  apply eq.
Qed.

Global Instance mul_right_instance x : Proper (eqMALG ==> eqMALG) (MRS_mul x) | 10.
Proof. repeat intro; now apply mul_right. Qed.

Lemma minus_cong : forall A B , A === B -> -S A === -S B.
Proof.
  intros A B eq.
  apply (@ctxt MRS_cohole).
  assumption.
Qed.

Global Instance minus_cong_instance : Proper (eqMALG ==> eqMALG) MRS_minus | 10.
Proof. repeat intro; now apply minus_cong. Qed.

Lemma diamond_cong : forall A B, A === B -> (<S> A === <S> B).
Proof.
  intros A B eq.
  apply (@ctxt (MRS_diamondC MRS_hole)).
  apply eq.
Qed.

Global Instance diamond_cong_instance : Proper (eqMALG ==> eqMALG) MRS_diamond | 10.
Proof. repeat intro; now apply diamond_cong. Qed.

Hint Resolve plus_left plus_right max_left max_right min_left min_right minus_cong mul_left mul_right diamond_cong : core.

Lemma evalContext_cong : forall c t1 t2, t1 === t2 -> evalContext c t1 === evalContext c t2.
Proof.
  induction c; simpl; auto.
  all:intros t1 t2 eq; specialize (IHc1 t1 t2 eq); specialize (IHc2 t1 t2 eq).
  - etransitivity; [apply (@ctxt (MRS_minC MRS_hole (MRS_TC (evalContext c2 t1)))); apply IHc1 |]; simpl.
    apply (@ctxt (MRS_minC (MRS_TC (evalContext c1 t2)) MRS_hole)); apply IHc2.
  - etransitivity; [apply (@ctxt (MRS_maxC MRS_hole (MRS_TC (evalContext c2 t1)))); apply IHc1 |]; simpl.
    apply (@ctxt (MRS_maxC (MRS_TC (evalContext c1 t2)) MRS_hole)); apply IHc2.
  - etransitivity; [apply (@ctxt (MRS_plusC MRS_hole (MRS_TC (evalContext c2 t1)))); apply IHc1 |]; simpl.
    apply (@ctxt (MRS_plusC (MRS_TC (evalContext c1 t2)) MRS_hole)); apply IHc2.
Qed.

Global Instance evalContext_cong_instance c : Proper (eqMALG ==> eqMALG) (evalContext c) | 10.
Proof. repeat intro; now apply evalContext_cong. Qed.

Lemma leq_compa_plus : forall A B C, (A /\S B) +S C <== B +S C.
Proof.
  intros A B C.
  auto.
Qed.

Hint Resolve leq_compa_plus : MGA_solver.

Lemma minus_distri : forall A B, -S (A +S B) === (-S A) +S (-S B).
Proof.
  intros A B.
  auto.
Qed.

Hint Resolve minus_distri : MGA_solver.

Lemma minus_zero : MRS_zero === -S MRS_zero.
Proof.
  auto.
Qed.

Lemma minus_minus : forall A , -S (-S A) = A.
Proof with auto.
  induction A; simpl; try rewrite IHA; try rewrite IHA1; try rewrite IHA2...
Qed.

Hint Resolve minus_zero : MGA_solver.
Hint Resolve minus_minus : MGA_solver.

Lemma leq_antisym : forall A B, A <== B -> B <== A -> A === B.
Proof with auto.
  intros A B eq1 eq2.
  apply trans with (B /\S A)...
  apply trans with (A /\S B)...
Qed.

Lemma leq_cong_l : forall A A' B, A === A' -> A' <== B -> A <== B.
Proof with auto.
  intros A A' B eq leq.
  apply trans with (A' /\S B)...
  apply trans with A'...
Qed.

Lemma leq_cong_r : forall A B B', B === B' -> A <== B' -> A <== B.
Proof with auto.
  intros A B B' eq leq.
  apply trans with (A /\S B')...
Qed.

Lemma leq_trans : forall A B C, A <== B -> B <== C -> A <== C.
Proof with auto.
  intros A B C leq1 leq2.
  apply trans with ((A /\S B) /\S C)...
  apply trans with (A /\S (B /\S C))...
  apply trans with (A /\S B)...
Qed.

Lemma leq_plus : forall A B C, A <== B -> (A +S C) <== (B +S C).
Proof with auto.
  intros A B C leq.
  apply leq_cong_l with ((A /\S B) +S C)...
Qed.

Hint Resolve leq_plus : MGA_solver.

Lemma min_max : forall A B , (A /\S B) === A -> (A \/S B) === B.
Proof with auto.
  intros A B eq.
  apply trans with ((A /\S B) \/S B)...
  apply trans with ((B /\S A) \/S B)...
  apply trans with (B \/S (B /\S A))...
Qed.

Lemma max_min : forall A B , (A \/S B) === A -> (A /\S B) === B.
Proof with auto.
  intros A B eq.
  apply trans with ((A \/S B) /\S B)...
  apply trans with ((B \/S A) /\S B)...
  apply trans with (B /\S (B \/S A))...
Qed.

Hint Resolve max_min min_max : MGA_solver.

Lemma leq_refl_cong : forall A B, ((A /\S A) /\S B) === A /\S B.
Proof with auto.
  intros A B.
  apply trans with (A /\S (A /\S B))...
  apply max_min.
  apply abso_max.
Qed.

Lemma leq_refl : forall A , A /\S A === A.
Proof with auto.
  intro A.
  apply trans with (A /\S (A /\S (A \/S A)))...
  apply trans with ((A /\S A) /\S (A \/S A))...
  apply trans with (A /\S (A \/S A)); auto using leq_refl_cong.
Qed.

Hint Resolve leq_refl : MGA_solver.

Lemma leq_min : forall A B C, A <== B -> A <== C -> A <== (B /\S C).
Proof with auto.
  intros A B C leq1 leq2.
  apply trans with ((A /\S B) /\S C)...
  apply trans with (A /\S C)...
Qed.

Lemma leq_max : forall A B , A <== (A \/S B).
Proof with auto.
  intros A B.
  auto.
Qed.

Lemma min_leq : forall A B, (A /\S B) <== A.
Proof with auto with *.
  intros A B.
  apply trans with (A /\S (A /\S B))...
Qed.

Lemma max_leq : forall A B C, A <== C -> B <== C -> (A \/S B) <== C.
Proof with auto with *.
  intros A B C leq1 leq2.
  apply trans with (C /\S (A \/S B))...
  apply max_min.
  apply trans with ((A \/S B) \/S C)...
  apply trans with (A \/S (B \/S C))...
  apply trans with (A \/S C)...
Qed.

Hint Resolve leq_max min_leq min_leq max_leq : MGA_solver.

Lemma leq_plus_left : forall A B C, A <== B -S C -> A +S C <== B.
Proof with auto with *.
  intros A B C leq.
  apply leq_cong_r with (B +S (-S C) +S C)...
  apply trans with (B +S ((-S C) +S C))...
  apply trans with (B +S (C -S C))...
  apply trans with (B +S MRS_zero)...
Qed.

Lemma leq_plus_right : forall A B C, A -S B <== C -> A <== C +S B.
Proof with auto with *.
  intros A B C leq.
  apply leq_cong_l with ( A -S B +S B)...
  apply trans with (A +S MRS_zero)...
  apply trans with (A +S (B -S B))...
  apply trans with (A +S ((-S B) +S B))...
Qed.

Lemma leq_minus_left : forall A B C, A <== B +S C -> A -S C <== B.
Proof with auto.
  intros A B C leq.
  apply leq_plus_left...
  apply trans with (A /\S (B +S C)); auto using minus_minus.
Qed.

Lemma leq_minus_right : forall A B C , A +S C <== B -> A <== B -S C.
Proof with auto.
  intros A B C leq.
  apply leq_plus_right.
  apply trans with ((A +S C) /\S B); auto using minus_minus.
  apply trans with (A +S C); auto using minus_minus.
Qed.

Lemma max_plus : forall A B C, ((A \/S B) +S C) === (A +S C) \/S (B +S C).
Proof with auto.
  intros A B C.
  apply leq_antisym.
  - apply leq_plus_left.
    apply max_leq.
    + apply leq_minus_right...
    + apply leq_minus_right...
      apply trans with ((B +S C) /\S ((B +S C) \/S (A +S C)))...
  - apply max_leq; auto using leq_plus.
    apply leq_plus_right.
    apply leq_cong_l with B.
      * apply trans with (B +S (C -S C))...
        apply trans with (B +S MRS_zero)...
      * apply leq_cong_r with (B \/S A)...
Qed.

Hint Resolve max_plus : MGA_solver.

Lemma minus_reverse_leq : forall A B, B <== A -> (-S A) <== (-S B).
Proof with auto.
  intros A B leq.
  apply leq_cong_r with (-S B +S MRS_zero)...
  apply leq_cong_r with (MRS_zero -S B)...
  apply leq_minus_right.
  apply leq_cong_l with (B -S A)...
  apply leq_minus_left.
  apply leq_cong_r with (A +S MRS_zero)...
  apply leq_cong_r with A...
Qed.

Hint Resolve minus_reverse_leq : MGA_solver.

Lemma minus_min_max : forall A B, -S (A /\S B) === (-S A) \/S (-S B).
Proof with auto with MGA_solver.
  intros A B.
  apply leq_antisym.
  - apply leq_cong_r with (-S (-S ((-S A) \/S (-S B))))...
    apply minus_reverse_leq.
    apply leq_min.
    + apply leq_cong_r with (-S (-S A))...
    + apply leq_cong_r with (-S (-S B))...
      apply leq_cong_l with (-S (-S B \/S -S A))...
  - apply max_leq.
    + apply minus_reverse_leq...
    + apply leq_cong_r with (-S (B /\S A))...
Qed.

Lemma min_leq_max : forall A B, A /\S B <== A \/S B.
Proof with auto with MGA_solver.
  intros A B.
  apply leq_trans with A...
Qed.

Hint Resolve minus_min_max min_leq_max : MGA_solver.

Lemma minus_inj : forall A B, -S A === -S B -> A === B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (-S (-S A))...
  apply trans with (-S (-S B))...
Qed.

Lemma leq_plus_cong : forall A B C D, A <== B -> C <== D -> A +S C <== B +S D.
Proof with auto with MGA_solver.
  intros A B C D leq1 leq2.
  apply leq_trans with (B +S C)...
  apply leq_cong_l with (C +S B)...
  apply leq_cong_r with (D +S B)...
Qed.

Hint Resolve leq_plus_cong : MGA_solver.

Lemma cond_leq : forall A B, MRS_zero <== (A -S B) -> B <== A.
Proof with auto with MGA_solver.
  intros A B Hleq.
  apply leq_cong_r with ((A -S B) +S B).
  { apply trans with (A +S MRS_zero)...
    apply trans with (A +S (B -S B))...
    apply trans with (A +S ((-S B) +S B))... }
  apply leq_cong_l with (MRS_zero +S B)...
  apply trans with (B +S MRS_zero)...
Qed.

Lemma cond_leq_inv : forall A B, B <== A -> MRS_zero <== (A -S B).
Proof with auto with MGA_solver.
  intros A B Hleq.
  apply leq_cong_l with (B -S B)...
Qed.

Lemma eq_minus : forall A B, A === B -> A -S B === MRS_zero.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (B -S B)...
Qed.

Hint Resolve eq_minus : MGA_solver.

Lemma minus_eq : forall A B, A -S B === MRS_zero -> A === B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (A +S MRS_zero)...
  apply trans with (A +S (B -S B))...
  apply trans with (A +S ((-S B) +S B))...
  apply trans with (A -S B +S B)...
  apply trans with (MRS_zero +S B)...
  apply trans with (B +S MRS_zero)...
Qed.

Lemma mul_compa : forall (r : Rpos) A B, A <== B -> (r *S A) <== (r *S B).
Proof with auto with MGA_solver.
  intros r A B HleqAB.
  apply cond_leq.
  apply leq_cong_r with ((r *S ((B -S A) \/S MRS_zero))).
  { apply trans with ((r *S B) +S (r *S (-S A)))...
    apply trans with (r *S (B -S A))...
    apply mul_right.
    apply sym.
    apply trans with (MRS_zero \/S (B -S A))...
    apply min_max.
    apply cond_leq_inv...
  }
  apply compa_mul_ax...
Qed.

Hint Resolve mul_compa : MGA_solver.

Lemma mul_0 :  forall r, r *S MRS_zero === MRS_zero.
Proof with auto with MGA_solver.
  intro r.
  transitivity (r *S (MRS_zero +S MRS_zero))...
  transitivity (r *S MRS_zero +S r *S MRS_zero)...
  transitivity (r *S MRS_zero +S r *S (-S MRS_zero))...
  transitivity (r *S MRS_zero +S (-S (r *S MRS_zero)))...
Qed.

Hint Resolve mul_0 : MGA_solver.

Lemma no_div_zero : forall r A, r *S A === MRS_zero -> A === MRS_zero.
Proof with auto with MGA_solver.
  intros r A eq.
  transitivity (One *S A)...
  transitivity ((time_pos (inv_pos r) r) *S A)...
  { apply mul_left.
    apply Rpos_eq; destruct r; simpl. clear eq; apply R_blt_lt in e.
    rewrite Rinv_l...
    nra. }
  apply trans with ((inv_pos r) *S (r *S A))...
  apply trans with ((inv_pos r) *S MRS_zero)...
Qed.

Lemma mul_distri_minus : forall k A B, (k *S A) -S (k *S B) === k *S (A -S B).
Proof with auto with MGA_solver.
  intros k A B.
  apply trans with ((k *S A) +S (k *S (-S B)))...
Qed.

Lemma minus_max_min : forall A B, -S (A \/S B) === (-S A) /\S (-S B).
Proof with auto with MGA_solver.
  intros A B.
  apply trans with (-S (A \/S (-S (-S B))))...
  apply trans with (-S ((-S (-S A)) \/S (-S (-S B))))...
  apply trans with (-S (-S ((-S A) /\S (-S B))))...
Qed.

Hint Resolve mul_distri_minus minus_max_min : MGA_solver.

Lemma zero_leq_pos : forall A , MRS_zero <== pos A.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_r with (MRS_zero \/S A)...
Qed.

Lemma zero_leq_neg : forall A , MRS_zero <== neg A.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_r with (MRS_zero \/S (-S A))...
Qed.

Hint Resolve zero_leq_pos zero_leq_neg : MGA_solver.

Lemma eq_minus_right : forall A B C, A +S C === B -> A === B -S C.
Proof with auto with MGA_solver.
  intros A B C eq.
  apply trans with (A +S MRS_zero)...
  apply trans with (A +S (C -S C))...
  apply trans with ((A +S C) -S C)...
Qed.

Lemma eq_plus_right : forall A B C, A -S C === B -> A === B +S C.
Proof with auto with MGA_solver.
  intros A B C eq.
  apply trans with (A +S MRS_zero)...
  apply trans with (A +S (C -S C))...
  apply trans with (A +S ((-S C) +S C))...
  apply trans with ((A -S C) +S C)...
Qed.

Lemma decomp_pos_neg : forall A, A === (pos A) -S (neg A).
Proof with auto with MGA_solver.
  intros A.
  apply eq_minus_right.
  apply trans with (A \/S (A -S A))...
  apply trans with ((A +S MRS_zero) \/S (A -S A))...
  apply trans with ((MRS_zero +S A) \/S (A -S A))...
  apply trans with ((A -S A) \/S (MRS_zero +S A))...
  apply trans with (((-S A) +S A) \/S (MRS_zero +S A))...
  apply trans with (neg A +S A)...
Qed.

Hint Resolve decomp_pos_neg : MGA_solver.

Lemma pos_neg : forall A, pos A === A +S (neg A).
Proof.
  intros A.
  apply trans with ((pos A -S neg A) +S neg A); auto using eq_plus_right with MGA_solver.
Qed.

Lemma neg_pos : forall A , neg A === (pos A) -S A.
Proof with auto with MGA_solver.
  intros A.
  apply eq_minus_right...
  apply trans with (A +S neg A); auto using eq_plus_right with MGA_solver.
Qed.

Hint Resolve pos_neg neg_pos : MGA_solver.

Lemma min_plus : forall A B C, (A /\S B) +S C === (A +S C) /\S (B +S C).
Proof with auto with MGA_solver.
  intros A B C.
  apply trans with (-S (-S ((A +S C) /\S (B +S C))))...
  apply trans with (-S ((-S (A +S C)) \/S (-S (B +S C))))...
  apply trans with (-S (((-S A) -S C) \/S ((-S (B +S C)))))...
  apply trans with (-S (((-S A) -S C) \/S (((-S B) -S C))))...
  apply trans with (-S (((-S A) \/S ((-S B))) -S C))...
  apply trans with ((-S (((-S A) \/S ((-S B))))) -S (-S C))...
  apply trans with ((-S (((-S A) \/S ((-S B))))) +S C)...
  apply trans with (((-S (-S A)) /\S ((-S (-S B)))) +S C)...
  apply trans with ((A /\S ((-S (-S B)))) +S C)...
Qed.

Hint Resolve min_plus : MGA_solver.

Lemma min_pos_neg : forall A, (pos A) /\S (neg A) === MRS_zero.
Proof with auto with MGA_solver.
  intros A.
  apply trans with ((A +S (neg A)) /\S (neg A))...
  apply trans with ((A +S (neg A)) /\S (neg A +S MRS_zero))...
  apply trans with ((A +S (neg A)) /\S (MRS_zero +S neg A))...
  apply trans with ((A /\S MRS_zero) +S neg A)...
  apply trans with ( (-S (-S (A /\S MRS_zero))) +S neg A)...
  apply trans with ( (-S ((-S A) \/S (-S MRS_zero))) +S neg A)...
  apply trans with ( (-S (neg A)) +S neg A)...
  apply trans with (neg A -S neg A)...
Qed.

Hint Resolve min_pos_neg : MGA_solver.

Lemma cond_zero_leq_max : forall A B,
    (A \/S B) === (pos A \/S pos B) -> MRS_zero <== A \/S B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with ((A \/S B) /\S MRS_zero)...
  apply max_min.
  apply trans with ((A \/S B) \/S (MRS_zero \/S MRS_zero))...
  apply trans with (A \/S (B \/S (MRS_zero \/S MRS_zero)))...
  apply trans with (A \/S (pos B \/S MRS_zero))...
  apply trans with (A \/S (MRS_zero \/S pos B))...
  apply trans with (pos A \/S pos B)...
Qed.

Lemma cond_eq_pos : forall A B,
    MRS_zero <== A \/S B -> (A \/S B) === (pos A \/S pos B).
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (A \/S (MRS_zero \/S pos B))...
  apply trans with (A \/S (pos B \/S MRS_zero))...
  apply trans with (A \/S (B \/S (MRS_zero \/S MRS_zero)))...
  apply trans with ((A \/S B) \/S (MRS_zero \/S MRS_zero))...
  apply trans with (A \/S B \/S MRS_zero)...
  apply trans with (MRS_zero \/S (A \/S B))...
Qed.

Lemma max_pos : forall A B, A \/S B === (pos (A -S B)) +S B.
Proof with auto with MGA_solver.
  intros A B.
  apply trans with ((A +S MRS_zero) \/S B)...
  apply trans with ((A +S (B -S B)) \/S B)...
  apply trans with ((A +S ((-S B) +S B)) \/S B)...
  apply trans with ((A +S (-S B) +S B) \/S B)...
  apply trans with ((A +S (-S B) +S B) \/S (B +S MRS_zero))...
  apply trans with ((A +S (-S B) +S B) \/S (MRS_zero +S B))...
Qed.

Hint Resolve max_pos : MGA_solver.

Lemma min_pos : forall A B, A /\S B === A -S (pos (A -S B)).
Proof with auto with MGA_solver.
  intros A B.
  apply eq_minus_right.
  apply trans with ((pos (A -S B)) +S (A /\S B))...
  apply sym.
  apply eq_plus_right.
  apply trans with (A +S ((-S A) \/S (-S B)))...
  apply trans with (((-S A) \/S (-S B)) +S A)...
  apply trans with (((-S A) +S A) \/S ((-S B) +S A))...
  apply trans with ((A -S A) \/S ((-S B) +S A))...
  apply trans with (MRS_zero \/S ((-S B) +S A))...
  apply trans with (MRS_zero \/S (A -S B))...
Qed.

Hint Resolve min_pos : MGA_solver.

Lemma min_max_plus : forall A B, (A \/S B) +S (A /\S B) === A +S B.
Proof with auto with MGA_solver.
  intros A B.
  apply trans with (((pos (A -S B)) +S B) +S (A /\S B))...
  apply trans with (((pos (A -S B)) +S B) +S (A -S (pos (A -S B))))...
  apply trans with ((B +S (pos (A -S B))) +S (A -S (pos (A -S B))))...
  apply trans with (B +S ((pos (A -S B)) +S (A -S (pos (A -S B)))))...
  apply trans with (B +S ((pos (A -S B)) +S ((-S (pos (A -S B))) +S A)))...
  apply trans with (B +S ((pos (A -S B)) +S (-S (pos (A -S B))) +S A))...
  apply trans with (B +S (MRS_zero +S A))...
  apply trans with (B +S (A +S MRS_zero))...
  apply trans with (B +S A)...
Qed.

Hint Resolve min_max_plus : MGA_solver.

Lemma max_distri_min : forall A B C, (A /\S B) \/S C === (A \/S C) /\S (B \/S C).
Proof with auto with MGA_solver.
  intros A B C.
  remember ((A \/S C) /\S (B \/S C)) as m.
  apply leq_antisym.
  - apply leq_cong_r with (A \/S C /\S B \/S C)...
    apply leq_min.
    + apply max_leq.
      * apply leq_trans with A...
      * apply leq_cong_r with (C \/S A)...
    + apply max_leq...
      * apply leq_trans with B...
        apply leq_cong_l with (B /\S A)...
      * apply leq_cong_r with (C \/S B)...
  - apply leq_cong_r with ((A /\S B) -S ((-S C) +S ((A /\S B) /\S C)))...
    + apply trans with ((A /\S B) +S ((-S (-S C)) -S ((A /\S B) /\S C)))...
      apply trans with ((A /\S B) +S (C -S ((A /\S B) /\S C)))...
      apply trans with (((A /\S B) +S C) -S ((A /\S B) /\S C)); auto using eq_minus_right with MGA_solver.
    + apply leq_minus_right...
      apply leq_min...
      * apply leq_cong_l with ((m +S ((A /\S B) /\S C)) -S C)...
        ** apply trans with (m +S (((A /\S B) /\S C) -S C))...
        ** apply leq_cong_r with ((A +S C) -S C); auto using eq_minus_right with MGA_solver.
           apply leq_plus.
           apply leq_cong_r with ((A \/S C) +S (A /\S C))...
           apply leq_trans with (m +S (A /\S C))...
           *** apply leq_plus_cong...
               apply leq_cong_l with (A /\S (B /\S C))...
               apply leq_cong_l with (A /\S (C /\S B))...
               apply leq_cong_l with (A /\S C /\S B)...
           *** apply leq_plus_cong...
               apply leq_cong_l with (A \/S C /\S B \/S C)...
      * apply leq_cong_l with (m +S ((A /\S B /\S C) -S C))...
        apply leq_cong_l with ((m +S (A /\S B /\S C)) -S C)...
        apply leq_cong_r with (B +S MRS_zero)...
        apply leq_cong_r with (B +S (C -S C))...
        apply leq_cong_r with ((B +S C) -S C)...
        apply leq_plus...
        apply leq_cong_r with ((B \/S C) +S (B /\S C))...
        apply leq_plus_cong...
        apply leq_cong_l with (A \/S C /\S B \/S C)...
        ** apply leq_cong_l with (B \/S C /\S A \/S C)...
        ** apply leq_cong_l with (A /\S (B /\S C))...
           apply leq_cong_l with ((B /\S C) /\S A)...
Qed.

Hint Resolve max_distri_min : MGA_solver.

Lemma min_distri_max : forall A B C, (A \/S B) /\S C === (A /\S C) \/S (B /\S C).
Proof with auto with MGA_solver.
  intros A B C.
  apply trans with (-S (-S (A \/S B /\S C)))...
  apply trans with (-S ((-S (A \/S B) \/S (-S C))))...
  apply trans with (-S (((-S A) /\S (-S B)) \/S (-S C)))...
  apply trans with (-S (((-S A) \/S (-S C)) /\S ((-S B) \/S (-S C))))...
  apply trans with ((-S ((-S A) \/S (-S C))) \/S (-S ((-S B) \/S (-S C))))...
  apply trans with (((-S (-S A)) /\S (-S (-S C))) \/S (-S ((-S B) \/S (-S C))))...
  apply trans with (((-S (-S A)) /\S (-S (-S C))) \/S ((-S (-S B)) /\S (-S (-S C))))...
  apply trans with ((A /\S (-S (-S C))) \/S ((-S (-S B)) /\S (-S (-S C))))...
  apply trans with ((A /\S C) \/S ((-S (-S B)) /\S (-S (-S C))))...
  apply trans with ((A /\S C) \/S (B /\S (-S (-S C))))...
Qed.

Hint Resolve min_distri_max : MGA_solver.

Lemma decomp_max_pos_neg : forall A B, A \/S B === ((pos A) \/S (pos B)) -S ((neg A) /\S (neg B)).
Proof with auto with MGA_solver.
  intros A B.
  apply trans with (pos (A \/S B) -S (neg (A \/S B)))...
  apply trans with ((pos A \/S pos B) -S (neg (A \/S B))).
  - apply (@ctxt (MRS_plusC MRS_hole (minusC (MRS_TC (neg (A \/S B)))))).
    apply trans with (A \/S B \/S (MRS_zero \/S MRS_zero))...
    apply trans with (A \/S (B \/S pos MRS_zero))...
    apply trans with (A \/S (pos B \/S MRS_zero))...
    apply trans with (A \/S (MRS_zero \/S pos B))...
  - apply trans with ((pos A \/S pos B) -S (((-S A) /\S (-S B)) \/S MRS_zero))...
Qed.

Hint Resolve decomp_max_pos_neg : MGA_solver.

Lemma cond_zero_leq_max_2 : forall A B, (neg A) /\S (neg B) === MRS_zero -> MRS_zero <== A \/S B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply cond_zero_leq_max...
  apply trans with ((pos A \/S pos B) +S MRS_zero)...
  apply trans with ((pos A \/S pos B) -S MRS_zero)...
  apply trans with ((pos A \/S pos B) -S (neg A /\S neg B))...
Qed.

Lemma cond_min_neg_eq_zero : forall A B, MRS_zero <== A \/S B -> (neg A) /\S (neg B) === MRS_zero.
Proof with auto with MGA_solver.
  intros A B leq.
  apply trans with (((pos A) \/S (pos B)) -S (A \/S B)); auto using eq_minus_right, cond_eq_pos with MGA_solver.
  apply eq_minus_right...
  apply trans with ((A \/S B) +S (neg A /\S neg B)); auto using eq_plus_right with MGA_solver.
Qed.

Lemma zero_leq_abs : forall A, MRS_zero <== abs A.
Proof with auto with MGA_solver.
  intro A.
  apply cond_zero_leq_max_2.
  apply trans with ((neg A) /\S (pos A))...
  apply trans with ((pos A) /\S (neg A))...
Qed.

Hint Resolve zero_leq_abs : MGA_solver.

Lemma mul_distri_max_pos : forall r A B, r *S (A \/S B) === (r *S A) \/S (r *S B).
Proof with auto with MGA_solver.
  intros r A B.
  apply leq_antisym.
  - apply leq_cong_r with (r *S ((inv_pos r) *S ((r *S A) \/S (r *S B)))).
    { apply trans with ((time_pos r (inv_pos r)) *S (r *S A \/S r *S B))...
      replace (time_pos r (inv_pos r)) with One...
      destruct r; apply Rpos_eq; simpl.
      apply R_blt_lt in e; rewrite Rinv_r...
      nra. }
    apply mul_compa.
    apply max_leq.
    + apply leq_cong_l with ((inv_pos r) *S (r *S A)).
      { apply trans with ((time_pos (inv_pos r) r) *S A)...
        replace (time_pos (inv_pos r) r) with One.
        2:{ apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_l; try auto; try nra. }
        auto with MGA_solver; apply Rgt_not_eq; apply Hlt. }
      apply mul_compa; try apply Rlt_le; try auto with MGA_solver.
    + apply leq_cong_l with ((inv_pos r) *S (r *S B)).
      { apply trans with ((time_pos (inv_pos r) r) *S B)...
        replace (time_pos (inv_pos r) r) with One.
        2:{ apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_l; try auto; try nra. }
        symmetry; apply mul_1. }
      apply mul_compa.
      eapply leq_cong_r ; [ apply commu_max | apply leq_max].
  - apply max_leq; apply mul_compa...
    apply leq_cong_r with (B \/S A)...
Qed.

Lemma mul_distri_min_pos : forall r A B, r *S (A /\S B) === (r *S A) /\S (r *S B).
Proof with auto with MGA_solver.
  intros r A B.
  apply leq_antisym.
  - apply leq_min; apply mul_compa...
    apply leq_cong_l with (B /\S A)...
  - apply leq_cong_l with (r *S ((inv_pos r) *S ((r *S A) /\S (r *S B)))).
    { apply trans with ((time_pos r (inv_pos r)) *S (r *S A /\S r *S B))...
      replace (time_pos r (inv_pos r)) with One...
      apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_r; nra. }
    apply mul_compa...
    apply leq_min.
    + apply leq_cong_r with ((inv_pos r) *S (r *S A)).
      { apply trans with ((time_pos (inv_pos r) r) *S A)...
        replace (time_pos (inv_pos r) r) with One...
        apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_l; nra. }
      apply mul_compa; try apply Rlt_le; try auto with MGA_solver.
    + apply leq_cong_r with ((inv_pos r) *S (r *S B)).
      { apply trans with ((time_pos (inv_pos r) r) *S B)...
        replace (time_pos (inv_pos r) r) with One...
        apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_l; nra. }
      apply mul_compa; try apply Rlt_le; try auto with MGA_solver.
      apply leq_cong_l with (r *S B /\S r *S A)...
Qed.
Hint Resolve mul_distri_max_pos : MGA_solver.
Hint Resolve mul_distri_min_pos : MGA_solver.

Require Import Lra.

Lemma mul_distri_min : forall A B, (plus_pos One One) *S (A /\S B) === ((plus_pos One One) *S A) /\S ((plus_pos One One) *S B).
Proof with auto with MGA_solver.
  intros A B.
  apply trans with (-S (-S ((plus_pos One One) *S (A /\S B))))...
  apply trans with (-S ((plus_pos One One) *S (-S (A /\S B))))...
  apply trans with (-S ((plus_pos One One) *S ((-S A) \/S (-S B))))...
  apply trans with (-S (((plus_pos One One) *S (-S A)) \/S ((plus_pos One One) *S (-S B))))...
  apply trans with (-S ((-S ((plus_pos One One) *S A)) \/S ((plus_pos One One) *S (-S B))))...
  apply trans with (-S ((-S ((plus_pos One One) *S A)) \/S (-S ((plus_pos One One) *S B))))...
  apply trans with (-S (-S (((plus_pos One One) *S A) /\S ((plus_pos One One) *S B))))...
Qed.

Hint Resolve mul_distri_min : MGA_solver.

Lemma mul_2 : forall A , (plus_pos One One) *S A === A +S A.
Proof with auto with MGA_solver.
  intros A.
  transitivity (One *S A +S One *S A)...
  transitivity (One *S A +S A)...
Qed.

Hint Resolve mul_2 : MGA_solver.

Lemma mean_prop : forall A B , A +S B <== (plus_pos One One) *S (A \/S B).
Proof with auto with MGA_solver.
  intros A B.
  apply leq_cong_r with (((plus_pos One One) *S A) \/S ((plus_pos One One) *S B))...
  apply leq_trans with (A +S (A \/S B))...
  { apply leq_cong_r with (A +S (B \/S A))... }
  apply leq_cong_r with ((plus_pos One One) *S (A \/S B))...
  apply leq_cong_r with ((A \/S B) +S (A \/S B))...
Qed.

Hint Resolve mean_prop : MGA_solver.

Lemma decomp_abs : forall A , abs A === pos A +S neg A.
Proof with auto with MGA_solver.
  intro A.
  apply trans with ((A +S MRS_zero) \/S (-S A))...
  etransitivity.
  { apply (@ctxt (MRS_maxC (MRS_plusC (MRS_TC A) MRS_hole) (MRS_TC (-S A)))).
    symmetry; apply (@opp_plus A). }
  simpl.
  apply trans with (((A +S A) -S A) \/S (-S A))...
  apply trans with (((A +S A) -S A) \/S ((-S A) +S MRS_zero))...
  apply trans with (((A +S A) -S A) \/S (MRS_zero -S A))...
  apply trans with (((A +S A) \/S MRS_zero) -S A)...
  transitivity ((((plus_pos One One) *S A) \/S MRS_zero) -S A)...
  transitivity ((((plus_pos One One) *S A) \/S (MRS_zero +S MRS_zero)) -S A)...
  transitivity ((((plus_pos One One) *S A) \/S ((plus_pos One One) *S MRS_zero)) -S A)...
  apply trans with (((plus_pos One One) *S (pos A)) -S A)...
  apply trans with ((pos A +S pos A) -S A)...
  apply trans with (pos A +S (pos A -S A))...
Qed.

Hint Resolve decomp_abs : MGA_solver.

Lemma pos_leq_abs : forall A , pos A <== abs A.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_l with (pos A +S MRS_zero)...
  apply leq_cong_r with (pos A +S neg A)...
Qed.

Lemma neg_leq_abs : forall A , neg A <== abs A.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_l with (neg A +S MRS_zero)...
  apply leq_cong_l with (MRS_zero +S neg A)...
  apply leq_cong_r with (pos A +S neg A)...
Qed.

Hint Resolve pos_leq_abs neg_leq_abs : MGA_solver.

Lemma abs_eq_zero : forall A , abs A === MRS_zero -> A === MRS_zero.
Proof with auto with MGA_solver.
  intros A eq.
  apply trans with (pos A -S neg A)...
  apply trans with (pos A -S MRS_zero)...
  - apply plus_right.
    apply minus_cong.
    apply leq_antisym...
    apply leq_trans with (abs A)...
    apply leq_cong_r with (abs A)...
  - apply trans with (pos A +S MRS_zero)...
    apply trans with (pos A)...
    apply leq_antisym...
    apply leq_trans with (abs A)...
    apply leq_cong_r with (abs A)...
Qed.

Lemma min_minus_leq_zero : forall A , A /\S (-S A) <== MRS_zero.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_l with (-S (-S (A /\S (-S A))))...
  apply leq_cong_r with (-S MRS_zero)...
  apply minus_reverse_leq.
  apply leq_cong_r with ((-S A) \/S (-S (-S A)))...
Qed.

Hint Resolve min_minus_leq_zero : MGA_solver.

Lemma two_eq_zero : forall A , (plus_pos One One) *S A === MRS_zero -> A === MRS_zero.
Proof with auto with MGA_solver.
  intros A eq.
  assert (A === -S A).
  - apply trans with ((-S A) +S MRS_zero)...
    apply trans with (MRS_zero -S A)...
    apply eq_minus_right...
    apply trans with ((plus_pos One One) *S A)...
  - apply abs_eq_zero.
    apply leq_antisym...
    apply leq_cong_l with (A /\S (-S A))...
    apply trans with (A \/S A)...
    apply trans with A...
    apply trans with (A /\S A)...
Qed.

Lemma inj_mul_two : forall A B, (plus_pos One One) *S A === (plus_pos One One) *S B -> A === B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (B +S MRS_zero)...
  apply trans with (MRS_zero +S B)...
  apply eq_plus_right.
  apply two_eq_zero...
  apply trans with (((plus_pos One One) *S A) +S ((plus_pos One One) *S (-S B)))...
  apply trans with (((plus_pos One One) *S A) -S ((plus_pos One One) *S B))...
Qed.

Lemma leq_div_2 : forall A B , (plus_pos One One) *S A <== (plus_pos One One) *S B -> A <== B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply inj_mul_two...
  apply trans with (((plus_pos One One) *S A) /\S ((plus_pos One One) *S B))...
Qed.

Lemma neg_subdistri_plus : forall A B, neg (A +S B) <== (neg A) +S (neg B).
Proof with auto with MGA_solver.
  intros A B.
  apply max_leq...
  - apply leq_cong_l with ((-S A) +S (-S B))...
  - apply leq_cong_l with (MRS_zero +S MRS_zero)...
Qed.

Hint Resolve neg_subdistri_plus : MGA_solver.

Lemma Rpos_mul_neg : forall t A, t *S neg A === neg (t *S A).
Proof with auto with MGA_solver.
  intros t A.
  etransitivity; [ apply mul_distri_max_pos | ].
  auto using mul_0.
Qed.

Hint Resolve Rpos_mul_neg : MGA_solver.

Lemma mul_leq : forall t A B, A <== B -> t *S A <== t *S B.
Proof.
  auto with MGA_solver.
Qed.

Hint Resolve mul_leq : MGA_solver.

Lemma mul_leq_inv : forall t A B, t *S A <== t *S B -> A <== B.
Proof with auto with MGA_solver.
  intros t A B Hle.
  apply leq_cong_r with (One *S B); try auto.
  apply leq_cong_l with (One *S A); try auto.
  replace One with (time_pos (inv_pos t) t).
  2:{ destruct t; apply Rpos_eq; simpl; clear Hle; apply R_blt_lt in e; rewrite Rinv_l; nra. }
  eapply leq_cong_r; [ symmetry; apply mul_assoc | ].
  eapply leq_cong_l; [ symmetry; apply mul_assoc | ]...
Qed.

Lemma neg_leq_cond : forall A B, A <== B -> neg B <== neg A.
Proof with try assumption.
  intros A B Hleq.
  apply max_leq.
  - apply leq_trans with (-S A).
    + apply minus_reverse_leq...
    + apply leq_max.
  - auto with MGA_solver.
Qed.

Lemma max_idempotence : forall A, A \/S A === A.
Proof.
  intros A.
  apply min_max.
  apply leq_refl.
Qed.

Lemma eq_subs_minus : forall A B n, subs (-S A) n B = -S (subs A n B).
Proof with try reflexivity.
  induction A ; intros B v'; try (simpl; constructor; assumption); try (simpl; rewrite IHA1; rewrite IHA2; auto with MGA_solver; fail)...
  - simpl; case (term.V_eq v' v)...
  - simpl; case (term.V_eq v' v)...
    rewrite minus_minus...
  - simpl; rewrite IHA...
  - simpl; rewrite IHA...
Qed.

Lemma diamond_zero : <S> MRS_zero === MRS_zero.
Proof.
  etransitivity; [ apply (@ctxt (MRS_diamondC MRS_hole)); symmetry; apply (opp_plus MRS_zero) | ].
  etransitivity; [ apply diamond_linear | ].
  apply opp_plus.
Qed.

Lemma leq_diamond : forall A, MRS_zero <== A -> MRS_zero <== (<S> A).
Proof.
  intros A Hleq.
  apply leq_cong_r with (<S> (A \/S MRS_zero)).
  2:{ apply diamond_pos. }
  apply diamond_cong.
  symmetry; etransitivity; [ apply commu_max | ]; apply min_max.
  apply Hleq.
Qed.

Lemma leq_pos_max_mul_l : forall A B r,
    MRS_zero <== (r *S A) \/S B ->
    MRS_zero <== A \/S B.
Proof.
  intros A B [r Hpos];
    remember (existT (fun r : R => (0 <? r)%R = true) r Hpos) as t; intros Hleq.
  apply cond_min_neg_eq_zero in Hleq.
  apply cond_zero_leq_max_2.
  apply leq_antisym.
  - case (Rlt_dec 1 r); intros Hlt; [ | case (Rlt_dec r 1); intros Hnlt].
    + eapply leq_cong_r; [ symmetry; apply Hleq | ].
      apply leq_min.
      * apply leq_trans with (neg A); [ apply min_leq | ].
        apply leq_cong_l with (MRS_zero +S neg A).
        { etransitivity; [ | apply commu_plus ].
         symmetry; apply neutral_plus. }
        apply leq_plus_left.
        change (1%R) with (projT1 One) in Hlt.
        replace r with (projT1 t) in Hlt by now rewrite Heqt.
        eapply leq_cong_r.
        { etransitivity.
          { apply (@ctxt (MRS_plusC MRS_hole (MRS_TC (-S neg A)))).
            symmetry; apply Rpos_mul_neg. }
          simpl evalContext.
          etransitivity.
          { change ((-S (-S A)) /\S MRS_zero) with (-S neg A).
            apply (@ctxt (MRS_plusC (MRS_TC (t *S neg A)) MRS_cohole)).
            etransitivity; [ symmetry; apply mul_1 | ].
            reflexivity. }
          simpl.
          change (One *S ((-S (-S A)) /\S MRS_zero)) with (-S (One *S neg A)).
          etransitivity; [apply (minus_ax _ _ _ Hlt) | ].
          reflexivity. }
        apply leq_cong_r with (minus_pos Hlt *S (pos (neg A))).
        { etransitivity.
          2:{ apply (@ctxt (MRS_mulC (minus_pos Hlt) MRS_hole)).
              symmetry; apply (commu_max (neg A)). }
          simpl.
          apply (@ctxt (MRS_mulC (minus_pos Hlt) MRS_hole)).
          symmetry.
          apply min_max.
          auto with MGA_solver. }
        apply compa_mul_ax.
      * eapply leq_cong_l; [apply commu_min | ].
        apply min_leq.
    + apply (@mul_leq_inv t).
      eapply leq_cong_l; [ apply mul_distri_min_pos | ].
      eapply leq_cong_r; [ apply mul_0 | ].
      eapply leq_cong_r; [ symmetry; apply Hleq | ].
      apply leq_cong_r with ((t *S neg A) /\S neg B); [auto with MGA_solver | ].
      apply leq_min; [apply min_leq | ].
      eapply leq_cong_l; [ apply commu_min | ].
      apply leq_trans with (t *S neg B) ; [ apply min_leq | ].
      eapply leq_cong_l; [ symmetry; apply neutral_plus | ].
      eapply leq_cong_l; [ apply commu_plus | ].
      apply leq_plus_left.
      apply leq_cong_r with ((One *S neg B) -S (t *S neg B)); [ auto | ].
      apply leq_cong_r with ((One *S neg B) +S (t *S (-S neg B))); [auto | ].
      change (1%R) with (projT1 One) in Hnlt.
      replace r with (projT1 t) in Hnlt by now rewrite Heqt.
      eapply leq_cong_r; [ apply (minus_ax _ _ _ Hnlt) | ].
      apply leq_cong_r with (minus_pos Hnlt *S (pos (neg B))).
      { transitivity (minus_pos Hnlt *S (MRS_zero \/S neg B)) ; [ | auto].
        apply (@ctxt (MRS_mulC (minus_pos Hnlt) MRS_hole)).
        symmetry.
        apply min_max; auto with MGA_solver. }
      apply compa_mul_ax.
    + assert (t = One) as Heq.
      { apply Rpos_eq; rewrite Heqt;simpl; nra. }
      eapply leq_cong_r; [ symmetry; apply Hleq | ].
      rewrite Heq.
      eapply leq_cong_r ; [ | apply leq_refl ].
      auto.
  - apply leq_min; (eapply leq_cong_r ; [ apply commu_max | ]); apply leq_max.
Qed.

Lemma leq_pos_max_mul_l_inv : forall A B r,
    MRS_zero <== A \/S B ->
    MRS_zero <== (r *S A) \/S B.
Proof.
  intros A B r Hleq.
  apply leq_pos_max_mul_l with (inv_pos r).
  apply leq_cong_r with ((time_pos (inv_pos r) r) *S A \/S B); [ auto | ].
  rewrite inv_pos_l.
  apply leq_cong_r with (A \/S B); [ auto | ].
  apply Hleq.
Qed.

Lemma plus_pos_min : forall A B C, MRS_zero <== A -> MRS_zero <== B -> MRS_zero <== C -> A +S B /\S C <== (A /\S C) +S (B /\S C).
Proof.
  intros A B C H1 H2 H3.
  apply leq_plus_right.
  apply leq_min.
  - apply leq_minus_left.
    eapply leq_cong_r; [ apply commu_plus | ].
    apply leq_plus_right.
    apply leq_min.
    + apply leq_minus_left.
      eapply leq_cong_r; [ apply commu_plus | ].
      apply min_leq.
    + apply leq_trans with (A +S B /\S C).
      * apply leq_minus_left.
        eapply leq_cong_l ; [ symmetry; apply neutral_plus | ].
        apply leq_plus_cong; try assumption.
        apply leq_refl.
      * eapply leq_cong_l; [ apply commu_min | ].
        apply min_leq.
  - apply leq_minus_left.
    eapply leq_cong_r; [apply commu_plus | ].
    apply leq_plus_right.
    apply leq_min.
    + apply leq_minus_left.
      eapply leq_cong_r; [ apply commu_plus | ].
      eapply leq_cong_l; [ symmetry; apply neutral_plus | ].
      apply leq_plus_cong; try assumption.
      eapply leq_cong_l; [ apply commu_min | ].
      apply min_leq.
    + apply leq_minus_left.
      eapply leq_cong_l ; [ symmetry; apply neutral_plus | ].
      apply leq_plus_cong; try assumption.
      eapply leq_cong_l; [ apply commu_min | ].
      apply min_leq.
Qed.


Require Import ClasspoolIface.
Require Import BasicMachineTypes.
Require Import ClassDatatypesIface.
Require Import List.
Require Import BoolExt.
Require Import OptionExt.
Require Import AssignabilityIface.

Require Import AnnotationIface.

(* TODO: remove *)
Set Asymmetric Patterns.

Module MkAssignability (B : BASICS)
                       (ANN : ANNOTATION B)
                       (C : CLASSDATATYPES B ANN)
                       (CP : CLASSPOOL B ANN C)
                     : ASSIGNABILITY B ANN C CP.

(* the assignability predicate *)

Inductive sub_class (classes:CP.cert_classpool) : B.Classname.t -> B.Classname.t -> Prop :=
| sub_class_refl : forall nm cwitness,
   CP.class_loaded classes nm cwitness ->
   sub_class classes nm nm
| sub_class_step : forall nm nm_t s_nm c,
   CP.class_loaded classes nm c ->
   C.class_super_class c = Some s_nm ->
   sub_class classes s_nm nm_t ->
   sub_class classes nm nm_t.

Inductive direct_super_interface (classes:CP.cert_classpool) : list B.Classname.t -> B.Classname.t -> Prop :=
| d_inter_here : forall nmT interfaces,
   direct_super_interface classes (nmT::interfaces) nmT
| d_inter_step_up : forall interfaces nmX cX nmT,
   CP.class_loaded classes nmX cX ->
   C.class_interface cX = true ->
   direct_super_interface classes (C.class_interfaces cX) nmT ->
   direct_super_interface classes (nmX::interfaces) nmT
| d_inter_step_along : forall interfaces nmT nmX,
   direct_super_interface classes interfaces nmT ->
   direct_super_interface classes (nmX::interfaces) nmT.

Definition class_implements classes nmS nmT :=
 exists nmS', exists cS',
   CP.class_loaded classes nmS' cS' /\
   C.class_interface cS' = false /\
   sub_class classes nmS nmS' /\
   direct_super_interface classes (C.class_interfaces cS') nmT.

Lemma cl_impls_direct : forall classes nmS cS nmT,
  CP.class_loaded classes nmS cS ->
  C.class_interface cS = false ->
  direct_super_interface classes (C.class_interfaces cS) nmT ->
  class_implements classes nmS nmT.
unfold class_implements. intuition eauto 8 using sub_class_refl.
Qed.

Lemma cl_impls_super: forall classes nmS cS nm_superS nmT,
  CP.class_loaded classes nmS cS ->
  C.class_super_class cS = Some nm_superS ->
  class_implements classes nm_superS nmT ->
  class_implements classes nmS nmT.
intros classes nmS cS nm_superS nmT loaded_nmS_cS cS_super super_impl_T.
destruct super_impl_T as [nmS' [cS' [S'_loaded [S'_not_interface [S_S' S'_T]]]]].
unfold class_implements. intuition eauto 9 using sub_class_step.
Qed.

(* This is from the specification on page 278 of the JVM spec (except for arrays, for now) *)
Inductive assignable' (classes:CP.cert_classpool) : C.java_ref_type -> C.java_ref_type -> Prop :=
| assign_class_class : forall nmS nmT cS cT,
   CP.class_loaded classes nmS cS ->
   CP.class_loaded classes nmT cT ->
   C.class_interface cS = false ->
   C.class_interface cT = false ->
   sub_class classes nmS nmT ->
   assignable' classes (C.ty_obj nmS) (C.ty_obj nmT)
| assign_class_interface : forall nmS nmT cS cT nmS' cS',
   CP.class_loaded  classes nmS cS ->
   CP.class_loaded  classes nmT cT ->
   CP.class_loaded  classes nmS' cS' ->
   C.class_interface cS = false ->
   C.class_interface cS' = false ->
   C.class_interface cT = true ->
   sub_class classes nmS nmS' ->
   direct_super_interface classes (C.class_interfaces cS') nmT ->
   assignable' classes (C.ty_obj nmS) (C.ty_obj nmT)
| assign_interface_class : forall nmS cS,
   CP.class_loaded  classes nmS cS ->
   C.class_interface cS = true ->
   assignable' classes (C.ty_obj nmS) (C.ty_obj B.java_lang_Object)
| assign_interface_interface_refl : forall nmS cS,
   CP.class_loaded  classes nmS cS ->
   C.class_interface cS = true ->
   assignable' classes (C.ty_obj nmS) (C.ty_obj nmS)
| assign_interface_interface_strict : forall nmS nmT cS cT,
   CP.class_loaded  classes nmS cS ->
   CP.class_loaded  classes nmT cT ->
   C.class_interface cS = true ->
   C.class_interface cT = true ->
   direct_super_interface classes (C.class_interfaces cS) nmT ->
   assignable' classes (C.ty_obj nmS) (C.ty_obj nmT).
Definition assignable := assignable'.

Definition assignable_class_class := assign_class_class.
Definition assignable_class_interface := assign_class_interface.
Definition assignable_interface_class := assign_interface_class.
Definition assignable_interface_interface_refl := assign_interface_interface_refl.
Definition assignable_interface_interface_strict := assign_interface_interface_strict.

Lemma sub_class_trans : forall classes a b c,
  sub_class classes a b ->
  sub_class classes b c ->
  sub_class classes a c.
intros classes a b c. induction 1; eauto using sub_class_step.
Qed.

Lemma sub_class_linearish : forall classes A B C,
  sub_class classes A B ->
  sub_class classes A C ->
  sub_class classes B C \/ sub_class classes C B.
intros classes A B C A_sub_B A_sub_C.
induction A_sub_B as [A|A B A' cA A_exists A_sc_A' A'_sub_B].
 (* A = B *)
 left. assumption.
 (* A < B *)
 destruct A_sub_C as [C|A C A'' cA' A_exists' A_sc_A'' A''_sub_C].
  (* A = C *)
  right. clear H. eapply sub_class_step; eauto.
  (* A < C *)
  rewrite (CP.class_loaded_unique A_exists A_exists') in *.
  rewrite A_sc_A' in A_sc_A''. inversion A_sc_A''. subst.
  auto.
Qed.

Ltac clu_congruence :=
  match goal with
  | [H1 : CP.class_loaded _ _ _, H2 : CP.class_loaded _ _ _ |- _ ] => rewrite (CP.class_loaded_unique H1 H2) in *; clear H1 H2; first [ congruence | clu_congruence ]
  end.

Lemma get_sub_class : forall classes A B cA cB,
  CP.class_loaded  classes A cA ->
  CP.class_loaded  classes B cB ->
  C.class_interface cA = false ->
  C.class_interface cB = false ->
  assignable classes (C.ty_obj A) (C.ty_obj B) ->
  sub_class classes A B.
intros classes A B cA cB A_exists B_exists A_class B_class A_sub_B.
inversion A_sub_B; subst; clu_congruence.
Qed.

Lemma get_class_implements : forall classes A B cA cB,
  CP.class_loaded  classes A cA ->
  CP.class_loaded  classes B cB ->
  C.class_interface cA = false ->
  C.class_interface cB = true ->
  assignable classes (C.ty_obj A) (C.ty_obj B) ->
  exists A', exists cA', CP.class_loaded  classes A' cA'
                         /\ C.class_interface cA' = false
                         /\ sub_class classes A A'
                         /\ direct_super_interface classes (C.class_interfaces cA') B.
intros classes A B cA cB A_exists B_exists A_class B_interface A_sub_B.
inversion A_sub_B; subst; try clu_congruence. intuition eauto 6.
Qed.

Lemma assignable_shared_subclass : forall classes A B C cA cB cC,
  CP.class_loaded classes A cA ->
  CP.class_loaded classes B cB ->
  CP.class_loaded classes C cC ->
  C.class_interface cA = false ->
  C.class_interface cB = false ->
  C.class_interface cC = false ->
  assignable classes (C.ty_obj A) (C.ty_obj B) ->
  assignable classes (C.ty_obj A) (C.ty_obj C) ->
  assignable classes (C.ty_obj B) (C.ty_obj C) \/ assignable classes (C.ty_obj C) (C.ty_obj B).
intros classes A B C cA cB cC.
intros A_exists B_exists C_exists A_class B_class C_class.
intros A_sub_B. intros A_sub_C.
destruct (sub_class_linearish classes A B C).
 eapply get_sub_class; eassumption.
 eapply get_sub_class; eassumption.
 left. eapply assign_class_class; eassumption.
 right. eapply assign_class_class; eassumption.
Qed.

Lemma assignable_class_interface2 : forall classes nmS nmT cS cT,
  CP.class_loaded classes nmS cS ->
  CP.class_loaded classes nmT cT ->
  C.class_interface cS = false ->
  C.class_interface cT = true ->
  class_implements classes nmS nmT ->
  assignable classes (C.ty_obj nmS) (C.ty_obj nmT).
intros. destruct H3 as [nmS' [cS' [S'_loaded [S'_not_interface [S_S' S'_T]]]]].
eapply assign_class_interface; eassumption.
Qed.

Lemma assignable_shared_subclass_2 : forall classes A B C cA cB cC,
  CP.class_loaded classes A cA ->
  CP.class_loaded classes B cB ->
  CP.class_loaded classes C cC ->
  C.class_interface cA = false ->
  C.class_interface cB = false ->
  C.class_interface cC = true ->
  assignable classes (C.ty_obj A) (C.ty_obj B) ->
  assignable classes (C.ty_obj A) (C.ty_obj C) ->
     assignable classes (C.ty_obj B) (C.ty_obj C)
  \/ (exists B', exists cB', CP.class_loaded classes B' cB'
                             /\ C.class_interface cB' = false
                             /\ assignable classes (C.ty_obj B') (C.ty_obj B)
                             /\ assignable classes (C.ty_obj A) (C.ty_obj B')
                             /\ assignable classes (C.ty_obj B') (C.ty_obj C)).
intros classes A B C cA cB cC.
intros A_exists B_exists C_exists A_class B_class C_interface.
intros A_sub_B A_sub_C.
assert (A_subc_B:sub_class classes A B);[eapply get_sub_class; eassumption|].
destruct (get_class_implements classes A C cA cC) as [A' [cA' [A'_exists [A'_class [A_sub_A' dsi]]]]]; try assumption.
destruct (sub_class_linearish classes A B A' A_subc_B A_sub_A') as [B_sub_A' | A'_sub_B].
 (* B <: A' *)
 left. eapply assign_class_interface; eauto.
 (* A' <: B *)
 right. exists A'. exists cA'. intuition.
  eapply assign_class_class; eassumption.
  eapply assign_class_class; eassumption.
  eapply assign_class_interface; try eassumption. eapply sub_class_refl. apply A'_exists.
Qed.

Lemma sub_class_Object_top : forall classes nm c,
  CP.class_loaded  classes nm c ->
  C.class_interface c = false ->
  sub_class classes nm B.java_lang_Object.
intros classes nm c nm_c c_class.
assert (scc:CP.super_class_chain classes (C.class_super_class c)) by eauto using CP.cert_classpool_gives_scc.
set (sc:=C.class_super_class c) in *.
set (e:=refl_equal sc : C.class_super_class c = sc). generalize sc scc nm c nm_c c_class e. clear sc scc nm c nm_c c_class e. intros sc scc.
elim scc using CP.super_class_chain_induction; clear scc; intros.
 (* top case: if a class is loaded and has no super class, then it is Object *)
 rewrite (CP.no_super_is_jlObject _ _ _ nm_c e). destruct (CP.cert_classpool_has_Object classes) as [objc [objloaded _]].  eapply sub_class_refl. apply objloaded.
 (* step case *)
 eauto using sub_class_step.
Qed.
(* FIXME: should we prohibit sub_class from ever relating interfaces? *)

Lemma assignable_Object : forall classes a c,
  CP.class_loaded  classes a c ->
  assignable classes (C.ty_obj a) (C.ty_obj B.java_lang_Object).
intros. destruct (bool_dec (C.class_interface c)).
 (* it is an interface *)
 eapply assign_interface_class; eauto.
 (* it is a class *)
 destruct (CP.cert_classpool_has_Object classes) as [object [object_exists [_ [_ object_class]]]].
 eapply assign_class_class; eauto. eapply sub_class_Object_top; eassumption.
Qed.

Lemma sub_class_Object_only : forall classes a,
  sub_class classes B.java_lang_Object a -> a = B.java_lang_Object.
intros. inversion H.
 reflexivity.
 destruct (CP.cert_classpool_has_Object classes) as [object [object_exists [no_super _]]].
  rewrite (CP.class_loaded_unique object_exists H0) in *. rewrite H1 in no_super. discriminate.
Qed.

Lemma no_interfaces_no_direct_super_interface : forall classes a,
 ~(direct_super_interface classes nil a).
unfold not. intros. inversion H.
Qed.

Lemma assignable_Object_only : forall classes a,
  assignable classes (C.ty_obj B.java_lang_Object) a -> a = C.ty_obj B.java_lang_Object.
intros.
destruct (CP.cert_classpool_has_Object classes) as [object [object_exists [no_super [no_interfaces is_class]]]].
inversion H; try congruence.
 eapply (f_equal C.ty_obj). eapply sub_class_Object_only. apply H5.
 assert (nmS' = B.java_lang_Object) by (eapply sub_class_Object_only; eassumption).
  subst.
  rewrite (CP.class_loaded_unique object_exists H3) in *.
  rewrite no_interfaces in H8. elimtype False. apply (no_interfaces_no_direct_super_interface _ _ H8).
 clu_congruence.
Qed.

Lemma direct_super_interface_trans : forall classes a b c cB,
  direct_super_interface classes a b ->
  CP.class_loaded  classes b cB ->
  C.class_interface cB = true ->
  direct_super_interface classes (C.class_interfaces cB) c ->
  direct_super_interface classes a c.
intros. induction H; eauto using d_inter_step_up, d_inter_step_along.
Qed.

Lemma assignable_refl : forall classes nmA cA,
  CP.class_loaded  classes nmA cA ->
  assignable classes (C.ty_obj nmA) (C.ty_obj nmA).
intros classes nmA cA cA_exists.
destruct (bool_dec (C.class_interface cA)) as [A_interface | A_class].
 (* A is an interface *)
 eapply assign_interface_interface_refl; eauto.
 (* A is a class *)
 eapply assign_class_class; eauto. eapply sub_class_refl. eauto.
Qed.

Lemma assignable_trans : forall classes a b c,
  assignable classes a b ->
  assignable classes b c ->
  assignable classes a c.
intros. induction H.
 (* assign_class_class a b *)
 set (b:=C.ty_obj nmT) in H0. set (e:=refl_equal b : b = C.ty_obj nmT).
 generalize b e H0. clear b e H0. intros.
 induction H0; inversion e; subst; try clu_congruence.
  (* assign_class_class b c *)
  eapply assign_class_class; eauto. eapply sub_class_trans; eauto.
  (* assign_class_interface b c *)
  eapply assign_class_interface.
   apply H.
   apply H5.
   apply H6.
   apply H2.
   apply H8.
   apply H9.
   eapply sub_class_trans; eauto.
   apply H11.
 (* assign_class_interface a b *)
 set (b:=C.ty_obj nmT) in H0. set (e:=refl_equal b : b = C.ty_obj nmT).
 generalize b e H0. clear b e H0. intros.
 induction H0; inversion e; subst; try clu_congruence.
  (* assign_interface_class b c *)
  eapply assignable_Object. apply H.
  (* assign_interface_interface_refl b c *)
  eapply assign_class_interface.
   apply H. apply H0. apply H2. assumption. assumption. assumption. assumption. assumption.
  (* assign_interface_interface_strict b c *)
  eapply assign_class_interface.
   apply H. apply H8. apply H2. assumption. assumption. assumption. assumption.
   eapply direct_super_interface_trans; eassumption.
 (* assign_interface_object *)
 rewrite (assignable_Object_only _ _ H0). eapply assignable_Object. apply H.
 (* assign_interface_interface_refl *)
 assumption.
 (* assign_interface_interface_strict *)
 set (b:=C.ty_obj nmT) in H0. set (e:=refl_equal b : b = C.ty_obj nmT).
 generalize b e H0. clear b e H0. intros.
 induction H0; inversion e; subst; try clu_congruence.
  (* assign_interface_class *)
  eapply assignable_Object. apply H.
  (* assign_interface_interface_refl *)
  eapply assign_interface_interface_strict; eauto.
  (* assign_interface_interface_strict *)
  rewrite (CP.class_loaded_unique H1 H0) in *. eapply assign_interface_interface_strict; eauto.
  eapply direct_super_interface_trans; eauto.
Qed.

(* Checking of assignability *)

Fixpoint check_subclass_aux (classes:CP.cert_classpool)
                            (next_name:option B.Classname.t)
                            (nm:B.Classname.t)
                            (scc:CP.super_class_chain classes next_name)
                            {struct scc}
                          : bool
 :=
 match option_informative next_name with
 | inleft (exist super_nm super_nm_eq) =>
    match B.Classname.eq_dec super_nm nm with
    | left _ => true
    | right _ =>
       let not_not_there := CP.super_class_chain_not_not_there super_nm_eq scc in
       match CP.class_loaded_dec classes super_nm with
       | inleft (exist super_c super_c_exists) =>
          check_subclass_aux classes (C.class_super_class super_c) nm (CP.super_class_chain_inv super_c_exists super_nm_eq scc)
       | inright not_there =>
          match not_not_there not_there with end
       end
    end
 | inright _ =>
    false
 end.

Definition check_subclass : forall classes c,
  CP.class_loaded  classes (C.class_name c) c ->
  B.Classname.t ->
  bool
 := fun classes c c_exists nm_t =>
 match B.Classname.eq_dec (C.class_name c) nm_t with
 | left _ => true
 | right _ =>
    match bool_informative (C.class_interface c) with
    | left is_interface =>
       if B.Classname.eq_dec nm_t B.java_lang_Object then true else false
    | right is_class =>
       let scc := CP.cert_classpool_gives_scc c_exists is_class in
       check_subclass_aux classes (C.class_super_class c) nm_t scc
    end
 end.
Implicit Arguments check_subclass [classes c].

Lemma check_subclass_aux_sound : forall classes nm_s nm_t scc,
  check_subclass_aux classes nm_s nm_t scc = true ->
  match nm_s with
  | None => False
  | Some nm_s => sub_class classes nm_s nm_t
  end.
intros classes c nm scc. elim scc using CP.super_class_chain_induction; intros; simpl in *.

discriminate.

destruct (B.Classname.eq_dec nm0 nm).
 (* names are equal *)
 subst. eapply sub_class_refl. eauto.
 (* names not equal *)
 destruct (CP.class_loaded_dec classes nm0) as [[c' c'_loaded] | no_c'].
  (* the class was found *)
  pose (H _ _ H0).
  generalize y. clear y H0. intro H2.
  destruct (option_dec (C.class_super_class c')) as [[x0 update_res]|update_res]; rewrite update_res in H2.
   apply (sub_class_step classes nm0 nm x0 c'); assumption.
   contradiction.
  (* class not found *)
  elimtype False. apply no_c'. eauto.
Qed.

Lemma check_subclass_aux_complete : forall classes nm_s nm_t scc,
  sub_class classes nm_s nm_t ->
  check_subclass_aux classes (Some nm_s) nm_t scc = true.
intros.
induction H.
 destruct (CP.scc_Some _ _ scc) as [c [c_exists [c_class [s e]]]]. rewrite e.
 simpl. destruct (B.Classname.eq_dec nm nm).
  reflexivity.
  elimtype False. apply n. reflexivity.
 destruct (CP.scc_Some _ _ scc) as [c' [c'_exists [c'_class [s e]]]]. rewrite e.
 simpl. destruct (B.Classname.eq_dec nm nm_t).
  reflexivity.
  destruct (CP.class_loaded_dec classes nm) as [[super_c super_c_exists] | no_super_c].
   assert (c = super_c) by eauto using CP.class_loaded_unique. subst.
   set (scc':=(s super_c (eq_ind_r (fun nm => CP.class_loaded  classes nm super_c) super_c_exists (refl_equal nm)))).
   generalize scc'. clear scc' s H super_c_exists H1. rewrite H0. apply IHsub_class.
   elimtype False. apply no_super_c. exists c. assumption.
Qed.

Lemma check_subclass_sound : forall classes c nm_t c_exists,
  check_subclass (classes:=classes) (c:=c) c_exists nm_t = true -> sub_class classes (C.class_name c) nm_t.
intros. unfold check_subclass in H.
destruct (B.Classname.eq_dec (C.class_name c) nm_t).
 (* names are equal *)
 subst. eapply sub_class_refl. apply c_exists.
 (* names not equal *)
 destruct (bool_informative (C.class_interface c)).
  (* is an interface: case not fully handled yet *)
  destruct (B.Classname.eq_dec nm_t B.java_lang_Object).
   subst.
   destruct (CP.cert_classpool_has_Object classes).
   eapply sub_class_step.
    apply c_exists.
    apply (CP.cert_classpool_gives_interface_super_class_Object c_exists e).
    destruct H0. eapply sub_class_refl. apply H0.
   discriminate.
  (* is a class *)
  pose (check_subclass_aux_sound _ _ _ _ H).
  generalize y. clear y H. intro H. destruct (option_dec (C.class_super_class c)) as [[x update_res]|update_res]; rewrite update_res in H.
   eapply sub_class_step; eauto.
   contradiction.
Qed.

Lemma check_subclass_complete : forall classes c c_exists nm_t,
  sub_class classes (C.class_name c) nm_t -> check_subclass (classes:=classes) (c:=c) c_exists nm_t = true.
intros. unfold check_subclass.
destruct (B.Classname.eq_dec (C.class_name c) nm_t).
 reflexivity.
 inversion H.
  (* reflexivity *)
  contradiction.
  (* step *)
  destruct (bool_informative (C.class_interface c)).
   (* is an interface *)
   rewrite (CP.class_loaded_unique H0 c_exists) in *.
   rewrite (CP.cert_classpool_gives_interface_super_class_Object c_exists e) in H1.
   inversion H1. rewrite <- H4 in H2. inversion H2.
    (* refl *)
    subst. subst. destruct (B.Classname.eq_dec B.java_lang_Object B.java_lang_Object).
     reflexivity.
     elimtype False. apply n0. reflexivity.
    (* step *)
    destruct (CP.cert_classpool_has_Object classes) as [object [object_exists [no_super _]]].
    subst. clu_congruence.
   (* not an interface *)
   set (scc':=CP.cert_classpool_gives_scc c_exists e).
   generalize scc'. clear scc'.
   rewrite (CP.class_loaded_unique c_exists H0) in *. rewrite H1.
   intro. apply check_subclass_aux_complete. assumption.
Qed.

Fixpoint check_direct_super_interface (classes:CP.cert_classpool)
                                      (interface_list:list B.Classname.t)
                                      (nm:B.Classname.t)
                                      (gil:CP.good_interface_list2 classes interface_list)
                                      {struct gil}
                                    : bool
 :=
 match interface_list as il return (interface_list = il -> bool) with
 | nil => fun e : interface_list = nil =>
    false
 | i_nm::rest => fun e : interface_list = i_nm::rest =>
    match B.Classname.eq_dec i_nm nm with
    | left _ => true
    | right _ =>
       let gil_rest      := CP.good_interface_list2_inv_2 gil e in
       let not_not_there := CP.good_interface_list2_not_not_there gil e in
        match CP.class_loaded_dec classes i_nm with
        | inleft (exist i i_exists) =>
           let g_supers := CP.good_interface_list2_inv_1 gil e i_exists in
            if check_direct_super_interface classes (C.class_interfaces i) nm g_supers then
              true
            else
              check_direct_super_interface classes rest nm gil_rest
        | inright not_there =>
           match not_not_there not_there with end
        end
    end
 end (refl_equal interface_list).

Lemma check_direct_super_interface_sound : forall classes i_list nmT gil,
  check_direct_super_interface classes i_list nmT gil = true ->
  direct_super_interface classes i_list nmT.
intros classes i_list nmT gil.
elim gil using CP.good_interface_list2_induction; intros; simpl in *.
 (* empty list *)
 discriminate.
 (* otherwise... *)
 destruct (B.Classname.eq_dec i_nm nmT).
  (* found it! *)
  subst. apply d_inter_here.
  (* otherise, plodding on... *)
  destruct (CP.class_loaded_dec classes0 i_nm) as [[c' c'_exists] | no_c'].
   (* found the interface *)
   match goal with H:match ?x with true => true | false => _ end = true |- _ => destruct (bool_dec x) end.
    assert (C.class_interface c' = true). clear H1 H2. rewrite (CP.class_loaded_unique c'_exists c). assumption.
    eapply d_inter_step_up; eauto.
    rewrite H2 in H1. eapply d_inter_step_along; eauto.
   (* interface not found: unpossible! *)
   elimtype False. apply no_c'. eauto.
Qed.

Lemma check_direct_super_interface_complete : forall classes i_list nmT gil,
  direct_super_interface classes i_list nmT ->
  check_direct_super_interface classes i_list nmT gil = true.
intros. induction H.
 (* refl case *)
 destruct (CP.gil2_inv_cons gil) as [i [i_exists [i_interface [go_up [go_along eq]]]]].
 rewrite eq. simpl. destruct (B.Classname.eq_dec nmT nmT).
  reflexivity.
  elimtype False. apply n. reflexivity.
 (* up case *)
 destruct (CP.gil2_inv_cons gil) as [i [i_exists [i_interface [go_up [go_along eq]]]]]. rewrite eq.
 simpl. destruct (B.Classname.eq_dec nmX nmT).
  (* names equal *)
  reflexivity.
  (* names unequal *)
  destruct (CP.class_loaded_dec classes nmX) as [[c c_exists] | no_c].
   (* class found *)
   rewrite (CP.class_loaded_unique H c_exists) in IHdirect_super_interface. rewrite IHdirect_super_interface. reflexivity.
   (* class not found *)
   elimtype False. apply no_c. eauto.
 (* along case *)
 destruct (CP.gil2_inv_cons gil) as [i [i_exists [i_interface [go_up [go_along eq]]]]]. rewrite eq.
 simpl. destruct (B.Classname.eq_dec nmX nmT).
  (* names equal *)
  reflexivity.
  (* names unequal *)
  destruct (CP.class_loaded_dec classes nmX) as [[c c_exists] | no_c].
   (* class found *)
   match goal with |- match ?x with true => true | false => _ end = true => destruct x end.
    reflexivity.
    auto.
   (* class not found *)
   elimtype False. apply no_c. eauto.
Qed.

Fixpoint check_class_implements_aux (classes:CP.cert_classpool)
                                    (next_name:option B.Classname.t)
                                    (nmT:B.Classname.t)
                                    (scc:CP.super_class_chain classes next_name)
                                    {struct scc}
                                  : bool
 :=
 match option_informative next_name with
 | inleft (exist super_nm super_nm_eq) =>
    let not_not_there := CP.super_class_chain_not_not_there super_nm_eq scc in
    match CP.class_loaded_dec classes super_nm with
    | inleft (exist super_c super_c_exists) =>
       let gil := CP.cert_classpool_gives_gil2 super_c_exists in
         if check_direct_super_interface classes (C.class_interfaces super_c) nmT gil then
           true
         else
           check_class_implements_aux classes (C.class_super_class super_c) nmT (CP.super_class_chain_inv super_c_exists super_nm_eq scc)
    | inright not_there =>
       match not_not_there not_there with end
    end
 | inright _ =>
    false
 end.

Definition check_class_implements : forall classes c,
  CP.class_loaded  classes (C.class_name c) c ->
  C.class_interface c = false ->
  B.Classname.t ->
  bool
 := fun classes c c_exists is_class nmT =>
 let gil := CP.cert_classpool_gives_gil2 c_exists in
  if check_direct_super_interface classes (C.class_interfaces c) nmT gil then
    true
  else
    let scc := CP.cert_classpool_gives_scc c_exists is_class in
    check_class_implements_aux classes (C.class_super_class c) nmT scc.

Lemma check_class_implements_aux_sound : forall classes opt_nmS nmT scc,
  check_class_implements_aux classes opt_nmS nmT scc = true ->
  match opt_nmS with
  | None => False
  | Some nmS => exists nmS', exists cS',
                  CP.class_loaded  classes nmS' cS' /\
                  C.class_interface cS' = false /\
                  sub_class classes nmS nmS' /\
                  direct_super_interface classes (C.class_interfaces cS') nmT
  end.
intros classes opt_nmS nmT scc. elim scc using CP.super_class_chain_induction; intros; simpl in *.
 (* no super class *)
 discriminate.
 (* some super class *)
 destruct (CP.class_loaded_dec classes nm) as [[cl cl_exists] | no_cl].
  (* class exists *)
  match goal with _:match ?x with true => true | false => _ end = true |- _ => destruct (bool_dec x) end.
   (* this class implements the interface *)
   rewrite (CP.class_loaded_unique e cl_exists) in *.
   exists nm. exists cl. intuition.
    eapply sub_class_refl. eauto.
    eapply check_direct_super_interface_sound. eassumption.
   (* this class doesn't directly implement the interface *)
   rewrite H1 in H0.
   pose (H _ _ H0). generalize y. clear y H0. intro.
   destruct (option_dec (C.class_super_class cl)) as [[nm' nm'_eq] | no_nm'].
    rewrite nm'_eq in y. destruct y as [nmS' [cS' [nmS'_cS' [cS'_not_interface [nm'_sub_nmS' dsi]]]]].
    exists nmS'. exists cS'. intuition. eapply sub_class_step; eassumption.
    rewrite no_nm' in y. contradiction.
  (* class does not exist *)
  elimtype False. apply no_cl. eauto.
Qed.

Lemma check_class_implements_aux_complete : forall classes nmS nmT scc,
  (exists nmS', exists cS',
    CP.class_loaded  classes nmS' cS' /\
    C.class_interface cS' = false /\
    sub_class classes nmS nmS' /\
    direct_super_interface classes (C.class_interfaces cS') nmT) ->
  check_class_implements_aux classes (Some nmS) nmT scc = true.
intros classes nmS nmT scc [nmS' [cS' [S'_loaded [S'_not_interface [S_sub_S' S'_sub_T]]]]].
induction S_sub_S'.
 (* direct implementation *)
 destruct (CP.scc_Some _ _ scc) as [c [c_exists [s [s2 eq]]]]. rewrite eq.
 simpl. destruct (CP.class_loaded_dec classes nm) as [[super_c super_c_exists] | no_super].
  (* class exists *)
  rewrite (CP.class_loaded_unique S'_loaded super_c_exists) in *.
  rewrite (check_direct_super_interface_complete _ _ _ (CP.cert_classpool_gives_gil2 super_c_exists) S'_sub_T).
  reflexivity.
  (* no class: unpossible! *)
  elimtype False. apply no_super. eauto.
 (* super has an implementation *)
 destruct (CP.scc_Some _ _ scc) as [c' [c'_exists [s [s2 eq]]]]. rewrite eq.
 simpl. destruct (CP.class_loaded_dec classes nm) as [[super_c super_c_exists] | no_super].
  (* class exists *)
  match goal with |- match ?x with true => true | false => _ end = true => destruct x end.
   (* this class actually directly implemented it *)
   reflexivity.
   (* need to step on *)
   rewrite (CP.class_loaded_unique H super_c_exists) in *.
   match goal with |- (check_class_implements_aux _ _ _ ?x) = true => set (scc':=x) end.
   generalize scc'. clear scc'. rewrite H0. intro. apply IHS_sub_S'. apply S'_loaded.
  (* no class: unpossible, again *)
  elimtype False. apply no_super. eauto.
Qed.

Lemma check_class_implements_sound : forall classes c c_exists c_class nmT,
  check_class_implements classes c c_exists c_class nmT = true ->
  exists nmS', exists cS',
    CP.class_loaded  classes nmS' cS' /\
    C.class_interface cS' = false /\
    sub_class classes (C.class_name c) nmS' /\
    direct_super_interface classes (C.class_interfaces cS') nmT.
intros. unfold check_class_implements in H.
match goal with _:match ?x with true => _ | false => _ end = true |- _ => destruct (bool_dec x) end.
 rewrite H0 in H. exists (C.class_name c). exists c. intuition.
  eapply sub_class_refl. eauto.
  eapply check_direct_super_interface_sound. apply H0.
 rewrite H0 in H.
 set (B:=check_class_implements_aux_sound _ _ _ _ H).
 destruct (option_dec (C.class_super_class c)) as [[nm' nm'_eq] | no_nm'].
  rewrite nm'_eq in B. destruct B as [nmS' [cS' [S'_loaded [S'_not_interface [nm'_S' S'_T]]]]].
   exists nmS'. exists cS'. intuition. eapply sub_class_step; eassumption.
  rewrite no_nm' in B. contradiction.
Qed.

Lemma check_class_implements_complete : forall classes c c_exists c_class nmT,
  (exists nmS', exists cS',
    CP.class_loaded  classes nmS' cS' /\
    C.class_interface cS' = false /\
    sub_class classes (C.class_name c) nmS' /\
    direct_super_interface classes (C.class_interfaces cS') nmT) ->
  check_class_implements classes c c_exists c_class nmT = true.
intros. unfold check_class_implements. destruct H as [nmS' [cS' [S'_loaded [S'_not_interface [c_S' S'_T]]]]].
inversion c_S'; subst.
 (* direct implementation *)
 rewrite (CP.class_loaded_unique S'_loaded c_exists) in S'_T.
 rewrite (check_direct_super_interface_complete _ _ _ (CP.cert_classpool_gives_gil2 c_exists) S'_T).
 reflexivity.
 (* super implementation *)
 match goal with |- match ?x with true => _ | false => _ end = true => destruct x end.
  (* there was actually a direct implementation *)
  reflexivity.
  (* continue up the hierarchy *)
  set (scc:=CP.cert_classpool_gives_scc c_exists c_class).
  generalize scc. clear scc. rewrite (CP.class_loaded_unique H c_exists) in *.
  rewrite H0.
  intro. apply check_class_implements_aux_complete.
  intuition eauto 6.
Qed.

Definition check_assignable : CP.cert_classpool -> C.java_ref_type -> C.java_ref_type -> bool :=
  fun classes S T =>
  match S with
  | C.ty_obj nmS =>
     match T with
     | C.ty_obj nmT =>
        match CP.class_loaded_dec classes nmS with
        | inleft (exist cS cS_exists) =>
           match CP.class_loaded_dec classes nmT with
           | inleft (exist cT cT_exists) =>
              match bool_informative (C.class_interface cS) with
              | left S_is_interface =>
                 match bool_informative (C.class_interface cT) with
                 | left T_is_interface =>
                    match B.Classname.eq_dec nmS nmT with
                    | left _ =>
                       true
                    | right _ =>
                       let gil := CP.cert_classpool_gives_gil2 cS_exists in
                        check_direct_super_interface classes (C.class_interfaces cS) nmT gil
                    end
                 | right _ =>
                    match B.Classname.eq_dec nmT B.java_lang_Object with
                    | left _ => true
                    | right _ => false
                    end
                 end
              | right S_is_class =>
                 let cS_exists := CP.cert_classpool_names cS_exists in
                 match bool_informative (C.class_interface cT) with
                 | left T_is_interface =>
                    check_class_implements classes cS cS_exists S_is_class nmT
                 | right T_is_class =>
                    check_subclass cS_exists nmT
                 end
              end
           | inright _ =>
              false
           end
        | inright _ =>
           false
        end
     | C.ty_arr _ =>
        false
     end
  | C.ty_arr _ =>
     false
  end.

Lemma check_assignable_sound : forall classes S T,
  check_assignable classes S T = true ->
  assignable classes S T.
unfold check_assignable. intros.
destruct S as [nmS|]; try discriminate.
destruct T as [nmT|]; try discriminate.
destruct (CP.class_loaded_dec classes nmS) as [[cS cS_exists] | no_cS].
 (* S exists *)
 destruct (CP.class_loaded_dec classes nmT) as [[cT cT_exists] | no_cT].
  (* T exists *)
  destruct (bool_informative (C.class_interface cS)) as [S_is_interface | S_is_class].
   (* S is an interface *)
   destruct (bool_informative (C.class_interface cT)) as [T_is_interface | T_is_class].
    (* T is an interface *)
    destruct (B.Classname.eq_dec nmS nmT) as [S_eq_T | S_neq_T].
     (* they are equal *)
     subst. eapply assign_interface_interface_refl; eauto.
     (* not equal *)
     eapply assign_interface_interface_strict; eauto.
     eapply check_direct_super_interface_sound. apply H.
    (* T is a class *)
    destruct (B.Classname.eq_dec nmT B.java_lang_Object) as [T_is_Object | T_notObject].
     (* T is j.l.Object *)
     subst. eapply assign_interface_class; eauto.
     (* T not Object *)
     discriminate.
   (* S is a class *)
   destruct (bool_informative (C.class_interface cT)) as [T_is_interface | T_is_class].
    (* T is an interface *)
    destruct (check_class_implements_sound _ _ _ _ _ H) as [nmS' [cS' [S'_loaded [S'_not_interface [S_S' S'_T]]]]].
    eapply assign_class_interface; eauto.
    rewrite <- (CP.cert_classpool_names_2 cS_exists). assumption.
    (* T is a class *)
    eapply assign_class_class; eauto.
    rewrite <- (CP.cert_classpool_names_2 cS_exists).
    eapply check_subclass_sound. apply H.
  (* T doesn't exist *)
  discriminate.
 (* S doesn't exist *)
 discriminate.
Qed.

Lemma check_assignable_complete : forall classes S T,
  assignable classes S T ->
  check_assignable classes S T = true.
intros. unfold check_assignable.
destruct H.
 (* assign_class_class *)
 destruct (CP.class_loaded_dec classes nmS) as [[cS0 cS_exists] | no_cS].
  (* S exists *)
  rewrite (CP.class_loaded_unique H cS_exists) in * |- *.
  destruct (CP.class_loaded_dec classes nmT) as [[cT0 cT_exists] | no_cT].
   (* T exists *)
   rewrite (CP.class_loaded_unique H0 cT_exists) in * |- *.
   destruct (bool_informative (C.class_interface cS0)) as [cS_is_interface | cS_is_class].
    (* S interface: impossible *)
    congruence.
    (* S class *)
    destruct (bool_informative (C.class_interface cT0)) as [cT_interface | cT_class].
     (* T interface *)
     congruence.
     (* T class *)
     apply check_subclass_complete. rewrite (CP.cert_classpool_names_2 cS_exists). assumption.
   (* no T: impossible *)
   elimtype False. apply no_cT. eauto.
  (* no S: impossible *)
  elimtype False. apply no_cS. eauto.
 (* assign_class_interface *)
 destruct (CP.class_loaded_dec classes nmS) as [[cS0 cS_exists] | no_cS].
  (* S exists *)
  rewrite (CP.class_loaded_unique H cS_exists) in * |- *. clear H cS.
  destruct (CP.class_loaded_dec classes nmT) as [[cT0 cT_exists] | no_cT].
   (* T exists *)
  rewrite (CP.class_loaded_unique H0 cT_exists) in * |- *. clear H0 cT.
   destruct (bool_informative (C.class_interface cS0)) as [cS_is_interface | cS_is_class].
    (* S interface: impossible *)
    congruence.
    (* S class *)
    destruct (bool_informative (C.class_interface cT0)) as [cT_interface | cT_class].
     (* T interface *)
     apply check_class_implements_complete. rewrite (CP.cert_classpool_names_2 cS_exists). intuition eauto 6.
     (* T class: impossible *)
     congruence.
   (* no T: impossible *)
   elimtype False. apply no_cT. eauto.
  (* no S: impossible *)
  elimtype False. apply no_cS. eauto.
 (* assign_interface_class *)
 destruct (CP.cert_classpool_has_Object classes) as [object [object_exists [_ [_ object_class]]]].
 destruct (CP.class_loaded_dec classes nmS) as [[cS0 cS_exists] | no_cS].
  (* S exists *)
  rewrite (CP.class_loaded_unique H cS_exists) in * |- *. clear H cS.
  destruct (CP.class_loaded_dec classes B.java_lang_Object) as [[cT cT_exists] | no_cT].
   (* T exists *)
   rewrite (CP.class_loaded_unique object_exists cT_exists) in * |- *. clear object_exists object.
   destruct (bool_informative (C.class_interface cS0)) as [cS_interface | cS_class].
    (* S interface *)
    destruct (bool_informative (C.class_interface cT)) as [cT_interface | cT_class].
     (* T interface: impossible *)
     rewrite cT_interface in object_class. discriminate.
     (* T class *)
     destruct (B.Classname.eq_dec B.java_lang_Object B.java_lang_Object) as [is_eq | not_eq].
      (* of course... *)
      reflexivity.
      (* not *)
      elimtype False. apply not_eq. reflexivity.
    (* S class *)
    rewrite cS_class in H0. discriminate.
   (* no T: impossible *)
   elimtype False. apply no_cT. eauto.
  (* no S : impossible *)
  elimtype False. apply no_cS. eauto.
 (* assign_interface_interface_refl *)
 destruct (CP.class_loaded_dec classes nmS) as [[cS0 cS_exists] | no_cS].
  (* S exists *)
  rewrite (CP.class_loaded_unique H cS_exists) in * |- *. clear H cS.
  destruct (bool_informative (C.class_interface cS0)) as [S_interface | cS_class].
   (* S interface *)
   destruct (B.Classname.eq_dec nmS nmS) as [is_eq | not_eq].
    (* of course... *)
    reflexivity.
    (* not *)
    elimtype False. apply not_eq. reflexivity.
   (* S class *)
   rewrite cS_class in H0. discriminate.
  (* no S: impossible *)
  elimtype False. apply no_cS. eauto.
 (* assign_interface_interface_strict *)
 destruct (CP.class_loaded_dec classes nmS) as [[cS0 cS_exists] | no_cS].
  (* S exists *)
  rewrite (CP.class_loaded_unique H cS_exists) in * |- *. clear H cS.
  destruct (CP.class_loaded_dec classes nmT) as [[cT0 cT_exists] | no_cT].
   (* T exists *)
   rewrite (CP.class_loaded_unique H0 cT_exists) in * |- *. clear H0 cT.
   destruct (bool_informative (C.class_interface cS0)) as [cS_interface | cS_class].
    (* S interface *)
    destruct (bool_informative (C.class_interface cT0)) as [cT_interface | cT_class].
     (* T interface *)
     destruct (B.Classname.eq_dec nmS nmT) as [S_eq_T | S_neq_T].
      (* are equal *)
      reflexivity.
      (* not equal *)
      apply check_direct_super_interface_complete. apply H3.
     (* T class: impossible *)
     rewrite cT_class in H2. discriminate.
    (* S class: impossible *)
    rewrite cS_class in H1. discriminate.
   (* no T: impossible *)
   elimtype False. apply no_cT. eauto.
  (* no S: impossible *)
  elimtype False. apply no_cS. eauto.
Qed.

Definition is_assignable : forall classes S T, {assignable classes S T}+{~assignable classes S T}.
intros classes S T.
destruct (bool_informative (check_assignable classes S T)) as [is_true | is_false].
 left. apply check_assignable_sound. apply is_true.
 right. unfold not. intro. rewrite (check_assignable_complete _ _ _ H) in is_false. discriminate.
Defined.

(* preservation of assignability *)

Lemma preserve_subclass : forall classesA classesB nm_s nm_t,
  sub_class classesA nm_s nm_t ->
  CP.preserve_old_classes classesA classesB ->
  sub_class classesB nm_s nm_t.
intros. unfold CP.preserve_old_classes in *. induction H.
 eapply sub_class_refl; eauto.
 eapply sub_class_step; eauto.
Qed.
Hint Resolve preserve_subclass.

Lemma preserve_subclass_rev : forall classesA classesB nm_s c_s nm_t,
  CP.class_loaded classesA nm_s c_s ->
  sub_class classesB nm_s nm_t ->
  CP.preserve_old_classes classesA classesB ->
  sub_class classesA nm_s nm_t.
Proof.
  intros until nm_t. intros loaded_s subclass preserve.
  generalize c_s loaded_s.
  clear c_s loaded_s.
  induction subclass; intros.
    eapply sub_class_refl; eauto.

    pose (loaded_s' := preserve nm c_s loaded_s).
    clearbody loaded_s'.
    rewrite (CP.class_loaded_unique H loaded_s') in H0.
    eapply sub_class_step; eauto.
    destruct (CP.class_super_loaded _ _ _ _ loaded_s H0).
    eapply IHsubclass; eauto.
Qed.

Lemma preserve_direct_super_interface : forall classesA classesB nm_s nm_t,
  direct_super_interface classesA nm_s nm_t ->
  CP.preserve_old_classes classesA classesB ->
  direct_super_interface classesB nm_s nm_t.
intros classesA classesB nm_s nm_t direct1 preserve1.
unfold CP.preserve_old_classes in preserve1.
induction direct1; eauto using d_inter_here, d_inter_step_up, d_inter_step_along.
Qed.
Hint Resolve preserve_direct_super_interface.

Lemma preserve_assignable : forall classesA classesB S T,
  assignable classesA S T ->
  CP.preserve_old_classes classesA classesB ->
  assignable classesB S T.
intros classesA classesB S T assignable1 preserve1.
unfold CP.preserve_old_classes in preserve1. unfold assignable in *.
destruct assignable1; eauto 7 using assign_class_class, assign_class_interface, assign_interface_class, assign_interface_interface_refl, assign_interface_interface_strict.
Qed.

Lemma superclass_loaded : forall classes nm_s c_s nm_t,
  CP.class_loaded classes nm_s c_s ->
  sub_class classes nm_s nm_t ->
  exists c, CP.class_loaded classes nm_t c.
Proof.
  intros.
  generalize nm_s c_s H.
  clear H.
  induction H0; intros.
    exists cwitness.  assumption.
    eapply IHsub_class; eauto.
Qed.

Lemma interfaces_loaded : forall classes nmA cA nmB,
  CP.class_loaded classes nmA cA ->
  In nmB (C.class_interfaces cA) ->
  exists cB, CP.class_loaded classes nmB cB.
Proof.
  intros classes nmA cA nmB loadedA in_ifaces.
  pose (good := CP.cert_classpool_gives_gil2 loadedA).
  clearbody good.
  set (ifaces := C.class_interfaces cA) in *.
  induction good.
    inversion in_ifaces.

    inversion in_ifaces.
      subst i_nm. exists i. assumption.

      apply IHgood; auto.
Qed.

Lemma super_interface_loaded : forall classes nmA cA nmB,
  CP.class_loaded classes nmA cA ->
  direct_super_interface classes (C.class_interfaces cA) nmB ->
  exists cB, CP.class_loaded classes nmB cB.
Proof.
  intros classes nmA cA nmB loadedA supers.
  set (ifaces := C.class_interfaces cA) in *.
  assert (in_ifaces : forall iface, In iface ifaces -> In iface (C.class_interfaces cA)) by auto.
  clearbody ifaces.
  generalize nmA cA loadedA in_ifaces.
  clear nmA cA loadedA in_ifaces.
  induction supers; intros.
    eapply interfaces_loaded; eauto. apply in_ifaces. left. reflexivity.

    apply IHsupers with (nmA:=nmX) (cA:=cX); auto.

    apply IHsupers with (nmA:=nmA) (cA:=cA); auto.
    intros. apply in_ifaces. right. assumption.
Qed.

Lemma assignable_loaded : forall classes nmA cA nmB,
  CP.class_loaded classes nmA cA ->
  assignable classes (C.ty_obj nmA) (C.ty_obj nmB) ->
  exists cB, CP.class_loaded classes nmB cB.
Proof.
  intros.
  inversion H0; eauto.
  destruct (CP.cert_classpool_has_Object classes) as [obj [loaded _]].
  eauto.
Qed.

Lemma preserve_superinterfaces_rev : forall classesA classesB nmA cA nmB,
  CP.class_loaded classesA nmA cA ->
  CP.preserve_old_classes classesA classesB ->
  direct_super_interface classesB (C.class_interfaces cA) nmB ->
  direct_super_interface classesA (C.class_interfaces cA) nmB.
Proof.
  intros.
  set (ifaces := C.class_interfaces cA) in *.
  assert (in_ifaces : forall iface, In iface ifaces -> In iface (C.class_interfaces cA)) by auto.
  clearbody ifaces.
  generalize nmA cA H in_ifaces.
  clear nmA cA H in_ifaces.
  induction H1; eauto using d_inter_here, d_inter_step_up, d_inter_step_along.
    intros.
    destruct (interfaces_loaded classesA nmA cA nmX); eauto.  apply in_ifaces. left. reflexivity.
    rewrite (CP.class_loaded_unique (H0 _ _ H4) H) in H4.
    apply d_inter_step_up with (cX:=cX); auto.
    apply IHdirect_super_interface with (nmA:=nmX) (cA:=cX); auto.

    intros.
    apply d_inter_step_along.
    apply IHdirect_super_interface with (nmA:=nmA) (cA:=cA); auto.
    intros. apply in_ifaces. right. assumption.
Qed.

Lemma preserve_assignable_rev : forall classesA classesB nmA cA nmB,
  assignable classesB (C.ty_obj nmA) (C.ty_obj nmB) ->
  CP.class_loaded classesA nmA cA ->
  C.class_interface cA = false ->
  CP.preserve_old_classes classesA classesB ->
  assignable classesA (C.ty_obj nmA) (C.ty_obj nmB).
Proof.
  intros until nmB; intros assign loaded_A notint_A preserve.
  inversion assign; subst.
    apply preserve_subclass_rev with (classesA:=classesA) (c_s:=cA) in H5; auto.
    eapply assign_class_class; eauto.
    destruct (superclass_loaded classesA nmA cA nmB); eauto.
    rewrite (CP.class_loaded_unique H2 (preserve _ _ H)). assumption.

    rewrite (CP.class_loaded_unique H1 (preserve _ _ loaded_A)) in *.
    apply preserve_subclass_rev with (classesA:=classesA) (c_s:=cA) in H7; auto.
    destruct (superclass_loaded classesA nmA cA nmS'); eauto.
    rewrite (CP.class_loaded_unique (preserve _ _ H) H3) in H.
    apply (preserve_superinterfaces_rev classesA classesB nmS' cS' nmB) in H8; auto.
    destruct (super_interface_loaded classesA nmS' cS' nmB) as [cT' loadedB']; auto.
    rewrite (CP.class_loaded_unique (preserve _ _ loadedB') H2) in loadedB'.
    eapply (assign_class_interface classesA nmA nmB cA cT nmS' cS'); eauto.

    rewrite (CP.class_loaded_unique H1 (preserve _ _ loaded_A)) in *.
    eapply assign_interface_class; eauto.

    rewrite (CP.class_loaded_unique H1 (preserve _ _ loaded_A)) in *.
    eapply assign_interface_interface_refl; eauto.

    rewrite (CP.class_loaded_unique H1 (preserve _ _ loaded_A)) in *.
    apply (preserve_superinterfaces_rev classesA classesB nmA cA nmB) in H5; auto.
    destruct (super_interface_loaded classesA nmA cA nmB) as [cT' loadedB']; auto.
    rewrite (CP.class_loaded_unique (preserve _ _ loadedB') H2) in loadedB'.
    eapply assign_interface_interface_strict; eauto.
Qed.

Lemma subclass_distinct : forall classes nm c nm' nm_t,
  CP.class_loaded classes nm c ->
  C.class_super_class c = Some nm' ->
  C.class_interface c = false ->
  sub_class classes nm' nm_t ->
  nm <> nm_t.
Proof.
  intros.
  intro nmeq.
  subst nm_t.
  set (scc:=CP.cert_classpool_gives_scc H H1).
  clearbody scc.
  set (x:=C.class_super_class c).
  assert (xeq :C.class_super_class c = x) by reflexivity.
  rewrite xeq in scc.
  generalize x scc nm c nm' H H0 H1 H2 xeq.
  clear - classes.
  induction 1 using CP.super_class_chain_induction.
    intros.
    rewrite H0 in xeq.
    discriminate.

    intros.
    rewrite xeq in H1.
    injection H1 as nmeq'.
    subst nm'.
    destruct H3.
      rewrite (CP.class_loaded_unique e H0) in *.
      clear H1.
      eapply (H c0 H0); eauto.
      eapply sub_class_refl; eauto.

      eapply H; eauto.
      apply CP.class_super_interface with (classes:=classes) (nm1:=nm_t) (nm2:=nm) (c1:=c0) (c2:=c1); auto.
      eapply sub_class_trans. apply H4. eapply sub_class_step; eauto. eapply sub_class_refl; eauto.
Qed.

End MkAssignability.