(* This file is part of the Linear Logic  formalization in Coq: https://github.com/meta-logic/coq-ll *)

(** ** Basic proof theory
 *)

(*Add LoadPath "../../".  *)
Require Export Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export LL.StrongInduction.
Require Export LL.SequentCalculi.

Set Implicit Arguments.

Module SqBasic (DT : Eqset_dec_pol).

  Module Export Sys :=  SqSystems DT.
  #[export] Hint Resolve Nat.le_max_r : core .
  #[export] Hint Resolve Nat.le_max_l : core .
  #[export] Hint Constructors sig2h : core .
  #[export] Hint Constructors sig2hc : core .
  #[export] Hint Constructors sig2hcc : core .
  #[export] Hint Constructors sig3 : core .

  (** Exchange for the dyadic system *)
  Lemma sig2_der_compat : forall B1 B2 L1 L2 : list Lexp, B1 =mul= B2 -> L1 =mul= L2 -> |-- B1 ; L1 -> |-- B2 ; L2.
  Proof.
    intros B1 B2 L1 L2 PB PL H.
    revert dependent B2.
    revert dependent L2.
    induction H; intros;
      try rewrite PB in *;
      try rewrite PL in *.
    eapply sig2_init; eassumption.
    eapply sig2_one; eassumption.
    eapply sig2_top; eassumption.
    assert (|-- B2 ; M) by solve [apply IHsig2; auto].
    eapply sig2_bot; eassumption.
    assert (|-- B2 ; (F :: G :: M)) by solve [apply IHsig2; auto].
    eapply sig2_par; eassumption.
    assert (|-- B2 ; F :: M) by solve [apply IHsig2_1; auto].
    assert (|-- B2 ; G :: N) by solve [apply IHsig2_2; auto].
    eapply sig2_tensor; eassumption.
    assert (|-- B2 ; F :: M) by solve [apply IHsig2; auto].
    eapply sig2_plus1; eassumption.
    assert (|-- B2 ; G :: M) by solve [apply IHsig2; auto].
    eapply sig2_plus2; eassumption.
    assert (|-- B2 ; F :: M) by solve [apply IHsig2_1; auto].
    assert (|-- B2 ; G :: M) by solve [apply IHsig2_2; auto].
    eapply sig2_with; eassumption.
    assert (|-- B2 ; L) by solve [apply IHsig2; auto].
    eapply sig2_copy; eassumption.
    assert (|-- F :: B2; M) by solve [apply IHsig2; auto].
    eapply sig2_quest; eassumption.
    assert (|-- B2; [F]) by solve [apply IHsig2; auto].
    eapply sig2_bang; eassumption.
    (* exists *)
    eapply sig2_ex;eauto.
    (* forall *)
    eapply sig2_fx;eauto.
  Qed.

  #[export] Instance sig2_der_morphism :
    Proper (meq ==> meq ==> iff) (sig2).
  Proof.
    unfold Proper; unfold respectful.
    intros B1 B2 PB L1 L2 PL.
    split; intro H.
    refine (sig2_der_compat PB PL H).
    refine (sig2_der_compat (symmetry PB) (symmetry PL) H).
  Qed.

  (** Exchange rule *)
  Lemma sig2h_der_compat : forall n B1 B2 L1 L2, B1 =mul= B2 -> L1 =mul= L2 -> n |-- B1 ; L1 -> n |-- B2 ; L2.
  Proof.
    intros n B1 B2 L1 L2 PB PL H.
    revert L1 L2 PL B1 B2 PB H;
      induction n using strongind; intros.
    - inversion H; subst.
      +
        refine (sig2h_init _ (transitivity (symmetry PL) H0)).
      +
        refine (sig2h_one _ (transitivity (symmetry PL) H0)).
      +
        refine (sig2h_top _ (transitivity (symmetry PL) H0)).
    - inversion H0; subst; try rewrite PL in H3; try rewrite PL in H2;
        try rewrite PB in H3; try rewrite PB in H2.
      +
        refine (sig2h_bot H2 _); auto.
        apply H with (L1:= M) (B1:=B1); auto.
      +
        refine (sig2h_par H2 _); auto.
        apply H with (L1:= F :: G :: M) (B1:=B1); auto.
      +
        refine (sig2h_tensor H2 _ _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
        apply H with (L1:= G :: N) (B1:=B1); auto.
      +
        refine (sig2h_plus1 H2 _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
      +
        refine (sig2h_plus2 H2 _).
        apply H with (L1:= G :: M) (B1:=B1); auto.
      +
        refine (sig2h_with H2 _ _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
        apply H with (L1:= G :: M) (B1:=B1); auto.
      +
        refine (sig2h_copy H2 H3 _).
        apply H with (L1:= L) (B1:=B1); auto.
      +
        refine (sig2h_quest H2 _).
        apply H with (L1:= M) (B1:= F :: B1); auto.
      +
        refine (sig2h_bang H2 _).
        apply H with (L1:= [F]) (B1:=B1); auto.
      + (* exists *)
        eapply sig2h_ex; auto; eapply H with (B1:=B1) (L1:=Subst FX t :: M) ;simpl;auto.
      + (* forall *)
        eapply sig2h_fx; auto; intro x;eapply H with (B1:=B1) (L1:=Subst FX x :: M) ;simpl;auto. apply H3.
  Qed.

  Lemma Sig2InitNegative:  forall B A, IsNegativeAtom A ->  |-- B; [A°; A].
    intros.
    inversion H;try(rewrite AtomNeg);try(rewrite AtomPos); eapply sig2_init;eauto.
  Qed.
  Lemma Sig2InitNegative':  forall B A, IsNegativeAtom A ->  |-- B; [A; A°].
    intros.
    inversion H;try(rewrite AtomNeg);try(rewrite AtomPos); eapply sig2_init;eauto.
  Qed.
  Lemma Sig2One: forall B, |-- B; [1].
    intro. apply sig2_one;auto.
  Qed.
  Lemma Sig2Top: forall B M M', |-- B; M ++ ⊤ :: M'.
    intros. eapply sig2_top;auto.
  Qed.
  #[export] Hint Resolve Sig2InitNegative Sig2InitNegative' Sig2One Sig2Top : core .

  Lemma sig2hc_der_compat : forall n (B1 B2 L1 L2 : list Lexp), B1 =mul= B2 -> L1 =mul= L2 -> n |-c B1 ; L1 -> n |-c B2 ; L2.
  Proof.
    intros n B1 B2 L1 L2 PB PL H.
    revert L1 L2 PL B1 B2 PB H;
      induction n using strongind; intros.
    - inversion H; subst.
      +
        refine (sig2hc_init _ (transitivity (symmetry PL) H0)).
      +
        refine (sig2hc_one _ (transitivity (symmetry PL) H0)).
      +
        refine (sig2hc_top _ (transitivity (symmetry PL) H0)).
    - inversion H0; subst; try rewrite PL in H3; try rewrite PL in H2;
        try rewrite PB in H3; try rewrite PB in H2.
      +
        refine (sig2hc_bot H2 _); auto.
        apply H with (L1:= M) (B1:=B1); auto.
      +
        refine (sig2hc_par H2 _); auto.
        apply H with (L1:= F :: G :: M) (B1:=B1); auto.
      +
        refine (sig2hc_cut H2 _ _).
        eapply H with (L1:= F :: M) (B1:=B1); auto.
        eapply H with (L1:= F° :: N) (B1:=B1); auto.
      +
        refine (sig2hc_tensor H2 _ _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
        apply H with (L1:= G :: N) (B1:=B1); auto.
      +
        refine (sig2hc_plus1 H2 _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
      +
        refine (sig2hc_plus2 H2 _).
        apply H with (L1:= G :: M) (B1:=B1); auto.
      +
        refine (sig2hc_with H2 _ _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
        apply H with (L1:= G :: M) (B1:=B1); auto.
      +
        refine (sig2hc_copy H2 H3 _).
        apply H with (L1:= L) (B1:=B1); auto.
      +
        refine (sig2hc_quest H2 _).
        apply H with (L1:= M) (B1:= F :: B1); auto.
      +
        refine (sig2hc_bang H2 _).
        apply H with (L1:= [F]) (B1:=B1); auto.
      + (* exists *)
        eapply sig2hc_ex; auto; eapply H with (B1:=B1) (L1:=Subst FX t :: M) ;simpl;auto.
      + (* forall *)
        eapply sig2hc_fx; auto;intro x; eapply H with (B1:=B1) (L1:=Subst FX x :: M) ;simpl;auto. apply H3.
  Qed.

  Generalizable All Variables.
  #[export] Instance sig2hc_der_morphism n :
    Proper (meq ==> meq ==> iff) (sig2hc n).
  Proof.
    unfold Proper; unfold respectful.
    intros B1 B2 PB L1 L2 PL.
    split; intro H.
    refine (sig2hc_der_compat PB PL H).
    refine (sig2hc_der_compat (symmetry PB) (symmetry PL) H).
  Qed.

  Lemma sig2hcc_der_compat : forall n (B1 B2 L1 L2 : list Lexp), B1 =mul= B2 -> L1 =mul= L2 -> n |-cc B1 ; L1 -> n |-cc B2 ; L2.
  Proof.
    intros n B1 B2 L1 L2 PB PL H.
    revert L1 L2 PL B1 B2 PB H;
      induction n using strongind; intros.
    - inversion H; subst.
      +
        refine (sig2hcc_init _ (transitivity (symmetry PL) H0)).
      +
        refine (sig2hcc_one _ (transitivity (symmetry PL) H0)).
      +
        refine (sig2hcc_top _ (transitivity (symmetry PL) H0)).
    - inversion H0; subst; try rewrite PL in H3; try rewrite PL in H2;
        try rewrite PB in H3; try rewrite PB in H2.
      +
        refine (sig2hcc_bot H2 _); auto.
        apply H with (L1:= M) (B1:=B1); auto.
      +
        refine (sig2hcc_par H2 _); auto.
        apply H with (L1:= F :: G :: M) (B1:=B1); auto.
      +
        refine (sig2hcc_cut H2 _ _).
        eapply H with (L1:= F :: M) (B1:=B1); auto.
        eapply H with (L1:= F° :: N) (B1:=B1); auto.
      +
        refine (sig2hcc_ccut H2 _ _).
        eapply H with (L1:= (! F) :: M) (B1:=B1); auto.
        eapply H with (L1:=N) (B1:= F° :: B1); auto.
      +
        refine (sig2hcc_tensor H2 _ _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
        apply H with (L1:= G :: N) (B1:=B1); auto.
      +
        refine (sig2hcc_plus1 H2 _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
      +
        refine (sig2hcc_plus2 H2 _).
        apply H with (L1:= G :: M) (B1:=B1); auto.
      +
        refine (sig2hcc_with H2 _ _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
        apply H with (L1:= G :: M) (B1:=B1); auto.
      +
        refine (sig2hcc_copy H2 H3 _).
        apply H with (L1:= L) (B1:=B1); auto.
      +
        refine (sig2hcc_quest H2 _).
        apply H with (L1:= M) (B1:= F :: B1); auto.
      +
        refine (sig2hcc_bang H2 _).
        apply H with (L1:= [F]) (B1:=B1); auto.
      + (* exists *)
        eapply sig2hcc_ex; auto; eapply H with (B1:=B1) (L1:=Subst FX t :: M) ;simpl;auto.
      + (* forall *)
        eapply sig2hcc_fx; auto; intro x; eapply H with (B1:=B1) (L1:=Subst FX x :: M) ;simpl;auto. apply H3.
  Qed.

  Generalizable All Variables.
  #[export] Instance sig2hcc_der_morphism n :
    Proper (meq ==> meq ==> iff) (sig2hcc n).
  Proof.
    unfold Proper; unfold respectful.
    intros B1 B2 PB L1 L2 PL.
    split; intro H.
    refine (sig2hcc_der_compat PB PL H).
    refine (sig2hcc_der_compat (symmetry PB) (symmetry PL) H).
  Qed.

  Lemma sig3_der_compat : forall n c (B1 B2 L1 L2: list Lexp),
      B1 =mul= B2 -> L1 =mul= L2 -> n |~> c ; B1 ; L1 -> n |~> c ; B2 ; L2.
  Proof.
    intros n c B1 B2 L1 L2 PB PL H.
    revert dependent L1;
      revert dependent L2;
      revert dependent B1;
      revert dependent B2;
      revert dependent c;
      induction n using strongind; intros.
    - inversion H; subst.
      refine (sig3_init _ (transitivity (symmetry PL) H0)).
      refine (sig3_one _ (transitivity (symmetry PL) H0)).
      refine (sig3_top _ (transitivity (symmetry PL) H0)).

    - inversion H0; subst; try rewrite PL in H3; try rewrite PL in H2;
        try rewrite PB in H3; try rewrite PB in H2.
      +
        refine (sig3_bot H2 _); auto.
        apply H with (L1:= M) (B1:=B1); auto.
      +
        refine (sig3_par H2 _); auto.
        apply H with (L1:= F :: G :: M) (B1:=B1); auto.
      +
        refine (sig3_tensor H2 _ _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
        apply H with (L1:= G :: N) (B1:=B1); auto.
      +
        refine (sig3_plus1 H2 _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
      +
        refine (sig3_plus2 H2 _).
        apply H with (L1:= G :: M) (B1:=B1); auto.
      +
        refine (sig3_with H2 _ _).
        apply H with (L1:= F :: M) (B1:=B1); auto.
        apply H with (L1:= G :: M) (B1:=B1); auto.
      +
        refine (sig3_copy H2 H3 _).
        apply H with (L1:= L) (B1:=B1); auto.
      +
        refine (sig3_quest H2 _).
        apply H with (L1:= M) (B1:= F :: B1); auto.
      +
        refine (sig3_bang H2 _).
        apply H with (L1:= [F]) (B1:=B1); auto.
      + (* exists *)
        eapply sig3_ex; auto; eapply H with (B1:=B1) (L1:=Subst FX t :: M) ;simpl;auto.
      + (* forall *)
        eapply sig3_fx; auto; intro x; eapply H with (B1:=B1) (L1:=Subst FX x :: M) ;simpl;auto.
      + inversion H2; subst.
        ++
          eapply sig3_CUT.
          eapply sig3_cut with (F:=F); [ auto | auto | | |].
          rewrite <- PL. exact H4.
          apply H with (L1:= F :: M) (B1:=B1); auto.
          apply H with (L1:= F° :: N) (B1:=B1); auto.
        ++
          eapply sig3_CUT.
          eapply sig3_ccut with (F:=F) (M:=M) (N:=N) ; [ auto | auto | | | ].
          rewrite <- PL. exact H4.
          eapply H with (L1:= (! F) :: M) (B1:=B1); auto.
          apply H with (L1:= N) (B1:= F° :: B1); auto.
  Qed.

  Generalizable All Variables.
  #[export] Instance sig3_der_morphism n c :
    Proper (meq ==> meq ==> iff) (sig3 n c).
  Proof.
    unfold Proper; unfold respectful.
    intros B1 B2 PB L1 L2 PL.
    split; intro H.
    refine (sig3_der_compat PB PL H).
    refine (sig3_der_compat (symmetry PB) (symmetry PL) H).
  Qed.

  #[export] Hint Constructors sig2h : core .
  #[export] Hint Constructors sig2hc : core .
  #[export] Hint Constructors sig2hcc : core .
  #[export] Hint Constructors sig3 : core .

  Theorem sig2hc_then_sig2hcc: forall n B L, sig2hc n B L -> sig2hcc n B L.
  Proof.
    intros.
    induction H.
    eapply sig2hcc_init; eassumption.
    eapply sig2hcc_one; eassumption.
    eapply sig2hcc_top; eassumption.
    eapply sig2hcc_bot; eassumption.
    eapply sig2hcc_par; eassumption.
    eapply sig2hcc_cut; eassumption.
    eapply sig2hcc_tensor; eassumption.
    eapply sig2hcc_plus1; eassumption.
    eapply sig2hcc_plus2; eassumption.
    eapply sig2hcc_with; eassumption.
    eapply sig2hcc_copy; eassumption.
    eapply sig2hcc_quest; eassumption.
    eapply sig2hcc_bang; eassumption.
    eapply sig2hcc_ex; eassumption.
    eapply sig2hcc_fx; eassumption.
  Qed.

  (* substitution lemma axioms. See details in the SequentCalculi3 part below *)

  Axiom fx_swap_sig2h : forall M B FX,
      (forall x : Term, exists m : nat, m |-- B; [Subst FX x] ++ M) ->
      (exists m : nat, forall x : Term, m |-- B; [Subst FX x] ++ M).

  Axiom fx_swap_sig2hc : forall M B FX,
      (forall x : Term, exists m : nat, m |-c B; [Subst FX x] ++ M) ->
      (exists m : nat, forall x : Term, m |-c B; [Subst FX x] ++ M).

  Axiom fx_swap_sig2hcc : forall M B FX,
      (forall x : Term, exists m : nat, m |-cc B; [Subst FX x] ++ M) ->
      (exists m : nat, forall x : Term, m |-cc B; [Subst FX x] ++ M).

  Axiom fx_swap_sig3h : forall c M B FX,
      (forall x : Term, exists m : nat, m |~> c ; B; [Subst FX x] ++ M) ->
      (exists m : nat, forall x : Term, m |~> c ; B; [Subst FX x] ++ M).

  Axiom fx_swap_sig3c : forall m M B FX,
      (forall x : Term, exists c : nat, m |~> c ; B; [Subst FX x] ++ M) ->
      (exists c : nat, forall x : Term, m |~> c ; B; [Subst FX x] ++ M).

  Theorem sig2hcc_then_sig2hc: forall n B L, sig2hcc n B L -> exists m, sig2hc m B L.
  Proof.
    intros.
    induction H; try destruct IHsig2hcc; try destruct IHsig2hcc1; try destruct IHsig2hcc2.

    eexists; eapply sig2hc_init; eassumption.
    eexists; eapply sig2hc_one; eassumption.
    eexists; eapply sig2hc_top; eassumption.
    eexists; eapply sig2hc_bot; eassumption.
    eexists; eapply sig2hc_par; eassumption.
    eexists; eapply sig2hc_cut; eassumption.
    eexists; eapply sig2hc_cut with (F:=!F) (M:=M) (N:=N) (m:=x); auto.
    eapply sig2hc_quest with (F:=F°); eauto.
    eexists; eapply sig2hc_tensor; eassumption.
    eexists; eapply sig2hc_plus1; eassumption.
    eexists; eapply sig2hc_plus2; eassumption.
    eexists; eapply sig2hc_with; eassumption.
    eexists; eapply sig2hc_copy; eassumption.
    eexists; eapply sig2hc_quest; eassumption.
    eexists; eapply sig2hc_bang; eassumption.
    eexists; eapply sig2hc_ex; eassumption.
    apply fx_swap_sig2hc in H1.
    destruct H1.
    eexists.
    eapply sig2hc_fx; eauto.
  Qed.

  Theorem sig2hc_iff_sig2hcc: forall B L, (exists n, sig2hc n B L) <-> exists m, sig2hcc m B L.
  Proof.
    split; intros.
    *
      destruct H.
      eexists.
      apply sig2hc_then_sig2hcc; eauto.
    *
      destruct H.
      eapply sig2hcc_then_sig2hc; eauto.
  Qed.

  Theorem sig2hcc_then_sig3 :  forall B L n,
      n |-cc B ; L -> exists c, n |~> c ; B ; L.
  Proof.
    intros.
    revert dependent B;
      revert dependent L.
    induction n using strongind; intros L B Hyp.
    **
      inversion Hyp; subst; eexists.
      eapply sig3_init; eassumption.
      eapply sig3_one; eassumption.
      eapply sig3_top; eassumption.
    **
      inversion Hyp; subst.
      ***
        assert (exists c : nat, n |~> c ; B; M) as Hn by solve [eapply H; auto].
        destruct Hn.
        eexists.
        refine (sig3_bot H1 H0).
      ***
        assert (exists c : nat, n |~> c ; B; F :: G :: M) as Hn by solve [eapply H; auto].
        destruct Hn.
        eexists.
        refine (sig3_par H1 H0).
      ***
        assert (exists c : nat, m |~> c ; B; F :: M) as Hn1 by solve [eapply H; auto].
        assert (exists c : nat, n0 |~> c ; B; F° :: N) as Hn2 by solve [eapply H; auto].
        destruct Hn1, Hn2.
        eexists.
        eapply sig3_CUT.
        refine (sig3_cut _ _ _ H0 H4); auto.
      ***
        assert (exists c : nat, m |~> c ; B; (! F) :: M) as Hn1 by solve [eapply H; auto].
        assert (exists c : nat, n0 |~> c ; F° :: B; N) as Hn2 by solve [eapply H; auto].
        destruct Hn1, Hn2.
        eexists.
        eapply sig3_CUT.
        refine (sig3_ccut _ _ _ H0 H4); auto.
      ***
        assert (exists c : nat, m |~> c ; B; F :: M) as Hn1 by solve [eapply H; auto].
        assert (exists c : nat, n0 |~> c ; B; G :: N) as Hn2 by solve [eapply H; auto].
        destruct Hn1, Hn2.
        eexists.
        refine (sig3_tensor H1 H0 H4).
      ***
        assert (exists c : nat, n |~> c ; B; F :: M) as Hn by solve [eapply H; auto].
        destruct Hn.
        eexists.
        refine (sig3_plus1 H1 H0).
      ***
        assert (exists c : nat, n |~> c ; B; G :: M) as Hn by solve [eapply H; auto].
        destruct Hn.
        eexists.
        refine (sig3_plus2 H1 H0).
      ***
        assert (exists c : nat, m |~> c ; B; F :: M) as Hn1 by solve [eapply H; auto].
        assert (exists c : nat, n0 |~> c ; B; G :: M) as Hn2 by solve [eapply H; auto].
        destruct Hn1, Hn2.
        eexists.
        refine (sig3_with H1 H0 H4).
      ***
        assert (exists c : nat, n |~> c ; B; L0) as Hn by solve [eapply H; auto].
        destruct Hn.
        eexists.
        rewrite H2 in H0.
        refine (sig3_copy H1 _ H0); auto.
      ***
        assert (exists c : nat, n |~> c ; F :: B; M) as Hn by solve [eapply H; auto].
        destruct Hn.
        eexists.
        refine (sig3_quest H1 H0).
      ***
        assert (exists c : nat, n |~> c ; B; [F]) as Hn by solve [eapply H; auto].
        destruct Hn.
        eexists.
        refine (sig3_bang H1 H0).
      ***
        assert (exists c : nat, n |~> c ; B; Subst FX t :: M) as Hn by solve [eapply H; auto].
        destruct Hn.
        eexists.
        refine (sig3_ex H1 H0).
      ***
        assert (forall x, exists c : nat, n |~> c ; B; [Subst FX x] ++ M)
          as Hn by solve [intro; eapply H; auto].
        apply fx_swap_sig3c in Hn.
        destruct Hn.
        eexists.
        refine (sig3_fx H1 H0).
  Qed.

  Theorem sig3_then_sig2hcc :  forall B L n c,
      n |~> c ; B ; L  -> n |-cc B ; L.
  Proof.
    intros.
    revert dependent B;
      revert dependent L;
      revert dependent c.
    induction n using strongind; intros c L B Hyp.
    **
      inversion Hyp; subst.
      eapply sig2hcc_init; eassumption.
      eapply sig2hcc_one; eassumption.
      eapply sig2hcc_top; eassumption.
    **
      inversion Hyp; subst.
      ***
        assert (n |-cc B; M) as Hc by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_bot H1 _); auto.
      ***
        assert (n |-cc B; F :: G :: M) as Hc by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_par H1 _); auto.
      ***
        assert (m |-cc B; F :: M) as Hc1 by
              solve [eapply H; auto; eassumption].
        assert (n0 |-cc B; G :: N) as Hc2 by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_tensor H1 Hc1 Hc2).
      ***
        assert (n |-cc B; F :: M) as Hc by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_plus1 H1 Hc).
      ***
        assert (n |-cc B; G :: M) as Hc by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_plus2 H1 Hc).
      ***
        assert (m |-cc B; F :: M) as Hc1 by
              solve [eapply H; auto; eassumption].
        assert (n0 |-cc B; G :: M) as Hc2 by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_with H1 Hc1 Hc2).
      ***
        assert (n |-cc B; L0) as Hc by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_copy H1 H2 Hc).
      ***
        assert (n |-cc F :: B; M) as Hc by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_quest H1 Hc).
      ***
        assert (n |-cc B; [F]) as Hc by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_bang H1 Hc).
      ***
        assert (n |-cc B; Subst FX t :: M) as Hc by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_ex H1 Hc).
      ***
        assert (forall x, n |-cc B; [Subst FX x] ++ M)
          as Hc by solve [intro; eapply H; eauto].
        refine (sig2hcc_fx H1 Hc).
      ***
        inversion H1; subst.
        assert (m |-cc B; F :: M) as Hc1 by
              solve [eapply H; auto; eassumption].
        assert (n0 |-cc B; F° :: N) as Hc2 by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_cut H3 Hc1 Hc2).

        assert (m |-cc B; (! F) :: M) as Hc1 by
              solve [eapply H; auto; eassumption].
        assert (n0 |-cc F° :: B; N) as Hc2 by
              solve [eapply H; auto; eassumption].
        refine (sig2hcc_ccut _ Hc1 Hc2); auto.
  Qed.

  Theorem sig3_iff_sig2hcc :  forall B L,
      (exists n c, n |~> c ; B ; L) <-> exists m, m |-cc B ; L.
  Proof.
    split; intros.
    *
      do 2 destruct H.
      eexists.
      eapply sig3_then_sig2hcc; eauto.
    *
      destruct H.
      eexists.
      eapply sig2hcc_then_sig3; eauto.
  Qed.

  (* Triadic System theorems *)

  Theorem AdequacyTri1 : forall n B M X, n |-F- B ; M ; X -> |-F- B ; M ; X.
    induction n using strongind;intros.
    + inversion H;subst;eauto.
    (* inversion H0;subst;eauto. solves everything but it takes almost 1 min *)
    + inversion H0;subst.
      eapply tri_tensor;eauto.
      eapply tri_plus1;eauto.
      eapply tri_plus2;eauto.
      eapply tri_bang;eauto.
      eapply tri_rel;eauto.
      eapply tri_bot;eauto.
      eapply tri_par;eauto.
      eapply tri_with;eauto.
      eapply tri_quest;eauto.
      eapply tri_store;eauto.
      eapply tri_dec1;eauto.
      eapply tri_dec2;eauto.
      eapply tri_ex;eauto.
      eapply tri_fx;eauto.
  Qed.

  (**
Since there are no free variables in our encoding, we cannot prove
directly the usual substitution lemma: if there is a proof with a
fresh variable x, then there is a proof, of the same height for any
term t. The following axiom (and the similar ones for the other
systems) are introduced to cope with proofs of the form:

<<
H: forall x:Term, exists n:nat, |- Gamma, Subst FX x
----------------------------------------------------
G: exists n:nat, |- Gamma, F{ FX}
>>

The hypothesis [H] results in inductive proofs where the principal
formula is (the LL universal quantifier} [F{ FX}]. Note that we cannot
conclude the goal [G] from [H] since our hypothesis is weaker than the
similar one in pencil/paper proofs. More precisely, in a paper proof,
we can generalize [H] with a fresh variable [x]. Then, there exists
[n] s.t.  [n |- Gamma, Subst Fx x]. By using the substitution lemma,
for any [y], it must be the case [n |- Gamma, Subst Fx y] and we can
easily conclude the goal [G].
   *)
  Axiom ax_subs_prop: forall B L M FX (P:nat -> Prop), (forall x : Term, exists n : nat, (P n) /\ n |-F- B; L; UP (Subst FX x :: M)) -> exists n, (P n) /\ forall x, n |-F- B; L; UP (Subst FX x :: M) .

  Theorem ax_subs_prop' : forall B L M FX , (forall x : Term, exists n : nat, n |-F- B; L; UP (Subst FX x :: M)) -> exists n, forall x, n |-F- B; L; UP (Subst FX x :: M) .
    intros.
    assert(Hs: forall x : Term, exists n : nat, ((fun _ => True) n) /\ n |-F- B; L; UP (Subst FX x :: M)).
    intro x.
    generalize (H x) ; intro Hx.
    destruct Hx.
    eexists;eauto.
    apply ax_subs_prop in Hs.
    destruct Hs as [n [Hs Hs']].
    eexists. intro x.
    apply Hs'.
  Qed.

  Theorem AdequacyTri2 : forall B M X, |-F- B ; M ; X ->  exists n, n |-F- B ; M ; X.
    intros.
    induction H;try( destruct IHTriSystem);try( destruct IHTriSystem1); try( destruct IHTriSystem2); eauto.
    apply ax_subs_prop' in H0.
    destruct H0.
    exists (S x).
    apply trih_fx.
    intro.
    apply H0.
  Qed.

  (** The [B] and [M] contexts can be substituted by equivalent multisets *)
  Theorem TriExchangeh : forall B B' M M' X n, n |-F-  B ; M ; X -> B =mul= B' -> M =mul= M' -> n |-F- B' ; M' ; X.
  Proof.
    intros.
    generalize dependent B.
    generalize dependent M.
    generalize dependent B'.
    generalize dependent M'.
    generalize dependent X.
    induction n using strongind;intros.
    + inversion H;subst.
      ++ apply MulSingleton in H1;subst.
         eapply trih_init1;auto.
      ++ apply meq_sym in H1.
         apply  multiset_meq_empty in H1;subst.
         eapply trih_init2;eauto.
      ++
        apply meq_sym in H1.
        apply  multiset_meq_empty in H1;subst.
        eapply trih_one.
      ++
        eapply trih_top.
    +  inversion H0;subst.
       ++ (* tensor *)
         apply H  with (M':=N) (B':= B') in H5;auto.
         apply H  with (M':=M0) (B':= B') in H6;auto.
         apply trih_tensor with (F:=F)(G:=G) (N:=N)(M:=M0);auto.
         rewrite <- H1.
         assumption.
       ++ (* Oplus *)
         eapply H  with (M':=M') (B':=B')in H4;auto.
       ++ (* Oplus 2*)
         eapply H  with (M':=M') (B':=B')in H4;auto.
       ++ (* Bang *)
         apply meq_sym in H1.
         apply  multiset_meq_empty in H1;subst.
         eapply H  with (B':=B')in H4;auto.
         eapply trih_bang;auto.
       ++ (* Release *)
         eapply H  with (M':=M') (B':=B')in H5;auto.
       ++ (* Bottom *)
         eapply H  with (M':=M') (B':=B')in H4;auto.
       ++ (* Par *)
         eapply H  with (M':=M') (B':=B')in H4;auto.
       ++ (* with *)
         eapply H  with (M':=M') (B':=B')in H4;auto.
         eapply H  with (M':=M') (B':=B')in H5;auto.
       ++ (* ? *)
         eapply H  with (M':=M')(B':=B' ++ [F])in H4;auto.
       ++  (* store *)
         eapply H  with (M':=M' ++ [F]) (B':=B')in H5;auto.
       ++  (* decide 1*)
         eapply H  with (M':= L' ) (B':=B')in H6;auto.
         eapply trih_dec1 with (F:=F);auto.
         rewrite <- H1.
         apply H5.
         assumption.
       ++ (* decide 2 *)
         eapply H  with (M':= M' ) (B':=B')in H6;auto.
         eapply trih_dec2 with (F:=F);auto.
         rewrite <- H2.
         apply H5.
       ++ (* exists *)
         eapply H  with (M':= M' ) (B':=B')in H4;auto.
         eapply trih_ex;eauto.
       ++ (* forall *)
         eapply trih_fx;auto ;intro.
         generalize (H4 x);intros.
         eapply H  with (M':=  M' ) (B':=B')in H3;auto.
  Qed.

  Generalizable All Variables.
  #[export] Instance trih_morphh n : Proper (meq ==> meq ==> eq ==> iff) (TriSystemh n).
  Proof.
    intros A B Hab C D Hcd X Y Hxy; subst.
    split;intro.
    + apply TriExchangeh with (B:=A) (M:=C);auto.
    + apply TriExchangeh with (B:=B) (M:=D);auto.
  Qed.
  #[export] Instance trih_morph' n : Proper (meq ==> meq ==> @eq Arrow ==> iff) (TriSystemh n).
  Proof.
    intros A B Hab C D Hcd X Y Hxy; subst.
    split;intro.
    + apply TriExchangeh with (B:=A) (M:=C);auto.
    + apply TriExchangeh with (B:=B) (M:=D);auto.
  Qed.

  Theorem TriExchange : forall B B' M M' X, |-F-  B ; M ; X -> B =mul= B' -> M =mul= M' -> |-F- B' ; M' ; X.
    intros.
    apply AdequacyTri2 in H.
    destruct H.
    rewrite H0 in H.
    rewrite H1 in H.
    eapply AdequacyTri1;eauto.
  Qed.

  #[export] Instance tri_morph : Proper (meq ==> meq ==> eq ==> iff) (TriSystem).
  Proof.
    intros  A B Hab C D Hcd X Y Hxy; subst.
    split;intro.
    + apply TriExchange with (B:=A) (M:=C);auto.
    + apply TriExchange with (B:=B) (M:=D);auto.
  Qed.

  #[export] Instance tri_morph' : Proper (meq ==> meq ==> @eq Arrow ==> iff) (TriSystem).
  Proof.
    intros A B Hab C D Hcd X Y Hxy; subst.
    split;intro.
    + apply TriExchange with (B:=A) (M:=C);auto.
    + apply TriExchange with (B:=B) (M:=D);auto.
  Qed.

  Ltac inversionF H := inversion H;subst; LexpContr; try(LexpSubst);auto;invPosOrNegAtom;
                       try(match goal with [H : ~ Asynchronous ?F |- _] => assert(Asynchronous F) by auto;contradiction
                           end).

  Lemma Init1: forall B n x,
      true = isPositive n ->
      |-F- B; [fun T : Type => atom (a1 n (x T))]; DW (fun T : Type => perp (a1 n (x T))).
  Proof.
    intros.
    assert((fun T : Type => perp (a1 n (x T)))° = (fun T : Type => atom (a1 n (x T)))) by auto.
    rewrite <- H0.
    apply tri_init1. constructor;auto.
  Qed.

  Lemma Init2: forall B n x,
      true = isPositive n ->
      |-F- B ++ [fun T : Type => atom (a1 n (x T))]; []; DW (fun T : Type => perp (a1 n (x T))).
  Proof.
    intros.
    assert((fun T : Type => perp (a1 n (x T)))° = (fun T : Type => atom (a1 n (x T)))) by auto.
    rewrite <- H0.
    eapply tri_init2;auto. constructor;auto.
  Qed.

  Lemma Init1': forall B n x y,
      true = isPositive n ->
      |-F- B; [fun T : Type => atom (a2 n (x T) (y T))]; DW (fun T : Type => perp (a2 n (x T) (y T))).
  Proof.
    intros.
    assert((fun T : Type => perp (a2 n (x T) (y T)))° = (fun T : Type => atom (a2 n (x T) (y T)))) by auto.
    rewrite <- H0.
    apply tri_init1. constructor;auto.
  Qed.

  Lemma Init2': forall B n x y,
      true = isPositive n ->
      |-F- B ++ [fun T : Type => atom (a2 n (x T) (y T))]; [] ; DW (fun T : Type => perp (a2 n (x T) (y T))).
  Proof.
    intros.
    assert((fun T : Type => perp (a2 n (x T) (y T)))° = (fun T : Type => atom (a2 n (x T) (y T)))) by auto.
    rewrite <- H0.
    eapply tri_init2. constructor;eauto.
    solve_permutation.
  Qed.

  Lemma InitAtom : forall At B , IsPositiveAtom (At ⁺) ->  |-F- B; [At ⁺]; DW (At ⁻).
  Proof.
    intros.
    assert((At ⁻) ° = At ⁺) by reflexivity.
    rewrite <- H0.
    apply tri_init1.
    apply PositiveNegativeAtom;auto.
  Qed.

  Lemma InitAtom' : forall At B , IsNegativeAtom (At ⁺) ->  |-F- B; [At ⁻]; DW (At ⁺).
  Proof.
    intros.
    assert((At ⁺) ° = At⁻ ) by reflexivity.
    rewrite <- H0.
    apply tri_init1;auto.
  Qed.

  Lemma TopDown : forall M B, |-F- B ; M ; DW (Top).
    intros.
    apply tri_rel. constructor.
    apply tri_top.
  Qed.

  Ltac solveF :=
    subst;simpl in *;LexpContr;auto using tri_init1, tri_top, Init1, Init2,Init1', Init2', InitAtom, InitAtom',TopDown;invNegAtom;invRel;invPosOrNegAtom;try(LexpSubst);
    try(
        match goal with
        | [|- Release _] => try(auto using IsPositiveAtomRelease); try(constructor)
        | [|- IsNegativeAtom _] => constructor;auto
        | [|-~ Asynchronous _] => eauto using NotAsyncAtom, NotAsyncAtom', NotAsyncOne ,NotAsyncZero, NotAsyncTensor, NotAsyncPlus, NotAsyncEx, NotAsyncBang
        | [|- ~ IsPositiveAtom ?F] => eauto using NotPATop,NotPABot,NotPAOne,NotPAZero,NotPATensor,NotPAPlus,NotPAWith,NotPAPar,NotPABang,NotPAQuest,NotPAExists,NotPAForall
                                      (* try( assert(HPosNeg: IsNegativeAtom F) by  (constructor;auto);
                                           intro HisPos; apply PositiveNegative in HPosNeg;auto) *)
        | [H : ~ Asynchronous ?F |- _] => assert(Asynchronous F) by auto;contradiction
        | [H1 : LexpPos ?M, H2 : ?M =mul= ?K ++ ?N |- LexpPos ?N]
          => MReplaceIn M (K ++ N) H1; eapply LPos3 in H1;eauto
        | [H1 : LexpPos ?M, H2 : ?M =mul= ?N ++ ?K |- LexpPos ?N]
          => MReplaceIn M (N ++ K) H1; eapply LPos2 in H1;eauto
        | [ |- LexpPos (?M ++ [?F]) ] =>  eapply LexpPosConc;eauto
        | [H1 : LexpPos ?M , H2 : ?M =mul= ?F :: ?L |- LexpPos(?L)] =>
          rewrite H2 in H1 ; inversion H1 ;auto
        | [|- ?M =mul= ?N] => try ( (timeout 3 solve_permutation) )
        end
      ); (try reflexivity); try now symmetry.

  Lemma StoreInversion : forall n B M F,  n |-F- B; M; UP [F] -> PosOrNegAtom F -> n -1 |-F- B ; M ++ [F] ; UP [].
    intros.
    inversionF H.
    simpl. rewrite Nat.sub_0_r. auto.
  Qed.

  Lemma StoreInversionL : forall n B M N L,  n |-F- B; M; UP (N ++ L) -> LexpPos N -> exists m, m |-F- B ; M ++ N ; UP L.
    intros.
    generalize dependent M.
    generalize dependent n.
    induction N;intros.
    + simpl in *.
      eexists.
      rewrite app_nil_r.
      eauto.
    + inversion H; subst; inversion H0; try discriminate H1.
      apply (IHN H2) in H7.
      destruct H7.
      eexists.
      assert( (M ++ [a]) ++ N =mul=  M ++ a :: N) as <- by solve_permutation.
      eauto.
  Qed.

  Lemma AppSingleton : forall (F G: Lexp) M, [F] = M ++ [G] -> M = [].
    intros.
    destruct M;auto.
    simpl in H.
    inversion H.
    contradiction_multiset.
  Qed.

  (** This tactic solves (mostly automatically) the whole negative phase. *)
  Ltac NegPhase :=
    repeat (
        autounfold;simpl;
        match goal with
        | [|- |-F- _ ; _ ; UP (?l :: ?L)] =>
          match l with
          | Atom _ => apply tri_store;solveF
          | Perp _ => apply tri_store;solveF
          | Top => apply tri_top;solveF
          | Bot => apply tri_bot;solveF
          | Zero => apply tri_store;solveF
          | One => apply tri_store;solveF
          | Tensor _ _ => apply tri_store;solveF
          | Plus _ _ => apply tri_store;solveF
          | Par _ _ => apply tri_par;solveF
          | With _ _ => apply tri_with;solveF;NegPhase
          | Bang _ => apply tri_store;solveF
          | Quest _ => apply tri_quest;solveF
          | Ex _ => apply tri_store;solveF
          | Fx _ => apply tri_fx;solveF;intro
          end
        end).

End SqBasic.


Require Export ssreflect ssrfun.
Require Import Logic.ProofIrrelevance Logic.FunctionalExtensionality Logic.PropExtensionality.

Export EqNotations.

Set Bullet Behavior "Strict Subproofs".
Set Primitive Projections.

Notation prfE := proof_irrelevance.
Notation funE := (functional_extensionality _ _).
Notation dfunE := functional_extensionality_dep.
Notation propE := propositional_extensionality.

Lemma unfunE {A B : Type} (f g : A -> B) : f = g -> forall x, f x = g x.
Proof. by move=> ->. Qed.

Global Hint Resolve prfE : core.

Ltac build := unshelve esplit=>//=.

Scheme eq_ind := Induction for eq Sort Type.
Arguments eq_ind [A] x P f y e.

Record sig (A : Type) (B : A -> Type) : Type :=
  Sig {pi1 : A; pi2 : B pi1}.

Arguments Sig [A] [B] pi1 pi2.
Arguments pi1 {A B} _ /.
Arguments pi2 {A B} _ /.

Definition sub (A : Type) (P : A -> Prop) : Type :=
  sig A P.

Set Warnings "-notation-overridden".
Notation "{ x : A & B }" := (sig A (fun x:A => B)) : type_scope.
Notation "{ x : A | B }" := (sub A (fun x:A => (B : Prop))) : type_scope.
Notation "( x , y , .. , z )" := (Sig .. (Sig x y) .. z) : core_scope.
Set Warnings "default".

Definition prod (A B : Type) := {_:A & B}.
Infix "×" := prod (at level 60).

Definition pair {A B} (a : A) (b : B) : A × B :=
  Sig a b.

Lemma sigE {A} {B : A -> Type} : forall (p q : {x : A & B x}) (u : pi1 p = pi1 q) (v : rew u in pi2 p = pi2 q), p = q.
Proof.
  move=> [a +] [x +] //= h; move: x h.
  by apply: eq_ind=> b1 b2//= ->.
Qed.

Lemma subE {A} {P : A -> Prop} : forall (p q : {x : A | P x}), pi1 p = pi1 q -> p = q.
Proof. by move=>???; apply: sigE. Qed.

Lemma prodE {A B} : forall (p q : A × B), pi1 p = pi1 q -> pi2 p = pi2 q -> p = q.
Proof.
  move=> [a1 +] [a2 +] //= h; move: a2 h.
  by apply: eq_ind=> b1 b2 ->.
Qed.

Record iso (A B : Type) :=
  {fwd : A -> B;
   bwd : B -> A;
   fwd_bwd : forall x, fwd (bwd x) = x;
   bwd_fwd : forall x, bwd (fwd x) = x}.

Arguments fwd [_] [_] _.
Arguments bwd [_] [_] _.
Arguments bwd_fwd [_] [_] _.
Arguments fwd_bwd [_] [_] _.

Infix "≅" := iso (at level 100).

Lemma push_iso {A B C} (α : A ≅ B) : (forall x : A, C (fwd α x)) -> forall x : B, C x.
Proof.
  move=> H x.
  by rewrite -[x](fwd_bwd α).
Defined.

Definition iso_fun {A A' B B'} (α : A ≅ A') (β : B ≅ B') : (A -> B) ≅ (A' -> B').
Proof.
  unshelve esplit.
  - by move=> f x; apply/(fwd β)/f/(bwd α)/x.
  - by move=> f x; apply/(bwd β)/f/(fwd α)/x.
  - abstract (by move=> f; apply: funE => ?; rewrite ? fwd_bwd).
  - abstract (by move=> f; apply: funE => ?; rewrite ? bwd_fwd).
Defined.

Definition iso_trans {A B C} (α : A ≅ B) (β : B ≅ C) : A ≅ C.
Proof.
  build.
  - move=> x; apply/(fwd β)/(fwd α)/x.
  - move=> x; apply/(bwd α)/(bwd β)/x.
  - abstract (by move=> f /=; rewrite ? fwd_bwd).
  - abstract (by move=> f /=; rewrite ? bwd_fwd).
Defined.

Definition iso_id {A} : A ≅ A.
Proof. build; by []. Defined.

Class Connective (A A' : Type) :=
  {conn_def : A' ≅ A}.

#[export] Hint Mode Connective + - : core.

Section Rules.
  Context {A A'} `{Connective A A'}.
  Definition intro : A' -> A := fwd conn_def.
  Definition elim : A -> A' := bwd conn_def.
  Definition beta : forall x, elim (intro x) = x := bwd_fwd conn_def.
  Definition eta : forall x, intro (elim x) = x := fwd_bwd conn_def.
End Rules.

Lemma push_conn {A B C} `{Connective B A} : (forall x : A, C (intro x)) -> forall x : B, C x.
Proof.
  move=> K x.
  by rewrite -[x](@eta B A).
Defined.


Require Import FP.Core.
Require Import FP.Data.Unit.
Require Import FP.Classes.Lattice.

Definition vbool := Coq.Init.Datatypes.bool.
Definition vtrue := Coq.Init.Datatypes.true.
Definition vfalse := Coq.Init.Datatypes.false.

Definition bool := lib bool.
Definition true : dom bool := vtrue.
Definition false : dom bool := vfalse.
Definition case {A} : dom (bool ⇒ (unit ⇒ A) ⇒ (unit ⇒ A) ⇒ A) := λ b t f →
  if b : dom bool then t ∙ tt else f ∙ tt.
Global Opaque true.
Global Opaque false.
Global Opaque case.
Ltac bool_induction e :=
  induction e ;
  repeat
    match goal with
    | |- context[Coq.Init.Datatypes.true] => change Coq.Init.Datatypes.true with true
    | |- context[Coq.Init.Datatypes.false] => change Coq.Init.Datatypes.false with false
    end.

Definition and : dom (bool ⇒ bool ⇒ bool) := λ x y → case ∙ x ∙ (λ _ → y) ∙ (λ _ → false).

Definition bool_beta_true {A} t f : case (A:=A) ∙ true ∙ t ∙ f ≃ t ∙ tt := libReflexivity.
Definition bool_beta_false {A} t f : case (A:=A) ∙ false ∙ t ∙ f ≃ f ∙ tt := libReflexivity.
Ltac BoolRewrite :=
  match goal with
  | |- ⟨ case ∙ true ∙ ?t ∙ ?f IN _ |_| _ ⟩ => ReplaceBy (bool_beta_true t f)
  | |- ⟨ case ∙ false ∙ ?t ∙ ?f IN _ |_| _ ⟩ => ReplaceBy (bool_beta_false t f)
  end.
Definition bool_eta e : case ∙ e ∙ (λ _ → true) ∙ (λ _ → false) ≃ e.
Proof.
  bool_induction e ; Re fail || BoolRewrite.
Qed.

Definition bool_beta_lte {A} `{! Lattice A } e t f : case (A:=A) ∙ e ∙ t ∙ f ⊑ t ∙ tt ⊔ f ∙ tt.
Proof.
  bool_induction e ; Re fail || BoolRewrite ; apply join_left || apply join_right.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable ltA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable isosceles_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deftriangle_1 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_2 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable defcollinear_3 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_4 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_5 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_6 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_7 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_8 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_9 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_inequalitysymmetric_10 : (forall A B : Universe, (A <> B -> B <> A)).
Variable cn_congruencereflexive_11 : (forall A B : Universe, cong_ A B A B).
Variable proposition_03_12 : (forall A B C D E F : Universe, (exists X : Universe, ((lt_ C D A B /\ cong_ E F A B) -> (betS_ E X F /\ cong_ E X C D)))).
Variable lemma_collinearorder_13 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_betweennotequal_14 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_collinear4_15 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable axiom_betweennesssymmetry_16 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable proposition_16_17 : (forall A B C D : Universe, ((triangle_ A B C /\ betS_ B C D) -> (ltA_ B A C A C D /\ ltA_ C B A A C D))).
Variable defisosceles_18 : (forall A B C : Universe, (isosceles_ A B C -> (triangle_ A B C /\ cong_ A B A C))).
Variable defisosceles2_19 : (forall A B C : Universe, ((triangle_ A B C /\ cong_ A B A C) -> isosceles_ A B C)).
Variable proposition_05_20 : (forall A B C : Universe, (isosceles_ A B C -> congA_ A B C A C B)).
Variable lemma_ray4_1_21 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_22 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_23 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_equalanglesreflexive_24 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_equalangleshelper_25 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable lemma_angleorderrespectscongruence2_26 : (forall A B C D E F Xa Xb Xc : Universe, ((ltA_ A B C D E F /\ congA_ Xa Xb Xc A B C) -> ltA_ Xa Xb Xc D E F)).
Variable lemma_ABCequalsCBA_27 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_angleorderrespectscongruence_28 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ congA_ P Q R D E F) -> ltA_ A B C P Q R)).
Variable lemma_equalanglessymmetric_29 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable defanglelessthan_30 : (forall A B C D E F : Universe, (exists U X V : Universe, (ltA_ A B C D E F -> (betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X)))))).
Variable defanglelessthan2_31 : (forall A B C D E F U X V : Universe, ((betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X))) -> ltA_ A B C D E F)).
Variable lemma_angleordertransitive_32 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ ltA_ D E F P Q R) -> ltA_ A B C P Q R)).

Theorem proposition_18_33 : (forall A B C : Universe, ((triangle_ A B C /\ lt_ A B A C) -> ltA_ B C A A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export init.
Require Import Program.
Require Import univ utils examples ngmap gmap.

(* simple proofs about self-defined generic types *)

Theorem sum_eq_teither (A B : Type)
  : sum A B = decodeClosed teither A B.
Proof.
  unfold decodeClosed; unfold decodeType; simpl.
  reflexivity.
Qed.

Definition optMaybe (A : Type) (o : option A) : decodeClosed tmaybe A :=
  match o with
  | Some x => inr x
  | None => inl tt
  end.

Definition maybeOpt (A : Type) (t : decodeClosed tmaybe A) : option A :=
  match t with
  | inl tt => None
  | inr x => Some x
  end.

Theorem opt_eq_tmaybe (A : Type) (o : option A)
  : maybeOpt (optMaybe o) = o.
Proof.
  destruct o as [sa |].
  - reflexivity.
  - reflexivity.
Qed.

Theorem tmaybe_eq_opt (A : Type) (m : decodeClosed tmaybe A)
  : optMaybe (maybeOpt m) = m.
Proof.
  destruct m as [sm |].
  - destruct sm; reflexivity.
  - reflexivity.
Qed.

(** Map = nMap 2 **)

Lemma nmap2 (v : vec Type 2)
  : nMap v = (vhd v -> vhd (vtl v)).
Proof.
  unfold nMap.
  (* dep destruct uses axiom JMeq_eq *)
  dependent destruction v.
  dependent destruction v.
  reflexivity.
Qed.

Theorem map_eq_nmap2 (v : vec Type 2)
  : Map v = nMap v.
Proof.
  unfold Map.
  dependent destruction v;
  dependent destruction v.
  reflexivity.
Qed.

Print Assumptions map_eq_nmap2.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable midpoint_ : Universe -> Universe -> Universe -> Prop.
Variable eF_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_NCdistinct_1 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable deftriangle_2 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_3 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable proposition_10_4 : (forall A B : Universe, (exists X : Universe, (A <> B -> (betS_ A X B /\ cong_ X A X B)))).
Variable lemma_congruenceflip_5 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable defmidpoint_6 : (forall A B C : Universe, (midpoint_ A B C -> (betS_ A B C /\ cong_ A B B C))).
Variable defmidpoint2_7 : (forall A B C : Universe, ((betS_ A B C /\ cong_ A B B C) -> midpoint_ A B C)).
Variable lemma_betweennotequal_8 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_extension_9 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable defcollinear_10 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_11 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_12 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_13 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_14 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_15 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_16 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_17 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_NCorder_18 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable lemma_NChelper_19 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable proposition_23C_20 : (forall A B C D E P : Universe, (exists X Y : Universe, ((A <> B /\ (~(col_ D C E) /\ ~(col_ A B P))) -> (out_ A B Y /\ (congA_ X A Y D C E /\ oS_ X P A B))))).
Variable lemma_inequalitysymmetric_21 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_congruencetransitive_22 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable lemma_congruencesymmetric_23 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable axiom_betweennesssymmetry_24 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable proposition_42B_25 : (forall B C D E J K R Xa Xb Xc Xe : Universe, (exists X Z : Universe, ((triangle_ Xa Xb Xc /\ (midpoint_ Xb Xe Xc /\ (~(col_ J D K) /\ (midpoint_ B E C /\ (cong_ E C Xe Xc /\ ~(col_ R E C)))))) -> (pG_ X E C Z /\ (eF_ Xa Xb Xe Xc X E C Z /\ (congA_ C E X J D K /\ oS_ R X E C)))))).
Variable lemma_PGrotate_26 : (forall A B C D : Universe, (pG_ A B C D -> pG_ B C D A)).
Variable proposition_44A_27 : (forall A B D E F G J N : Universe, (exists X Y : Universe, ((pG_ B E F G /\ (congA_ E B G J D N /\ betS_ A B E)) -> (pG_ A B X Y /\ (congA_ A B X J D N /\ (eF_ B E F G Y X B A /\ betS_ G B X)))))).
Variable defparallelogram_28 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_29 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable lemma_parallelNC_30 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Variable defoppositeside_31 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_32 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable axiom_EFpermutation_33 : (forall A B C D Ca Cb Cc Cd : Universe, (eF_ A B C D Ca Cb Cc Cd -> (eF_ A B C D Cb Cc Cd Ca /\ (eF_ A B C D Cd Cc Cb Ca /\ (eF_ A B C D Cc Cd Ca Cb /\ (eF_ A B C D Cb Ca Cd Cc /\ (eF_ A B C D Cd Ca Cb Cc /\ (eF_ A B C D Cc Cb Ca Cd /\ eF_ A B C D Ca Cd Cc Cb)))))))).
Variable axiom_EFtransitive_34 : (forall A B C D P Q R S Ca Cb Cc Cd : Universe, ((eF_ A B C D Ca Cb Cc Cd /\ eF_ Ca Cb Cc Cd P Q R S) -> eF_ A B C D P Q R S)).
Variable lemma_samesidecollinear_35 : (forall A B C P Q : Universe, ((oS_ P Q A B /\ (col_ A B C /\ A <> C)) -> oS_ P Q A C)).
Variable lemma_samesideflip_36 : (forall A B P Q : Universe, (oS_ P Q A B -> oS_ P Q B A)).
Variable lemma_planeseparation_37 : (forall A B C D E : Universe, ((oS_ C D A B /\ tS_ D A B E) -> tS_ C A B E)).
Variable lemma_oppositesidesymmetric_38 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ Q A B P)).

Theorem proposition_44_39 : (forall A B D J N R Xa Xb Xc : Universe, (exists X Y Z : Universe, ((triangle_ Xa Xb Xc /\ (~(col_ J D N) /\ ~(col_ A B R))) -> (pG_ A B X Y /\ (congA_ A B X J D N /\ (eF_ Xa Xb Z Xc A B X Y /\ (midpoint_ Xb Z Xc /\ tS_ X A B R))))))).
Proof.
  time tac.
Qed.

End FOFProblem.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Product of Data Structures                                              *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibReflect.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Inhabited *)

Global Instance prod_inhab : forall `{Inhab A, Inhab B}, Inhab (A * B).
Proof. intros. apply (prove_Inhab (arbitrary, arbitrary)). Qed.

(* ********************************************************************** *)
(** * Comparable *)

Definition prod_compare {A B : Type} `{Comparable A} `{Comparable B} (x y : A * B) :=
  let (x1, x2) := x in let (y1, y2) := y in
  decide (x1 = y1 /\ x2 = y2).

Global Instance prod_comparable : forall A B : Type,
  Comparable A -> Comparable B -> Comparable (A * B).
Proof.
  introv CA CB. applys comparable_beq (@prod_compare A B _ _). intros x y.
  destruct x; destruct y; simpl; rew_refl; iff H; inverts~ H;
   tryfalse; auto; try congruence.
Qed.

(* ********************************************************************** *)
(** * Structure *)

(** Decomposition as projection *)

Lemma tuple2_from_proj : forall A1 A2 (x:A1*A2),
  (fst x, snd x) = x.
Proof. intros. destruct~ x. Qed.

(** Structural equality *)

Section Properties.
Variables (A1 A2 A3 A4 : Type).
Lemma eq_prod2 : forall (x1 y1:A1) (x2 y2:A2),
  x1 = y1 -> x2 = y2 -> (x1, x2) = (y1, y2).
Proof. intros. subst~. Qed.

Lemma eq_prod3 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3),
  x1 = y1 -> x2 = y2 -> x3 = y3 -> (x1, x2, x3) = (y1, y2, y3).
Proof. intros. subst~. Qed.

Lemma eq_prod4 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
  x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> (x1, x2, x3, x4) = (y1, y2, y3, y4).
Proof. intros. subst~. Qed.

End Properties.

Hint Immediate eq_prod2 eq_prod3 eq_prod4.

(* ********************************************************************** *)
(** * Operations *)

(** [fst] and [snd] are defined in the standard library *)

Implicit Arguments fst [[A] [B]].
Implicit Arguments snd [[A] [B]].

(* ---------------------------------------------------------------------- *)
(** ** Notation for projections *)

(** N-ary projections are defined as notations and not as
    definitions, which has appeared to be more flexible with
    respect to type inference.
    TODO: investigate the possibility of using definitions. *)

Notation "'proj11' P" := P (at level 69, only parsing).

Notation "'proj21' P" := (proj1 P) (at level 69, only parsing).
Notation "'proj22' P" := (proj2 P) (at level 69, only parsing).

Notation "'proj31' P" := (proj1 P) (at level 69).
Notation "'proj32' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj33' P" := (proj2 (proj2 P)) (at level 69).

Notation "'proj41' P" := (proj1 P) (at level 69).
Notation "'proj42' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj43' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj44' P" := (proj2 (proj2 (proj2 P))) (at level 69).

Notation "'proj51' P" := (proj1 P) (at level 69).
Notation "'proj52' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj53' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj54' P" := (proj1 (proj2 (proj2 (proj2 P)))) (at level 69).
Notation "'proj55' P" := (proj2 (proj2 (proj2 (proj2 P)))) (at level 69).

(*-----------------------------------------------------*)
(** ** Currying *)

Section Currying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition curry1 f : A1 -> B :=
  f.
Definition curry2 f : A1 -> A2 -> B :=
  fun x1 x2 => f (x1,x2).
Definition curry3 f : A1 -> A2 -> A3 -> B :=
  fun x1 x2 x3 => f (x1,x2,x3).
Definition curry4 f : A1 -> A2 -> A3 -> A4 -> B :=
  fun x1 x2 x3 x4 => f (x1,x2,x3,x4).
Definition curry5 f : A1 -> A2 -> A3 -> A4 -> A5 -> B :=
  fun x1 x2 x3 x4 x5 => f (x1,x2,x3,x4,x5).
End Currying.

(*-----------------------------------------------------*)
(** ** Uncurrying *)

Section Uncurrying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition uncurry1 f : A1 -> B :=
  f.
Definition uncurry2 f : A1*A2 -> B :=
  fun p => match p with (x1,x2) =>
  f x1 x2 end.
Definition uncurry3 f : A1*A2*A3 -> B :=
  fun p => match p with (x1,x2,x3) =>
  f x1 x2 x3 end.
Definition uncurry4 f : A1*A2*A3*A4 -> B :=
  fun p => match p with (x1,x2,x3,x4) =>
  f x1 x2 x3 x4 end.
Definition uncurry5 f : A1*A2*A3*A4*A5 -> B :=
  fun p => match p with (x1,x2,x3,x4,x5) =>
  f x1 x2 x3 x4 x5 end.
End Uncurrying.

(* ---------------------------------------------------------------------- *)
(** ** Uncurrying for relations *)

(** [uncurrypN] turns a function of type [A1 -> A1 -> .. -> AN -> AN -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Uncurryp.
Variables (A1 A2 A3 A4 B : Type).
Definition uncurryp1 f : A1 -> A1 -> B :=
  f.
Definition uncurryp2 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 x2 y2 end.
Definition uncurryp3 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 x2 x3 y1 y2 y3 end.
Definition uncurryp4 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 x2 x3 x4 y1 y2 y3 y4 end.
End Uncurryp.

(** Unfolding *)

Tactic Notation "unfold_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4.

Tactic Notation "unfolds_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4 in *.

(* ---------------------------------------------------------------------- *)
(** ** Inverse projections for relations *)

(* TODO: rename to [unprojpNK] and define also [unprojNK] *)

(** [unprojNK] turns a function of type [AK -> AK -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Unproj.
Variables (A1 A2 A3 A4 B : Type).
Definition unproj21 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 end.
Definition unproj22 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x2 y2 end.
Definition unproj31 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 y1 end.
Definition unproj32 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x2 y2 end.
Definition unproj33 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x3 y3 end.
Definition unproj41 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 y1 end.
Definition unproj42 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x2 y2 end.
Definition unproj43 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x3 y3 end.
Definition unproj44 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x4 y4 end.
End Unproj.

Implicit Arguments unproj21 [ A1 B ].
Implicit Arguments unproj22 [ A2 B ].
Implicit Arguments unproj31 [ A1 B ].
Implicit Arguments unproj32 [ A2 B ].
Implicit Arguments unproj33 [ A3 B ].
Implicit Arguments unproj41 [ A1 B ].
Implicit Arguments unproj42 [ A2 B ].
Implicit Arguments unproj43 [ A3 B ].
Implicit Arguments unproj44 [ A4 B ].

(** Unfolding *)

Tactic Notation "unfold_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44.

Tactic Notation "unfolds_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44 in *.


(******************************************************************************)
(* PipeCheck: Specifying and Verifying Microarchitectural                     *)
(* Enforcement of Memory Consistency Models                                   *)
(*                                                                            *)
(* Copyright (c) 2014 Daniel Lustig, Princeton University                     *)
(* All rights reserved.                                                       *)
(*                                                                            *)
(* This library is free software; you can redistribute it and/or              *)
(* modify it under the terms of the GNU Lesser General Public                 *)
(* License as published by the Free Software Foundation; either               *)
(* version 2.1 of the License, or (at your option) any later version.         *)
(*                                                                            *)
(* This library 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          *)
(* Lesser General Public License for more details.                            *)
(*                                                                            *)
(* You should have received a copy of the GNU Lesser General Public           *)
(* License along with this library; if not, write to the Free Software        *)
(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  *)
(* USA                                                                        *)
(******************************************************************************)

Require Import Arith.
Require Import Compare_dec.
Require Import wmm.
Require Import util2.
Require Import tree.
Require Import Bool.
Require Import Ascii.
Require Import String.
Require Import List.
Import ListNotations.

(** * Local Ordering Graphs *)

Definition location : Type := nat.

(** ** Paths *)

(** A [Path] is a list of locations (e.g., pipeline stages), given by [nat]
  indices, through which an operation passes during its execution. *)
Definition Path : Type := list location.

(** *** Transitive Closure of a [Path] *)

(** Pair the first argument with each element of the second argument *)
Fixpoint PathTC_Pair {A : Type}
  (src : A)
  (dsts : list A)
  : list (A * A) :=
  match dsts with
  | dst_head::dsts_tail => (src, dst_head) :: PathTC_Pair src dsts_tail
  | [] => []
  end.

(** Given a path, generate the list of pairs representing the transitive
  closure of the path. *)
Fixpoint PathTC {A : Type}
  (l : list A)
  : list (A * A) :=
  match l with
  | h::t => PathTC_Pair h t ++ PathTC t
  | [] => []
  end.

Lemma PathTCPairIn :
  forall (A : Type) (x y : A) (l : list A),
  In y l -> In (x, y) (PathTC_Pair x l).
Proof.
  intros A x y.  induction l as [|lh lt].
    intros H; inversion H.
  intros H.  destruct H as [H|H].
    rewrite H in *; clear H.  left.  auto.
  apply IHlt in H.  right.  auto.
Qed.

Lemma PathTCFollows :
  forall (A : Type) (x y : A) (l : list A),
  In x l ->
  In y l ->
  x <> y ->
  In (x, y) (PathTC l) \/ In (y, x) (PathTC l).
Proof.
  intros A x y l Hx Hy Hxy.
  induction l as [|lh lt].  inversion Hx.
  destruct Hx as [Hx|Hx].
    destruct Hy as [Hy|Hy].
      rewrite Hx, Hy in *.  elim Hxy; auto.
    left.  simpl.  assert(In (x, y) (PathTC_Pair lh lt)) as Hin.
      rewrite Hx.  apply PathTCPairIn.  auto.
    apply in_or_app.  left; auto.
  destruct Hy as [Hy|Hy].
    rewrite Hy in *.  right.
    simpl.  apply in_or_app.  left.  apply PathTCPairIn.  auto.
  simpl.  destruct IHlt; auto.
    left.  apply in_or_app.  auto.
  right.  apply in_or_app.  auto.
Qed.

Module PathTCExample.

Example e :
  PathTC [1; 2; 3] = [(1, 2); (1, 3); (2, 3)].
Proof.
auto.
Qed.

End PathTCExample.

(** A [PathMap] is a list in which the nth element is the path (as pairs of
  [location]s taken by the nth Event in program order. *)
Definition PathMap : Type := list (list (location * location)).

(** ** Graphs of Happens-Before Orderings *)

(* A [LocalOrdering] is an ordering on [Event]s that is enforced with at
  a given [location] (e.g., at a particular pipeline stage) *)
Definition LocalOrdering : Type := list (Event * Event).

(** A [LocalReordering] takes a set of events and returns some other
set of events.  This represents the set of guarantees that are
maintained, restored, no longer maintained, etc. through a given location.

The first argument provides the ordering as seen by all previous locations in
the pipeline.  We use this to be able to define things like reorder buffers,
where the output ordering is defined to be equal to the output ordering of
some previous stage, e.g., the decode stage. *)
Definition LocalReordering : Type :=
  list (list (Event * Event)) -> LocalOrdering -> LocalOrdering.

(** If the [LocalOrdering] edge [(e1, e2)] is present at location (vertex) [v1],
  and if both [e1] and [e2] have [v2] as the next [location] after [v1] in the
  [Path]s they take, then [(e1, e2)] is a [TransferedEdge] from [v1] to [v2]. *)
Definition TransferedEdge
  (paths : PathMap)
  (v1 v2 : location)
  (e1 e2 : Event)
  : bool :=
  let (p1, p2) := (nth (eiid e1) paths [], nth (eiid e2) paths []) in
    andb (Inb_nat_nat (v1, v2) p1) (Inb_nat_nat (v1, v2) p2).

(** Given a set [candidates] of [LocalOrdering] edges at a vertex [v1], return
  the set of edges that are [TransferedEdge]s from [v1] to [v2]; i.e., those
  such that the source and dest of the edge both have [v2] as the next stage
  in their paths. *)
Fixpoint TransferedEdges
  (paths : PathMap)
  (candidates : list (Event * Event))
  (v1 v2 : location)
  : list (Event * Event) :=
  match candidates with
  | [] => []
  | (e1, e2)::t =>
    if (TransferedEdge paths v1 v2 e1 e2)
      then (e1, e2) :: TransferedEdges paths t v1 v2
      else TransferedEdges paths t v1 v2
  end.

(** Given a set [candidates] of [LocalOrdering] edges at a vertex [v1], return
  the set of [TransferedEdges], and apply the [local_reordering] that a
  location performs. *)
Definition TransferedReorderedEdges
  (paths : PathMap)
  (candidates : list (Event * Event))
  (edges_all : list (list (Event * Event)))
  (v1 v2 : location)
  (local_reordering : LocalReordering)
  : list (Event * Event) :=
  local_reordering edges_all (TransferedEdges paths candidates v1 v2).

(** Return the set of [TransferedReorderedEdges] from [v1] to [v2], where
  [v1] is the index into the list of list of edges [edges_all]. *)
Fixpoint EdgesToTransferedEdges'
  (paths : PathMap)
  (edges_all : list (list (Event * Event)))
  (v1 v2 : location)
  (local_reordering : LocalReordering)
  : list (list (Event * Event)) :=
  match edges_all with
  | [] => []
  | edges_h::edges_t =>
    TransferedReorderedEdges paths edges_h edges_all v1 v2 local_reordering ::
    EdgesToTransferedEdges' paths edges_t (S v1) v2 local_reordering
  end.

(** Return the union of the sets of [TransferedReorderedEdges] from every
  previous location to [v2]. *)
Definition EdgesToTransferedEdges
  (paths : PathMap)
  (edges_all : list (list (Event * Event)))
  (v2 : location)
  (local_reordering : LocalReordering) :
  list (Event * Event) :=
  fold_left (app (A:=_))
    (EdgesToTransferedEdges' paths edges_all 0 v2 local_reordering)
    [].

(** Given a list of edges at locations 0 through (n-1), calculate and append
  the list of edges at location n. *)
Definition EdgesToEdges
  (paths : PathMap)
  (local_reordering : LocalReordering)
  (edges_all : list (list (Event * Event))) :
  list (list (Event * Event)) :=
  edges_all ++
    [EdgesToTransferedEdges paths edges_all (List.length edges_all)
     local_reordering].

Module EdgesExample.

Definition ev0 : Event := mkev 0 (mkiiid 0 0) (Access W 0 1).
Definition ev1 : Event := mkev 1 (mkiiid 0 1) (Access R 0 0).
Definition ev2 : Event := mkev 2 (mkiiid 0 2) (Access R 0 0).
Definition ev3 : Event := mkev 3 (mkiiid 0 3) (Access W 0 1).

Definition pathpairs : PathMap :=
  [[(0, 1); (1, 3)]; [(0, 1); (1, 3)]; [(0, 2); (2, 3)]; [(0, 2); (2, 3)]].

Definition edges0 : list (list (Event * Event)) :=
  [PathTC [ev0; ev1; ev2; ev3]].

Definition FIFO : LocalReordering := fun _ => fun z => z.

Definition edges01 := EdgesToEdges pathpairs FIFO edges0.

Example edges0_to_01 : edges01 = edges0 ++ [[(ev0, ev1)]].
Proof.
  auto.
Qed.

Definition edges012 := EdgesToEdges pathpairs FIFO edges01.
Definition edges0123 := EdgesToEdges pathpairs FIFO edges012.

End EdgesExample.

(** Given a list of events originating at a given [location], create program
  order edges between edges from the same [poi]. *)
Definition ProgramOrderEdges
  (l : list Event)
  : list (Event * Event) :=
  let sorted_events := fold_left
    (fun l' e => AppendToNth l' (proc (iiid e)) e) l [] in
  let edges := map PathTC sorted_events in
  fold_left (app (A:=_)) edges [].

(** Given a list of locations (defined as a list of [LocalReordering]s),
  a set of [LocalOrdering] edges from the first [location], and a [PathMap]
  defining the [Path] taken by each [Event] in the scenario, calculate the
  full set of [LocalOrdering] edges in the scenario.

  [IntraLocationEdges'] handles cases other than the first, i.e., those which
  are defined in terms of previous [location]s rather than program order. *)
Fixpoint IntraLocationEdges'
  (paths : PathMap)
  (edges_all : list (list (Event * Event)))
  (po_events : list (list Event))
  (local_reorderings : list (LocalReordering))
  : list (list (Event * Event)) :=
  match (local_reorderings, po_events) with
  | (oh::ot, eh::et) =>
    IntraLocationEdges' paths
      (AppendToLast (ProgramOrderEdges eh) (EdgesToEdges paths oh edges_all))
      et ot
  | (oh::ot, _) =>
    IntraLocationEdges' paths (EdgesToEdges paths oh edges_all) [] ot
  | _ => edges_all
  end.

(** Given a list of locations (as specified as a list of [LocalReordering]s),
  a set of [LocalOrdering] edges from the first location, and a [PathMap]
  defining the [Path] taken by each [Event] in the scenario, calculate the
  full set of [LocalOrdering] edges in the scenario.

  [IntraLocationEdges] handles the base case, i.e., the stage which is defined
  in terms of program order, since there are no previous [location]s. *)
Definition IntraLocationEdges
  (paths : PathMap)
  (events : list (list Event))
  (local_reorderings : list (LocalReordering))
  : list (list (Event * Event)) :=
  IntraLocationEdges' paths [] events local_reorderings.

Module EdgesExample2.
Import EdgesExample.

Definition my_local_reorderings := [FIFO; FIFO; FIFO; FIFO].

Example edges_to_3 :
  edges0123 =
    IntraLocationEdges pathpairs [[ev0; ev1; ev2; ev3]] my_local_reorderings.
Proof.
  auto.
Qed.

End EdgesExample2.

(** ** Global Events *)

(** A [GlobalEvent] is a memory [Event] (as its [eiid]) passing through
  a particular [location] *)
Definition GlobalEvent : Type := prod location Eiid.

(** A [GlobalGraph] is a list of labeled edges between [GlobalEvent]s *)
Definition GlobalGraph : Type := list (GlobalEvent * GlobalEvent * string).

(** * Pipeline Model *)

(** ** Pipeline Stages *)

(** A SpecialEdgeMap produces a set of extra edges from a given [Event] to
  edges coming either before or after it in program order.

  For example, a store buffer might ensure that only one unacknowledged store
  is outstanding at any given time; in this case, we would add an global edge
  from the [GlobalEvent] of the first [Event] getting acknowledged to the
  subsequent [Event] leaving the store buffer. *)
Definition SpecialEdgeMap : Type :=
  list Event -> Event -> list Event -> GlobalGraph.

(** A pipeline [Stage] is defined by its name, its numerical ID (which must be
  monotonically increasing), the [LocalReordering] it performs, and a
  [SpecialEdgeMap] if applicable. *)
Record Stage := mkStage {
  name : string;
  localReordering : LocalReordering;
  specialEdges : SpecialEdgeMap
}.

(** A [PerformStages] specifies the locations at which an instruction peforms
  with respect to each core along its path.

 [observability] refers to the situation in which a particular performing
 location is only visible to stores from certain cores.  For example, a read
 forwarded from the store buffer may perform with respect to all cores wheen
 it performs, but it can only observe stores from the same core in this
 situation.
 *)
Record PerformStages := mkPerformStages {
  stage : nat;
  cores : list nat;
  observability : list nat;
  cacheLineInvLoc : option nat;
  isMainMemory : bool
}.

(** A [PathOption] is a possible [Path] for an [Event] through a given
  [Pipeline], together with a [SpecialEdgeMap] that adds any extra orderings
  associated with the option.

  For example, a cache miss may flush the pipeline, meaning that no subsequent
  (in program order) [Event]s will leave the fetch stage until the cache miss
  response is received.
*)
Record PathOption : Type := mkPathOption {
  optionName : string;
  evt : Event;
  path : Path;
  performStages : list PerformStages;
  sem : SpecialEdgeMap
}.

(** [PathOptions] represents a set of paths for a single event, such that only
  one will be chosen in any given scenario. *)
Definition PathOptions : Type := list PathOption.

(** [Scenario] represents a set of paths for different events, such that the
  set of [PathOption]s taken together represent the path of each [Event] in
  a scenario. *)
Definition Scenario : Type := list PathOption.

(** A [Pipeline] is defined as a set of [Stage]s, a function [pathsFor] that
  maps each event into a list of its possible [PathOptions] *)
Record Pipeline := mkPipeline {
  pipename : string;
  stages : list Stage;
  pathsFor : Event -> PathOptions
}.

(** ** Edges in the Global Ordering Graph *)

Open Scope string_scope.
Open Scope list_scope.

(** Given an [Event] and the [Path] it takes, produce the associated set of
  global edges for that path. *)
Fixpoint IntraEventGlobalEdges
  (e : Event)
  (p : Path)
  : GlobalGraph :=
  match p with
  | h::t =>
    match t with
    | th::_ =>
      ((h, eiid e), (th, eiid e), "IntraEvent") :: IntraEventGlobalEdges e t
    | [] => []
    end
  | [] => []
  end.

(** Calculate the [IntraEventGlobalEdges] for each [Path] in a [Scenario]. *)
Fixpoint ScenarioIntraEventGlobalEdges
  (l : Scenario)
  : GlobalGraph :=
  match l with
  | (mkPathOption _ e p _ sem)::t =>
    IntraEventGlobalEdges e p ++ ScenarioIntraEventGlobalEdges t
  | [] => []
  end.

(** Convert a list of local edges at a given [location] into the corresponding
  set of global edges. *)
Fixpoint IntraLocationGlobalEdges'
  (l : location)
  (le : list (Event * Event))
  : GlobalGraph :=
  match le with
  | (e1,e2)::t =>
    ((l, eiid e1), (l, eiid e2), "IntraLocation")
    :: IntraLocationGlobalEdges' l t
  | [] => []
  end.

(** Convert the list of local edges at each [location] in a [Scenario]
  [Pipeline] into the corresponding set of global edges. *)
Fixpoint IntraLocationGlobalEdges
  (l : location)
  (le : list (list (Event * Event)))
  : GlobalGraph :=
  match le with
  | h::t =>
    IntraLocationGlobalEdges' l h ++ IntraLocationGlobalEdges (S l) t
  | [] => []
  end.

(** Given a set of events, sort them into a list of lists based on the first
  location in their paths. *)
Fixpoint EventsSortedByFirstLocation'
  (l : list (list Event))
  (s : Scenario)
  : list (list Event) :=
  match s with
  | h::t =>
    let e := evt h in
    let p := path h in
    match p with
    | h::_ => EventsSortedByFirstLocation' (AppendToNth l h e) t
    | [] => EventsSortedByFirstLocation' l t
    end
  | [] => l
  end.

(** Given a set of events, sort them into a list of lists based on their
  processor ID. *)
Definition EventsSortedByFirstLocation
  (s : Scenario)
  : list (list Event) :=
  EventsSortedByFirstLocation' [] s.

Module EventsSortedByFirstLocationExample.

Definition ev0 := mkev 0 (mkiiid 0 0) (Access W 0 1).
Definition ev1 := mkev 1 (mkiiid 0 1) (Access W 0 2).
Definition ev2 := mkev 2 (mkiiid 2 0) (Access W 0 3).

Definition NoSpecialEdges : SpecialEdgeMap := fun _ _ _ => [].
Definition DummyScenario e := mkPathOption "Dummy" e [1; 2] [] NoSpecialEdges.

Example e1 : EventsSortedByFirstLocation (map DummyScenario [ev0; ev1; ev2]) =
  [[]; [ev0; ev1; ev2]].
Proof.  cbv.  auto.  Qed.

End EventsSortedByFirstLocationExample.

(** Convert the list of local edges at each location in a [Scenario] into the
  corresponding set of global edges. *)
Definition ScenarioIntraLocationGlobalEdges
  (s : Scenario)
  (pipeline : Pipeline)
  : GlobalGraph :=
  let path_pairs := map PairConsecutive (map path s) in
  let local_reorderings := map localReordering (stages pipeline) in
  IntraLocationGlobalEdges 0
    (IntraLocationEdges path_pairs (EventsSortedByFirstLocation s) local_reorderings).

Fixpoint PartitionAtEvent'
  (h t : list Event)
  (e : Event)
  : list Event * list Event :=
  match t with
  | th::t' =>
    if beq_nat (eiid e) (eiid th)
      then (h, t')
      else PartitionAtEvent' (h ++ [th]) t' e
  | [] => ([], [])
  end.

(** Given a list [l] of [Event]s, return the list of [Event]s before [e] and
  after [e], with before and after determined by program order index. *)
Definition PartitionAtEvent
  (l : list Event)
  (e : Event)
  : list Event * list Event :=
  PartitionAtEvent' [] l e.

Fixpoint LocalEvents
  (l : list Event)
  (e : Event)
  : list Event :=
  match l with
  | h::t =>
    match (nat_compare (proc (iiid h)) (proc (iiid e))) with
    | Eq => h :: LocalEvents t e
    | _  =>      LocalEvents t e
    end
  | [] => []
  end.

(** Calculate the set of all special global edges due to the [Event] path
  choices in a given [Scenario] *)
Fixpoint ScenarioPathSpecialEdges'
  (s : Scenario)
  (prev_events : list Event)
  : GlobalGraph :=
  match s with
  | (mkPathOption _ e p _ sem)::t =>
    let local_events := LocalEvents (prev_events ++ map evt s) e in
    let (e_before, e_after) := PartitionAtEvent local_events e in
    sem e_before e e_after
    ++ ScenarioPathSpecialEdges' t (prev_events ++ [e])
  | [] => []
  end.

(** Calculate the set of all special global edges due to the [Event] path
  choices in a given [Scenario] *)
Fixpoint ScenarioPathSpecialEdges
  (s : Scenario)
  : GlobalGraph :=
  ScenarioPathSpecialEdges' s [].

(** Calculate the set of all special global edges at a given [location] *)
Definition LocationSpecialEdges
  (e : Event)
  (events : list Event)
  (m : SpecialEdgeMap)
  : GlobalGraph :=
  let local_events := LocalEvents events e in
  let (e_before, e_after) := PartitionAtEvent local_events e in
  m e_before e e_after.

(** Calculate the set of all special global edges due to the pipelines in a
  given [PathOption] *)
Fixpoint PathPipelineSpecialEdges
  (l : list location)
  (e : Event)
  (events : list Event)
  (p : Pipeline)
  : GlobalGraph :=
  match l with
  | h::t =>
    let m := nth h (map specialEdges (stages p)) (fun _ _ _ => []) in
    LocationSpecialEdges e events m
    ++ PathPipelineSpecialEdges t e events p
  | [] => []
  end.

(** Calculate the set of all special global edges due to the pipelines in a
  given [Scenario] *)
Fixpoint ScenarioPipelineSpecialEdges
  (s : Scenario)
  (p : Pipeline)
  : GlobalGraph :=
  match s with
  | h::t =>
    PathPipelineSpecialEdges (path h) (evt h) (map evt s) p
    ++ ScenarioPipelineSpecialEdges t p
  | [] => []
  end.

(** Calculate the set of all global edges in a [Scenario] *)
Definition ScenarioEdges
  (t : string)
  (p : Pipeline)
  (s : Scenario)
  : GraphTree GlobalEvent :=
  let (t_start, t) := TimerStartHook t in
  let result := GraphTreeLeaf _ t (
    ScenarioIntraLocationGlobalEdges s p
    ++
    ScenarioIntraEventGlobalEdges s
    ++
    ScenarioPipelineSpecialEdges s p
    ++
    ScenarioPathSpecialEdges s) in
  TimerStopHook "ScenarioEdges" t_start result.

Module EdgesExample3.
Import EdgesExample.
Import EdgesExample2.

Definition NoSpecialEdges : SpecialEdgeMap := fun _ _ _ => [].

Definition my_stages := [
  mkStage "F"  FIFO NoSpecialEdges;
  mkStage "FL" FIFO NoSpecialEdges;
  mkStage "FS" FIFO NoSpecialEdges;
  mkStage "L"  FIFO NoSpecialEdges;
  mkStage "S"  FIFO NoSpecialEdges;
  mkStage "LC" FIFO NoSpecialEdges;
  mkStage "SC" FIFO NoSpecialEdges;
  mkStage "C"  FIFO NoSpecialEdges].

Definition my_paths_for (e : Event) :=
  match dirn e with
  | R =>
    [mkPathOption "Read"  e [0; 1; 3; 5; 7] [mkPerformStages 3 [0] [0] None true]
     NoSpecialEdges]
  | W =>
    [mkPathOption "Write" e [0; 2; 4; 6; 7] [mkPerformStages 4 [0] [0] None true]
     NoSpecialEdges]
  end.

Definition my_pipeline :=
  mkPipeline "SamplePipeline" my_stages my_paths_for.

(** Since each event only has one possible [PathOption] in this pipeline, there
  is only one [Scenario] to consider. *)
Definition my_scenarios := [[
    mkPathOption "Write" ev0 [0; 2; 4; 6; 7] [mkPerformStages 4 [0] [0] None true]
      NoSpecialEdges;
    mkPathOption "Read"  ev1 [0; 1; 3; 5; 7] [mkPerformStages 3 [0] [0] None true]
      NoSpecialEdges;
    mkPathOption "Read"  ev2 [0; 1; 3; 5; 7] [mkPerformStages 3 [0] [0] None true]
      NoSpecialEdges;
    mkPathOption "Write" ev3 [0; 2; 4; 6; 7] [mkPerformStages 4 [0] [0] None true]
      NoSpecialEdges
  ]].

Definition my_scenario : Scenario := hd [] my_scenarios.

Definition my_global_edges :=
  ScenarioEdges "my_sample " my_pipeline my_scenario.

Example e_my_global_edges :
  my_global_edges = GraphTreeLeaf _ "my_sample " [
   (** location 0 *)
   ((0, 0), (0, 1), "IntraLocation"); ((0, 0), (0, 2), "IntraLocation");
   ((0, 0), (0, 3), "IntraLocation"); ((0, 1), (0, 2), "IntraLocation");
   ((0, 1), (0, 3), "IntraLocation"); ((0, 2), (0, 3), "IntraLocation");
   (** location 1 *)
   ((1, 1), (1, 2), "IntraLocation");
   (** location 2 *)
   ((2, 0), (2, 3), "IntraLocation");
   (** location 3 *)
   ((3, 1), (3, 2), "IntraLocation");
   (** location 4 *)
   ((4, 0), (4, 3), "IntraLocation");
   (** location 5 *)
   ((5, 1), (5, 2), "IntraLocation");
   (** location 6 *)
   ((6, 0), (6, 3), "IntraLocation");
   (** location 7 *)
   ((7, 1), (7, 2), "IntraLocation"); ((7, 0), (7, 3), "IntraLocation");
   (** event 0 *)
   ((0, 0), (2, 0), "IntraEvent"); ((2, 0), (4, 0), "IntraEvent");
   ((4, 0), (6, 0), "IntraEvent"); ((6, 0), (7, 0), "IntraEvent");
   (** event 1 *)
   ((0, 1), (1, 1), "IntraEvent"); ((1, 1), (3, 1), "IntraEvent");
   ((3, 1), (5, 1), "IntraEvent"); ((5, 1), (7, 1), "IntraEvent");
   (** event 2 *)
   ((0, 2), (1, 2), "IntraEvent"); ((1, 2), (3, 2), "IntraEvent");
   ((3, 2), (5, 2), "IntraEvent"); ((5, 2), (7, 2), "IntraEvent");
   (** event 3 *)
   ((0, 3), (2, 3), "IntraEvent"); ((2, 3), (4, 3), "IntraEvent");
   ((4, 3), (6, 3), "IntraEvent"); ((6, 3), (7, 3), "IntraEvent")].
Proof.
cbv.  auto.
Qed.

End EdgesExample3.


From Hammer Require Import Hammer.

From Tait Require Import minlog_mode.

Ltac dcase x := generalize (refl_equal x); pattern x at -1; case x.

Inductive nc_type (A:Set) : Prop := nc : A -> nc_type A.
Arguments nc [A].
Notation " t ! " := (nc_type t) (at level 50).

Inductive existsnc_t (A : Prop) (P : A -> Type) : Type :=
existsnc_I : forall x : A, P x -> existsnc_t A P.

Notation "'existsnc' x : t , p" := (existsnc_t (t!) (fun x => p))
(at level 200, x ident) : type_scope.

Notation "'forallnc' x : t , p" := (forall x:t!,p)
(at level 200, x ident) : type_scope.

Notation "'letnc' x := y 'in' p" :=
(forall x, nc x = y -> p)
(at level 200, x ident) : type_scope.

Ltac existsnc_i wit := match goal with
|- (existsnc_t ?A ?P) => apply (existsnc_I A P (nc wit))
end.

Set Implicit Arguments.

Axiom ProofRelevance : forall (A:Set)(a b:A), nc a = nc b -> a = b.

Lemma nc_ex : forall (A:Set)(p: A!), exists r, p = nc r.
intros.
case p; intro r.
exists r.
reflexivity.
Defined.

Definition nc1 (A B:Set)(f:A->B) :=
fun (a:A!) => let (a'):=a in nc (f a').

Check nc1.
Check (nc1 pred).

Definition nc2 (A B C:Set)(f:A->B->C) :=
fun (a:A!)(b:B!) => let (a'):=a in let (b'):=b in nc (f a' b').

Check nc2.
Check (nc2 plus).
Check (nc2 plus (nc 0) (nc 3)).
Eval compute in (nc2 plus (nc 0) (nc 3)).

Definition nc3 (A B C D:Set)(f:A->B->C->D) :=
fun (a:A!)(b:B!)(c:C!) =>
let (a'):=a in let (b'):=b in let (c'):=c in nc (f a' b' c').

Definition ncP (A:Set)(P:A->Prop) :=
fun (a:A!) => letnc a':=a in P a'.

Definition ncP2 (A B:Set)(P:A->B->Prop) :=
fun (a:A!)(b:B!) => letnc a':=a in letnc b':=b in P a' b'.

Unset Implicit Arguments.

Ltac ncsimp := match goal with
|H : (nc _ = nc _) |- _ =>

generalize (ProofRelevance H); clear H; intro H
|H : (letnc id := nc ?t in _) |- _ =>
generalize (H t (refl_equal (nc t))); clear H; intro H
| |- nc _ = nc _ => f_equal
end.

Ltac nc:=intros;
repeat (progress (match goal with
| a:(_ !) |-_ =>
(unfold a in *; clear a) ||
(dcase a; intro; intro; subst)
end));
unfold nc1, nc2 in *; repeat ncsimp; try subst.

Ltac nc2:= match goal with
|H : context [match ?t with nc _ => _ end] |- _ =>
dcase t; intro;
let H' := fresh in
(intro H'; subst || (rewrite_all H'; clear H'))
|H : (letnc id := ?t in _) |- _ =>
elim (nc_ex t); intro ;
let H':= fresh in
(intro H'; subst || (rewrite_all H';clear H'))
end.

Section ProofRelevance.

Inductive test : Prop := A | B :test.

Lemma EqPropCons_ProofIrr :
A=B <-> forall (P:Prop)(p p':P), p = p'.
split.
intros.
set (discr := fun a => match a with A => p | B => p' end).
exact
(eq_ind A
(fun a : test => discr A = discr a)
(refl_equal p) B H).
intros.
apply (H _ A B).
Qed.

Lemma ProofIrr_NoHope :
(forall (P:Prop)(p p':P), p = p') <-> nc 0 = nc 1.
Proof. hammer_hook "nc" "nc.ProofIrr_NoHope".
split.
intro.
apply H.
intros.
set (discr := fun a => match a with
| nc O => p
| nc (S _) => p' end).
exact
(eq_ind (nc 0)
(fun a => discr (nc 0) = discr a)
(refl_equal p) (nc 1) H).
Qed.

End ProofRelevance.