(**
 CoqTL user theorem: Relational_name_definedness
 Def: if all objects in the source model have name defined,
      then the target objects generated in the target model
      have name defined.
 **)

Require Import String.
Require Import Coq.Logic.Eqdep_dec.
Require Import Arith.
Require Import Coq.Arith.Gt.
Require Import Coq.Arith.EqNat.
Require Import List.

Require Import core.utils.Utils.
Require Import core.SyntaxCertification.
Require Import core.Metamodel.
Require Import core.Model.
Require Import core.Syntax.
Require Import core.Engine.

Require Import transformations.Class2Relational.Class2Relational.
Require Import transformations.Class2Relational.ClassMetamodel.
Require Import transformations.Class2Relational.RelationalMetamodel.

(*Ltac unfoldTransformationIn Tr Ht :=
  unfold Tr in Ht;
  unfold ConcreteSyntax.parse in Ht;
  unfold ConcreteSyntax.parseRule in Ht;
  unfold ConcreteSyntax.parseOutputPatternElement in Ht;
  unfold ConcreteSyntax.parseOutputPatternLink in Ht;
  unfold Expressions.makeGuard in Ht;
  unfold Expressions.makeElement in Ht;
  unfold Expressions.makeIterator in Ht;
  unfold Expressions.makeLink in Ht;
  repeat (unfold Expressions.wrapOptionElement in Ht);
  repeat (unfold Expressions.wrapOptionLink in Ht);
  repeat (unfold Expressions.wrapOption in Ht);
  simpl in Ht.

Ltac unfoldTransformation Tr :=
  unfold Tr;
  unfold ConcreteSyntax.parse;
  unfold ConcreteSyntax.parseRule;
  unfold ConcreteSyntax.parseOutputPatternElement;
  unfold ConcreteSyntax.parseOutputPatternLink;
  unfold Expressions.makeGuard;
  unfold Expressions.makeElement;
  unfold Expressions.makeIterator;
  unfold Expressions.makeLink;
  repeat (unfold Expressions.wrapOptionElement);
  repeat (unfold Expressions.wrapOptionLink);
  repeat (unfold Expressions.wrapOption);
  simpl.*)

Theorem Relational_name_definedness:
forall (te: TransformationEngine CoqTLSyntax) (cm : ClassModel) (rm : RelationalModel),
  (* transformation *) rm = @execute _ _ te Class2Relational cm ->
  (* precondition *)   (forall (c1 : ClassMetamodel_Object), In c1 (allModelElements cm) -> (ClassMetamodel_getName c1 <> ""%string)) ->
  (* postcondition *)  (forall (t1 : RelationalMetamodel_Object), In t1 (allModelElements rm) -> (RelationalMetamodel_getName t1 <> ""%string)).
Proof.
  intros.
  rewrite H in H1.
  rewrite (@tr_execute_in_elements _ _ te Class2Relational) in H1.
  do 2 destruct H1.
  destruct x as [| c]. (* Case analysis on source pattern *)
  - rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
    do 2 destruct H2.
    rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
    destruct H2.
    rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H4.
    simpl in H2.
    destruct H2.
    + rewrite <- H2 in H4.
      simpl in H4.
      inversion H4.
    + destruct H2.
      rewrite <- H2 in H4.
      simpl in H4.
      inversion H4.
      contradiction H2.
  - destruct x as [| c0].
    + (* Singleton *) specialize (H0 c).
      apply allTuples_incl in H1.
      unfold incl in H1.
      specialize (H1 c).
      assert (In c [c]). { left. reflexivity. }
      specialize (H0 (H1 H3)).
      do 2 destruct c. (* Case analysis on source element type *)
      * (* [Class] *)
        rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
        do 2 destruct H2.
        rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
        destruct H2.
        rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H5.
        simpl in H2.
        rewrite (@tr_instantiateRuleOnPattern_in _ _ te Class2Relational) in H4.
        do 2 destruct H4.
        apply tr_instantiateIterationOnPattern_in in H6.
        do 2 destruct H6.
        rewrite tr_instantiateElementOnPattern_leaf in H7.
        destruct H2.
        ** (* Class2Table *)
           rewrite <- H2 in H6.
           simpl in H6.
           destruct H6.
           *** rewrite <- H6 in H7.
               simpl in H7.
               inversion H7.
               simpl.
               apply H0.
           *** contradiction H6.
        ** destruct H2.
           ***  (* Attribute2Column contradict *)
                rewrite <- H2 in H6.
                simpl in H6.
                destruct H6.
                **** rewrite <- H6 in H7. simpl in H7.
                     inversion H7.
                **** contradiction H6.
           *** contradiction H2.
      * (* [Attribute] *) destruct c0.
        destruct b.
        -- (* derived *)
           rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
           do 2 destruct H2.
           rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
           destruct H2.
           rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H5.
           simpl in H2.
           destruct H2.
           ** rewrite <- H2 in H5.
              simpl in H5.
              inversion H5.
           ** destruct H2.
              *** rewrite <- H2 in H5.
                  simpl in H5.
                  inversion H5.
              *** contradiction H2.
        -- (* not derived *)
            rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
            do 2 destruct H2.
            rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
            destruct H2.
            rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H5.
            simpl in H2.
            rewrite (@tr_instantiateRuleOnPattern_in _ _ te Class2Relational) in H4.
            do 2 destruct H4.
            apply tr_instantiateIterationOnPattern_in in H6.
            do 2 destruct H6.
            rewrite tr_instantiateElementOnPattern_leaf in H7.
            destruct H2.
            **  (* Class2Table contradict *)
                 rewrite <- H2 in H6.
                 simpl in H6.
                 destruct H6.
                 *** rewrite <- H6 in H7. simpl in H7.
                      inversion H7.
                 *** contradiction H6.
            ** (* Attribute2Column *)
               destruct H2.
               *** rewrite <- H2 in H6.
                   simpl in H6.
                   destruct H6.
                   **** rewrite <- H6 in H7.
                        simpl in H7.
                        inversion H7.
                        simpl.
                        apply H0.
                   **** contradiction H6.
               *** contradiction H2.
    + (* Other patterns *) do 2 destruct c.
      * destruct c0.
        rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
        do 2 destruct H2.
        rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
        destruct H2.
        rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H4.
        simpl in H2.
        destruct H2.
        ** rewrite <- H2 in H4.
          simpl in H4.
          inversion H4.
        ** destruct H2.
          rewrite <- H2 in H4.
          simpl in H4.
          inversion H4.
          contradiction H2.
      * destruct c0.
        rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
        do 2 destruct H2.
        rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
        destruct H2.
        rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H4.
        simpl in H2.
        destruct H2.
        ** rewrite <- H2 in H4.
          simpl in H4.
          inversion H4.
        ** destruct H2.
          rewrite <- H2 in H4.
          simpl in H4.
          inversion H4.
          contradiction H2.
Qed.

(* Alternative for (* [Attribute] *):
      unfold instantiatePattern in H2.
      unfold matchPattern in H2.
      unfold matchRuleOnPattern in H2. simpl in H2.
      destruct (negb (getAttributeDerived c0)).
      -- simpl in H2. destruct H2.
        ++ rewrite <- H2. simpl. simpl in H0. assumption.
        ++ contradiction H2.
      --  contradiction H2.*)

(* Alternative for (* Other patterns *):
      apply maxArity_length with (sp:=c::c0::x) (tr:=Class2Relational) (sm:=cm).
      * unfold maxArity. simpl. omega.
      * assumption. *)

(*Ltac destructPattern sp tr sm h :=
  destruct sp;
  [> contradiction |
     repeat
      destruct sp;
       [>
          | exfalso;
            apply maxArity_length with (sp:=c::c0::x) (tr:=tr) (sm:=sm);
            [>
              parseTransformationInGoal tr; unfold maxArity; simpl; omega |
              assumption
            ]
            +
            destruct sp;
       ]
  ].*)

Ltac destruct_execute Hexecute sp Hin Hinstantiate :=
  apply tr_execute_in_elements in Hexecute;
  destruct Hexecute as [sp [Hin Hinstantiate]].

Ltac destruct_instantiatePattern Hinstantiate rule Hrule HinstRule :=
  apply tr_instantiatePattern_in in Hinstantiate;
  destruct Hinstantiate as [rule [Hrule HinstRule]].

Ltac destruct_matchPattern Hrule Hr Hmatch :=
  apply tr_matchPattern_in in Hrule;
  destruct Hrule as [Hr Hmatch].

Ltac destruct_rule Hrule :=
  repeat (destruct Hrule as [Hrule | Hrule]; try contradiction Hrule); destruct Hrule.

Ltac destruct_pattern Hinst sp :=
  repeat (let se := fresh "se" in
          destruct sp as [ | se sp ];
          [ | destruct se as [[] ?] eqn:?];
          try contradiction Hinst);
  destruct Hinst as [Hinst | []]; simpl in Hinst.

(*

Theorem Relational_name_definedness':
forall (cm : ClassModel) (rm : RelationalModel),
  (* transformation *) rm = execute Class2Relational cm ->
  (* precondition *)   (forall (c1 : ClassMetamodel_Object), In c1 (allModelElements cm) -> (ClassMetamodel_getName c1 <> ""%string)) ->
  (* postcondition *)  (forall (t1 : RelationalMetamodel_Object), In t1 (allModelElements rm) -> (RelationalMetamodel_getName t1 <> ""%string)).
Proof.
  intros. subst rm.
  destruct_execute H1 sp Hin Hinst. (* t1 comes from a pattern sp *)
  apply allTuples_incl in Hin. (* sp is made of source model elements *)
  destruct_instantiatePattern Hinst r Hr Hinst. (* sp matches a rule r *)
  destruct_matchPattern Hr Hr Hmatch. (* r comes from the transformation *)
  clear Hmatch. (* Hmatch is not used for this proof *)
  destruct_rule Hr; (* case analysis on rules *)
    destruct_pattern Hinst sp. (* retrieve the source pattern for each rule *)
  - (* Class2Table *) specialize (H0 se). crush.
  - (* Attribute2Column *) specialize (H0 se). crush.
Qed.

*)


Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Lang.Static.
Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.BasicFacts.
Require Import UFO.Rel.Monotone.
Require Import UFO.Rel.Compat_bind_LV.
Require Import UFO.Util.Subset.
Require Import UFO.Util.Postfix.
Set Implicit Arguments.

Section section_ccompat_tm_app_lbl.
Context (n : nat).
Context (EV LV : Set).
Context (Ξ : XEnv EV LV).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig).
Context (σ : ms ∅ EV (inc LV) ∅) (ℓ ℓ' : lbl LV ∅) (E : eff ∅ EV LV ∅).
Context (Wf_ℓ : wf_lbl Ξ ℓ).
Context (ξ₁ ξ₂ : list var).
Context (t₁ t₂ : tm0).
Context (Hξ : n ⊨ (𝜩 Ξ ξ₁ ξ₂)ᵢ).
Context (Hρ₁ρ₂ : n ⊨ (ρ₁ρ₂_are_closed ξ₁ ξ₂ ρ₁ ρ₂)ᵢ).

Lemma ccompat_tm_app_lbl :
n ⊨ 𝓣⟦ Ξ ⊢ (ty_ms (ms_lv σ) ℓ') # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ →
n ⊨ 𝓣⟦ Ξ ⊢ (ty_ms (LV_subst_ms ℓ σ) ℓ') # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (tm_app_lbl t₁ (LV_bind_lbl ρ₁ ℓ))
    (tm_app_lbl t₂ (LV_bind_lbl ρ₂ ℓ)).
Proof.
intro Ht.
change (tm_app_lbl t₁ (LV_bind_lbl ρ₁ ℓ))
with (ktx_plug (ktx_app_lbl ktx_hole (LV_bind_lbl ρ₁ ℓ)) t₁).
change (tm_app_lbl t₂ (LV_bind_lbl ρ₂ ℓ))
with (ktx_plug (ktx_app_lbl ktx_hole (LV_bind_lbl ρ₂ ℓ)) t₂).
eapply plug0 ; simpl ; eauto using postfix_refl.
clear t₁ t₂ Ht.

iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
iintro v₁ ; iintro v₂ ; iintro Hv ; simpl.
destruct v₁ as [ | | | m₁ [ | X₁' ] | m₁ [ | X₁' ] ], v₂ as [ | | | m₂ [ | X₂' ] | m₂ [ | X₂' ] ] ; simpl 𝓥_Fun in Hv ;
idestruct Hv as m₁' Hv ; idestruct Hv as m₂' Hv ;
idestruct Hv as X₁'' Hv ; idestruct Hv as X₂'' Hv ;
idestruct Hv as Hv Hr ; ielim_prop Hv ; destruct Hv as [Hv₁ Hv₂] ;
inversion Hv₁ ; inversion Hv₂ ; clear Hv₁ Hv₂ ; subst m₁' m₂' X₁'' X₂''.

idestruct Hr as HX₁'X₂' Hr ; idestruct Hr as m₁' Hr ; idestruct Hr as m₂' Hr ;
idestruct Hr as Hm Hr ; ielim_prop Hm ; destruct Hm ; subst m₁ m₂.
eapply 𝓣_step_r ; [ apply step_app_lbl | ].
eapply 𝓣_step_l ; [ apply step_app_lbl | ].
iintro_later.
apply 𝓥_in_𝓣.
simpl 𝓥_Fun.
repeat ieexists ; repeat isplit ; [ iintro_prop ; crush | apply HX₁'X₂' | ].
clear HX₁'X₂'.

ielim_vars Hr ; [ | apply postfix_refl | apply postfix_refl ].
destruct (LV_bind_lbl ρ₁ ℓ) as [ | [ | X₁ ] ] eqn:HX₁ ; [ auto | auto | ].
destruct (LV_bind_lbl ρ₂ ℓ) as [ | [ | X₂ ] ] eqn:HX₂ ; [ auto | auto | ].
ispecialize Hr X₁.
ispecialize Hr X₂.
ispecialize Hr (𝓣𝓵⟦ Ξ ⊢ ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ).

ispecialize Hr.
{ clear Hr.
  apply postfix_is_subset in Hξ₁' ; apply postfix_is_subset in Hξ₂'.
  destruct ℓ as [ α | [ | X ] ] ; [ | auto | ] ; simpl in HX₁, HX₂.
  + ielim_prop Hρ₁ρ₂ ; specialize (Hρ₁ρ₂ α) ; rewrite HX₁, HX₂ in Hρ₁ρ₂.
    iintro_prop ; split.
    - destruct (Hρ₁ρ₂ X₁) as [? _] ; auto.
    - destruct (Hρ₁ρ₂ X₂) as [_ ?] ; auto.
  + inversion HX₁ ; inversion HX₂ ; subst X₁ X₂.
    inversion Wf_ℓ ; subst.
    ielim_prop Hξ ; destruct Hξ as [Hξ₁ Hξ₂].
    iintro_prop ; crush.
}

replace Ξ with (LV_subst_XEnv ℓ (LV_shift_XEnv Ξ))
by (erewrite LV_bind_map_XEnv, LV_bind_XEnv_id, LV_map_XEnv_id ; crush).
replace ℓ' with (LV_subst_lbl ℓ (LV_shift_lbl ℓ'))
by (erewrite LV_bind_map_lbl, LV_bind_lbl_id, LV_map_lbl_id ; crush).
erewrite <- I_iff_elim_M ; [ apply Hr | clear Hr ].
apply LV_bind_𝓜.
+ crush.
+ crush.
+ iintro α ; destruct α as [ | α ] ; repeat iintro ; simpl.
  - erewrite LV_bind_map_XEnv, LV_map_XEnv_id, LV_bind_XEnv_id ;
    try reflexivity ; try auto_contr.
  - auto_contr.
+ erewrite LV_bind_map_XEnv, LV_map_XEnv_id, LV_bind_XEnv_id ; try reflexivity.
  intro α ; destruct α as [ | α ] ; simpl ; [ assumption | constructor ].
Qed.

End section_ccompat_tm_app_lbl.

Section section_compat_tm_app_lbl.
Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).
Context (σ : ms ∅ EV (inc LV) ∅) (ℓ ℓ' : lbl LV ∅) (E : eff ∅ EV LV ∅).
Context (Wf_ℓ : wf_lbl Ξ ℓ).

Lemma compat_tm_app_lbl n t₁ t₂ :
n ⊨ ⟦ Ξ Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : (ty_ms (ms_lv σ) ℓ') # E ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (tm_app_lbl t₁ ℓ) ≼ˡᵒᵍ (tm_app_lbl t₂ ℓ) :
      (ty_ms (LV_subst_ms ℓ σ) ℓ') # E ⟧.
Proof.
intro Ht.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂ ;
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
simpl subst_tm.
apply ccompat_tm_app_lbl ; try assumption.

iespecialize Ht ; repeat (ispecialize Ht ; [ eassumption | ]).
apply Ht.
Qed.

Lemma compat_ktx_app_lbl n T_hole E_hole K₁ K₂ :
n ⊨ ⟦ Ξ Γ ⊢ K₁ ≼ˡᵒᵍ K₂ :
      T_hole # E_hole ⇢ (ty_ms (ms_lv σ) ℓ') # E ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (ktx_app_lbl K₁ ℓ) ≼ˡᵒᵍ (ktx_app_lbl K₂ ℓ) :
      T_hole # E_hole ⇢ (ty_ms (LV_subst_ms ℓ σ) ℓ') # E ⟧.
Proof.
intro HK.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
iintro t₁ ; iintro t₂ ; iintro Ht.
iespecialize HK.
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ielim_vars HK ; [ | eassumption | eassumption ].
iespecialize HK.
ispecialize HK ; [ eassumption | ].
simpl ktx_plug.
apply ccompat_tm_app_lbl ; try apply HK.
- assumption.
- iintro_prop ; eapply 𝜩_monotone ; eauto.
- iintro_prop ; eapply ρ₁ρ₂_are_closed_monotone ; eauto.
Qed.

End section_compat_tm_app_lbl.


Require Import Thread0 Connect Bootstrap.

Module Type S.
  Parameter heapSize : nat.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := ((heapSize + 50) * 4)%nat.

  Definition inbuf_size := 40.

  Theorem inbuf_size_lower : (inbuf_size >= 2)%nat.
    unfold inbuf_size; auto.
  Qed.

  Theorem inbuf_size_upper : (N_of_nat (inbuf_size * 4) < Npow2 32)%N.
    reflexivity.
  Qed.
End M'.

Import M'.

Module E := Connect.Make(M').
Import E.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 1.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 1.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "connect"!"main" @ [E.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREmain[_] globalSched =?> 1 * 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSched =?> 1 * mallocHeap 0];;

        Goto "connect"!"main"
      end
    }}.

  Ltac t := unfold globalSched, localsInvariantMain, M'.globalSched; genesis.

  Theorem ok0 : moduleOk boot.
    vcgen; abstract t.
  Qed.

  Definition m1 := link Buffers.m boot.
  Definition m2 := link E.m m1.
  Definition m := link m2 E.T.T.m.

  Lemma ok1 : moduleOk m1.
    link Buffers.ok ok0.
  Qed.

  Lemma ok2 : moduleOk m2.
    link E.ok ok1.
  Qed.

  Theorem ok : moduleOk m.
    link ok2 E.T.T.ok.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $(size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok.
  Qed.
End boot.

End Make.


Require Import floyd.proofauto.
Require Import Coqlib.
Require Import Recdef.
Existing Instance NullExtension.Espec.
Require Import progs.switch.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition twice_spec :=
  DECLARE _twice
    WITH n : Z
    PRE [ _n OF tint ]
      PROP  (0 <= n+n <= Int.max_unsigned)
      LOCAL (temp _n (Vint (Int.repr n)))
      SEP ()
    POST [ tint ]
      PROP ()
      LOCAL (temp ret_temp (Vint (Int.repr (n+n))))
      SEP ().

Definition Gprog : funspecs :=   ltac:(with_library prog [twice_spec]).

Lemma body_twice: semax_body Vprog Gprog f_twice twice_spec.
Proof.
start_function.
forward_if (PROP() LOCAL(temp _n (Vint (Int.repr (n+n)))) SEP()).
repeat forward; entailer!.
repeat forward; entailer!.
repeat forward; entailer!.
repeat forward; entailer!.
repeat forward; entailer!.
Qed.


Require Import FinProof.ProgrammingWith.

Require Import UMLang.UrsusLib.
Require Import UMLang.LocalClassGenerator.ClassGenerator.

Require Import UrsusTVM.Cpp.tvmTypes.

Require Import Project.CommonTypes.

(*Поля контракта*)

Inductive IKWFundParticipantFields :=
| IKWFundParticipant_ι_botch0
| IKWFundParticipant_ι_botch1 .
Inductive VarInitFields :=
| VarInit_ι_botch0
| VarInit_ι_botch1 .
Local Open Scope xlist_scope.
Local Open Scope record.
Local Open Scope program_scope.
Local Open Scope glist_scope.
Opaque address.
Definition IKWFundParticipantL : list Type := [
address : Type;

address : Type].
GeneratePruvendoRecord IKWFundParticipantL IKWFundParticipantFields.
Opaque IKWFundParticipantLRecord.
Definition VarInitL: list Type := [
(address : Type);

(address : Type) ].
GeneratePruvendoRecord VarInitL VarInitFields.
Opaque VarInitLRecord.


(** * Context Reduction Basics *)

(** Reformulation of de Boer and Bonsangue's basic setup in the context-reduction setting *)

From Coq Require Import String Bool Datatypes Relations Program.Equality.
From Coq Require Import Classes.RelationClasses.
From Coq Require Import Logic.FunctionalExtensionality. (* for equality of substitutions *)

From SymEx Require Import Expr.
Import BasicExpr.

From SymEx Require Import Maps.
Import BasicMaps.

From SymEx Require Import Parallel.

From SymEx Require Import ContextReduction.

Inductive head_red__S: relation (sub * Bexpr * Stmt) :=
| SAsgn_step: forall x e sig phi,
    head_red__S (sig, phi, <{x := e}>) ((x !-> Aapply sig e; sig), phi, SSkip)
| SIfTrue_step: forall b s1 s2 sig phi,
    head_red__S (sig, phi, <{if b {s1} {s2}}>) (sig, BAnd phi (Bapply sig b), s1)
| SIfFalse_step: forall b s1 s2 sig phi,
    head_red__S (sig, phi, <{if b {s1} {s2}}>) (sig, BAnd phi (BNot (Bapply sig b)), s2)
| SWhileTrue_step: forall b s sig phi,
    head_red__S (sig, phi, <{while b {s}}>) (sig, BAnd phi (Bapply sig b), <{s ; while b {s}}>)
| SWhileFalse_step: forall b s sig phi,
    head_red__S (sig, phi, <{while b {s}}>) (sig, BAnd phi (BNot (Bapply sig b)), SSkip)
| SSeq_skip: forall s sig phi,
    head_red__S (sig, phi, <{skip ; s}>) (sig, phi, s)
| SPar_left_skip: forall s sig phi,
    head_red__S (sig, phi, <{skip || s}>) (sig, phi, s)
| SPar_right_skip: forall s sig phi,
    head_red__S (sig, phi, <{s || skip}>) (sig, phi, s)
.

Definition Sstep: relation (sub * Bexpr * Stmt) := context_red is_context head_red__S.
Definition multi_Sstep := clos_refl_trans_n1 _ Sstep.

Notation " c '->s' c'" := (Sstep c c') (at level 40).
Notation " c '->*' c'" := (multi_Sstep c c') (at level 40).

Inductive head_red__C: relation (Valuation * Stmt) :=
| CAsgn_step: forall x e V,
    head_red__C (V, <{x := e}>) ((x !-> Aeval V e ; V), SSkip)
| CIfTrue_step: forall b s1 s2 V,
    Beval V b = true ->
    head_red__C (V, <{if b {s1} {s2}}>) (V, s1)
| CIfFalse_step: forall b s1 s2 V,
    Beval V b = false ->
    head_red__C (V, <{if b {s1} {s2}}>) (V, s2)
| CWhileTrue_step: forall b s V,
    Beval V b = true ->
    head_red__C (V, <{while b {s}}>) (V, <{s ; while b {s}}>)
| CWhileFalse_step: forall b s V,
    Beval V b = false ->
    head_red__C (V, <{while b {s}}>) (V, SSkip)
| CSeq_skip: forall s V,
    head_red__C (V, <{skip ; s}>) (V, s)
| CPar_left_skip: forall s V,
    head_red__C (V, <{skip || s}>) (V, s)
| CPar_right_skip: forall s V,
    head_red__C (V, <{s || skip}>) (V, s)
.

Definition Cstep: relation (Valuation * Stmt) := context_red is_context head_red__C.
Definition multi_Cstep := clos_refl_trans_n1 _ Cstep.

Notation " c '=>c' c'" := (Cstep c c') (at level 40).
Notation " c '=>*' c'" := (multi_Cstep c c') (at level 40).

Theorem correctness : forall s s' sig phi V,
    (id_sub, BTrue, s) ->* (sig, phi, s') ->
    Beval V phi = true ->
    (V, s) =>* (Comp V sig, s').
Proof.
  intros. dependent induction H.
  - rewrite comp_id. constructor.
  - dependent destruction H. destruct x as [sig0 phi0]. dependent destruction H; econstructor;
      (* simplify path condition for use in the concrete step *)
      try (simpl in H2; apply andb_true_iff in H2; destruct H2; try (apply negb_true_iff in H2);
        rewrite <- comp_subB in H2).
    + constructor.
      * rewrite asgn_sound. constructor.
      * assumption.
    + eapply IHclos_refl_trans_n1; try reflexivity; assumption.
    + constructor.
      * constructor. apply H2.
      * assumption.
    + eapply IHclos_refl_trans_n1; try reflexivity; assumption.
    + constructor.
      * apply CIfFalse_step. apply H2.
      * assumption.
    + eapply IHclos_refl_trans_n1; try reflexivity; assumption.
    + constructor.
      * apply CWhileTrue_step. apply H2.
      * assumption.
    + eapply IHclos_refl_trans_n1; try reflexivity; assumption.
    + constructor.
      * apply CWhileFalse_step. apply H2.
      * assumption.
    + eapply IHclos_refl_trans_n1; try reflexivity; assumption.
    + constructor.
      * apply CSeq_skip.
      * assumption.
    + eapply IHclos_refl_trans_n1; try reflexivity; assumption.
    + constructor.
      * apply CPar_left_skip.
      * assumption.
    + eapply IHclos_refl_trans_n1; try reflexivity; assumption.
    + constructor.
      * apply CPar_right_skip.
      * assumption.
    + eapply IHclos_refl_trans_n1; try reflexivity; assumption.
Qed.

Ltac splits := repeat (try split).

Theorem completeness : forall s s' V0 V,
    (V0, s) =>* (V, s') ->
    exists sig phi, (id_sub, BTrue, s) ->* (sig, phi, s') /\ Beval V0 phi = true /\ V = Comp V0 sig.
Proof.
  intros. dependent induction H.
  - exists id_sub. exists BTrue. splits. constructor.
  - dependent destruction H. dependent destruction H.
    + destruct (IHclos_refl_trans_n1 s (C <{x0 := e}>) V0 x) as [sig [phi [IHcomp [IHval IHupd]]]];
        try reflexivity.
      eexists. eexists. splits.
      * econstructor.
        ** constructor; [apply SAsgn_step
                        | assumption].
        ** apply IHcomp.
      * assumption.
      * rewrite asgn_sound. rewrite IHupd. reflexivity.
    + destruct (IHclos_refl_trans_n1 s (C <{if b {s'0}{s2}}>) V0 V) as [sig [phi [IHcomp [IHval IHupd]]]];
        try reflexivity.
      eexists. eexists. splits.
      * econstructor.
        ** constructor; [apply SIfTrue_step
                        | assumption].
        ** apply IHcomp.
      * simpl. apply andb_true_iff. split.
        ** assumption.
        ** rewrite <- comp_subB. rewrite <- IHupd. assumption.
      * assumption.
    + destruct (IHclos_refl_trans_n1 s (C <{if b {s1}{s'0}}>) V0 V) as [sig [phi [IHcomp [IHval IHupd]]]];
        try reflexivity.
      eexists. eexists. splits.
      * econstructor.
        ** constructor; [apply SIfFalse_step
                        | assumption].
        ** apply IHcomp.
      * simpl. apply andb_true_iff. split.
        ** assumption.
        ** rewrite <- comp_subB. rewrite <- IHupd. apply negb_true_iff. assumption.
      * assumption.
    + destruct (IHclos_refl_trans_n1 s (C <{while b {s1}}>) V0 V) as [sig [phi [IHcomp [IHval IHupd]]]];
        try reflexivity.
      eexists. eexists. splits.
      * econstructor.
        ** constructor; [apply SWhileTrue_step
                        | assumption].
        ** apply IHcomp.
      * simpl. apply andb_true_iff. split.
        ** assumption.
        ** rewrite <- comp_subB. rewrite <- IHupd. assumption.
      * assumption.
    + destruct (IHclos_refl_trans_n1 s (C <{while b {s1}}>) V0 V) as [sig [phi [IHcomp [IHval IHupd]]]];
        try reflexivity.
      eexists. eexists. splits.
      * econstructor.
        ** constructor; [apply SWhileFalse_step
                        | assumption].
        ** apply IHcomp.
      * simpl. apply andb_true_iff. split.
        ** assumption.
        ** rewrite <- comp_subB. rewrite <- IHupd. apply negb_true_iff. assumption.
      * assumption.
    + destruct (IHclos_refl_trans_n1 s (C <{skip ; s'0}>) V0 V) as [sig [phi [IHcomp [IHval IHupd]]]];
        try reflexivity.
      exists sig. exists phi. splits; try assumption.
      econstructor.
      * constructor; [apply SSeq_skip | assumption].
      *  apply IHcomp.
    + destruct (IHclos_refl_trans_n1 s (C <{skip || s'0}>) V0 V) as [sig [phi [IHcomp [IHval IHupd]]]];
        try reflexivity.
      exists sig. exists phi. splits; try assumption.
      econstructor.
      * constructor; [apply SPar_left_skip | assumption].
      *  apply IHcomp.
    + destruct (IHclos_refl_trans_n1 s (C <{s'0 || skip}>) V0 V) as [sig [phi [IHcomp [IHval IHupd]]]];
        try reflexivity.
      exists sig. exists phi. splits; try assumption.
      econstructor.
      * constructor; [apply SPar_right_skip | assumption].
      *  apply IHcomp.
Qed.


Require Export List.
Export ListNotations.
Set Implicit Arguments.

From Coq Require Import ssreflect.

(* Add LoadPath "../modal".
Add LoadPath "../tense-lns". *)
Require Import gen genT ddT gen_tacs.
Require Import gstep.
Require Import List_lemmasT swappedT existsT.
Require Import Coq.Program.Basics.

Inductive rlsmap U W (f : U -> W) (rls : rlsT U) : rlsT W :=
  | rmI : forall ps c, rls ps c -> rlsmap f rls (map f ps) (f c).

Lemma rmI_eq U W (f : U -> W) (rls : rlsT U) ps c mps mc :
  rls ps c -> mps = map f ps -> mc = f c -> rlsmap f rls mps mc.
Proof. intros. subst. apply rmI ; assumption. Qed.

Inductive relmap U W (f : U -> W) (rel : relationT U) : relationT W :=
  | rlI : forall p c, rel p c -> relmap f rel (f p) (f c).

Lemma rlI_eq U W (f : U -> W) (rel : relationT U) p c mp mc :
  rel p c -> mp = f p -> mc = f c -> relmap f rel mp mc.
Proof. intros. subst. apply rlI ; assumption. Qed.

(** seqext, seqrule, extending sequent and rule with left- and right-contexts
  in antecedent and consequent **)
Definition seqext (W : Type) Γ1 Γ2 Δ1 Δ2 (seq : rel (list W)) :=
  match seq with | pair U V => pair (Γ1 ++ U ++ Γ2) (Δ1 ++ V ++ Δ2) end.

Lemma seqext_seqext: forall V (Γ1 Γ2 Δ1 Δ2 Φ1 Φ2 Ψ1 Ψ2 : list V) seq,
  seqext Γ1 Γ2 Δ1 Δ2 (seqext Φ1 Φ2 Ψ1 Ψ2 seq) =
  seqext (Γ1 ++ Φ1) (Φ2 ++ Γ2) (Δ1 ++ Ψ1) (Ψ2 ++ Δ2) seq.
Proof. intros. unfold seqext. destruct seq.
rewrite !app_assoc. reflexivity. Qed.

Lemma map_seqext_seqext: forall V (Γ1 Γ2 Δ1 Δ2 Φ1 Φ2 Ψ1 Ψ2 : list V) seqs,
  map (seqext Γ1 Γ2 Δ1 Δ2) (map (seqext Φ1 Φ2 Ψ1 Ψ2) seqs) =
  map (seqext (Γ1 ++ Φ1) (Φ2 ++ Γ2) (Δ1 ++ Ψ1) (Ψ2 ++ Δ2)) seqs.
Proof. induction seqs. tauto.
simpl. rewrite IHseqs. rewrite seqext_seqext. reflexivity. Qed.

Inductive seqrule (W : Type) (pr : rlsT (rel (list W))) :
    rlsT (rel (list W)) :=
  | Sctxt : forall ps c Φ1 Φ2 Ψ1 Ψ2, pr ps c ->
    seqrule pr (map (seqext Φ1 Φ2 Ψ1 Ψ2) ps) (seqext Φ1 Φ2 Ψ1 Ψ2 c).

Lemma seqext_def : forall (W : Type) Φ1 Φ2 Ψ1 Ψ2 U V,
      @seqext W Φ1 Φ2 Ψ1 Ψ2 (U,V) = (Φ1 ++ U ++ Φ2, Ψ1 ++ V ++ Ψ2).
Proof. reflexivity. Qed.

Lemma Sctxt_e: forall (W : Type) (pr : rlsT (rel (list W))) ps U V Φ1 Φ2 Ψ1 Ψ2,
  pr ps (U, V) ->
  seqrule pr (map (seqext Φ1 Φ2 Ψ1 Ψ2) ps) (Φ1 ++ U ++ Φ2, Ψ1 ++ V ++ Ψ2).
Proof.
  intros until 0. intros H. rewrite <- seqext_def.
  apply Sctxt. exact H.
Qed.

Lemma Sctxt_eq: forall (W : Type) pr ps mps (ca cs U V Φ1 Φ2 Ψ1 Ψ2 : list W),
  pr ps (U, V) -> ca = Φ1 ++ U ++ Φ2 -> cs = Ψ1 ++ V ++ Ψ2 ->
  mps = map (seqext Φ1 Φ2 Ψ1 Ψ2) ps -> seqrule pr mps (ca, cs).
Proof. intros.  subst. apply Sctxt_e. exact X. Qed.

Lemma seqrule_id (W : Type) (pr : rlsT (rel (list W))) :
  forall ps c, pr ps c -> seqrule pr ps c.
Proof. intros. destruct c as [ca cs].
apply (Sctxt_eq pr ps ca cs [] [] [] []). assumption.
simpl. rewrite app_nil_r.  reflexivity.
simpl. rewrite app_nil_r.  reflexivity.
clear X. induction ps.  simpl.  reflexivity.
simpl. rewrite <- IHps.
destruct a. unfold seqext. simpl.  rewrite !app_nil_r.
reflexivity. Qed.

Lemma seqrule_seqrule (W : Type) (pr : rlsT (rel (list W))) :
  rsub (seqrule (seqrule pr)) (seqrule pr).
Proof. unfold rsub. intros. inversion X. subst. clear X.
inversion X0.  subst. clear X0.
rewrite seqext_seqext.
destruct c0 as [ca cs].
eapply Sctxt_eq. exact X.
reflexivity.  reflexivity.
clear X. induction ps0.  simpl.  reflexivity.
simpl. rewrite IHps0.  rewrite seqext_seqext. reflexivity. Qed.

Definition seqrule_seqrule' (W : Type) pr :=
  rsubD (@seqrule_seqrule W pr).

Lemma derl_seqrule'' (W : Type) (rules : rlsT (rel (list W))) :
  forall Φ1 Φ2 Ψ1 Ψ2, (forall ps c, derl rules ps c ->
   derl (seqrule rules) (map (seqext Φ1 Φ2 Ψ1 Ψ2) ps) (seqext Φ1 Φ2 Ψ1 Ψ2 c)) *
  (forall ps cs, dersl rules ps cs ->
    dersl (seqrule rules) (map (seqext Φ1 Φ2 Ψ1 Ψ2) ps)
    (map (seqext Φ1 Φ2 Ψ1 Ψ2)cs)).
Proof. intros Φ1 Φ2 Ψ1 Ψ2.
eapply (derl_dersl_rect_mut (rules := rules)
  (fun ps c => fun _ => derl (seqrule rules)
    (map (seqext Φ1 Φ2 Ψ1 Ψ2) ps) (seqext Φ1 Φ2 Ψ1 Ψ2 c))
  (fun ps cs : list _ => fun _ => dersl (seqrule rules)
    (map (seqext Φ1 Φ2 Ψ1 Ψ2) ps) (map (seqext Φ1 Φ2 Ψ1 Ψ2) cs))).
- simpl. intros. apply asmI.
- intros. eapply dtderI.  apply Sctxt. eassumption.  assumption.
- simpl. apply dtNil.
- intros. rewrite map_app. simpl. apply dtCons ; assumption. Qed.

Definition derl_seqrule' W rules Φ1 Φ2 Ψ1 Ψ2 :=
  fst (@derl_seqrule'' W rules Φ1 Φ2 Ψ1 Ψ2).
Definition dersl_seqrule' W rules Φ1 Φ2 Ψ1 Ψ2 :=
  snd (@derl_seqrule'' W rules Φ1 Φ2 Ψ1 Ψ2).

Lemma derl_seqrule (W : Type) (rules : rlsT (rel (list W))) :
  rsub (seqrule (derl rules)) (derl (seqrule rules)).
Proof.  unfold rsub.  intros.  destruct X.
apply derl_seqrule'. assumption. Qed.

Lemma seqrule_derl_seqrule (W : Type) (rules : rlsT (rel (list W))) :
  rsub (seqrule (derl (seqrule rules))) (derl (seqrule rules)).
Proof.  eapply rsub_trans. apply derl_seqrule.
 unfold rsub.  intros.  eapply derl_mono. 2: eassumption.
 apply seqrule_seqrule. Qed.

Definition seqrule_derl_seqrule' W rules :=
  rsubD (@seqrule_derl_seqrule W rules).

(* seqrule_s ps c qs d means that d is a sequent extension of c
  and that each q in qs is a corresponding sequent extension of the
  corresponding p in ps *)
Inductive seqrule_s (W : Type) (ps : list (rel (list W))) (c : rel (list W)) :
    rlsT (rel (list W)) :=
  | Sctxt_s : forall Φ1 Φ2 Ψ1 Ψ2,
    seqrule_s ps c (map (seqext Φ1 Φ2 Ψ1 Ψ2) ps) (seqext Φ1 Φ2 Ψ1 Ψ2 c).

Inductive seqrule' (W : Type) (pr : rlsT (rel (list W))) :
    rlsT (rel (list W)) :=
  | Sctxt' : forall ps c pse ce,
    pr ps c -> seqrule_s ps c pse ce -> seqrule' pr pse ce.

Check (Sctxt' _ _ (Sctxt_s _ _ _ _ _ _)).

(* Check, get same as Sctxt but for seqrule' *)
Lemma Sctxt_alt : forall (W : Type) (pr : rlsT (rel (list W))) ps c Φ1 Φ2 Ψ1 Ψ2,
    pr ps c -> seqrule' pr (map (seqext Φ1 Φ2 Ψ1 Ψ2) ps) (seqext Φ1 Φ2 Ψ1 Ψ2 c).
Proof.
  intros until 0. intros H.
  eapply Sctxt'. exact H. apply Sctxt_s.
Qed.

Lemma Sctxt_e': forall (W : Type) (pr : rlsT (rel (list W))) ps U V Φ1 Φ2 Ψ1 Ψ2,
  pr ps (U, V) ->
  seqrule pr (map (seqext Φ1 Φ2 Ψ1 Ψ2) ps) ((Φ1 ++ U) ++ Φ2, Ψ1 ++ V ++ Ψ2).
Proof.
  intros until 0. intros H.
  rewrite <- app_assoc. apply Sctxt_e. exact H.
Qed.

Lemma seqext_defp : forall (W : Type) Φ1 Φ2 Ψ1 Ψ2 seq,
      @seqext W Φ1 Φ2 Ψ1 Ψ2 seq =
        let (U, V) := seq in (Φ1 ++ U ++ Φ2, Ψ1 ++ V ++ Ψ2).
Proof. reflexivity. Qed.

Lemma seqrule_same: forall (W : Type) pr ps (c c' : rel (list W)),
  seqrule pr ps c -> c = c' -> seqrule pr ps c'.
Proof. intros. subst. assumption. Qed.

Lemma seqrule_mono X (rulesa rulesb : rlsT (rel (list X))) :
  rsub rulesa rulesb -> rsub (seqrule rulesa) (seqrule rulesb).
Proof. unfold rsub. intros. destruct X1. apply Sctxt. firstorder. Qed.

Definition seqrule_mono' X rulesa rulesb rs :=
  rsubD (@seqrule_mono X rulesa rulesb rs).

Lemma Sctxt_nil: forall (W : Type) pr c Γ1 Γ2 Δ1 Δ2, (pr [] c : Type) ->
  @seqrule W pr [] (seqext Γ1 Γ2 Δ1 Δ2 c).
Proof.
  intros until 0.  intros H. eapply Sctxt in H.
  simpl in H. exact H.
Qed.

Lemma InT_seqextL : forall {W : Type} Γ Δ A,
    InT A Γ ->
    existsT2 Φ1 Φ2, @seqext W Φ1 Φ2 Δ [] ([A], []) = (Γ, Δ).
Proof.
  induction Γ; intros Δ A Hin.
  inversion Hin.
  inversion Hin. subst.
  repeat eexists. unfold seqext.
  do 2 rewrite app_nil_r. erewrite app_nil_l.
     reflexivity.
  subst. destruct (IHΓ  Δ _ X) as [H1 [H2 H3]].
  unfold seqext in *.
  inversion H3.
  repeat rewrite app_nil_r.
  repeat eexists. rewrite app_comm_cons. reflexivity.
Qed.

Lemma InT_seqextR : forall {W : Type} Γ Δ B,
    InT B Δ ->
    existsT2 Ψ1 Ψ2, @seqext W Γ [] Ψ1 Ψ2 ([], [B]) = (Γ, Δ).
Proof.
  induction Δ; intros A Hin.
  inversion Hin.
  inversion Hin. subst.
  repeat eexists. unfold seqext.
  do 2 rewrite app_nil_r. erewrite app_nil_l.
     reflexivity.
  subst. destruct (IHΔ _ X) as [H1 [H2 H3]].
  unfold seqext in *.
  inversion H3.
  repeat rewrite app_nil_r.
  repeat eexists. rewrite app_comm_cons. reflexivity.
Qed.

Lemma InT_seqext : forall {W : Type} Γ Δ A B,
    InT A Γ ->
    InT B Δ ->
    existsT2 Φ1 Φ2 Ψ1 Ψ2, @seqext W Φ1 Φ2 Ψ1 Ψ2 ([A], [B]) = (Γ, Δ).
Proof.
  intros until 0. intros Hin1 Hin2.
  destruct (@InT_seqextL _ _ Δ _ Hin1) as [H1 [H2 H3]].
  destruct (@InT_seqextR _ Γ _ _ Hin2) as [J1 [J2 J3]].
  unfold seqext in *.
  repeat rewrite app_nil_r in H3.
  repeat rewrite app_nil_r in J3.
  inversion H3. inversion J3.
  subst. repeat eexists.
Qed.

(* fmlsext copied from ../ll/fmlsext.v *)
Definition fmlsext (W : Type) Γ1 Γ2 (fmls : (list W)) := (Γ1 ++ fmls ++ Γ2).

Lemma fmlsext_fmlsext: forall V (Γ1 Γ2 Φ1 Φ2 : list V) seq,
  fmlsext Γ1 Γ2 (fmlsext Φ1 Φ2 seq) = fmlsext (Γ1 ++ Φ1) (Φ2 ++ Γ2) seq.
Proof. intros. unfold fmlsext.  rewrite !app_assoc. reflexivity. Qed.

Lemma map_fmlsext_fmlsext: forall V (Γ1 Γ2 Φ1 Φ2 : list V) seqs,
  map (fmlsext Γ1 Γ2) (map (fmlsext Φ1 Φ2) seqs) =
  map (fmlsext (Γ1 ++ Φ1) (Φ2 ++ Γ2)) seqs.
Proof. induction seqs. tauto.
simpl. rewrite IHseqs. rewrite fmlsext_fmlsext. reflexivity. Qed.

Lemma fmlsext_def : forall (W : Type) Φ1 Φ2 U,
      @fmlsext W Φ1 Φ2 U = (Φ1 ++ U ++ Φ2).
Proof. reflexivity. Qed.

Definition apfst U V W (f : U -> V) (p : U * W) := let (x, y) := p in (f x, y).
Definition apsnd U V W (f : U -> V) (p : W * U) := let (x, y) := p in (x, f y).

(** fst_ext_rls - adding left- and right-context
  to the antecedent of a sequent rule *)
Inductive fst_ext_rls U W rls : rlsT (list U * W) :=
  | fextI : forall Γ1 Γ2 ps c,
    rlsmap (apfst (fmlsext Γ1 Γ2)) rls ps c -> fst_ext_rls rls ps c.

Inductive snd_ext_rls U W rls : rlsT (U * list W) :=
  | sextI : forall Γ1 Γ2 ps c,
    rlsmap (apsnd (fmlsext Γ1 Γ2)) rls ps c -> snd_ext_rls rls ps c.

Definition fextI' U W rls Γ1 Γ2 ps c rpc :=
  @fextI U W rls Γ1 Γ2 _ _ (rmI _ _ ps c rpc).

Lemma fextI_eq' U W rls Γ1 Γ2 ps (c : list U * W) mps mc :
  rls ps c -> mps = map (apfst (fmlsext Γ1 Γ2)) ps ->
  mc = apfst (fmlsext Γ1 Γ2) c -> fst_ext_rls rls mps mc.
Proof. intros. subst. apply fextI'. exact X. Qed.

Definition fextI_eqc' U W rls Γ1 Γ2 ps (c : list U * W) mc rpc :=
  @fextI_eq' U W rls Γ1 Γ2 ps (c : list U * W) _ mc rpc eq_refl.

Lemma fst_snd_ext W (rls : rlsT (list W * list W)) :
  req (seqrule rls) (fst_ext_rls (snd_ext_rls rls)).
Proof. split ; intros ps c.
- intro sr. destruct sr. eapply fextI. eapply rmI_eq.
eapply sextI. apply rmI. exact r.
2: destruct c.  2: simpl.  2: unfold fmlsext.  2: reflexivity.
clear r. induction ps. reflexivity.
destruct a. simpl.  rewrite - IHps. unfold fmlsext. reflexivity.
- intro fs. destruct fs. inversion r. clear r. subst.
destruct X. inversion r. clear r. subst.
destruct c0. simpl. unfold fmlsext.
eapply Sctxt_eq. exact X. reflexivity. reflexivity.
clear X.  induction ps0. reflexivity.
destruct a. simpl.  rewrite IHps0. reflexivity. Qed.

Lemma snd_fst_ext W (rls : rlsT (list W * list W)) :
  req (seqrule rls) (snd_ext_rls (fst_ext_rls rls)).
Proof. split ; intros ps c.
- intro sr. destruct sr. eapply sextI. eapply rmI_eq.
eapply fextI. apply rmI. exact r.
2: destruct c.  2: simpl.  2: unfold fmlsext.  2: reflexivity.
clear r. induction ps. reflexivity.
destruct a. simpl.  rewrite - IHps. unfold fmlsext. reflexivity.
- intro fs. destruct fs. inversion r. clear r. subst.
destruct X. inversion r. clear r. subst.
destruct c0. simpl. unfold fmlsext.
eapply Sctxt_eq. exact X. reflexivity. reflexivity.
clear X.  induction ps0. reflexivity.
destruct a. simpl.  rewrite IHps0. reflexivity. Qed.

Lemma rm_mono U W (f : U -> W) rlsa rlsb :
  rsub rlsa rlsb -> rsub (rlsmap f rlsa) (rlsmap f rlsb).
Proof. intros rab ps c ra.
destruct ra.   pose (rab _ _ r).
apply rmI. apply r0. Qed.

Lemma fer_mono U W (rlsa rlsb : rlsT (list U * W)) :
  rsub rlsa rlsb -> rsub (fst_ext_rls rlsa) (fst_ext_rls rlsb).
Proof. intros rab ps c fea.
destruct fea.  destruct r.  pose (rab _ _ r).
eapply fextI. apply rmI. apply r0. Qed.

Lemma ser_mono U W (rlsa rlsb : rlsT (U * list W)) :
  rsub rlsa rlsb -> rsub (snd_ext_rls rlsa) (snd_ext_rls rlsb).
Proof. intros rab ps c sea.
destruct sea.  destruct r.  pose (rab _ _ r).
eapply sextI. apply rmI. apply r0. Qed.

(* derl_fst_ext_rls - similar for seqrule above *)
Lemma fst_ext_rls_fst_ext_rls (U W : Type) (pr : rlsT (list U * W)) :
  rsub (fst_ext_rls (fst_ext_rls pr)) (fst_ext_rls pr).
Proof. unfold rsub. intros. inversion X. subst. clear X.
inversion X0.  subst. clear X0. destruct X. destruct r.
destruct c. simpl.  rewrite fmlsext_fmlsext.
eapply fextI' in p.  simpl in p.
eapply arg1_cong_imp. 2: exact p.  clear p.
induction ps ; simpl. reflexivity.
rewrite IHps.  destruct a. simpl. rewrite fmlsext_fmlsext. reflexivity. Qed.

Definition fst_ext_rls_fst_ext_rls' (U W : Type) pr :=
  rsubD (@fst_ext_rls_fst_ext_rls U W pr).

Lemma derl_fst_ext_rls'' (U W : Type) (rules : rlsT (list U * W)) :
  forall Φ1 Φ2, (forall ps c, derl rules ps c ->
   derl (fst_ext_rls rules)
     (map (apfst (fmlsext Φ1 Φ2)) ps) (apfst (fmlsext Φ1 Φ2) c)) *
  (forall ps cs, dersl rules ps cs ->
    dersl (fst_ext_rls rules) (map (apfst (fmlsext Φ1 Φ2)) ps)
    (map (apfst (fmlsext Φ1 Φ2)) cs)).
Proof. intros Φ1 Φ2.
eapply (derl_dersl_rect_mut (rules := rules)
  (fun ps c => fun _ => derl (fst_ext_rls rules)
    (map (apfst (fmlsext Φ1 Φ2)) ps) (apfst (fmlsext Φ1 Φ2) c))
  (fun ps cs : list _ => fun _ => dersl (fst_ext_rls rules)
    (map (apfst (fmlsext Φ1 Φ2)) ps) (map (apfst (fmlsext Φ1 Φ2)) cs))).
- simpl. intros. apply asmI.
- intros. eapply dtderI. eapply fextI. apply rmI. eassumption.  assumption.
- simpl. apply dtNil.
- intros. rewrite map_app. simpl. apply dtCons ; assumption. Qed.

Definition derl_fst_ext_rls' U W rules Φ1 Φ2 :=
  fst (@derl_fst_ext_rls'' U W rules Φ1 Φ2).
Definition dersl_fst_ext_rls' U W rules Φ1 Φ2 :=
  snd (@derl_fst_ext_rls'' U W rules Φ1 Φ2).

Lemma derl_fst_ext_rls (U W : Type) (rules : rlsT (list U * W)) :
  rsub (fst_ext_rls (derl rules)) (derl (fst_ext_rls rules)).
Proof.  unfold rsub.  intros.  destruct X.  destruct r.
apply derl_fst_ext_rls'. assumption. Qed.

Lemma fst_ext_rls_derl_fst_ext_rls (U W : Type) (rules : rlsT (list U * W)) :
  rsub (fst_ext_rls (derl (fst_ext_rls rules))) (derl (fst_ext_rls rules)).
Proof.  eapply rsub_trans. apply derl_fst_ext_rls.
 unfold rsub.  intros.  eapply derl_mono. 2: eassumption.
 apply fst_ext_rls_fst_ext_rls. Qed.

Definition fst_ext_rls_derl_fst_ext_rls' U W rules :=
  rsubD (@fst_ext_rls_derl_fst_ext_rls U W rules).

(* simple version of weakening, new stuff added at beginning or end,
  could do more complicated, but why bother, have exchange *)
Definition wkL_valid V W rules (cl : list V) cr :=
  forall Γ1 Γ2, derrec rules (@emptyT _) (fmlsext Γ1 Γ2 cl, cr : W).
Definition wkL_valid' V W rules seq := @wkL_valid V W rules (fst seq) (snd seq).

Definition can_wkL V W rules seq :=
  derrec rules emptyT seq -> @wkL_valid' V W rules seq.

Lemma can_wkL_req V W rlsa rlsb seq : req rlsa rlsb ->
  @can_wkL V W rlsa seq -> can_wkL rlsb seq.
Proof. unfold can_wkL. unfold wkL_valid'. unfold wkL_valid.
intros rab da derb *.
specialize (da (derrec_rmono (snd rab) derb)).
exact (derrec_rmono (fst rab) (da Γ1 Γ2)). Qed.

Lemma weakeningL: forall V W seq rules, @can_wkL V W (fst_ext_rls rules) seq.
Proof. unfold can_wkL. intros.
eapply derrec_all_rect in X. exact X.
intros. contradiction H.
intros ps concl ljpc dsps fwk.  destruct ljpc.  inversion r.
destruct c0. unfold wkL_valid'. unfold wkL_valid. simpl. subst. clear r.
intros *.  rewrite fmlsext_fmlsext.
eapply derI. eapply fextI. eapply rmI_eq. apply X0.
reflexivity.  reflexivity.
apply dersrecI_forall. intros c0 incm.
apply InT_mapE in incm. cD.
eapply ForallTD_forall in fwk.
2: apply InT_map.  2: exact incm1.
simpl in incm0. destruct incm0. simpl in fwk.
unfold wkL_valid' in fwk.  unfold wkL_valid in fwk.  simpl in fwk.
rewrite - fmlsext_fmlsext. apply fwk.  Qed.

Print Implicit weakeningL.

(** exchange **)
(* properties can exchange adjacent sublists, and resulting sequent
  is derivable (not conditional on unexchanged version being derivable *)
Definition can_exchL W Y rules seq :=
  forall (Γ Γs : list W) (Δ : Y), seq = pair Γ Δ -> swapped Γ Γs ->
  derrec rules (@emptyT _) (pair Γs Δ).

Definition can_exchR W Y rules seq :=
  forall (Γ : Y) (Δ Δs : list W), seq = pair Γ Δ -> swapped Δ Δs ->
  derrec rules (@emptyT _) (pair Γ Δs).

Inductive sing_empty X : list X -> Type :=
  | se_empty : sing_empty []
  | se_single : forall a, sing_empty [a].

Lemma sing_empty_app X (xs ys : list X):
  sing_empty (xs ++ ys) -> sum (xs = []) (ys = []).
Proof. intro. inversion X0. destruct xs. tauto.
simpl in H0. discriminate H0.
destruct xs. tauto.
injection H0 as. destruct xs. simpl in H0. subst. tauto.
simpl in H0. discriminate H0.  Qed.

Lemma sing_empty_app_cons X z (xs ys : list X):
  sing_empty (xs ++ z :: ys) -> (xs = []) * (ys = []).
Proof. intro se. inversion se.
list_eq_ncT. inversion H0.  list_eq_ncT. sD. inversion H1. tauto.
list_eq_ncT. Qed.

Inductive fst_rel (A B : Type) (R : relationT A) : relationT (A * B) :=
  fst_relI : forall x y z, R x y -> @fst_rel A B R (x, z : B) (y, z).

Inductive snd_rel (A B : Type) (R : relationT A) : relationT (B * A) :=
  snd_relI : forall x y z, R x y -> @snd_rel A B R (z : B, x) (z, y).

Lemma fext_e: forall (U W : Type) (pr : rlsT (list U * W)) ps cl cr Φ1 Φ2,
  pr ps (cl, cr) ->
  fst_ext_rls pr (map (apfst (fmlsext Φ1 Φ2)) ps) (Φ1 ++ cl ++ Φ2, cr).
Proof.  intros * H. rewrite <- fmlsext_def.
  eapply fextI. eapply rmI_eq. exact H. reflexivity.  reflexivity.  Qed.

Lemma sext_e: forall (U W : Type) (pr : rlsT (U * list W)) ps cl cr Φ1 Φ2,
  pr ps (cl, cr) ->
  snd_ext_rls pr (map (apsnd (fmlsext Φ1 Φ2)) ps) (cl, Φ1 ++ cr ++ Φ2).
Proof.  intros * H. rewrite <- fmlsext_def.
  eapply sextI. eapply rmI_eq. exact H. reflexivity.  reflexivity.  Qed.

Ltac concl_in_app X0 r sea :=
  pose X0 as r ; apply sea in r ;
  destruct r ; subst ; rewrite ?app_nil_r ; rewrite ?app_nil_l ;
  simpl in X0 ; rewrite ?app_nil_r in X0.

Ltac fwl_tac mid := eexists ; split ;
  [> assoc_mid mid ; apply fext_e ; eassumption |
    apply ForallTI_forall ; intros x inms ; apply InT_mapE in inms ;
    destruct inms as [x0 p] ; destruct p as [sex int] ;
    destruct x0 ; simpl in sex ; unfold fmlsext in sex ; destruct sex ;
    eexists ; split ;
      [> eapply InT_map ; eassumption |
      simpl ; unfold fmlsext ; apply fst_relI ; swap_tac ]].

Ltac fwr_tac mid := eexists ; split ;
  [> assoc_mid mid ; apply sext_e ; eassumption |
    apply ForallTI_forall ; intros x inms ; apply InT_mapE in inms ;
    destruct inms as [x0 p] ; destruct p as [sex int] ;
    destruct x0 ; simpl in sex ; unfold fmlsext in sex ; destruct sex ;
    eexists ; split ;
      [> eapply InT_map ; eassumption |
      simpl ; unfold fmlsext ; apply snd_relI ; swap_tac ]].

Lemma exchL_std_rule: forall U W (rules : rlsT (list U * W)),
  (forall ps U S, rules ps (U, S) -> sing_empty U) ->
  forall ps c, fst_ext_rls rules ps c ->
    can_trf_rules (fst_rel (@swapped _)) (fst_ext_rls rules) ps c.
Proof. unfold can_trf_rules.
intros U W rules se ps c sqr c' fr.
pose (fun ps xs ys S rps =>
  sing_empty_app xs ys (se ps (xs ++ ys) S rps)) as sea.
inversion fr. subst. clear fr.
inversion sqr. clear sqr. subst.
inversion X0. destruct c as [pl pr].
simpl in H1. unfold fmlsext in H1.
inversion H1. subst. clear H1. clear X0.
inversion X. subst.
acacD'T2 ; subst.
- concl_in_app X1 r sea.  + fwl_tac H3.  + fwl_tac H1.
- concl_in_app X1 r sea.  concl_in_app X1 r sea.
+ fwl_tac H5.  + fwl_tac C.
+ list_eq_nc. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
simpl in X1. rewrite ?app_nil_r in X1.
fwl_tac H1.
- fwl_tac pl.
- concl_in_app X1 r sea.  + fwl_tac H5.  + fwl_tac H3.
- fwl_tac pl.
- fwl_tac pl.
- concl_in_app X1 r sea.  + fwl_tac H1.  + fwl_tac H.
- concl_in_app X1 r sea.  concl_in_app X1 r sea.
+ fwl_tac H3.  + fwl_tac B.
+ list_eq_ncT. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwl_tac H.
- concl_in_app X1 r sea.  concl_in_app X1 r sea. concl_in_app X1 r sea.
+ fwl_tac H5.  + fwl_tac C.
+ list_eq_ncT. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwl_tac B.
+ list_eq_nc. destruct e.  list_eq_nc. destruct H1. subst.
rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwl_tac H.
- fwl_tac pl.
Qed.

Print Implicit exchL_std_rule.

Lemma exchR_std_rule: forall U W (rules : rlsT (U * list W)),
  (forall ps U S, rules ps (U, S) -> sing_empty S) ->
  forall ps c, snd_ext_rls rules ps c ->
    can_trf_rules (snd_rel (@swapped _)) (snd_ext_rls rules) ps c.
Proof. unfold can_trf_rules.
intros U W rules se ps c sqr c' fr.
pose (fun ps xs ys U rps =>
  sing_empty_app xs ys (se ps U (xs ++ ys) rps)) as sea.
inversion fr. subst. clear fr.
inversion sqr. clear sqr. subst.
inversion X0. destruct c as [pl pr].
simpl in H1. unfold fmlsext in H1.
inversion H1. subst. clear H1. clear X0.
inversion X. subst.
acacD'T2 ; subst.
- concl_in_app X1 r sea.  + fwr_tac H3.  + fwr_tac H1.
- concl_in_app X1 r sea.  concl_in_app X1 r sea.
+ fwr_tac H5.  + fwr_tac C.
+ list_eq_nc. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
simpl in X1. rewrite ?app_nil_r in X1.
fwr_tac H1.
- fwr_tac pr.
- concl_in_app X1 r sea.  + fwr_tac H5.  + fwr_tac H3.
- fwr_tac pr.
- fwr_tac pr.
- concl_in_app X1 r sea.  + fwr_tac H1.  + fwr_tac H.
- concl_in_app X1 r sea.  concl_in_app X1 r sea.
+ fwr_tac H3.  + fwr_tac B.
+ list_eq_ncT. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwr_tac H.
- concl_in_app X1 r sea.  concl_in_app X1 r sea. concl_in_app X1 r sea.
+ fwr_tac H5.  + fwr_tac C.
+ list_eq_ncT. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwr_tac B.
+ list_eq_nc. destruct e.  list_eq_nc. destruct H1. subst.
rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwr_tac H.
- fwr_tac pr.
Qed.

Print Implicit exchR_std_rule.

Definition rev_pair {U W} (p : U * W) := let (x, y) := p in (y, x).

Lemma sext_rev_fext U W (rules : rlsT (U * list W)) ps c :
  snd_ext_rls rules ps c ->
  fst_ext_rls (rlsmap rev_pair rules) (map rev_pair ps) (rev_pair c).
Proof. intro ser. destruct ser.  inversion r. destruct c0.
clear r. subst. simpl.
eapply fextI.  eapply rmI_eq. apply rmI. exact X.
2: reflexivity.
clear X.  induction ps0. reflexivity.
simpl. rewrite IHps0.  destruct a. reflexivity. Qed.

Print Implicit sext_rev_fext.

(*
this is not going to be worthwhile without a bunch more lemmas
such as sext_rev_fext above, and more

Lemma exchR_std_rule: forall U W (rules : rlsT (U * list W)),
  (forall ps U S, rules ps (U, S) -> sing_empty S) ->
  forall ps c, snd_ext_rls rules ps c ->
    can_trf_rules (snd_rel (@swapped _)) (snd_ext_rls rules) ps c.
Proof. intros * se * ser.
pose (rlsmap rev_pair rules) as rrules.
pose (@exchL_std_rule _ _ rrules).
require c0.
{ intros * rr.  inversion rr. destruct c1. simpl in H1. inversion H1. subst.
eapply se. subst rrules. exact X. }
specialize (c0 (map rev_pair ps) (rev_pair c)).
require c0.  { subst rrules. exact (sext_rev_fext ser). }

destruct ser.
eapply fextI. inversion r.

*)

(* we may also want to refer to rules individually *)
Inductive Idrule (W : Type) : rlsT (rel (list W)) :=
  | Idrule_I : forall A, Idrule [] (pair [A] [A]).

Lemma sr_Id_alt X (A : X) ant suc: InT A ant -> InT A suc ->
  seqrule (@Idrule X) [] (ant, suc).
Proof. intros. apply InT_split in X1.
apply InT_split in X0. cD. subst.
eapply Sctxt_eq. apply (Idrule_I A).
simpl. reflexivity.  simpl. reflexivity.  simpl. reflexivity. Qed.


(** * Functors involving coproduct categories *)
Require Import Category.Sum Functor.Core Functor.Composition.Core Functor.Identity.
Require Import Functor.Paths HoTT.Tactics Types.Forall.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

(** We save [inl] and [inr] so we can use them to refer to the functors, too.  Outside of the [Categories/] directory, they should always be referred to as [Functor.inl] and [Functor.inr], after a [Require Functor].  Outside of this file, but in the [Categories/] directory, if you do not want to depend on all of [Functor] (for e.g., speed reasons), they should be referred to as [Functor.Sum.inl] and [Functor.Sum.inr] after a [Require Functor.Sum]. *)
Local Notation type_inl := inl.
Local Notation type_inr := inr.

(** ** Injections [inl : C → C + D] and [inr : D → C + D] *)
Section sum_functors.
  Variables C D : PreCategory.

  Definition inl : Functor C (C + D)
    := Build_Functor C (C + D)
                     (@inl _ _)
                     (fun _ _ m => m)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).

  Definition inr : Functor D (C + D)
    := Build_Functor D (C + D)
                     (@inr _ _)
                     (fun _ _ m => m)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).
End sum_functors.

(** ** Coproduct of functors [F + F' : C + C' → D] *)
Section sum.
  Variables C C' D : PreCategory.

  Definition sum (F : Functor C D) (F' : Functor C' D)
  : Functor (C + C') D.
  Proof.
    refine (Build_Functor
              (C + C') D
              (fun cc'
               => match cc' with
                    | type_inl c => F c
                    | type_inr c' => F' c'
                  end)
              (fun s d
               => match s, d with
                    | type_inl cs, type_inl cd
                      => fun m : morphism _ cs cd => F _1 m
                    | type_inr c's, type_inr c'd
                      => fun m : morphism _ c's c'd => F' _1 m
                    | _, _ => fun m => match m with end
                  end%morphism)
              _
              _);
    abstract (
        repeat (intros [] || intro);
        simpl in *;
          auto with functor
      ).
  Defined.
End sum.

(** ** swap : [C + D → D + C] *)
Section swap_functor.
  Definition swap C D
  : Functor (C + D) (D + C)
    := sum (inr _ _) (inl _ _).

  Local Open Scope functor_scope.

  Definition swap_involutive_helper {C D} c
  : (swap C D) ((swap D C) c)
    = c
    := match c with type_inl _ => idpath | type_inr _ => idpath end.

  Lemma swap_involutive `{Funext} C D
  : swap C D o swap D C = 1.
  Proof.
    path_functor.
    exists (path_forall _ _ swap_involutive_helper).
    repeat (apply (@path_forall _); intro).
    repeat match goal with
               | [ |- context[transport (fun x' => forall y, @?C x' y) ?p ?f ?x] ]
                 => simpl rewrite (@transport_forall_constant _ _ C _ _ p f x)
           end.
    transport_path_forall_hammer.
      by repeat match goal with
                  | [ H : Empty |- _ ] => destruct H
                  | [ H : (_ + _)%type |- _ ] => destruct H
                  | _ => progress hnf in *
                end.
  Qed.
End swap_functor.

Module Export FunctorSumNotations.
  Notation "F + G" := (sum F G) : functor_scope.
End FunctorSumNotations.