Require Export GenConstructions.
Require Export Consistency.
Require Export GenTarski.
Require Import Stability.

(** *** Standard Models **)

Section Completeness.
  Context {Sigma : Signature}.
  Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds}.
  Context {HeF : enumT Funcs} {HeP : enumT Preds}.

  Hint Constructors unused.

  Section BotModel.
    Variable T : theory.
    Hypothesis T_closed : closed_T T.

    Definition input_bot :=
      {|
        NBot := Fal ;
        NBot_closed := (fun n => uf_Fal n) ;

        variant := expl ;

        In_T := T ;
        In_T_closed := T_closed ;

        enum := form_enum ;
        enum_enum := form_enum_enumerates ;
        enum_unused := form_enum_fresh
      |}.

    Definition output_bot := construct_construction input_bot.

    Instance model_bot : interp term :=
      {| i_f := Func; i_P := fun P v => Pred P v ∈ Out_T output_bot ;
        i_F := ⊥ ∈ Out_T output_bot |}.

    Lemma eval_ident rho (t : term) :
      eval rho t = subst_term rho t.
    Proof.
      induction t using strong_term_ind; comp; asimpl; try congruence. f_equal.
    Qed.

    Lemma model_bot_correct phi rho :
      (phi[rho] ∈ Out_T output_bot <-> rho ⊨ phi).
    Proof.
      induction phi in rho |-*. 1,2,3: comp.
      - tauto.
      - now rewrite <- (vec_ext (fun x => eval_ident rho x)).
      - rewrite <-IHphi1, <-IHphi2. now apply Out_T_impl.
      - cbn. setoid_rewrite <-IHphi. rewrite Out_T_all.
        split; intros H d; specialize (H d); comp; now asimpl in H.
    Qed.

    Lemma model_bot_classical :
      classical model_bot.
    Proof.
      intros rho phi psi. apply model_bot_correct, Out_T_prv.
      use_theory (nil : list form). apply Pc.
    Qed.

    Lemma model_bot_standard :
      consistent T -> SM model_bot.
    Proof.
      intros Hcon. split. 1: exact model_bot_classical. intros Hin. apply Hcon.
      apply Out_T_econsistent with output_bot. use_theory [⊥]. ctx.
    Qed.

    Lemma model_bot_exploding :
      EM model_bot.
    Proof.
      split. 1: exact model_bot_classical. intros rho s t. apply model_bot_correct.
      comp. apply Out_T_prv. use_theory (nil : list form). ointros. oexfalso. ctx.
    Qed.

    Lemma valid_T_model_bot phi :
      phi ∈ T -> ids ⊨ phi.
    Proof.
      intros H % (Out_T_sub output_bot). apply model_bot_correct; now comp.
    Qed.
  End BotModel.

  Section StandardCompletenes.
    Variables (T : theory) (phi : form).
    Hypothesis (HT : closed_T T) (Hphi : closed phi).

    Lemma semi_completeness_standard :
      T ⊫S phi -> ~ ~ T ⊩CE phi.
    Proof.
      intros Hval Hcons. rewrite refutation_prv in Hcons.
      assert (Hcl : closed_T (T ⋄ (¬ phi))) by ( intros ? ? [] ; subst; eauto).
      destruct (model_bot_standard Hcl Hcons) as [Hclass Hb]. apply Hb.
      apply (model_bot_correct Hcl (¬ phi) ids). apply Out_T_sub. right. now comp. refine (Hval _ _ _ _ _).
      - now apply model_bot_standard.
      - intros ? ?. apply valid_T_model_bot; intuition.
    Qed.

    Lemma completeness_standard_stability :
      (T ⊫S phi -> T ⊩CE phi) <-> stable (T ⊩CE phi).
    Proof.
      split.
      - intros Hcomp Hdn. apply Hcomp, valid_T_standard_dm. 1: firstorder. intros Hsem.
        apply Hdn. intros H. apply Hsem, (StrongSoundness H).
        + now intros _ ? ? [].
        + intros _ ? ? []. firstorder.
      - intros Hstab Hsem. now apply Hstab, semi_completeness_standard.
    Qed.
  End StandardCompletenes.

  Section MPStrongCompleteness.
    Hypothesis mp : MP.
    Variable (T : theory) (phi : form) (L : nat -> list form).
    Hypothesis (HT : closed_T T) (Hphi : closed phi).
    Hypothesis (He : DecidableEnumerable.enum T L).

    Lemma mp_tprv_stability {p : peirce} {b : bottom} :
      ~ ~ T ⊩ phi -> T ⊩ phi.
    Proof.
      apply (enumeration_stability mp (enum_tprv He) (dec_form HdF HdP)).
    Qed.

    Lemma mp_standard_completeness :
      T ⊫S phi -> T ⊩CE phi.
    Proof.
      intros Hprv % semi_completeness_standard. 2,3: assumption.
      now apply mp_tprv_stability.
    Qed.
  End MPStrongCompleteness.

(** *** Exploding Models **)

  Section ExplodingCompletenes.
    Variables (T : theory) (phi : form).
    Hypothesis (HT : closed_T T) (Hphi : closed phi).

    Lemma completeness_expl :
      T ⊫E phi -> T ⊩CE phi.
    Proof.
      intros Hval. assert (Hcl : closed_T (T ⋄ (¬ phi))) by (intros ? ? [] ; subst; eauto).
      apply refutation_prv. apply (@Out_T_econsistent _ _ (output_bot Hcl)); cbn. use_theory [⊥]. 2: ctx.
      intros ? [<- | []]. apply (model_bot_correct _ ⊥ ids).
      specialize (Hval term (model_bot Hcl) (model_bot_exploding Hcl) ids).
      assert (@sat _ _ (model_bot Hcl) ids (¬ phi)) by (apply model_bot_correct, Out_T_sub; comp; firstorder).
      apply H, Hval. intros ? ?. apply valid_T_model_bot; intuition.
    Qed.

    Lemma valid_standard_expld_stability :
      (T ⊫S phi -> T ⊫E phi) <-> stable (T ⊩CE phi).
    Proof.
      rewrite <- completeness_standard_stability. 2,3: assumption. split.
      - intros Hincl Hval % Hincl. now apply completeness_expl.
      - intros Hcomp Hprv % Hcomp. apply (StrongSoundness Hprv).
        all: now intros _ ? ? [].
    Qed.
  End ExplodingCompletenes.

(** *** Minimal Models **)

  Section FragmentModel.
    Variable T : theory.
    Hypothesis T_closed : closed_T T.

    Variable GBot : form.
    Hypothesis GBot_closed : closed GBot.

    Definition input_fragment :=
      {|
        NBot := GBot ;
        NBot_closed := GBot_closed ;

        variant := lconst ;

        In_T := T ;
        In_T_closed := T_closed ;

        enum := form_enum ;
        enum_enum := form_enum_enumerates ;
        enum_unused := form_enum_fresh
      |}.

    Definition output_fragment := construct_construction input_fragment.

    Instance model_fragment : interp term :=
      {| i_f := Func; i_P := fun P v => Pred P v ∈ Out_T output_fragment ;
        i_F := ⊥ ∈ Out_T output_fragment |}.

    Lemma eval_ident_fragment rho (t : term) :
      eval rho t = subst_term rho t.
    Proof.
      induction t using strong_term_ind; comp; asimpl; try congruence. f_equal.
    Qed.

    Lemma model_fragment_correct phi rho :
      (phi[rho] ∈ Out_T output_fragment <-> rho ⊨ phi).
    Proof.
      induction phi in rho |-*. 1,2,3: comp.
      - tauto.
      - now rewrite <- (vec_ext (fun x => eval_ident_fragment rho x)).
      - rewrite <-IHphi1, <-IHphi2. now apply Out_T_impl.
      - cbn. setoid_rewrite <-IHphi. rewrite Out_T_all.
        split; intros H d; specialize (H d); comp; now asimpl in H.
    Qed.

    Lemma model_fragment_classical :
      BLM model_fragment.
    Proof.
      intros rho phi psi. apply model_fragment_correct, Out_T_prv.
      use_theory (nil : list form). apply Pc.
    Qed.

    Lemma valid_T_fragment phi :
      phi ∈ T -> ids ⊨ phi.
    Proof.
      intros H % (Out_T_sub output_fragment). apply model_fragment_correct; now comp.
    Qed.
  End FragmentModel.

  Section FragmentCompleteness.

    Lemma semi_completeness_fragment T phi :
      closed_T T -> closed phi -> T ⊫M phi -> T ⊩CL phi.
    Proof.
      intros HT Hphi Hval. replace phi with (phi[ids]) in * by now comp.
      apply (@Out_T_econsistent _ _ (output_fragment HT Hphi)); cbn. use_theory [phi[ids]]. 2: ctx.
      intros ? [<- | []]. apply (model_fragment_correct HT Hphi phi ids). comp. rewrite instId_form in Hval.
      apply Hval. 1: apply model_fragment_classical. intros ? ?. apply valid_T_fragment; intuition.
    Qed.
  End FragmentCompleteness.
End Completeness.

(** ** Extending the Completeness Results *)

Section FiniteCompleteness.
  Context {Sigma : Signature}.
  Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds}.
  Context {HeF : enumT Funcs} {HeP : enumT Preds}.

  Lemma list_completeness_standard A phi :
    ST__f -> valid_L SM A phi -> A ⊢CE phi.
  Proof.
    intros stf Hval % valid_L_to_single. apply prv_from_single.
    apply con_T_correct. apply completeness_standard_stability.
    1: intros ? ? []. 1: apply close_closed. 2: now apply valid_L_valid_T in Hval.
    apply stf, fin_T_con_T.
  Qed.

  Lemma list_completeness_expl A phi :
    valid_L EM A phi -> A ⊢CE phi.
  Proof.
    intros Hval % valid_L_to_single. apply prv_from_single.
    apply tprv_list_T. apply completeness_expl. 1: intros ? ? [].
    1: apply close_closed. now apply valid_L_valid_T in Hval.
  Qed.

  Lemma list_completeness_fragment A phi :
    valid_L BLM A phi -> A ⊢CL phi.
  Proof.
    intros Hval % valid_L_to_single. apply prv_from_single.
    apply tprv_list_T. apply semi_completeness_fragment. 1: intros ? ? [].
    1: apply close_closed. now apply valid_L_valid_T in Hval.
  Qed.
End FiniteCompleteness.

Section StrongCompleteness.
  Context {Sigma : Signature}.
  Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds}.
  Context {HeF : enumT Funcs} {HeP : enumT Preds}.

  Lemma dn_inherit (P Q : Prop) :
    (P -> Q) -> ~ ~ P -> ~ ~ Q.
  Proof. tauto. Qed.

  Lemma strong_completeness_standard S T phi :
    ST S -> @map_closed S Sigma (sig_ext Sigma) (fun phi => (sig_lift phi)[ext_c]) -> S Sigma T -> T ⊫S phi -> T ⊩CE phi.
  Proof.
    intros sts cls HT Hval. apply sig_lift_out_T. apply completeness_standard_stability.
    1: apply lift_ext_c_closes_T. 1: apply lift_ext_c_closes. 2: apply (sig_lift_subst_valid droppable_S Hval).
    now apply sts, cls.
  Qed.

  Lemma strong_completeness_expl T phi :
    T ⊫E phi -> T ⊩CE phi.
  Proof.
    intros Hval. apply sig_lift_out_T, completeness_expl.
    1: apply lift_ext_c_closes_T. 1: apply lift_ext_c_closes.
    apply (sig_lift_subst_valid droppable_E Hval).
  Qed.

  Lemma strong_completeness_fragment T phi :
    T ⊫M phi -> T ⊩CL phi.
  Proof.
    intros Hval. apply sig_lift_out_T, semi_completeness_fragment.
    1: apply lift_ext_c_closes_T. 1: apply lift_ext_c_closes.
    apply (sig_lift_subst_valid droppable_BL Hval).
  Qed.
End StrongCompleteness.


Require Import Common.Definitions.
Require Import CompCert.Events.
Require Import CompCert.Smallstep.
Require Import CompCert.Behaviors.
Require Import Lib.Extra.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

(* Define a canonical structure on event equality. If needed, richer event types
   can extend the encoding by using nested sums. *)
Definition sum_of_event (e : event) :=
  match e with
  | ERet C v C' => inl (C, v, C')
  | ECall C P v C' => inr (C, P, v, C')
  end.

Lemma sum_of_event_inj : injective sum_of_event.
Proof.
by case=> [????|???] [????|???] //= => [[-> -> -> ->]|[-> -> ->]].
Qed.

Definition event_eqMixin := InjEqMixin sum_of_event_inj.
Canonical event_eqType := Eval hnf in EqType event event_eqMixin.

Definition empty_behavior (beh : program_behavior) :=
  match beh with
  | Terminates t | Diverges t | Goes_wrong t => t == E0
  | Reacts _ => false
  end.

Lemma empty_behaviorPn beh :
  reflect (exists e beh', beh = behavior_app [:: e] beh')
          (~~ empty_behavior beh).
Proof.
case: beh=> [[|e t]|[|e t]|[e t]|[|e t]] /=; constructor;
try by case=> [e [[|||]]].
- eexists e, (Terminates _); rewrite /=; eauto.
- eexists e, (Diverges _); rewrite /=; eauto.
- eexists e, (Reacts _); rewrite /=; eauto.
- eexists e, (Goes_wrong _); rewrite /=; eauto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Smallstep semantics: alternative star. *)

Section CLOSURES.

Variable genv: Type.
Variable state: Type.

Variable step: genv -> state -> trace -> state -> Prop.

Inductive starR (ge: genv): state -> trace -> state -> Prop :=
  | starR_refl: forall s,
      starR ge s E0 s
  | starR_step: forall s1 t1 s2 t2 s3 t,
      starR ge s1 t1 s2 -> step ge s2 t2 s3 -> t = t1 ** t2 ->
      starR ge s1 t s3.

Lemma starR_one:
  forall ge s1 t s2, step ge s1 t s2 -> starR ge s1 t s2.
Proof.
  intros. eapply starR_step; eauto. apply starR_refl. traceEq.
Qed.

Lemma starR_trans:
  forall ge s1 t1 s2, starR ge s1 t1 s2 ->
  forall t2 s3 t, starR ge s2 t2 s3 -> t = t1 ** t2 -> starR ge s1 t s3.
Proof.
  intros ge s1 t1 s2 HstarR1 t2 s3 t HstarR2 Ht.
  generalize dependent t.
  generalize dependent t1.
  generalize dependent s1.
  induction HstarR2 as [| s1 t1 s2 t2 s3 t HstarR1 IHHstarR2 Hstep2 Ht].
  - intros s1 t1 HstarR1 t Ht.
    rewrite E0_right in Ht.
    subst.
    assumption.
  - intros s0 t0 HstarR0 t3 Ht3.
    eapply starR_step.
    + apply (IHHstarR2 _ _ HstarR0 _ (erefl (t0 ** t1))).
    + apply Hstep2.
    + subst.
      rewrite Eapp_assoc.
      reflexivity.
Qed.

Lemma star_iff_starR : forall ge s1 t s2, star step ge s1 t s2 <-> starR ge s1 t s2.
Proof.
  split.
  - intros H.
    induction H.
    + apply starR_refl.
    + apply starR_one in H.
      apply (starR_trans H IHstar H1).
  - intros H.
    induction H.
    + apply star_refl.
    + apply star_one in H0.
      apply (star_trans IHstarR H0 H1).
Qed.

Lemma star_E0_ind' ge (P : state -> state -> Prop) :
  (forall s, P s s) ->
  (forall s1 s2 s3, step ge s1 E0 s2 -> star step ge s2 E0 s3 -> P s2 s3 -> P s1 s3) ->
  forall s1 s2, star step ge s1 E0 s2 -> P s1 s2.
Proof.
move=> H0 H1 s1 s2; move e_t: E0 => t Hstar.
elim: s1 t s2 / Hstar e_t => // s1 t1 s2 t2 s3 t Hstep Hstar IH ->.
move=> /(@esym _ _ _)/Eapp_E0_inv [??]; subst t1 t2.
by apply: H1; eauto.
Qed.

End CLOSURES.

Section Inversion.

Variables (L : semantics) (Hsingle : single_events L).

Lemma star_cons_inv s1 e t s2 :
  Star L s1 (e :: t) s2 ->
  exists s1' s2', Star L s1 E0 s1' /\ Step L s1' [e] s2' /\ Star L s2' t s2.
Proof.
rewrite -[e :: t]/([e] ** t).
case/(star_app_inv Hsingle)=> s2'' [Hstar1 Hstar2].
case/star_non_E0_split: Hstar1=> // [s1' [s2' [A [B C]]]].
by exists s1', s2'; do !split=> //; apply: star_trans; eauto.
Qed.

Lemma star_middle1_inv s1 t1 e t2 s2 :
  Star L s1 (t1 ** e :: t2) s2 ->
  exists s1' s2', Star L s1 t1 s1' /\ Step L s1' [e] s2' /\ Star L s2' t2 s2.
Proof.
case/(star_app_inv Hsingle)=> s0 [Hstar0].
case/star_cons_inv=> s1' [s2' [Hstar1 [Hstep2 Hstar3]]].
exists s1', s2'; do !split=> //; apply: star_trans; eauto.
by rewrite E0_right.
Qed.

End Inversion.

(* Finite prefixes and behaviors. *)

Inductive finpref_behavior : Type :=
  | FTerminates: trace -> finpref_behavior
  | FGoes_wrong: trace -> finpref_behavior
  | FTbc : trace -> finpref_behavior.

Definition not_wrong_finpref (m:finpref_behavior) : Prop :=
  match m with
  | FGoes_wrong _ => False
  | _             => True
  end.

Definition prefix (m:finpref_behavior) (b:program_behavior) : Prop :=
  match m, b with
  | FTerminates t1, Terminates t2
  | FGoes_wrong t1, Goes_wrong t2 => t1 = t2
  | FTbc t1, b => behavior_prefix t1 b
  | _, _ => False
  end.

Definition finpref_trace (m : finpref_behavior) : trace :=
  match m with
  | FTerminates t | FGoes_wrong t | FTbc t => t
  end.

Definition trace_finpref_prefix (t : trace) (m : finpref_behavior) : Prop :=
  match m with
  | FTerminates t' | FGoes_wrong t' | FTbc t' => trace_prefix t t'
  end.

Definition finpref_trace_prefix (m : finpref_behavior) (t : trace) : Prop :=
  match m with
  | FTerminates t' | FGoes_wrong t' => False
  | FTbc t' => trace_prefix t' t
  end.

Definition behavior_improves_finpref (b:program_behavior) (m:finpref_behavior) :=
  exists t, b = Goes_wrong t /\ trace_finpref_prefix t m.

(* CH: Introduce a definition for
       does_prefix and use it everywhere where it's
       possible, instead of unfolding it everywhere. *)
Definition does_prefix x m := exists b, program_behaves x b /\ prefix m b.
(* CH: Alternatively could define this in terms of Star and prove the
       predicate above as an alternative characterization. *)

(* Properties of prefixes. *)

Lemma help : forall m1 m2 T,
    trace_prefix m1 T -> trace_prefix m2 T ->
    (trace_prefix m1 m2 \/ trace_prefix m2 m1).
Proof.
  intros m1. induction m1 as [| e m1]; intros m2 T [x1 H1] [x2 H2].
  - left. now exists m2.
  - assert (foo : (exists s, m2 = e :: s) \/ m2 = []).
   { destruct m2. right. reflexivity. subst T. inversion H2.
     left. now exists m2. }
    destruct foo as [[s k0] | k1].
     + subst m2. subst T. inversion H2. specialize (IHm1 s (m1 ** x1)).
       assert (use1 : trace_prefix m1 (m1 ** x1)) by now exists x1.
       assert (use2 : trace_prefix s (m1 ** x1)) by (rewrite H0; now exists x2).
       destruct (IHm1 use1 use2) as [K | K]. clear IHm1.
       left. destruct K as [m K]. exists m. simpl. now rewrite K.
     + right. destruct K as [m K]. exists m. simpl. now rewrite K.
     + right. rewrite k1. now exists (e :: m1).
Qed.

Lemma help_inf : forall m1 m2 T,
    traceinf_prefix m1 T -> traceinf_prefix m2 T ->
    (trace_prefix m1 m2 \/ trace_prefix m2 m1).
Proof.
   intros m1. induction m1 as [| e m1]; intros m2 T [x1 H1] [x2 H2].
  - left. now exists m2.
  - assert (foo : (exists s, m2 = e :: s) \/ m2 = []).
   { destruct m2. right. reflexivity. subst T. inversion H2.
     left. now exists m2. }
    destruct foo as [[s k0] | k1].
     + subst m2. subst T. inversion H2. specialize (IHm1 s (m1 *** x1)).
       assert (use1 : traceinf_prefix m1 (m1 *** x1)) by now exists x1.
       assert (use2 : traceinf_prefix s (m1 *** x1)) by (rewrite H0; now exists x2).
       destruct (IHm1 use1 use2) as [K | K]. clear IHm1.
       left. destruct K as [m K]. exists m. simpl. now rewrite K.
     + right. destruct K as [m K]. exists m. simpl. now rewrite K.
     + right. rewrite k1. now exists (e :: m1).
Qed.

(* How to simplify this proof ? *)
Lemma behavior_prefix_comp : forall m1 m2 b,
    behavior_prefix m1 b ->
    behavior_prefix m2 b ->
    (trace_prefix m1 m2 \/ trace_prefix m2 m1).
Proof.
  intros m1 m2 b [beh1 H1] [beh2 H2].
  destruct b.

  destruct beh1; inversion H1;
  destruct beh2; inversion H2;
  inversion H1; inversion H2.
  assert (K1 : trace_prefix m1 t) by now exists t0.
  assert (K2 : trace_prefix m2 t) by now exists t1.
  apply (help K1 K2).

  destruct beh1; inversion H1.
  destruct beh2; inversion H2.
  assert (K1 : trace_prefix m1 t ) by now exists t0.
  assert (K2 : trace_prefix m2 t) by now exists t1.
  apply (help K1 K2).

  destruct beh1; inversion H1.
  destruct beh2; inversion H2.
  assert (K1 : traceinf_prefix m1 t) by now exists t0.
  assert (K2 : traceinf_prefix m2 t) by now exists t1.
  apply (help_inf K1 K2).

  destruct beh1; inversion H1.
  destruct beh2; inversion H2.
  assert (K1 : trace_prefix m1 t) by now exists t0.
  assert (K2 : trace_prefix m2 t) by now exists t1.
  apply (help K1 K2).
Qed.

Lemma behavior_prefix_comp' : forall m1 m2 b,
    prefix m1 b ->
    behavior_prefix m2 b ->
    (finpref_trace_prefix m1 m2 \/ trace_finpref_prefix m2 m1).
Proof.
  unfold prefix, finpref_trace_prefix, trace_finpref_prefix.
  intros m1 m2 b Hbp1 Hbp2.
  (* Destruct behaviors. *)
  destruct m1 as [m1'|m1'|m1'];
    destruct b as [b'|b'|b'|b'];
    (* Non-matching cases are discarded by a simple inversion. *)
    try (inversion Hbp1; fail);
    (* Matching cases are proved by the lemma on standard behaviors. *)
    try (apply (behavior_prefix_comp Hbp1 Hbp2));
    (* The remaining cases are trivial. *)
    subst m1'; destruct Hbp2 as [b'' Happ]; destruct b''; inversion Happ as [Hb'];
      right; now exists t.
Qed.

Lemma trace_behavior_prefix_trans : forall m1 m2 b,
    finpref_trace_prefix m1 m2 ->
    behavior_prefix m2 b ->
    prefix m1 b.
Proof.
  unfold finpref_trace_prefix, behavior_prefix, prefix.
  intros f m b Hf [b' Hb'].
  subst b.
  destruct f as [| | f].
  - inversion Hf.
  - inversion Hf.
  - unfold trace_prefix in Hf. destruct Hf as [t Ht]. subst m.
    exists (behavior_app t b'). now rewrite <- behavior_app_assoc.
Qed.

Lemma trace_behavior_prefix_trans' : forall m1 m2 b,
  trace_finpref_prefix m1 m2 ->
  prefix m2 b ->
  behavior_prefix m1 b.
Proof.
  unfold trace_finpref_prefix, prefix, behavior_prefix.
  intros t f b Hf Hfb.
  destruct f as [t1 | t1 | t1];
    destruct Hf as [t2 Ht2]; subst t1.
  - destruct b as [t3 | t3 | t3 | t3]; try (inversion Hfb; fail).
    + subst t3. exists (Terminates t2). reflexivity.
  - destruct b as [t3 | t3 | t3 | t3]; try (inversion Hfb; fail).
    + subst t3. exists (Goes_wrong t2). reflexivity.
  - destruct Hfb as [b1 Hb1]. subst b.
    exists (behavior_app t2 b1). now rewrite <- behavior_app_assoc.
Qed.

Lemma behavior_prefix_goes_wrong_trans : forall t1 t2 b,
  behavior_prefix t1 (Goes_wrong t2) ->
  behavior_prefix t2 b ->
  behavior_prefix t1 b.
Proof.
  unfold behavior_prefix.
  intros t1 t2 b [b1 Hprefix1] [b2 ?]; subst b.
  unfold behavior_app in Hprefix1.
  destruct b1; try (inversion Hprefix1).
  - subst t2. exists (behavior_app t b2). now rewrite <- behavior_app_assoc.
Qed.

Lemma behavior_prefix_improves_trans' : forall t b m,
  behavior_prefix m t ->
  behavior_improves t b ->
  behavior_prefix m b.
Proof.
  unfold behavior_prefix, behavior_improves.
  intros b1 b2 t1 [b3 Happb1] [Heqb1 | [t2 [Hwrongb1 [b4 Happb2]]]].
  - subst. eauto.
  - subst.
    unfold behavior_app in Hwrongb1. destruct b3; try (inversion Hwrongb1; fail).
    + inversion Hwrongb1 as [Heqt2].
      exists (behavior_app t b4). now rewrite <- behavior_app_assoc.
Qed.

Lemma behavior_prefix_app_inv : forall t1 t2 b,
  behavior_prefix (t1 ++ t2) b ->
  behavior_prefix t1 b.
Proof.
  intros t1 t2 ? [b ?]; subst.
  exists (behavior_app t2 b).
  rewrite behavior_app_assoc.
  reflexivity.
Qed.

Lemma program_behaves_finpref_exists :
  forall L s t s',
    initial_state L s ->
    Star L s t s' ->
  exists beh,
    program_behaves L beh /\
    prefix (FTbc t) beh.
Proof.
  intros L s t s' Hini HStar.
  destruct (state_behaves_exists L s') as [beh_s' Hbeh_s'].
  pose proof program_runs Hini (state_behaves_app HStar Hbeh_s') as Hbeh.
  eexists. split.
  - exact Hbeh.
  - simpl. exists beh_s'. reflexivity.
Qed.


(* LISTA DE EXERCÍCIOS 1
   =====================================
   ALUNOS:
      PAULO RENATO LANZARIN - 228818
      MARCOS HENRIQUE BACKES - 228483
      MATHEUS ROSA CASTANHEIRA - 228400
   =====================================
*)

(********************* BIBLIOTECAS DO COQ NECESSÁRIAS *******************)

(* Bibliotecas importadas *)
Require Import Arith ListSet MSets.

(* Infraestrutura para usar a biblioteca MSets de conjuntos *)
Module ModNat.
Definition t := nat.
Definition eq_dec :=  eq_nat_dec.
Definition lt := lt.
End ModNat.
Module ND  := Make_UDT(ModNat).
Module S   := MSetWeakList.Make ND.          (* NatSets *)
Module SP  := MSetProperties.WProperties S.  (* NatSet Properties *)
Module SF  := MSetFacts.WFacts S.            (* NatSet Facts *)
(*
   Operações para trabalhar com conjuntos de variáveis
   Nesse caso, usamos a biblioteca MSet de Coq
*)
Definition setNat    := S.t.
Definition emptySet  := S.empty.
Definition union     := S.union.
Definition remove    := S.remove.
Definition add       := S.add.
Definition member    := S.mem.
Definition In        := S.In.

(********************* SINTAXE DE TIPOS E TERMOS ***********************)

(* Definição indutiva dos termos de L0+FUN *)

(* Tipos da linguagem *)
Inductive type :=
 | tnat  : type
 | tbool : type
 | tfn   : type -> type -> type
.

(* Exemplos *)
Check tfn tnat tnat.                           (* nat -> nat *)
Check tfn (tfn tnat tnat) (tfn tbool tbool).   (* (nat->nat)->(bool->bool) *)

(*
  Termos da linguagem
  Nota: para representar parâmetros serão usados números naturais
  Exemplo: x = var 0
           y = var 1
           z = var 2
           ...
*)
Inductive term :=
 | zero   : term
 | succ   : term -> term
 | true   : term
 | false  : term
 | iszero : term -> term
 | pred   : term -> term
 | ifte   : term -> term -> term -> term
 | var    : nat -> term
 | fn     : nat -> type -> term -> term
 | app    : term -> term -> term
 | letx   : nat -> type -> term -> term -> term
 | letrec : nat -> type -> type -> nat -> term -> term -> term
.

(* Exemplo 1:

   (fn x:nat => succ succ x) (succ succ succ 0)

*)
Check app (fn 0 tnat
              (succ (succ (var 0))))
          (succ (succ (succ zero))).

(* Exemplo 2:

   (fn x:nat => fn y:bool => y)

*)
Check (fn 0 tnat
          (fn 1 tbool
              (var 1))).

(* Definição indutiva da propriedade de ser um número *)

Inductive nv : term -> Prop :=
 | zeroNum : nv zero
 | succNum : forall n, (nv n) -> (nv (succ n))
.

(* Definição indutiva de valor : números OU booleanos OU funções *)

Inductive value : term -> Prop :=
 | trueVal  : value true
 | falseVal : value false
 | numVal   : forall n, (nv n) -> (value n)
 | funVal   : forall x T t, value (fn x T t)
.

(*****************************************************************)

(* Definição de substituição {t/x}e - potencialmente com captura de variáveis livres *)
Fixpoint subs (t:term) (x:nat) (e:term) : term :=
 match e with
  | true     => true
  | false    => false
  | zero     => zero
  | succ u   => succ (subs t x u)
  | iszero u => iszero (subs t x u)
  | pred u   => pred (subs t x u)
  | ifte t1 t2 t3 => ifte (subs t x t1) (subs t x t2) (subs t x t3)
  | var y => if beq_nat x y
               then t
               else (var y)
  | app t1 t2 =>  app (subs t x t1) (subs t x t2)
  | fn y T body => if beq_nat x y
                     then fn y T body
                     else fn y T (subs t x body)
  | letx y T t1 t2 => if beq_nat x y
                        then letx y T (subs t x t1) t2
                        else letx y T (subs t x t1) (subs t x t2)
  | letrec f T1 T2 y t1 t2 => if beq_nat x f
				then letrec f T1 T2 y t1 t2
				else if beq_nat x y
			          then letrec f T1 T2 y t1 (subs t x t2)
				  else letrec f T1 T2 y (subs t x t1) (subs t x t2)
 end.

(* Exemplo de substituição - sem captura de variaveis livres *)
(*
   {succ 0/y} (x y)

   =  x (succ 0)
*)
Eval compute in subs (succ zero) 1
                     (app (var 0) (var 1)).

(* Exemplo de substituição - com captura de variaveis livres *)
(*
   {succ x/y} (fn x:bool => x y)

   =  (fn x:bool => x (succ x))
*)
Eval compute in subs (succ (var 0)) 1
                     (fn 0 tbool (app (var 0) (var 1))).

(* Definição da semântica operacional *)
Inductive step : term -> term -> Prop :=
 | e_iftrue     : forall t2 t3,        step (ifte true  t2 t3) t2
 | e_iffalse    : forall t2 t3,        step (ifte false t2 t3) t3
 | e_if         : forall t1 t2 t3 t1', (step t1 t1') -> step (ifte t1 t2 t3) (ifte t1' t2 t3)
 | e_succ       : forall t t',         step t t' -> step (succ t) (succ t')
 | e_predzero   :                      step (pred zero) zero
 | e_predsucc   : forall t,  (nv t) -> step (pred (succ t)) t
 | e_pred       : forall t t',         step t t' -> step (pred t) (pred t')
 | e_iszerozero :                      step (iszero zero) true
 | e_iszerosucc : forall t,  (nv t) -> step (iszero (succ t)) false
 | e_iszero     : forall t t',         step t t' -> step (iszero t) (iszero t')
 | e_app1       : forall t t' u,       step t t' -> step (app t u) (app t' u)
 | e_app2       : forall t t' v,       step t t' -> value v ->
                                                   step (app v t) (app v t')
 | e_beta       : forall t x T e,      step (app (fn x T e) t) (subs t x e)
 | e_let1       : forall x T v t2,     value v ->
                                            step (letx x T v t2) (subs v x t2)
 | e_let2       : forall x T t1 t1' t2, step t1 t1' ->
                                            step (letx x T t1 t2) (letx x T t1' t2)
 | e_letrec     : forall f T1 T2 y t1 t2, step (letrec f T1 T2 y t1 t2)
                                               (subs (fn y T1 (letrec f T1 T2 y t1 t1)) f t2)
.

(* Definição de forma normal *)
Definition NF (t:term) : Prop := forall t', not (step t t').

(* TODO NV É FORMA NORMAL *)
Theorem nvNF : forall (t:term), nv t -> NF t.
Proof.
intro. intro.
induction H. unfold NF. intros. intro. inversion H.
unfold NF. intros. intro. unfold NF in IHnv. inversion H0. subst.
assert (~ step n t'0). apply IHnv.
contradiction.
Qed.

(* TODO VALOR É FORMA NORMAL *)
Theorem valueNF : forall (t:term), value t -> NF t.
Proof.
intro. intro. induction H.
(* H=true *)     unfold NF. intro. unfold not. intro. inversion H.
(* H=false *)    unfold NF. intro. unfold not. intro. inversion H.
(* H=nv *)       apply nvNF. assumption.
(* H=fn x T e *) unfold NF. intros. intro. inversion H.
Qed.

(*****************************************************************)

(* Ambiente de tipos *)
Definition env  := list (nat*type).

(* Consulta a ambiente de tipos *)
Fixpoint   lookup (x:nat) (Gamma:env) : option type :=
 match Gamma with
  | nil               => None
  | cons (y,T) Gamma' => if beq_nat y x
                           then Some T
                           else lookup x Gamma'
 end.

(* Atualiza um ambiente de tipos *)
Fixpoint update (x:nat) (T:type) (Gamma:env) : env :=
 match Gamma with
   | nil                => cons (x,T) nil
   | cons (y,T') Gamma' => if beq_nat x y
                             then cons (x,T) Gamma'
                             else cons (y,T') (update x T Gamma')
 end.

(* Domínio de um ambiente = conjunto de variáveis definidas em um dado ambiente de tipos *)
Fixpoint domEnv (Gamma:env) : setNat :=
match Gamma with
  | nil               => emptySet
  | cons (x,T) Gamma' => add x (domEnv Gamma')
end.

(* Exemplos *)

(* Ambiente vazio *)
Check nil.

(* Ambiente com associações: Gamma = <epsilon>, x:nat, y:bool->bool *)
Check (cons (1,tfn tbool tbool)
         (cons (0,tnat)
              nil)).

(* Consulta ao ambiente: Gamma(x) *)
Eval compute in lookup 0
                  (cons (1,tfn tbool tbool)
                    (cons (0,tnat)
                       nil)).

(****************************************************)
(*           Propriedades de ambientes              *)
(****************************************************)

Lemma update_after_update : forall Gamma x T U, update x T (update x U Gamma) = update x T Gamma.
Proof.
intros.
induction Gamma.
  simpl. rewrite <- beq_nat_refl. reflexivity. subst.
  induction a.
    simpl.
    destruct (beq_nat x a) as []_eqn.
    simpl.
    rewrite <- beq_nat_refl.
    reflexivity.
  simpl. rewrite <- IHGamma. rewrite -> Heqb0. reflexivity.
Qed.

Lemma lookup_after_update : forall Gamma x T, lookup x (update x T Gamma) = Some T.
Proof.
intros.
 induction Gamma.
  simpl.
  rewrite <- beq_nat_refl.
  reflexivity.
  induction a.
   simpl.
   case_eq (beq_nat x a).
   intros.
   simpl.
   rewrite <- beq_nat_refl.
   reflexivity.
   intros.
   simpl.
   assert (beq_nat x a = beq_nat a x).
   rewrite -> H.
   symmetry.
   apply beq_nat_false in H.
   rewrite -> beq_nat_false_iff.
   intuition.
   rewrite -> H0 in H.
   rewrite -> H.
   rewrite -> IHGamma.
   reflexivity.
Qed.

(****************************************************)
(*                                                  *)
(****************************************************)

(* Função que calcula as variáveis livres de um termo - FV(t) *)
Fixpoint fv (t:term) : setNat :=
match t with
  | true          => emptySet
  | false         => emptySet
  | zero          => emptySet
  | succ t1       => fv t1
  | ifte t1 t2 t3 => (union (union (fv t1) (fv t2)) (fv t3))
  | pred t1       => fv t1
  | iszero t1     => fv t1
  | var x         => add x emptySet
  | fn x T body   => remove x (fv body)
  | app t1 t2     => union (fv t1) (fv t2)
  | letx x T t1 t2 => union (fv t1) (remove x (fv t2))
  | letrec f T1 T2 y t1 t2 => (remove f (union (remove y (fv t1)) (fv t2)))
end.

(* Testando o cálculo de variáveis livres

  FV( fn x:nat => x y )

  = { y }

*)
Eval compute in fv (fn 0 tnat (app (var 0) (var 1))).

(* Termos fechados são aqueles que não possuem variáveis livres *)
Definition closed (t:term) : Prop := S.Empty (fv t).

(* Sistema de tipos *)
Inductive hasType : env -> term -> type -> Prop :=
 | t_true       : forall Gamma, hasType Gamma true  tbool
 | t_false      : forall Gamma, hasType Gamma false tbool
 | t_zero       : forall Gamma, hasType Gamma zero  tnat
 | t_if         : forall Gamma t1 t2 t3 T, (hasType Gamma t1 tbool) ->
                                           (hasType Gamma t2 T) ->
                                           (hasType Gamma t3 T) ->
                                           hasType Gamma (ifte t1 t2 t3) T
 | t_succ       : forall Gamma t,  (hasType Gamma t tnat) -> (hasType Gamma (succ t) tnat)
 | t_pred       : forall Gamma t,  (hasType Gamma t tnat) -> (hasType Gamma (pred t) tnat)
 | t_iszero     : forall Gamma t,  (hasType Gamma t tnat) -> (hasType Gamma (iszero t) tbool)
 | t_var        : forall Gamma x T, lookup x Gamma = Some T -> (hasType Gamma (var x) T)
 | t_fun        : forall Gamma x T T' body, (hasType (update x T Gamma) body T') ->
                                            (hasType Gamma (fn x T body) (tfn T T'))
 | t_app        : forall Gamma f a T T', (hasType Gamma f (tfn T T')) ->
                                         (hasType Gamma a T) ->
                                         (hasType Gamma (app f a) T')
 | t_let        : forall Gamma x T T' t1 t2, hasType Gamma t1 T ->
                                             hasType (update x T Gamma) t2 T' ->
                                             hasType Gamma (letx x T t1 t2) T'
 | t_letrec     : forall Gamma f x T1 T2 T t1 t2, hasType (update f (tfn T1 T2) (update x T1 Gamma)) t1 T2 ->
                                                  hasType (update f (tfn T1 T2) Gamma) t2 T ->
                                                  hasType Gamma (letrec f T1 T2 x t1 t2) T
.

(**** Propriedades do sistema de tipos da linguagem ****)

Lemma bool_values : forall t, hasType nil t tbool -> value t -> t=true \/ t=false.
Proof.
intros t H.
inversion H.
(* true *)
left. reflexivity.
(* false *)
right. reflexivity.
(* ~ ifte *)
subst. intros. inversion H3. subst. inversion H4.
(* ~ iszero *)
subst. intros. inversion H1. subst. inversion H2.
(* ~ var *)
subst. intros. inversion H1. subst. inversion H2.
(* ~ app *)
subst. intros. inversion H2. subst. inversion H3.
(* ~ letx *)
subst. intros. inversion H2. subst. inversion H3.
(* ~ letrec *)
subst. intros. inversion H2. subst. inversion H3.
Qed.

Lemma nat_values : forall t, hasType nil t tnat -> value t -> t=zero \/ (exists t', t=succ t').
Proof.
intros t H.
inversion H.
(* zero *)
left. reflexivity.
(* ~ ifte *)
subst. intros. inversion H3. subst. inversion H4.
(* succ *)
right. subst. eauto.
(* pred *)
subst. intros. inversion H1. subst. inversion H2.
(* ~ var *)
subst. intros. inversion H1. subst. inversion H2.
(* ~ app *)
subst. intros. inversion H2. subst. inversion H3.
(* ~ letx *)
subst. intros. inversion H2. subst. inversion H3.
(* ~ letrec *)
subst. intros. inversion H2. subst. inversion H3.
Qed.

Theorem progresso : forall t T,
         hasType nil t T ->
           ((value t) \/ (exists t', step t t') ).
Proof.
intro.
induction t.
(* t=zero *)
intros.
left.
apply numVal.
apply zeroNum.
(* t=succ t1*)
intros.
inversion H. subst.
assert (value t \/ (exists t' : term, step t t')).
apply (IHt tnat). assumption.
elim H0.
  intros.
  inversion H1.
  subst.  inversion H2.
  subst.  inversion H2.
  subst. left. apply numVal. apply succNum. assumption.
  subst.
inversion H2.
intros.
right.
inversion H1.
apply ex_intro with (x:=succ x).
apply e_succ.
assumption.
(* t=true *)
intros. left. apply trueVal.
(* t=false *)
intros. left. apply falseVal.
(* t=iszero t1 *)
intros.
inversion_clear H.
assert (value t \/ (exists t' : term, step t t')).
apply (IHt tnat). assumption.
elim H.
intros.
right.
inversion H1. subst. inversion H0.
subst. inversion H0.
subst.
inversion H2.
subst.
apply ex_intro with (x:=true).
apply e_iszerozero.
subst.
apply ex_intro with (x:=false).
apply e_iszerosucc.
inversion H2. assumption.
subst.  inversion H0.
intros.
right.
inversion H1.
apply ex_intro with (x:=iszero x).
apply e_iszero.
assumption.
(* t=pred t1 *)
intros.
right.
inversion H. subst.
assert (value t \/ (exists t' : term, step t t')).
apply (IHt tnat). assumption.
elim H0.
intros.
inversion H1.
subst. inversion H2. subst. inversion H2.
subst.
inversion H3.
subst.
apply ex_intro with (x:=zero).
apply e_predzero.
subst.
apply ex_intro with (x:=n).
apply e_predsucc.
assumption.
subst.
inversion H2.
intros.
inversion H1.
apply ex_intro with (x:=pred x).
apply e_pred.
assumption.
(* t=ifte t1 t2 t3 *)
intros.
right.
inversion H.
subst.
assert (value t1 \/ (exists t' : term, step t1 t')).
apply (IHt1 tbool). assumption.
elim H0.
 intros.
apply bool_values in H4.
elim H4.
subst.
  intros. subst.
  apply ex_intro with (x:=t2).
  apply e_iftrue.
  intros. subst.
  apply ex_intro with (x:=t3).
  apply e_iffalse. assumption.
intros.
inversion H1.
apply ex_intro with (x:=ifte x t2 t3).
apply e_if. assumption.
(* t=var n *)
intros.
right.
inversion H.
subst.
inversion H2.
(* t=fn x T body *)
intros. left. apply funVal.
(* t=app t1 t2 *)
intros.
right.
inversion H.
subst.
assert (value t1 \/ (exists t' : term, step t1 t')).
apply (IHt1 (tfn T0 T)). assumption.
elim H0.
 intros.
 inversion H1.
 subst. inversion H3.
 subst. inversion H3.
 subst. inversion H2.
   subst. inversion H3.
   subst. inversion H3.
 subst. apply ex_intro with (x:=(subs t2 x t)). apply e_beta.
intros.
inversion H1.
apply ex_intro with (x:=app x t2).
apply e_app1. assumption.
(* t=letx n t1 t2 t3 *)
intros.
right.
inversion H.
subst.
assert (value t2 \/ (exists t' : term, step t2 t')).
apply (IHt1 t1). assumption.
elim H0.
 intros.
 inversion H1.
   (* t2 = true *)
   subst. inversion H6. subst.
   apply ex_intro with (x:=(subs true n t3)).
   apply e_let1. assumption.
   (* t2 = false *)
   subst. inversion H6. subst.
   apply ex_intro with (x:=(subs false n t3)).
   apply e_let1. assumption.
   (* t2 = nv *)
   subst. inversion H2.
     (* t2 = zero *)
     subst. inversion H6. subst.
     apply ex_intro with (x:=(subs zero n t3)).
     apply e_let1. assumption.
     (* t2 = succ n0 *)
     subst. inversion H6. subst.
     apply ex_intro with (x:=(subs (succ n0) n t3)).
     apply e_let1. assumption.
   (* t2 = fn x T t *)
   subst. inversion H6. subst.
   apply ex_intro with (x:=(subs (fn x T0 t) n t3)).
   apply e_let1. assumption.
intros.
inversion H1.
apply ex_intro with (x:=(letx n t1 x t3)).
apply e_let2. assumption.
(* t=letrec n t1 t2 n0 t3 t4 *)
intros.
right.
inversion H.
subst.
apply ex_intro with (x:=(subs (fn n0 t1 (letrec n t1 t2 n0 t3 t3)) n t4)).
apply e_letrec.
Qed.


From CoqMTL Require Export Control.Monad.

(** A monad which models computations that can fail. If a computation
    fails, any later computation that depends on it also fails, as
    exhibited by the law [bind_fail_l]. *)
Class MonadFail (M : Type -> Type) (inst : Monad M) : Type :=
{
  fail : forall {A :  Type}, M A;
  bind_fail_l :
    forall (A B : Type) (f : A -> M B),
      fail >>= f = fail;
}.

#[global] Hint Rewrite @bind_fail_l : CoqMTL.

Set Implicit Arguments.

Section MonadFailFuns.

Variables M : Type -> Type.
Variable instM : Monad M.
Variable instMF : MonadFail M instM.

(** We can "filter" a computation by running it and then wrapping
    values that satisfy the given boolean predicate in [pure] and
    turning the ones that don't into [fail]s. *)
Definition mfilter {A : Type} (p : A -> bool) (ma : M A) : M A :=
  ma >>= fun a : A => if p a then pure a else fail.

(** Using [mfilter], we can partition a computation into two computations
    that satisfy and don't satisfy a predicate [p], respectively. *)
Definition mpartition {A : Type} (p : A -> bool) (ma : M A) : M A * M A :=
  (mfilter p ma, mfilter (p .> negb) ma).

(** We can turn an optional value of type [A] into a computation by
    treating [Some] as success and [None] as failure. Thnaks to this,
    we can turn computations that return [option A] into ones that
    return just [A]. We can use this for mapping partial functions
    over our computations. *)

Definition fromOption {A : Type} (oa : option A) : M A :=
match oa with
| None => fail
| Some a => pure a
end.

Definition mcatOptions {A : Type} (x : M (option A)) : M A :=
  x >>= fromOption.

Definition mmapOption {A B : Type} (f : A -> option B) (x : M A) : M B :=
  mcatOptions (fmap f x).

(** Similarly, we can split a computation that returns a sum into two
    computations that return the left and right component of the sum. *)

Definition sum_left {A B : Type} (x : A + B) : option A :=
match x with
| inl a => Some a
| _ => None
end.

Definition sum_right {A B : Type} (x : A + B) : option B :=
match x with
| inr b => Some b
| _ => None
end.

Definition mlefts {A B : Type} (x : M (A + B)) : M A :=
  mcatOptions (fmap sum_left x).

Definition mrights {A B : Type} (x : M (A + B)) : M B :=
  mcatOptions (fmap sum_right x).

Definition mpartitionSums {A B : Type} (x : M (A + B)) : M A * M B :=
  (mlefts x, mrights x).

End MonadFailFuns.

Arguments mfilter {M instM instMF A} _ _.
Arguments mpartition {M instM instMF A} _ _.
Arguments mcatOptions {M instM instMF A} _.

(*
From CoqMTL Require Import Control.Monad.Trans.

#[refine]
#[export]
Instance MonadFail_MonadTrans
  (T : (Type -> Type) -> Type -> Type) (instT : MonadTrans T)
  (M : Type -> Type) (instM : Monad M) (instMF : MonadFail M instM)
  : MonadFail (T M) (is_monad _ instM) :=
{
  fail := fun A => lift (@fail M instM instMF A);
}.
Proof.
  intros. Print MonadTrans. rewrite <- lift_bind. rewrite lift_bind.
  rewrite lift_constrA, ask_ask. reflexivity.
Defined.
*)


Require Import A1_Plan A2_Orientation A7_Tactics .
Require Import B7_Tactics .
Require Import C1_Distance C7_Tactics .
Require Import F5_Tactics .
Require Import G1_Angles G3_ParticularAngle .
Require Import H1_Triangles .
Require Import I2_Supplement I3_OpposedAngles .
Require Import K3_Tactics .
Require Import L1_Parallelogramm L2_StrictParallelogramm.

Section PARALLELOGRAMM_ANGLES.

Lemma ParallelogrammDABeqBCD : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B ->
	B <> C ->
	CongruentAngle D A B B C D.
Proof.
	intros.
	assert (H4 := ParallelogrammTCongruentBCDDAB A B C D H).
	step10 H4.
	 apply (ParallelogrammDistinctABDistinctCD A B C D H H0).
	 apply sym_not_eq; apply (ParallelogrammDistinctBCDistinctDA A B C D H H1).
Qed.

Lemma StrictParallelogrammDABeqBCD : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	CongruentAngle D A B B C D.
Proof.
	intros; apply ParallelogrammDABeqBCD.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctAB A B C D H).
	 apply (StrictParallelogrammDistinctBC A B C D H).
Qed.

Lemma ParallelogrammABCeqCDA : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B ->
	B <> C ->
	CongruentAngle A B C C D A.
Proof.
	intros.
	assert (H4 := ParallelogrammTCongruentABCCDA A B C D H).
	step10 H4.
	 apply sym_not_eq; apply (ParallelogrammDistinctABDistinctCD A B C D H H0).
	 apply (ParallelogrammDistinctBCDistinctDA A B C D H H1).
Qed.

Lemma StrictParallelogrammABCeqCDA : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	CongruentAngle A B C C D A.
Proof.
	intros; apply ParallelogrammABCeqCDA.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctAB A B C D H).
	 apply (StrictParallelogrammDistinctBC A B C D H).
Qed.

Lemma ParallelogrammBACeqDCA : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B ->
	CongruentAngle B A C D C A.
Proof.
	intros; inversion H.
	assert (H3 := ParallelogrammTCongruentABCCDA A B C D H).
	step10 H3.
	apply (ParallelogrammDistinctABDistinctCD A B C D H H0).
Qed.

Lemma StrictParallelogrammBACeqDCA : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	CongruentAngle B A C D C A.
Proof.
	intros; apply ParallelogrammBACeqDCA.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctAB A B C D H).
Qed.

Lemma ParallelogrammDACeqBCA : forall A B C D : Point,
	Parallelogramm A B C D ->
	B <> C ->
	CongruentAngle D A C B C A.
Proof.
	intros; inversion H.
	assert (H3 := ParallelogrammTCongruentABCCDA A B C D H).
	step10 H3.
	apply sym_not_eq; apply (ParallelogrammDistinctBCDistinctDA A B C D H H0).
Qed.

Lemma StrictParallelogrammDACeqBCA : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	CongruentAngle D A C B C A.
Proof.
	intros; apply ParallelogrammDACeqBCA.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctBC A B C D H).
Qed.

Lemma ParallelogrammABDeqCDB : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B ->
	CongruentAngle A B D C D B.
Proof.
	intros; inversion H.
	assert (H3 := ParallelogrammTCongruentBCDDAB A B C D H).
	step10 H3.
	apply sym_not_eq; apply (ParallelogrammDistinctABDistinctCD A B C D H H0).
Qed.

Lemma StrictParallelogrammABDeqCDB : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	CongruentAngle A B D C D B.
Proof.
	intros; apply ParallelogrammABDeqCDB.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctAB A B C D H).
Qed.

Lemma ParallelogrammADBeqCBD : forall A B C D : Point,
	Parallelogramm A B C D ->
	B <> C ->
	CongruentAngle A D B C B D.
Proof.
	intros; inversion H.
	assert (H3 := ParallelogrammTCongruentBCDDAB A B C D H).
	step10 H3.
	apply (ParallelogrammDistinctBCDistinctDA A B C D H H0).
Qed.

Lemma StrictParallelogrammADBeqCBD : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	CongruentAngle A D B C B D.
Proof.
	intros; apply ParallelogrammADBeqCBD.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctBC A B C D H).
Qed.

Lemma StrictParallelogrammExteriorAngles : forall A B C D E : Point,
	StrictParallelogramm A B C D ->
	Between A B E ->
	CongruentAngle D A B C B E.
Proof.
	intros.
	since10 (Clockwise C D B).
	 step10 (StrictParallelogrammClockwiseBCD A B C D H).
	 pose (G := StrictPVertex4 C D B H1).
	   pose (H2 := StrictPVertex4Parallelogramm C D B H1); fold G in H2.
	   since10 (Between G B A).
	  apply (SumAngles B G C D A).
	   step10 (StrictParallelogrammClockwiseCDA C D B G H2).
	   immediate10.
	   step10 (StrictParallelogrammClockwiseDAB A B C D H).
	   step10 (StrictParallelogrammBACeqDCA C D B G H2).
	   step10 (StrictParallelogrammABDeqCDB A B C D H).
	  since10 (OpenRay B E G).
	   canonize1.
	     step10 H6.
	     step10 H5.
	   since10 (CongruentAngle C B E C B G).
	    step10 H5.
	      step10 (StrictParallelogrammDABeqBCD A B C D H).
	      step10 (StrictParallelogrammBACeqDCA C D B G H2).
Qed.

Lemma StrictParallelogrammAlternateAngles : forall A B C D E : Point,
	StrictParallelogramm A B C D ->
	Between C B E ->
	CongruentAngle D A B E B A.
Proof.
	intros.
	setSymmetricPoint5 A B ipattern:(G).
	 apply (StrictParallelogrammDistinctAB A B C D H).
	 since10 (OpposedAngles B E A C G).
	  since10 (CongruentAngle E B A C B G).
	   step10 H5.
	     apply CongruentAngleSym; apply (StrictParallelogrammExteriorAngles A B C D G H).
	    immediate10.
Qed.

Lemma ParallelogrammSegmentElongated : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> D ->
	Segment A B C ->
	ElongatedAngle D A B.
Proof.
	intros.
	since10 (Segment D C A).
	 usingChaslesRec2.
	   rewrite <- (ParallelogrammBCeqDA A B C D H).
	   rewrite (DistanceSym D C).
	   rewrite <- (ParallelogrammABeqCD A B C D H).
	   usingChasles2 A C B.
	 from10 H2 (Between D A B).
	    step10 H2.
	    inversion H; immediate10.
Qed.

Lemma BetweenBetweenElongated : forall A B C E : Point,
	Between A B E ->
	Between A C B ->
	ElongatedAngle C B E.
Proof.
	intros.
	from10 H (Between C B E).
Qed.

Lemma ParallelogrammSegmentElongated2 : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B ->
	Segment B C A ->
	ElongatedAngle D A B.
Proof.
	intros.
	from10 H1 (Between D A B).
	  since10 (Segment A D C).
	   usingChaslesRec2.
	     rewrite (DistanceSym A D).
	     rewrite <- (ParallelogrammBCeqDA A B C D H).
	     rewrite <- (ParallelogrammABeqCD A B C D H).
	     usingChasles2 B A C.
	  step10 H1.
	    inversion H; immediate10.
Qed.

Lemma BetweenBetweenElongated2 : forall A B C E : Point,
	Between A B E ->
	Between C A B ->
	ElongatedAngle C B E.
Proof.
	intros.
	from10 H (Between C B E).
Qed.

Lemma ParallelogrammSegmentNull3 : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B ->
	A <> D ->
	Segment C A B ->
	NullAngle D A B.
Proof.
	intros.
	since10 (OpenRay A B D).
	 since10 (OpenRay A B C).
	  step10 H3.
	    since10 (Segment A C D).
	   usingChaslesRec2.
	     rewrite (DistanceSym A D).
	     rewrite <- (ParallelogrammBCeqDA A B C D H).
	     rewrite (DistanceSym D C).
	     rewrite <- (ParallelogrammABeqCD A B C D H).
	     usingChasles2 A B C.
Qed.

Lemma BetweenBetweenNull3 : forall A B C E : Point,
	Between A B E ->
	Between C B A ->
	NullAngle C B E.
Proof.
	intros.
	since10 (OpenRay B C E).
	 canonize1.
	   step10 H2.
	   step10 H3.
Qed.

Lemma ParallelogrammColinearExteriorAngles : forall A B C D E : Point,
	Parallelogramm A B C D ->
	A <> D ->
	Between A B E ->
	Collinear A B C ->
	CongruentAngle D A B C B E.
Proof.
	intros.
	by3SegmentCases1 H2.
	 since10 (ElongatedAngle C B E).
	  apply (BetweenBetweenElongated A).
	   immediate10.
	   step10 H3.
	    inversion H; immediate10.
	    assert (H4 := ParallelogrammDistinctDADistinctBC A B C D H).
	      apply sym_not_eq; apply H4; immediate10.
	  step10 H4.
	    apply (ParallelogrammSegmentElongated A B C D); immediate10.
	 since10 (ElongatedAngle C B E).
	  apply (BetweenBetweenElongated2 A).
	   immediate10.
	   step10 H4.
	     inversion H; immediate10.
	  step10 H3.
	    apply (ParallelogrammSegmentElongated2 A B C D); immediate10.
	 since10 (NullAngle C B E).
	  apply (BetweenBetweenNull3 A).
	   immediate10.
	   step10 H4.
	     apply sym_not_eq; apply (ParallelogrammDistinctDADistinctBC A B C D H).
	     immediate10.
	  step10 H3.
	    apply (ParallelogrammSegmentNull3 A B C D); immediate10.
Qed.

Lemma ParallelogrammExteriorAngles : forall A B C D E : Point,
	Parallelogramm A B C D ->
	A <> D ->
	Between A B E ->
	CongruentAngle D A B C B E.
Proof.
	intros.
	by3Cases1 A B C.
	 pose (H3 := SPDef H H2).
	   apply (StrictParallelogrammExteriorAngles A B C D E H3).
	   immediate10.
	 since10 (Parallelogramm C B A D).
	  do 2 apply ParallelogrammPerm; apply ParallelogrammRev; immediate10.
	  since10 (Clockwise C B A).
	   pose (H5 := SPDef H2 H4).
	     since10 (CongruentAngle D C B E B C).
	    apply (StrictParallelogrammAlternateAngles C B A D E H5); immediate10.
	    step10 H6.
	      since10 (CongruentAngle D A B B C D).
	     apply (ParallelogrammDABeqBCD A B C D H); immediate10.
	 apply ParallelogrammColinearExteriorAngles; immediate10.
Qed.

Lemma ParallelogrammAlternateAngles : forall A B C D E : Point,
	Parallelogramm A B C D ->
	A <> B ->
	Between C B E ->
	CongruentAngle D A B E B A.
Proof.
	intros.
	since10 (CongruentAngle D A B B C D).
	 apply ParallelogrammDABeqBCD; immediate10.
	 step10 H2.
	   since10 (CongruentAngle D C B A B E).
	  apply ParallelogrammExteriorAngles.
	   apply ParallelogrammRev.
	     do 2 apply ParallelogrammPerm; immediate10.
	   apply (ParallelogrammDistinctABDistinctCD A B C D H H0).
	   immediate10.
Qed.

Lemma ParallelogrammDABSupplementAngleABC : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B  ->
	B <> C  ->
	Supplement D A B A B C.
Proof.
	intros.
	setSymmetricPoint5 A B ipattern:(G).
	since10 (CongruentAngle D A B C B G).
	 assert (H4 := sym_not_eq (ParallelogrammDistinctBCDistinctDA A B C D H H1)).
	   apply (ParallelogrammExteriorAngles A B C D G H H4 H3).
	 step10 H4.
Qed.

Lemma StrictParallelogrammDABSupplementAngleABC : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	Supplement D A B A B C.
Proof.
	intros; apply ParallelogrammDABSupplementAngleABC.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctAB A B C D H).
	 apply (StrictParallelogrammDistinctBC A B C D H).
Qed.

Lemma ParallelogrammABCSupplementAngleBCD : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B ->
	B <> C  ->
	Supplement A B C B C D.
Proof.
	intros.
	assert (H2 := ParallelogrammDABSupplementAngleABC A B C D H H0 H1).
	step10 H2.
	apply ParallelogrammDABeqBCD; immediate10.
Qed.

Lemma StrictParallelogrammABCSupplementAngleBCD : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	Supplement A B C B C D.
Proof.
	intros; apply ParallelogrammABCSupplementAngleBCD.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctAB A B C D H).
	 apply (StrictParallelogrammDistinctBC A B C D H).
Qed.

Lemma ParallelogrammBCDSupplementAngleCDA : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B  ->
	B <> C  ->
	Supplement B C D C D A.
Proof.
	intros.
	assert (H2 := ParallelogrammABCSupplementAngleBCD A B C D H H0 H1).
	step10 H2.
	apply ParallelogrammABCeqCDA; immediate10.
Qed.

Lemma StrictParallelogrammBCDSupplementAngleCDA : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	Supplement B C D C D A.
Proof.
	intros; apply ParallelogrammBCDSupplementAngleCDA.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctAB A B C D H).
	 apply (StrictParallelogrammDistinctBC A B C D H).
Qed.

Lemma ParallelogrammCDASupplementAngleDAB : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B  ->
	B <> C  ->
	Supplement C D A D A B.
Proof.
	intros.
	assert (H2 := ParallelogrammBCDSupplementAngleCDA A B C D H H0 H1).
	step10 H2.
	apply CongruentAngleSym; apply ParallelogrammDABeqBCD; immediate10.
Qed.

Lemma StrictParallelogrammCDASupplementAngleDAB : forall A B C D : Point,
	StrictParallelogramm A B C D ->
	Supplement C D A D A B.
Proof.
	intros; apply ParallelogrammCDASupplementAngleDAB.
	 destruct H; immediate10.
	 apply (StrictParallelogrammDistinctAB A B C D H).
	 apply (StrictParallelogrammDistinctBC A B C D H).
Qed.

Lemma CongruentAnglesParallelogramm : forall A B C D : Point,
	Clockwise A B C ->
	Clockwise C B D ->
	CongruentAngle A B C B C D ->
	Distance A B = Distance C D ->
	StrictParallelogramm A B D C.
Proof.
	intros.
	since10 (TCongruent (Tr A B C) (Tr D C B)).
	since10 (StrictParallelogramm C A B D).
	 apply EquiDistantStrictParallelogramm; immediate10.
	 apply StrictParallelogrammPerm; immediate10.
Qed.

Lemma SupplementParallelogramm : forall A B C D : Point,
	Clockwise A B C ->
	Clockwise B C D ->
	Supplement A B C B C D ->
	Distance A B = Distance C D ->
	StrictParallelogramm A B C D.
Proof.
	intros.
	setSymmetricPoint5 D C ipattern:(E).
	since10 (StrictParallelogramm A B E C).
	 apply CongruentAnglesParallelogramm.
	  immediate10.
	  step10 H5.
	  step10 H1.
	  immediate10.
	 since10 (TCongruent (Tr B E C) (Tr A C D)).
	  step10 3.
	   destruct H6 as (Hp, H7).
	     assert (H8 := ParallelogrammBCeqDA A B E C Hp); immediate10.
	   apply ParallelogrammExteriorAngles.
	    inversion H6.
	      do 2 apply ParallelogrammPerm; immediate10.
	    apply sym_not_eq; apply (StrictParallelogrammDistinctBC A B E C H6).
	    immediate10.
	  apply EquiDistantStrictParallelogramm.
	   immediate10.
	   step10 H5.
	     left; apply (StrictParallelogrammClockwiseCDA A B E C H6).
	   immediate10.
	   immediate10.
Qed.

End PARALLELOGRAMM_ANGLES.


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Export continuity.
Require Export per_props.

Definition of_type_int {o} lib (t : @NTerm o) :=
  {z : Z & reduces_to lib t (mk_integer z)}.

Definition of_type_int_to_val {o} lib (f : @NTerm o) :=
  forall a,
    of_type_int lib a
    -> {v : NTerm
        & reduces_to lib (mk_apply f a) v
        # isvalue_like v}.

Definition of_type_int_to_val_TO_int {o} lib (F : @NTerm o) :=
  forall f,
    of_type_int_to_val lib f
    -> {z : Z & reduces_to lib (mk_apply F f) (mk_integer z)}.

Definition continuous {o} lib (F : @NTerm o) :=
  forall f,
    of_type_int_to_val lib f
    -> {b : nat
        & forall g,
            of_type_int_to_val lib g
            -> (forall i : Z,
                  Z.abs_nat i < b
                  -> {v : NTerm (* (isvalue_like v)? *)
                      & reduces_to lib (mk_apply f (mk_integer i)) v
                      # reduces_to lib (mk_apply g (mk_integer i)) v})
            -> {z : Z
                & reduces_to lib (mk_apply F f) (mk_integer z)
                # reduces_to lib (mk_apply F g) (mk_integer z)}}.

Lemma of_type_int_force_int {o} :
  forall lib (t : @NTerm o),
    of_type_int lib t
    -> of_type_int lib (force_int t).
Proof.
  introv h.
  allunfold @of_type_int; exrepnd.
  exists z.
  unfold reduces_to in h0; exrepnd.
  revert dependent t.
  induction k; introv r.
  - allrw @reduces_in_atmost_k_steps_0; subst.
    exists 1.
    allrw @reduces_in_atmost_k_steps_S.
    exists (@mk_integer o z); dands; eauto with slow.
    + simpl.
      unfold compute_step_arith; simpl.
      rw <- Zplus_0_r_reverse; auto.
    + rw @reduces_in_atmost_k_steps_0; auto.
  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    apply IHk in r0; exrepnd.
    apply (reduces_to_trans _ _ (force_int u)); auto.
    apply reduces_to_prinarg; eauto with slow.
Qed.
Hint Resolve of_type_int_force_int : slow.

Lemma alpha_eq_preserves_isvalue_like {o} :
  forall (a b : @NTerm o),
    alpha_eq a b
    -> isvalue_like a
    -> isvalue_like b.
Proof.
  introv aeq iv.
  unfold isvalue_like in iv.
  dorn iv;[|dorn iv].
  - apply iscan_implies in iv; exrepnd; subst.
    inversion aeq; subst; left; sp.
  - apply isexc_implies2 in iv; exrepnd; subst.
    inversion aeq; subst; right; left; sp.
  - apply ismrk_implies2 in iv; exrepnd; subst.
    inversion aeq; subst; right; right; sp.
Qed.

Lemma add_force_int {o} :
  forall lib (F f : @NTerm o) x z,
    of_type_int_to_val_TO_int lib F
    -> of_type_int_to_val lib f
    -> !LIn x (free_vars f)
    -> reduces_to
         lib
         (mk_apply F f)
         (mk_integer z)
    -> reduces_to
         lib
         (mk_apply F (mk_lam x (mk_apply f (force_int (mk_var x)))))
         (mk_integer z).
Proof.
  introv tF tf ni r.

  pose proof (tF (mk_lam x (mk_apply f (force_int (mk_var x))))) as h.
  autodimp h hyp.

  { introv ta.
    pose proof (tf (force_int a)) as h; exrepnd.

    autodimp h hyp; eauto with slow.
    exrepnd.

    destruct (dec_disjointv (bound_vars f) (free_vars a)) as [d|d].

    - exists v; dands; auto.

      apply (reduces_to_if_split2
               _ _
               (mk_apply f (force_int a))); auto.

      simpl; unfold apply_bterm, lsubst; simpl.
      allrw app_nil_r; boolvar; tcsp.
      rw @lsubst_aux_trivial_cl_term; simpl; auto.
      rw disjoint_singleton_r; auto.

    - pose proof (change_bvars_alpha_spec f (free_vars a)) as h.
      simpl in h; repnd.
      remember (change_bvars_alpha (free_vars a) f) as f'.

      assert (alpha_eq (mk_apply f (force_int a)) (mk_apply f' (force_int a))) as aeq.

      { prove_alpha_eq4; introv p.
        destruct n;[|destruct n]; cpx.
        apply alphaeqbt_nilv2; auto. }

      pose proof (reduces_to_steps_alpha
                    lib
                    (mk_apply f (force_int a))
                    (mk_apply f' (force_int a))
                    v) as q.
      repeat (autodimp q hyp).
      exrepnd.

      pose proof (alpha_eq_preserves_isvalue_like v u) as iv.
      repeat (autodimp iv hyp).

      applydup @alphaeq_preserves_free_vars in h.

      SearchAbout alpha_eq free_vars.

      exists u.
      dands; auto.

      apply (reduces_to_if_split2
               _ _
               (mk_apply f' (force_int a))); auto.

      simpl; unfold apply_bterm, lsubst; simpl.
      allrw app_nil_r; boolvar; tcsp.
      unfold var_ren; simpl.
      rw @lsubst_aux_nil.
      rw <- Heqf'.
      rw @lsubst_aux_trivial_cl_term; simpl; auto.
      allrw <-.
      rw disjoint_singleton_r; auto. }

  exrepnd.
Qed.

(*

  F f -> z
  => (* by typing *)
  F (\x.f(x+0)) -> z
  => (* by comp_force_int_app_F *)
  exists b. forall e.
    F (\x.f(let v:=x in if |v|<b then v else e)) -> z
    => (* if e cannot get caught, because the 2 functions agree upto b *)
    F (\x.g(let v:=x in if |v|<b then v else e)) -> z
    => (* because the exception e is not raised, the term computes to z *)
    F (\x.g(x+0)) -> z
    => (* by typing *)
    F g -> z

*)
Lemma continuity_axiom {o} :
  forall lib (F : @NTerm o),
    of_type_int_to_val_TO_int lib F
    -> continuous lib F.
Proof.
  introv type_of_F type_of_f.
  pose proof (type_of_F f type_of_f) as h; exrepnd.

Qed.


Section ICK.

Set Implicit Arguments.
Require Import Unicode.Utf8.
Require Import Utf8_core.
Require Import List.
Require Import Program.Equality.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Finite_sets.
Require Import Coq.Sets.Powerset_facts.
Require Import Coq.Sets.Constructive_sets.
Require Import EnsembleFacts.

(*
 This is how we say  " { (f a) | a in x } "
 Taken from http://www.alumnos.unican.es/ccc66/coq/EnsembleFacts.v

Inductive apply_func (U1 U2:Type) (f:U1->U2) (S:Ensemble U1)
: Ensemble U2 :=
|In_apply_func: forall a:U1, In U1 S a->
  In U2 (apply_func f S) (f a).
*)
(***********************)

Lemma apply_func_rec : forall (U1 U2:Type) (f:U1->U2)
(S:Ensemble U1) (a:U2),
In U2 (apply_func U1 U2 f S) a ->
exists ia:U1, In U1 S ia /\ f ia=a.
intros.
inversion H.
exists a0.
split.
assumption.
tauto.
Qed.

(*
  f({}) = {} (Empty sets remain empty when we map them.)

Theorem  : forall (U1 U2:Type) (f:U1->U2)
(S:Ensemble U1),
 (apply_func U1 U2 f (Empty_set U1)) = Empty_set U2.
Proof.
intros.
apply Extensionality_Ensembles.
unfold Same_set.
split.
unfold Included.
intros.
inversion H.
inversion H0.
unfold Included.
intros.
inversion H.
Qed.
*)
(***********************)

(*
  Notice the added (E t) Term.
*)
Inductive Term : Set :=
  | bottom : Term
  | var : nat → Term
  | e : Term → Term
  | k1 :  Term → Term
  | k2 :  Term → Term
  | c : Term → Term
  | impl : Term → Term → Term
  | and : Term → Term → Term
  | or : Term → Term → Term.

(*
  Helper definition for sets of Terms.
*)
Definition Forms := Ensemble Term.

Definition Si (t : Term) : Forms := Singleton Term t.
Definition In_si (t : Term) : In Term (Si t) t := In_singleton Term t.
Definition EmptyE : Ensemble Term := Empty_set Term.
Definition Ut (u : Forms) (v : Forms) : Forms := Union Term u v.
Definition Compt (x : Forms) (f : Term -> Term) : Forms :=
  apply_func Term Term f x.
Notation "a ∈ X" := (In Term X a) (at level 19).
Notation "A ∪ B" := (Ut A B) (at level 17, left associativity).
Notation "⊥" := bottom.
Notation "{{ A | F }}" := (Compt A F) (at level 18).

Reserved Notation "A ⊃ B" (at level 16).
Inductive S : Forms -> Term -> Type :=
| AxiS :  ∀ Γ a,      (a ∈ Γ) → (Γ ⊃ a)
| AxbS :  ∀ Γ a,      (⊥ ∈ Γ) → (Γ ⊃ a)
| EFix1S : ∀ Γ a,    (Γ ∪ (Si (e a))) ⊃ (k1 a)
| EFix2S : ∀ Γ a,    (Γ ∪ (Si (e a))) ⊃ (k2 a)
| EFixRS: ∀ Γ a,      (Γ ⊃ (and (k1 a) (k2 a))) → (Γ ⊃ e a)
| EFixLS: ∀ Γ a b,    ((Γ ∪ (Si (k1 a)) ∪ (Si (k2 a))) ⊃ b) → ((Γ ∪ (Si (e a))) ⊃ b)
| CutS :  ∀ Γ a b,    (Γ ⊃ a) → ((Γ ∪ (Si a)) ⊃ b) → (Γ ⊃ b)
| OrLS :  ∀ Γ a b c,  ((Γ ∪ (Si a))  ⊃ c) → ((Γ ∪ (Si b))  ⊃ c) → ((Γ ∪ (Si (or a b)))  ⊃ c)
| OrR1S : ∀ Γ a b  ,  (Γ ⊃ a) → (Γ ⊃ (or a b))
| OrR2S : ∀ Γ a b  ,  (Γ ⊃ a) → (Γ ⊃ (or b a))
| AndLS : ∀ Γ a b c,  (((Γ ∪ (Si a)) ∪ (Si b)) ⊃ c) → ((Γ ∪ (Si (and a b)))  ⊃ c)
| AndRS : ∀ Γ a b  ,  (Γ ⊃ a) → (Γ ⊃ b) → (Γ ⊃ (and a b))
| ImplLS: ∀ Γ a b c,  (Γ ⊃ a) → ((Γ ∪ (Si b)) ⊃ c) → ((Γ ∪ (Si (impl a b))) ⊃ c)
| ImplRS: ∀ Γ a b  ,  ((Γ ∪ (Si a)) ⊃ b) → (Γ ⊃ (impl a b))
| K1S   : ∀ Γ Δ Θ a,(( Γ ∪ {{ Δ | (fun x => c x) }}) ⊃ a) →
   (( {{ Γ | (fun x => k1 x) }} ∪ ({{ Δ | (fun x => c x) }} ∪ Θ)) ⊃ (k1 a))
| K2S   : ∀ Γ Δ Θ a,(( Γ ∪ {{ Δ | (fun x => c x) }}) ⊃ a) →
   (( {{ Γ | (fun x => k1 x) }} ∪ ({{ Δ | (fun x => c x) }} ∪ Θ)) ⊃ (k2 a))
| CLS :   ∀ Γ a b  ,  (( Γ ∪ (Si (e a))) ⊃ b ) → ((Γ ∪ (Si (c a))) ⊃ b)
| CRS   : ∀ Γ Θ a  ,  ( {{ Γ | (fun x => c x) }} ⊃ (e a)) → (( {{ Γ | (fun x => c x) }} ∪ Θ) ⊃ (c a))
| IndS :  ∀ Γ Θ a b,  ((Ut (Compt Γ (fun x => c x)) (Si b)) ⊃ (e a)) →
    ( ({{ Γ | (fun x => c x)}}) ∪ (Si b)) ⊃ (e b) →
    (((( {{ Γ | (fun x => c x) }}) ∪ Θ) ∪ (Si b)) ⊃ (c a))
where "A ⊃ B" := (S A B).

Definition ttt (Γ : Forms) (a : Term) : Type := (Γ ⊃ k1 a).
Goal ttt (Si bottom) (e bottom).
intros.
unfold ttt. unfold Si. apply AxbS. auto with sets. Defined.

Definition In_ut (a : Term) (x : Forms) : In Term (Ut x (Si a)) a :=
  Union_intror Term x (Si a) a (In_si a).

Lemma em : forall (A : Type) (e : Ensemble A), Union A (Empty_set A) e = e.
Proof.
intros.
auto with sets.
Defined.

Ltac simpl_empty :=
  intros;
  unfold Compt; unfold "∪"; unfold EmptyE; unfold Si;
  try rewrite apply_func_empty_simple;
  try rewrite em; try rewrite em;
  try reflexivity;
  try   exact (Si bottom);
  try   exact (Si bottom); auto with *.

Ltac simpl_empty_in id :=
  unfold Compt in id; unfold "∪" in id; unfold EmptyE in id; unfold Si in id;
  try rewrite apply_func_empty_simple in id;
  try rewrite em in id; try rewrite em in id.

Lemma triv : forall (a : Term), (Si a) ⊃ a.
intros.
apply AxiS.
simpl_empty.
Defined.

Lemma bla : forall (a : Term) (Γ Δ : Forms) (p : Γ = Δ),
(Γ ⊃ a) = (Δ ⊃ a).
intros.
rewrite -> p .
reflexivity.
Defined.

Require Export EnsembleFacts.
Check apply_func.

Theorem apply_func_union_singletons : forall (U1 U2:Type)
(f:U1->U2) (a b: U1),
 (apply_func U1 U2 f (Union U1 (Singleton U1 a) (Singleton U1 b)))
  = Union U2
     (apply_func U1 U2 f (Singleton U1 a)) (apply_func U1 U2 f (Singleton U1 b)).
Proof.
intros U1 U2 f a b.
apply Extensionality_Ensembles.
unfold Same_set.
split.
unfold Included.
intros.
inversion H.
inversion H0.

rewrite -> (apply_func_singleton U1 U2 f b).
rewrite -> (apply_func_singleton U1 U2 f a).
inversion H2.
apply Union_introl.
auto with sets.
rewrite -> (apply_func_singleton U1 U2 f a).
rewrite -> (apply_func_singleton U1 U2 f b).
inversion H2.
apply Union_intror.
auto with sets.

unfold Included.
intros.
inversion H.
inversion H0.
inversion H2.
apply In_apply_func.
apply Union_introl.
exact (In_singleton U1 a0).
inversion H0.
inversion H2.
apply In_apply_func.
apply Union_intror.
exact (In_singleton U1 a0).
Defined.

Lemma simplify_stuff : (forall a b,(({{(Ut (Si a) (Si (impl a b))) | λ x : Term, k1 x}}) ∪ (({{EmptyE | λ x : Term, c x}}) ∪ EmptyE)) = (Si (k1 a) ∪ Si (k1 (impl a b)))).
Proof.
intros.
unfold Compt.
rewrite (apply_func_union_singletons  (λ x : Term, k1 x)).
apply Extensionality_Ensembles.
unfold Same_set.
split.
unfold Included.
intros.
unfold Si.
unfold "∪".
(* simplify H *)
unfold "∪" in H.
unfold EmptyE in H.
rewrite apply_func_empty_simple in H.
rewrite em in H.
rewrite (apply_func_singleton ) in H.
rewrite (apply_func_singleton ) in H.
rewrite (Union_commutative Term) in H.
rewrite (em (Union Term (Singleton Term (k1 a))
           (Singleton Term (k1 (impl a b))))) in H.
(* --- *)
assumption.
unfold Included.
simpl_empty.
rewrite apply_func_singleton. rewrite apply_func_singleton.
auto with sets.
Defined.

Lemma one : forall (a : Term), (Si a) ⊃ a.
Proof.
apply triv.
Defined.

Lemma two : forall (a b : Term),
  (Ut (Si (k1 a)) (Si (k1 (impl a b)))) ⊃ (k1 b).
Proof.
intros.
unfold "∪".
Check simplify_stuff.
rewrite <- simplify_stuff.
apply K1S.
simpl_empty.
assert ((Union Term (Union Term (Singleton Term a) (Singleton Term (impl a b)))
  (Empty_set Term)) = (Si a ∪ Si (impl a b))).
  simpl_empty.
  rewrite Union_commutative.
  simpl_empty.
rewrite  H.
apply ImplLS.
apply AxiS.
auto with *.
apply AxiS.
simpl_empty.
Defined.

Check less_than_empty.
Check Noone_in_empty.
Check Union_commutative.
Check Included_Empty.

Lemma simplify_stuff_three :  ({{EmptyE | λ x : Term, k1 x}}) ∪ (({{EmptyE | λ x : Term, c x}}) ∪ EmptyE) = EmptyE.
Proof.
simpl_empty.
simpl_empty.
Defined.

Lemma three : forall (a : Term),
  (EmptyE ⊃ a) -> (EmptyE ⊃ (and (k1 a) (c a))).
Proof.
intros.
apply (AndRS).
Check K1S.
rewrite <- (simplify_stuff_three).
apply (K1S).
simpl_empty.
assert ((({{EmptyE | λ x : Term, c x}}) ∪ EmptyE) = EmptyE).
  simpl_empty.
rewrite <- H.
apply CRS.
apply EFixRS.
apply AndRS.
simpl_empty.
assert ((({{EmptyE | λ x : Term, k1 x}}) ∪ (({{EmptyE | λ x : Term, c x}}) ∪ EmptyE)) = Empty_set Term).
simpl_empty.
rewrite <- H0.
apply K1S.
simpl_empty.
assert ((({{EmptyE | λ x : Term, k1 x}}) ∪ (({{EmptyE | λ x : Term, c x}}) ∪ EmptyE)) = ({{EmptyE | λ x : Term, c x}})).
simpl_empty. simpl_empty.
rewrite <- H0.
apply K2S.
simpl_empty.
Defined.

(*
End ICK.

Extraction Language Haskell.
Extraction Language Ocaml.
Set Extraction Optimize.
Recursive Extraction three.
*)

Lemma assoc_si : forall (a b c : Term), (((Si a) ∪ (Si b)) ∪ (Si c)) = ((Si a) ∪ ((Si b) ∪ (Si c))).
Proof.
intros.
apply Extensionality_Ensembles.
unfold Same_set.
split.
unfold Included.
intros.
inversion H. inversion H0.
apply Union_introl. assumption.
apply Union_intror. apply Union_introl. assumption.
apply Union_intror. apply Union_intror. assumption.
unfold Included.
intros.
inversion H.
apply Union_introl. apply Union_introl. assumption.
inversion H0.
apply Union_introl. apply Union_intror. assumption.
apply Union_intror. assumption.
Defined.

Lemma four : forall (a : Term), (Si (and (e a) (e (c a)))) ⊃ (c a).
Proof.
intros.
Check (IndS).
assert (forall b, (({{EmptyE | λ x : Term, c x}}) ∪ EmptyE ∪ Si b) = Si b).
  simpl_empty.
rewrite <- H.
apply IndS.
simpl_empty.
apply EFixRS.
intros.
(* assert (forall a, ((EmptyE ∪ (Si (and (e a) (e (c a))))) ⊃ e a) = (Si (and (e a) (e (c a))) ⊃ e a)). *)
assert (forall a, ((EmptyE ∪ (Si (and (e a) (e (c a))))) ⊃ and (k1 a) (k2 a)) = (Singleton Term (and (e a) (e (c a))) ⊃ and (k1 a) (k2 a))).
  simpl_empty.
rewrite <- H0.
apply AndLS.
Check EFixLS.
assert (((Si (e (c a))) ∪ Si (e a)) = (EmptyE ∪ Si (e a) ∪ Si (e (c a)))).
  simpl_empty. rewrite Union_commutative. reflexivity.
rewrite <- H1.
apply EFixLS.
apply AndRS.
apply AxiS. simpl_empty.
apply AxiS. simpl_empty.
(* end 1 *)
apply EFixRS.
apply AndRS.
apply AndLS.
apply EFixLS.
Check EFixLS.
assert ((({{EmptyE | λ x : Term, c x}}) ∪ Si (e a) ∪ Si (k1 (c a)) ∪ Si (k2 (c a))) =
((Si (k1 (c a)) ∪ Si (k2 (c a))) ∪ Si (e a))).
  simpl_empty.  rewrite Union_commutative.  rewrite Union_commutative.
rewrite assoc_si.
simpl_empty. rewrite Union_commutative. reflexivity.
rewrite H0.
assert ((({{(Si (c a)) | λ x : Term, k1 x}}) ∪ (({{EmptyE | λ x : Term, c x}}) ∪ ((Si (k2 (c a)) ∪ Si (e a))))) =
(Si (k1 (c a)) ∪ Si (k2 (c a)) ∪ Si (e a))).
simpl_empty. rewrite apply_func_singleton. rewrite assoc_si. simpl_empty.
rewrite <- H1.
apply K1S.

Check EFix1S.
assert (forall a, ((Si (e (c a))) ∪ Si (e a)) = (EmptyE ∪ Si (e a) ∪ Si (e (c a)))).
simpl_empty.  rewrite Union_commutative. reflexivity.
rewrite <- H1.
apply EFix1S.
assert (forall a, ((Si (e (c a))) ∪ Si (e a)) = (EmptyE ∪ Si (e a) ∪ Si (e (c a)))).
simpl_empty.  rewrite Union_commutative. reflexivity.
rewrite <- H1.
apply EFix2S.
apply EFixRS.
apply AndRS.
assert ((({{EmptyE | λ x : Term, k1 x}}) ∪ (({{EmptyE | λ x : Term, c x}}) ∪ (Si (and (e a) (e (c a)))))) = (({{EmptyE | λ x : Term, c x}}) ∪ Si (and (e a) (e (c a))))).
  simpl_empty.
rewrite <- H0.
apply K1S.
apply AxiS.
simpl_empty.
auto with sets.
assert ((({{EmptyE | λ x : Term, k1 x}}) ∪ (({{EmptyE | λ x : Term, c x}}) ∪ (EmptyE ∪ Si (e a) ∪ Si (e (c a))))) = (EmptyE ∪ Si (e a) ∪ Si (e (c a)))).
simpl_empty. simpl_empty.
rewrite <- H1.
apply K1S.
 EFix1
S.
assert ((EmptyE ∪ Si (e a) ∪ Si (e (c a))) = ( Si (e (c a)) ∪ Si (e a))).
  simpl_empty.
  rewrite Union_commutative.
  reflexivity.
rewrite -> H1.
apply EFixS.
simpl_empty.
apply EFixRS.
intros.
Check KiS.
assert ((Singleton Term (and (e a) (e (c a)))) = (EmptyE ∪ Si (and (e a) (e (c a))))).
  simpl_empty.
rewrite H0.
apply AndLS.
apply EFixLS.
intros.
assert ((({{Si ((c a)) | λ x : Term, k i0 x}}) ∪ (({{EmptyE | λ x : Term, c x}})
  ∪ (Si (e a))))
  = (EmptyE ∪ Si (e a) ∪ Si (k i0 (c a)))).
  simpl_empty.
  rewrite apply_func_singleton.
  rewrite Union_commutative.
  simpl_empty.
rewrite <- H1.
apply (KiS i0).
simpl_empty.
simpl_empty.
apply AxiS.
simpl_empty.
*)

(*
Lemma fife : forall (a : Term), (Si (c a)) ⊃ (and (e a) (c (e a))).
Proof.
intros.
(* AND right *)
apply AndRS.
assert (forall a, (Si (c a)) = (EmptyE ∪ Si (c a))).
  simpl_empty.
rewrite -> H.
(* C left *)
apply CLS.
(* ID Axiom *)
apply AxiS.
simpl_empty.
assert (forall a, (Si (c a)) = (({{EmptyE  | λ x : Term, c x}}) ∪ EmptyE ∪ Si (c a))).
  simpl_empty.
rewrite -> H.
(* C Induction *)
apply IndS.
simpl_empty.
(* E-Fix Right *)
apply EFixRS.
apply AndRS.
assert ((({{EmptyE | λ x : Term, k1 x}}) ∪ (({{(Si a) | λ x : Term, c x}}) ∪ EmptyE)) = (Singleton Term (c a))).
simpl_empty. rewrite apply_func_singleton.  rewrite Union_commutative. simpl_empty.
rewrite <- H0.
apply K1S.
apply EFixRS.
apply AndRS.
assert ((({{EmptyE | λ x : Term, k1 x}}) ∪ (({{(Si a) | λ x : Term, c x}}) ∪ EmptyE)) = (EmptyE ∪ ({{Si a | λ x : Term, c x}}))).
simpl_empty. rewrite apply_func_singleton.  rewrite Union_commutative. simpl_empty.
rewrite <- H1.
apply K1S.
simpl_empty.
rewrite apply_func_singleton.
assert ((EmptyE ∪ Si (c a)) = Singleton Term (c a)).
simpl_empty.
rewrite <- H2.
apply CLS.
apply EFixLS.
intro.
assert (forall i, ((({{EmptyE | λ x : Term, k i x}})
   ∪ (({{(Si a) | λ x : Term, c x}}) ∪ EmptyE)) = (Singleton Term (c a)))).
  simpl_empty.
  rewrite apply_func_singleton.
  rewrite Union_commutative.
  simpl_empty.
rewrite <- (H0 i).
(* K rule *)
apply KiS.
simpl_empty.    rewrite apply_func_singleton.
2: simpl_empty.
rewrite <- (H0 i).
(* E-Fix Left *)
apply EFixRS.
intros.
simpl_empty.
rewrite apply_func_singleton.
rewrite Union_commutative.
simpl_empty.
assert (forall i, (({{EmptyE | λ x : Term, k i x}})
   ∪ (({{(Si a) | λ x : Term, c x}}) ∪ EmptyE)) = (Singleton Term (c a))).
  simpl_empty.
  rewrite apply_func_singleton.
  rewrite Union_commutative.
  simpl_empty.
rewrite <- (H1 i0).
(* K rule *)
apply KiS.
simpl_empty.
rewrite apply_func_singleton.
assert (forall a, (EmptyE ∪ Si (c a)) = Singleton Term (c a)).
  simpl_empty.
rewrite <- H2.
(* C Left *)
apply CLS.
(* E-Fix Left *)
apply EFixLS.
intros.
simpl_empty.
(* C Induction *)
apply IndS.
rewrite (em Term).
eauto with sets.
*)

Lemma tlist_eq : forall (a b : Term), a ∈ Si b -> (Si a) = (Si b).
intros.
inversion H.
reflexivity.
Defined.

Lemma six : forall (a b : Term),
  ((Si b) ⊃ (and (e a) (e (c b)))) -> ((Si b) ⊃ (c a)).
Proof.
intros x y H.
assert (Si y = (({{EmptyE | λ x : Term, c x}}) ∪ EmptyE ∪ Si y)).
  simpl_empty.
rewrite H0.
apply IndS.
apply AndRS with (b:=(e (c y))) in H .
dependent induction y.
apply AxbS.
auto with *.
assert (Si (var n) = (({{EmptyE | λ x : Term, c x}}) ∪ EmptyE ∪ Si (var n))).
  simpl_empty.
rewrite H0.
apply IndS.
apply EFixRS.

inversion H.
inversion H0.
Check IndS.
assert ((({{EmptyE | λ x : Term, c x}}) ∪ EmptyE ∪ Si y) = (Si y)).
simpl_empty.
assert ((EmptyE ∪ Si (and (e x) (e (c y)))) = Si (and (e x) (e (c y)))).
simpl_empty.
rewrite <- H5.
apply AndLS.
assert ((({{EmptyE | λ x : Term, c x}}) ∪ Si (e (c y)) ∪ (Si (e x))) = (EmptyE ∪ Si (e x) ∪ Si (e (c y)))).
  simpl_empty. simpl_empty.
  rewrite Union_commutative. reflexivity.
rewrite <- H6.
apply IndS.
apply AxiS.
simpl_empty.
(*rewrite <- H4.*)
apply EFixRS. apply AndRS. apply EFixLS.
assert ((({{(Si x) | λ x : Term, k1 x}}) ∪ (({{EmptyE | λ x : Term, c x}}) ∪ (Si (k2 x)))) = (({{EmptyE | λ x : Term, c x}}) ∪ Si (k1 x) ∪ Si (k2 x))).
  simpl_empty.  rewrite apply_func_singleton.  simpl_empty.
rewrite <- H7.
apply K1S.
apply EFixRS.
apply AndRS.
(*assert ((({{EmptyE | λ x : Term, c x}}) ∪ EmptyE ∪ Si (e x)) = (({{EmptyE | λ x0 : Term, c x0}}) ∪ Si (e x))).
  simpl_empty.
  rewrite <- H8.*)
apply IndS.
inversion H0.
rewrite H4.
apply AndLS.
apply AxiS.
simpl_empty.

apply EFixRS.
apply AndRS.
inversion H.
assert ((({{EmptyE | λ x : Term, c x}}) ∪ Si y) = Si y).
simpl_empty.
rewrite H1.
2:assert ((({{EmptyE | λ x : Term, c x}}) ∪ Si y) = Si y).
2:simpl_empty.
2: rewrite H1.
inversion H.
Check AndRS.
apply AndRS in H.

apply Extensionality_Ensembles.
unfold Same_set.
split.
unfold Included.
intros.
assert ( and (e x) (e (c x)) ∈ Si y).
unfold Si.
unfold Si in H.
exact H2.

Check AndRS.
simpl_empty.
assert (Included Term (EmptyE ∪ Si (and (e x) (e (c x)))) (Si y) = (and (e x) (e (c x)) ∈ Si y)).
simpl_empty.
rewrite H2.
unfold Included.

simpl_empty.

apply AndLS.

Check CRS.
assert ((({{EmptyE | λ x : Term, c x}}) ∪ (Si b)) = Si b).
simpl_empty.
rewrite <- H0.
apply CRS.
inversion H.
*)


Require Import String.

Import List.
Import ListNotations.

Inductive Flood_Action : Set :=
| Flood_Input   : nat -> (string * nat) -> Flood_Action
| Flood_Leak    : nat -> (string * nat) -> Flood_Action
| Flood_Deliver : nat -> nat -> (string * nat) -> Flood_Action
| Flood_Output  : nat -> nat -> (string * nat) -> Flood_Action.

Definition Flood_Trace : Type := list Flood_Action.

Definition flood_safety (t: Flood_Trace) : Prop :=
  forall i j m c t2,
  nth_error t t2 = Some (Flood_Output i j (m, c)) ->
  exists t1, t1 < t2 /\ nth_error t t1 = Some (Flood_Input i (m, c)).

(* n = number of parties *)
Definition flood_liveness (t: Flood_Trace) (n: nat) : Prop :=
  forall i m c t1,
  nth_error t t1 = Some (Flood_Input i (m, c)) ->
  (forall j, j < n -> exists t2, t1 < t2 /\ nth_error t t2 = Some (Flood_Output i j (m, c))).


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_upp_bot_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_upp x1 L1 T1') ->
                  subtype T1 t_bot = subtype T1' t_bot.
Proof.
  intros.

  remember (subtype T1 t_bot) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


(* The classic construction of an oblivious transfer protocol from a hard-core predicate, due to GMW. We assume the receiver is semi-honest. *)

Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Permutation Typ Lib.SeqOps.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Ipdl.Tacs Lib.Dist Lib.Base Pars.
Require Import HCBit OTIdeal Ipdl.Approx.

Open Scope bool_scope.
Module TrapdoorOT (P : HCBit).
  Module HCBitPair := HCBitPair(P).
  Import HCBitPair.

  Section TrapdoorOT.
  Context {chan : Type -> Type}.
  (* OT channels *)
  Context (i : chan bool).
  Context (m : chan (bool * bool)).
  Context (o : chan bool).

  (* Leakage channels for receiver *)
  Context (leaky0 leaky1 : chan D.-bv).
  Context (leakEK : chan ek.-bv).
  Context (leakd01 : chan (bool * bool)).

  Definition TD_Snd (uv : chan (D.-bv * D.-bv)) (c_ek : chan ek.-bv) (d01 : chan (bool * bool)) :=
    c_tk <- new tk.-bv ;;
     pars [::
       c_tk ::= (Samp sampK);
       c_ek ::= (x <-- Read c_tk ;; Ret (evalKey x));
       d01 ::= (
        m01 <-- Read m;;
        uv <-- Read uv;;
        tk <-- Read c_tk ;;
        Ret (
            let '(m0, m1) := m01 in
            let '(u, v) := uv in
            let c0 := B (evalInv tk u) in
            let c1 := B (evalInv tk v) in
            (m0 (+) c0, m1 (+) c1)) ) ].

  Definition TD_Rcv (uv : chan (D.-bv * D.-bv)) (c_ek : chan ek.-bv) (d01 : chan (bool * bool)) :=
    y0 <- new D.-bv ;;
    y1 <- new D.-bv ;;
           pars [::
                leakEK ::= (copy c_ek);
                y0 ::= (Samp Unif);
                leaky0 ::= (copy y0);
                y1 ::= (Samp Unif);
                leaky1 ::= (copy y1);
                uv ::= (
                      i <-- Read i ;;
                      ek <-- Read c_ek ;;
                      x0 <-- Read y0 ;;
                      x1 <-- Read y1 ;;
                      Ret (if i then ( x0, eval ek x1 ) else (eval ek x0, x1) ) );
                leakd01 ::= (copy d01);
                o ::= (
                      i <-- Read i ;;
                      d01 <-- Read d01 ;;
                      x0 <-- Read y0 ;;
                      x1 <-- Read y1 ;;
                      Ret ((d01 # i) (+) B ((x0, x1) # i) : bool))
                    ].

  Definition OT_trapdoor :=
    uv <- new _ ;;
    c_ek <- new _ ;;
    d01 <- new _ ;;
    pars [:: TD_Snd uv c_ek d01;
            TD_Rcv uv c_ek d01].

  (*+ Begin proof +*)

  Definition OT_trapdoor_simp_r :=
c <- new ek.-bv;;
c0 <- new tk.-bv;;
c1 <- new D.-bv;;
c2 <- new D.-bv;;
c3 <- new D.-bv;;
c4 <- new D.-bv;;
[pars [:: leakd01 ::=
            (x <-- Read c0;;
             x0 <-- Read c3;;
             x1 <-- Read c4;;
             i0 <-- Read i;;
             m0 <-- Read m;;
             (if i0
              then
                Ret (
                    let '(m1, m2) := m0 in
                    (
                        m1 (+) B x0 : bool,
                        m2 (+) B (eval (evalKey x) x1) : bool
                  ))
              else
                Ret (
                    let '(m1, m2) := m0 in
                    (
                        m1 (+) B (eval (evalKey x) x0) : bool,
                        m2 (+) B x1 : bool
                  ) )
            ) );
          c ::= (x <-- Read c0;; Ret (evalKey x)); Out c0 (Samp sampK);
          c3 ::= (Samp Unif);
          c2 ::= (x <-- Read c4;; x0 <-- Read c0;; Ret (eval (evalKey x0) x));
          c4 ::= (Samp Unif);
          leakEK ::= (copy c);
         leaky0 ::= (copy c1); Out leaky1 (copy c2);
          c1 ::= (x <-- Read c3;; x0 <-- Read c0;; Ret (eval (evalKey x0) x))] ].

  Definition OT_trapdoor_simp :=
Out o (x <-- Read i;; m0 <-- Read m;; Ret (m0 # x : bool))
    ||| OT_trapdoor_simp_r.

  Lemma OT_trapdoor_simpE : OT_trapdoor =p OT_trapdoor_simp.
    rewrite /OT_trapdoor.
    rewrite /TD_Snd.
    setoid_rewrite newPars.
    setoid_rewrite pars_pars.
    rewrite //=.
    rewrite /TD_Rcv.
    swap_tac 0 3.
    setoid_rewrite newPars.
    setoid_rewrite newPars.
    setoid_rewrite pars_pars.
    simpl.
    etransitivity.
    repeat ltac:(apply EqCongNew; intro).
    swap_in (Out o) 0 1.
    inline_tac (Out o) (Out c1).
    simp_tac (Out o).

    swap_in (Out o) 0 1.
    inline_tac (Out o) (Out c).
    simp_tac (Out o).

    swap_in (Out o) 0 1.
    inline_tac (Out o) (Out c0).
    simp_tac (Out o).

    edit_tac 0.

    {
        r_swap 1 5.
        rewrite EqReadSame; apply EqBind_r => tk.
        r_swap 1 4.
        rewrite EqReadSame; apply EqBind_r => i'.
        r_swap 1 3.
        rewrite EqReadSame; apply EqBind_r => y.
        r_swap 1 2.
        rewrite EqReadSame; apply EqBind_r => x.
        apply EqBind_r => m'.
        instantiate (1 := fun m' => Ret (m' # i' : bool)).
        destruct m'; destruct i'; rewrite //= eval_cancel addbK //=.
    }

    (* Undep o *)
    swap_tac 0 (Out o).
    swap_tac 1 (Out c2).
    rewrite -pars_mkdep //=.
    swap_in (Out o) 0 1.
    swap_tac 1 (Out c3).
    rewrite -pars_mkdep //=.
    swap_in (Out o) 0 1.
    swap_tac 1 (Out c4).
    rewrite -pars_mkdep //=.

    apply EqRefl.
    (* Move down c1 *)
    simpl.
    setoid_rewrite (EqNewExch (bool * bool) tk.-bv).
    setoid_rewrite (EqNewExch (bool * bool) D.-bv).
    setoid_rewrite (EqNewExch (bool * bool) D.-bv).

    swap_tac 6 0.
    swap_tac 1 5.
    setoid_rewrite pars_fold.

    etransitivity.
    repeat ltac:(apply EqCongNew; intros).
    simp_tac (Out leakd01).
    swap_at 0 0 1.
    apply EqRefl.

    setoid_rewrite (EqNewExch (D.-bv * D.-bv) ek.-bv).
    setoid_rewrite (EqNewExch (D.-bv * D.-bv) tk.-bv).
    setoid_rewrite (EqNewExch (D.-bv * D.-bv) D.-bv).
    setoid_rewrite (EqNewExch (D.-bv * D.-bv) D.-bv).
    swap_tac 1 7.
    setoid_rewrite pars_fold.

    etransitivity.
    repeat ltac:(apply EqCongNew; intros).
    simp_tac (Out leakd01).
    apply EqRefl.

    (* Now pull out o *)
    simpl.
    swap_tac 0 4.
    setoid_rewrite new_pars_pull; last by apply _.
    setoid_rewrite <- newComp_r; last by apply _.
    setoid_rewrite <- newComp_r; last by apply _.
    setoid_rewrite <- newComp_r; last by apply _.

    (* Now map the c's through the permutation, simplify leakd01 *)
    apply EqCong.
    done.
    etransitivity.
    apply EqCongNew => ek .
    apply EqCongNew => tk .

    (* Make the samps depend on tk *)
    swap_tac 1 6.
    apply EqCongNew; intro.
    apply EqCongNew; intro.
    rewrite pars_mkdep //=.
    edit_tac 0.
    apply EqBind_r; intro.
    apply (EqSampBijection _ (eval (evalKey x))).
    eapply can_inj.
    apply eval_cancel.
    apply uniform_Unif.
    swap_at 0 0 1.
    rewrite -pars_fold.

    swap_tac 0 3.
    swap_tac 1 2.
    apply EqCongNew; intro;
    rewrite pars_mkdep //=.
    edit_tac 0.
    apply EqBind_r; intro.
    apply (EqSampBijection _ (eval (evalKey x))).
    eapply can_inj.
    apply eval_cancel.
    apply uniform_Unif.
    swap_at 0 0 1.
    rewrite -pars_fold.
    apply EqCongNew; intro.

    swap_at 5 0 3.
    swap_at 5 1 3.
    apply EqRefl.

    (* Now inline the postcomputations *)
    etransitivity.
    repeat ltac:(apply EqCongNew; intro).
    inline_tac (Out leakd01) (Out c2).
    simp_tac leakd01.
    swap_at 0 0 2.
    inline_tac (Out leakd01) (Out c1).
    simp_tac leakd01.
    swap_at 0 0 5.
    inline_tac (Out leakd01) (Out c).
    simp_tac leakd01.

    edit_tac 0.
    r_swap 1 2.
    rewrite EqReadSame.
    r_swap 1 3.
    rewrite EqReadSame.
    r_swap 1 5.
    rewrite EqReadSame.
    apply EqBind_r; intros.
    apply EqBind_r; intros.
    apply EqBind_r; intros.
    apply EqBind_r; intro i'.
    apply EqBind_r; intros m'.
    apply EqRxnRefl.
    apply EqRefl.
    repeat ltac:(apply EqCongNew; intro).
    apply pars_cons_cong.
    apply EqCongReact.
    repeat ltac:(apply EqBind_r; intro).
    destruct x3.
    destruct x2.
    simpl.
    rewrite !eval_cancel //=.
    rewrite //=.
    rewrite !eval_cancel //=.
    rewrite //=.
    apply _.
    apply _.
    apply _.
 Qed.

Definition OT_trapdoor_HCBitPairSim c_ek y1 y2 (b1 b2 : chan bool) :=
                  pars [::
                     Out leaky0 (copy y1);
                     Out leaky1 (copy y2);
                     Out leakEK (copy c_ek);
                       Out leakd01 (
                             ek <-- Read c_ek ;;
                             y1 <-- Read y1 ;;
                             y2 <-- Read y2 ;;
                             i <-- Read i ;;
                             m <-- Read m ;;
                             b1 <-- Read b1 ;;
                             b2 <-- Read b2 ;;
                             Ret (
                                 let '(m1, m2) := m in
                                 if i then
                                   ( m1 (+) b1 : bool,
                                           m2 (+) (B y2) : bool )
                                 else
                                   (
                                       m1 (+) B y1 : bool,
                                       m2 (+) b2 : bool
                                                     ) ) ) ].

Lemma OT_trapdoor_simp_rE :
  OT_trapdoor_simp_r =p
                        withHCBitPairReal OT_trapdoor_HCBitPairSim.
  rewrite /withHCBitPairReal /OT_trapdoor_HCBitPairSim.
  rewrite /OT_trapdoor_simp_r.
  apply EqCongNew => ek.
  symmetry.
  rewrite /HCBitPairReal.
  setoid_rewrite newPars.
  setoid_rewrite newPars.
  setoid_rewrite newPars.
  setoid_rewrite pars_pars.
  simpl.
  swap_tac 0 8.
  setoid_rewrite pars_pars.
  simpl.
  rewrite (EqNewExch tk.-bv D.-bv).
  apply EqCongNew => y1 .
  rewrite (EqNewExch tk.-bv D.-bv).
  apply EqCongNew => y2 .
  setoid_rewrite (EqNewExch bool tk.-bv).
  setoid_rewrite (EqNewExch bool tk.-bv).
  apply EqCongNew => tk .
  setoid_rewrite (EqNewExch bool D.-bv).
  setoid_rewrite (EqNewExch bool D.-bv).
  apply EqCongNew => w1 .
  setoid_rewrite (EqNewExch bool D.-bv).
  setoid_rewrite (EqNewExch bool D.-bv).
  apply EqCongNew => w2 .

  (* fold in the b's *)
  etransitivity.
  apply EqCongNew; intro.
  apply EqCongNew; intro.
  swap_at 3 0 6.
  apply EqRefl.

  simpl.
  swap_tac 0 3.
  swap_tac 1 10.
  setoid_rewrite pars_fold.
  etransitivity.
  apply EqCongNew; intro.
  simp_tac leakd01.
  swap_at 0 0 6.
  apply EqRefl.

  swap_tac 1 8.
  setoid_rewrite pars_fold.
  simp_tac leakd01.
  swap_at 0 0 2.
  inline_tac leakd01 (Out ek).
  simp_tac leakd01.

  swap_at 0 0 3.
  inline_tac leakd01 (Out y1).
  simp_tac leakd01.

  swap_at 0 0 5.
  inline_tac leakd01 (Out y2).
  simp_tac leakd01.

  swap_at 0 1 2.
  rewrite EqReadSame.
  swap_at 0 0 5.
  swap_at 0 1 2.
  rewrite EqReadSame.
  swap_at 0 0 2.
  swap_at 0 1 4.
  rewrite EqReadSame.

  swap_at 0 0 2.
  inline_tac leakd01 (Out ek).
  simp_tac leakd01.
  swap_at 0 1 3.
  rewrite EqReadSame.
  apply pars_cons_cong.
  apply EqCongReact.
  repeat ltac:(apply EqBind_r; intros).
  destruct x3; destruct x2; done.

  inline_tac (Out y2) (Out ek).
  simp_tac y2.
  inline_tac (Out y1) (Out ek).
  simp_tac y1.

  align.
  apply EqCongReact; r_swap 0 1; done.
  apply EqCongReact; r_swap 0 1; done.
  apply _.
  apply _.
  apply _.
Qed.

Definition OT_trapdoor_OTSim (leakO : chan bool) :=
  withHCBitPairIdeal (fun c_ek y1 y2 b1 b2 =>
                  pars [::
                     Out leaky0 (copy y1);
                     Out leaky1 (copy y2);
                     Out leakEK (copy c_ek);
                       Out leakd01 (
                             ek <-- Read c_ek ;;
                             y1 <-- Read y1 ;;
                             y2 <-- Read y2 ;;
                             i <-- Read i ;;
                             o <-- Read leakO ;;
                             b1 <-- Read b1 ;;
                             b2 <-- Read b2 ;;
                             Ret (
                                 if i then
                                   (
                                       b1 : bool,
                                       o (+) B y2 : bool
                                   )
                                 else
                                  (
                                       o (+) B y1 : bool,
                                                    b2
                                                      ) )) ]).

Lemma OT_trapdoor_OTSimE :
  withHCBitPairIdeal OT_trapdoor_HCBitPairSim =p (leakO <- new bool ;; OT_trapdoor_OTSim leakO ||| OTIdeal _ i m leakO).
  symmetry.
  (* First, fold in the leakO *)

  rewrite /OT_trapdoor_OTSim.
  rewrite /withHCBitPairIdeal.
  rewrite /OTIdeal.
  repeat setoid_rewrite EqCompNew.
  setoid_rewrite pars_rcons; simpl.
  swap_tac 0 1.
  setoid_rewrite pars_pars; simpl.

  setoid_rewrite (EqNewExch bool ek.-bv).
  setoid_rewrite (EqNewExch bool D.-bv).
  setoid_rewrite (EqNewExch bool D.-bv).
  setoid_rewrite (EqNewExch bool bool) at 1.
  setoid_rewrite (EqNewExch bool bool) at 2.
  etransitivity.
  repeat ltac:(apply EqCongNew; intro).
  swap_tac 0 3.
  swap_at 0 0 4.
  apply EqRefl.
  simpl.
  swap_tac 1 5.
  setoid_rewrite pars_fold.
  (* Now fold in the flips *)
  etransitivity.
  repeat ltac:(apply EqCongNew; intro).
  simp_tac leakd01.
  rewrite /HCBitPairIdeal.
  swap_tac 0 3.
  rewrite pars_pars; simpl.
  swap_at 7 0 7.
  swap_at 7 1 7.
  apply EqRefl.
  simpl.
  swap_tac 0 7.
  swap_tac 1 4.
  setoid_rewrite pars_fold.
  swap_tac 1 2.

  under_new swap_at 0 0 1.
  simpl.
  setoid_rewrite pars_fold.
  symmetry.

  rewrite /OT_trapdoor_HCBitPairSim.
  swap_tac 0 5.
  setoid_rewrite par_in_pars.
  setoid_rewrite pars_pars; simpl.
  swap_tac 0 3.
  under_new swap_at 0 0 6.
  simpl.
  swap_tac 1 8.
  setoid_rewrite pars_fold.
  under_new swap_at 0 0 6.
  simpl.
  swap_tac 1 6.
  setoid_rewrite pars_fold.
  apply EqCongNew; intro.
  apply EqCongNew; intro.
  apply EqCongNew; intro.
  apply pars_cons_cong.
  apply EqCongReact.
  r_swap 0 5.
  r_swap 1 3.
  r_swap 2 5.
  r_swap 3 6.
  r_swap 4 6.
  symmetry.
  r_swap 0 2.
  r_swap 1 7.
  rewrite EqReadSame.
  apply EqBind_r; intros.
  r_swap 0 3.
  apply EqBind_r; intros.
  r_swap 0 4.
  apply EqBind_r; intros.
  r_swap 0 2.
  apply EqBind_r; intros.
  r_swap 0 2.
  apply EqBind_r; intros.
  destruct x2; simpl.
  destruct x.
  r_swap 0 1.
  symmetry; r_swap 0 1; symmetry.
  apply EqBind_r; intros.
  rewrite EqBind_r_samp_bijection.
  apply EqBind_r; intro.
  reflexivity.
  apply uniform_boolP.
  apply addbI.
  apply EqBind_r; intros.
  rewrite EqBind_r_samp_bijection.
  apply EqBind_r; intro.
  reflexivity.
  apply uniform_boolP.
  apply addbI.
  align.
  swap_tac 0 6.
  rewrite pars_prot0.
  align.

  reflexivity.
Qed.

  Lemma OT_Trapdoor_Security :
    OT_trapdoor =a_(lambda, (2, 8)) (leakO <- new bool ;; pars [:: OTIdeal _ i m o; OT_trapdoor_OTSim leakO; OTIdeal _ i m leakO] ).
    rewrite OT_trapdoor_simpE.
    rewrite /OT_trapdoor_simp.
    symmetry.
    rewrite new_pars_pull.
    eapply AEq_err_eq; last first.
    rewrite /OTIdeal.
    apply AEq_comp_r.
    apply _.
    setoid_rewrite pars2.
    rewrite OT_trapdoor_simp_rE.
    rewrite -OT_trapdoor_OTSimE.
    symmetry.
    apply withHCBitPairRealP.
    apply _.
    rewrite /comp_err //=.
  Qed.

  Lemma OT_trapdoor_t :
    ipdl_t [:: tag o; tag leaky0; tag leaky1; tag leakEK; tag leakd01] OT_trapdoor.
    rewrite /OT_trapdoor /TD_Snd /TD_Rcv.
    repeat type_tac.
    symmetry.
    perm_match_step.
    perm_match.
  Qed.

  Lemma OT_trapdoor_OTSim_t c :
    ipdl_t [:: tag leaky0; tag leaky1; tag leakEK; tag leakd01] (OT_trapdoor_OTSim c).
    rewrite /OT_trapdoor_OTSim.
    rewrite /withHCBitPairIdeal.
    rewrite /HCBitPairIdeal.
    repeat type_tac.
    perm_match.
  Qed.
  End TrapdoorOT.

End TrapdoorOT.


(**************************************************************************)
(*  This is part of EXCEPTIONS-CL, it is distributed under the terms of   *)
(*         the GNU Lesser General Public License version 3                *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms Bool.
Require Import Program.
Require Prerequistes Terms.
Set Implicit Arguments.

Module Make(Import M: Prerequistes.T).
  Module Export DecorationsExp := Terms.Make(M).

 Inductive kind := epure | ppg | ctc.

 Inductive is: kind -> forall X Y, term X Y -> Prop :=
 | is_tpure: forall X Y (f: X -> Y), is epure (tpure f)
 | is_comp: forall k X Y Z (f: term X Y) (g: term Y Z), is k f -> is k g -> is k (f o g)
 | is_tag: forall t, is ppg (tag t)
 | is_untag: forall t, is ctc (untag t)
 | is_epure_ppg: forall X Y (f: term X Y), is epure f -> is ppg f
 | is_ppg_ctc: forall X Y  (f: term X Y), is ppg f -> is ctc f.

 Hint Constructors is.

Fixpoint fix_has_no_catcher X Y (f: term X Y): bool :=
   match f with
     | untag _ => false
     | comp _ _ _ f g => (fix_has_no_catcher f) && (fix_has_no_catcher g)
     | _ => true
   end.

Definition has_no_catcher X Y (f : term X Y) : Prop := fix_has_no_catcher f = true.

Fixpoint fix_has_no_propagator X Y (f: term X Y): bool :=
   match f with
     | tag _ => false
     | comp _ _ _ f g => fix_has_no_propagator f && fix_has_no_propagator g
     | _ => true
   end.

Definition has_no_propogator X Y (f : term X Y) : Prop := fix_has_no_propagator f = true.

Definition has_only_pure X Y (f : term X Y) : Prop := fix_has_no_propagator f = true /\ fix_has_no_catcher f = true.

Lemma no_untag_ispropagator : forall X Y (g: term X Y), has_no_catcher g -> is ppg g.
Proof.
  induction g.
  (* tpure *)
  intros. auto.
  (* comp *)
  intros. apply is_comp. unfold has_no_catcher in H.
  simpl in H.
  rewrite ?andb_true_iff in H.
  destruct H.
  auto. unfold has_no_catcher in H.
  simpl in H.
  rewrite ?andb_true_iff in H.
  destruct H as (H1&H2).
  auto.
  (* tag *)
  intros.  auto.
  (* untag *)
  intros. simpl in H.
  apply diff_false_true in H.
  contradiction H.
Qed.

Lemma onlypurecomp : forall X Y Z (f: term Y X) (g: term Z Y),
      has_only_pure f /\ has_only_pure g -> has_only_pure (g o f).
Proof.
  intros. unfold has_only_pure. unfold has_only_pure in H.
  split. simpl. rewrite ?andb_true_iff. split. apply H. apply H.
  simpl. rewrite ?andb_true_iff. split. apply H. apply H.
Qed.

Lemma no_untag_tag_ispure : forall X Y (g: term X Y),
	(has_only_pure g) -> is epure g.
Proof.
    intros. unfold has_only_pure in H. induction g.
    (* tpure *)
    intros. auto.
    (* comp *)
    apply is_comp.
    simpl in H.
    rewrite ?andb_true_iff in H.
    destruct H. destruct H. destruct H0.
    apply IHg1. split. apply H.
    apply H0.
    simpl in H.
    rewrite ?andb_true_iff in H.
    destruct H. destruct H. destruct H0.
    apply IHg2. split. apply H1.
    apply H2.
    (* tag *)
    simpl in H. destruct H. contradict H. auto.
    (* untag *)
    simpl in H. destruct H. contradict H0. auto.
Qed.

Lemma eq_catchers_eq_propags_lemma1 : forall {X Y} (f: term X Y),
	not (has_no_catcher f) -> not (has_only_pure f).
Proof.
intros. contradict H. unfold has_only_pure in H.
unfold has_no_catcher. apply H.
Qed.

Lemma eq_catchers_eq_propags_lemma2 : forall {X Y} (f: term X Y),
	not (is ctc f) -> not (has_no_catcher f).
Proof.
intros. contradict H. apply is_ppg_ctc. apply no_untag_ispropagator.
assumption.
Qed.

 Ltac edecorate :=  solve[
                          repeat (apply is_comp)
                            ||
		                 (apply is_tpure || apply is_tag || apply is_untag || assumption)
                            ||
                                 (((apply no_untag_tag_ispure; assumption) || (apply no_untag_ispropagator; assumption))
			    ||
                                 ((apply is_epure_ppg; assumption)  || (apply is_ppg_ctc; assumption)))
                            ||
                                 (apply is_epure_ppg)
                            ||
                                 (apply is_ppg_ctc)
                        ].

 Class EPURE {A B: Type} (f: term A B) := isp : is epure f.
 Hint Extern 0 (EPURE _) => edecorate : typeclass_instances.

 Class PPG {A B: Type} (f: term A B) := ispropag : is ppg f.
 Hint Extern 0 (PPG _) => edecorate : typeclass_instances.

 Class CTC {A B: Type} (f: term A B) := ireplsubstc : is ctc f.
 Hint Extern 0 (CTC _) => edecorate : typeclass_instances.

End Make.