(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                          Pierre CASTERAN                             *)
(*                            2003 -2006                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Require Export basics.
Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Section props.
 Variables A W I J: Set.

(* some inversion lemmas *)

Lemma access_res:forall  decI decJ n (r:resource W) (rp
:rule_pattern I J) (Gamma':context I J A W)(A1: Form I J A),
access decI decJ rp n (res r A1) =(Some Gamma',true) ->
 {i:nat |rp=(pvar i)}.

 intros  decI decJ n r rp; case rp.
 simpl in |- *.
 intro n0.
 intros.
 exists n0.
 auto.
 simpl in |- *.
 intros.
 discriminate H.
 simpl in |- *.
 intros.
 discriminate H.
Defined.

Lemma access_com_none:forall (rp1 rp2:rule_pattern I J) decI decJ n i
                      (Gamma:context I J A W),
                   access decI decJ (pcomma i rp1 rp2) n Gamma=(None, true) ->
                      {Gamma1:context I J A W&{Gamma2:context  I J A W|
                       Gamma=(Comma i Gamma1 Gamma2)/\
                     (access decI decJ rp2 n Gamma2=(None,true))/\
                      (access  decI decJ rp1 n Gamma1=(None, true))}}.

 simpl in |- *.
 intros  rp1 rp2 decI decJ n i Gamma; case Gamma.
 intros.
 discriminate H.
 intro i0; case (decI i0 i).
 intro R; subst; intros c c0.
 intros.
 exists c; exists c0; generalize H; clear H.
 case (access decI decJ rp1 n c).
 intros o b0; case o.
 intro c1; case (access decI decJ rp2 n c0).
 intro o0; case o0.
 intros.
 discriminate H.
 intro b1; case b1.
 intro H; discriminate H.
 intro H; discriminate H.
 case b0.
 tauto.
 intro H; discriminate H.
 intros.
 discriminate H.
 intros; discriminate H.
Qed.

Lemma access_com_some:forall (rp1 rp2:rule_pattern I J) decI decJ n b
 i (Gamma Gamma':context I J A W),
          access decI decJ (pcomma i rp1 rp2) n Gamma=((Some Gamma'), b) ->
         {Gamma1:context I J A W&{Gamma2:context I J A W|
           Gamma=(Comma i Gamma1 Gamma2)/\
         (((access decI decJ rp1 n Gamma1=((Some Gamma'),b))/\
                      (access  decI decJ rp2 n Gamma2=(None, true))) \/
                     ((access decI decJ rp2 n Gamma2=((Some Gamma'),b))/\
                      (access  decI decJ rp1 n Gamma1=(None, true))))}}.
 simpl in |- *.
 intros rp1 rp2 decI decJ n b i Gamma Gamma'; case Gamma.
 intros.
 discriminate H.
 intro i0; case (decI i0 i).
 intro R; subst; intros c c0.
 intros.
 exists c; exists c0; generalize H; clear H.
 case (access decI decJ rp1 n c).
 intros o b0; case o.
 intro c1; case (access decI decJ rp2 n c0).
 intro o0; case o0.
 intros.
 discriminate H.
 intro b1; case b1.
 intros; tauto.
 intro H; discriminate H.
 case b0.
 tauto.
 intro H; discriminate H.
 intros.
 discriminate H.
 intros.
 discriminate H.
Qed.

Lemma access_Com_some:forall (rp:rule_pattern I J) decI decJ n
 i (Gamma1 Gamma2 Gamma':context I J A W),
                   access decI decJ rp n (Comma i Gamma1 Gamma2)=
                     ((Some Gamma'), true) ->
                      {rp1:rule_pattern I J &{rp2:rule_pattern I J&
                     {H: {(access decI decJ rp1 n Gamma1=((Some Gamma'),true))/\
                      (access  decI decJ rp2 n Gamma2=(None, true))} +
                     {(access decI decJ rp2 n Gamma2=((Some Gamma'),true))/\
                      (access  decI decJ rp1 n Gamma1=(None,true))} |
                       rp=pcomma i rp1 rp2}}}
                  +{i:nat|rp=pvar i}.
 intros.
 generalize H; clear H.
 case rp.
 intros; right.
 exists n0; auto.
 intros i0 r r0.
 intro H0.
 cut
 ({access decI decJ r n Gamma1 = (Some Gamma', true) /\
   access decI decJ r0 n Gamma2 = (None, true)} +
  {access decI decJ r0 n Gamma2 = (Some Gamma', true) /\
  access decI decJ r n Gamma1 = (None, true)}).
 intro H.
 left.
 exists r; exists r0; exists H.
 generalize H0.
 simpl in |- *.
 case (decI i i0).
 intros; subst; auto.
 intros.
 discriminate H1.
 generalize H0.
 simpl in |- *.
 case (decI i i0).
 case (access decI decJ r n Gamma1).
 intro o; case o.
 case (access decI decJ r0 n Gamma2).
 intro o0; case o0.
 intros.
 discriminate H1.
 intro b; case b.
 intros.
 injection H1; intros; subst.
 left.
 tauto.
 intros.
 discriminate H1.
 intro b; case b.
 intros.
 right.
 tauto.
 intros.
 discriminate H1.
 intros.
 discriminate H1.
 simpl in |- *.
 intros.
 discriminate H.
Qed.

Lemma access_diam_some:forall (rp:rule_pattern I J) decI decJ n b j
                   (Gamma Gamma':context I J A W),
                    access decI decJ (pdiam j rp) n Gamma=((Some Gamma'), b) ->
                   {Gamma1:context I J A W|Gamma=(TDiamond j Gamma1) /\
                    access decI decJ rp n Gamma1=((Some Gamma'), b)}.
 simpl in |- *.
 intros rp decI decJ n b j Gamma Gamma'; case Gamma.
 intros; discriminate H.
 intros; discriminate H.
 intro j0; case (decJ j j0).
 intros.
 exists c.
 subst; tauto.
 intros.
 discriminate H.
Qed.

Lemma access_diam_TDiam:forall (rp:rule_pattern I J) decI decJ n b j
                   (Gamma Gamma':context I J A W),
                    access decI decJ  rp n (TDiamond j Gamma)=((Some Gamma'), b) ->
                   {rp1:rule_pattern I J|rp=(pdiam j rp1) /\
                    access decI decJ rp1 n Gamma=((Some Gamma'), b)}+
                   {j:nat|rp=pvar j}.
 intros  rp; case rp.
 intros; right; econstructor; eauto.
 simpl in |- *.
 intros.
 discriminate H.
 intros; left.
 generalize H; simpl in |- *.
 case (decJ j j0).
 intros.
 subst.
 exists r.
 tauto.
 intros.
 discriminate H0.
Qed.

Lemma access_diam_none:forall  (rp:rule_pattern I J) decI decJ n  j
                      (Gamma :context I J A W),
                    access decI decJ (pdiam j rp) n Gamma=(None, true) ->
                   {Gamma1:context I J A W|Gamma=(TDiamond j Gamma1) /\
                    access decI decJ rp n Gamma1=(None,true)}.
 simpl.
 intros rp decI decJ n j Gamma; case Gamma.
 intros; discriminate H.
 intros; discriminate H.
 intro j0; case (decJ j j0).
 intros.
 exists c.
 subst; tauto.
 intros.
 discriminate H.
Qed.

Lemma access_some_true: forall (rp1:rule_pattern I J) decI decJ n b
                   (Gamma Gamma':context I J A W),
                   access decI decJ rp1 n Gamma=(Some Gamma', b)->
                   b=true.
 intros rp1; elim rp1.
 intros n decI decJ n0 b Gamma Gamma'.
 simpl in |- *.
 case (eq_nat_dec n n0).
 intros.
 injection H; auto.
 intros.
 discriminate H.
 intros.
 elim (access_com_some _ _ _ _ _ _ _ H1).
 intros Gamma1 H2; elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intro H3; elim H3; clear H3; intros H3 H4.
 eauto.
 eauto.
 intros.
 elim (access_diam_some _ _ _ _ _ _ H0).
 intros Gamma1 H1.
 elim H1; clear H1; intros.
 eauto.
Qed.

Lemma access_dec:forall (rp1:rule_pattern I J) decI decJ n
                   (Gamma :context I J A W),
                 (exists Gamma', access decI decJ rp1 n Gamma=(Some Gamma', true)) \/
                 (exists b:bool,  access decI decJ rp1 n Gamma=(None ,
                   b)).
Proof.
 intros.
 cut
 ((exists Gamma' : context I J A W,
     (exists b : bool, access decI decJ rp1 n Gamma = (Some Gamma', b))) \/
  (exists b : bool, access decI decJ rp1 n Gamma = (None, b))).
 intro H0; elim H0; intros.
 elim H; clear H; intros Gamma' H; elim H; clear H; intros.
 rewrite (access_some_true _ _ _ _ _ H) in H.
 left; econstructor; eauto.
 tauto.
 case (access decI decJ rp1 n Gamma).
 intros o b; case o.
 intro; left; econstructor; econstructor; eauto.
 right; econstructor; eauto.
Qed.

Lemma access_leaf:forall decI decJ (rp1:rule_pattern I J) (Gamma
                   Gamma':context I J A W) n,
                   access decI decJ rp1 n Gamma=(Some Gamma', true)->
                   isLeaf n rp1.
Proof.
 intros decI decJ rp1; elim rp1; intros.
 simpl in |- *.
 generalize H; simpl in |- *.
 case (eq_nat_dec n n0).
 auto.
 intros.
 discriminate H0.
 simpl in |- *.
 elim (access_com_some _ _ _ _ _ _ _ H1).
 intros Gamma1 H2.
 elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intros.
 elim H3; clear H3; intros.
 left; eauto.
 right; elim H3; eauto.
 simpl in |- *.
 elim (access_diam_some _ _ _ _ _ _ H0).
 intros Gamma0 H1.
 elim H1; eauto.
Qed.

Lemma access_is_sub_cont:forall decI decJ (rp:rule_pattern I J)
                        (Gamma Gamma':context I J A W) n,
                        access decI decJ rp n Gamma=(Some Gamma',true)->
                        is_sub_cont Gamma' Gamma.
intros decI decJ rp; elim rp; intros.
generalize H;clear H;simpl.
case (eq_nat_dec n n0).
 intros.
injection H.
intro;subst;constructor.
discriminate 2.
elim (access_com_some _ _ _ _ _ _ _ H1).
intros Gamma1 H2.
 elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intros;elim H3; clear H3; intros;subst.
constructor.
eauto.
subst;constructor 3.
eauto.
elim (access_diam_some _ _ _ _ _ _ H0).
 intros T H1;decompose [and] H1.
subst;constructor;eauto.
Qed.

Lemma access_leaf_false:forall decI decJ (rp:rule_pattern I J)
                        (Gamma:context I J A W) n,
                        isLeaf n rp ->
                        access decI decJ rp n Gamma=(None,true)->
                        False.
 intros decI decJ rp; elim rp; intros.
 generalize H0; clear H0; simpl in |- *.
 case (eq_nat_dec n n0).
 intros.
 discriminate H0.
 simpl in H.
 intros.
 elim n1; auto.
 simpl in H1.
 elim (access_com_none _ _ _ _ _ _ _ H2).
 intros Gamma1 H3; elim H3; clear H3; intros Gamma2 H3.
 elim H3; clear H3; intros.
 elim H1; elim H4; intros; eauto.
 simpl in H0.
 elim (access_diam_none _ _ _ _ _ _ H1).
 intros Gamma0 H2; elim H2; clear H2; intros.
 eauto.
Qed.

Lemma access_pathL:forall  decI decJ n (rp1 rp2:rule_pattern I J)
 (i:I)(Gamma0 Gamma1 Gamma2 Gamma' Gamma:context I J A W),
 access decI decJ rp1 n Gamma=(Some Gamma',true)->
 access decI decJ (pcomma i rp1 rp2) n (Comma i Gamma1 Gamma2)=(Some
 Gamma0 , true)->
 access decI decJ rp1 n Gamma1=(Some Gamma0 , true).

 intros.
 elim (access_com_some _ _ _ _ _ _ _ H0).
 intros Gamma3 H1; elim H1; clear H1; intros Gamma4 H1.
 elim H1; clear H1; intros H1 H2; elim H2; clear H2; intros.
 injection H1; intros; subst.
 tauto.
 injection H1; intros; subst.
 elim H2; clear H2; intros.
 cut (isLeaf n rp1).
 intro.
 elim (access_leaf_false _ _ _ _ _ H4 H3).
 eapply access_leaf; eauto.
Qed.

Lemma access_pathR:forall decI decJ n (rp1 rp2:rule_pattern I J)
 (i:I)(Gamma0 Gamma1 Gamma2 Gamma' Gamma:context I J A W),
 access decI decJ rp2 n Gamma=(Some Gamma',true)->
 access decI decJ (pcomma i rp1 rp2) n (Comma i Gamma1 Gamma2)=
           (Some Gamma0 , true)->
 access decI decJ rp2 n Gamma2=(Some Gamma0 , true).

 intros.
 elim (access_com_some _ _ _ _ _ _ _ H0).
 intros Gamma3 H1; elim H1; clear H1; intros Gamma4 H1.
 elim H1; clear H1; intros H1 H2; elim H2; clear H2; intros.
 cut (isLeaf n rp2).
 intro.
 elim H2; clear H2; intros.
 elim (access_leaf_false _ _ _ _ _ H3 H4).
 eapply access_leaf; eauto.
 injection H1; intros; subst; tauto.
Qed.

Lemma apply_rule_pvar:forall (rp1:rule_pattern I J) decI decJ n (t
                           t':context I J A W),
                           apply_rule (rp1, (pvar n))  decI decJ t=Some t' ->
                          {b:bool |access decI decJ rp1 n t=((Some t'), b)}.
 simpl in |- *.
 intros rp1 decI decJ n t t'.
 case (access decI decJ rp1 n t).
 intros o b; case o.
 intros.
 injection H; intros; subst; econstructor; eauto.
 intro H; discriminate H.
Qed.

Lemma apply_rule_com:forall (rp1 rp2 rp3: rule_pattern I J) decI decJ i
                           (t t':context I J A W),
               apply_rule (rp1, (pcomma i rp2 rp3)) decI decJ t=Some t' ->
               {t1:context I J A W&{t2:context I J A W | t'=(Comma i t1 t2) /\
                             apply_rule (rp1, rp2) decI decJ t =Some t1 /\
                             apply_rule (rp1, rp3) decI decJ t=Some t2}}.
 simpl.
 intros.
 generalize H; clear H.
 case (compile decI decJ rp1 rp3 t).
 case (compile decI decJ rp1 rp2 t).
 intros.
 injection H; econstructor;econstructor.
 split.
 eauto.
 auto.
 intros.
 discriminate H.
 case (compile decI decJ rp1 rp2 t);intros.
 discriminate H.
 discriminate H.
Qed.

Lemma apply_rule_diam: forall (rp1 rp2: rule_pattern I J)decI decJ i
                       (t t':context I J A W),
                      apply_rule (rp1,(pdiam i rp2)) decI decJ t =Some t' ->
                      {t1:context I J A W |t'=TDiamond i t1 /\ apply_rule (rp1, rp2) decI decJ t=Some t1}.
 intros.
 generalize H; clear H; simpl.
 case (compile  decI decJ rp1 rp2 t).
 intros.
 injection H; econstructor.
 split;eauto.
 intro H; discriminate H.
Qed.

Lemma access_same_shape_true:forall decI decJ rp1 opt
                        (n:nat)(Gamma:context I J A W),
                        access decI decJ rp1  n Gamma =(opt, true)->
                        same_shape rp1 Gamma.
 intros decI decJ rp1; elim rp1.
 intros; constructor.
 intros.
 generalize H1; case opt.
 intros.
 elim (access_com_some _ _ _ _ _ _ _ H2).
 clear H2.
 intros Gamma1 H2; elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intro H3; elim H3; clear H3; intros H3 H4.
 rewrite H2.
 constructor; eauto.
 rewrite H2; constructor; eauto.
 intro.
 elim (access_com_none _ _ _ _ _ _ _ H2); clear H2.
 intros Gamma1 H2; elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 rewrite H2.
 elim H3; intros; constructor; eauto.
 intros.
 generalize H0; clear H0; case opt; intros.
 elim (access_diam_some _ _ _ _ _ _ H0).
 intros Gamma1 H1.
 elim H1; clear H1; intros.
 subst.
 constructor; eauto.
 elim (access_diam_none _ _ _ _ _ _ H0).
 intros Gamma1 H1; elim H1; intros.
 subst; constructor; eapply H; eauto.
Qed.

Lemma access_same_shape:forall decI decJ b (n:nat)(Gamma
                          Gamma':context I J A W)rp1,
                          access decI decJ rp1 n Gamma=((Some Gamma'), b) ->
                          same_shape rp1 Gamma.
Proof.
intros.
rewrite (access_some_true _ _ _ _ _ H) in H.
eapply access_same_shape_true; eauto.
Qed.

Lemma apply_rule_same_shape:forall decI decJ  (r1 r2: rule_pattern I J )
                           (t t':context I J A W),
                             (apply_rule (r1 , r2) decI decJ  t)=Some t'->
                             same_shape r1 t.

 intros.
 generalize t' H; clear t' H.
 elim r2.
 intros.
 elim apply_rule_pvar with (1 := H).
 intros.
 eapply access_same_shape; eauto.
 intros.
 elim apply_rule_com with (1:= H1).
 intros.
 elim p; clear p; intros.
 elim p; clear p; intros.
 elim H3; clear H3; intros.
 eauto.
 intros.
 elim apply_rule_diam with (1 := H0).
 intros.
 elim p; intros.
 eauto.
Qed.

Lemma apply_rule_same_shape2:forall decI decJ  (r1 r2: rule_pattern I J )
                           (t t':context I J A W),
                             (apply_rule (r1 , r2) decI decJ  t)=Some t'->
                             same_shape r2 t'.
Proof.
 intros decI decJ r1 r2; elim r2; intros.
 constructor.
 elim (apply_rule_com _ _ _ _ _ _ _ H1).
 intro t1.
 intro H2; elim H2; clear H2; intros t2 H2.
 elim H2; clear H2; intros.
 subst.
 elim H3; intros; constructor; eauto.
 elim (apply_rule_diam _ _ _ _ _ _ H0).
 intros t1 H1; elim H1; clear H1; intros.
 subst.
 constructor; eauto.
Qed.

(* access, apply_rule and par_replace *)
Definition access_par_replace:forall (r:resource W)(Gamma1 Gamma1'
Delta:context I J A W)decI decJ A1 n,
 par_replace (res r A1) Delta Gamma1 Gamma1'->
forall (rp:rule_pattern I J)(Gamma2 Gamma2':context I J A W),
 access decI decJ rp n Gamma1=(Some Gamma2, true)->
 access decI decJ rp n Gamma1'=(Some Gamma2', true)->
 par_replace (res r A1) Delta Gamma2 Gamma2'.

 induction 1.
 intros.
 rewrite H in H0.
 injection H0.
 intro; subst; constructor.
 intros.
 elim (access_res _ _ _ _ _ _ H).
 intros i H1.
 subst.
 generalize H H0; clear H H0; simpl in |- *.
 case (eq_nat_dec i n).
 intros.
 injection H; injection H0.
 intros; subst.
 constructor.
 intros.
 discriminate H.
 intros.
 elim (access_Com_some _ _ _ _ _ _ _ H1).
 intro H3.
 elim H3; clear H3; intros rp1 H3.
 elim H3; clear H3; intros rp2 H3.
 elim H3; clear H3; intros H3 H4.
 elim (access_Com_some _ _ _ _ _ _ _ H2).
 intro H5.
 elim H5; clear H5; intros r1 H5; elim H5; clear H5; intros r2 H5.
 elim H5; clear H5; intros H5 H6.
 rewrite H6 in H4; injection H4; intros; subst.
 elim H3.
 intro H6.
 elim H6; clear H6; intros.
 eapply IHpar_replace1.
 eauto.
 eapply access_pathL; eauto.
 intro H6; elim H6; clear H6; intros.
 eapply IHpar_replace2.
 eauto.
 eapply access_pathR; eauto.
 intro H5; elim H5; clear H5; intros; subst.
 discriminate p.
 intro H3; elim H3; clear H3; intros j H3.
 generalize H1 H2; clear H1 H2; subst.
 simpl in |- *.
 case (eq_nat_dec j n).
 intros.
 injection H1; injection H2; intros; subst.
 constructor.
 auto.
 auto.
 intros.
 discriminate H1.
 intros.
 elim (access_diam_TDiam _ _ _ _ _ _ H0).
 intro H2.
 elim H2; clear H2; intros rp1 H2.
 elim H2; clear H2; intros.
 elim (access_diam_TDiam _ _ _ _ _ _ H1).
 intro H4; elim H4; clear H4; intros rp2 H4; elim H4; clear H4; intros.
 rewrite H2 in H4; injection H4; intros; subst.
 eauto.
 intro H5; elim H5; intros k H6; rewrite H6 in H2; discriminate H2.
 intro H2; elim H2; clear H2; intros k H2; subst.
 generalize H0 H1; simpl in |- *.
 case (eq_nat_dec k n).
 intros.
 injection H2; injection H3; intros; subst.
 constructor; auto.
 intros.
 discriminate H2.
Defined.

Definition apply_rule_par_replace:forall ru (r:resource W)(Gamma1 Gamma1'
Gamma2 Gamma2' Delta:context I J A W)decI decJ A1 ,
 par_replace (res r A1) Delta Gamma1 Gamma1'->
 apply_rule ru decI decJ  Gamma1=Some Gamma2->
 apply_rule ru decI decJ Gamma1'=Some Gamma2'->
 par_replace (res r A1) Delta Gamma2 Gamma2'.

 intro ru; case ru; intros r1 r2; elim r2; intros.
 elim (apply_rule_pvar _ _ _ _ _ H0).
 intros b H2.
 clear H0.
 elim (apply_rule_pvar _ _ _ _ _ H1); clear H1.
 intros b1 H1.
 rewrite (access_some_true _ _ _ _ _ H2) in H2.
 rewrite (access_some_true _ _ _ _ _ H1) in H1.
 eapply access_par_replace; eauto.
 elim (apply_rule_com _ _ _ _ _ _ _ H2).
 clear H2; intros Gamma11 H2.
 elim H2; clear H2; intros Gamma12 H2.
 elim H2; clear H2; intros H2 H4.
 elim H4; clear H4; intros.
 subst.
 elim (apply_rule_com _ _ _ _ _ _ _ H3).
 clear H3; intros Gamma21 H3.
 elim H3; clear H3; intros Gamma22 H3.
 elim H3; clear H3; intros H3 H6.
 elim H6; clear H6; intros.
 subst.
 constructor.
 eapply H;eauto.
 eapply H0 ;eauto.
 elim (apply_rule_diam _ _ _ _ _ _ H1); clear H1.
 intros Gamma11 H3.
 elim H3; clear H3; intros.
 subst.
 subst.
 elim (apply_rule_diam _ _ _ _ _ _ H2); clear H2.
 intros Gamma11' H4; elim H4; clear H4; intros.
 subst; constructor; eauto.
Defined.

Lemma acces_leaf_shape: forall decI decJ (n:nat)(rp:rule_pattern I J)
                     (Gamma:context I J A W),
                      ~isLeaf n rp ->
                      same_shape rp Gamma->
                      access decI decJ rp n Gamma =(None, true).
 induction 2.
 simpl in H.
 simpl in |- *.
 elim (eq_nat_dec n0 n).
 intro.
 absurd (n = n0); auto.
 auto.
 simpl in H.
 elim (isLeaf_dec n r1); elim (isLeaf_dec n r2); intros.
 elim H; tauto.
 elim H; tauto.
 elim H; tauto.
 simpl in |- *.
 case (decI i i).
 generalize IHsame_shape1; generalize IHsame_shape2.
 case (access decI decJ r1 n Gamma1).
 intros o b1; case o.
 case (access decI decJ r2 n Gamma2).
 intros.
 cut ((Some c, b1) = (None, true)).
 intro D; discriminate D.
 auto.
 case b1.
 intros.
 auto.
 intros.
 tauto.
 tauto.
 simpl in H.
 simpl in |- *.
 case (decJ j j);tauto.
Qed.

Lemma acces_isLeaf: forall decI decJ (n:nat)(rp:rule_pattern I J)
                     (Gamma:context I J A W), ~isLeaf n rp ->
                     {b:bool|access decI decJ rp n Gamma=(None, b)}.
 intros  decI decJ n rp.
 elim rp; intros.
 simpl in |- *.
 elim (eq_nat_dec n0 n).
 simpl in H.
 intro.
 absurd (n = n0); auto.
 auto.
 intro; econstructor; eauto.
 simpl in H1.
 simpl in |- *.
 case Gamma.
 intros; econstructor; eauto.
 elim (isLeaf_dec n r).
 intros.
 elim H1; tauto.
 intros; elim (isLeaf_dec n r0).
 intro; elim H1; tauto.
 intros.
 simpl in |- *.
 case (decI i0 i).
 intros.
 elim (H c b).
 intros.
 rewrite p.
 elim x.
 eauto.
 econstructor; eauto.
 intro; econstructor; eauto.
 intros; econstructor; eauto.
 simpl in H0.
 case Gamma; simpl in |- *.
 intros; econstructor; eauto.
 intros; econstructor; eauto.
 intros.
 elim (decJ j j0).
 intro; auto.
 intro; econstructor; eauto.
Qed.

Lemma acces_same_shape:forall decI decJ (rp1:rule_pattern I J)
                      (Gamma:context I J A W) n,
                       allDistinctLeaves rp1 -> isLeaf n rp1 ->
                       same_shape rp1 Gamma ->
                       {Gamma' : context I J A W | access decI decJ rp1 n Gamma = ((Some Gamma'),true)}.

 intros decI decJ rp1; elim rp1; intros.
 simpl in H0.
 subst.
 econstructor.
 simpl in |- *.
 case (eq_nat_dec n n).
 eauto.
 tauto.
 elim (sameShapeCom H3).
 intros.
 elim p; intros.
 elim p0; clear p0; intros.
 subst.
 clear p.
 simpl in H1.
 simpl in |- *.
 elim H1; clear H1; intros.
 elim H4; clear H4; intros.
 elim (isLeaf_dec_com H6 H2).
 intros.
 elim a; clear a; intros.
 elim H5; clear H5; intros.
 elim (H _ _ H1 H7 H5).
 intros.
 rewrite p.
 elim (decI i i).
 intro.
 exists x1.
 rewrite (acces_leaf_shape decI decJ _ H8 H9).
 auto.
 tauto.
 intros.
 elim b; clear b; intros.
 elim H5; clear H5; intros.
 elim (H0 _ _ H4 H7 H9).
 intros.
 rewrite p.
 exists x1.
 case (decI i i).
 rewrite (acces_leaf_shape decI decJ _ H8 H5).
 auto.
 tauto.
 simpl in H1.
 simpl in H0.
 elim (sameShapeDiam H2).
 intros.
 elim p; clear p; intros; subst.
 simpl in |- *.
 elim (H _ _ H0 H1 H4).
 intros.
 exists x0.
 case (decJ j j);tauto.
Qed.

Lemma access_sub_cont:forall (decI:eqdec I)(decJ :eqdec
J)(rp:rule_pattern I J)(Gamma:context I J A W) l ,
               allDistinctLeaves rp->
               hasSubContexts rp Gamma l->
               forall n (Delta :context I J A W)i,
               (nth_error (flatten_pattern rp) i)=Some n ->
                access decI decJ rp n Gamma=(Some Delta,true)->
                nth_error l i=Some Delta.

Proof.
 induction 2.
 simpl in |- *.
 intro n ; case (eq_nat_dec i n).
 intros H0 Delta0 i0;case i0.
 simpl in |- *.
 injection 2; intros; subst; auto.
 intro n0; case n0; discriminate 1.
 discriminate 3.
 intros.
 simpl in H0.
 elim (nth_error_app _ _ _ H0); intro.
 apply nth_error_fst_app.
 simpl in H; decompose [and] H; clear H.
 elim
 (acces_same_shape decI decJ n H3 (nth_flatten_leaf _ _ H2)
        (same_shape_SubCont H0_)).
 intros.
 eapply IHhasSubContexts1; eauto.
 eapply access_pathL; eauto.
 decompose [and] H2; clear H2.
 replace i0 with (i0 - length l1 + length l1).
 apply nth_error_scd_app.
 simpl in H; decompose [and] H; clear H.
 elim
  (acces_same_shape decI decJ n H6 (nth_flatten_leaf _ _ H4)
         (same_shape_SubCont H0_0)).
 intros.
 eapply IHhasSubContexts2; eauto.
 rewrite (subCont_length H0_); eauto.
 eapply access_pathR; eauto.
 rewrite (subCont_length H0_).
 omega.
 intros.
 simpl in H1.
 elim (access_diam_some _ _ _ _ _ _ H2).
 intros Gamma H3; decompose [and] H3; clear H3.
 injection H4; intros; subst; eauto.
Qed.

Lemma access_subCont:forall (decI:eqdec I)(decJ :eqdec
J)(rp:rule_pattern I J)(Gamma:context I J A W) l i,
               allDistinctLeaves rp->
               hasSubContexts rp Gamma l->
               i<length l->
               (exists n:nat,(exists Delta:context I J A W,
               (nth_error (flatten_pattern rp) i)=Some n /\
                access decI decJ rp n Gamma=(Some Delta,true)/\
                nth_error l i=Some Delta)).

Proof.
 intros.
 rewrite (subCont_length H0) in H1.
 elim (nth_error_length _ H1).
 intros n H2.
 exists n.
 elim
 (acces_same_shape decI decJ _ H (nth_flatten_leaf _ _ H2)
    (same_shape_SubCont H0)).
 intros Delta H3.
 exists Delta.
 split.
 auto.
 split.
 auto.
 eapply access_sub_cont; eauto.
Qed.

Lemma access_eq_apply:forall decI decJ (rp1 rp2:rule_pattern I J)(T1
                      T2 T:context I J A W) (i:nat),
                      apply_rule (rp1 , rp2) decI decJ T1 =Some T2->
                      access decI decJ rp2 i T2=(Some T,true)->
                      access decI decJ rp1 i T1=(Some T,true).
Proof.
 intros decI decJ rp1 rp2; elim rp2.
 simpl in |- *.
 intros n T1 T2 T i.
 case (eq_nat_dec n i).
 intro; subst.
 elim (access_dec rp1 decI decJ i T1).
 intro H; elim H.
 clear H; intros T' H.
 rewrite H.
 injection 1; intros; subst; auto.
 intro H; elim H; clear H; intros b H; rewrite H.
 discriminate 1.
 discriminate 3.
 intros.
 elim (apply_rule_com _ _ _ _ _ _ _ H1).
 intros T' H3.
 elim H3; clear H3; intros T1' H3.
 elim H3; clear H3; intros H3 H4; elim H4; clear H4; intros H4 H5.
 subst.
 elim (access_com_some _ _ _ _ _ _ _ H2).
 intros Gamma1 H3.
 elim H3; clear H3; intros Gamma2 H3.
 elim H3; clear H3; intro H3.
 intro H6; elim H6; clear H6; intro H6; elim H6; clear H6; intros H6 H7.
 injection H3; intros; subst.
 eauto.
 injection H3; intros; subst; eauto.
 intros.
 elim (apply_rule_diam _ _ _ _ _ _ H0).
 intros T' H2; elim H2; clear H2; intros.
 subst.
 elim (access_diam_some _ _ _ _ _ _ H1).
 intros Gamma H2; elim H2; clear H2; intros.
 injection H2; intros; subst; eauto.
Qed.

Lemma permut_sub_cont:forall decI decJ (rp1 rp2:rule_pattern I J)(T1
                      T2 :context I J A W)l1 l2,
                         allDistinctLeaves rp1->
                         allDistinctLeaves rp2->
                        permut (flatten_pattern rp1) (flatten_pattern rp2)->
                        apply_rule  (rp1 , rp2) decI decJ T1 =Some T2->
                        hasSubContexts rp1 T1 l1->
                        hasSubContexts rp2 T2 l2->
                        permut l1 l2.
Proof.

 intros.
 pose (f := fun n : nat => let (p1, _) := access decI decJ rp1 n T1 in p1).
 cut (permut (map f (flatten_pattern rp1)) (map f (flatten_pattern rp2))).
 intro.
 eapply permut_extract.
 eexact H5.
 apply extract_forall.
 rewrite (subCont_length H3).
 rewrite map_length; auto.
 intros.
 assert (i < length l1).
 eapply nth_error_some_length.
 eauto.
 elim (access_subCont decI decJ H H3 H7).
 intros n H8; decompose [ex] H8.
 clear H8.
 decompose [and] H9; clear H9.
 rewrite (nth_map f _ _ H8).
 unfold f in |- *; simpl in |- *.
 rewrite H11.
 rewrite H12 in H6; injection H6.
 intro; subst; auto.
 apply extract_forall.
 rewrite (subCont_length H4).
 rewrite map_length; auto.
 intros.
 assert (i < length l2).
 eapply nth_error_some_length; eauto.
 elim (access_subCont decI decJ H0 H4 H7); intros.
 decompose [ex and] H8; clear H8.
 rewrite (nth_map f _ _ H10).
 unfold f in |- *; simpl in |- *.
 rewrite (access_eq_apply _ _ _ _ _ _ H2 H9).
 rewrite H12 in H6; injection H6; intro; subst; auto.
 apply map_permut; auto.
Qed.

End props.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ProofTheory.BasicDeduction.
Require Import Logic.GeneralLogic.ProofTheory.BasicLogicEquiv.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.
Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.ProofTheory.ProofRules.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import CoqPropInLogicNotation.
Import SeparationLogicNotation.

Class SepconAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  sepcon_comm_impp: forall x y, |-- x * y --> y * x;
  sepcon_assoc1: forall x y z, |-- x * (y * z) --> (x * y) * z;
  sepcon_mono: forall x1 x2 y1 y2, |-- x1 --> x2 -> |-- y1 --> y2 -> |-- (x1 * y1) --> (x2 * y2);
}.

Class SepconOrAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {orpL: OrLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  orp_sepcon_impp: forall (x y z: expr),
    |-- (x || y) * z --> x * z || y * z
}.

Class SepconCoqPropAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {iffpL: IffLanguage L}
        {coq_prop_L: CoqPropLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  prop_andp_sepcon1: forall P Q R,
    |-- (!! P && Q) * R <--> !! P && (Q * R)
}.

Class SepconFalseAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {falsepL: FalseLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  falsep_sepcon_impp: forall (x: expr),
    |-- FF * x --> FF
}.

Class EmpAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
    sepcon_emp1: forall x, |-- x * emp --> x;
    sepcon_emp2: forall x, |-- x --> x * emp
}.

Class WandAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        (Gamma: Provable L) := {
  wand_sepcon_adjoint: forall x y z, |-- x * y --> z <-> |-- x --> (y -* z)
}.

Class ExtSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {trueL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  sepcon_ext: forall x, |-- x --> x * TT
}.

Class NonsplitEmpSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  emp_sepcon_truep_elim: forall x, |-- (x * TT) && emp --> x
}.

Class DupEmpSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  emp_dup: forall x, |-- x && emp --> x * x
}.

(* Only for documentation *)
Class MallocFreeSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  MallocFreeSeparationLogic_NonsplitEmpSeparationLogic :>
    NonsplitEmpSeparationLogic L Gamma;
  MallocFreeSeparationLogic_DupEmpSeparationLogic :>
    DupEmpSeparationLogic L Gamma
}.

Class GarbageCollectSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  sepcon_elim1: forall x y, |-- x * y --> x
}.

Class SepconDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_sepcon_comm: forall x y, x * y |-- y * x;
  derivable1_sepcon_assoc1: forall x y z, x * (y * z) |-- (x * y) * z;
  derivable1_sepcon_mono: forall x1 x2 y1 y2, x1 |-- x2 -> y1 |-- y2
               -> (x1 * y1) |-- (x2 * y2);
}.

Class SepconOrDeduction
        (L: Language)
        {orpL: OrLanguage L}
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  orp_sepcon_left: forall x y z,
     (x || y) * z |-- x * z || y * z
}.

Class SepconFalseDeduction
        (L: Language)
        {falsepL: FalseLanguage L}
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  falsep_sepcon_left: forall x,
     FF * x |-- FF
}.

Class EmpDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (GammaD1: Derivable1 L) := {
    sepcon_emp_left: forall x,  x * emp |-- x;
    sepcon_emp_right: forall x, x |-- x * emp
}.

Class WandDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_wand_sepcon_adjoint: forall x y z, x * y  |-- z <-> x |-- (y -* z)
}.

Class ExtSeparationLogicDeduction
        (L: Language)
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_sepcon_ext: forall x, x |-- x * TT
}.

Class NonsplitEmpSeparationLogicDeduction
        (L: Language)
        {andpL: AndLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_emp_sepcon_truep_elim: forall x, (x * TT) && emp |-- x
}.

Class DupEmpSeparationLogicDeduction
        (L: Language)
        {andpL: AndLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_emp_dup: forall x, x && emp |-- x * x
}.

Class GarbageCollectSeparationLogicDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_sepcon_elim1: forall x y, x * y |-- x
}.

Section SepconRules.

Context {L: Language}
        {sepconL: SepconLanguage L}
        {GammaD1: Derivable1 L}
        {bD: BasicDeduction L GammaD1}
        {sepconD: SepconDeduction L GammaD1}.

Lemma derivable1_sepcon_Comm: D1.Commutativity L GammaD1 sepcon.
Proof.
  constructor.
  intros.
  apply derivable1_sepcon_comm.
Qed.

Lemma derivable1_sepcon_Mono: D1.Monotonicity L GammaD1 sepcon.
Proof.
  constructor.
  intros.
  apply derivable1_sepcon_mono; auto.
Qed.

Lemma derivable1_sepcon_Assoc: D1.Associativity L GammaD1 sepcon.
Proof.
  apply @D1.Build_Associativity1; auto.
  + apply derivable1_sepcon_Comm.
  + apply derivable1_sepcon_Mono.
  + intros.
    apply derivable1_sepcon_assoc1.
Qed.

Lemma derivable1_sepcon_assoc2: forall x y z, (x * y) * z |-- x * (y * z).
Proof.
  intros.
  apply (@D1.prodp_assoc2 _ _ _ derivable1_sepcon_Assoc).
Qed.

Lemma orp_sepcon_right
      {orpL: OrLanguage L}
      {orpD: OrDeduction L GammaD1}:
  forall (x y z: expr), x * z || y * z |-- (x || y) * z.
Proof.
  intros.
  apply derivable1_orp_elim; apply derivable1_sepcon_mono.
  - apply derivable1_orp_intros1.
  - reflexivity.
  - apply derivable1_orp_intros2.
  - reflexivity.
Qed.

Lemma falsep_sepcon_right
      {falsepL: FalseLanguage L}
      {falsepD: FalseDeduction L GammaD1}:
  forall (x: expr), FF |-- FF * x.
Proof.
  intros.
  apply derivable1_falsep_elim.
Qed.

Section emp.

Context {empL: EmpLanguage L}
        {empD: EmpDeduction L GammaD1}.

Lemma derivable1_sepcon_LU: D1.LeftUnit L GammaD1 emp sepcon.
Proof.
  constructor; intros.
  + rewrite derivable1_sepcon_comm.
    apply sepcon_emp_left.
  + rewrite <- derivable1_sepcon_comm.
    apply sepcon_emp_right.
Qed.

Lemma derivable1_sepcon_RU: D1.RightUnit L GammaD1 emp sepcon.
Proof.
  constructor; intros.
  intros.
  + apply sepcon_emp_left.
  + apply sepcon_emp_right.
Qed.

End emp.

Context {GammaE: LogicEquiv L}
        {GammED1: EquivDerivable1 L GammaD1 GammaE}
        {bE: BasicLogicEquiv L GammaE}.

Lemma sepcon_comm_logic_equiv:
  forall (x y: expr), x * y --||-- y * x.
Proof.
  intros.
  apply (@D1.prodp_comm _ _ _ _ _ derivable1_sepcon_Comm).
Qed.

Lemma sepcon_assoc_logic_equiv:
  forall x y z, x * (y * z) --||-- (x * y) * z.
Proof.
  intros.
  apply (@D1.prodp_assoc _ _ _ _ _ derivable1_sepcon_Assoc).
Qed.

Section emp.

Context {empL: EmpLanguage L}
        {empD: EmpDeduction L GammaD1}.

Lemma sepcon_emp_logic_equiv: forall x, x * emp --||-- x.
Proof. apply (@D1.right_unit _ _ _ _ _ _ derivable1_sepcon_RU). Qed.

Lemma emp_sepcon_logic_equiv: forall x, emp * x --||-- x.
Proof. apply (@D1.left_unit _ _ _ _ _ _ derivable1_sepcon_LU). Qed.

End emp.

Context {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {orpD: OrDeduction L GammaD1}
        {falsepD: FalseDeduction L GammaD1}
        {sepcon_orp_D: SepconOrDeduction L GammaD1}
        {sepcon_falsep_D: SepconFalseDeduction L GammaD1}.

Lemma derivable1_sepcon_orp_RDistr: D1.RightDistr L GammaD1 sepcon orp.
Proof.
  constructor; intros.
  + apply orp_sepcon_left.
  + apply orp_sepcon_right.
Qed.

Lemma derivable1_sepcon_orp_LDistr: D1.LeftDistr L GammaD1 sepcon orp.
Proof.
  apply @D1.RightDistr2LeftDistr; auto.
  + apply derivable1_sepcon_Comm.
  + apply derivable1_orp_Mono.
  + apply derivable1_sepcon_orp_RDistr.
Qed.

Lemma sepcon_orp_distr_r: forall (x y z: expr),
  (x || y) * z --||-- x * z || y * z.
Proof.
  intros.
  apply (@D1.prodp_sump_distr_r _ _ _ _ _ _ derivable1_sepcon_orp_RDistr).
Qed.

Lemma sepcon_orp_distr_l: forall (x y z: expr),
  x * (y || z) --||-- x * y || x * z.
Proof.
  intros.
  apply (@D1.prodp_sump_distr_l _ _ _ _ _ _ derivable1_sepcon_orp_LDistr).
Qed.

Lemma falsep_sepcon_logic_equiv: forall (x: expr),
  FF * x --||-- FF.
Proof.
  intros.
  apply logic_equiv_derivable1; split.
  + apply falsep_sepcon_left.
  + apply falsep_sepcon_right.
Qed.

Lemma sepcon_falsep_logic_equiv: forall (x: expr),
  x * FF --||-- FF.
Proof.
  intros.
  rewrite sepcon_comm_logic_equiv.
  apply falsep_sepcon_logic_equiv.
Qed.

End SepconRules.

(*
(** Proof rules for cancel. **)

Lemma cancel_ready: forall x y, |-- x * emp --> y -> |-- x --> y.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- sepcon_emp2 in H.
  auto.
Qed.

Lemma cancel_one_succeed: forall u x y z,
  |-- x * y --> z -> |-- (u * x) * y --> u * z.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite sepcon_assoc2.
  apply sepcon_mono; auto.
  apply provable_impp_refl.
Qed.

Lemma cancel_one_giveup: forall x y z w v,
  |-- x * (y * z) --> w * v-> |-- (y * x) * z --> w * v.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp y x.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite H1.
  apply sepcon_assoc2.
Qed.

Lemma cancel_rev: forall x y z w,  |-- (y * x) * z --> w -> |-- x * (y * z) --> w.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp x y.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite <- H1.
  apply sepcon_assoc1.
Qed.

Lemma cancel_finish: forall x, |-- x * emp --> x.
Proof.
  apply sepcon_emp1.
Qed.

End SepconRules.
*)
Section WandRules.

Context {L: Language}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {GammaD1: Derivable1 L}
        {bD: BasicDeduction L GammaD1}
        {wandD: WandDeduction L GammaD1}.

Lemma derivable1_wand_sepcon_Adj: D1.Adjointness L GammaD1 sepcon wand.
Proof.
  constructor.
  intros.
  apply derivable1_wand_sepcon_adjoint.
Qed.

Lemma derivable1_wand_sepcon_modus_ponens1: forall (x y: expr),
  (x -* y) * x |-- y.
Proof.
  intros.
  apply (@D1.adjoint_modus_ponens _ _ _ _ _ derivable1_wand_sepcon_Adj).
Qed.

Context {sepconD: SepconDeduction L GammaD1}.

Lemma derivable1_wand_sepcon_modus_ponens2: forall (x y: expr),
  x * (x -* y) |-- y.
Proof.
  intros.
  rewrite (derivable1_sepcon_comm x (x -* y)).
  apply derivable1_wand_sepcon_modus_ponens1.
Qed.

Lemma derivable1_wand_mono: forall x1 x2 y1 y2,
  x2 |-- x1 -> y1 |-- y2 -> x1 -* y1 |-- x2 -* y2.
Proof.
  intros.
  apply (@D1.funcp_mono _ _ _ _ _ derivable1_wand_sepcon_Adj derivable1_sepcon_Mono); auto.
Qed.

Context {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {GammaE: LogicEquiv L}
        {GammED1: EquivDerivable1 L GammaD1 GammaE}
        {bE: BasicLogicEquiv L GammaE}
        {andpD: AndDeduction L GammaD1}
        {orpD: OrDeduction L GammaD1}
        {sepcon_orp_D: SepconOrDeduction L GammaD1}.

Lemma wand_andp_logic_equiv: forall x y z: expr,
  x -* y && z --||-- (x -* y) && (x -* z).
Proof.
  intros.
  apply (@D1.funcp_andp_distr_r _ _ _ _ _ _ _ derivable1_wand_sepcon_Adj); auto.
Qed.

Lemma orp_wand_logic_equiv: forall x y z: expr,
  (x || y) -* z --||-- (x -* z) && (y -* z).
Proof.
  intros.
  apply (@D1.orp_funcp _ _ _ _ _ _ _ _ _ _ derivable1_wand_sepcon_Adj _ _ derivable1_sepcon_Comm); auto.
Qed.

Lemma derivable1_sepcon_elim2: forall {gcsD: GarbageCollectSeparationLogicDeduction L GammaD1} (x y: expr),
  x * y |-- y.
Proof.
  intros.
  rewrite (derivable1_sepcon_comm x y).
  apply derivable1_sepcon_elim1.
Qed.

Lemma derivable1_emp_sepcon_elim1
      {truepL: TrueLanguage L}
      {empL: EmpLanguage L}
      {truepD: TrueDeduction L GammaD1}
      {empD: EmpDeduction L GammaD1}
      {nssD: NonsplitEmpSeparationLogicDeduction L GammaD1}:
  forall x y, x * y && emp |-- x.
Proof.
  intros.
  rewrite <- (derivable1_emp_sepcon_truep_elim x) at 2.
  apply andp_proper_derivable1; [| reflexivity].
  apply derivable1_sepcon_mono; [reflexivity |].
  apply derivable1_truep_intros.
Qed.

Lemma derivable1_emp_sepcon_elim2
      {truepL: TrueLanguage L}
      {empL: EmpLanguage L}
      {truepD: TrueDeduction L GammaD1}
      {empD: EmpDeduction L GammaD1}
      {nssD: NonsplitEmpSeparationLogicDeduction L GammaD1}:
  forall x y, x * y && emp |-- y.
Proof.
  intros.
  rewrite derivable1_sepcon_comm.
  apply derivable1_emp_sepcon_elim1.
Qed.

End WandRules.

Section Axiomatization2Deduction.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {GammaP: Provable L}
        {GammaD1: Derivable1 L}
        {GammaD1P: Derivable1Provable L GammaP GammaD1}
        {minAX: MinimumAxiomatization L GammaP}
        {sepconAX: SepconAxiomatization L GammaP}.

Lemma Axiomatization2Deduction_sepconD: SepconDeduction L GammaD1.
Proof.
  constructor; intros.
  + apply derivable1_provable.
    apply sepcon_comm_impp.
  + apply derivable1_provable.
    apply sepcon_assoc1.
  + rewrite derivable1_provable in H, H0 |- *.
    apply sepcon_mono; auto.
Qed.

Lemma Axiomatization2Deduction_wandD
      {wandL: WandLanguage L}
      {wandAX: WandAxiomatization L GammaP}:
  WandDeduction L GammaD1.
Proof.
  constructor; intros.
  rewrite !derivable1_provable.
  apply wand_sepcon_adjoint.
Qed.

Lemma Axiomatization2Deduction_empD
      {empL: EmpLanguage L}
      {empAX: EmpAxiomatization L GammaP}:
  EmpDeduction L GammaD1.
Proof.
  constructor; intros.
  + rewrite derivable1_provable.
    apply sepcon_emp1.
  + rewrite derivable1_provable.
    apply sepcon_emp2.
Qed.

End Axiomatization2Deduction.

Section SepconRules.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {sepconAX: SepconAxiomatization L Gamma}.

Lemma sepcon_Comm: P.Commutativity L Gamma sepcon.
Proof.
  constructor.
  intros.
  apply sepcon_comm_impp.
Qed.

Lemma sepcon_Mono: P.Monotonicity L Gamma sepcon.
Proof.
  constructor.
  intros.
  apply sepcon_mono; auto.
Qed.

Lemma sepcon_Assoc: P.Associativity L Gamma sepcon.
Proof.
  apply @P.Build_Associativity1; auto.
  + apply sepcon_Comm.
  + apply sepcon_Mono.
  + intros.
    apply sepcon_assoc1.
Qed.

Lemma sepcon_assoc2: forall x y z, |-- (x * y) * z --> x * (y * z).
Proof.
  intros.
  apply (@P.prodp_assoc2 _ _ _ _ sepcon_Assoc).
Qed.

Context {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {andpAX: AndAxiomatization L Gamma}
        {orpAX: OrAxiomatization L Gamma}
        {falsepAX: FalseAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {iffpAX: IffAxiomatization L Gamma}
        {truepAX: TrueAxiomatization L Gamma}.

Lemma sepcon_comm:
  forall (x y: expr), |-- x * y <--> y * x.
Proof.
  intros.
  apply (@P.prodp_comm _ _ _ _ _ _ _ sepcon_Comm).
Qed.

Lemma sepcon_assoc:
  forall x y z, |-- x * (y * z) <--> (x * y) * z.
Proof.
  intros.
  apply (@P.prodp_assoc _ _ _ _ _ _ _ sepcon_Assoc).
Qed.

Lemma impp_orp_sepcon:
  forall (x y z: expr), |-- x * z || y * z --> (x || y) * z.
Proof.
  intros.
  apply solve_orp_impp; apply sepcon_mono.
  - apply orp_intros1.
  - apply provable_impp_refl.
  - apply orp_intros2.
  - apply provable_impp_refl.
Qed.

Lemma impp_falsep_sepcon:
  forall (x: expr),|-- FF --> FF * x.
Proof.
  intros.
  apply falsep_elim.
Qed.

Context {sepcon_orp_AX: SepconOrAxiomatization L Gamma}
        {sepcon_false_AX: SepconFalseAxiomatization L Gamma}.

Lemma sepcon_orp_RDistr: P.RightDistr L Gamma sepcon orp.
Proof.
  constructor; intros.
  + apply orp_sepcon_impp.
  + apply impp_orp_sepcon.
Qed.

Lemma sepcon_orp_LDistr: P.LeftDistr L Gamma sepcon orp.
Proof.
  apply @P.RightDistr2LeftDistr; auto.
  + apply sepcon_Comm.
  + apply orp_Mono.
  + apply sepcon_orp_RDistr.
Qed.

Lemma sepcon_orp_distr_r_iffp: forall (x y z: expr),
  |-- (x || y) * z <--> x * z || y * z.
Proof.
  intros.
  apply (@P.prodp_sump_distr_r _ _ _ _ _ _ _ _ sepcon_orp_RDistr).
Qed.

Lemma sepcon_orp_distr_l_iffp: forall (x y z: expr),
  |-- x * (y || z) <--> x * y || x * z.
Proof.
  intros.
  apply (@P.prodp_sump_distr_l _ _ _ _ _ _ _ _ sepcon_orp_LDistr).
Qed.

Lemma falsep_sepcon: forall (x: expr),
  |-- FF * x <--> FF.
Proof.
  intros.
  apply solve_iffp_intros.
  + apply falsep_sepcon_impp.
  + apply impp_falsep_sepcon.
Qed.

Lemma sepcon_falsep: forall (x: expr),
  |-- x * FF <--> FF.
Proof.
  intros.
  rewrite sepcon_comm.
  apply falsep_sepcon.
Qed.

Context {empL: EmpLanguage L}
        {empAX: EmpAxiomatization L Gamma}.

Lemma sepcon_emp: forall x, |-- x * emp <--> x.
Proof.
  intros.
  apply solve_iffp_intros.
  + apply sepcon_emp1.
  + apply sepcon_emp2.
Qed.

Lemma sepcon_LU: P.LeftUnit L Gamma emp sepcon.
Proof.
  apply P.Build_LeftUnit; intros.
  + rewrite sepcon_comm_impp.
    apply sepcon_emp1.
  + rewrite <- sepcon_comm_impp.
    apply sepcon_emp2.
Qed.

Lemma sepcon_RU: P.RightUnit L Gamma emp sepcon.
Proof.
  apply P.Build_RightUnit.
  intros.
  + apply sepcon_emp1.
  + apply sepcon_emp2.
Qed.

(** Proof rules for cancel. **)

Lemma cancel_ready: forall x y, |-- x * emp --> y -> |-- x --> y.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- sepcon_emp2 in H.
  auto.
Qed.

Lemma cancel_one_succeed: forall u x y z,
  |-- x * y --> z -> |-- (u * x) * y --> u * z.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite sepcon_assoc2.
  apply sepcon_mono; auto.
  apply provable_impp_refl.
Qed.

Lemma cancel_one_giveup: forall x y z w v,
  |-- x * (y * z) --> w * v-> |-- (y * x) * z --> w * v.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp y x.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite H1.
  apply sepcon_assoc2.
Qed.

Lemma cancel_rev: forall x y z w,  |-- (y * x) * z --> w -> |-- x * (y * z) --> w.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp x y.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite <- H1.
  apply sepcon_assoc1.
Qed.

Lemma cancel_finish: forall x, |-- x * emp --> x.
Proof.
  apply sepcon_emp1.
Qed.

End SepconRules.

Section WandRules.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {wandAX: WandAxiomatization L Gamma}.

Lemma wand_sepcon_Adj: P.Adjointness L Gamma sepcon wand.
Proof.
  constructor.
  intros.
  apply wand_sepcon_adjoint.
Qed.

Lemma provable_wand_sepcon_modus_ponens1: forall (x y: expr),
  |-- (x -* y) * x --> y.
Proof.
  intros.
  apply (@P.adjoint_modus_ponens _ _ _ _ _ _ wand_sepcon_Adj).
Qed.

Context {sepconAX: SepconAxiomatization L Gamma}.

Lemma provable_wand_sepcon_modus_ponens2: forall (x y: expr),
  |-- x * (x -* y) --> y.
Proof.
  intros.
  rewrite (sepcon_comm_impp x (x -* y)).
  apply provable_wand_sepcon_modus_ponens1.
Qed.

Lemma wand_mono: forall x1 x2 y1 y2,
  |-- x2 --> x1 -> |-- y1 --> y2 -> |-- (x1 -* y1) --> (x2 -* y2).
Proof.
  intros.
  apply (@P.funcp_mono _ _ _ _ _ _ wand_sepcon_Adj sepcon_Mono); auto.
Qed.

Context {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {andpAX: AndAxiomatization L Gamma}
        {orpAX: OrAxiomatization L Gamma}
        {falsepAX: FalseAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {iffpAX: IffAxiomatization L Gamma}
        {truepAX: TrueAxiomatization L Gamma}
        {sepcon_orp_AX: SepconOrAxiomatization L Gamma}
        {sepcon_false_AX: SepconFalseAxiomatization L Gamma}.

Lemma wand_andp: forall x y z: expr,
  |-- x -* y && z <--> (x -* y) && (x -* z).
Proof.
  intros.
  apply (@P.funcp_andp_distr_r _ _ _ _ _ _ wand_sepcon_Adj); auto.
Qed.

Lemma orp_wand: forall x y z: expr,
  |-- (x || y) -* z <--> (x -* z) && (y -* z).
Proof.
  intros.
  apply (@P.orp_funcp _ _ _ _ _ _ _ _ wand_sepcon_Adj _ _ _ _ sepcon_Comm); auto.
Qed.

Lemma sepcon_elim2: forall {gcsGamma: GarbageCollectSeparationLogic L Gamma} (x y: expr),
  |-- x * y --> y.
Proof.
  intros.
  rewrite (sepcon_comm_impp x y).
  apply sepcon_elim1.
Qed.

Lemma emp_sepcon_elim1: forall {empL: EmpLanguage L} {empAX: EmpAxiomatization L Gamma} {nssGamma: NonsplitEmpSeparationLogic L Gamma} x y,
  |-- x * y && emp --> x.
Proof.
  intros.
  rewrite <- (emp_sepcon_truep_elim x) at 2.
  apply andp_proper_impp; [| apply provable_impp_refl].
  apply sepcon_mono; [apply provable_impp_refl |].
  apply solve_impp_elim_left, provable_truep.
Qed.

Lemma emp_sepcon_elim2: forall {empL: EmpLanguage L} {empAX: EmpAxiomatization L Gamma} {nssGamma: NonsplitEmpSeparationLogic L Gamma} x y,
  |-- x * y && emp --> y.
Proof.
  intros.
  rewrite sepcon_comm.
  apply emp_sepcon_elim1.
Qed.

End WandRules.


(** printing ⊢#    %\vdash_{\#}%    #⊢##     *)
(** printing ⊢##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing ⊢##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing ⊢!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

(** * Tight typing ⊢#] *)

Set Implicit Arguments.

Require Import Coq.Program.Equality.
Require Import Definitions PreciseTyping.

Reserved Notation "G '⊢#' t ':' T" (at level 40, t at level 59).
Reserved Notation "G '⊢#' T '<:' U" (at level 40, T at level 59).

(** Tight typing is very similar to general typing, and could be obtained by replacing
    all occurrences of [⊢] with [⊢#], except for the following:
    - in the type selection subtyping rules Sel-<: and <:-Sel ([subtyp_sel1], [subtyp_sel2])
      the premise is precise typing of a type declaration with equal bounds;
    - in the singleton subtyping rules Sngl-<: and <:-Sngl ([subtyp_sngl_pq], and [subtyp_sngl_qp])
      the premise is precise typing;
    - whenever a typing judgement in a premise extends the environment (for example, [ty_all_intro_t]),
      it is typed under general typing [⊢] and not tight typing [⊢#]. *)

Inductive ty_trm_t : ctx -> trm -> typ -> Prop :=

(** [G(x) = T]   #
#
    [――――――――――] #
#
    [G ⊢# x: T]  *)
| ty_var_t : forall G x T,
    binds x T G ->
    G ⊢# tvar x : T

(** [G, x: T ⊢ t^x: U^x]       #
#
    [x fresh]                  #
#
    [――――――――――――――――――――――――] #
#
    [G ⊢# lambda(T)t: forall(T)U]     *)
| ty_all_intro_t : forall G t T U L,
    (forall x, x \notin L ->
      G & x ~ T ⊢ open_trm x t : open_typ x U) ->
    G ⊢# trm_val (λ(T) t) : ∀(T) U

(** [G ⊢# p: forall(S)T]  #
#
    [G ⊢# q: S]      #
#
    [―――――――――――――――] #
#
    [G ⊢ p q: T^q]    *)
| ty_all_elim_t : forall G p q S T,
    G ⊢# trm_path p : ∀(S) T ->
    G ⊢# trm_path q : S ->
    G ⊢# trm_app p q : open_typ_p q T

(** [z; G, z: T^z ⊢ ds^z :: T^z]    #
#
    [z fresh]                          #
#
    [―――――――――――――――――――――――――――――――]  #
#
    [G ⊢# nu(T)ds :: mu(T)]             *)
| ty_new_intro_t : forall G ds T L,
    (forall z, z \notin L ->
      z; nil; G & (z ~ open_typ z T) ⊢ open_defs z ds :: open_typ z T) ->
    G ⊢# trm_val (ν(T) ds) : μ T

(** [G ⊢# p: {a: T}] #
#
    [―――――――――――――]   #
#
    [G ⊢# p.a: T]        *)
| ty_new_elim_t : forall G p a T,
    G ⊢# trm_path p : typ_rcd {a ⦂ T} ->
    G ⊢# trm_path p • a : T

(** [G ⊢# p.a: T]      #
#
    [――――――――――――――]   #
#
    [G ⊢# p: {a: T}]        *)
| ty_rec_intro_t : forall G p a T,
    G ⊢# trm_path p•a : T ->
    G ⊢# trm_path p : typ_rcd { a ⦂ T }

(** [G ⊢# t: T]             #
#
    [G, x: T ⊢ u^x: U]       #
#
    [x fresh]                #
#
    [――――――――――――――――]       #
#
    [G ⊢# let t in u: U]        *)
| ty_let_t : forall G t u T U L,
    G ⊢# t : T ->
    (forall x, x \notin L ->
      G & x ~ T ⊢ open_trm x u : U) ->
    G ⊢# trm_let t u : U

(** [G ⊢# p: q.type]  #
#
    [G ⊢# q]          #
#
    [―――――――――――――――] #
#
    [G ⊢# p: T]            *)
| ty_sngl_t : forall G p q T,
    G ⊢# trm_path p : {{ q }} ->
    G ⊢# trm_path q : T ->
    G ⊢# trm_path p : T

(** [G ⊢# p.: T]       #
#
    [――――――――――――――]   #
#
    [G ⊢# p: {a: T}]        *)
| ty_path_elim_t : forall G p q a T,
    G ⊢# trm_path p : {{ q }} ->
    G ⊢# trm_path q • a : T ->
    G ⊢# trm_path p • a : {{ q•a }}

(** [G ⊢# p: T^p]   #
#
    [――――――――――――] #
#
    [G ⊢# p: mu(T)]     *)
| ty_rcd_intro_t : forall G p T,
    G ⊢# trm_path p : open_typ_p p T ->
    G ⊢# trm_path p : μ T

(** [G ⊢# p: mu(T)] #
#
    [――――――――――――] #
#
    [G ⊢# p: T^p]   *)
| ty_rec_elim_t : forall G p T,
    G ⊢# trm_path p : μ T ->
    G ⊢# trm_path p : open_typ_p p T

(** [G ⊢# p: T]     #
#
    [G ⊢# p: U]     #
#
    [――――――――――――] #
#
    [G ⊢# p: T /\ U]     *)
| ty_and_intro_t : forall G p T U,
    G ⊢# trm_path p : T ->
    G ⊢# trm_path p : U ->
    G ⊢# trm_path p : T ∧ U

(** [G ⊢# t: T]    #
#
    [G ⊢# T <: U]  #
#
    [―――――――――――――] #
#
    [G ⊢# t: U]        *)
| ty_sub_t : forall G t T U,
    G ⊢# t : T ->
    G ⊢# T <: U ->
    G ⊢# t : U
where "G '⊢#' t ':' T" := (ty_trm_t G t T)

(** *** Tight subtyping [G ⊢# T <: U] *)
with subtyp_t : ctx -> typ -> typ -> Prop :=

(** [G ⊢# T <: top] *)
| subtyp_top_t: forall G T,
    G ⊢# T <: ⊤

(** [G ⊢# bot <: T] *)
| subtyp_bot_t: forall G T,
    G ⊢# ⊥ <: T

(** [G ⊢# T <: T] *)
| subtyp_refl_t: forall G T,
    G ⊢# T <: T

(** [G ⊢# S <: T]     #
#
    [G ⊢# T <: U]     #
#
    [―――――――――――――]    #
#
    [G ⊢# S <: U]         *)
| subtyp_trans_t: forall G S T U,
    G ⊢# S <: T ->
    G ⊢# T <: U ->
    G ⊢# S <: U

(** [G ⊢# T /\ U <: T] *)
| subtyp_and11_t: forall G T U,
    G ⊢# T ∧ U <: T

(** [G ⊢# T /\ U <: U] *)
| subtyp_and12_t: forall G T U,
    G ⊢# T ∧ U <: U

(** [G ⊢# S <: T]       #
#
    [G ⊢# S <: U]       #
#
    [――――――――――――――――]   #
#
    [G ⊢# S <: T /\ U]       *)
| subtyp_and2_t: forall G S T U,
    G ⊢# S <: T ->
    G ⊢# S <: U ->
    G ⊢# S <: T ∧ U

(** [G ⊢# T <: U]           #
#
    [――――――――――――――――――――――] #
#
    [G ⊢# {a: T} <: {a: U}]     *)
| subtyp_fld_t: forall G T U a,
    G ⊢# T <: U ->
    G ⊢# typ_rcd {a ⦂ T} <: typ_rcd {a ⦂ U}

(** [G ⊢# S2 <: S1]                   #
#
    [G ⊢# T1 <: T2]                   #
#
    [――――――――――――――――――――――――――――――――] #
#
    [G ⊢# {A: S1..T1} <: {A: S2..T2}]     *)
| subtyp_typ_t: forall G S1 S2 T1 T2 A,
    G ⊢# S2 <: S1 ->
    G ⊢# T1 <: T2 ->
    G ⊢# typ_rcd { A >: S1 <: T1 } <: typ_rcd { A >: S2 <: T2 }

(** [G ⊢!!! p: q.type]                 #
#
    [G ⊢!!! q: U]                      #
#
    [――――――――――――――――――――――――――――――――] #
#
    [G ⊢# T <: [T[q/p,n]]              *)
| subtyp_sngl_pq_t : forall G p q T T' U,
    G ⊢!!! p : {{ q }} ->
    G ⊢!!! q : U ->
    repl_typ p q T T' ->
    G ⊢# T <: T'

(** [G ⊢!!! p: q.type]                 #
#
    [G ⊢!!! q: U]                      #
#
    [――――――――――――――――――――――――――――――――] #
#
    [G ⊢# T <: [T[p/q,n]]              *)
| subtyp_sngl_qp_t : forall G p q T T' U,
    G ⊢!!! p : {{ q }} ->
    G ⊢!!! q : U ->
    repl_typ q p T T' ->
    G ⊢# T <: T'

(** [G ⊢!!! p: {A: T..T}] #
#
    [―――――――――――――――――――] #
#
    [G ⊢# T <: p.A]         *)
| subtyp_sel2_t: forall G p A T ,
    G ⊢!!! p : typ_rcd { A >: T <: T } ->
    G ⊢# T <: p ↓ A

(** [G ⊢!!! p: {A: T..T}] #
#
    [―――――――――――――――――――] #
#
    [G ⊢# p.A <: T]         *)
| subtyp_sel1_t: forall G p A T,
    G ⊢!!! p : typ_rcd { A >: T <: T } ->
    G ⊢# p↓A <: T

(** [[
G ⊢# ∀(S1)T1 <: ∀(S2)T2
T1 and T2 is non-dependent
S2 is a trivial type
__________________________
G ⊢# T1 <: T2
]]
*)
(* | subtyp_all_inv2 : forall G S1 T1 S2 T2, *)
(*     G ⊢# ∀(S1)T1 <: ∀(S2)T2 -> *)
(*     (forall x, open_typ x T1 = T1) -> *)
(*     (forall x, open_typ x T2 = T2) -> *)
(*     trivial_typ S2 -> *)
(*     G ⊢# T1 <: T2 *)

(** [G ⊢# S2 <: S1]                #
#
    [G, x: S2 ⊢ T1^x <: T2^x]       #
#
    [x fresh]                       #
#
    [――――――――――――――――――――――――]      #
#
    [G ⊢# forall(S1)T1 <: forall(S2)T2]          *)
| subtyp_all_t: forall G S1 S2 T1 T2 L,
    G ⊢# S2 <: S1 ->
    (forall x, x \notin L ->
       G & x ~ S2 ⊢ open_typ x T1 <: open_typ x T2) ->
    G ⊢# ∀(S1) T1 <: ∀(S2) T2

where "G '⊢#' T '<:' U" := (subtyp_t G T U).

Hint Constructors ty_trm_t subtyp_t.

Scheme ts_ty_trm_mut_ts  := Induction for ty_trm_t    Sort Prop
with   ts_subtyp_ts      := Induction for subtyp_t    Sort Prop.
Combined Scheme ts_mutind_ts from ts_ty_trm_mut_ts, ts_subtyp_ts.

(** Tight typing implies general typing. *)
Lemma tight_to_general:
  (forall G t T,
     G ⊢# t : T ->
     G ⊢ t : T) /\
  (forall G S U,
     G ⊢# S <: U ->
     G ⊢ S <: U).
Proof.
  apply ts_mutind_ts; intros; subst; eauto using precise_to_general3.
  Unshelve.
  all: solve_ex_typ_L.
Qed.


Require Import Coq.Lists.List.
Require Import Lia.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Sum.
Require Import Crypto.Util.LetIn.
Require Crypto.Util.ListUtil. (* for tests *)

Section Loops.
  Context {continue_state break_state}
          (body : continue_state -> break_state + continue_state)
          (body_cps : continue_state ->
                  forall {T}, (break_state + continue_state -> T)
                              -> T).

  Definition funapp {A B} (f : A -> B) (x : A) := f x.

  Fixpoint loop_cps (fuel: nat) (start : continue_state)
           {T} (ret : break_state -> T) : continue_state + T :=
    funapp
    (body_cps start _) (fun next =>
                      match next with
                      | inl state => inr (ret state)
                      | inr state =>
                        match fuel with
                        | O => inl state
                        | S fuel' =>
                          loop_cps fuel' state ret
                        end end).

  Fixpoint loop (fuel: nat) (start : continue_state)
    : continue_state + break_state :=
    match (body start) with
    | inl state => inr state
    | inr state =>
      match fuel with
      | O => inl state
      | S fuel' => loop fuel' state
      end end.

  Lemma loop_break_step fuel start state :
    (body start = inl state) ->
    loop fuel start = inr state.
  Proof.
    destruct fuel; simpl loop; break_match; intros; congruence.
  Qed.

  Lemma loop_continue_step fuel start state :
    (body start = inr state) ->
    loop fuel start =
    match fuel with | O => inl state | S fuel' => loop fuel' state end.
  Proof.
    destruct fuel; simpl loop; break_match; intros; congruence.
  Qed.

  (* TODO: provide [invariant state] to proofs of this *)
  Definition progress (measure : continue_state -> nat) :=
    forall state state', body state = inr state' -> measure state' < measure state.
  Definition terminates fuel start := forall l, loop fuel start <> inl l.
  Lemma terminates_by_measure measure (H : progress measure) :
    forall fuel start, measure start <= fuel -> terminates fuel start.
  Proof.
    induction fuel; intros;
      repeat match goal with
             | _ => solve [ congruence | lia ]
             | _ => progress cbv [progress terminates] in *
             | _ => progress cbn [loop]
             | _ => progress break_match
             | H : forall _ _, body _ = inr _ -> _ , Heq : body _ = inr _ |- _ => specialize (H _ _ Heq)
             | _ => eapply IHfuel
    end.
  Qed.

  Definition loop_default fuel start default
    : break_state :=
    sum_rect
      (fun _ => break_state)
      (fun _ => default)
      (fun result => result)
      (loop fuel start).

  Lemma loop_default_eq fuel start default
        (Hterm : terminates fuel start) :
    loop fuel start = inr (loop_default fuel start default).
  Proof.
    cbv [terminates loop_default sum_rect] in *; break_match; congruence.
  Qed.

  Lemma invariant_iff fuel start default (H : terminates fuel start) P :
      P (loop_default fuel start default) <->
      (exists (inv : continue_state -> Prop),
          inv start
          /\ (forall s s', body s = inr s' -> inv s -> inv s')
          /\ (forall s s', body s = inl s' -> inv s -> P s')).
  Proof.
    split;
      [ exists (fun st => exists f e, (loop f st = inr e /\ P e ))
      | destruct 1 as [?[??]]; revert dependent start; induction fuel ];
      repeat match goal with
             | _ => solve [ trivial | congruence | eauto ]
             | _ => progress destruct_head' @ex
             | _ => progress destruct_head' @and
             | _ => progress intros
             | _ => progress cbv [loop_default terminates] in *
             | _ => progress cbn [loop] in *
             | _ => progress erewrite loop_default_eq by eassumption
             | _ => progress erewrite loop_continue_step in * by eassumption
             | _ => progress erewrite loop_break_step in * by eassumption
             | _ => progress break_match_hyps
             | _ => progress break_match
             | _ => progress eexists
             | H1:_, c:_ |- _ => progress specialize (H1 c); congruence
             end.
  Qed.
End Loops.

Definition by_invariant {continue_state break_state body fuel start default}
           invariant measure P invariant_start invariant_continue invariant_break le_start progress
  := proj2 (@invariant_iff continue_state break_state body fuel start default (terminates_by_measure body measure progress fuel start le_start) P)
           (ex_intro _ invariant (conj invariant_start (conj invariant_continue invariant_break))).
Arguments terminates_by_measure {_ _ _}.

Module while.
  Section While.
    Context {state}
            (test : state -> bool)
            (body : state -> state).

    Fixpoint while (fuel: nat) (s : state) {struct fuel} : state :=
      if test s
      then
        let s := body s in
        match fuel with
        | O => s
        | S fuel' => while fuel' s
        end
      else s.

    Section AsLoop.
      Local Definition lbody := fun s => if test s then inr (body s) else inl s.

      Lemma eq_loop : forall fuel start, while fuel start = loop_default lbody fuel start (while fuel start).
      Proof.
        induction fuel; intros;
          cbv [lbody loop_default sum_rect id] in *;
          cbn [while loop]; [|rewrite IHfuel]; break_match; auto.
      Qed.

      Lemma by_invariant fuel start
            (invariant : state -> Prop) (measure : state -> nat) (P : state -> Prop)
            (_: invariant start)
            (_: forall s, invariant s -> if test s then invariant (body s) else P s)
            (_: measure start <= fuel)
            (_: forall s, if test s then measure (body s) < measure s else True)
        : P (while fuel start).
      Proof.
        rewrite eq_loop; cbv [lbody].
        eapply (by_invariant invariant measure);
          repeat match goal with
                 | [ H : forall s, invariant s -> _, G: invariant ?s |- _ ] => unique pose proof (H _ G)
                 | [ H : forall s, if ?f s then _ else _, G: ?f ?s = _ |- _ ] => unique pose proof (H s)
                 | _ => solve [ trivial | congruence ]
                 | _ => progress cbv [progress]
                 | _ => progress intros
                 | _ => progress subst
                 | _ => progress inversion_sum
                 | _ => progress break_match_hyps (* FIXME: this must be last? *)
                 end.
      Qed.
    End AsLoop.
  End While.
  Arguments by_invariant {_ _ _ _ _}.
End while.
Notation while := while.while.

Definition for2 {state} (test : state -> bool) (increment body : state -> state)
  := while test (fun s => increment (body s)).

Definition for3 {state} init test increment body fuel :=
  @for2 state test increment body fuel init.

Module _test.
  Section GCD.
    Definition gcd_step :=
      fun '(a, b) => if Nat.ltb a b
                     then inr (a, b-a)
                     else if Nat.ltb b a
                          then inr (a-b, b)
                          else inl a.

    Definition gcd fuel a b := loop_default gcd_step fuel (a,b) 0.

    (* Eval cbv [gcd loop_default loop gcd_step] in (gcd 10 5 7). *)

    Example gcd_test : gcd 1000 28 35 = 7 := eq_refl.

    Definition gcd_step_cps
      : (nat * nat) -> forall T, (nat + (nat * nat) -> T) -> T
      :=
        fun st T ret =>
          let a := fst st in
          let b := snd st in
          if Nat.ltb a b
          then ret (inr (a, b-a))
          else if Nat.ltb b a
               then ret (inr (a-b, b))
               else ret (inl a).

    Definition gcd_cps fuel a b {T} (ret:nat->T)
      := loop_cps gcd_step_cps fuel (a,b) ret.

    Example gcd_test2 : gcd_cps 1000 28 35 id = inr 7 := eq_refl.

    (* Eval cbv [gcd_cps loop_cps gcd_step_cps id] in (gcd_cps 2 5 7 id). *)

  End GCD.

  (* simple example--set all elements in a list to 0 *)
  Section ZeroLoop.
    Import Crypto.Util.ListUtil.

    Definition zero_body (state : nat * list nat) :
      list nat + (nat * list nat) :=
      if dec (fst state < length (snd state))
      then inr (S (fst state), set_nth (fst state) 0 (snd state))
      else inl (snd state).

    Lemma zero_body_progress (arr : list nat) :
      progress zero_body (fun state : nat * list nat => length (snd state) - fst state).
    Proof.
      cbv [zero_body progress]; intros until 0;
        repeat match goal with
               | _ => progress autorewrite with cancel_pair distr_length
               | _ => progress subst
               | _ => progress break_match; intros
               | _ => congruence
               | H: inl _ = inl _ |- _ => injection H; intros; subst; clear H
               | H: inr _ = inr _ |- _ => injection H; intros; subst ;clear H
               | _ => lia
               end.
    Qed.

    Definition zero_loop (arr : list nat) : list nat :=
      loop_default zero_body (length arr) (0,arr) nil.

    Definition zero_invariant (state : nat * list nat) :=
      fst state <= length (snd state)
      /\ forall n, n < fst state -> nth_default 0 (snd state) n = 0.

    Lemma zero_correct (arr : list nat) :
      forall n, nth_default 0 (zero_loop arr) n = 0.
    Proof.
      intros. cbv [zero_loop].
      eapply (by_invariant zero_invariant); eauto using zero_body_progress;
        [ cbv [zero_invariant]; autorewrite with cancel_pair; split; intros; lia | ..];
        cbv [zero_invariant zero_body];
        intros until 0;
        break_match; intros;
          repeat match goal with
                 | _ => congruence
                 | H: inl _ = inl _ |- _ => injection H; intros; subst; clear H
                 | H: inr _ = inr _ |- _ => injection H; intros; subst ;clear H
                 | _ => progress split
                 | _ => progress intros
                 | _ => progress subst
                 | _ => progress (autorewrite with cancel_pair distr_length in * )
                 | _ => rewrite set_nth_nth_default by lia
                 | _ => progress break_match
                 | H : _ /\ _ |- _ => destruct H
                 | H : (_,_) = ?x |- _ =>
                   destruct x; inversion H; subst; destruct H
                 | H : _ |- _ => apply H; lia
                 | _ => lia
                 end.
      destruct (Compare_dec.lt_dec n (fst s)).
      apply H1; lia.
      apply nth_default_out_of_bounds; lia.
    Qed.
  End ZeroLoop.
End _test.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C Aprime Bprime Cprime : Universe, ((wd_ O Aprime /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ Aprime Bprime /\ (wd_ B C /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ A C /\ (wd_ O C /\ (wd_ O B /\ (wd_ O A /\ (wd_ B Aprime /\ (wd_ Bprime C /\ (wd_ Aprime C /\ (wd_ Bprime A /\ (col_ O A B /\ (col_ Aprime Bprime Cprime /\ (col_ O Aprime Bprime /\ col_ A B C)))))))))))))))))))) -> col_ O Aprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Hammer Require Import Hammer.

Set Implicit Arguments.

From QuicksortComplexity Require Import monads.

From QuicksortComplexity Require ne_tree.
From QuicksortComplexity Require Import util.

Definition C := ne_tree.T.

Definition ret {A: Set}: A -> C A := @ne_tree.Leaf A.

Fixpoint bind (A B: Set) (m: C A) (k: A -> C B): C B :=
match m with
| ne_tree.Leaf a => k a
| ne_tree.Node ts => ne_tree.Node (ne_list.map (fun x => bind x k) ts)
end.

Let runit (a b: Set) (x: a) (f: a -> C b): bind (ret x) f = f x.
Proof. hammer_hook "ne_tree_monad" "ne_tree_monad.runit". auto. Qed.

Fixpoint lunit A (f: C A) {struct f}: bind f ret = f :=
match f return bind f ret = f with
| ne_tree.Leaf x => refl_equal
| ne_tree.Node l =>
eq_ind_r (fun l0 => ne_tree.Node l0 = ne_tree.Node l) refl_equal
((fix F (l: ne_list.L (C A)) :=
match l return ne_list.map (fun u => bind u ret) l = l with
| ne_list.one x => eq_ind_r (fun c => ne_list.one c = ne_list.one x) refl_equal (lunit x)
| ne_list.cons x y => eq_ind_r (fun c => ne_list.cons c (ne_list.map (fun x => bind x ret) y) = ne_list.cons x y) (eq_ind_r (fun l => ne_list.cons x l = ne_list.cons x y) refl_equal (F y)) (lunit x)
end) l)
end.

Let assoc (a b c: Set) (n: C a) (f: a -> C b) (g: b -> C c):
bind (bind n f) g = bind n (fun x: a => bind (f x) g).
Proof with auto. hammer_hook "ne_tree_monad" "ne_tree_monad.assoc".
intros.
generalize n. clear n.
apply (ne_tree.alt_rect2 (fun n => bind (bind n f) g = bind n (fun x: a => bind (f x) g)) (fun l => ne_list.map (fun x => bind (bind x f) g) l = ne_list.map (fun x => bind x (fun x0 => bind (f x0) g)) l)); intros; simpl...
rewrite ne_list.map_map.
unfold compose.
rewrite H...
rewrite H...
rewrite H.
rewrite H0...
Qed.

Definition M: Monad := Build_Monad C bind (@ret) runit lunit assoc.

Lemma ext: extMonad M.
Proof with auto. hammer_hook "ne_tree_monad" "ne_tree_monad.ext".
unfold extMonad.
induction x using ne_tree.alt_ind; simpl...
replace (ne_list.map (fun x: C A => bind x f) l) with (ne_list.map (fun x: C A => bind x g) l)...
generalize H0. clear H0.
induction l; simpl; intros; rewrite H0...
rewrite IHl...
Qed.

Lemma bind_Leaf (A B: Set) (x: A) (f: A -> M B): bind (ne_tree.Leaf x) f = f x.
Proof. hammer_hook "ne_tree_monad" "ne_tree_monad.bind_Leaf". auto. Qed.

Lemma bind_Node (A B: Set) (x: ne_list.L (ne_tree.T A)) (f: A -> M B):
bind (ne_tree.Node x) f = ne_tree.Node (ne_list.map (fun x0: C A => bind x0 f) x).
Proof. hammer_hook "ne_tree_monad" "ne_tree_monad.bind_Node". auto. Qed.

Lemma bind_Node_one (X Y: Set) (t: M X) (g: X -> M Y):
bind (ne_tree.Node (ne_list.one t)) g = ne_tree.Node (ne_list.one (t >>= g)).
Proof. hammer_hook "ne_tree_monad" "ne_tree_monad.bind_Node_one". auto. Qed.

Lemma bind_Node_cons (X Y: Set) (t: M X) (l: ne_list.L (M X)) (g: X -> M Y):
bind (ne_tree.Node (ne_list.cons t l)) g = ne_tree.Node (ne_list.cons (bind t g) (ne_list.map (fun x => bind x g) l)).
Proof. hammer_hook "ne_tree_monad" "ne_tree_monad.bind_Node_cons". auto. Qed.

Lemma bind_map (X Y: Set) (f: X -> Y) (x: M X): bind x (ret ∘ f) = ne_tree.map f x.
Proof with try reflexivity. hammer_hook "ne_tree_monad" "ne_tree_monad.bind_map".
induction x...
simpl.
rewrite IHx...
simpl.
rewrite IHx.
f_equal.
simpl in IHx0.
inversion_clear IHx0...
Qed.

Definition deterministic (X: Set) (x: M X) (v: X): Prop := x = ne_tree.Leaf v.

Lemma deterministic_ret (A: Set) (a: A): deterministic (ret a) a.
Proof. hammer_hook "ne_tree_monad" "ne_tree_monad.deterministic_ret". unfold deterministic. auto. Qed.

Lemma ex_deterministic_ret (X: Set) (x: X): exists u, deterministic (ret x) u.
Proof. hammer_hook "ne_tree_monad" "ne_tree_monad.ex_deterministic_ret". intros. exists x. apply deterministic_ret. Qed.

Lemma deterministic_bind:
forall (A: Set) (a: M A) (z: A), deterministic a z ->
forall (B: Set) (b: A -> M B) (v: B), deterministic (b z) v ->
exists w, deterministic (a >>= b) w.
Proof with auto. hammer_hook "ne_tree_monad" "ne_tree_monad.deterministic_bind". unfold deterministic. intros. subst. simpl. exists v... Qed.

Lemma deterministic_bind_weak:
forall (A: Set) (a: M A) (z: A), deterministic a z ->
forall (B: Set) (b: A -> M B), (forall q, exists v, deterministic (b q) v) ->
exists w, deterministic (a >>= b) w.
Proof with auto. hammer_hook "ne_tree_monad" "ne_tree_monad.deterministic_bind_weak". intros. destruct (H0 z). apply (deterministic_bind H _ H1). Qed.

Lemma ex_deterministic_bind:
forall (A: Set) (a: M A) (z: A), deterministic a z ->
forall (B: Set) (b: A -> M B), (exists v, deterministic (b z) v) ->
exists w, deterministic (a >>= b) w.
Proof. hammer_hook "ne_tree_monad" "ne_tree_monad.ex_deterministic_bind". intros. destruct H0. apply (deterministic_bind H _ H0). Qed.

Lemma ex_deterministic_bind_weak:
forall (A: Set) (a: M A) (z: A), deterministic a z ->
forall (B: Set) (b: A -> M B), (forall q, exists v, deterministic (b q) v) ->
exists w, deterministic (a >>= b) w.
Proof. hammer_hook "ne_tree_monad" "ne_tree_monad.ex_deterministic_bind_weak". intros. apply (deterministic_bind_weak H). assumption. Qed.

Definition pick T: ne_list.L T -> M T := @ne_tree.Node T ∘ ne_list.map (@ne_tree.Leaf T).

Lemma In_bind_inv (X Y: Set) (f: X -> M Y) (x: M X) r:
ne_tree.In r (bind x f) -> exists z, ne_tree.In z x /\ ne_tree.In r (f z).
Proof with eauto. hammer_hook "ne_tree_monad" "ne_tree_monad.In_bind_inv".
induction x in r |- *...
simpl.
intros.
inversion_clear H.
inversion_clear H0.
destruct (IHx r H).
destruct H0...
intros.
inversion_clear H.
inversion_clear H0.
destruct (IHx r H).
destruct H0...
destruct (IHx0 r (ne_tree.InNode H)).
destruct H0.
inversion_clear H0...
Qed.

Lemma bind_eq (X X' Y XM: Set)
(f: X -> M Y) (f': X' -> M Y)
(xm: X -> XM) (xm': X' -> XM):
(forall p q, xm p = xm' q -> f p = f' q) ->
forall (x: M X) (x': M X'),
ne_tree.map xm x = ne_tree.map xm' x' ->
bind x f = bind x' f'.
Proof with auto. hammer_hook "ne_tree_monad" "ne_tree_monad.bind_eq".
induction x; simpl; destruct x'; simpl; intros; try discriminate.
apply H.
inversion_clear H0...
destruct l; simpl; intros.
simpl.
intros.
rewrite (IHx t)...
inversion_clear H0...
discriminate.
destruct l0.
discriminate.
simpl in H0.
simpl.
inversion H0.
clear H0.
f_equal.
replace (bind x f) with (bind t f').
Focus 2.
symmetry.
apply IHx...
replace (ne_list.map (fun x0: C X => bind x0 f) l) with (ne_list.map (fun x0: C X' => bind x0 f') l0)...
assert (ne_tree.map xm (ne_tree.Node l) = ne_tree.map xm' (ne_tree.Node l0)).
simpl.
rewrite H3...
cset (IHx0 (ne_tree.Node l0) H0).
inversion_clear H1...
Qed.

Lemma map_bind (X Y Z: Set) (f: Y -> Z) (g: X -> M Y) (x: M X):
ne_tree.map f (bind x g) =
bind x (fun xx => ne_tree.map f (g xx)).
Proof with auto. hammer_hook "ne_tree_monad" "ne_tree_monad.map_bind".
induction x...
simpl.
rewrite IHx...
simpl.
rewrite IHx.
f_equal.
simpl in IHx0.
inversion IHx0...
Qed.

Coercion ne_tree_isa_monad (A: Set) (a: ne_tree.T A): M A := a.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q Q0 R : Universe, ((wd_ A B /\ (wd_ C B /\ (wd_ P B /\ (wd_ A C /\ (wd_ P Q /\ (wd_ B Q /\ (wd_ B Q0 /\ (wd_ P C /\ (wd_ P Q0 /\ (wd_ C Q0 /\ (col_ Q P Q0 /\ (col_ R B C /\ col_ P R Q0)))))))))))) -> col_ P Q R)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C Aprime Bprime Cprime : Universe, ((wd_ O Aprime /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ Aprime Bprime /\ (wd_ B C /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ A C /\ (wd_ O B /\ (wd_ O A /\ (wd_ B Aprime /\ (wd_ Bprime C /\ (wd_ Aprime C /\ (wd_ Bprime A /\ (col_ O A B /\ (col_ Aprime Bprime Cprime /\ (col_ O Aprime Bprime /\ col_ A B C))))))))))))))))))) -> col_ O Cprime Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From iris.algebra Require Export ofe.
From iris.bi Require Export weakestpre.
From iris.prelude Require Import options.

Section language_mixin.
  Context {expr val state observation : Type}.
  Context (of_val : val → expr).
  Context (to_val : expr → option val).
  (** We annotate the reduction relation with observations [κ], which we will
     use in the definition of weakest preconditions to predict future
     observations and assert correctness of the predictions. *)
  Context (prim_step : expr → state → list observation → expr → state → list expr → Prop).

  Record LanguageMixin := {
    mixin_to_of_val v : to_val (of_val v) = Some v;
    mixin_of_to_val e v : to_val e = Some v → of_val v = e;
    mixin_val_stuck e σ κ e' σ' efs : prim_step e σ κ e' σ' efs → to_val e = None
  }.
End language_mixin.

Structure language := Language {
  expr : Type;
  val : Type;
  state : Type;
  observation : Type;
  of_val : val → expr;
  to_val : expr → option val;
  prim_step : expr → state → list observation → expr → state → list expr → Prop;
  language_mixin : LanguageMixin of_val to_val prim_step
}.

Bind Scope expr_scope with expr.
Bind Scope val_scope with val.

Global Arguments Language {_ _ _ _ _ _ _} _.
Global Arguments of_val {_} _.
Global Arguments to_val {_} _.
Global Arguments prim_step {_} _ _ _ _ _ _.

Canonical Structure stateO Λ := leibnizO (state Λ).
Canonical Structure valO Λ := leibnizO (val Λ).
Canonical Structure exprO Λ := leibnizO (expr Λ).

Definition cfg (Λ : language) := (list (expr Λ) * state Λ)%type.

Class LanguageCtx {Λ : language} (K : expr Λ → expr Λ) := {
  fill_not_val e :
    to_val e = None → to_val (K e) = None;
  fill_step e1 σ1 κ e2 σ2 efs :
    prim_step e1 σ1 κ e2 σ2 efs →
    prim_step (K e1) σ1 κ (K e2) σ2 efs;
  fill_step_inv e1' σ1 κ e2 σ2 efs :
    to_val e1' = None → prim_step (K e1') σ1 κ e2 σ2 efs →
    ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 κ e2' σ2 efs
}.

Global Instance language_ctx_id Λ : LanguageCtx (@id (expr Λ)).
Proof. constructor; naive_solver. Qed.

Inductive atomicity := StronglyAtomic | WeaklyAtomic.

Definition stuckness_to_atomicity (s : stuckness) : atomicity :=
  if s is MaybeStuck then StronglyAtomic else WeaklyAtomic.

Section language.
  Context {Λ : language}.
  Implicit Types v : val Λ.
  Implicit Types e : expr Λ.

  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. apply language_mixin. Qed.
  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof. apply language_mixin. Qed.
  Lemma val_stuck e σ κ e' σ' efs : prim_step e σ κ e' σ' efs → to_val e = None.
  Proof. apply language_mixin. Qed.

  Definition reducible (e : expr Λ) (σ : state Λ) :=
    ∃ κ e' σ' efs, prim_step e σ κ e' σ' efs.
  (* Total WP only permits reductions without observations *)
  Definition reducible_no_obs (e : expr Λ) (σ : state Λ) :=
    ∃ e' σ' efs, prim_step e σ [] e' σ' efs.
  Definition irreducible (e : expr Λ) (σ : state Λ) :=
    ∀ κ e' σ' efs, ¬prim_step e σ κ e' σ' efs.
  Definition stuck (e : expr Λ) (σ : state Λ) :=
    to_val e = None ∧ irreducible e σ.
  Definition not_stuck (e : expr Λ) (σ : state Λ) :=
    is_Some (to_val e) ∨ reducible e σ.

  (* [Atomic WeaklyAtomic]: This (weak) form of atomicity is enough to open
     invariants when WP ensures safety, i.e., programs never can get stuck.  We
     have an example in lambdaRust of an expression that is atomic in this
     sense, but not in the stronger sense defined below, and we have to be able
     to open invariants around that expression.  See `CasStuckS` in
     [lambdaRust](https://gitlab.mpi-sws.org/FP/LambdaRust-coq/blob/master/theories/lang/lang.v).

     [Atomic StronglyAtomic]: To open invariants with a WP that does not ensure
     safety, we need a stronger form of atomicity.  With the above definition,
     in case `e` reduces to a stuck non-value, there is no proof that the
     invariants have been established again. *)
  Class Atomic (a : atomicity) (e : expr Λ) : Prop :=
    atomic σ e' κ σ' efs :
      prim_step e σ κ e' σ' efs →
      if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e').

  Inductive step (ρ1 : cfg Λ) (κ : list (observation Λ)) (ρ2 : cfg Λ) : Prop :=
    | step_atomic e1 σ1 e2 σ2 efs t1 t2 :
       ρ1 = (t1 ++ e1 :: t2, σ1) →
       ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) →
       prim_step e1 σ1 κ e2 σ2 efs →
       step ρ1 κ ρ2.
  Local Hint Constructors step : core.

  Inductive nsteps : nat → cfg Λ → list (observation Λ) → cfg Λ → Prop :=
    | nsteps_refl ρ :
       nsteps 0 ρ [] ρ
    | nsteps_l n ρ1 ρ2 ρ3 κ κs :
       step ρ1 κ ρ2 →
       nsteps n ρ2 κs ρ3 →
       nsteps (S n) ρ1 (κ ++ κs) ρ3.
  Local Hint Constructors nsteps : core.

  Definition erased_step (ρ1 ρ2 : cfg Λ) := ∃ κ, step ρ1 κ ρ2.

  (** [rtc erased_step] and [nsteps] encode the same thing, just packaged
      in a different way. *)
  Lemma erased_steps_nsteps ρ1 ρ2 :
    rtc erased_step ρ1 ρ2 ↔ ∃ n κs, nsteps n ρ1 κs ρ2.
  Proof.
    split.
    - induction 1; firstorder eauto. (* FIXME: [naive_solver eauto] should be able to handle this *)
    - intros (n & κs & Hsteps). unfold erased_step.
      induction Hsteps; eauto using rtc_refl, rtc_l.
  Qed.

  Lemma of_to_val_flip v e : of_val v = e → to_val e = Some v.
  Proof. intros <-. by rewrite to_of_val. Qed.

  Lemma not_reducible e σ : ¬reducible e σ ↔ irreducible e σ.
  Proof. unfold reducible, irreducible. naive_solver. Qed.
  Lemma reducible_not_val e σ : reducible e σ → to_val e = None.
  Proof. intros (?&?&?&?&?); eauto using val_stuck. Qed.
  Lemma reducible_no_obs_reducible e σ : reducible_no_obs e σ → reducible e σ.
  Proof. intros (?&?&?&?); eexists; eauto. Qed.
  Lemma val_irreducible e σ : is_Some (to_val e) → irreducible e σ.
  Proof. intros [??] ???? ?%val_stuck. by destruct (to_val e). Qed.
  Global Instance of_val_inj : Inj (=) (=) (@of_val Λ).
  Proof. by intros v v' Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.
  Lemma not_not_stuck e σ : ¬not_stuck e σ ↔ stuck e σ.
  Proof.
    rewrite /stuck /not_stuck -not_eq_None_Some -not_reducible.
    destruct (decide (to_val e = None)); naive_solver.
  Qed.

  Lemma strongly_atomic_atomic e a :
    Atomic StronglyAtomic e → Atomic a e.
  Proof. unfold Atomic. destruct a; eauto using val_irreducible. Qed.

  Lemma reducible_fill `{!@LanguageCtx Λ K} e σ :
    reducible e σ → reducible (K e) σ.
  Proof. unfold reducible in *. naive_solver eauto using fill_step. Qed.
  Lemma reducible_fill_inv `{!@LanguageCtx Λ K} e σ :
    to_val e = None → reducible (K e) σ → reducible e σ.
  Proof.
    intros ? (e'&σ'&k&efs&Hstep); unfold reducible.
    apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto.
  Qed.
  Lemma reducible_no_obs_fill `{!@LanguageCtx Λ K} e σ :
    reducible_no_obs e σ → reducible_no_obs (K e) σ.
  Proof. unfold reducible_no_obs in *. naive_solver eauto using fill_step. Qed.
  Lemma reducible_no_obs_fill_inv `{!@LanguageCtx Λ K} e σ :
    to_val e = None → reducible_no_obs (K e) σ → reducible_no_obs e σ.
  Proof.
    intros ? (e'&σ'&efs&Hstep); unfold reducible_no_obs.
    apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto.
  Qed.
  Lemma irreducible_fill `{!@LanguageCtx Λ K} e σ :
    to_val e = None → irreducible e σ → irreducible (K e) σ.
  Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill_inv. Qed.
  Lemma irreducible_fill_inv `{!@LanguageCtx Λ K} e σ :
    irreducible (K e) σ → irreducible e σ.
  Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill. Qed.

  Lemma not_stuck_fill_inv K `{!@LanguageCtx Λ K} e σ :
    not_stuck (K e) σ → not_stuck e σ.
  Proof.
    rewrite /not_stuck -!not_eq_None_Some. intros [?|?].
    - auto using fill_not_val.
    - destruct (decide (to_val e = None)); eauto using reducible_fill_inv.
  Qed.

  Lemma stuck_fill `{!@LanguageCtx Λ K} e σ :
    stuck e σ → stuck (K e) σ.
  Proof. rewrite -!not_not_stuck. eauto using not_stuck_fill_inv. Qed.

  Lemma step_Permutation (t1 t1' t2 : list (expr Λ)) κ σ1 σ2 :
    t1 ≡ₚ t1' → step (t1,σ1) κ (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ step (t1',σ1) κ (t2',σ2).
  Proof.
    intros Ht [e1 σ1' e2 σ2' efs tl tr ?? Hstep]; simplify_eq/=.
    move: Ht; rewrite -Permutation_middle (symmetry_iff (≡ₚ)).
    intros (tl'&tr'&->&Ht)%Permutation_cons_inv_r.
    exists (tl' ++ e2 :: tr' ++ efs); split; [|by econstructor].
    by rewrite -!Permutation_middle !assoc_L Ht.
  Qed.

  Lemma step_insert i t2 σ2 e κ e' σ3 efs :
    t2 !! i = Some e →
    prim_step e σ2 κ e' σ3 efs →
    step (t2, σ2) κ (<[i:=e']>t2 ++ efs, σ3).
  Proof.
    intros.
    edestruct (elem_of_list_split_length t2) as (t21&t22&?&?);
      first (by eauto using elem_of_list_lookup_2); simplify_eq.
    econstructor; eauto.
    by rewrite insert_app_r_alt // Nat.sub_diag /= -assoc_L.
  Qed.

  Lemma erased_step_Permutation (t1 t1' t2 : list (expr Λ)) σ1 σ2 :
    t1 ≡ₚ t1' → erased_step (t1,σ1) (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ erased_step (t1',σ1) (t2',σ2).
  Proof.
    intros Heq [? Hs]. pose proof (step_Permutation _ _ _ _ _ _ Heq Hs). firstorder.
     (* FIXME: [naive_solver] should be able to handle this *)
  Qed.

  Record pure_step (e1 e2 : expr Λ) := {
    pure_step_safe σ1 : reducible_no_obs e1 σ1;
    pure_step_det σ1 κ e2' σ2 efs :
      prim_step e1 σ1 κ e2' σ2 efs → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs = []
  }.

  Notation pure_steps_tp := (Forall2 (rtc pure_step)).

  (* TODO: Exclude the case of [n=0], either here, or in [wp_pure] to avoid it
  succeeding when it did not actually do anything. *)
  Class PureExec (φ : Prop) (n : nat) (e1 e2 : expr Λ) :=
    pure_exec : φ → relations.nsteps pure_step n e1 e2.

  Lemma pure_step_ctx K `{!@LanguageCtx Λ K} e1 e2 :
    pure_step e1 e2 →
    pure_step (K e1) (K e2).
  Proof.
    intros [Hred Hstep]. split.
    - unfold reducible_no_obs in *. naive_solver eauto using fill_step.
    - intros σ1 κ e2' σ2 efs Hpstep.
      destruct (fill_step_inv e1 σ1 κ e2' σ2 efs) as (e2'' & -> & ?); [|exact Hpstep|].
      + destruct (Hred σ1) as (? & ? & ? & ?); eauto using val_stuck.
      + edestruct (Hstep σ1 κ e2'' σ2 efs) as (? & -> & -> & ->); auto.
  Qed.

  Lemma pure_step_nsteps_ctx K `{!@LanguageCtx Λ K} n e1 e2 :
    relations.nsteps pure_step n e1 e2 →
    relations.nsteps pure_step n (K e1) (K e2).
  Proof. eauto using nsteps_congruence, pure_step_ctx. Qed.

  Lemma rtc_pure_step_ctx K `{!@LanguageCtx Λ K} e1 e2 :
    rtc pure_step e1 e2 → rtc pure_step (K e1) (K e2).
  Proof. eauto using rtc_congruence, pure_step_ctx. Qed.

  (* We do not make this an instance because it is awfully general. *)
  Lemma pure_exec_ctx K `{!@LanguageCtx Λ K} φ n e1 e2 :
    PureExec φ n e1 e2 →
    PureExec φ n (K e1) (K e2).
  Proof. rewrite /PureExec; eauto using pure_step_nsteps_ctx. Qed.

  (* This is a family of frequent assumptions for PureExec *)
  Class IntoVal (e : expr Λ) (v : val Λ) :=
    into_val : of_val v = e.

  Class AsVal (e : expr Λ) := as_val : ∃ v, of_val v = e.
  (* There is no instance [IntoVal → AsVal] as often one can solve [AsVal] more
  efficiently since no witness has to be computed. *)
  Global Instance as_vals_of_val vs : TCForall AsVal (of_val <$> vs).
  Proof.
    apply TCForall_Forall, Forall_fmap, Forall_true=> v.
    rewrite /AsVal /=; eauto.
  Qed.

  Lemma as_val_is_Some e :
    (∃ v, of_val v = e) → is_Some (to_val e).
  Proof. intros [v <-]. rewrite to_of_val. eauto. Qed.

  Lemma prim_step_not_stuck e σ κ e' σ' efs :
    prim_step e σ κ e' σ' efs → not_stuck e σ.
  Proof. rewrite /not_stuck /reducible. eauto 10. Qed.

  Lemma rtc_pure_step_val `{!Inhabited (state Λ)} v e :
    rtc pure_step (of_val v) e → to_val e = Some v.
  Proof.
    intros ?; rewrite <- to_of_val.
    f_equal; symmetry; eapply rtc_nf; first done.
    intros [e' [Hstep _]].
    destruct (Hstep inhabitant) as (?&?&?&Hval%val_stuck).
    by rewrite to_of_val in Hval.
  Qed.

  (** Let thread pools [t1] and [t3] be such that each thread in [t1] makes
   (zero or more) pure steps to the corresponding thread in [t3]. Furthermore,
   let [t2] be a thread pool such that [t1] under state [σ1] makes a (single)
   step to thread pool [t2] and state [σ2]. In this situation, either the step
   from [t1] to [t2] corresponds to one of the pure steps between [t1] and [t3],
   or, there is an [i] such that [i]th thread does not participate in the
   pure steps between [t1] and [t3] and [t2] corresponds to taking a step in
   the [i]th thread starting from [t1]. *)
  Lemma erased_step_pure_step_tp t1 σ1 t2 σ2 t3 :
    erased_step (t1, σ1) (t2, σ2) →
    pure_steps_tp t1 t3 →
    (σ1 = σ2 ∧ pure_steps_tp t2 t3) ∨
    (∃ i e efs e' κ,
      t1 !! i = Some e ∧ t3 !! i = Some e ∧
      t2 = <[i:=e']>t1 ++ efs ∧
      prim_step e σ1 κ e' σ2 efs).
  Proof.
    intros [κ [e σ e' σ' efs t11 t12 ?? Hstep]] Hps; simplify_eq/=.
    apply Forall2_app_inv_l in Hps
      as (t31&?&Hpsteps&(e''&t32&Hps&?&->)%Forall2_cons_inv_l&->).
    destruct Hps as [e|e1 e2 e3 [_ Hprs]].
    - right.
      exists (length t11), e, efs, e', κ; split_and!; last done.
      + by rewrite lookup_app_r // Nat.sub_diag.
      + apply Forall2_length in Hpsteps.
        by rewrite lookup_app_r Hpsteps // Nat.sub_diag.
      + by rewrite insert_app_r_alt // Nat.sub_diag /= -assoc_L.
    - edestruct Hprs as (?&?&?&?); first done; simplify_eq.
      left; split; first done.
      rewrite right_id_L.
      eauto using Forall2_app.
  Qed.

End language.

Global Hint Mode PureExec + - - ! - : typeclass_instances.

Global Arguments step_atomic {Λ ρ1 κ ρ2}.

Notation pure_steps_tp := (Forall2 (rtc pure_step)).


Require Import CertiGraph.prim.prim_env.
Require Export CertiGraph.priq.priq_arr_specs.
Require Import CertiGraph.graph.MathUAdjMatGraph.
Require Import CertiGraph.prim.prim_constants.
Require Import CertiGraph.graph.SpaceUAdjMatGraph2.
Require Export CertiGraph.prim.prim2.

Local Open Scope Z_scope.

#[export] Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition G := @UAdjMatGG size inf.
Identity Coercion UAdjMatGG_G: G >-> UAdjMatGG.

Definition getCell_spec :=
  DECLARE _getCell
  WITH g: G,
       graph_ptr: pointer_val,
       addresses: list val,
       u: V,
       i : V
  PRE [tptr tint, tint, tint]
    PROP (0 <= i < size;
         0 <= u < size;
         size * size <= Int.max_signed)
    PARAMS (pointer_val_val graph_ptr;
           Vint (Int.repr u);
           Vint (Int.repr i))
    GLOBALS ()
    SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_list size g eformat) (pointer_val_val graph_ptr))
  POST [tint]
    PROP ()
    RETURN (Vint (Int.repr (Znth i (Znth u (@graph_to_symm_mat size g)))))
    SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_list size g eformat) (pointer_val_val graph_ptr)).

Definition initialise_list_spec :=
  DECLARE _initialise_list
  WITH arr : val, old_list: list val, a: Z
  PRE [tptr tint, tint]
     PROP ( writable_share Tsh;
            repable_signed a;
            size <= Int.max_signed
          )
     PARAMS ( arr; Vint (Int.repr a) )
     GLOBALS ()
     SEP (data_at Tsh (tarray tint size) (old_list) (arr))
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (data_at Tsh (tarray tint size) (repeat (Vint (Int.repr a)) (Z.to_nat size)) arr
         ).

Definition initialise_matrix_spec :=
  DECLARE _initialise_matrix
  WITH arr : val, old_contents: list Z, a: Z
  PRE [tptr tint, tint]
     PROP ( writable_share Tsh;
            Zlength old_contents = Z.mul size size;
            repable_signed a;
            0 < size <= Int.max_signed; (*this is not enough for malloc, requires*)
            size * (4 * size) <= Ptrofs.max_signed (*you can alloc the entire matrix. Can derive above from here*)
          )
     PARAMS ( arr ; Vint (Int.repr a) )
     GLOBALS ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh old_contents arr)
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (repeat a (Z.to_nat (Z.mul size size))) arr).

Definition prim_spec :=
  DECLARE _prim
  WITH g: G, garbage: list V, gptr : pointer_val, r: Z, parent_ptr : pointer_val
  PRE [tptr tint, tint, tptr tint]
     PROP ( writable_share Tsh;
            vvalid g r;
            size * (4 * size) <= Ptrofs.max_signed;
            inf < Int.max_signed
          )
     PARAMS ( pointer_val_val gptr; (Vint (Int.repr r)); pointer_val_val parent_ptr)
     GLOBALS ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_list size g eformat) (pointer_val_val gptr);
          data_at Tsh (tarray tint size) (map (fun x => Vint (Int.repr x)) garbage) (pointer_val_val parent_ptr)
         )
  POST [ tvoid ]
     EX mst: G,
     EX fmst: FiniteGraph mst,
     EX parents: list V,
     PROP ( (*connected_graph mst;*)
            @minimum_spanning_forest size inf mst g;
            Permutation (EList mst) (map (fun v => eformat (v, Znth v parents))
                                         (filter (fun v => Znth v parents <? size) (nat_inc_list (Z.to_nat size))))
          )
     RETURN ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_list size g eformat) (pointer_val_val gptr);
          data_at Tsh (tarray tint size) (map (fun x => Vint (Int.repr x)) parents) (pointer_val_val parent_ptr)
         ).

Definition Gprog: funspecs :=
  ltac:(with_library prog
                     [(@push_spec size inf _);
                     (@pq_emp_spec size inf _);
                     (@popMin_spec size inf _);
                     (@adjustWeight_spec size inf _);
                     (@init_spec size _);
                     freePQ_spec;
                     getCell_spec;
                     initialise_list_spec;
                     initialise_matrix_spec;
                     prim_spec
       ]).


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Morphisms.
Require Export Category.Theory.Isomorphism.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Bifunctor.
Require Import Category.Functor.Product.Internal.
Require Export Category.Structure.Monoidal.
Require Export Category.Structure.Monoidal.Symmetric.
Require Export Category.Structure.Monoidal.Cartesian.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Local Obligation Tactic :=
  unfold proj_left, proj_right; simpl;
  cat_simpl; try split; intros; unfork; cat.

(* Every cartesian category with terminal objects gives rise to a monoidal
   category taking the terminal object as unit, and the tensor as product. *)

Program Definition InternalProduct_Monoidal
        {C : Category} `{@Cartesian C} `{@Terminal C} : @Monoidal C := {|
  tensor := InternalProductFunctor C;
  I := 1
|}.

Program Definition InternalProduct_SymmetricMonoidal
        {C : Category} `{@Cartesian C} `{@Terminal C} :
  @SymmetricMonoidal C InternalProduct_Monoidal := {|
  twist := fun x y =>
    {| to   := @swap C _ x y
     ; from := @swap C _ y x
     ; iso_to_from := swap_invol
     ; iso_from_to := swap_invol
    |}
|}.

Program Definition InternalProduct_CartesianMonoidal
        {C : Category} `{@Cartesian C} `{@Terminal C} :
  @CartesianMonoidal C InternalProduct_Monoidal := {|
  is_semicartesian := {| eliminate := fun _ => one |};
  is_relevance := {| diagonal  := fun _ => id △ id |}
|}.
Next Obligation.
  apply InternalProduct_SymmetricMonoidal.
Defined.
Next Obligation.
  apply fork_respects.
    apply one_unique.
  reflexivity.
Qed.