(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** Support for defining and reasoning about sub-lists. *)

Require Import List.
Require Import ListSet.
Require Import Bool.
Require Import Permutation.
Require Import Equivalence.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import RelationClasses.
Require Import Lia.
Require Import CoqLibAdd.
Require Import ListAdd.
Require Import SortingAdd.
Require Import Assoc.
Require Import Program.

Section Sublist.
  (** * Sublists *)

  Section sublist.
    Context {A:Type}.
    Inductive sublist : list A -> list A -> Prop :=
    | sublist_nil : sublist nil nil
    | sublist_cons :
        forall x l1 l2, sublist l1 l2 -> sublist (x::l1) (x::l2)
    | sublist_skip :
        forall x l1 l2, sublist l1 l2 -> sublist l1 (x::l2)
    .

    Hint Constructors sublist : qcert.

    Lemma sublist_In {l1 l2:list A} :
      sublist l1 l2 -> forall x, In x l1 -> In x l2.
    Proof.
      induction 1; simpl; intuition.
    Qed.

    Lemma sublist_nil_l l : sublist nil l.
    Proof.
      induction l; intuition.
    Qed.

    Lemma sublist_nil_r l : sublist l nil -> l = nil.
    Proof.
      inversion 1; trivial.
    Qed.

    Global Instance sublist_incl_sub : subrelation sublist (@incl A).
    Proof.
      intros l1 l2 subl x inx.
      eapply sublist_In; eauto.
    Qed.

    Hint Immediate sublist_nil_l : qcert.

    Global Instance sublist_pre : PreOrder sublist.
    Proof.
      constructor; red; intros l; [induction l; intuition | ].
      intros y z; revert l y. induction z.
      - intros.
        apply sublist_nil_r in H0; subst.
        apply sublist_nil_r in H; subst.
        auto with qcert.
      - intros.
        inversion H0; subst; eauto 3 with qcert.
        inversion H; subst; eauto 3 with qcert.
    Qed.

    Lemma sublist_trans l1 l2 l3:
      sublist l1 l2 -> sublist l2 l3 -> sublist l1 l3.
    Proof.
      intros.
      apply (PreOrder_Transitive l1 l2 l3); assumption.
    Qed.

    Lemma sublist_length {l1 l2} : sublist l1 l2 -> length l1 <= length l2.
    Proof.
      revert l1. induction l2; simpl; intros.
      - apply sublist_nil_r in H; subst; auto.
      - inversion H; subst; simpl; auto with arith.
    Qed.

    Lemma sublist_length_eq {l1 l2} :
      sublist l1 l2 -> length l1 = length l2 -> l1 = l2.
    Proof.
      revert l1; induction l2; simpl.
      - intros; apply sublist_nil_r in H; subst; auto.
      - inversion 1; subst; simpl; intros.
        + f_equal; auto with arith.
        + apply sublist_length in H2. lia.
    Qed.

    Global Instance sublist_antisymm : Antisymmetric (list A) eq sublist.
    Proof.
      red; intros x y sub1 sub2.
      apply (sublist_length_eq sub1).
      apply sublist_length in sub1.
      apply sublist_length in sub2.
      lia.
    Qed.

    Global Instance sublist_part : PartialOrder eq sublist.
    Proof.
      unfold PartialOrder, relation_equivalence, relation_conjunction,
      predicate_equivalence, predicate_intersection, Basics.flip; simpl.
      split; intros; subst; trivial; intuition.
      apply sublist_antisymm; trivial.
    Qed.

    Global Instance sublist_NoDup : Proper (sublist --> impl) (@NoDup A).
    Proof.
      repeat red; unfold flip.
      induction x; simpl; intros.
      - apply sublist_nil_r in H; subst; auto.
      - inversion H0; subst.
        inversion H; subst; auto.
        constructor; auto.
        intro inn; apply H3.
        eapply sublist_In; eauto.
    Qed.

    Hint Constructors sublist : qcert.

    Lemma sublist_app {a1 b1 a2 b2:list A}:
      sublist a1 b1 ->
      sublist a2 b2 ->
      sublist (a1 ++ a2) (b1 ++ b2).
    Proof.
      revert a1 a2 b2.
      induction b1; inversion 1; subst; simpl; eauto with qcert.
    Qed.

    Lemma sublist_app_l (l1 l2:list A) : sublist l1 (l1 ++ l2).
    Proof.
      induction l1; simpl.
      - apply sublist_nil_l.
      - apply sublist_cons. trivial.
    Qed.

    Lemma sublist_app_r (l1 l2:list A) : sublist l2 (l1 ++ l2).
    Proof.
      induction l1; simpl.
      - reflexivity.
      - apply sublist_skip. trivial.
    Qed.

    Lemma filter_sublist f (l:list A) : sublist (filter f l) l.
    Proof.
      induction l; simpl.
      - reflexivity.
      - match_destr.
        + apply sublist_cons; trivial.
        + apply sublist_skip; trivial.
    Qed.

  End sublist.

  Lemma cut_down_to_sublist
        {A B} {dec:EqDec A eq}
        (l:list (A*B)) (l2:list A) :
    sublist (cut_down_to l l2) l.
  Proof.
    unfold cut_down_to.
    apply filter_sublist.
  Qed.

  Hint Constructors sublist : qcert.

  Lemma sublist_map {A B} {l1 l2} (f:A->B) :
    sublist l1 l2 -> sublist (map f l1) (map f l2).
  Proof.
    revert l1; induction l2; intros.
    - apply sublist_nil_r in H; subst; simpl; auto with qcert.
    - inversion H; subst; simpl; auto with qcert.
  Qed.

  Lemma sublist_domain {A B} {l1 l2:list(A*B)} :
    sublist l1 l2 -> sublist (domain l1) (domain l2).
  Proof.
    intros; apply sublist_map; trivial.
  Qed.

  Lemma sublist_set_inter {A} dec (l1 l2 l3:list A):
    sublist l1 l3 ->
    sublist (set_inter dec l1 l2) l3.
  Proof.
    revert l1 l2.
    induction l3; intros.
    - apply sublist_nil_r in H; subst; simpl; trivial with qcert.
    - inversion H; subst.
      + simpl.
        match_destr; eauto with qcert.
      + eauto with qcert.
  Qed.

  Global Instance Forall_sublist {A} {P:A->Prop} :
    Proper (sublist --> impl) (Forall P).
  Proof.
    repeat red; unfold flip.
    induction x; intros.
    - apply sublist_nil_r in H; subst; trivial.
    - inversion H0; clear H0; subst.
      inversion H; clear H; subst; auto.
  Qed.

  Lemma forallb_sublist {A} f (l1 l2:list A) :
    sublist l1 l2 ->
    forallb f l2 = true ->
    forallb f l1 = true.
  Proof.
    intros.
    eapply forallb_incl; eauto.
    apply sublist_incl_sub; trivial.
  Qed.

  Lemma forallb_ordpairs_sublist {A} f (l1 l2:list A) :
    sublist l1 l2 ->
    forallb_ordpairs f l2 = true ->
    forallb_ordpairs f l1 = true.
  Proof.
    revert l2.
    induction l1; simpl; trivial; intros.
    induction l2; simpl; inversion H; subst; simpl in * ;
      rewrite andb_true_iff in *.
    - rewrite (IHl1 l2); intuition.
      eapply forallb_sublist; eauto.
    - intuition.
  Qed.

  Lemma forallb_ordpairs_refl_sublist {A} f (l1 l2:list A) :
    sublist l1 l2 ->
    forallb_ordpairs_refl f l2 = true ->
    forallb_ordpairs_refl f l1 = true.
  Proof.
    repeat rewrite forallb_ordpairs_refl_conj.
    repeat rewrite andb_true_iff; intuition.
    - eapply forallb_ordpairs_sublist; eauto.
    - eapply forallb_sublist; eauto.
  Qed.

  Global Instance StronglySorted_sublist {A} {R:A->A->Prop} : Proper (sublist --> impl) (StronglySorted R).
  Proof.
    repeat red; unfold flip.
    induction x; simpl; intros.
    - apply sublist_nil_r in H; subst; trivial.
    - inversion H0; clear H0; subst.
      inversion H; clear H; subst; auto 3.
      rewrite <- H2 in H4; constructor; auto.
  Qed.

  Lemma is_list_sorted_sublist {A} {R} {Rdec} {l l':list A}
        `{Transitive A R} :
    @is_list_sorted A R Rdec l = true ->
    sublist l' l ->
    is_list_sorted Rdec l' = true.
  Proof.
    repeat rewrite sorted_StronglySorted by auto.
    intros ? sl.
    rewrite sl.
    trivial.
  Qed.

  Hint Immediate sublist_nil_l : qcert.

  Lemma StronglySorted_incl_sublist {A R l1 l2} `{EqDec A eq} `{StrictOrder A R} :
    StronglySorted R l1 ->
    StronglySorted R l2 ->
    (forall x : A, In x l1 -> In x l2) ->
    sublist l1 l2.
  Proof.
    intros.
    generalize (StronglySorted_NoDup _ H1).
    generalize (StronglySorted_NoDup _ H2).
    revert l1 H1 H2 H3.
    induction l2; simpl.
    - destruct l1; simpl; auto 1 with qcert.
      intros. specialize (H3 a); intuition.
    - intros. inversion H2; subst.
      destruct l1; auto 1 with qcert.
      simpl in *.
      inversion H1; subst.
      inversion H4; inversion H5; subst.
      destruct (a == a0); unfold Equivalence.equiv, complement in *; subst.
      unfold equiv in *.
      + apply sublist_cons. apply IHl2; trivial.
        intros x inn.
        specialize (H3 x); intuition. subst; intuition.
      + apply sublist_skip. apply IHl2; auto.
        simpl; intros x inn.
        generalize (H3 a0).
        specialize (H3 _ inn). intuition; subst.
        * intuition.
        * rewrite Forall_forall in H9,H11.
          specialize (H11 _ H3).
          specialize (H9 _ H14).
          rewrite H9 in H11.
          eelim irreflexivity; eauto.
  Qed.

  Lemma Sorted_incl_sublist {A R l1 l2} `{EqDec A eq} `{StrictOrder A R}:
    Sorted R l1 ->
    Sorted R l2 ->
    (forall x : A, In x l1 -> In x l2) ->
    sublist l1 l2.
  Proof.
    intros.
    apply StronglySorted_incl_sublist; trivial;
      apply Sorted_StronglySorted; trivial; apply StrictOrder_Transitive.
  Qed.

  Lemma Sorted_incl_both_eq {A R l1 l2} `{EqDec A eq} `{StrictOrder A R}:
    Sorted R l1 ->
    Sorted R l2 ->
    (forall x : A, In x l1 -> In x l2) ->
    (forall x : A, In x l2 -> In x l1) ->
    l1 = l2.
  Proof.
    intros.
    apply sublist_antisymm; apply Sorted_incl_sublist; trivial.
  Qed.

  Lemma insertion_sort_equivlist_strong {A R R_dec} `{EqDec A eq} `{StrictOrder A R} l l' (contr:asymmetric_over R l) :
    equivlist l l' ->
    @insertion_sort A R R_dec l =
    @insertion_sort A R R_dec l'.
  Proof.
    intros.
    generalize (equivlist_insertion_sort_strong R_dec contr H1); intros.
    apply Sorted_incl_both_eq; try apply insertion_sort_Sorted.
    intros. eapply equivlist_in; eauto.
    intros. symmetry in H2. eapply equivlist_in; eauto.
  Qed.

  Lemma insertion_sort_equivlist {A R R_dec} `{EqDec A eq} `{StrictOrder A R}  (contr:forall x y,  ~R x y -> ~R y x -> x = y) l l' :
    equivlist l l' ->
    @insertion_sort A R R_dec l =
    @insertion_sort A R R_dec l'.
  Proof.
    intros.
    apply insertion_sort_equivlist_strong; eauto.
    eapply asymmetric_asymmetric_over; trivial.
  Qed.

  Lemma sublist_skip_l {A} (a:A) {l1 l2} :
    sublist (a::l1) l2 ->
    sublist l1 l2.
  Proof.
    revert l1.
    induction l2; inversion 1; subst.
    - apply sublist_skip; trivial.
    - apply sublist_skip. eauto.
  Qed.

  Lemma sublist_cons_eq_inv {A a l1 l2} :
    @sublist A (a::l1) (a::l2) ->
    sublist l1 l2.
  Proof.
    inversion 1; subst; trivial.
    rewrite <- H2. apply sublist_skip; reflexivity.
  Qed.

  Lemma sublist_filter {A} (f:A->bool) {l1 l2} :
    sublist l1 l2 -> sublist (filter f l1) (filter f l2).
  Proof.
    revert l1. induction l2; simpl; intros.
    - apply sublist_nil_r in H; subst; simpl; auto 1 with qcert.
    - inversion H; subst.
      + specialize (IHl2 _ H2); simpl.
        destruct (f a); [apply sublist_cons | ]; congruence.
      + specialize (IHl2 _ H2); simpl.
        destruct (f a); [apply sublist_skip | ]; congruence.
  Qed.

  Lemma sublist_cons_inv' {A B l1 a l2} :
    sublist l1(a::l2) ->
    NoDup (@domain A B (a::l2)) ->
    (exists l',
        l1 = a::l' /\ sublist l' l2)
    \/
    (~ In (fst a) (domain l1)
     /\ sublist l1 l2).
  Proof.
    inversion 1; subst.
    intuition; eauto.
    intros; right. split; trivial.
    generalize (sublist_In (sublist_domain H2)); intros inn.
    inversion H0; subst.
    auto.
  Qed.

  Lemma sublist_cons_inv {A B l1 a l2 R R_dec} `{StrictOrder A R}:
    sublist l1(a::l2) ->
    @is_list_sorted A R R_dec (@domain _ B (a::l2)) = true ->
    (exists l',
        l1 = a::l' /\ sublist l' l2)
    \/
    (~ In (fst a) (domain l1)
     /\ sublist l1 l2).
  Proof.
    inversion 1; subst.
    intuition; eauto.
    intros; right. split; trivial.
    generalize (sublist_In (sublist_domain H3)); intros inn.
    apply is_list_sorted_NoDup in H1; eauto.
    inversion H1; subst.
    auto.
  Qed.

  Lemma sublist_cons_inv_simple {A l1} {a:A} {l2} :
    sublist l1(a::l2) ->
    NoDup (a::l2) ->
    (exists l',
        l1 = a::l' /\ sublist l' l2)
    \/
    (~ In a l1
     /\ sublist l1 l2).
  Proof.
    inversion 1; subst.
    intuition; eauto.
    intros; right. split; trivial.
    generalize (sublist_In H2); intros inn.
    inversion H0; subst.
    auto.
  Qed.

  Lemma sublist_dec {A}  {dec:EqDec A eq} (l1 l2 : list A) :
    {sublist l1 l2} + { ~ sublist l1 l2}.
  Proof.
    revert l1.
    induction l2; intros l1; destruct l1.
    - left; trivial with qcert.
    - right; inversion 1.
    - left; apply sublist_nil_l.
    - destruct (a0 == a).
      + destruct (IHl2 l1).
        * left. rewrite e. eauto with qcert.
        * right. rewrite e. intro subl.
          apply sublist_cons_eq_inv in subl.
          intuition.
      + destruct (IHl2 (a0::l1)).
        * left. apply sublist_skip; trivial.
        * right; inversion 1; subst; intuition.
  Defined.

  Lemma sublist_remove {A} dec (x:A) l1 l2 :
    sublist l1 l2 ->
    sublist (remove dec x l1) (remove dec x l2).
  Proof.
    revert l1. induction l2; simpl; intros.
    - apply sublist_nil_r in H; subst; simpl; auto 1 with qcert.
    - inversion H; subst.
      + specialize (IHl2 _ H2); simpl.
        match_destr. apply sublist_cons; auto.
      + specialize (IHl2 _ H2); simpl.
        match_destr.
        apply sublist_skip; auto.
  Qed.

  Lemma sublist_nin_remove {A} dec (l1 l2:list (A)) a :
    ~ In a l1 -> sublist l1 l2 -> sublist l1 (remove dec a l2).
  Proof.
    intros.
    apply (sublist_remove dec a) in H0.
    rewrite (nin_remove dec l1 a) in H0 by trivial.
    trivial.
  Qed.

  Lemma assoc_lookupr_nodup_sublist {A B} {R_dec:forall a a' : A, {a = a'} + {a <> a'}} {l1 l2} {a:A} {b:B} :
    NoDup (domain l2) ->
    sublist l1 l2 ->
    assoc_lookupr R_dec l1 a = Some b ->
    assoc_lookupr R_dec l2 a = Some b.
  Proof.
    revert a b l1.  induction l2; simpl; intros.
    - apply sublist_nil_r in H0; subst. simpl in *; discriminate.
    - destruct a; simpl.
      generalize (sublist_cons_inv' H0 H).
      inversion H; subst.
      destruct 1.
      + destruct H2 as [? [??]]; subst.
        simpl in H1.
        case_eq (assoc_lookupr R_dec x a0); [ intros? eqq | intros eqq]
        ; rewrite eqq in H1.
        * inversion H1; clear H1; subst.
          rewrite (IHl2 _ _ _ H5 H3 eqq); trivial.
        * destruct (R_dec a0 a); inversion H1; subst.
          case_eq (assoc_lookupr R_dec l2 a); trivial.
          intros.
          apply assoc_lookupr_in in H2.
          apply in_dom in H2.
          congruence.
      + simpl in H2. destruct H2.
        rewrite (IHl2 _ _ _ H5 H3 H1); trivial.
  Qed.

  Lemma insertion_sort_insert_sublist_self {A R}
        R_dec (a:A) l :
    sublist l (@insertion_sort_insert A R R_dec a l).
  Proof.
    induction l; simpl.
    - apply sublist_skip; reflexivity.
    - match_destr.
      + apply sublist_skip; apply sublist_cons; reflexivity.
      + match_destr; try reflexivity.
        apply sublist_cons.
        eauto.
  Qed.

  Lemma insertion_sort_insert_sublist_prop {A R} {rstrict:StrictOrder R}
        (trich:forall a b, {R a b} + {a = b} + {R b a})
        R_dec a l1 l2:
    is_list_sorted R_dec l2 = true ->
    sublist l1 l2 ->
    sublist (@insertion_sort_insert A R R_dec a l1)
            (@insertion_sort_insert A R R_dec a l2).
  Proof.
    unfold Proper, respectful; intros; subst.
    revert l1 H H0. induction l2.
    - inversion 2; subst; simpl; reflexivity.
    - intros. apply sublist_cons_inv_simple in H0;
                [ | apply (is_list_sorted_NoDup R_dec); trivial].
      destruct H0 as [[?[??]]|[??]]; subst.
      + simpl. match_destr.
        * do 2 apply sublist_cons; eauto.
        * match_destr; apply sublist_cons; trivial.
          apply IHl2; trivial.
          eapply is_list_sorted_cons_inv; eauto.
      + simpl. match_destr.
        * rewrite IHl2; trivial; [| eapply is_list_sorted_cons_inv; eauto].
          rewrite insertion_sort_insert_forall_lt.
          { apply sublist_cons; apply sublist_skip; reflexivity. }
          apply sorted_StronglySorted in H; [| eapply StrictOrder_Transitive].
          inversion H; subst.
          revert H5. apply Forall_impl; intros.
          rewrite <- H2; trivial.
        * specialize (IHl2 l1).
          cut_to IHl2; trivial; [| eapply is_list_sorted_cons_inv; eauto].
          match_destr; [apply sublist_skip; trivial | ].
          destruct (trich a a0) as [[?|?]|?]; try congruence.
          subst.
          rewrite insertion_sort_insert_forall_lt; [ apply sublist_cons; trivial | ].
          rewrite H1.
          apply sorted_StronglySorted in H; [| eapply StrictOrder_Transitive].
          inversion H; subst. trivial.
  Qed.

  Lemma insertion_sort_sublist_proper {A R} {rstrict:StrictOrder R}
        (trich:forall a b, {R a b} + {a = b} + {R b a}) R_dec :
    Proper (sublist ==> sublist) (@insertion_sort A R R_dec).
  Proof.
    unfold Proper, respectful; intros.
    revert x H. induction y; simpl; inversion 1; subst; simpl; trivial.
    - specialize (IHy _ H2).
      apply insertion_sort_insert_sublist_prop; trivial.
      apply is_list_sorted_Sorted_iff.
      apply insertion_sort_Sorted.
    - rewrite IHy; trivial.
      apply insertion_sort_insert_sublist_self.
  Qed.

  Lemma sublist_of_sorted_sublist {A R} {rstrict:StrictOrder R}
        (trich:forall a b, {R a b} + {a = b} + {R b a})
        R_dec {l1 l2} :
    sublist (@insertion_sort A R R_dec l1) l2 ->
    forall l1',
      sublist l1' l1 ->
      sublist (insertion_sort R_dec l1') l2.
  Proof.
    intros.
    transitivity (insertion_sort R_dec l1); trivial.
    apply insertion_sort_sublist_proper; trivial.
  Qed.

  Lemma incl_NoDup_sublist_perm {A} {dec:EqDec A eq} {l1 l2:list A} :
    NoDup l1 ->
    incl l1 l2 ->
    exists l1', Permutation l1 l1' /\ sublist l1' l2.
  Proof.
    unfold incl.
    revert l1.
    induction l2; simpl.
    - destruct l1; simpl; eauto 3 with qcert.
      intros ? inn.
      specialize (inn a); intuition.
    - intros.
      case_eq (In_dec dec a l1); intros.
      + destruct (in_split _ _ i) as [x [y ?]]; subst.
        assert (perm:Permutation (x ++ a :: y) (a::x ++ y))
          by (rewrite Permutation_middle; reflexivity).
        rewrite perm in H.
        inversion H; clear H; subst.
        destruct (IHl2 (x++y)) as [l1' [l1'perm l1'incl]]; trivial.
        * intros ? inn.
          { destruct (H0 a0); trivial.
            - rewrite perm; simpl; intuition.
            - subst. intuition.
          }
        * exists (a::l1').
          { split.
            - rewrite perm.
              eauto.
            - apply sublist_cons.
              trivial.
          }
      + destruct (IHl2 l1 H) as [x [perm subl]].
        * intros ? inn.
          destruct (H0 _ inn); subst; intuition.
        * exists x; split; trivial.
          apply sublist_skip.
          trivial.
  Qed.

  Lemma incl_NoDup_length_le {A} {dec:EqDec A eq} {l1 l2:list A} :
    NoDup l1 ->
    incl l1 l2 ->
    length l1 <= length l2.
  Proof.
    intros nd inc.
    destruct (incl_NoDup_sublist_perm nd inc) as [l1' [perm subl]].
    rewrite (Permutation_length perm).
    apply sublist_length.
    trivial.
  Qed.

  Lemma find_fresh_from {A} {dec:EqDec A eq} (bad l:list A) :
    length l > length bad ->
    NoDup l ->
    {y | find (fun x : A => if in_dec equiv_dec x bad then false else true) l = Some y}.
  Proof.
    rewrite find_filter.
    unfold hd_error.
    match_case; eauto; intros.
    generalize (filter_nil_implies_not_pred _ l H); intros.
    cut (length l <= length bad); [intuition|].
    apply incl_NoDup_length_le; trivial.
    intros ? inn.
    specialize (H2 _ inn).
    match_destr_in H2.
  Defined.

  Lemma concat_sublist {A} (ls:list (list A)) :
    Forall (fun x : list A => sublist x (concat ls)) ls.
  Proof.
    induction ls; simpl; trivial.
    constructor.
    - apply sublist_app_l.
    - revert IHls.
      apply Forall_impl; intros ? subl.
      rewrite subl.
      apply sublist_app_r.
  Qed.

  Lemma sublist_perm_head {A:Type} {l1 l2 : list A} :
    sublist l1 l2 ->
    exists t,
      Permutation (l1++t) l2.
  Proof.
    intros subl; induction subl.
    - exists nil; simpl; reflexivity.
    - destruct IHsubl as [t perm].
      simpl.
      exists t.
      rewrite <- perm.
      reflexivity.
    - destruct IHsubl as [t perm].
      exists (x::t).
      rewrite <- perm.
      rewrite <- Permutation_cons_app; reflexivity.
  Qed.

  Lemma Permutation_sublist_pullback_r {A:Type} {l1 l1' l2:list A} :
    sublist l1 l1' ->
    Permutation l1 l2 ->
    exists l2',
      Permutation l1' l2' /\
      sublist l2 l2'.
  Proof.
    intros subl perm.
    revert l1' subl.
    revert l1 l2 perm.
    change (forall l1 l2 : list A,
               Permutation l1 l2 ->
               (fun l1 l2 => forall l1' : list A, sublist l1 l1' -> exists l2' : list A, Permutation l1' l2' /\ sublist l2 l2') l1 l2).
    apply Permutation_ind_bis; simpl; intros.
    - exists l1'; split; trivial.
    - dependent induction H1.
      + destruct (H0 _ H1) as [ll [perm subl]].
        exists (x::ll).
        split.
        * eauto.
        * constructor; trivial.
      + destruct (IHsublist x l l' H H0 (eq_refl _)) as [ll [perm subl]].
        exists (x0::ll).
        split.
        * eauto.
        * constructor; trivial.
    - revert l' H H0 H1.
      induction l1'; intros l' perm IH subl.
      + invcs subl.
      + specialize (IHl1' _ perm IH).
        invcs subl.
        * clear IHl1'.
          { revert l' H0 perm IH.
            induction l1'; intros l' subl perm1 IH1.
            - invcs subl.
            - invcs subl.
              + destruct (IH1 _ H0) as [ll [perm2 subl2]].
                exists (a0::a::ll); split.
                * rewrite perm_swap, perm2; trivial.
                * do 2 constructor; trivial.
              + destruct (IHl1' _ H1 perm1 IH1) as [ll [perm2 subl2]].
                exists (a0::ll); split.
                * rewrite <- perm2, perm_swap; trivial.
                * constructor; trivial.
          }
        * destruct (IHl1' H1) as [ll [perm2 subl2]].
          exists (a::ll).
          { split.
            - constructor; trivial.
            - constructor; trivial.
          }
    - destruct (H0 _ H3) as [ll [perm1 subl1]].
      destruct (H2 _ subl1) as [ll' [perm2 subl2]].
      exists ll'.
      split; trivial.
      rewrite <- perm2; trivial.
  Qed.

  Lemma Permutation_filter_pullback_r {A:Type} {f:A->bool} {l1 l2} :
    Permutation (filter f l1) l2 ->
    exists l2',
      l2 = filter f l2' /\ Permutation l1 l2'.
  Proof.
    cut (forall l1 l2 : list A,
            Permutation l1 l2 ->
            (fun l1 l2 => forall l1', l1 = filter f l1' ->
                                      exists l2',
                                        l2 = filter f l2' /\ Permutation l1' l2') l1 l2).
    { intros H; intros.
      specialize (H _ _ H0); simpl in H.
      specialize (H _ (eq_refl _)).
      eauto.
    }
    apply Permutation_ind_bis; simpl; intros.
    - exists l1'; split; trivial.
    - induction l1'; simpl in *; try discriminate.
      match_case_in H1; intros eqq; rewrite eqq in H1.
      + invcs H1.
        destruct (H0 _ (eq_refl _))
          as [ll [? perm]]; subst.
        exists (a::ll); split; simpl.
        * rewrite eqq; trivial.
        * constructor; trivial.
      + destruct (IHl1' H1)
          as [ll [? perm]]; subst.
        exists (a::ll); split; simpl.
        * rewrite eqq; trivial.
        * constructor; trivial.
    - induction l1'; simpl in *; try discriminate.
      match_case_in H1; intros eqq1; rewrite eqq1 in H1.
      + invcs H1.
        clear IHl1'.
        revert l H H0 H4.
        induction l1'; simpl in *; try discriminate; intros.
        { match_case_in H4; intros eqq2; rewrite eqq2 in *.
          + invcs H4.
            destruct (H0 _ (eq_refl _))
              as [ll [? perm]]; subst.
            exists (a0::a::ll); split; simpl.
            * rewrite eqq1, eqq2; trivial.
            * rewrite perm_swap, perm; trivial.
          + destruct (IHl1' _ H H0 H4)
              as [ll [? perm]]; subst.
            exists (a0::ll); split; simpl.
            * rewrite eqq2; trivial.
            * rewrite perm_swap, perm; trivial.
        }
      + { destruct (IHl1' H1)
            as [ll [? perm]]; subst.
          exists (a::ll); split.
          + simpl; rewrite eqq1; trivial.
          + constructor; trivial.
        }
    - subst.
      destruct (H0 _ (eq_refl _))
        as [ll [? perm]]; subst.
      destruct (H2 _ (eq_refl _))
        as [ll2 [? perm2]]; subst.
      exists ll2; split; trivial.
      rewrite perm; trivial.
  Qed.

  Lemma filter_perm_head {A:Type} {f:A->bool} {l1 l2} :
    Permutation (filter f l1) l2 ->
    exists t,
      Permutation l1 (l2++t).
  Proof.
    intros.
    generalize (filter_sublist f l1); intros subl.
    destruct (sublist_perm_head subl)
      as [x perm].
    rewrite H in perm.
    symmetry in perm.
    eauto.
  Qed.

  Lemma Permutation_filter {A : Type} (f : A -> bool) (l l' : list A) :
    Permutation l l' -> Permutation (filter f l) (filter f l').
  Proof.
    revert l l'.
    apply Permutation_ind_bis; simpl; intros.
    - trivial.
    - match_case; eauto.
    - repeat match_case; eauto 2; intros.
      rewrite perm_swap; eauto.
    - rewrite H0, H2; trivial.
  Qed.

End Sublist.

Global Hint Immediate sublist_nil_l : qcert.


Set Warnings "-notation-overridden,-parsing".

Require Import Coq.Strings.String.
Require stdpp.stringmap.
Require Coq.setoid_ring.Ncring.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.setoid_ring.Algebra_syntax.

From STLCZK Require Import Maps.
From STLCZK Require Import StlcRing.
Import StlcRing.StlcRing.

Print StlcRing.

Module StlcGadget.

  Definition ty := StlcRing.ty.
  Definition Ty_Arrow := StlcRing.Ty_Arrow.
  Definition Ty_Ring := StlcRing.Ty_Ring.

  Local Open Scope string_scope.
  Context {R: Type}`{Coq.setoid_ring.Ncring.Ring_ops R}.

  Print StlcRing.
  Set Implicit Arguments.
  Inductive tm {a:Set} : Type :=
  (* pure STLC *)
  | tm_var : a -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : string -> ty -> tm -> tm
  (* Bool algebra *)
  |tm_boolc: bool -> tm
  | tm_and : tm -> tm -> tm
  | tm_or : tm -> tm -> tm
  | tm_neg: tm -> tm
  (* Ring algebra *)
  |tm_rc: R -> tm
  |tm_opp: tm -> tm
  |tm_add: tm -> tm -> tm
  |tm_mul: tm -> tm -> tm
  |tm_eq: tm -> tm -> tm
  |tm_if: tm -> tm -> tm -> tm
  (* GADGET MACRO *)
  |tm_gadget: string -> tm -> tm -> tm -> tm.

  Declare Custom Entry stlc_gadget.
  Declare Custom Entry stlc_gadget_ty.

  Notation "<[ e ]>" := e (e custom stlc_gadget at level 99).
  Notation "<[[ e ]]>" := e (e custom stlc_gadget_ty at level 99).
  Notation "( x )" := x (in custom stlc_gadget, x at level 99).
  Notation "( x )" := x (in custom stlc_gadget_ty, x at level 99).
  Notation "x" := x (in custom stlc_gadget at level 0, x constr at level 0).
  Notation "x" := x (in custom stlc_gadget_ty at level 0, x constr at level 0).
  Notation "S -> T" := (Ty_Arrow S T) (in custom stlc_gadget_ty at level 50, right associativity).
  Notation "x y" := (tm_app x y) (in custom stlc_gadget at level 1, left associativity).
  Notation "\ x : t , y" :=
    (tm_abs x t y) (in custom stlc_gadget at level 90, x at level 99,
                       t custom stlc_gadget_ty at level 99,
                       y custom stlc_gadget at level 99,
                       left associativity).
  Coercion tm_var : string >-> tm.

  Notation "{ x }" := x (in custom stlc_gadget at level 1, x constr).

  Notation "'Ring'" := Ty_Ring (in custom stlc_gadget_ty at level 0).
  Notation "'Bool'" := Ty_Ring (in custom stlc_gadget_ty at level 0).
  Notation "x && y" := (tm_and x y) (in custom stlc_gadget at level 2,
                                        left associativity).
  Notation "x || y" := (tm_or x y) (in custom stlc_gadget at level 2,
                                        left associativity).
  Notation "'opp' x" := (tm_opp x) (in custom stlc_gadget at level 0,
                                        x custom stlc_gadget at level 0).
  Notation "'neg' x" := (tm_neg x) (in custom stlc_gadget at level 0,
                                       x custom stlc_gadget at level 0).
  Notation "x + y" := (tm_add x y) (in custom stlc_gadget at level 2,
                                        left associativity).
  Notation "x * y" := (tm_mul x y) (in custom stlc_gadget at level 2,
                                        left associativity).
  Notation "x == y" := (tm_eq x y) (in custom stlc_gadget at level 1,
                                        left associativity).
  Notation "'if' x 'then' y 'else' z" :=
    (tm_if x y z) (in custom stlc_gadget at level 89,
                       x custom stlc_gadget at level 99,
                       y custom stlc_gadget at level 99,
                       z custom stlc_gadget at level 99,
                       left associativity).
  (* GADGET MACRO binder *)
  (* w= f(x) <-> c(x, w) = true *)
  Notation "'let' w ':=' f 'with' x 'in' c" :=
    (tm_gadget w f x c) (in custom stlc_gadget at level 89,
                          w at level 99,
                          f custom stlc_gadget at level 99,
                          x custom stlc_gadget at level 99,
                          c custom stlc_gadget at level 99,
                          left associativity).
  Coercion tm_rc : R >-> tm.
  Coercion tm_boolc : bool >-> tm.

  Reserved Notation "'[' x ':=' s ']' t" (in custom stlc_gadget at level 20, x constr).

  Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
    match t with
    (* pure STLC_GADGET *)
    | tm_var y =>
      if eqb_string x y then s else t
    | <[\y:T, t1]> =>
      if eqb_string x y then t else <[\y:T, [x:=s] t1]>
    | <[t1 t2]> =>
      <[([x:=s] t1) ([x:=s] t2)]>
    (* booleans *)
    | tm_boolc _ => t
    | <[neg t]> => <[ neg ([x:=s] t) ]>
    | <[t1 && t2]> => <[ ([x:=s]t1) && ([x:=s]t2) ]>
    | <[t1 || t2]> => <[ ([x:=s]t1) || ([x:=s]t2) ]>
    (* numbers *)
    | tm_rc _ => t
    | <[opp t]> => <[opp ([x:=s] t)]>
    | <[t1 + t2]> =>
      <[ ([x := s] t1) + ([x := s] t2)]>
    | <[t1 * t2]> =>
      <[ ([x := s] t1) * ([x := s] t2)]>
    | <[t1 == t2]> =>
      <[ ([x := s] t1) == ([x := s] t2)]>
    | <[if t1 then t2 else t3]> =>
      <[if [x := s] t1 then [x := s] t2 else [x := s] t3]>
    | <[let w := f with a in c]> =>
      if eqb_string x w then t else
        <[let w := [x := s]f with [x:=s]a in [x:=s]c]>
    end
  where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc_gadget).

  Inductive mode := Verifier(w: StlcRing.tm) | Prover.

  Reserved Notation "t '=' m '=>' t'" (at level 40).

  Inductive macro_expand : mode -> tm -> StlcRing.tm -> Prop :=
  (* pure STLC *)
  | M_Abs : forall m x T2 t1 t1' v2 v2',
      t1 =m=> t1' ->
      v2 =m=> v2' ->
      <[ (\x:T2, t1) v2 ]> =m=> <{ (\x:T2, t1') v2' }>
  | ST_App : forall m t1 t2 t1' t2',
      t1 =m=> t1' ->
      t2 =m=> t2' ->
      <[t1 t2]> =m=> <{t1' t2'}>
  (* Bools *)
  |ST_And: forall m b1 b2 b1' b2',
      b1 =m=> b1' ->
      b2 =m=> b2' ->
      <[b1 && b2]> =m=> <{b1' && b2'}>
  |ST_Or: forall m b1 b2 b1' b2',
      b1 =m=> b1' ->
      b2 =m=> b2' ->
      <[b1 || b2]> =m=> <{b1' || b2'}>
  |ST_Neg: forall m b b',
      b =m=> b' ->
      <[ neg b ]> =m=> <{ neg b' }>
  (* Numbers *)
  |ST_Add: forall m n1 n2 n1' n2',
      n1 =m=> n1' ->
      n2 =m=> n2' ->
      <[n1 + n2]> =m=> <{n1' + n2'}>
  |ST_Eq: forall m t1 t2 t1' t2',
      t1 =m=> t1' ->
      t2 =m=> t2' ->
      <[t1 == t2]> =m=> <{t1' == t2'}>
  |ST_Mul: forall m n1 n2 n1' n2',
      n1 =m=> n1' ->
      n2 =m=> n2' ->
      <[n1 * n2]> =m=> <{n1' * n2'}>
  |ST_If: forall m t1 t2 t3 t1' t2' t3',
      t1 =m=> t1' ->
      t2 =m=> t2' ->
      t3 =m=> t3' ->
      <[ if t1 then t2 else t3 ]> =m=> <{ if t1' then t2' else t3' }>
  (* These are the actual macros *)
  |ST_gadget_Prover: forall f w x c f' x',
      f =Prover=> f' ->                                      (** Bring f' to StlcRing *)
      x =Prover=> x' ->                                      (** Bring x' to StlcRing *)
      <[let w := f with x in c]> =Prover=> <{f' x'}>        (** The prover computes f(x) *)
  |ST_gadget_Verifier: forall f x c f' x' c',
      f =Verifier(w)=> f' ->                                    (** Bring f' to StlcRing *)
      x =Verifier(w)=> x' ->                                    (** Bring x' to StlcRing *)
      c =Verifier(w)=> c' ->                                    (** Bring c' to StlcRing *)

                      (*<{ f' x' }> -->* w' ->                                (** Compute witness w' in Coq proof *)*)
      <[let w := f with x in c]> =Verifier(w)=> <{ if(c' x' w) then w else error }> (** Verifier checks witness c' x' w' *)
  where "t '=' m '=>' t'" := (macro_expand m t t').
End StlcGadget.

(* A * (Map string R): put (Map String R) -> Writer (Map String R) A
   A -> Map string R : get () -> Reader (Map String R) (Map String R)

{
   forall t: tm, let (o, w) = evalWriter (prove t) in
      let Some (o') = evalReader w (verify t) in
         o = o'.

   Completeness
   forall w, c(x, w) = true -> f(x) = w
}
{
   Soundness
   forall w, f(x) = w -> c(x, w) = true
}

   Definition prove(in: tm)  : Writer (Map string R) tm
   Definition verify(in: tm) : Reader (Map string R) tm

(* f: forall t, exists o, t -> o
   c: forall t, forall o, t -> o -> Bool

(*

  back-end language: R1CS

  [
    a * b = c,
    c * d = 1, ...]

  Frank-Zippel lemma
  --------------------
  (a * b) * d = 1

*)


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.

(* Why3 assumption *)
Definition unit := unit.

Parameter fib: Z -> Z.

Axiom fib0 : ((fib 0%Z) = 0%Z).

Axiom fib1 : ((fib 1%Z) = 1%Z).

Axiom fibn : forall (n:Z), (2%Z <= n)%Z ->
  ((fib n) = ((fib (n - 1%Z)%Z) + (fib (n - 2%Z)%Z))%Z).

(* Why3 assumption *)
Inductive t :=
  | mk_t : Z -> Z -> Z -> Z -> t.
Axiom t_WhyType : WhyType t.
Existing Instance t_WhyType.

(* Why3 assumption *)
Definition a22 (v:t): Z := match v with
  | (mk_t x x1 x2 x3) => x3
  end.

(* Why3 assumption *)
Definition a21 (v:t): Z := match v with
  | (mk_t x x1 x2 x3) => x2
  end.

(* Why3 assumption *)
Definition a12 (v:t): Z := match v with
  | (mk_t x x1 x2 x3) => x1
  end.

(* Why3 assumption *)
Definition a11 (v:t): Z := match v with
  | (mk_t x x1 x2 x3) => x
  end.

(* Why3 assumption *)
Definition mult (x:t) (y:t): t :=
  (mk_t (((a11 x) * (a11 y))%Z + ((a12 x) * (a21 y))%Z)%Z
  (((a11 x) * (a12 y))%Z + ((a12 x) * (a22 y))%Z)%Z
  (((a21 x) * (a11 y))%Z + ((a22 x) * (a21 y))%Z)%Z
  (((a21 x) * (a12 y))%Z + ((a22 x) * (a22 y))%Z)%Z).

Axiom Assoc : forall (x:t) (y:t) (z:t), ((mult (mult x y) z) = (mult x
  (mult y z))).

Axiom Unit_def_l : forall (x:t), ((mult (mk_t 1%Z 0%Z 0%Z 1%Z) x) = x).

Axiom Unit_def_r : forall (x:t), ((mult x (mk_t 1%Z 0%Z 0%Z 1%Z)) = x).

Axiom Comm : forall (x:t) (y:t), ((mult x y) = (mult y x)).

Parameter power: t -> Z -> t.

Axiom Power_0 : forall (x:t), ((power x 0%Z) = (mk_t 1%Z 0%Z 0%Z 1%Z)).

Axiom Power_s : forall (x:t) (n:Z), (0%Z <= n)%Z -> ((power x
  (n + 1%Z)%Z) = (mult x (power x n))).

Axiom Power_s_alt : forall (x:t) (n:Z), (0%Z < n)%Z -> ((power x n) = (mult x
  (power x (n - 1%Z)%Z))).

Axiom Power_1 : forall (x:t), ((power x 1%Z) = x).

Axiom Power_sum : forall (x:t) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((power x (n + m)%Z) = (mult (power x n) (power x m)))).

Axiom Power_mult : forall (x:t) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((power x (n * m)%Z) = (power (power x n) m))).

Axiom Power_mult2 : forall (x:t) (y:t) (n:Z), (0%Z <= n)%Z -> ((power (mult x
  y) n) = (mult (power x n) (power y n))).

(* Why3 goal *)
Theorem WP_parameter_logfib : forall (n:Z), (0%Z <= n)%Z -> ((~ (n = 0%Z)) ->
  let o := (int.EuclideanDivision.div n 2%Z) in ((0%Z <= o)%Z ->
  forall (result:Z) (result1:Z), ((power (mk_t 1%Z 1%Z 1%Z 0%Z)
  o) = (mk_t (result + result1)%Z result1 result1 result)) -> let c :=
  (result + result1)%Z in ((((int.EuclideanDivision.mod1 n 2%Z) = 0%Z) ->
  let a := ((result * result)%Z + (result1 * result1)%Z)%Z in let b :=
  (result1 * (result + c)%Z)%Z in ((power (mk_t 1%Z 1%Z 1%Z 0%Z)
  n) = (mk_t (a + b)%Z b b a))) /\ ((~ ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z)) -> let a := (result1 * (result + c)%Z)%Z in let b :=
  ((c * c)%Z + (result1 * result1)%Z)%Z in ((power (mk_t 1%Z 1%Z 1%Z 0%Z)
  n) = (mk_t (a + b)%Z b b a)))))).
(* Why3 intros n h1 h2 o h3 result result1 h4 c. *)
(* YOU MAY EDIT THE PROOF BELOW *)
Import EuclideanDivision.
intros.
subst o c.
assert (h: (2 <> 0)%Z) by omega.
generalize (Div_mod n 2 h)%Z.
intuition.
rewrite H4 in H3.
rewrite H3.
replace (2 * div n 2 + 0)%Z with (div n 2 + div n 2)%Z by omega.
rewrite Power_sum by exact H1.
rewrite H2; simpl.
unfold mult; simpl.
apply f_equal4; ring.

generalize (Mod_bound n 2 h)%Z.
simpl.
intro.
assert (h': (mod1 n 2 = 1)%Z) by omega.
rewrite h' in H3.
rewrite H3.
replace (2 * div n 2 + 1)%Z with ((div n 2 + div n 2) + 1)%Z by omega.
rewrite Power_s.
rewrite Power_sum by exact H1.
rewrite H2; simpl.
unfold mult at 2; simpl.
unfold mult.
apply f_equal4; unfold a11, a12, a21, a22; try ring.
intuition.
Qed.


(*
Copyright 2010 IMDEA Software Institute
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

From Coq Require Import ssreflect ssrbool ssrfun Setoid.
From mathcomp Require Import seq.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Warnings "-projection-no-head-constant".

(******************************************************************************)
(* This file re-implements some of ssrbool's entities in Prop universe        *)
(******************************************************************************)

Lemma andTp p : True /\ p <-> p.      Proof. by intuition. Qed.
Lemma andpT p : p /\ True <-> p.      Proof. by intuition. Qed.
Lemma andFp p : False /\ p <-> False. Proof. by intuition. Qed.
Lemma andpF p : p /\ False <-> False. Proof. by intuition. Qed.
Lemma orTp p : True \/ p <-> True.    Proof. by intuition. Qed.
Lemma orpT p : p \/ True <-> True.    Proof. by intuition. Qed.
Lemma orFp p : False \/ p <-> p.      Proof. by intuition. Qed.
Lemma orpF p : p \/ False <-> p.      Proof. by intuition. Qed.

Delimit Scope rel_scope with rel.
Open Scope rel_scope.

(**************************************************************************)
(* We follow ssrbool, and provide four different types of predicates.     *)
(*                                                                        *)
(* (1) Pred is the type of propositional functions                        *)
(* (2) Simpl_Pred is the type of predicates that automatically simplify   *)
(*     when used in an applicative position.                              *)
(* (3) Mem_Pred is for predicates that support infix notation x \In P     *)
(* (4) PredType is the structure for interpreting various types, such as  *)
(* lists, tuples, etc. as predicates.                                     *)
(*                                                                        *)
(* Important point is that custom lemmas over predicates can be stated in *)
(* terms of Pred, while Simpl_Pred, Mem_Pred and PredType are for         *)
(* technical developments used in this file only. More on this point      *)
(* can be found in ssrbool.                                               *)
(**************************************************************************)

Definition Pred T := T -> Prop.
Identity Coercion fun_of_Pred : Pred >-> Funclass.

Notation xPred0 := (fun _ => False).
Notation xPred1 := (fun x y => x = y).
Notation xPredT := (fun _ => True).
Notation xPredI := (fun (p1 p2 : Pred _) x => p1 x /\ p2 x).
Notation xPredU := (fun (p1 p2 : Pred _) x => p1 x \/ p2 x).
Notation xPredC := (fun (p : Pred _) x => ~ p x).
Notation xPredD := (fun (p1 p2 : Pred _) x => ~ p2 x /\ p1 x).
Notation xPreim := (fun f (p : Pred _) x => p (f x)).

Section Predicates.
Variable T : Type.

(* simple predicates *)

Definition Simpl_Pred := simpl_fun T Prop.
Definition SimplPred (p : Pred T) : Simpl_Pred := SimplFun p.
Coercion Pred_of_Simpl (p : Simpl_Pred) : Pred T := p : T -> Prop.

(* it's useful to declare the operations as simple predicates, so that *)
(* complex expressions automatically reduce when used in applicative   *)
(* positions *)

Definition Pred0 := SimplPred xPred0.
Definition Pred1 x := SimplPred (xPred1 x).
Definition PredT := SimplPred xPredT.
Definition PredI p1 p2 := SimplPred (xPredI p1 p2).
Definition PredU p1 p2 := SimplPred (xPredU p1 p2).
Definition PredC p := SimplPred (xPredC p).
Definition PredD p1 p2 := SimplPred (xPredD p1 p2).
Definition Preim rT f (d : Pred rT) := SimplPred (xPreim f d).

(* membership predicates *)

CoInductive Mem_Pred : Type := MemProp of Pred T.
Definition isMem pT toPred mem := mem = (fun p : pT => MemProp [eta toPred p]).

(* the general structure for predicates *)

Structure PredType : Type := PropPredType {
  Pred_Sort :> Type;
  toPred : Pred_Sort -> Pred T;
  _ : {mem | isMem toPred mem}}.

Definition mkPredType pT toP :=
  PropPredType (exist (@isMem pT toP) _ (erefl _)).

(* Pred, SimplPred, Mem_Pred, pred and simpl_pred are PredType's *)
Canonical Structure PredPredType := Eval hnf in @mkPredType (Pred T) id.
Canonical Structure SimplPredPredType := Eval hnf in mkPredType Pred_of_Simpl.
Coercion Pred_of_Mem mp : Pred_Sort PredPredType :=
  let: MemProp p := mp in [eta p].
Canonical Structure MemPredType := Eval hnf in mkPredType Pred_of_Mem.
Canonical Structure predPredType := Eval hnf in @mkPredType (pred T) id.
Canonical Structure simplpredPredType :=
  Eval hnf in @mkPredType (simpl_pred T) (fun p x => p x).

End Predicates.

Arguments Pred0 [T].
Arguments PredT [T].
Prenex Implicits Pred0 PredT PredI PredU PredC PredD Preim.

Notation "r1 +p r2" := (PredU r1 r2 : Pred _)
  (at level 55, right associativity) : rel_scope.
Notation "r1 *p r2" := (xPredI r1 r2 : Pred _)
  (at level 45, right associativity) : rel_scope.

Notation "[ 'Pred' : T | E ]" := (SimplPred (fun _ : T => E))
  (at level 0, format "[ 'Pred' :  T  |  E ]") : fun_scope.
Notation "[ 'Pred' x | E ]" := (SimplPred (fun x => E))
  (at level 0, x ident, format "[ 'Pred'  x  |  E ]") : fun_scope.
Notation "[ 'Pred' x : T | E ]" := (SimplPred (fun x : T => E))
  (at level 0, x ident, only parsing) : fun_scope.
Notation "[ 'Pred' x y | E ]" := (SimplPred (fun t => let: (x, y) := t in E))
  (at level 0, x ident, y ident, format "[ 'Pred'  x  y  |  E ]") : fun_scope.
Notation "[ 'Pred' x y : T | E ]" :=
  (SimplPred (fun t : (T*T) => let: (x, y) := t in E))
  (at level 0, x ident, y ident, only parsing) : fun_scope.

Definition repack_Pred T pT :=
  let: PropPredType _ a mP := pT return {type of @PropPredType T for pT} -> _ in
   fun k => k a mP.

Notation "[ 'PredType' 'of' T ]" := (repack_Pred (fun a => @PropPredType _ T a))
  (at level 0, format "[ 'PredType'  'of'  T ]") : form_scope.

Notation Pred_Class := (Pred_Sort (PredPredType _)).
Coercion Sort_of_Simpl_Pred T (p : Simpl_Pred T) : Pred_Class := p : Pred T.

Definition PredArgType := Type.
Coercion Pred_of_argType (T : PredArgType) : Simpl_Pred T := PredT.

Notation "{ :: T }" := (T%type : PredArgType)
  (at level 0, format "{ ::  T }") : type_scope.

(* These must be defined outside a Section because "cooking" kills the *)
(* nosimpl tag. *)
Definition Mem T (pT : PredType T) : pT -> Mem_Pred T :=
  nosimpl (let: PropPredType _ _ (exist mem _) := pT return pT -> _ in mem).
Definition InMem T x mp := nosimpl Pred_of_Mem T mp x.

Prenex Implicits Mem.

(* Membership Predicates can be used as simple ones *)
Coercion Pred_of_Mem_Pred T mp := [Pred x : T | InMem x mp].

(* equality and subset *)

Definition EqPredType T (pT : PredType T) (p1 p2 : pT) :=
  forall x : T, toPred p1 x <-> toPred p2 x.

Definition SubPredType T (pT : PredType T) (p1 p2 : pT) :=
  forall x : T, toPred p1 x -> toPred p2 x.

Definition EqSimplPred T (p1 p2 : Simpl_Pred T) := EqPredType p1 p2.
Definition SubSimplPred T (p1 p2 : Simpl_Pred T) := SubPredType p1 p2.

Definition EqPredFun T1 T2 (pT2 : PredType T2) p1 p2 :=
  forall x : T1, @EqPredType T2 pT2 (p1 x) (p2 x).
Definition SubPredFun T1 T2 (pT2 : PredType T2) p1 p2 :=
  forall x : T1, @SubPredType T2 pT2 (p1 x) (p2 x).

Definition EqMem T p1 p2 := forall x : T, InMem x p1 <-> InMem x p2.
Definition SubMem T p1 p2 := forall x : T, InMem x p1 -> InMem x p2.

Notation "A <~> B" := (@EqPredType _ _ A B)
  (at level 70, no associativity) : rel_scope.
Notation "A ~> B" := (@SubPredType _ _ A B)
  (at level 70, no associativity) : rel_scope.
Notation "A <~1> B" := (@EqPredFun _ _ _ A B)
  (at level 70, no associativity) : rel_scope.
Notation "A ~1> B" := (@SubPredFun _ _ _ A B)
  (at level 70, no associativity) : rel_scope.

Notation "x \In A" := (InMem x (Mem A))
  (at level 70, no associativity) : rel_scope.
Notation "x \Notin A" := (~ (x \In A))
  (at level 70, no associativity) : rel_scope.
Notation "A =p B" := (EqMem (Mem A) (Mem B))
  (at level 70, no associativity) : type_scope.
Notation "A <=p B" := (SubMem (Mem A) (Mem B))
  (at level 70, no associativity) : type_scope.

(* Some notation for turning PredTypes into Pred or Simple Pred *)
Notation "[ 'Mem' A ]" := (Pred_of_Simpl (Pred_of_Mem_Pred (Mem A)))
  (at level 0, only parsing) : fun_scope.
Notation "[ 'PredI' A & B ]" := (PredI [Mem A] [Mem B])
  (at level 0, format "[ 'PredI'  A  &  B ]") : fun_scope.
Notation "[ 'PredU' A & B ]" := (PredU [Mem A] [Mem B])
  (at level 0, format "[ 'PredU'  A  &  B ]") : fun_scope.
Notation "[ 'PredD' A & B ]" := (PredD [Mem A] [Mem B])
  (at level 0, format "[ 'PredD'  A  &  B ]") : fun_scope.
Notation "[ 'PredC' A ]" := (PredC [Mem A])
  (at level 0, format "[ 'PredC'  A ]") : fun_scope.
Notation "[ 'Preim' f 'of' A ]" := (Preim f [Mem A])
  (at level 0, format "[ 'Preim'  f  'of'  A ]") : fun_scope.

Notation "[ 'Pred' x \In A ]" := [Pred x | x \In A]
  (at level 0, x ident, format "[ 'Pred'  x  \In  A ]") : fun_scope.
Notation "[ 'Pred' x \In A | E ]" := [Pred x | (x \In A) /\ E]
  (at level 0, x ident, format "[ 'Pred'  x  \In  A  |  E ]") : fun_scope.
Notation "[ 'Pred' x y \In A & B | E ]" :=
  [Pred x y | (x \In A) /\ (y \In B) /\ E]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A  &  B  |  E ]") : fun_scope.
Notation "[ 'Pred' x y \In A & B ]" := [Pred x y | (x \In A) /\ (y \In B)]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A  &  B ]") : fun_scope.
Notation "[ 'Pred' x y \In A | E ]" := [Pred x y \In A & A | E]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A  |  E ]") : fun_scope.
Notation "[ 'Pred' x y \In A ]" := [Pred x y \In A & A]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A ]") : fun_scope.

Section Simplifications.
Variables (T : Type) (pT : PredType T).

Lemma Mem_toPred : forall (p : pT), Mem (toPred p) = Mem p.
Proof. by rewrite /Mem; case: pT => T1 app1 [mem1  /= ->]. Qed.

Lemma toPredE x (p : pT) : toPred p x = (x \In p).
Proof. by rewrite -Mem_toPred. Qed.

Lemma In_Simpl x (p : Simpl_Pred T) : (x \In p) = p x.
Proof. by []. Qed.

Lemma Simpl_PredE (p : Pred T) : p <~> [Pred x | p x].
Proof. by []. Qed.

Lemma Mem_Simpl (p : Simpl_Pred T) : Mem p = p :> Pred T.
Proof. by []. Qed.

Definition MemE := Mem_Simpl. (* could be extended *)

Lemma Mem_Mem (p : pT) : (Mem (Mem p) = Mem p) * (Mem [Mem p] = Mem p).
Proof. by rewrite -Mem_toPred. Qed.

End Simplifications.

(**************************************)
(* Definitions and lemmas for setoids *)
(**************************************)

Section RelProperties.
Variables (T : Type) (pT : PredType T).

Lemma EqPredType_refl (r : pT) : EqPredType r r. Proof. by []. Qed.
Lemma SubPredType_refl (r : pT) : SubPredType r r. Proof. by []. Qed.

Lemma EqPredType_sym (r1 r2 : pT) : EqPredType r1 r2 -> EqPredType r2 r1.
Proof. by move=>H1 x; split; move/H1. Qed.

Lemma EqPredType_trans' (r1 r2 r3 : pT) :
  EqPredType r1 r2 -> EqPredType r2 r3 -> EqPredType r1 r3.
Proof. by move=>H1 H2 x; split; [move/H1; move/H2 | move/H2; move/H1]. Qed.

Lemma SubPredType_trans' (r1 r2 r3 : pT) :
  SubPredType r1 r2 -> SubPredType r2 r3 -> SubPredType r1 r3.
Proof. by move=>H1 H2 x; move/H1; move/H2. Qed.

Definition EqPredType_trans r2 r1 r3 := @EqPredType_trans' r1 r2 r3.
Definition SubPredType_trans r2 r1 r3 := @SubPredType_trans' r1 r2 r3.
End RelProperties.

Hint Resolve EqPredType_refl SubPredType_refl : core.

(* Declaration of relations *)

Add Parametric Relation T (pT : PredType T) : pT (@EqPredType _ pT)
   reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqPredType_rel.

Add Parametric Relation T : (Simpl_Pred T) (@EqSimplPred _)
  reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqSimplPred_rel.

Add Parametric Relation T : (Simpl_Pred T) (@SubSimplPred _)
  reflexivity proved by (@SubPredType_refl _ _)
  transitivity proved by (@SubPredType_trans' _ _) as SubSimplPred_rel.

Add Parametric Relation T : (Mem_Pred T) (@EqMem T)
  reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqMem_rel.

Add Parametric Relation T : (Mem_Pred T) (@SubMem _)
  reflexivity proved by (@SubPredType_refl _ _)
  transitivity proved by (@SubPredType_trans' _ _) as SubMem_rel.

(* Declaring morphisms. *)

Add Parametric Morphism T : (@Pred_of_Simpl T) with signature
      @EqSimplPred _ ==> @EqPredType T (PredPredType T) as Pred_of_Simpl_morph.
Proof. by []. Qed.

Add Parametric Morphism T (pT : PredType T) : (@EqPredType T pT) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> iff as EqPredType_morph.
Proof. by move=>r1 s1 H1 r2 s2 H2; rewrite H1 H2. Qed.

Add Parametric Morphism T (pT : PredType T) : (@SubPredType T pT) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> iff as SubPred_morph.
Proof. by move=>r1 s1 H1 r2 s2 H2; split=>H x; move/H1; move/H; move/H2. Qed.

Add Parametric Morphism T : (@InMem T) with signature
    @eq _ ==> @EqMem _ ==> iff as InMem_morph.
Proof. by move=>x r s H; split; move/H. Qed.

Add Parametric Morphism T (pT : PredType T) : (@Mem T pT) with signature
  @EqPredType _ _ ==> @EqMem _ as Mem_morhp.
Proof. by move=>x y H p; rewrite /EqPredType -!toPredE in H *; rewrite H. Qed.

Add Parametric Morphism T : (@PredU T) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> @EqSimplPred _ as predU_morph.
Proof.
move=>r1 s1 H1 r2 h2 H2 x; split;
by case; [move/H1 | move/H2]=>/=; auto.
Qed.

Add Parametric Morphism T : (@PredI T) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> @EqPredType _ _ as predI_morph.
Proof.
move=>r1 s1 H1 r2 s2 H2 x; split;
by case; move/H1=>T1; move/H2=>T2.
Qed.

Add Parametric Morphism T : (@PredC T) with signature
    @EqPredType _ _ ==> @EqPredType _ _ as predC_morph.
Proof. by move=>r s H x; split=>H1; apply/H. Qed.

Section RelLaws.
Variable (T : Type).

Lemma orrI (r : Pred nat) : r +p r <~> r.
Proof.  by move=>x; split; [case | left]. Qed.

Lemma orrC (r1 r2 : Pred T) : r1 +p r2 <~> r2 +p r1.
Proof. move=>x; split=>/=; tauto. Qed.

Lemma orr0 (r : Pred T) : r +p Pred0 <~> r.
Proof. by move=>x; split; [case | left]. Qed.

Lemma or0r (r : Pred T) : Pred0 +p r <~> r.
Proof. by rewrite orrC orr0. Qed.

Lemma orrCA (r1 r2 r3 : Pred T) : r1 +p r2 +p r3 <~> r2 +p r1 +p r3.
Proof. by move=>x; split=>/=; intuition. Qed.

Lemma orrAC (r1 r2 r3 : Pred T) : (r1 +p r2) +p r3 <~> (r1 +p r3) +p r2.
Proof. by move=>?; split=>/=; intuition. Qed.

Lemma orrA (r1 r2 r3 : Pred T) : (r1 +p r2) +p r3 <~> r1 +p r2 +p r3.
Proof. by rewrite (orrC r2) orrCA orrC. Qed.

(* absorption *)
Lemma orrAb (r1 a : Pred T) : r1 <~> r1 +p a <-> a ~> r1.
Proof.
split; first by move=>-> x /=; auto.
move=>H x /=; split; first by auto.
by case=>//; move/H.
Qed.

Lemma sub_orl (r1 r2 : Pred T) : r1 ~> r1 +p r2. Proof. by left. Qed.
Lemma sub_orr (r1 r2 : Pred T) : r2 ~> r1 +p r2. Proof. by right. Qed.

End RelLaws.

Section SubMemLaws.
Variable T : Type.

Lemma subp_refl (p : Pred T) : p <=p p.
Proof. by []. Qed.

Lemma subp_asym (p1 p2 : Pred T) : p1 <=p p2 -> p2 <=p p1 -> p1 =p p2.
Proof. by move=>H1 H2 x; split; [move/H1 | move/H2]. Qed.

Lemma subp_trans (p2 p1 p3 : Pred T) : p1 <=p p2 -> p2 <=p p3 -> p1 <=p p3.
Proof. by move=>H1 H2 x; move/H1; move/H2. Qed.

Lemma subp_or (p1 p2 q : Pred T) : p1 <=p q /\ p2 <=p q <-> p1 +p p2 <=p q.
Proof.
split=>[[H1] H2 x|H1]; first by case; [move/H1 | move/H2].
by split=>x H2; apply: H1; [left | right].
Qed.

Lemma subp_and (p1 p2 q : Pred T) : q <=p p1 /\ q <=p p2 <-> q <=p p1 *p p2.
Proof.
split=>[[H1] H2 x|] H; last by split=>x; case/H.
by split; [apply: H1 | apply: H2].
Qed.

Lemma subp_orl (p1 p2 q : Pred T) : p1 <=p p2 -> p1 +p q <=p p2 +p q.
Proof. by move=>H x; case; [move/H; left|right]. Qed.

Lemma subp_orr (p1 p2 q : Pred T) : p1 <=p p2 -> q +p p1 <=p q +p p2.
Proof. by move=>H x; case; [left | move/H; right]. Qed.

Lemma subp_andl (p1 p2 q : Pred T) : p1 <=p p2 -> p1 *p q <=p p2 *p q.
Proof. by by move=>H x [H1 H2]; split; [apply: H|]. Qed.

Lemma subp_andr (p1 p2 q : Pred T) : p1 <=p p2 -> q *p p1 <=p q *p p2.
Proof. by move=>H x [H1 H2]; split; [|apply: H]. Qed.

End SubMemLaws.

Hint Resolve subp_refl : core.

Section ListMembership.
Variable T : Type.

Fixpoint Mem_Seq (s : seq T) :=
  if s is y::s' then (fun x => x = y \/ Mem_Seq s' x) else xPred0.

Definition EqSeq_Class := seq T.
Identity Coercion seq_of_EqSeq : EqSeq_Class >-> seq.

Coercion Pred_of_Eq_Seq (s : EqSeq_Class) : Pred_Class := [eta Mem_Seq s].

Canonical Structure seq_PredType := @mkPredType T (seq T) Pred_of_Eq_Seq.
(* The line below makes Mem_Seq a canonical instance of topred. *)
Canonical Structure Mem_Seq_PredType := mkPredType Mem_Seq.

Lemma In_cons y s x : (x \In y :: s) <-> (x = y) \/ (x \In s).
Proof. by []. Qed.

Lemma In_nil x : (x \In [::]) <-> False.
Proof. by []. Qed.

Lemma Mem_Seq1 x y : (x \In [:: y]) <-> (x = y).
Proof. by rewrite In_cons orpF. Qed.

Definition InE := (Mem_Seq1, In_cons, In_Simpl).

Lemma Mem_cat x : forall s1 s2, (x \In s1 ++ s2) <-> x \In s1 \/ x \In s2.
Proof.
elim=>[|y s1 IH] s2 /=; first by split; [right | case].
rewrite !InE /=.
split.
- case=>[->|/IH]; first by left; left.
  by case; [left; right | right].
case; first by case; [left | move=>H; right; apply/IH; left].
by move=>H; right; apply/IH; right.
Qed.

Lemma In_split x s : x \In s -> exists s1 s2, s = s1 ++ x :: s2.
Proof.
elim:s=>[|y s IH] //=; rewrite InE.
case=>[<-|]; first by exists [::], s.
by case/IH=>s1 [s2 ->]; exists (y :: s1), s2.
Qed.

End ListMembership.

Lemma Mem_map T T' (f : T -> T') x (s : seq T) :
         x \In s -> f x \In (map f s).
Proof.
elim: s=>[|y s IH] //; rewrite InE /=.
by case=>[<-|/IH]; [left | right].
Qed.

Lemma Mem_map_inv T T' (f : T -> T') x (s : seq T) :
        x \In (map f s) -> exists y, x = f y /\ y \In s.
Proof.
elim: s=>[|y s IH] //=; rewrite InE /=.
case; first by move=>->; exists y; split=>//; left.
by case/IH=>z [->]; exists z; split=>//; right.
Qed.

Prenex Implicits Mem_map_inv.

(* Setoids for extensional equality of functions *)

Lemma eqfun_refl A B (f : A -> B) : f =1 f. Proof. by []. Qed.
Lemma eqfun_sym A B (f1 f2 : A -> B) : f1 =1 f2 -> f2 =1 f1.
Proof. by move=>H x; rewrite H. Qed.
Lemma eqfun_trans A B (f1 f2 f3 : A -> B) : f1 =1 f2 -> f2 =1 f3 -> f1 =1 f3.
Proof. by move=>H1 H2 x; rewrite H1 H2. Qed.

Add Parametric Relation A B : (A -> B) (@eqfun _ _)
  reflexivity proved by (@eqfun_refl A B)
  symmetry proved by (@eqfun_sym A B)
  transitivity proved by (@eqfun_trans A B) as eqfun_morph.

(***********************************)
(* Image of a collective predicate *)
(***********************************)

Section Image.
Variables (A B : Type) (P : Pred A) (f : A -> B).

Inductive image_spec b : Prop := Im_mem a of b = f a & a \In P.

Definition Image' : Pred B := image_spec.

End Image.

(* swap to make the notation consider P before E; helps inference *)
Notation Image f P := (Image' P f).

Notation "[ 'Image' E | i <- s ]" := (Image (fun i => E) s)
  (at level 0, E at level 99, i ident,
   format "[ '[hv' 'Image'  E '/ '  |  i  <-  s ] ']'") : rel_scope.

Notation "[ 'Image' E | i <- s & C ]" := [Image E | i <- [PredI s & C]]
  (at level 0, E at level 99, i ident,
   format "[ '[hv' 'Image'  E '/ '  |  i  <-  s '/ '  &  C ] ']'") : rel_scope.

Notation "[ 'Image' E | i : T <- s ]" := (Image (fun i : T => E) s)
  (at level 0, E at level 99, i ident, only parsing) : rel_scope.

Notation "[ 'Image' E | i : T <- s & C ]" :=
  [Image E | i : T <- [PredI s & C]]
  (at level 0, E at level 99, i ident, only parsing) : rel_scope.

Lemma Image_mem A B (f : A -> B) (P : Pred A) x : x \In P -> f x \In Image f P.
Proof. by apply: Im_mem. Qed.

Lemma Image_inj_sub A B (f : A -> B) (X1 X2 : Pred A) :
        injective f -> Image f X1 <=p Image f X2 -> X1 <=p X2.
Proof. by move=>H E x /(Image_mem f) /E [y] /H ->. Qed.

Lemma Image_inj_eqmem A B (f : A -> B) (X1 X2 : Pred A) :
        injective f -> Image f X1 =p Image f X2 -> X1 =p X2.
Proof. by move=>H E; split; apply: Image_inj_sub H _ _; rewrite E. Qed.

Lemma ImageU A B (f : A -> B) (X1 X2 : Pred A) :
        Image f (PredU X1 X2) =p [PredU Image f X1 & Image f X2].
Proof.
move=>x; split.
- by case=>y -> [H|H]; [left | right]; apply: Image_mem.
by case; case=>y -> H; apply: Image_mem; [left | right].
Qed.

Lemma ImageIm A B C (f1 : B -> C) (f2 : A -> B) (X : Pred A) :
        Image f1 (Image f2 X) =p Image (f1 \o f2) X.
Proof.
move=>x; split; first by case=>_ -> [x' ->] H; exists x'.
by case=>a -> H; exists (f2 a)=>//; exists a.
Qed.

Lemma ImageEq A B (f1 f2 : A -> B) (X : Pred A) :
        f1 =1 f2 -> Image f1 X =p Image f2 X.
Proof. by move=>H x; split; case=>a ->; exists a. Qed.


Declare Scope composition.

Definition comp (v w u:Type) (g:w -> u) (f:v -> w) (x:v) : u := g (f x).

Arguments comp {v} {w} {u} _ _ _.

Notation "g ; f" := (comp g f) (at level 60, right associativity) : composition.


(** * The type of the unital lB-systems

By Vladimir Voevodsky, started on Jan. 18, 2015 *)

Require Import UniMath.Foundations.All.

Require Import TypeTheory.Csystems.hSet_ltowers.
Require Export TypeTheory.Bsystems.lB_non_unital.
Require Export TypeTheory.Bsystems.lB0.

(** *** Condition dltT *)

Definition dltT_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.dltT_type ( @T_ax0 BB ) ( @T_ax1b BB ) ( @Tt_op BB ) ( dlt_ax1 dlt ) .

(** *** Condition dltS *)

Definition dltS_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.dltS_type ( @T_ax1b BB ) ( @S_ax0 BB ) ( @St_op BB ) ( dlt_ax1 dlt ) .

(** *** Condition SdltT *)

Definition SdltT_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.SdltT_type ( @T_ax0 BB ) ( @T_ax1a BB ) ( dlt_ax1 dlt ) ( @S_op BB ) .

(** *** Condition StdltTt *)

Definition StdltTt_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.StdltTt_type ( @T_ax0 BB ) ( @T_ax1a BB ) ( dlt_ax1 dlt ) ( @Tt_ax1 BB ) ( @St_op BB ) .

(** *** Condition dltSid *)

Definition dltSid_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.dltSid_type ( @T_ax1b BB ) ( dlt_ax1 dlt ) ( @St_op BB ) .

(** *** Unital lB-system *)

Definition lB :=
  ∑ (BB : lB_nu) (dlt : dlt_layer ( @T_op BB )),
               ( ( ( dltT_type dlt ) × ( dltS_type dlt ) ) ×
                 ( ( SdltT_type dlt ) × ( StdltTt_type dlt ) ) )
               × ( dltSid_type dlt ).

(** This definition corresponds to the addition of Definition 3.2 in arXiv:1410.5389v1
    of the axioms, only the packaging order is different in irrelevant ways
    ([lB_to_lB0] below is not just a projection). *)

Definition lB_to_lB_nu : lB -> lB_nu := pr1 .
Coercion lB_to_lB_nu : lB >-> lB_nu .

Definition lB_to_lB0 ( BB : lB ) : lB0system :=
  tpair ( fun BB : lB0system_non_unital => dlt_layer ( @T_op BB ) ) BB ( pr1 ( pr2 BB ) ) .
Coercion lB_to_lB0 : lB >-> lB0system .

Definition dltT { BB : lB } : dltT_type BB := pr1 ( pr1 ( pr1 ( pr2 ( pr2 BB ) ) ) ) .

Definition dltS { BB : lB } : dltS_type BB := pr2 ( pr1 ( pr1 ( pr2 ( pr2 BB ) ) ) ) .

Definition SdltT { BB : lB } : SdltT_type BB := pr1 ( pr2 ( pr1 ( pr2 ( pr2 BB ) ) ) ) .

Definition StdltTt { BB : lB } : StdltTt_type BB := pr2 ( pr2 ( pr1 ( pr2 ( pr2 BB ) ) ) ) .

Definition dltSid { BB : lB } : dltSid_type BB := pr2 ( pr2 ( pr2 BB ) ) .

(* End of the file lB.v *)


From mathcomp Require Import all_ssreflect zify.
From CoTypes Require Export coGlobal coLocal.
Require Import Paco.paco.

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

Inductive part_of (p : ptcp) : gcType -> Prop :=
| po_msg a u g0 : comp_dir p a -> part_of p (GCMsg a u g0)
| po_msg2 a u g0 : part_of p g0 -> part_of p (GCMsg a u g0)
| po_branch a gs : comp_dir p a -> part_of p (GCBranch a gs)
| po_branch2 a g (gs : seq gcType) : In g gs -> part_of p g ->   part_of p (GCBranch a gs).
Hint Constructors part_of.

Lemma part_of_ind2
     : forall (p : ptcp) (P : gcType -> Prop),
       (forall (a : action) (u : value) (g0 : gcType), comp_dir p a -> P (GCMsg a u g0)) ->
       (forall (a : action) (u : value) (g0 : gcType), ~ comp_dir p a -> part_of p g0 -> P g0 -> P (GCMsg a u g0)) ->
       (forall (a : action) (gs : coseq gcType), comp_dir p a -> P (GCBranch a gs)) ->
       (forall (a : action) (g : gcType) (gs : seq gcType), ~ comp_dir p a -> In g gs -> part_of p g -> P g -> P (GCBranch a gs)) ->
       forall g : gcType, part_of p g -> P g.
Proof.
intros. eapply part_of_ind;eauto.
intros. destruct (comp_dir p a) eqn:Heqn. apply H. rewrite Heqn. done.
apply H0. rewrite Heqn. done. done. done.
intros. destruct (comp_dir p a) eqn:Heqn. apply H1. rewrite Heqn. done.
eapply H2. rewrite Heqn. done. eauto. eauto. done.
Qed.

Lemma not_part_msg : forall p a v g, ~ part_of p (GCMsg a v g) -> ~ part_of p g.
Proof.
intros. intro.  apply/H. eauto.
Qed.

Lemma not_part_msg2 : forall p a v g, ~ part_of p (GCMsg a v g) -> ~ comp_dir p a.
Proof.
intros. intro.  apply/H. eauto.
Qed.

Lemma not_part_branch : forall p a g (gs : seq gcType), ~ part_of p (GCBranch a gs) -> In g gs -> ~ part_of p g.
Proof.
intros. intro.  apply/H. eauto.
Qed.

Lemma not_part_branch2 : forall p a (gs : seq gcType), ~ part_of p (GCBranch a gs) -> ~ comp_dir p a.
Proof.
intros. intro.  apply/H. eauto.
Qed.

Hint Resolve not_part_msg not_part_msg2  not_part_branch  not_part_branch2.

Inductive part_of_all (p : ptcp) : gcType -> Prop   :=
| poac_msg a u g0 : comp_dir p a -> part_of_all p (GCMsg a u g0)
| poac_msg2 a u g0 :  part_of_all p g0 -> part_of_all p (GCMsg a u g0)
| poac_branch a gs : comp_dir p a -> part_of_all p (GCBranch a gs)
| poac_branch2 a (gs : seq gcType)  :  (forall g, In g gs -> part_of_all p g) ->  part_of_all p (GCBranch a gs). (*May not be vacously true, require their to be at least one element in g, now part_of_all -> part_of and also part_of_all and ~ part_of cannot coincide*)
Hint Constructors part_of_all.

Lemma none_not : forall (A : Type) (a : option A), a = None <-> ~ a.
Proof.
intros. split;destruct a;done.
Qed.

Lemma part_of_all_ind2
     : forall (p : ptcp) (P : gcType -> Prop),
       (forall (a : action) (u : value) (g0 : gcType), comp_dir p a -> P (GCMsg a u g0)) ->
       (forall (a : action) (u : value) (g0 : gcType), ~ comp_dir p a -> part_of_all p g0 -> P g0 -> P (GCMsg a u g0)) ->
       (forall (a : action) (gs : coseq gcType), comp_dir p a -> P (GCBranch a gs)) ->
       (forall (a : action) (gs : seq gcType),  ~ comp_dir p a ->  (forall g, In g gs -> part_of_all p g)   ->  (forall g, In g gs -> part_of_all p g -> P g) ->  P (GCBranch a gs)) ->
       forall g : gcType, part_of_all p g -> P g.
Proof.
intros. move : g H3. fix IH 2. intros. destruct H3.
apply/H. done.
destruct (comp_dir p a) eqn:Heqn. apply/H. rewrite Heqn. done.
apply/H0. apply/none_not. done. done. apply/IH. done.
apply/H1. done. destruct (comp_dir p a) eqn:Heqn.
apply/H1. rewrite Heqn. done. apply/H2. apply/none_not. done.
intros. apply/H3. done. intros. apply/IH. apply/H3. done. Qed.

Variant FinSeq_gen (R : gcType ->  Prop) : gcType   -> Prop :=
 | fin_seq_msg e0  d u :  R e0 -> FinSeq_gen R  (GCMsg d u e0)
 | fin_seq_branch (es : seq gcType)  d :  Forall R es -> FinSeq_gen R (GCBranch d es)
 | fin_seq_end :   FinSeq_gen R GCEnd .

Lemma FinSeq_gen_mon : monotone1 FinSeq_gen.
Proof.
move => x0 x1. intros. induction IN;try done. con. eauto. con. apply/List.Forall_forall. eauto.
intros. move/List.Forall_forall : H. eauto.
con.
Qed.

Hint Resolve FinSeq_gen_mon : paco.

Notation Finite := (paco1 FinSeq_gen bot1).
Lemma Finite_msg : forall a u g0,  Finite (GCMsg a u g0) -> Finite g0.
Proof.
intros. punfold H. inv H. pclearbot=>//=.
Qed.

Lemma Finite_branch : forall a g (gs : seq gcType),  Finite (GCBranch a gs) -> In g gs -> Finite g.
Proof.
intros. punfold H. inv H. injt.
forallApp H2 H0=> [] //=[] //=.
Qed.

Hint Resolve  Finite_msg  Finite_branch.

Lemma Finite_coerce : forall a gs, Finite (GCBranch a gs) -> exists (gs' : seq gcType), gs = gs'.
Proof.
intros. punfold H. inv H. exists es. done.
Qed.

Inductive cproject_gen (p : ptcp) (R : gcType ->  lcType -> Prop) : gcType -> lcType -> Prop :=
 | cproject_msg_s g0 a e0 u d : comp_dir p a = Some d ->
                                  R g0 e0 -> cproject_gen p R (GCMsg a u g0) (ECMsg d (action_ch a) u e0)
 | cproject_msg_n g0 a e0 u : comp_dir p a = None ->
                                 R g0 e0 -> part_of_all p g0 ->  cproject_gen p R (GCMsg a u g0) e0(*assumption has to build something*)
 | cproject_gen_branch_f (gs : seq gcType) (es : seq lcType) a d :  comp_dir p a = Some d -> size gs = size es ->
                                        (forall p, In p (zip gs es) ->  R p.1 p.2 ) -> cproject_gen p R (GCBranch a gs) (ECBranch d (action_ch a) es)
 | cproject_gen_branch_o g (gs : seq gcType)  a e : comp_dir p a = None -> In g gs ->  (*We need list to be non -empty otherweise it projects to anything*)
                                    (forall g', In g' gs ->  part_of_all p g' /\  R g' e) ->  cproject_gen p R (GCBranch a gs) e
 | cproject_gen_end g : ~ part_of p g -> Finite g -> cproject_gen p R g ECEnd. (*Finite predicate ensures coinductive lists in the global type are finite*)
Hint Constructors cproject_gen.

Lemma cproject_gen_mon p: monotone2 (cproject_gen p).
Proof.
move => x0 x1. intros. induction IN;try done.
con;eauto. con;eauto. con;eauto. econstructor;eauto.
intros. ssa. move/H1 : H2.  ssa. apply/LE. move/H1 : H2. ssa. con.
done. done.
Qed.

Hint Resolve cproject_gen_mon : paco.

Definition CProject g p e := paco2 (cproject_gen p) bot2 g e.

Lemma part_of_or_end : forall p g e r, paco2 (cproject_gen p) r g e -> part_of_all p g \/ e = ECEnd.
Proof.
intros. punfold H. inv H;eauto.
left. con.  rewrite H0. eauto.
left. con. comp_disc.
left. econstructor 4. eauto.
intros. move/H2 : H3. ssa.
Qed.

Lemma CProject_not_part : forall g p, paco2 (cproject_gen p) bot2 g ECEnd  ->  ~  part_of p g.
Proof. intros. intro.
elim/part_of_ind2 : H0 H;intros. punfold H0. inv H0;try comp_disc.
apply/H1. punfold H2.
punfold H2.
inv H2;try comp_disc. pclearbot. eauto.
have : ~ part_of p g0 by eauto. done.
punfold H0. inv H0. comp_disc.
have :~  comp_dir p a. eauto. comp_disc.
punfold H3. inv H3. injt. apply H2.  move/H9 : H0. ssa. pclearbot. done.
have : ~ part_of p g0. eauto. done.
Qed.


(*|
#######################################################
How to solve goals with invalid type equalities in Coq?
#######################################################

:Link: https://stackoverflow.com/q/12224318
|*)

(*|
Question
********

My proof scripts are giving me stupid type equalities like ``nat =
bool`` or ``nat = list unit`` which I need to use to solve
contradictory goals.

In normal math, this would be trivial. Given sets ``bool := { true,
false }`` and ``nat := { 0, 1, 2, ... }`` I know that ``true ∈ bool``,
but ``true ∉ nat``, hence ``bool ≠ nat``. In Coq, I don't even know
how to state that ``true :̸ nat``.

Question
========

Is there a way to show that these equalities are false? Or maybe, is
it impossible?
|*)

(*|
Answer (pigworker)
******************

**tl;dr** Cardinality arguments are the only way to show types
unequal. You can certainly automate cardinality arguments more
effectively with a bit of reflection. If you want to go further, give
your types a syntactic representation by constructing a universe,
ensuring your proof obligations are framed as syntactic inequality of
representations rather than semantic inequality of types.

Isomorphism as Equality
=======================

It's widely believed (and there may even be a proof of it somewhere)
that Coq's logic is consistent with the axiom that *isomorphic* sets
are *propositionally equal*. Indeed, this is a consequence of the
Univalence Axiom from Vladimir Voevodsky, which people are having so
much fun with at the moment. I must say, it seems very plausible that
it is consistent (in the absence of typecase), and that a
computational interpretation can be constructed which somehow
transports values between equal types by inserting whichever component
of the isomorphism is needed at any given moment.

If we assume that such an axiom is consistent, we discover that type
inequality in the logic as it stands can hold by only refuting the
existence of type isomorphism. As a result, your partial solution is,
at least in principle, where it's at. Enumerability is rather key to
showing non-isomorphism. I'm not sure what the status of ``nat = (nat
-> nat)`` might be, but it is clear *from outside the system* that
every inhabitant of ``nat -> nat`` has a normal form, and that there
are countably many normal forms: it's at least plausible that there
are consistent axioms or reflection principles which make the logic
more *intensional* and which validate that hypothesis.

Automating Cardinality Arguments
================================

I can see two steps you might take to improve on the present
situation. The less radical step is to improve your generic technology
for making these cardinality arguments by better use of reflection.
You're ideally placed to do so, because in general, you're looking to
show that a finite set is distinct from some larger set. Suppose we
have some notion of ``DList A``, a list of distinct elements of ``A``.
If you can construct an *exhaustive* ``DList A`` and a *longer*
``DList B``, then you can disprove ``A = B``.

There's a lovely definition of ``DList`` by *induction-recursion*, but
Coq doesn't have induction-recursion. Fortunately, it's one of those
definitions we can simulate by careful use of indexing. Forgive my
informal syntax, but let's have

.. code::

    Parameters
      A   : Set
      d   : A -> A -> bool
      dok : forall x y, d x y = true -> x = y -> False

That's ``d`` for "distinct". If a set already has decidable equality,
you can equip it with ``d`` very easily. A large set can be equipped
with an adequate ``d`` for our purposes with not much work. And
actually, that's the crucial step: following the wisdom of the
SSReflect team, we take advantage of the smallness of our domain by
working with ``bool`` rather than ``Prop``, and make the computer do
the heavy lifting.

Now, let us have

.. code::

    DListBody : (A -> bool) -> Set

where the index is the *freshness test* for the list

.. code::

    dnil  : DListBody (const true) (* any element is fresh for the empty list *)
    dsnoc : forall f, (xs : DListBody f) -> (x : A) -> is_true (f x) ->
              DListBody (fun y => f y /\ d x y)

And if you like, you can define ``DList`` wrapping ``DListBody``
existentially. Perhaps that's actually hiding information we want,
though, because to show such a thing exhaustive goes like this:

.. code::

    Exhaustive (f : A -> bool) (mylist : DListBody f) = forall x : A, is_false (f x)

So if you can write down a ``DListBody`` for a finite enumeration, you
can prove it exhaustive just by a case analysis with trivial subgoals.

You then need only make the pigeonholing argument once. When you want
to disprove an equality between types (assuming you already have
suitable candidates for ``d``), you exhaustively enumerate the smaller
and exhibit a longer list from the larger, and that's it.

Working in a Universe
=====================

The more radical alternative is to question why you are getting these
goals in the first place, and whether they really mean what you want
them to. What are types supposed to be, really? There are multiple
possible answers to that question, but it is at least open that they
are in some sense "cardinalities". If you want to think of types as
being more concrete and syntactic, distinct if they are built by
distinct constructions, then you may need to equip types with a more
concrete representation by working in a universe. You define an
inductive datatype of "names" for types, together with the means to
decode names as types, then you reframe your development in terms of
names. You should find that inequality of names follows by ordinary
constructor discrimination.

The snag is that universe constructions can be a bit tricky in Coq,
again because induction-recursion is unsupported. It depends heavily
on what types you need to consider. Maybe you can define inductively
some ``U : Set`` then implement a recursive decoder ``T : U -> Set``.
That's certainly plausible for universes of simple types. If you want
a universe of dependent types, things get a bit sweatier. You can at
least do this much

.. code::

    U : Type   (* note that we've gone up a size *)
    NAT : U
    PI : forall (A : Set), (A -> U) -> U

    T : U -> Set
    T NAT = nat
    T (PI A B) = forall (a : A), T (B a)

but note that the domain of ``PI`` is unencoded in ``Set``, not in
``U``. The inductive-recursive Agdans can get over this, defining
``U`` and ``T`` simultaneously

.. code::

    U : Set   (* nice and small *)
    NAT : U
    PI : forall (A : U), (T A -> U) -> U   (* note the use of T *)

    T : U -> Set
    T NAT = nat
    T (PI A B) = forall (a : T A), T (B a)

but Coq won't have that. Again, the workaround is to use indexing.
Here the cost is that ``U`` is inevitably large.

.. code::

    U : Set -> Type
    NAT : U nat
    PI : forall (A : Set) (B : A -> Set),
           U A -> (forall a, U (B a)) -> U (forall a, B a)

But you can still get a lot of stuff done with a universe built that
way. For example, one can equip such a universe with a computationally
effective `extensional equality
<https://personal.cis.strath.ac.uk/conor.mcbride/pub/JOTT/coq/ott.v>`__.
|*)

(*|
Answer (nobody)
***************

expanded *partial* solution
===========================

For reference, here is my proof for ``nat = bool -> False``. (It's
quite long but I hope it's easy to see the general structure of this
proof.)
|*)

Goal nat = bool -> False.
(* For any two types, if they are actually identical, the identity is an
   isomorphism. *)
Proof.
  assert (forall T U : Set,
             T = U -> exists (f : T -> U) (g : U -> T),
               (forall t, g (f t) = t) /\ (forall u, f (g u) = u))
    as Hiso
      by (intros T U H; rewrite H; exists (@id U); exists (@id U);
          split; intro; reflexivity).
  (* our nat = bool *)
  intro HC.
  (* combining the facts gives an iso between nat and bool *)
  pose proof (Hiso nat bool HC); clear HC Hiso.
  inversion H as [phi [phi_inv [Hl Hr]]]; clear H Hr.
  (* this breaks because ||bool|| = 2 while ||nat|| > 2 -- we get collisions *)
  assert (forall m n o, phi m = phi n \/ phi n = phi o \/ phi m = phi o)
    by (intros m n o;
        case (phi m); case (phi n); case (phi o); clear; tauto).
  (* building the collision for 0, 1 and 2 *)
  pose proof (H 0 1 2) as HC; clear H.
  (* (false) identity preservation for 0, 1, 2 *)
  pose proof (Hl 0) as H0; pose proof (Hl 1) as H1;
    pose proof (Hl 2) as H2; clear Hl.
  (* case analysis on phi calls yields equalities on non-equal numbers... *)
  destruct (phi 0); destruct (phi 1); destruct (phi 2);
    (* ...rewriting leads to an equality '0 = 2' or '0 = 1' or '1 = 2'... *)
    try (rewrite H2 in H0); try (rewrite H1 in H0); try (rewrite H2 in H1);
  (* ...which can be used to solve by constructor inequality *)
    try inversion H0; inversion H1.
Qed.

(*|
As you can see, this is not really usable for large finite types (even
if automated) -- the terms are too big. Any improvement on this would
be great.
|*)


Require Import Base.
Require Import Kleene.
Require Import RealAxioms.
Require Import RealRing.
Require Import RealOrder.

Open Scope Real_scope.

(* Lemma Reallt_add_r : forall z x y, x + z < y + z -> x < y. *)
(* Proof. *)
(*   intros. *)
(*   pose proof (Reallt_plus_lt (-z) _ _ H). *)
(*   ring_simplify in H0. *)
(*   exact H0. *)
(* Qed. *)

(* Lemma Realgt_add_r : forall z x y, x + z > y + z -> x > y. *)
(* Proof. *)
(*   intros. *)
(*   pose proof (Reallt_plus_lt (-z) _ _ H). *)
(*   ring_simplify in H0. *)
(*   exact H0. *)
(* Qed. *)

(* Lemma Realle_add_r : forall z x y, x + z <= y + z -> x <= y. *)
(* Proof. *)
(*   intros. *)
(*   destruct H. *)
(*   left. *)
(*   exact (Reallt_add_r z x y H). *)
(*   right. *)
(*   pose proof (lp _ _ (fun k => k - z) _ _ H). *)
(*   simpl in H0. *)
(*   ring_simplify in H0. *)
(*   exact H0. *)
(* Qed. *)

(* Lemma Realge_add_r : forall z x y, x + z >= y + z -> x >= y. *)

Inductive ltac_No_arg : Set :=
  | ltac_no_arg : ltac_No_arg.

Ltac Tac_Real_order s t :=
  match (type of s) with
  |  (?A < ?B) =>
     match (type of t) with
     | _  =>
       ((apply (real_lt_plus_lt t _ _) in s);
        ring_simplify in s)
     | ltac_No_arg =>
       ((apply (real_lt_plus_lt (- B) _ _) in s);
        ring_simplify in s)
     | _ => fail "has to be Real"
     end

  | (?A <= ?B) =>
    match (type of t) with
    | _  =>
      ((apply (real_le_plus_le t _ _) in s);
       ring_simplify in s)
    | ltac_No_arg =>
      ((apply (real_le_plus_le (- B) _ _) in s);
       ring_simplify in s)
    | _ => fail "has to be Real"
    end

  |  (?A >= ?B) =>
     match (type of t) with
     | _  =>
       ((apply (real_ge_plus_ge t _ _) in s);
        ring_simplify in s)
     | ltac_No_arg =>
       ((apply (real_ge_plus_ge (- B) _ _) in s);
        ring_simplify in s)
     end

  | _ =>
    match goal with
    | |- (?A < ?B) =>
      match (type of s) with
      | _  =>
        (apply (real_lt_add_r s _ _);
         ring_simplify )
      | ltac_No_arg =>
        ((apply (real_lt_add_r (- B) _ _));
         ring_simplify)
      | _ => fail "has to be Real"
      end

    |  |- (?A <= ?B) =>
       match (type of s) with
       | _  =>
         (apply (real_le_add_r s _ _);
          ring_simplify)
       | ltac_No_arg =>
         ((apply (real_le_add_r (- B) _ _));
          ring_simplify)
       | _ => fail "has to be Real"
       end
    |  |- (?A >= ?B) =>

       match (type of s) with
       | _  =>
         (apply (real_ge_add_r s _ _);
          ring_simplify)
       | ltac_No_arg =>
         ((apply (real_ge_add_r (- B) _ _));
          ring_simplify)
       | _ => fail "has to be Real"
       end

    | |- ?A => fail "cannot clean the ineqaulity" s
    end
  end
.

Tactic Notation "add_both_side_by" :=
  Tac_Real_order ltac_no_arg ltac_no_arg.
Tactic Notation "add_both_side_by" constr(x) :=
  Tac_Real_order x ltac_no_arg.
Tactic Notation "add_both_side_by" constr(x) constr(y) :=
  Tac_Real_order x y.

(* Goal forall z x y, x + z >= y + z -> x >= y. *)
(*   intros. *)
(*   add_both_side_by. *)
(*   add_both_side_by (-x). *)
(*    H (-z). *)
(*   mv_all_left. *)

  (* | |- (¬¬ ?A) => *)
  (*   match (type of s) with *)
  (*   | ¬¬ ?T => *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ¬ ¬ ?T => *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ↑↓ ?T => *)
  (*     apply sdn in s; *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ↑ (↓ ?T) => *)
  (*     apply sdn in s; *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | _ => fail "type of the argument is supposed to be ¬¬ ?A" *)
  (*   end *)

  (* | |- neg (neg _) => *)
  (*   match (type of s) with *)
  (*   | ¬¬ ?T => *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ¬ ¬ ?T => *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)
  (*   | ↑↓ ?T => *)
  (*     apply sdn in s; *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)
  (*   | ↑ (↓ ?T) => *)
  (*     apply sdn in s; *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | _ => fail "type of the argument is supposed to be ¬¬ ?A" *)

  (*   end *)
  (* | |- ↑ ?A => *)
  (*   match (type of s) with *)
  (*   | ¬¬ ?T => *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ¬ ¬ ?T => *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ↑↓ ?T => *)
  (*     apply sdn in s; *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ↑ (↓ ?T) => *)
  (*     apply sdn in s; *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | _ => fail "type of the argument is supposed to be ¬¬ ?A" *)
  (*   end *)
  (* | |- updown ?A => *)
  (*   match (type of s) with *)
  (*   | ¬¬ ?T => *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ¬ ¬ ?T => *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ↑↓ ?T => *)
  (*     apply sdn in s; *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | ↑ (↓ ?T) => *)
  (*     apply sdn in s; *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in intro st; apply st in s; clear st)) *)
  (*     + *)
  (*     ((apply (cprop_dn_elim_intro T)); *)
  (*      (let st := (fresh s) in *)
  (*       intro st; *)
  (*       let stt := (fresh st) in pose proof (st s) as stt; clear st)) *)

  (*   | _ => fail "type of the argument is supposed to be ¬¬ ?A" *)
  (*   end *)
  (* | |- ?A => fail "Goal has to be either ¬¬ ?A or ↑ ?A But " A " is given" *)
  (* end. *)


Require Export PredMonad.Ordered.OrderedType.
Import OTermNotations.

(***
 *** The monad typeclass
 ***)

Class MonadOps (M : OType -> OType) : Type :=
  { returnM : forall {A}, A -o> M A;
    bindM : forall {A B}, M A -o> (A -o> M B) -o> M B }.

Class Monad (M : OType -> OType) {MonadOps:MonadOps M} : Prop :=
  {
    monad_return_bind :
      forall {A B ctx} (f: OTerm ctx (A -o> M B)) x,
        !bindM @o@ (!returnM @o@ x) @o@ f =o= f @o@ x;

    monad_bind_return :
      forall {A ctx} (m: OTerm ctx (M A)),
        !bindM @o@ m @o@ !returnM =o= m;

    monad_assoc :
      forall {A B C ctx} m (f:OTerm ctx (A -o> M B)) (g:OTerm ctx (B -o> M C)),
        !bindM @o@ (!bindM @o@ m @o@ f) @o@ g
        =o=
        !bindM @o@ m @o@ (pfun (x:::_) ==> !bindM @o@ (!f @o@ !x) @o@ !g);

  }.

(* Helpful bind notation *)
Notation "'do' x <- m1 ; m2" :=
  ((!bindM @o@ m1%pterm @o@ (pfun (x:::_) ==> m2%pterm))%pterm)
    (at level 60, right associativity).

(*
Check (fun `{Monad} => do x <- returnM @o@ ot_fst; !returnM @o@ ot_fst).
 *)

Definition Identity (X:OType) := X.

Instance IdMonad_MonadOps : MonadOps Identity :=
  { returnM := fun A => (pfun (x:::_) ==> x)%pterm;
    bindM := fun A B => (pfun (m:::_) ==> pfun (f:::_) ==> f @o@ !m)%pterm; }.

Instance IdMonad : Monad Identity.
Proof.
  constructor.
  { intros. unfold bindM, returnM, IdMonad_MonadOps.
    admit. }
Admitted.

(* FIXME HERE NOW: need rewrite rules for beta! *)