(** * Semantic Cut-Elimination (following Su & Sano ) *)

Require Import models nd forms decidability toolbox.
Require Import PslBase.Base.

Section Canonical.
  (**
We define the *canonical models*, whose worlds are the maximally consistent theories.
We first define the relations.
   **)
  Context {d : DerivationType}.
    Variable A0 : context.
  Variable s0 : form.
  Definition U' := scl (s0::(K ⊥)::A0).

  Record mcTheory := mkmcTheory {
                         T: list form;
                         B: form;
                         Tgood: ~(gen T B);
                         Tsubs: T <<= U' ;
                         Tlcons: forall A, A el U' -> A el T \/ (gen (A::T) B) ;
                       }.

  (** Define extension operator on theories  **)

  Definition single_extend (Ω: context) (A: form) (a: form) :=
    if (@gen_dec (a::Ω) A d) then Ω else (a::Ω).

  Lemma single_extend_subcontext  A Ω B: Ω <<= (single_extend Ω A B).
  Proof.
    intros a Ha.  unfold single_extend. destruct (gen_dec (B :: Ω) A d); eauto.
  Qed.
  Fixpoint extend (Ω: context) (A: form) (Γ: context) : context :=
    match Γ with
      nil => Ω
    | (a::Γ') =>
      single_extend (extend Ω A Γ') A a  end.

  Lemma extend_does_not_derive Ω A Γ: ~(gen Ω A) -> ~(gen (extend Ω A Γ) A).
  Proof.
    revert Ω.
    induction Γ; eauto.
    - intros.  destruct (gen_dec (a :: extend Ω A Γ) A d) eqn:di.
      +  simpl extend. unfold single_extend. rewrite di. apply IHΓ.  auto.
      +  simpl extend. unfold single_extend. rewrite di. apply n.
  Qed.

  Lemma extend_subset Ω Γ A: Ω <<= (extend Ω A Γ).
  Proof.
    revert Ω.
    induction Γ; eauto.
    - intro.  simpl extend. unfold single_extend.  destruct (gen_dec (a :: extend Ω A Γ) A d); eauto.
  Qed.

  Lemma extend_disjunction  Γ Ω A B: ~(gen Ω A) -> B el Γ ->  B el (extend Ω A Γ) \/ (gen (B::(extend Ω A Γ)) (A)).
  Proof.
    intros H H0. induction Γ.
    - inversion H0.
    -  destruct H0.
       + subst a. simpl extend. unfold single_extend. destruct (gen_dec (B :: extend Ω A Γ) A d).  tauto.   left. auto.
       + specialize (IHΓ H0).   destruct IHΓ. left.   simpl extend. unfold single_extend. destruct (gen_dec (a :: extend Ω A Γ) A d); eauto.
         * right. apply genW with ((B :: extend Ω A Γ)); auto.  intros x Hx. destruct Hx.
           -- subst x. eauto.
           --  right.   simpl extend. unfold single_extend. destruct (gen_dec (a :: extend Ω A Γ) A d); auto.
  Qed.

  Lemma extend_locally_prime Γ Ω A B C:  ~(gen Ω A) -> (B ∨ C) el (extend Ω A Γ)  -> B el Γ -> C el Γ -> B el (extend Ω A Γ) \/ C el (extend Ω A Γ).
  Proof.
    intros. destruct (extend_disjunction H H1); try tauto.  destruct (extend_disjunction H H2); try tauto. exfalso.
    specialize (@extend_does_not_derive Ω A Γ H). intro. apply H5. apply genOL with B C.  auto. auto. auto.
   Qed.

  Lemma extend_locally_easy_subset Ω A Γ: (extend Ω A Γ) <<= (Ω ++ Γ).
  Proof.
    revert Ω. induction Γ. eauto. intros.  simpl extend. unfold single_extend. destruct (gen_dec (a :: extend Ω A Γ) A d); auto.
    specialize (IHΓ Ω). intros b Hb.  apply  IHΓ in Hb. apply in_app_iff. apply in_app_iff in Hb. destruct Hb. tauto. right. right. assumption.
    intros b Hb.  destruct Hb; eauto. subst b; eauto. apply IHΓ in H.  apply in_app_iff in H; destruct H; apply in_app_iff; try tauto. right. right. auto.
  Qed.

  Lemma extend_locally_subset Γ A Ω: Ω <<= Γ -> (extend Ω A Γ) <<= Γ.
  Proof.
    intros. enough (extend Ω A Γ <<= Γ ++ Γ).  intros a Ha. specialize (H0 a Ha). apply in_app_iff in H0; destruct H0; assumption.
    enough (extend Ω A Γ <<= Ω ++ Γ). intros a Ha. specialize (H0 a Ha).  apply in_app_iff in H0. destruct H0; eauto.  apply extend_locally_easy_subset.
  Qed.
  (* Not deriven implies adding it causes us to derive A *)
  Definition U'_sfc : sf_closed U' := @scl_closed _.

  Definition subsetMKT (A B: mcTheory) :=  (T A) <<= (T B).
  Definition valuationMKT (A: mcTheory) (a: nat) := (Var a) el (T A).
  Definition subsetVerif (A B:mcTheory) := (unK (T A)) <<= (T B).

  Instance canonical: (KripkeModel).
  Proof.
    apply mkKripkeModel with (world := mcTheory) (cogn := subsetMKT) (val := valuationMKT) (verif := subsetVerif).
    firstorder.  firstorder.
    + intros A B c d' E. unfold subsetVerif in c.  apply c.  apply unK_in_iff.  eauto.
    +   intros x y z H H0. intros a Ha.  apply unK_in_iff in Ha. destruct Ha; auto.  apply H0. apply unK_in_iff. left. apply H. auto. apply H0. apply unK_in_iff. right. apply H.  auto.
  Defined.

  Definition Lindenbaum (Γ : list form) (A: form) (H: Γ <<= U') (H'': A el U') (H': ~(gen Γ A)) : mcTheory.
  Proof.
    eapply mkmcTheory.
    - apply extend_does_not_derive.  apply H'.
    - apply extend_locally_subset.     auto.
    - intro.
      intro.
      specialize (@extend_does_not_derive Γ A U' H'). intro.
      specialize (extend_disjunction H' H0). intro. destruct H2.
      +  left.  apply H2.
      +  right.   auto.
  Defined.

  Lemma mctheory_conjucntion (Δ: mcTheory) A B: (A ∧ B) el (T Δ) -> (A el (T Δ)) /\  (B el (T Δ)).
  Proof.
    intros.
    split.
    - destruct Δ. simpl.  cbn in H.  specialize (  Tlcons0 A). destruct Tlcons0. enough ((A ∧ B) el U'). apply U'_sfc in H0; tauto.  eauto.   auto. exfalso. apply Tgood0. apply genAL with A B.  auto.  apply genW with ((A :: T0)). auto.  firstorder eauto.
    - destruct Δ. simpl.  cbn in H.  specialize (  Tlcons0 B). destruct Tlcons0. enough ((A ∧ B) el U'). apply U'_sfc in H0; tauto.  eauto.   auto. exfalso. apply Tgood0. apply genAL with A B.  auto.  apply genW with ((B :: T0)). auto.  firstorder eauto.
  Qed.

  Lemma mctheory_disjunction (Δ: mcTheory) A B: (A ∨ B) el (T Δ) -> (A el (T Δ)) \/  (B el (T Δ)).
  Proof.
    destruct Δ. intros.
    intros. decide (A el (T0)); decide (B el (T0)). all: try tauto.
    cbn in H. cbn. enough (A el U'). enough (B el U'). pose proof (Tlcons0 A H0) as Ha.   pose proof (Tlcons0 B H1) as Hb.  destruct Ha; destruct Hb; try tauto.
    exfalso. apply Tgood0. apply genOL with  A B. auto. auto. auto. all: apply Tsubs0 in H;   apply U'_sfc in H; tauto.
  Qed.

  Lemma truth_lemma : forall (x: form), In x U' -> forall (t: (@world  canonical)), ( (x el (T t) -> (evalK x t))  /\( ~(gen (T t) x) -> ~(evalK x t))).
  Proof.
    intro x. intro Hx. induction x.
    - intros w. split.
      + intros H w' v.  apply IHx. apply U'_sfc in Hx. auto.   apply v. apply unK_in_iff. tauto.
      + intros D D1.   assert (~(gen (unK (T w)) x)).   intro. apply D. apply genKI. auto. apply U'_sfc in Hx.  specialize (IHx Hx).
        assert (exists Δ: mcTheory, (unK (T w)) <<= (T Δ)
                                   /\ ~(gen (T Δ) (x))).
        {
          assert ((unK (T w)) <<= U'). { destruct w.  intros a Ha. apply unK_in_iff in Ha.  destruct Ha; auto.  assert (K a el U') by auto.  apply U'_sfc in H1.  assumption. }
          eexists (@Lindenbaum  (unK (T w)) x H0 Hx H). split.
          - simpl. apply extend_subset.
          - simpl. apply extend_does_not_derive.  auto.
        }

        destruct H0 as (w' & Hw').
        specialize (IHx w').  destruct IHx. destruct Hw'.  specialize (H1 H3). specialize (D1 w').   apply H1. apply D1. auto.

    - intros w.  split.
      + intro H. apply U'_sfc in Hx. intros w' Hw' c. assert (x2 el (T w') \/ ~(gen (T w') x1)).
        {
          decide (x2 el (T w')); try tauto.
          right. intro.
          destruct w'. cbn in H0. destruct (Tlcons0 x2).  tauto. cbn in n. congruence.
          cbn in n. apply Tgood0. apply genIL with x1 x2.  auto. auto.  auto.
        }
        destruct H0.
        *  apply IHx2. tauto. auto.
        *  apply IHx1 in H0.   congruence. tauto.
      + intro. intro. assert (~ gen (x1::(T w)) x2). {
          intro. apply H. apply genIR. auto.
        }
        enough (exists w' : mcTheory, (x1::(T w)) <<= (T w') /\ ~(gen (T w') x2)).
        destruct H2 as (w' & Hw' & Hw'2).
        apply U'_sfc in Hx. destruct Hx as (Hx1 & Hx2). specialize (IHx2 Hx2 w'). specialize (IHx1 Hx1 w').    destruct IHx2. apply H3.  auto.
        apply H0. intros a Ha.  apply Hw'.  auto.  apply IHx1.  apply Hw'.  auto.
        assert ((x1::(T w)) <<= U'). {  intros a Ha. destruct Ha.  subst a. apply U'_sfc in Hx; tauto.  destruct w; eauto. }
                                    apply U'_sfc in Hx; destruct Hx.
          eexists (@Lindenbaum  (x1::(T w)) x2 H2 H4 H1). split.
          * simpl. apply extend_subset.
          * simpl. apply extend_does_not_derive.  auto.

    - intros w.  split.
      + intro. apply mctheory_conjucntion in H.  split.
        * apply IHx1. apply U'_sfc in Hx.  tauto.  tauto.
        * apply IHx2.  apply U'_sfc in Hx.  tauto.  tauto.
      + intro.    intro.  destruct H0.
        assert (~(gen (T w) x1) \/ ~(gen (T w) x2)). {
          destruct (gen_dec (T w) x1 d).  destruct (gen_dec (T w) x2 d).  exfalso. apply H. apply genAR; auto. tauto.  tauto.
        }
        apply U'_sfc in Hx.  destruct Hx as (Hx1 & Hx2). specialize (IHx1 Hx1 w). specialize (IHx2 Hx2 w). destruct IHx1, IHx2.   destruct H2.
        * specialize (H4 H2). congruence.
        * specialize (H6 H2). congruence.
    - intros w. split.
      + intro. apply mctheory_disjunction in H.  destruct H.
        * simpl evalK. left. apply IHx1. apply U'_sfc in Hx; tauto.  auto.
        * right. apply IHx2. apply U'_sfc in Hx; tauto.  auto.
      +  apply U'_sfc in Hx.  destruct Hx as (Hx1 & Hx2).
         intro. intro. apply H.   destruct H0.
         * apply genOR1. destruct (gen_dec (T w) x1 d); try tauto.   apply IHx1 in n.  congruence.  tauto.
         * apply genOR2. destruct (gen_dec (T w) x2 d); try tauto.   apply IHx2 in n.  congruence.  tauto.
    -  intros w. split.
       + intro.  simpl evalK. destruct w. apply Tgood0. apply genF. auto.
       + intro. intro.  unfold evalK in H0. auto.
    -  intros w. split.
       + intro. apply H.
       + intro.   intro. apply H. apply genV. apply H0.
  Qed.

  Lemma are_iel_models: d = normal -> forall w, exists u, verif w u.
  Proof.
    intros.
    assert (exists Δ: mcTheory, (unK (T w)) <<= (T Δ)).
    {
      destruct w.
      assert (~(gen (unK T0) (⊥))).
      intro. apply Tgood0. rewrite H.   apply genKB. apply genKI. subst d.   eapply H0.

      enough (unK (T0) <<= U').
      assert (⊥ el U'). {
        unfold U'. simpl.  firstorder eauto.
      }
      exists (Lindenbaum  H1 H2 H0).
      simpl T. enough (unK (T0) <<= (extend (unK T0) (⊥) U')).
      intros a Ha. apply H3. assumption.
      apply extend_subset; auto.
      intros a Ha.   apply unK_in_iff in Ha; destruct Ha; eauto.
      apply Tsubs0 in H1.  apply U'_sfc in H1.  auto.
    }
    destruct H0.  exists x.  firstorder eauto.
  Qed.

    Lemma completeness' Ω A: A el U' -> Ω <<= U' -> entails Ω A -> gen Ω A.
  Proof.
    intros Au U H. destruct (gen_dec Ω A d); auto.  exfalso.
    unfold entails in H.
    specialize (H (@canonical)).
     assert (exists Δ: mcTheory, ~(gen (T Δ) A) /\ (Ω <<= (T Δ))).
     {
       eexists (Lindenbaum  U Au n). split.
       - simpl.  apply extend_does_not_derive.   auto.
       - simpl.   apply extend_subset.
     }
     assert (model_constraint canonical). {
       destruct d eqn:dn; simpl; auto. unfold isIEL.  apply are_iel_models. auto.

     }
     specialize (H H1).
     destruct (H0) as [Δ H2].
     specialize (H Δ). destruct H2.
     decide (A el (T Δ)).
    + apply H2. apply genA.  auto.
    +
      pose proof (truth_lemma Au Δ).

      destruct H4. specialize (H5 H2).   apply H5.  apply H.   unfold evalK'.   intros s H6.
      apply truth_lemma.  auto.  auto.
  Qed.

End Canonical.

Lemma completeness Ω A (D: DerivationType): entails Ω A -> gen Ω A.
Proof.
  intro. apply completeness' with Ω A. unfold U'. apply scl_incl'. auto. intros a Ha. apply scl_incl'. auto. auto.
Qed.

Lemma soundnessGen (Γ: context) (A: form) {D: DerivationType}:
  gen Γ A -> entails Γ A.
Proof.
  intros H % gen2nd.  eapply soundness.  auto.
Qed.

(**
   ** Semantic Cut-Elimination
 **)

Lemma semaCut Γ A (D: DerivationType):
  nd Γ A -> gen Γ A.
Proof.
  intro. apply soundness in H. apply completeness.  assumption.
Qed.
(** Soundness w.r.t gen used by using nd soundness **)
Lemma semaCut' Γ A B (D: DerivationType):
  gen Γ A -> gen (A::Γ) B -> gen Γ B.
Proof.
  intros H1 % gen2nd H2 % gen2nd.
  apply semaCut.
  eauto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Qring.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Qfield.


(** * Coproduct of natural transformations *)
Require Import Category.Core Functor.Core Category.Sum Functor.Sum NaturalTransformation.Core.

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

Section sum.
  Definition sum
             C C' D F G F' G'
             (T : @NaturalTransformation C D F G)
             (T' : @NaturalTransformation C' D F' G')
  : NaturalTransformation (F + F') (G + G').
  Proof.
    refine (Build_NaturalTransformation
              (F + F') (G + G')
              (fun x => match x with
                          | Datatypes.inl c => T c
                          | Datatypes.inr c' => T' c'
                        end)
              _).
    abstract (
        repeat (intros [] || intro); simpl;
        auto with natural_transformation
      ).
  Defined.
End sum.

Module Export NaturalTransformationSumNotations.
  Notation "T + U" := (sum T U) : natural_transformation_scope.
End NaturalTransformationSumNotations.


Require Export sequences_AX.

Module lub_proof(N:Num_w).

Import N.
Module Export UU := seq(N).

Axiom lim_not_lim : forall n v, lim n/\0<=n -> ~lim v/\0<=v -> n <v.

Lemma foo :
forall S : subset,
forall Hdec : forall alpha beta : HRw,
       beta [>] alpha -> {s : HRw | S s /\ s [>] alpha} + {upper_bound S beta},
forall s0 : HRw,
forall Hs0 : S s0,
forall b0' : HRw,
forall b0,
forall Hb0 : b0 = b0' [+] [1],
forall Hup : upper_bound S b0,
forall s_b_alpha_beta : forall (k : A) (Hk : std k /\ 0 <= k),
                 {sn : HRw & {bn : HRw & Psb S s0 b0 k Hk sn bn}},
forall Hs_b_alpha_beta : s_b_alpha_beta = def_s_b_alpha_beta S Hdec s0 b0 Hs0 Hup,
forall ss : forall k0 : A, std k0 /\ 0 <= k0 -> HRw,
forall Hss : ss = fun (k0 : A) (Hk0 : std k0 /\ 0 <= k0) =>
      projT1 (s_b_alpha_beta k0 Hk0),
forall bb : forall k0 : A, std k0 /\ 0 <= k0 -> HRw,
forall Hbb : bb = fun (k0 : A) (Hk0 : std k0 /\ 0 <= k0) =>
      projT1 (projT2 (s_b_alpha_beta k0 Hk0)),
forall ssA : forall k0 : A, std k0 /\ 0 <= k0 -> A,
forall HssA : ssA = fun (k0 : A) (Hk0 : std k0 /\ 0 <= k0) => proj1_sig (ss k0 Hk0),
forall bbA : forall k0 : A, std k0 /\ 0 <= k0 -> A,
forall HbbA : bbA = fun (k0 : A) (Hk0 : std k0 /\ 0 <= k0) => proj1_sig (bb k0 Hk0),
forall v1 : A,
forall Hv1 : ~ lim v1 /\
      0 < v1 /\
      (forall k : A,
       0 <= k /\ k <= v1 -> extends ssA k <= min k (extends bbA)),
forall v2 : A,
forall Hv2 : ~ lim v2 /\
      0 < v2 /\
      (forall n : A,
       0 <= n /\ n <= v2 ->
       forall m : A, 0 <= m -> m < n -> extends ssA m <= extends ssA n),
forall n : A,
forall Hlim : std n,
forall Hlt : 0 <= n,
extends ssA n <= min (minA v1 v2) (extends bbA).
Proof.
intros.
elim (A0_dec (v1 + - v2)). (* Meaning ? *)
intros Hv1v2.
apply le_trans with (min v1 (extends bbA)).
apply le_trans with (extends ssA  v1).
decompose [and] Hv2.
apply H3.
split.
apply lt_le; solve[intuition].
setoid_replace v2 with (0+v2) by ring.
setoid_replace v1 with ((v1 + -v2)+v2) by ring.
apply le_plus.
elim Hv1v2; intros Hv1v2'.
apply lt_le; assumption.
rewrite Hv1v2'; apply le_refl.
apply le_refl.
assumption.
assert (nlim:lim n).
apply std_lim; assumption.
apply lim_not_lim; solve [intuition | intuition; apply lt_le; intuition].
decompose [and] Hv1.
apply H3; split;  solve[intuition | intuition; apply lt_le; intuition | apply le_refl ].
apply min_def2.
unfold minA; destruct (A0_dec (v1 +- v2)).
apply le_refl.
elim Hv1v2.
intros.
assert (Hf:False)
  by (apply contradict_lt_le with (s:=v1+ - v2) (x:=0); [ assumption | apply lt_le; assumption]).
destruct Hf.
intros Hrew; rewrite Hrew in l.
assert (Hf:False) by (apply not_lt_0_0; assumption).
destruct Hf.
intros Hv1v2.
apply le_trans with (min v2 (extends bbA)).
apply le_trans with (extends ssA  v2).
decompose [and] Hv2.
apply H3.
split.
apply lt_le; assumption.
apply le_refl.
assumption.
assert (nlim : lim n).
apply std_lim; assumption.
apply lim_not_lim;  solve [intuition | intuition; apply lt_le; intuition].
decompose [and] Hv1.
apply H3.
split.
apply lt_le; solve [intuition].
setoid_replace v2 with (0+v2) by ring.
setoid_replace v1 with ((v1 + -v2)+v2) by ring.
apply le_plus.
apply lt_le; assumption.
apply le_refl.
apply min_def2.
unfold minA.
destruct (A0_dec (v1 + - v2)).
destruct s.
assert (Hf:False)
  by (apply contradict_lt_le with (s:=v1+ - v2) (x:=0); [ assumption | apply lt_le; assumption]).
destruct Hf.
rewrite e in Hv1v2.
assert (Hf:False) by (apply not_lt_0_0; assumption).
destruct Hf.
apply le_refl.
Qed.

Lemma least_upper_bound_principle :
  forall S:subset, non_empty S -> bound_above S ->
    (forall alpha beta:HRw,  beta [>] alpha ->
      {s:HRw| S s /\ s [>] alpha}+{upper_bound S beta}) ->
   has_least_upper_bound S.
Proof.
intros S Hnon_empty Hbound Hdec.
elim Hnon_empty; intros s0 Hs0.
elim Hbound; intros b0' Hb0'.

pose (b0 := b0' [+] [1]).
assert (Hup:(upper_bound S b0)) by (unfold b0; apply HRwgt_upper_bound; assumption).
assert (b0 [>] s0) by (unfold b0; apply Hup; assumption).
pose (s_b_alpha_beta := (def_s_b_alpha_beta S Hdec s0 b0 Hs0 Hup)).
(* avec valeurs dans HRw *)
pose (ss := fun k0 Hk0 =>  (projT1  (s_b_alpha_beta k0 Hk0))).
pose (bb := fun k0 Hk0 => (projT1 (projT2  (s_b_alpha_beta k0 Hk0)))).
(* avec valeurs dans A *)
pose (ssA := (fun k0 Hk0 => proj1_sig (ss k0 Hk0))).
pose (bbA := (fun k0 Hk0 => proj1_sig (bb k0 Hk0))).

assert (Hbn_sup_sn : (forall n, std n /\ 0<=n ->  (forall k, forall Hk:(std k/\ 0 <=k), k<=n ->
  (ssA k Hk) <= (min_lim n bbA)))).
intros n (Hlimn, Hlen) k (Hlimk,Hlek) Hkn.
replace (ssA k (conj Hlimk Hlek)) with (proj1_sig (ss k (conj Hlimk Hlek))) by solve[trivial].
assert (HS:(S (ss k (conj Hlimk Hlek)))).
unfold ss.
elim (s_b_alpha_beta k (conj Hlimk Hlek)).
intros sk (bk, (Hsk,(Hbk,H'))).
simpl; solve [intuition].
apply min_lim_prop.
intros p (Hlimp,Hlep) Hpn.
apply lt_le.
assert (bb p (conj Hlimp Hlep) [>] ss k (conj Hlimk Hlek)).
unfold ss.
elim (s_b_alpha_beta k (conj Hlimk Hlek)).
intros sk (bk,(Hsk,(Hbk,H'))).
simpl; unfold bb.
elim (s_b_alpha_beta p (conj Hlimp Hlep)).
intros sp (bp,(Hsp,(Hbp,Hp'))).
simpl; unfold upper_bound in Hbp.
apply Hbp.
solve [intuition].
apply HRwgt_Zgt.
assumption.

assert (Hsn_increasing : forall n, forall Hn:std n/\0<= n, forall m, forall (Hm:std m/\0<= m),
  n <= m -> ssA n Hn <= ssA m Hm).
intros.
apply thm_Hsn_increasing with (S:=S) (Hdec:=Hdec) (s0:=s0) (b0:=b0) (Hs0:=Hs0) (Hb0S := Hup) (n:=m) (m:=n) (bbA:=bbA).
unfold ssA,ss, s_b_alpha_beta; trivial.
unfold bbA,bb, s_b_alpha_beta; trivial.
assumption.

assert (Hequal : forall n:A, forall Hn: std n /\ 0<= n,
  (HRwequal (HRwminus (bb n Hn) (ss n Hn))
                     (HRwmult (power two_third n Hn) (HRwminus b0 s0)))).
intros n Hn.
unfold bb,ss; elim (s_b_alpha_beta n Hn).
intros sn (bn, (Hsn,(Hbn,Hequaln))).
simpl.
unfold HRwminus in *.
subst.
assumption.

(* we overspill the min_bn_sup_sn using the magic function "extends" *)
assert (Hbn_sup_sn' : exists v:A, ~lim v /\ 0<v /\
  (forall k, 0 <=k /\ k<=v ->  (extends ssA) k <= (min k (extends bbA)))).
apply (overspill_principle' (fun m => extends ssA m <= min m (extends bbA))).
intros.
apply min_prop.
intros.
solve [intuition].
rewrite <- extends_id with (H:=H1).
intros.
assert (H2': std k /\ 0<=k).
solve [intuition].
rewrite <- extends_id with (H:=H2').
apply le_trans with (min_lim n bbA).
apply Hbn_sup_sn with (n:=n).
assumption.
apply le_refl.
apply min_lim_def.
assumption.
assumption.

assert (Hsn_increasing' : exists v:A,~lim v /\ 0<v /\ forall (n : A), 0 <= n /\ n<= v ->
forall (m : A), 0<=m -> m < n -> (extends ssA) m  <= (extends ssA) n).

assert (Hsn_increasing'' : exists v : A,
         ~ lim v /\
         0 < v /\
         (forall n : A,
          0 <= n /\ n <= v ->
          forall m : A, 0 <= m /\ m <= v -> m < n -> (extends ssA) m  <= (extends ssA) n)).
apply (overspill_principle2 (fun n m => m < n -> extends ssA m <= extends ssA n)).

intros.
rewrite <- (extends_id ssA n H1).
rewrite <- (extends_id ssA m H2).

apply Hsn_increasing.
apply lt_le; assumption.

destruct Hsn_increasing'' as [nv Hnv].
exists nv.
repeat split; try solve [intuition].
intros; apply Hnv; try solve [intuition].
split.
assumption.
apply le_trans with n.
apply lt_le.
assumption.
solve [intuition].

elim Hbn_sup_sn'.
intros v1 Hv1.
elim Hsn_increasing' .
intros v2 Hv2.
pose (bA:=min (minA v1 v2) (extends bbA)).
unfold has_least_upper_bound.
assert (Hb:(P bA)).
assert (Hl0:std 0/\0<=0) by (apply H0std). (*split; [apply lim0 | apply le_refl]).*)

elim (A0_dec bA). (* Meaning ? *)
intros HA0; elim HA0.
intros Hneg.
assert (ssA 0 Hl0 <= bA).
unfold bA.
decompose [and] Hv1.
rewrite (extends_id ssA).
eapply foo with (v1:=v1) (b0:=b0) (b0':=b0') (ss:=ss) (bb:=bb) (ssA:=ssA) (bbA:=bbA)(s_b_alpha_beta:=s_b_alpha_beta); try solve [intuition].
generalize (H0std).
assert (|bA|<=|ssA 0 Hl0|).
rewrite abs_neg_val.
rewrite abs_neg_val.
setoid_replace (-bA) with ((-a1)*bA) by ring.
setoid_replace (- ssA 0 Hl0) with ((-a1)*(ssA 0 Hl0)) by ring.
apply le_mult_neg.
apply lt_m1_0.
assumption.
apply le_trans with bA.
assumption.
apply lt_le; assumption.
apply lt_le; assumption.

assert (P (ssA 0 Hl0)).
replace (ssA 0 Hl0) with (proj1_sig (ss 0 Hl0)) by solve [auto].
apply HRw_P.
elim H3; intros n (Hlimn,(H0n, Hex)).
exists n.
split.
assumption.
split.
assumption.
apply le_trans with (|ssA 0 Hl0 |) ; assumption.
intros Hr; unfold P.
elim P0; intros nP0 HP0; exists nP0; rewrite Hr; solve [intuition].
intros Hpos.
unfold bA.
assert ((min (minA v1 v2) (extends bbA)) <= (extends bbA) 0).
apply min_def.
split.
apply le_refl.
apply minA_le; solve [apply lt_le; intuition].
assert (P (extends bbA 0)).

rewrite <- extends_id with (H:=Hl0) in *.
replace (bbA 0 Hl0) with (proj1_sig (bb 0 Hl0)) by solve [auto].
apply HRw_P.
elim H2; intros n (Hlimn,(H0n, Hex)).
exists n.
split.
assumption.
split.
assumption.
apply le_trans with (| extends bbA 0|).
rewrite abs_pos_val.
rewrite abs_pos_val.
assumption.
apply le_trans with (min (minA v1 v2) (extends bbA)).
apply lt_le; assumption.
assumption.
apply lt_le; assumption.
assumption.
(* ici, on a construit b et on va montrer que c'est bien la plus petite borne supérieure pour S *)
pose (b :=(exist
       (fun x0 : A => exists n1 : A, lim n1 /\ 0 < n1 /\ (|x0 |) <= n1 * w)
       bA Hb)).
exists b.

unfold least_upper_bound.
split.

intros s Hs.
assert (~ (s [>] b)).
intro Hsb.
assert (H1:exists n:A, std n /\ 0 <= n /\ forall (Hyp:std n/\0 <= n),
  (s [+] -w b) [>] ((bb n Hyp) [+] -w (ss n Hyp))). (* (1) *)
apply has_limit with (x:=(b0 [+] (-w s0))) (eps:=s [+] (-w b)).
apply HRwgt_HRwplus_inv_l with s0.
ring_simplify.
unfold upper_bound in Hup; apply Hup; assumption.
apply HRwgt_HRwplus_inv_l with b.
ring_simplify.
assumption.
assumption.

elim H1; clear H1.
intros n (Hlim,(Hlt,H1)).
generalize (H1 (conj Hlim Hlt)); clear H1; intros H1.
assert (H2:(bb n (conj Hlim Hlt) [+] -w (ss n (conj Hlim Hlt))) [>=]
        (bb n (conj Hlim Hlt) [+] -w b)). (* (2) *)
assert (b [>=] (ss n (conj Hlim Hlt))).
apply Zge_HRwge.
simpl.
replace (proj1_sig (ss n (conj Hlim Hlt))) with (ssA n (conj Hlim Hlt)) by solve [auto].
unfold bA.
rewrite extends_id with (H:=conj Hlim Hlt).
(* HHH *)
eapply foo with (v1:=v1) (b0:=b0) (b0':=b0') (ss:=ss) (bb:=bb) (ssA:=ssA) (bbA:=bbA)(s_b_alpha_beta:=s_b_alpha_beta); try solve [intuition].

assert (-w (ss n (conj Hlim Hlt)) [>=] -w b).
apply HRwge_HRwopp; assumption.

rewrite (HRwplus_comm _ (-w b)).
rewrite HRwplus_comm.
apply R2_4'; assumption.

generalize (HRwgt_HRwge_trans _ _ _ H1 H2); intros H3.
generalize (HRwgt_HRwplus_inv_r _ _ (-w b) H3); intros H4.
assert (bb n (conj Hlim Hlt) [>=] s).
unfold bb; elim (s_b_alpha_beta n (conj Hlim Hlt)).
intros sn (bn, (alphan, (betan, Hn))); simpl.
apply HRwgt_HRwge.
unfold upper_bound in *; intuition.
eapply contradict_HRwgt_HRwge ; eassumption.

apply not_HRwgt_HRwge; assumption.

intros b' Hbb'.
assert (H1:exists n:A, std n /\ 0 <= n /\ forall (Hyp:std n/\0 <= n),
  (b [+] -w b') [>] ((bb n Hyp) [+] -w (ss n Hyp))).
apply has_limit with (x:=b0 [+] (-w s0)) (eps:=b [+] (-w b')).
apply HRwgt_HRwplus_inv_l with s0.
ring_simplify.
unfold upper_bound in Hup; apply Hup; assumption.
apply HRwgt_HRwplus_inv_l with b'.
ring_simplify; assumption.
assumption.
elim H1; clear H1.
intros n (Hlim,(Hlt,H1)).
generalize (H1 (conj Hlim Hlt)); clear H1; intros H1.
assert ( (bb n (conj Hlim Hlt)) [>=] b).
apply Zge_HRwge.
change (proj1_sig b <= (bbA n (conj Hlim Hlt))).
unfold b; simpl.
assert (Hnn: (0 <=n /\ n <= minA v1 v2)).
split.
assumption.
assert (~lim (minA v1 v2)) by (apply minA_lim; solve [intuition]).
assert (nlim:lim n).
apply std_lim; assumption.
apply lt_le; apply lim_not_lim.
split; assumption.
split.
assumption.
apply minA_le; solve[apply lt_le; intuition].
rewrite extends_id.
apply (min_def (minA v1 v2) (extends bbA) n Hnn).
assert ((bb n (conj Hlim Hlt) [+] (-w (ss n (conj Hlim Hlt)))) [>=]
            (b [+] (-w (ss n (conj Hlim Hlt))))).
apply R2_4'; assumption.

assert (b [+] (-w b') [>] b [+] (-w ss n (conj Hlim Hlt))).
apply HRwgt_HRwge_trans with (bb n (conj Hlim Hlt) [+] (-w ss n (conj Hlim Hlt))); assumption.
assert ((b [+] (-w (ss n (conj Hlim Hlt)))) [+] ((ss n (conj Hlim Hlt)
           [+] (-w b'))) [>]
b [+] (-w (ss n (conj Hlim Hlt)))).
ring_simplify; unfold HRwminus.
assumption.
assert (H' : (ss n (conj Hlim Hlt) [+] (-w b')) [>] [0]).

apply HRwgt_HRwplus_inv_l with ((b [+] (-w ss n (conj Hlim Hlt)))).
rewrite (HRwplus_comm _ [0]); rewrite HRwplus_zero.
assumption.
revert H'.
unfold ss.
elim (s_b_alpha_beta n (conj Hlim Hlt)).
intros sn (bn, (Hsn,(Hbn,Hn'))).
simpl; intros H'.
exists sn.
split.
solve [intuition].
apply HRwgt_HRwplus_inv_l with (-w b').
rewrite (HRwplus_comm _ b').
rewrite HRwplus_opp.
rewrite HRwplus_comm.
assumption.
Qed.

End lub_proof.


From Hammer Require Import Hammer.

Require Import ExtLib.Core.Type.
Require Import ExtLib.Data.PreFun.
Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Structures.CoFunctor.
Require Import ExtLib.Structures.Monoid.

Set Implicit Arguments.
Set Strict Implicit.

Global Instance proper_id (T : Type) {tT : type T} : proper (fun x => x).
Proof. hammer_hook "Fun" "Fun.proper_id".
repeat red; intros. apply H.
Qed.

Section functors.
Variable A : Type.

Instance FunFunctor A : Functor (Fun A) :=
{ fmap _A _B g f x := g (f x)
}.

Local Instance Functor_Fun : Functor (Fun A) :=
{ fmap _A _B g f x := g (f x) }.

Local Instance CoFunctor_Fun T : CoFunctor (fun x => x -> T) :=
{| cofmap := fun _ _ g f => fun x => f (g x) |}.

Local Instance Functor_functor F G (fF : Functor F) (fG : Functor G) : Functor (fun x => F (G x)) :=
{| fmap := fun _ _ g => @fmap F _ _ _ (@fmap G _ _ _ g) |}.

Local Instance CoFunctor_functor F G (fF : Functor F) (fG : CoFunctor G) : CoFunctor (fun x => F (G x)) :=
{| cofmap := fun _ _ g => @fmap F _ _ _ (@cofmap G _ _ _ g) |}.

Local Instance Functor_cofunctor F G (fF : CoFunctor F) (fG : Functor G) : CoFunctor (fun x => F (G x)) :=
{| cofmap := fun _ _ g => @cofmap F _ _ _ (@fmap G _ _ _ g) |}.

Local Instance CoFunctor_cofunctor F G (fF : CoFunctor F) (fG : CoFunctor G) : Functor (fun x => F (G x)) :=
{| fmap := fun _ _ g => @cofmap F _ _ _ (@cofmap G _ _ _ g) |}.

Local Instance Applicative_Fun : Applicative (Fun A) :=
{ pure := fun _ x _ => x
; ap := fun _ _ f x y => (f y) (x y)
}.

End functors.

Definition Monoid_compose T : Monoid (T -> T) :=
{| monoid_plus g f x := g (f x)
; monoid_unit x := x
|}.

Export PreFun.


Require Import core.Semantics.
Require Import core.Syntax.
Require Import core.Model.
Require Import core.TransformationConfiguration.
Require Import String.
Require Import EqNat.
Require Import List.
Require Import Expressions.
Require Import core.utils.Utils.
Require Import PeanoNat.
Require Import Lia.
Require Import FunctionalExtensionality.

(*********************************************************)
(** * Additivity in OutputPatternLink context            *)
(*********************************************************)

Fixpoint Rule_incl_patternElements {tc: TransformationConfiguration} (l1 l2: list OutputPatternElement) : Prop :=
  match l1, l2 with
  | o1 :: l1', o2 :: l2' =>
      OutputPatternElement_getName o1 = OutputPatternElement_getName o2
      /\ OutputPatternElement_getElementExpr o1 = OutputPatternElement_getElementExpr o2
      /\ (OutputPatternElement_getLinkExpr o1 = OutputPatternElement_getLinkExpr o2 \/
          OutputPatternElement_getLinkExpr o1 = (fun _ _ _ _ _ => None))
      /\ Rule_incl_patternElements l1' l2'
  | nil, nil => True
  | _, _ => False
  end.

Lemma Rule_incl_patternElements_exists:
  forall (tc: TransformationConfiguration) opes1 opes2 o1,
    Rule_incl_patternElements opes1 opes2 -> In o1 opes1 ->
      (exists o2, In o2 opes2 /\
         OutputPatternElement_getName o1 = OutputPatternElement_getName o2
      /\ OutputPatternElement_getElementExpr o1 = OutputPatternElement_getElementExpr o2
      /\ (OutputPatternElement_getLinkExpr o1 = OutputPatternElement_getLinkExpr o2 \/
          OutputPatternElement_getLinkExpr o1 = (fun _ _ _ _ _ => None)) ).
Proof.
intros.
revert H.
revert opes2.
revert H0.
induction opes1.
- contradiction.
- intros.
  simpl in H0.
  destruct H0.
  --  unfold Rule_incl_patternElements in H.
      destruct opes2.
      + contradiction.
      + exists o.
      split; crush.
  --  induction opes2.
      + unfold Rule_incl_patternElements in H.
        contradiction.
      + clear IHopes2.
        assert (Rule_incl_patternElements opes1 opes2).
        {
        unfold Rule_incl_patternElements.
        unfold Rule_incl_patternElements in H.
        crush.
        }
        specialize (IHopes1 H0 opes2 H1).
        destruct IHopes1.
        destruct H2.
        exists x.
        split; auto.
        simpl.
        right.
        auto.
Qed.

Fixpoint Transformation_incl_rules {tc: TransformationConfiguration} (l1 l2: list Rule) : Prop :=
  match l1, l2 with
  | r1 :: l1', r2 :: l2' =>
      Rule_getName r1 = Rule_getName r2
      /\ Rule_getGuardExpr r1 = Rule_getGuardExpr r2
      /\ Rule_getIteratorExpr r1 = Rule_getIteratorExpr r2
      /\ Rule_incl_patternElements (Rule_getOutputPatternElements r1) (Rule_getOutputPatternElements r2)
      /\ Transformation_incl_rules l1' l2'
  | nil, nil => True
  | _, _ => False
  end.

Definition Transformation_incl_links {tc: TransformationConfiguration} (t1 t2: Transformation) : Prop :=
  (Transformation_getArity t1 = Transformation_getArity t2) /\
  (Transformation_incl_rules (Transformation_getRules t1) (Transformation_getRules t2)).

Definition Model_incl {tc: TransformationConfiguration}  (m1 m2: TargetModel) : Prop :=
  incl (allModelElements m1) (allModelElements m2) /\
  incl (allModelLinks m1) (allModelLinks m2).

Lemma Transformation_incl_rules_exists:
  forall (tc: TransformationConfiguration) (rs1 rs2: list Rule) (r1: Rule),
    Transformation_incl_rules rs1 rs2 -> In r1 rs1 ->
      (exists r2, In r2 rs2 /\
         Rule_getName r1 = Rule_getName r2
      /\ Rule_getGuardExpr r1 = Rule_getGuardExpr r2
      /\ Rule_getIteratorExpr r1 = Rule_getIteratorExpr r2
      /\ Rule_incl_patternElements (Rule_getOutputPatternElements r1) (Rule_getOutputPatternElements r2) ).
Proof.
intros.
revert H.
revert rs2.
revert H0.
induction rs1.
- contradiction.
- intros.
  simpl in H0.
  destruct H0.
  --  unfold Transformation_incl_rules in H.
      destruct rs2.
      + contradiction.
      + exists r.
      split; crush.
  --  induction rs2.
      + unfold Transformation_incl_rules in H.
        contradiction.
      + clear IHrs2.
        assert (Transformation_incl_rules rs1 rs2).
        {
        unfold Transformation_incl_rules.
        unfold Transformation_incl_rules in H.
        crush.
        }
        specialize (IHrs1 H0 rs2 H1).
        destruct IHrs1.
        destruct H2.
        exists x.
        split; auto.
        simpl.
        right.
        auto.
Qed.

Lemma Rule_incl_patternElements_eq:
  forall  (tc: TransformationConfiguration)  x x0 sm opes1 opes2,
   Rule_incl_patternElements opes1 opes2 ->
    flat_map
  (fun o : OutputPatternElement =>
   optionToList
     (e <- evalOutputPatternElementExpr sm x x0 o;
      return buildTraceLink (x, x0, OutputPatternElement_getName o) e)) opes1 =
  flat_map
  (fun o : OutputPatternElement =>
   optionToList
     (e <- evalOutputPatternElementExpr sm x x0 o;
      return buildTraceLink (x, x0, OutputPatternElement_getName o) e)) opes2.
Proof.
intros.
revert H.
revert opes2.
induction opes1.
- intros.
  unfold Rule_incl_patternElements in H.
  destruct opes2.
  -- auto.
  -- contradiction.
- induction opes2.
  -- intros.
     unfold Rule_incl_patternElements in H.
     contradiction.
  -- clear IHopes2.
     intros.

     assert (Rule_incl_patternElements opes1 opes2). {
       unfold Rule_incl_patternElements in H.
       unfold Rule_incl_patternElements.
       crush.
     }
     specialize (IHopes1 opes2 H0).
     simpl.

     assert (optionToList
       (e <- evalOutputPatternElementExpr sm x x0 a;
       return buildTraceLink (x, x0, OutputPatternElement_getName a) e) =
        optionToList
       (e <- evalOutputPatternElementExpr sm x x0 a0;
       return buildTraceLink (x, x0, OutputPatternElement_getName a0) e)).
      {
      f_equal.
      unfold Rule_incl_patternElements in H.
      destruct H.
      destruct H1.
      clear H2.
      unfold evalOutputPatternElementExpr.
      rewrite H.
      rewrite H1.
      auto.
      }

     crush.
Qed.

Lemma matchPattern_eq:
  forall (tc: TransformationConfiguration)  t1 t2 sm x,
  Transformation_incl_links t1 t2 ->
    flat_map (fun r : Rule => traceRuleOnPattern r sm x)
      (matchPattern t1 sm x) =
    flat_map (fun r : Rule => traceRuleOnPattern r sm x)
      (matchPattern t2 sm x).
Proof.
intros.
revert H.
destruct t1 as [a1 rs1].
revert t2.
induction rs1.
- (* base case: rs1 = nil *)
  intros.
  unfold Transformation_incl_links in H.
  simpl in H.
  destruct H.
  destruct (Transformation_getRules t2) eqn: t2_res.
  -- (* case 1: rs2 = nil *)
     unfold trace.
     unfold tracePattern.
     destruct t2.
     simpl in t2_res.
     rewrite t2_res.
     simpl.
     auto.
  -- (* case 2: rs2 != nil, a contradiction w.r.t. Transformation_incl_links *)
     contradiction.
- intro.
  destruct t2 as [a2 rs2].
  induction rs2.
  -- (* base case: rs2 = nil, a contradiction w.r.t. Transformation_incl_links *)
     intro.
     unfold Transformation_incl_links in H.
     simpl in H.
     destruct H.
     contradiction.
  -- specialize (IHrs1 (buildTransformation a2 rs2)).
     intros.
     assert (Transformation_incl_links (buildTransformation a1 rs1)
              (buildTransformation a2 rs2) ).  (* derived from H *)
     {
      unfold Transformation_incl_links in H.
      unfold Transformation_incl_links.
      crush.
     }

     specialize (IHrs1 H0).
      clear IHrs2.

      unfold Transformation_incl_links in H.
      simpl in H.
      destruct H.
      destruct H1.
      destruct H2.
      destruct H3.
      destruct H4.

      unfold matchPattern.
      simpl.

      destruct (matchRuleOnPattern a sm x) eqn: ca1.
      + destruct (matchRuleOnPattern a0 sm x) eqn: ca2.
        ++ simpl.
      assert (traceRuleOnPattern a sm x = traceRuleOnPattern a0 sm x).
      { unfold traceRuleOnPattern.
        unfold evalIteratorExpr.
        rewrite H3.
        unfold traceIterationOnPattern, traceElementOnPattern, instantiateElementOnPattern.

        f_equal.
        apply functional_extensionality.
        intros.

        remember  (Rule_getOutputPatternElements a) as opes1.
        remember  (Rule_getOutputPatternElements a0) as opes2.

        apply Rule_incl_patternElements_eq.
        auto.
       }
      rewrite H6.
      assert (flat_map (fun r : Rule => traceRuleOnPattern r sm x)
        (filter (fun r : Rule => matchRuleOnPattern r sm x) rs1) =
      flat_map (fun r : Rule => traceRuleOnPattern r sm x)
        (filter (fun r : Rule => matchRuleOnPattern r sm x) rs2)).
      {  unfold matchPattern in IHrs1. simpl in IHrs1. auto. }
      rewrite H7.
      auto.
        ++ unfold matchRuleOnPattern in ca2.
           unfold evalGuardExpr in ca2.
           rewrite <- H2 in ca2.
           unfold matchRuleOnPattern in ca1.
           unfold evalGuardExpr in ca1.
           crush. (* contradiction in ca1 and ca2 *)
      + destruct (matchRuleOnPattern a0 sm x) eqn: ca2.
        ++ unfold matchRuleOnPattern in ca2.
           unfold evalGuardExpr in ca2.
           rewrite <- H2 in ca2.
           unfold matchRuleOnPattern in ca1.
           unfold evalGuardExpr in ca1.
           crush. (* contradiction in ca1 and ca2 *)
        ++ unfold matchPattern in IHrs1.
           simpl in IHrs1.
           auto.
Qed.

Lemma trace_eq:
  forall (tc: TransformationConfiguration)  t1 t2 sm,
  Transformation_incl_links t1 t2 ->
    (trace t1 sm) = (trace t2 sm).
Proof.
intros.
revert H.
destruct t1 as [a1 rs1].
revert t2.
induction rs1.
- (* base case: rs1 = nil *)
  intros.
  unfold Transformation_incl_links in H.
  simpl in H.
  destruct H.
  destruct (Transformation_getRules t2) eqn: t2_res.
  -- (* case 1: rs2 = nil *)
     unfold trace.
     unfold tracePattern.
     destruct t2.
     simpl in t2_res.
     rewrite t2_res.
     simpl.
     unfold allTuples.
     unfold maxArity.
     simpl.
     simpl in H.
     rewrite H.
     auto.
  -- (* case 2: rs2 != nil, a contradiction w.r.t. Transformation_incl_links *)
     contradiction.
- (* inductive case: rs1 *)
  intro.
  destruct t2 as [a2 rs2].
  induction rs2.
  -- (* base case: rs2 = nil, a contradiction w.r.t. Transformation_incl_links *)
     intro.
     unfold Transformation_incl_links in H.
     simpl in H.
     destruct H.
     contradiction.
  -- (* inductive case: rs2 = nil *)
     specialize (IHrs1 (buildTransformation a2 rs2)).
     intros.

     assert (Transformation_incl_links (buildTransformation a1 rs1)
              (buildTransformation a2 rs2) ).  (* derived from H *)
     {
      unfold Transformation_incl_links in H.
      unfold Transformation_incl_links.
      crush.
     }

     specialize (IHrs1 H0).
     unfold trace, tracePattern.
     f_equal.
     + (* traceRuleOnPattern on matchPattern of t1 and t2 are the same *)
       apply functional_extensionality.
       intros.
       apply matchPattern_eq.
       auto.
     + (* allTuples of t1 and t2 are the same *)
       unfold allTuples.
       simpl.
       unfold Transformation_incl_links in H0.
       destruct H0.
       simpl in H0.
       rewrite H0.
       auto.
Qed.

Theorem additivity_links:
forall (tc: TransformationConfiguration) (t1 t2: Transformation) (sm: SourceModel),
  (Transformation_incl_links t1 t2 ->
    Model_incl (execute t1 sm) (execute t2 sm)).
Proof.
  simpl.
  unfold Model_incl.
  unfold incl.
  unfold Transformation_incl_links.
intros.
split.
- intro.
  simpl.
  destruct H.
  intros.
  apply in_flat_map in H1 as [sp].
  destruct H1.
  apply in_flat_map in H2 as [r1].
  destruct H2.
  apply in_flat_map in H3 as [iter1].
  destruct H3.
  apply in_flat_map in H4 as [ope].
  destruct H4.
  unfold instantiateElementOnPattern in H5.
  destruct (evalOutputPatternElementExpr sm sp iter1 ope) eqn: outExpr.
  + simpl in H5.
    destruct H5.
    ++ apply in_flat_map.
exists sp.
assert ((allTuples t1 sm) = (allTuples t2 sm)) as allTup. {
  unfold allTuples.
  unfold maxArity.
  rewrite H.
  auto.
}
split.
+++ rewrite <- allTup. exact H1.
+++ apply in_flat_map.
    specialize (Transformation_incl_rules_exists tc (Transformation_getRules t1) (Transformation_getRules t2) r1 H0).
    intros.
    assert (In r1 (Transformation_getRules t1)). { unfold matchPattern in H2. apply filter_In in H2. destruct H2. exact H2. }
    specialize (H6 H7).
    repeat destruct H6.
    destruct H8.
    destruct H8.
    rename x into r2.
    exists r2.
    split.
    ++++  unfold matchPattern in H2.
          apply filter_In in H2.
          unfold matchPattern.
          apply filter_In.
          split.
          * auto.
          * destruct H2.
            unfold matchRuleOnPattern, evalGuardExpr.
          unfold matchRuleOnPattern, evalGuardExpr in H8.
          destruct H9.
          rewrite <- H9.
          auto.
    ++++  apply in_flat_map.
          exists iter1.
          split.
          +++++ unfold evalIteratorExpr.
                unfold evalIteratorExpr in H3.
                destruct H9.
                destruct H9.
                rewrite <- H9.
                auto.
          +++++ unfold instantiateIterationOnPattern.
                unfold instantiateElementOnPattern.
                assert (exists ope2, In ope2 (Rule_getOutputPatternElements r2) /\ evalOutputPatternElementExpr sm sp iter1 ope2 = return a).
                {
                destruct H9.
                destruct H9.
                specialize Rule_incl_patternElements_exists.
                intros.
                specialize (H11 tc (Rule_getOutputPatternElements r1) (Rule_getOutputPatternElements r2)).
                specialize (H11 ope H10 H4).
                destruct H11.
                destruct H11.
                destruct H12.
                destruct H13.
                clear H14.
                exists x.
                split; auto.
                unfold evalOutputPatternElementExpr.
                unfold evalOutputPatternElementExpr in outExpr.
                rewrite <- H13.
                rewrite <- H5.
                auto.
                }
                destruct H8.
                apply in_flat_map.
                exists x.
                split.
                * destruct H8.
                  auto.
                * destruct H8.
                rewrite H10.
                simpl.
                left.
                auto.
    ++ contradiction.
  + contradiction.
- intro.
  simpl.
  destruct H.
  intros.
  apply in_flat_map in H1 as [sp].
  destruct H1.
  apply in_flat_map in H2 as [r1].
  destruct H2.
  apply in_flat_map in H3 as [iter1].
  destruct H3.
  apply in_flat_map in H4 as [ope].
  destruct H4.
  unfold applyElementOnPattern in H5.
  destruct (evalOutputPatternElementExpr sm sp iter1 ope) eqn: outExpr.
  + destruct (evalOutputPatternLinkExpr sm sp t iter1 (trace t1 sm) ope) eqn: linkExpr.
    ++ simpl in H5.
       apply in_flat_map.
       exists sp.
       assert ((allTuples t1 sm) = (allTuples t2 sm)) as allTup. {
        unfold allTuples.
        unfold maxArity.
        rewrite H.
        auto.
       }
       split.
       +++  rewrite <- allTup. exact H1.
       +++  apply in_flat_map.
            specialize (Transformation_incl_rules_exists tc (Transformation_getRules t1) (Transformation_getRules t2) r1 H0).
            intros.
            assert (In r1 (Transformation_getRules t1)). { unfold matchPattern in H2. apply filter_In in H2. destruct H2. exact H2. }
            specialize (H6 H7).
            repeat destruct H6.
            destruct H8.
            destruct H8.
            rename x into r2.
            exists r2.
            split.
            ++++  unfold matchPattern in H2.
                  apply filter_In in H2.
                  unfold matchPattern.
                  apply filter_In.
                  split.
                  * auto.
                  * destruct H2.
                    unfold matchRuleOnPattern, evalGuardExpr.
                  unfold matchRuleOnPattern, evalGuardExpr in H8.
                  destruct H9.
                  rewrite <- H9.
                  auto.
            ++++  apply in_flat_map.
                  exists iter1.
                  split.
                  +++++ unfold evalIteratorExpr.
                        unfold evalIteratorExpr in H3.
                        destruct H9.
                        destruct H9.
                        rewrite <- H9.
                        auto.
                  +++++ assert ((trace t1 sm) = (trace t2 sm)).
                        {
                          apply trace_eq.
                          unfold Transformation_incl_links; auto.
                        }
                        unfold applyIterationOnPattern.
                        unfold applyElementOnPattern.
                        assert (exists ope2, In ope2 (Rule_getOutputPatternElements r2) /\
                                  evalOutputPatternElementExpr sm sp iter1 ope2 = return t /\
                                  evalOutputPatternLinkExpr sm sp t iter1 (trace t1 sm) ope2 = return l).
                        {
                        destruct H9.
                        destruct H9.
                        destruct H10.
                        specialize Rule_incl_patternElements_exists.
                        intros.
                        specialize (H11 tc (Rule_getOutputPatternElements r1) (Rule_getOutputPatternElements r2)).
                        specialize (H11 ope H10 H4).
                        destruct H11.
                        destruct H11.
                        destruct H12.
                        destruct H13.
                        exists x.
                        split; auto.
                        split.
                        * unfold evalOutputPatternElementExpr.
                          unfold evalOutputPatternElementExpr in outExpr.
                          rewrite <- H13.
                          auto.
                        * unfold evalOutputPatternLinkExpr.
                        unfold evalOutputPatternLinkExpr in linkExpr.
                        destruct H14.
                        ** rewrite <- H14.
                           auto.
                        ** rewrite H14 in linkExpr.
                        unfold evalExpr in linkExpr.
                        inversion linkExpr.
                        }
                        destruct H10.
                        apply in_flat_map.
                        exists x.
                        split.
                        * destruct H10.
                          auto.
                        * destruct H10.
                          destruct H11.
                          rewrite H11.
                          rewrite <- H8.
                          rewrite H12.
                          simpl.
                          exact H5.
    ++ contradiction.
  + contradiction.
Qed.

(*********************************************************)
(** * Additivity in OutputPatternLink context            *)
(** * Inductive Definitions                              *)
(*********************************************************)

Inductive Rule_incl_patternElements' {tc: TransformationConfiguration} : list OutputPatternElement -> list OutputPatternElement -> Prop :=
  | incl_e_nil : Rule_incl_patternElements' nil nil
  | incl_e_diff : forall x y xs ys, Rule_incl_patternElements' xs ys
    -> OutputPatternElement_getName x = OutputPatternElement_getName y
    -> OutputPatternElement_getElementExpr x = OutputPatternElement_getElementExpr y
    -> (OutputPatternElement_getLinkExpr x = OutputPatternElement_getLinkExpr y \/
        OutputPatternElement_getLinkExpr x = (fun _ _ _ _ _ => None))
    -> Rule_incl_patternElements' (x::xs) (y::ys).

Inductive Transformation_incl_rules' {tc: TransformationConfiguration} : list Rule -> list Rule -> Prop :=
  | incl_rules_nil : Transformation_incl_rules' nil nil
  | incl_rules_diff : forall x y xs ys, Transformation_incl_rules' xs ys
    -> Rule_getName x = Rule_getName y
    -> Rule_getGuardExpr x = Rule_getGuardExpr y
    -> Rule_getIteratorExpr x = Rule_getIteratorExpr y
    -> Rule_incl_patternElements' (Rule_getOutputPatternElements x) (Rule_getOutputPatternElements y)
    -> Transformation_incl_rules' (x::xs) (y::ys).

Definition Transformation_incl_links' {tc: TransformationConfiguration} (t1 t2: Transformation) : Prop :=
  (Transformation_getArity t1 = Transformation_getArity t2) /\
  (Transformation_incl_rules' (Transformation_getRules t1) (Transformation_getRules t2)).

Lemma tr_incl_equiv:
  forall (tc: TransformationConfiguration) t1 t2,
    Transformation_incl_links' t1 t2 -> Transformation_incl_links t1 t2.
Proof.
intros.
destruct  H.
unfold Transformation_incl_links.
split.
* auto.
*
  induction H0.
  ** unfold Transformation_incl_rules. auto.
  ** simpl. repeat split; auto.
     induction H4.
     - unfold Rule_incl_patternElements. auto.
     - simpl. repeat split; auto.
Qed.

Theorem additivity_links' :
forall (tc: TransformationConfiguration) (t1 t2: Transformation) (sm: SourceModel),
  (Transformation_incl_links' t1 t2 ->
    Model_incl (execute t1 sm) (execute t2 sm)).
Proof.
intros.
specialize (tr_incl_equiv tc t1 t2 H).
specialize (additivity_links tc t1 t2).
auto.
Qed.


From Ordinal Require Import sflib Basics.
From Ordinal Require Export Ordinal Arithmetic Hessenberg ClassicalOrdinal.

Require Import Coq.Classes.RelationClasses Coq.Classes.Morphisms.

Set Implicit Arguments.
Set Primitive Projections.

(* TODO: find a constructive proof!! *)
Module ClassicJacobsthal.
  Lemma mult_dist o0 o1 o2: Ord.eq (Jacobsthal.mult o0 (Hessenberg.add o1 o2)) (Hessenberg.add (Jacobsthal.mult o0 o1) (Jacobsthal.mult o0 o2)).
  Proof.
    destruct (ClassicOrd.total o0 Ord.O) as [LE|LT].
    { assert (ZERO: Ord.eq o0 Ord.O).
      { split; auto. apply Ord.O_bot. }
      rewrite ZERO. rewrite ! Jacobsthal.mult_O_l. rewrite Hessenberg.add_O_l. reflexivity.
    }
    revert o1 o2.
    eapply (double_well_founded_induction Ord.lt_well_founded Ord.lt_well_founded).
    i. hexploit (ClassicOrd.limit_or_S a1). i. des.
    { hexploit Ord.is_S_unique.
      { eapply H. }
      { eapply Ord.S_is_S. }
      i. rewrite H0. rewrite Hessenberg.add_S_l.
      rewrite Jacobsthal.mult_S. rewrite Jacobsthal.mult_S.
      rewrite IHL.
      { rewrite Hessenberg.add_assoc. reflexivity. }
      { eapply H. }
    }
    hexploit (ClassicOrd.limit_or_S b1). i. des.
    { hexploit Ord.is_S_unique.
      { eapply H1. }
      { eapply Ord.S_is_S. }
      i. rewrite H2. rewrite Hessenberg.add_S_r.
      rewrite Jacobsthal.mult_S. rewrite Jacobsthal.mult_S.
      rewrite IHR.
      { rewrite Hessenberg.add_comm.
        rewrite Hessenberg.add_assoc.
        eapply Hessenberg.eq_add_r.
        eapply Hessenberg.add_comm.
      }
      { eapply H1. }
    }
    hexploit Ord.is_join_unique.
    { eapply H. }
    { eapply Ord.join_is_join. }
    i. rewrite H3.
    hexploit Ord.is_join_unique.
    { eapply H1. }
    { eapply Ord.join_is_join. }
    i. rewrite H4.
    rewrite Jacobsthal.mult_join. rewrite Jacobsthal.mult_join.
    rewrite <- Ord.build_join; auto.
    rewrite <- Ord.build_join; auto.
    symmetry. rewrite <- Ord.build_join.
    2:{ ii. specialize (H0 a0). des. exists a2. eapply Jacobsthal.lt_mult_r; auto. }
    rewrite <- Ord.build_join.
    2:{ ii. specialize (H2 a0). des. exists a2. eapply Jacobsthal.lt_mult_r; auto. }
    rewrite Hessenberg.add_red.
    rewrite Hessenberg.add_red.
    rewrite Jacobsthal.mult_union. eapply Ord.eq_union.
    { rewrite Jacobsthal.mult_build. rewrite Ord.build_join.
      2:{ ii. specialize (H2 a0). des. exists a2. eapply Hessenberg.lt_add_r. eapply Jacobsthal.lt_mult_r; auto. }
      split.
      { eapply Ord.le_join. i. hexploit (H2 a0); auto. i. des.
        exists a2. rewrite (Ord.build_join H0); auto.
        rewrite <- H3. rewrite IHR.
        2:{ rewrite H4. rewrite <- Ord.build_join; auto. eapply Ord.build_upperbound. }
        eapply Ord.S_supremum in H5. rewrite <- H5.
        rewrite Jacobsthal.mult_S. rewrite <- Hessenberg.add_assoc.
        rewrite <- Hessenberg.add_assoc.
        eapply Hessenberg.le_add_l.
        eapply Ord.build_supremum. i.
        eapply Ord.lt_le_lt.
        { apply Jacobsthal.lt_mult_r; auto. eapply Ord.build_upperbound. }
        { rewrite Ord.build_join; auto.
          rewrite <- H3. rewrite Hessenberg.add_comm.
          rewrite <- Hessenberg.add_assoc. eapply Hessenberg.add_base_r.
        }
      }
      { eapply Ord.le_join. i. hexploit (H2 a0); auto. i. des.
        exists a2. rewrite Ord.build_join; auto.
        rewrite <- H3. rewrite IHR.
        2:{ rewrite H4. rewrite <- Ord.build_join; auto. eapply Ord.build_upperbound. }
        eapply Ord.S_supremum in H5. rewrite <- H5.
        rewrite Jacobsthal.mult_S. rewrite <- Hessenberg.add_assoc.
        rewrite <- Hessenberg.add_assoc.
        eapply Hessenberg.le_add_l.
        rewrite Hessenberg.add_comm.
        eapply Hessenberg.le_add_l.
        rewrite H3. rewrite Jacobsthal.mult_join.
        rewrite Ord.build_join; auto.
        2:{ ii. specialize (H0 a3). des. exists a4. apply Jacobsthal.lt_mult_r; auto. }
        reflexivity.
      }
    }
    { rewrite Jacobsthal.mult_build. rewrite Ord.build_join.
      2:{ ii. specialize (H0 a0). des. exists a2. eapply Hessenberg.lt_add_l. eapply Jacobsthal.lt_mult_r; auto. }
      split.
      { eapply Ord.le_join. i. hexploit (H0 a0); auto. i. des.
        exists a2. rewrite (Ord.build_join H2); auto.
        rewrite <- H4. rewrite IHL.
        2:{ rewrite H3. rewrite <- Ord.build_join; auto. eapply Ord.build_upperbound. }
        eapply Ord.S_supremum in H5. rewrite <- H5.
        rewrite Jacobsthal.mult_S. transitivity (Jacobsthal.mult o0 (os a0) ⊕ o0 ⊕ Jacobsthal.mult o0 b1)%ord.
        { eapply Hessenberg.le_add_r.
          eapply Ord.build_supremum. i.
          eapply Ord.lt_le_lt.
          { apply Jacobsthal.lt_mult_r; auto. eapply Ord.build_upperbound. }
          { rewrite Ord.build_join; auto.
            rewrite <- H4. eapply Hessenberg.add_base_r.
          }
        }
        { etransitivity; [|eapply Hessenberg.add_base_r].
          rewrite <- Hessenberg.add_assoc.
          eapply Hessenberg.le_add_l. rewrite Hessenberg.add_comm. reflexivity.
        }
      }
      { eapply Ord.le_join. i. hexploit (H0 a0); auto. i. des.
        exists a2. rewrite Ord.build_join; auto.
        rewrite <- H4. rewrite IHL.
        2:{ rewrite H3. rewrite <- Ord.build_join; auto. eapply Ord.build_upperbound. }
        eapply Ord.S_supremum in H5. rewrite <- H5.
        rewrite Jacobsthal.mult_S. rewrite Hessenberg.add_assoc.
        eapply Hessenberg.le_add_r.
        eapply Hessenberg.le_add_r.
        rewrite H4. rewrite Jacobsthal.mult_join.
        rewrite Ord.build_join; auto.
        2:{ ii. specialize (H2 a3). des. exists a4. apply Jacobsthal.lt_mult_r; auto. }
        reflexivity.
      }
    }
  Qed.

  Lemma mult_assoc o0 o1 o2: Ord.eq (Jacobsthal.mult (Jacobsthal.mult o0 o1) o2) (Jacobsthal.mult o0 (Jacobsthal.mult o1 o2)).
  Proof.
    revert o0 o1. induction o2. i. etransitivity.
    { eapply Jacobsthal.mult_build. } etransitivity.
    2: {
      eapply Jacobsthal.eq_mult_r; auto.
      { symmetry. eapply Jacobsthal.mult_build. }
    }
    etransitivity.
    2: { symmetry. eapply Jacobsthal.mult_join. }
    split.
    { eapply Ord.le_join. i. exists a0.
      etransitivity.
      { eapply Hessenberg.le_add_r. eapply H. }
      { eapply mult_dist. }
    }
    { eapply Ord.le_join. i. exists a0.
      etransitivity.
      { eapply mult_dist. }
      { eapply Hessenberg.le_add_r. eapply H. }
    }
  Qed.
End ClassicJacobsthal.


Require Import Setoid Morphisms RelationClasses Program.Basics.
Require Import ILogic IBILogic BILogic BILInsts ILQuantTac ILInsts Pure ILEmbed.
Require Import Rel SepAlg.

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

Section PureBIInsts.
  Context {A} `{sa : SepAlg A}.
  Context {B} `{IL: ILogic B}.
  Context {HPre : PreOrder (@rel A _)}.

  Existing Instance SABIOps.
  Existing Instance SABILogic.
  Existing Instance pureop_bi_sepalg.
  Existing Instance pure_bi_sepalg.
  Existing Instance ILPre_Ops.
  Existing Instance ILPre_ILogic.

  Transparent ILPre_Ops.
  Transparent SABIOps.

  Instance pure_ltrue : pure ltrue.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance pure_lfalse : pure lfalse.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance pure_land p q (Hp : pure p) (Hq : pure q) : pure (p //\\ q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_lor p q (Hp : pure p) (Hq : pure q) : pure (p \\// q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_limpl p q (Hp : pure p) (Hq : pure q) : pure (p -->> q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro H.
    apply lforallL with h. apply lforallL; [reflexivity|].
    specialize (Hp h'' h); specialize (Hq h h'').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_lsc p q (Hp : pure p) (Hq : pure q) : pure (p ** q).
  Proof.
    intros h h'; simpl.
    apply lexistsL; intro h''; apply lexistsL; intro h'''; apply lexistsL; intro H.
    destruct (sa_unit_ex h') as [u [Ha H1]].
    apply lexistsR with h'; apply lexistsR with u. apply lexistsR with H1.
    specialize (Hp h'' h'); specialize (Hq h''' u).
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_lsi p q (Hp : pure p) (Hq : pure q) : pure (p -* q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro h'''; apply lforallR; intro H.
    destruct (sa_unit_ex h) as [u [Ha H1]].
    apply lforallL with u; apply lforallL with h; apply lforallL with H1.
    specialize (Hp h'' u); specialize (Hq h h''').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Context {C : Type} {ILC : ILogicOps C} {HCOp: EmbedOp C B} {HC: Embed C B}.

  Local Existing Instance EmbedILPreDropOp.
  Local Existing Instance EmbedILPreOp.
  Transparent EmbedILPreDropOp.
  Transparent EmbedILPreOp.

  Instance pure_bi_embed_drop (p : C) : pure (@embed C (ILPreFrm rel B) _ p).
  Proof.
    intros h h'; simpl; reflexivity.
  Qed.

  Instance pure_bi_embed (p : ILPreFrm rel C) (H : pure p) :
    pure (@embed (ILPreFrm rel C) (ILPreFrm rel B) _ p).
  Proof.
    intros h h'; simpl.
    specialize (H h h'). rewrite H. reflexivity.
  Qed.

End PureBIInsts.

Section PureIBIInsts.
  Context {A} `{sa : SepAlg A}.
  Context {B} `{IL: ILogic B}.
  Context {HPre : PreOrder (@rel A _)}.

  Existing Instance SAIBIOps.
  Existing Instance SAIBILogic.
  Existing Instance pureop_pure_ibi_sepalg.
  Existing Instance pure_ibi_sepalg.
  Existing Instance ILPre_Ops.
  Existing Instance ILPre_ILogic.

  Transparent ILPre_Ops.
  Transparent SAIBIOps.

  Instance ibi_pure_ltrue : pure ltrue.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance ibi_pure_lfalse : pure lfalse.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance ibi_pure_emp : pure empSP.
  Proof.
    intros h h'; simpl; apply ltrueR.
  Qed.

  Instance ibi_pure_land p q (Hp : pure p) (Hq : pure q) : pure (p //\\ q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_lor p q (Hp : pure p) (Hq : pure q) : pure (p \\// q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_limpl p q (Hp : pure p) (Hq : pure q) : pure (p -->> q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro H.
    apply lforallL with h. apply lforallL; [reflexivity|].
    specialize (Hp h'' h); specialize (Hq h h'').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_lsc p q (Hp : pure p) (Hq : pure q) : pure (p ** q).
  Proof.
    intros h h'; simpl.
    apply lexistsL; intro h''; apply lexistsL; intro h'''; apply lexistsL; intro H.
    destruct (sa_unit_ex h') as [u [Ha H1]].
    apply lexistsR with h'; apply lexistsR with u. apply lexistsR with H1.
    specialize (Hp h'' h'); specialize (Hq h''' u).
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_lsi p q (Hp : pure p) (Hq : pure q) : pure (p -* q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro h'''; apply lforallR; intro H.
    destruct (sa_unit_ex h) as [u [Ha H1]].
    apply lforallL with u; apply lforallL with h; apply lforallL with H1.
    specialize (Hp h'' u); specialize (Hq h h''').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Context {C : Type} {ILC : ILogicOps C} {HCOp: EmbedOp C B} {HC: Embed C B}.

  Local Existing Instance EmbedILPreDropOp.
  Local Existing Instance EmbedILPreOp.

  Transparent EmbedILPreDropOp.
  Transparent EmbedILPreOp.

  Instance pure_ibi_embed_drop (p : C) : pure (@embed C (ILPreFrm subheap B) _ p).
  Proof.
    intros h h'; simpl; reflexivity.
  Qed.

  Instance pure_ibi_embed (p : ILPreFrm subheap C) (H : pure p) :
    pure (@embed (ILPreFrm subheap C) (ILPreFrm subheap B) _ p).
  Proof.
    intros h h'; simpl.
    specialize (H h h'). rewrite H. reflexivity.
  Qed.

End PureIBIInsts.

Section PureEmbedFun.
  Context (T: Type).
  Context {A : Type} `{BIL: BILogic A}.
  Context {HIL : ILogic A}.
  Context {B : Type} {ILX : ILogicOps B} {HBOp: EmbedOp B A} {HB : Embed B A}.
  Context {POA : @PureOp A} {PA : Pure POA}.

  Existing Instance PureBILFunOp.
  Existing Instance PureBILFun.
  Existing Instance ILFun_Ops.
  Existing Instance ILFun_ILogic.
  Existing Instance BILFun_Ops.
  Existing Instance BILFunLogic.
  Existing Instance EmbedILFunDropOp.
  Existing Instance EmbedILFunDrop.
  Existing Instance EmbedILFunOp.
  Existing Instance EmbedILFun.

  Transparent EmbedILFunDropOp.
  Transparent EmbedILFunOp.

  Instance pure_embed_fun_drop (p : B) (H : pure (@embed B A _ p)) :
    pure (@embed B (T -> A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

  Instance pure_embed_fun (p : T -> B) (H : forall t, pure (@embed B A _ (p t))) :
    pure (@embed (T -> B) (T -> A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

End PureEmbedFun.

Section PureEmbedPre.
  Context T (ord: relation T) {HPre: PreOrder ord}.
  Context {A : Type} `{HBI: BILogic A}.
  Context {HIL : ILogic A}.
  Context {B : Type} {ILX : ILogicOps B} {HBOp: EmbedOp B A} {HB : Embed B A}.
  Context {POA : @PureOp A} {PA : Pure POA}.

  Existing Instance PureBILPreOp.
  Existing Instance PureBILPre.
  Existing Instance ILPre_Ops.
  Existing Instance ILPre_ILogic.
  Existing Instance BILPre_Ops.
  Existing Instance BILPreLogic.
  Existing Instance EmbedILPreDropOp.
  Existing Instance EmbedILPreDrop.
  Existing Instance EmbedILPreOp.
  Existing Instance EmbedILPre.

  Instance pure_embed_pre_drop (p : B) (H : pure (@embed B A _ p)) :
    pure (@embed B (ILPreFrm ord A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

  Instance pure_embed_pre (p : ILPreFrm ord B) (H : forall t, pure (@embed B A _ (ILPreFrm_pred p t))) :
    pure (@embed (ILPreFrm ord B) (ILPreFrm ord A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

End PureEmbedPre.


Require Export FinTypes.

Lemma dec_DM_and_iff (X Y : Prop) : dec X -> ~ (X /\ Y) <-> ~ X \/ ~ Y.
  split;[now eapply dec_DM_and|firstorder].
Qed.
Lemma dec_DM_and_iff' (X Y : Prop) : dec Y -> ~ (X /\ Y) <-> ~ X \/ ~ Y.
  split;[now eapply dec_DM_and'|firstorder].
Qed.
Lemma dec_DN_iff (X : Prop) : dec X -> ~ ~ X <-> X.
  split;[now eapply dec_DN|firstorder].
Qed.
Lemma dec_DM_impl_iff (X Y : Prop) : dec X -> dec Y -> ~ (X -> Y) <-> X /\ ~ Y.
  split;[now eapply dec_DM_impl|firstorder].
Qed.

Ltac simpl_dec' H :=
  (first [(setoid_rewrite (DM_notAll _) in H;eauto)|
          (setoid_rewrite (dec_DM_and_iff _ _) in H;eauto)|
          (setoid_rewrite (dec_DM_and_iff' _ _) in H;eauto)|
          setoid_rewrite DM_not_exists in H|
          setoid_rewrite DM_or in H|
          (setoid_rewrite (dec_DN_iff _) in H;eauto)|
          (setoid_rewrite (dec_DM_impl_iff _ _) in H;eauto)]).
Ltac simpl_dec :=
  (try (setoid_rewrite DM_notAll;[|eauto]);
   try (setoid_rewrite (dec_DM_and_iff _ _);[|eauto]);
   try (setoid_rewrite (dec_DM_and_iff' _ _);[|eauto]);
   try setoid_rewrite DM_not_exists;
   try setoid_rewrite DM_or;
   try (setoid_rewrite (dec_DN_iff _);[|eauto]);
   try (setoid_rewrite (dec_DM_impl_iff _ _);eauto)).

(*Ltac collapse H :=
  lazymatch type of H with
  | ?a /\ ?b => let H1 := fresh "H" in
              let H2 := fresh "H" in
              destruct H as [H1 H2];
              collapse H1;
              collapse H2
  | ?a \/ ?b => destruct H as [H|H]; collapse H
  | ~ ?x => simpl_dec' H; collapse H
  | _ => idtac
  end.*)


(* colimits are computed pointwise
 *)

(**
It is the product of modules
Then it induces a morphism
*)
(* TODO : Faire les mêmes choses pour les limites de Modules *)
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

Require Import Modules.Signatures.Signature.
Require Import Modules.Prelims.LModulesColims.
Require Import Modules.Prelims.CoproductsComplements.

Local Open Scope cat.

(*
Lemma compfNat
   {C : precategory} {g : graph} {d1 d2 d3 : diagram g C}

   {f : ∏ u : vertex g, C ⟦ dob d1 u, dob d2 u ⟧}
  (fNat : ∏ (u v : vertex g) (e : edge u v), dmor d1 e · f v = f u · dmor d2 e)
   {f2 : ∏ u : vertex g, C ⟦ dob d2 u, dob d3 u ⟧}
   (fNat2 : ∏ (u v : vertex g) (e : edge u v), dmor d2 e · f2 v = f2 u · dmor d3 e)
   (f3 := fun u => f u · f2 u)
   :
   ∏ (u v : vertex g) (e : edge u v), dmor d1 e · f3 v = f3 u · dmor d3 e .
  intros u v e.
  etrans;[apply assoc|].
  etrans;[apply cancel_postcomposition; apply fNat|].
  etrans;[|apply assoc].
  etrans;[|apply cancel_precomposition; apply fNat2].
  apply pathsinv0.
  apply assoc.
Qed.
*)
(*
Lemma compColimOfArrows
   (C : precategory) (g : graph) (d1 d2 d3 : diagram g C) (CC1 : ColimCocone d1)
   (CC2 : ColimCocone d2)(CC3 : ColimCocone d3)
   (f : ∏ u : vertex g, C ⟦ dob d1 u, dob d2 u ⟧)
  (fNat : ∏ (u v : vertex g) (e : edge u v), dmor d1 e · f v = f u · dmor d2 e)
   (f2 : ∏ u : vertex g, C ⟦ dob d2 u, dob d3 u ⟧)
  (fNat2 : ∏ (u v : vertex g) (e : edge u v), dmor d2 e · f2 v = f2 u · dmor d3 e)
  (x : C) (cc : cocone d2 x) :
  colimOfArrows CC1 CC2 f fNat · colimOfArrows CC2 CC3 f2 fNat2 =
  colimOfArrows CC1 CC3 (fun z => f z · f2 z) (compfNat  fNat fNat2).
  etrans;[apply precompWithColimOfArrows|].
  cbn.
  unfold colimOfArrows.
  apply maponpaths.
  Abort.
*)
(*

  use map_on_two_paths.
  maponpaths
  apply maponpaths2.

  reflexivity.
.fNat · colimOfArrows CC2 CC3 f2 fNat2 .
  colimOfArrows CC1 CC3 (fun
  colimArrow CC1 x
    (make_cocone (λ u : vertex g, f u · coconeIn cc u)
       (preCompWithColimOfArrows_subproof CC1 CC2 f fNat x cc)).
*)
(* forget ful functor from Modules to functors *)

(* TODO déplacer ça dans Signature.v *)

Section ColimsSig.
  Context
          {C : category}
          {g : graph} (colims_g : Colims_of_shape g C)
          (lims_g : Lims_of_shape g C).
  Let hsC := (homset_property C).
          (* (hsB : has_homsets B) *)
  Let coMod R := (LModule_Colims_of_shape C (B := C) R _ colims_g).
  Let limMod R := (LModule_Lims_of_shape C (B := C) R _ lims_g).

  (* Local Notation limMod := (LModule_Lims_of_shape _ B _ hsC colims_g). *)
  (* Local Notation coFunc := (ColimsFunctorCategory_of_shape _ B _ hsC colims_g). *)
  (* Local Notation limFunc := (LimsFunctorCategory_of_shape _ B _ hsC lims_g). *)
  (* Local Notation bpFunct := *)
  (*   (BinProducts_functor_precat B C bpC hsC (M : functor _ _) (N : functor _ _)). *)

  (* Definition LModule_colim_functor : functor _ _ := *)
  (*   BinProductObject  _ bpFunct. *)
  Local Notation MOD R := (precategory_LModule R C).
  Local Notation HAR := (signature_precategory (C:=C)).
  Variable (d : diagram g HAR).
  (* TODO generalize this kind of construction : composition of a diagram and a functor
(here the forget ful functor MOD --> [B , C])
   *)
  Let FORGET R := (forget_Sig (C:=C) R ).
  Let d' R := (  mapdiagram (FORGET R) d : diagram g (MOD R) ).
  (* The natural candidate *)
  Let  F R := (colim (coMod _ (d' R)) : LModule _ _).
  Let  F' R := (lim (limMod _ (d' R)) : LModule _ _).
  (* Local Notation BP := (binproduct_functor bpC). *)

  (* Is there a lemma that state the existence of a natural transformation
  (A x B) o R --> A o R x B o R  ? *)
  (* TODO define it without nat_trans *)
  Definition Sig_colim_on_mor (R S : Monad C) (f : Monad_Mor R S) :
    LModule_Mor _ (F R) (pb_LModule f (F S)).
  Proof.
  eapply (compose (C:= MOD _)); [| apply pb_LModule_colim_iso].
  use  colimOfArrows.
  - intro u.
    exact ((#(dob d u : signature _))%ar f).
  - abstract (intros u v e;
    apply LModule_Mor_equiv;[apply homset_property|];
    apply pathsinv0;
    apply signature_Mor_ax).
  Defined.

  Definition Sig_lim_on_mor (R S : Monad C) (f : Monad_Mor R S) :
    LModule_Mor _ (F' R) (pb_LModule f (F' S)).
  Proof.
  eapply (compose (C:= MOD _)); [| apply pb_LModule_lim_iso].
  use  limOfArrows.
  - intro u.
    exact ((#(dob d u : signature _))%ar f).
  - abstract(intros u v e;
    apply LModule_Mor_equiv;[apply homset_property|];
    apply signature_Mor_ax).
  Defined.

  Definition Sig_colim_signature_data : signature_data := _ ,, Sig_colim_on_mor.
  Definition Sig_lim_signature_data : signature_data := _ ,, Sig_lim_on_mor.

  Lemma Sig_colim_is_signature : is_signature Sig_colim_signature_data.
  Proof.
    split.
    - intros R c.
      apply pathsinv0.
      apply colim_endo_is_identity.
      intro u.
      cbn.
      rewrite id_right.
      set (cc := colims_g _).
      etrans;[apply (colimArrowCommutes  cc)|].
      cbn.
      etrans;[|apply id_left].
      apply cancel_postcomposition.
      apply signature_id.
    - intros U V W m n.
      apply LModule_Mor_equiv;[apply homset_property|].
      apply nat_trans_eq;[apply homset_property|].
      intro c.
      cbn.
      repeat rewrite id_right.
      apply pathsinv0.
      apply colimArrowUnique.
      intro u.
      cbn.
      etrans.
      {
        etrans;[apply assoc|].
        apply cancel_postcomposition.
        set (cc := colims_g _).
        apply (colimArrowCommutes cc).
      }
      cbn.
      etrans.
      {
        cbn.
        rewrite <- assoc.
        apply cancel_precomposition.
        set (cc := colims_g _).
        apply (colimArrowCommutes cc).
        }
      cbn.
      rewrite assoc.
      apply cancel_postcomposition.
      apply pathsinv0.
      etrans.
      {
      assert (h := signature_comp (dob d u) m n).
      eapply LModule_Mor_equiv in h; try apply homset_property.
      eapply nat_trans_eq_pointwise in h.
      apply h.
      }
      cbn.
      now rewrite id_right.
  Qed.
  Lemma Sig_lim_is_signature : is_signature Sig_lim_signature_data.
  Proof.
    split.
    - intros R c.
      apply pathsinv0.
      apply lim_endo_is_identity.
      intro u.
      cbn.
      rewrite id_right.
      set (cc := lims_g _).
      etrans;[apply (limArrowCommutes  cc)|].
      cbn.
      etrans;[|apply id_right].
      apply cancel_precomposition.
      apply signature_id.
    - intros U V W m n.
      apply LModule_Mor_equiv;[apply homset_property|].
      apply nat_trans_eq;[apply homset_property|].
      intro c.
      cbn.
      repeat rewrite id_right.
      apply pathsinv0.
      apply limArrowUnique.
      intro u.
      cbn.
      etrans.
      {
        rewrite <- assoc.
        (* etrans;[apply assoc|]. *)
        apply cancel_precomposition.
        set (cc := lims_g _).
        apply (limArrowCommutes cc).
      }
      cbn.
      etrans.
      {
        cbn.
        rewrite assoc.
        apply cancel_postcomposition.
        set (cc := lims_g _).
        apply (limArrowCommutes cc).
        }
      cbn.
      rewrite <- assoc.
      apply cancel_precomposition.
      apply pathsinv0.
      etrans.
      {
      assert (h := signature_comp (dob d u) m n).
      eapply LModule_Mor_equiv in h; try apply homset_property.
      eapply nat_trans_eq_pointwise in h.
      apply h.
      }
      cbn.
      now rewrite id_right.
  Qed.

  Definition Sig_colim : signature _ :=
    _ ,, Sig_colim_is_signature.

  Definition Sig_lim : signature _ :=
    _ ,, Sig_lim_is_signature.

  Lemma Sig_coconeIn_laws v :
    is_signature_Mor
                      (dob d v : signature  _)  Sig_colim
      (fun R => (coconeIn (colimCocone (coMod R (d' R))) v   )).
  Proof.
    intros X Y f.
    (* not necessary but more convenienet *)
    apply nat_trans_eq;[apply homset_property|].
    intro x.
    cbn.
    rewrite id_right.
    set (cc1 := colims_g _).
    set (cc2 := colims_g _).
    apply pathsinv0.
    cbn.
    apply (colimArrowCommutes cc2).
  Qed.
  Lemma Sig_coneOut_laws v :
    is_signature_Mor
                  Sig_lim    (dob d v : signature  _)
      (fun R => (coneOut (limCone (limMod R (d' R))) v   )).
  Proof.
    intros X Y f.
    (* not necessary but more convenienet *)
    apply nat_trans_eq;[apply homset_property|].
    intro x.
    cbn.
    rewrite id_right.
    set (cc1 := lims_g _).
    set (cc2 := lims_g _).
    cbn.
    apply (limArrowCommutes cc1).
  Qed.

  Definition Sig_coconeIn v : signature_precategory ⟦ dob d v, Sig_colim ⟧ :=
    _ ,, Sig_coconeIn_laws v.

  Definition Sig_coneOut v : signature_precategory ⟦ Sig_lim, dob d v ⟧ :=
    _ ,, Sig_coneOut_laws v.

  Lemma Sig_coconeIn_commutes (u v : vertex g) (e : edge u v) :
    dmor d e · Sig_coconeIn v = Sig_coconeIn u.
  Proof.
    apply signature_Mor_eq.
    intro R.
    apply (coconeInCommutes (colimCocone (coMod R (d' R)))).
  Defined.
  Lemma Sig_coneOut_commutes (u v : vertex g) (e : edge u v) :
      Sig_coneOut u · dmor d e = Sig_coneOut v.
  Proof.
    apply signature_Mor_eq.
    intro R.
    apply (coneOutCommutes (limCone (limMod _ (d' R)))).
  Defined.

  Definition Sig_colim_cocone : cocone d Sig_colim :=
    make_cocone Sig_coconeIn Sig_coconeIn_commutes.

  Definition Sig_lim_cone : cone d Sig_lim :=
    make_cone Sig_coneOut Sig_coneOut_commutes.

  Lemma Sig_colimArrow_laws {M : signature C} (cc : cocone d M) :
    is_signature_Mor
       (  Sig_colim) (M)
      (fun R => colimArrow  (coMod R (d' R)) (M R) (mapcocone (FORGET R) d cc)  ).
  Proof.
    intros R S f.
    apply nat_trans_eq;[apply homset_property|].
    intro c.
    cbn.
    repeat rewrite id_right.
    apply pathsinv0.
    etrans;[apply postcompWithColimArrow|].
    apply pathsinv0.
    apply colimArrowUnique.
    intro u.
    cbn.
    etrans.
    {
      rewrite assoc.
      apply cancel_postcomposition.
      set (cc1 := colims_g _).
      apply (colimArrowCommutes cc1).
    }
    cbn.
    etrans.
    {
      rewrite <- assoc.
      apply cancel_precomposition.
      set (cc1 := colims_g _).
      apply (colimArrowCommutes cc1).
    }
    cbn.
    apply signature_Mor_ax_pw.
  Qed.
  Lemma Sig_limArrow_laws {M : signature C} (cc : cone d M) :
    is_signature_Mor
      M  (  Sig_lim)
      (fun R => limArrow  (limMod R (d' R)) (M R) (mapcone (FORGET R) d cc)  ).
  Proof.
    intros R S f.
    apply nat_trans_eq;[apply homset_property|].
    intro c.
    cbn.
    repeat rewrite id_right.
    apply pathsinv0.
    etrans;[apply postCompWithLimArrow|].
    apply pathsinv0.
    apply limArrowUnique.
    intro u.
    cbn.
    etrans.
    {
      rewrite <- assoc.
      apply cancel_precomposition.
      set (cc1 := lims_g _).
      apply (limArrowCommutes cc1).
    }
    cbn.
    apply pathsinv0.
    etrans.
    {
      rewrite assoc.
      apply cancel_postcomposition.
      set (cc1 := lims_g _).
      apply (limArrowCommutes cc1).
    }
    cbn.
    apply pathsinv0.
    apply signature_Mor_ax_pw.
  Qed.

  Definition Sig_colimArrow {M : signature _} (cc : cocone d M) :
    signature_Mor  Sig_colim M := _ ,, Sig_colimArrow_laws  cc.

  Definition Sig_limArrow {M : signature C} (cc : cone d M) :
    signature_Mor  M Sig_lim := _ ,, Sig_limArrow_laws  cc.

  Lemma Sig_isColimCocone : isColimCocone _ _ Sig_colim_cocone.
    intros M cc.
    use unique_exists.
    - exact (Sig_colimArrow cc).
    - intro v.
      apply signature_Mor_eq.
      intro R.
      apply (colimArrowCommutes (coMod _ (d' R))).
    - intro y.
      cbn -[isaprop].
      apply  impred_isaprop.
      intro u.
      use signature_category_has_homsets.
    - intros y h.
      apply signature_Mor_eq.
      intro R.
      apply (colimArrowUnique (coMod _ (d' R))).
      intro u.
      apply (  maponpaths (fun z => pr1 z R) (h u)).
  Defined.
  Lemma Sig_isLimCone : isLimCone _ _ Sig_lim_cone.
    intros M cc.
    use unique_exists.
    - exact (Sig_limArrow cc).
    - intro v.
      apply signature_Mor_eq.
      intro R.
      apply (limArrowCommutes (limMod _ (d' R))).
    - intro y.
      cbn -[isaprop].
      apply  impred_isaprop.
      intro u.
      use signature_category_has_homsets.
    - intros y h.
      apply signature_Mor_eq.
      intro R.
      apply (limArrowUnique (limMod _ (d' R))).
      intro u.
      apply (  maponpaths (fun z => pr1 z R) (h u)).
  Defined.

  Definition Sig_ColimCocone : ColimCocone d :=
    make_ColimCocone  _ _ _  Sig_isColimCocone.

  Definition Sig_LimCone : LimCone d :=
    make_LimCone  _ _ _  Sig_isLimCone.

End ColimsSig.

Definition Sig_Colims_of_shape {C : category}
           (g : graph)
           (colims_g : Colims_of_shape g C)
            : Colims_of_shape g (signature_category) :=
   Sig_ColimCocone  (C:= C) (g := g) colims_g.
Definition Sig_Lims_of_shape {C : category}
           (g : graph)
           (lims_g : Lims_of_shape g C)
            : Lims_of_shape g (signature_precategory) :=
   Sig_LimCone  (C:= C) (g := g) lims_g.


Require Import Brenner.
Import Syntax.CST.

(** * An example *)

Definition t1 := 1.
Definition td := 2.
Definition ph1 := 1.
Parameter bf : prog.

Definition bl := t1 <- NEW_TID;; REG(ph1, t1);; FORK(t1, bf);; END.
Definition bd := LOOP(bl) ;; DEREG(ph1);; END.
Definition b := ph1 <- NEW_PHASER;; bd.
Definition s1_tm := TaskMap.add td b TaskMap.make.

(** Initializes an abstract state from a program. *)
Definition s1 := load td b.

(** Performs the first reduction step that creates a phaser. *)
Definition s2_td := bd.
Definition s2_tm := add td s2_td s1_tm.
Definition s2_pm := PhaserMap.eval PhaserMap.make td (PhaserMap.NEW ph1).
Definition s2 :state := (s2_pm, s2_tm).
Lemma td_In_s1_tm : TaskMap.MapsTo td b s1_tm.
  assert (H: TID.eq td td) by apply (TID.eq_refl td).
  apply Map_TID.add_1; auto.
Qed.

Goal Reduces s1 s2.
  eauto using r_phaser, PhaserMap.make, s1_tm, td_In_s1_tm.
Qed.

Definition s3_td := t1 <- NEW_TID;; REG(ph1, t1);; FORK(t1, bf);; bd.
Definition s3_tm := TaskMap.add td s3_td s2_tm.
Definition s3_pm := s2_pm.
Definition s3 :state := (s3_pm, s3_tm).

(** The next reduction step is to unfold the loop. *)
Goal Reduces s2 s3.
  apply r_cflow with (c:=loop bl) (p:=DEREG(ph1);; END).
  - unfold s2_tm.
    unfold s2_td.
    unfold bd.
    apply Map_TID.add_1; auto using TID.eq_refl.
  - eapply ControlFlow.r_iter; eauto.
Qed.


(********** Syntax of the contract language **********)

Require Export Reals.
Require Export Utils.
Require Export Equalities.

(* The types of assets and parties are kept abstract. They should at
least be decicable, though. *)

Parameter Asset : Set.
Parameter Party : Set.

Module Asset.
  Parameter eqb : Asset -> Asset -> bool.
  Axiom eqb_eq : forall x y, eqb x y = true <-> x = y.

  Lemma eqb_refl p:  eqb p p = true.
  Proof.
    assert (p = p) as E by reflexivity. rewrite <- eqb_eq in E. auto.
  Qed.

End Asset.

Module Party.
  Parameter eqb : Party -> Party -> bool.
  Axiom eqb_eq : forall x y, eqb x y = true <-> x = y.
  Lemma eqb_refl p:  eqb p p = true.
  Proof.
    assert (p = p) as E by reflexivity. rewrite <- eqb_eq in E. auto.
  Qed.

End Party.

(* We also keep the types for Boolean and real observable labels
abstract. *)

Parameter BoolObs : Set.
Parameter RealObs : Set.

(* The type of variables. *)

Inductive Var : Set := V1 | VS (v:Var).

(* The type of labels that describe external observables. *)

Inductive ObsLabel : Set := LabR (l:RealObs) | LabB (l:BoolObs).

(* The type of operations that may be used in expressions. *)

Inductive Op : Set := Add | Sub | Mult | Div | And | Or | Less | Leq | Equal |
                      Not | Neg |
                      BLit (b : bool) | RLit (r:R) |
                      Cond.

(* The type of expressions. *)

Inductive Exp : Set := OpE (op : Op) (args : list Exp)
                     | Obs (l:ObsLabel) (i: Z)
                     | VarE (v:Var)
                     | Acc (f : Exp) (d : nat) (e : Exp).

(* We need to define a custom induction principle for expressions. The
automatically generated induction principle is too weak. *)

Definition Exp_ind'   : forall P : Exp -> Prop,
       (forall (op : Op) (args : list Exp), all P args -> P (OpE op args)) ->
       (forall (l : ObsLabel) (i : Z), P (Obs l i)) ->
       (forall v : Var, P (VarE v)) ->
       (forall f2 : Exp,
        P f2 -> forall (d : nat) (e : Exp), P e -> P (Acc f2 d e)) ->
       forall e : Exp, P e :=
fun (P : Exp -> Prop)
  (f : forall (op : Op) (args : list Exp), all P args -> P (OpE op args))
  (f0 : forall (l : ObsLabel) (i : Z), P (Obs l i))
  (f1 : forall v : Var, P (VarE v))
  (f2 : forall f2 : Exp,
        P f2 -> forall (d : nat) (e : Exp), P e -> P (Acc f2 d e)) =>
fix F (e : Exp) : P e :=
  match e as e0 return (P e0) with
  | OpE op args => let fix step es : all P es :=
                       match es with
                           | nil => forall_nil P
                           | e' :: es' => forall_cons P (F e') (step es')
                       end
                   in  f op args (step args)
  | Obs l i => f0 l i
  | VarE v => f1 v
  | Acc f3 d e0 => f2 f3 (F f3) d e0 (F e0)
  end.

(* This type defines the syntax of the contract language *)

Inductive Contr : Type :=
 | Zero : Contr
 | Let : Exp -> Contr -> Contr
 | Transfer : Party -> Party -> Asset -> Contr
 | Scale : Exp -> Contr -> Contr
 | Translate : nat -> Contr -> Contr
 | Both : Contr -> Contr -> Contr
 | If : Exp -> nat -> Contr -> Contr -> Contr.


Require Import msl.msl_standard.
Require Import Maps.

(*** Machine specification ***)

(** Abstract syntax of machine code **)

Definition var: Set := positive.
Definition var_eq: forall (v1 v2: var), {v1=v2} + {v1<>v2} := peq.
Definition V (n: nat) : var := P_of_succ_nat n.

Definition label: Set := positive.
Definition label_eq: forall (l1 l2: label), {l1=l2} + {l1<>l2} := peq.
Definition L (n: nat) : label := P_of_succ_nat n.

Section instr_def.
  Variable X:Type.

  Inductive instr : Type :=
  | instr_assert : X -> instr

  | instr_getlabel: label -> var -> instr
  | instr_fetch_field: var -> nat -> var -> instr
  | instr_cons: var -> var -> var -> instr

  | instr_seq: instr -> instr -> instr
  | instr_if_nil : var -> instr -> instr -> instr
  | instr_call: var -> instr
  | instr_return: instr.

(*  | instr_nil : instr.*)
End instr_def.

Implicit Arguments instr_assert [X].
Implicit Arguments instr_getlabel [X].
Implicit Arguments instr_fetch_field [X].
Implicit Arguments instr_cons [X].
Implicit Arguments instr_seq [X].
Implicit Arguments instr_if_nil [X].
Implicit Arguments instr_call [X].
Implicit Arguments instr_return [X].

Fixpoint fmap_instr {A B} (f:A->B) (x:instr A) : instr B :=
  match x with
  | instr_assert a => instr_assert (f a)
  | instr_getlabel l v => instr_getlabel l v
  | instr_fetch_field v1 n v2 => instr_fetch_field v1 n v2
  | instr_cons v1 v2 v3 => instr_cons v1 v2 v3
  | instr_seq i1 i2 => instr_seq (fmap_instr f i1) (fmap_instr f i2)
  | instr_if_nil v i1 i2 => instr_if_nil v (fmap_instr f i1) (fmap_instr f i2)
  | instr_call v => instr_call v
  | instr_return => instr_return
(*  | instr_nil => instr_nil _*)
  end.

(** Run-time values and environments **)

Inductive value: Set :=
  | value_label: label -> value
  | value_cons: value -> value -> value.

Definition store := map value.
Definition store_empty : store := empty value.

Definition program X := map (instr X).

Module KnotInput <: KNOT_INPUT__HERED_PROP_OTH.
  Definition F := program.

  Definition fmap A B (f:A->B) := map_fmap _ _ (fmap_instr f).
  Implicit Arguments fmap [A B].

  Lemma fmap_id : forall A, fmap (id A) = id (F A).
  Proof.
    intros; unfold fmap.
    extensionality x.
    induction x; simpl; auto.
    destruct o; unfold id; f_equal; auto.
    f_equal.
    induction i; simpl; auto; congruence.
  Qed.

  Lemma fmap_comp : forall A B C (f:B -> C) (g:A -> B),
    fmap f oo fmap g = fmap (f oo g).
  Proof.
    unfold fmap, compose; intros; extensionality x.
    induction x; simpl; auto.
    destruct o; unfold id; f_equal; auto.
    f_equal.
    induction i; simpl; auto; congruence.
  Qed.

  Definition other := store.
End KnotInput.

Module K <: KNOT__HERED_PROP_OTH := Knot_HeredPropOth(KnotInput).
Import K.

Definition prog := K.knot.
Definition world := (prog * store)%type.
Definition assert := pred world.

Definition instruction := instr assert.
Definition stack := list instruction.

Infix ";;" := instr_seq (at level 60, right associativity).

Definition prog_lookup (p:prog) (l:label) : option instruction :=
  get _ (snd (unsquash p)) l.

(** Execution of machine code **)

Inductive step : prog -> prog -> store -> stack -> store -> stack -> Prop :=

  | step_assert : forall p r i stk (P:assert),
      P (p,r) ->
    (*----------------------------------------------------*)
      step p p r ((instr_assert P ;; i) :: stk) r (i :: stk)

  | step_getlabel: forall p r l v i stk,
    (*----------------------------------------------------*)
      step p p r ((instr_getlabel l v ;; i) :: stk) (r#v <- (value_label l)) (i :: stk)

  | step_fetch_field_0: forall p r v1 v2 i a0 a1 stk,
      r#v1 = Some (value_cons a0 a1) ->
    (*----------------------------------------------------*)
      step p p r ((instr_fetch_field v1 0 v2 ;; i) :: stk) (r#v2 <- a0) (i :: stk)

  | step_fetch_field_1: forall p r v1 v2 i a0 a1 stk,
      r#v1 = Some (value_cons a0 a1) ->
    (*----------------------------------------------------*)
      step p p r ((instr_fetch_field v1 1 v2 ;; i) :: stk) (r#v2 <- a1) (i :: stk)

  | step_cons: forall p r v1 v2 v3 i a1 a2 stk,
      r#v1 = Some a1 ->
      r#v2 = Some a2 ->
    (*----------------------------------------------------*)
      step p p r ((instr_cons v1 v2 v3 ;; i) :: stk) (r#v3 <- (value_cons a1 a2)) (i :: stk)

  | step_seq: forall p r i1 i2 i3 stk,
    (*----------------------------------------------------*)
      step p p r (((i1 ;; i2) ;; i3) :: stk) r ((i1 ;; i2 ;; i3) :: stk)

  | step_if_nil1 : forall p r v i1 i2 i stk,
      r#v = Some (value_label (L 0)) ->
    (*----------------------------------------------------*)
      step p p r ((instr_if_nil v i1 i2 ;; i) :: stk) r ((i1 ;; i) :: stk)

  | step_if_nil2 : forall p r v i1 i2 i a1 a2 stk,
      r#v = Some (value_cons a1 a2) ->
    (*----------------------------------------------------*)
      step p p r ((instr_if_nil v i1 i2 ;; i) :: stk) r ((i2 ;; i) :: stk)

  | step_call : forall p p' r v l i i' stk,
      r#v = Some (value_label l) ->
      prog_lookup p l = Some i' ->
      age p p' ->
    (*----------------------------------------------------*)
      step p p' r ((instr_call v ;; i) :: stk) r ((i' ;; instr_assert FF) :: i :: stk)

  | step_return : forall p r stk i,
    (*----------------------------------------------------*)
      step p p r ((instr_return ;; i) :: stk) r stk.

(* Safety property *)

Inductive stepstar : prog -> prog -> store -> stack -> store -> stack ->  Prop :=
 | stepstar_O: forall s i p, stepstar p p s i s i
 | stepstar_S: forall p p' p'' s i s' i' s'' i'',
              step p p' s i s' i' -> stepstar p' p'' s' i' s'' i'' -> stepstar p p'' s i s'' i''.

Inductive step_or_halt : prog -> store -> stack -> Prop :=
  | step_or_halt_step: forall p p' r i r' i',
      step p p' r i r' i' -> step_or_halt p r i
  | step_or_halt_halt: forall p r,
      step_or_halt p r nil.

Definition safe (p: prog) (s: store) (k: stack) :=
   forall p' s' k', stepstar p p' s k s' k' -> step_or_halt p' s' k'.

Definition safe_prog (p: program assert) (l:label) :=
  exists i, p#l = Some i /\
    forall n s, safe (K.squash (n,p)) s (i::nil).

Definition eventually_halts (p:prog) (r:store) (s:stack) : Prop :=
  exists p', exists r', stepstar p p' r s r' nil.

Definition eventually_halts_n (n : nat) (p:prog) (r:store) (s:stack) : Prop :=
  exists p', exists r', (level p - level p' <= n) /\ stepstar p p' r s r' nil.

(*****)
(* Other Stuff *)

Inductive stepN : nat -> prog -> prog -> store -> stack -> store -> stack ->  Prop :=
 | stepN_O: forall p s i, stepN O p p s i s i
 | stepN_S: forall n s i p p' p'' s' i' s'' i'',
              step p p' s i s' i' -> stepN n p' p'' s' i' s'' i'' -> stepN (S n) p p'' s i s'' i''.

Lemma stepstar_stepN : forall p p' s i s' i',
  stepstar p p' s i s' i' ->
  exists n, stepN n p p' s i s' i'.
Proof.
  intros p p' s i s' i' H; induction H.
  exists 0; apply stepN_O.
  destruct IHstepstar as [n Hn].
  exists (S n).
  eapply stepN_S.
  apply H.
  apply Hn.
Qed.

Lemma stepN_stepstar : forall p p' n s i s' i',
  stepN n p p' s i s' i' ->
  stepstar p p' s i s' i'.
Proof.
  intros p p' n s i s' i' H; induction H.
  apply stepstar_O.
  eapply stepstar_S.
  apply H.
  apply IHstepN.
Qed.

Lemma step_deterministic : forall p p1 p2 s i s1 s2 i1 i2,
  step p p1 s i s1 i1 ->
  step p p2 s i s2 i2 ->
  s1 = s2 /\ i1 = i2 /\ p1 = p2.
Proof.
  intros p p1 p2 s i s1 s2 i1 i2 H1 H2.
  inversion H1; subst; inversion H2; subst; unfold age in *;
    try intuition congruence.
Qed.

Lemma step_confluent : forall p p1 p2 p' n s s1 s2 s' i i1 i2 i',
  step p p1 s i s1 i1 ->
  step p p2 s i s2 i2 ->
  stepN n p1 p' s1 i1 s' i' ->
  stepN n p2 p' s2 i2 s' i'.
Proof.
 intros p p1 p2 p' n s s1 s2 s' i i1 i2 i' H1 H2 H3.
 generalize (step_deterministic _ _ _ _ _ _ _ _ _ H1 H2).
 intuition; subst; auto.
Qed.

Lemma step_triangle : forall n1 n2 p p1 p2 s s1 s2 i i1 i2,
  n1 <= n2 ->
  stepN n1 p p1 s i s1 i1 ->
  stepN n2 p p2 s i s2 i2 ->
  stepN (n2 - n1) p1 p2 s1 i1 s2 i2.
Proof.
  intros n1; induction n1; simpl; intros.
  inversion H0; subst; clear H0.
  replace (n2 -0) with n2; [ auto | omega ].
  inversion H0; subst; clear H0.
  destruct n2; simpl in *.
  inversion H.
  eapply IHn1.
  omega.
  apply H4.
  inversion H1; subst; clear H1.
  destruct (step_deterministic p p' p'0 s i s' s'0 i' i'0) as [? [? ?]]; auto.
  subst; auto.
Qed.


Require Import Unicode.Utf8 ssreflect.
Require Import micromega.Lia.

Set Primitive Projections.

Record iso (A B : Type) :=
  {intro : A → B;
   elim : B → A;
   eta : ∀ x, intro (elim x) = x;
   beta : ∀ x, elim (intro x) = x}.

Arguments intro [_] [_] _.
Arguments elim [_] [_] _.

Record product (A B : Type) :=
  {π1 : A;
   π2 : B}.

Arguments Build_product [_] [_] _ _.
Arguments π1 [_] [_] _.
Arguments π2 [_] [_] _.

Infix "≅" := iso (at level 100).
Notation "◻" := Type.
Notation "f ∘ g" := (λ x, f (g x)) (at level 10).

Axiom later : Type → Type.
Notation "▶ A" := (later A) (at level 60).

Axiom dlater : ▶ Prop → Prop.
Notation "⟨▷⟩ A" := (dlater A) (at level 60).

Axiom plater : Prop → Prop.
Notation "▷ A" := (plater A) (at level 60).

Axiom next : ∀ {A}, A → ▶ A.
Axiom pnext : ∀ {P : Prop}, P → ▷ P.
Notation "next: x" := (next x) (at level 100).

Axiom loeb : ∀ {A}, (▶ A → A) → A.
Axiom ploeb : ∀ {A : Prop}, (▷ A → A) → A.
Notation "fix: x ; e" := (loeb (λ x, e)) (at level 100).
Axiom loeb_unfold : ∀ {A f}, @loeb A f = f (next (loeb f)).

Module Later.
  Axiom from_eq : ∀ {A} (a b : A), ▷ (a = b) → next a = next b.
  Axiom to_eq : ∀ {A} (a b : A), next a = next b → ▷ (a = b).
  Axiom ap : ∀ {A B}, later (A → B) → later A → later B.
  Axiom pap : ∀ {A B : Prop}, plater (A → B) → plater A → plater B.

  Axiom dlater_compute : ∀ A, ⟨▷⟩ (next A) = ▷ A.

  Module ApNotation.
    Infix "⊛" := ap (at level 50).
    Infix "⊛p" := pap (at level 50).
  End ApNotation.

  Import ApNotation.

  Axiom ap_compute : ∀ {A B} (f : A → B) (x : A), next f ⊛ next x = next (f x).

  Definition map {A B} : (A → B) → later A → later B :=
    fun f x => next f ⊛ x.

  Definition pmap {A B : Prop} : (A → B) → plater A → plater B :=
    fun f x => pnext f ⊛p x.
End Later.

Export Later.ApNotation.
Infix "<$>" := Later.map (at level 50).

Fixpoint boom n :=
  ▷ match n with
    | 0 => False
    | S n => boom n
    end.

Notation "n ⊩ P" := (boom n → P) (at level 100).

Lemma boom_suc : ∀ n, boom n → boom (S n).
Proof.
  move=> n.
  apply: pnext.
Qed.

Lemma boom_leq : ∀ m n, m ≤ n → boom m → boom n.
Proof.
  move=> m; elim.
  - move=> ?.
    replace m with 0; first by auto.
    by lia.
  - move=> n ih p z.
    compare m (S n).
    + by move=> <- .
    + move=> q.
      apply: pnext; apply: ih; last by auto.
      by lia.
Defined.