(** * Definition of the part of boolean-returning CFG parser-recognizer that instantiates things to lists *)
Require Import Coq.Lists.List Coq.Strings.String Coq.Arith.Wf_nat.
Require Import Coq.Strings.Ascii.
Require Import Coq.omega.Omega.
Require Import Fiat.Common.StringOperations.
Require Import Fiat.Common.StringFacts.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Equality.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.BaseTypes Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Common.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.

Set Implicit Arguments.
Local Open Scope type_scope.
Local Open Scope string_like_scope.

Local Arguments leb !_ !_.

Section recursive_descent_parser_list.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HLSP : StringLikeProperties Char} {G : pregrammar Char}
          (Char_beq : Char -> Char -> bool).
  Definition rdp_list_nonterminals_listT : Type := list nat.
  Notation rdp_list_nonterminal_carrierT := default_nonterminal_carrierT.
  (** (nonterminal, production_index, drop_count) *)
  Notation rdp_list_production_carrierT := default_production_carrierT.

  Definition list_bin_eq
    := Eval unfold list_bin in list_bin EqNat.beq_nat.

  Definition rdp_list_is_valid_nonterminal : rdp_list_nonterminals_listT -> rdp_list_nonterminal_carrierT -> bool
    := fun ls nt => list_bin_eq nt ls.

  Local Ltac fix_list_bin_eq :=
    unfold rdp_list_is_valid_nonterminal;
    change list_bin_eq with (list_bin EqNat.beq_nat) in *.

  Local Notation valid_nonterminals := (map fst (pregrammar_productions G)).

  Definition rdp_list_initial_nonterminals_data
  : rdp_list_nonterminals_listT
    := up_to (List.length valid_nonterminals).

  Definition rdp_list_of_nonterminal
  : String.string -> rdp_list_nonterminal_carrierT
    := fun nt => first_index_default
                   (string_beq nt)
                   (List.length valid_nonterminals)
                   valid_nonterminals.
  Definition rdp_list_to_nonterminal
  : rdp_list_nonterminal_carrierT -> String.string
    := default_to_nonterminal (G := G).

  Definition rdp_list_to_production : rdp_list_production_carrierT -> production Char
    := default_to_production (G := G).

  Definition rdp_list_nonterminal_to_production : rdp_list_nonterminal_carrierT -> list rdp_list_production_carrierT
    := fun nt_idx
       => List.map
            (fun p_idx : nat => (nt_idx, (p_idx, 0)))
            (up_to (List.length (Lookup G (rdp_list_to_nonterminal nt_idx)))).

  Definition rdp_list_production_tl : rdp_list_production_carrierT -> rdp_list_production_carrierT
    := (default_production_tl (G := G)).

  Local Ltac t' :=
    idtac;
    match goal with
      | _ => assumption
      | _ => omega
      | _ => congruence
      | _ => discriminate
      | [ H : first_index_error _ _ = Some _ |- _ ] => apply first_index_error_Some_correct in H
      | [ H : first_index_error _ _ = None |- _ ] => rewrite first_index_error_None_correct in H
      | _ => intro
      | [ H : and _ _ |- _ ] => destruct H
      | [ H : ex _ |- _ ] => destruct H
      | [ H : string_beq _ _ = true |- _ ] => apply string_bl in H
      | _ => progress subst
      | [ |- nth _ _ _ = _ ] => apply nth_error_Some_nth
      | [ H : ?T |- _ <-> ?T ] => split; [ intro; assumption | intro ]
      | [ H : is_true (list_bin _ _ _) |- _ ] => apply (list_in_bl (@beq_nat_true)) in H
      | [ |- is_true (list_bin _ _ _) ] => apply list_in_lb; [ intros ???; subst; symmetry; apply beq_nat_refl | ]
      | [ H : In _ (up_to _) |- _ ] => apply in_up_to_iff in H
      | [ |- In _ (up_to _) ] => apply in_up_to_iff
      | [ H : In ?nt _ |- _ ] => let H' := fresh in assert (H' : string_beq nt nt = false) by eauto; exfalso; clear -H'
      | [ H : context[string_beq ?x ?x] |- _ ] => rewrite (string_lb eq_refl) in H
      | [ |- _ <-> _ ] => split
      | [ |- In (nth _ ?ls _) ?ls ] => apply nth_In; assumption
      | [ H : nth_error _ _ = Some _ |- _ ]
        => let H' := fresh in
           pose proof H as H';
             apply nth_error_In in H;
             apply nth_error_Some_short in H'
      | [ |- ?x < ?y ] => destruct (le_lt_dec y x); [ exfalso | assumption ]
      | [ H : context[nth ?nt ?ls ?d] |- _ ]
        => rewrite nth_overflow in H by assumption
      | [ H : In some_invalid_nonterminal _ |- _ ]
        => apply some_invalid_nonterminal_invalid in H
      | _ => progress simpl in *
      | [ |- In (nth _ (uniquize ?beq ?ls) _) ?ls ]
        => apply (uniquize_In _ beq)
      | [ H : In ?x (uniquize ?beq ?ls) |- In ?x ?ls ]
        => eapply uniquize_In; eexact H
      | [ H : forall elem, In elem (uniquize ?beq ?ls) -> ?beq ?nt elem = false,
            H' : In ?nt ?ls
            |- _ ]
        => exfalso; specialize (H nt)
      | _ => progress specialize_by ltac:(apply uniquize_In_refl; first [ apply string_lb; reflexivity | apply @string_bl | assumption ])
    end.

  Local Ltac t := repeat t'.

  Definition rdp_list_initial_nonterminals_correct'
  : forall nt,
      is_true (rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt) <-> List.In (rdp_list_to_nonterminal nt) (Valid_nonterminals G).
  Proof.
    fix_list_bin_eq.
    unfold rdp_list_is_valid_nonterminal, rdp_list_to_nonterminal, rdp_list_initial_nonterminals_data, default_to_nonterminal.
    intro nt.
    t.
  Qed.

  Definition rdp_list_initial_nonterminals_correct
  : forall nt,
      is_true (rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data (rdp_list_of_nonterminal nt)) <-> List.In nt (Valid_nonterminals G).
  Proof.
    fix_list_bin_eq.
    unfold rdp_list_is_valid_nonterminal, rdp_list_of_nonterminal, rdp_list_initial_nonterminals_data.
    intro nt.
    rewrite first_index_default_first_index_error.
    destruct (first_index_error (string_beq nt) valid_nonterminals) eqn:H'; t.
  Qed.

  Lemma rdp_list_find_to_nonterminal idx
  : List.first_index_error
      (string_beq (rdp_list_to_nonterminal idx))
      valid_nonterminals
    = bool_rect
        (fun _ => option _)
        (Some idx)
        (None)
        (Compare_dec.leb (S idx) (List.length valid_nonterminals)).
  Proof.
    apply default_find_to_nonterminal.
  Qed.

  Lemma rdp_list_to_of_nonterminal
  : forall nt,
      List.In nt (Valid_nonterminals G)
      -> rdp_list_to_nonterminal (rdp_list_of_nonterminal nt) = nt.
  Proof.
    unfold rdp_list_to_nonterminal, rdp_list_of_nonterminal, default_to_nonterminal.
    intro nt.
    rewrite first_index_default_first_index_error.
    destruct (first_index_error (string_beq nt) valid_nonterminals) eqn:H';
      t.
  Qed.

  Lemma rdp_list_of_to_nonterminal
  : forall nt,
      is_true (rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt)
      -> rdp_list_of_nonterminal (rdp_list_to_nonterminal nt) = nt.
  Proof.
    pose proof (nonterminals_unique G) as HNoDup.
    hnf in HNoDup.
    simpl in *.
    unfold rdp_list_to_nonterminal, rdp_list_of_nonterminal, rdp_list_is_valid_nonterminal, rdp_list_initial_nonterminals_data, default_to_nonterminal.
    intros nt H.
    apply (list_in_bl (@beq_nat_true)), in_up_to_iff in H.
    revert nt H.
    replace valid_nonterminals with (uniquize string_beq valid_nonterminals) by (rewrite HNoDup; reflexivity).
    induction valid_nonterminals as [|x xs IHxs].
    { simpl; intros; omega. }
    { simpl in *.
      destruct (list_bin string_beq x (uniquize string_beq xs)) eqn:Hbin; try assumption.
      { apply (f_equal (@List.length _)) in HNoDup.
        simpl in *.
        pose proof (uniquize_shorter xs string_beq) as H'.
        rewrite HNoDup in H'.
        exfalso; clear -H'.
        omega. }
      apply (f_equal (@tl _)) in HNoDup; simpl @tl in HNoDup.
      specialize_by assumption.

      intros [|nt].
      { simpl.
        rewrite (string_lb eq_refl); trivial. }
      { simpl Datatypes.length.
        intro H.
        apply lt_S_n in H.
        etransitivity; [ | eapply (f_equal S), (IHxs _ H); clear IHxs ].
        rewrite first_index_default_S_cons; simpl.
        match goal with
          | [ |- context[string_beq ?x ?y] ]
            => destruct (string_beq x y) eqn:H'
        end; simpl;
        [ exfalso | reflexivity ].
        clear -Hbin H H'.
        apply string_bl in H'.
        subst.
        rewrite list_in_lb in Hbin; [ congruence | apply @string_lb | ].
        apply nth_In; assumption. } }
  Qed.

  Definition rdp_list_production_carrier_valid
  : rdp_list_production_carrierT -> bool
    := default_production_carrier_valid (G := G).

  Lemma rdp_list_production_tl_correct
  : forall p,
      rdp_list_to_production (rdp_list_production_tl p) = tl (rdp_list_to_production p).
  Proof.
    unfold rdp_list_to_production, rdp_list_production_tl, default_production_tl, default_to_production; simpl.
    intros [? [? p]]; rewrite tl_drop; simpl.
    do 2 try
       match goal with
         | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?; simpl
       end;
      repeat match goal with
               | _ => destruct p; reflexivity
               | _ => assumption
               | _ => omega
               | [ H : leb _ _ = false |- _ ] => apply leb_iff_conv in H
               | [ H : ?x < 1 |- _ ] => assert (x = 0) by omega; clear H
               | [ H : ?x = 0 |- context[?x] ] => rewrite H
               | [ H : ?x = nil |- context[?x] ] => rewrite H
               | [ H : List.length ?x = 0 |- _ ] => assert (x = nil) by (destruct x; simpl in *; trivial; discriminate); clear H
               | _ => progress simpl in *
               | _ => reflexivity
               | [ H : _ < S _ |- _ ] => apply le_S_n in H
               | _ => rewrite drop_all by assumption
               | [ |- nil = drop _ _ ] => symmetry; apply drop_all
               | [ |- context[List.length (tl ?x)] ] => destruct x eqn:?
             end.
  Qed.

  Local Arguments List.nth _ !_ !_ _.
  Local Arguments minus !_ !_.

  Lemma rdp_list_nonterminal_to_production_correct
  : forall nt,
      List.In nt (Valid_nonterminals G)
      -> List.map rdp_list_to_production (rdp_list_nonterminal_to_production (rdp_list_of_nonterminal nt))
         = Lookup G nt.
  Proof.
    intros nt Hvalid.
    unfold rdp_list_to_production, rdp_list_nonterminal_to_production, default_to_production.
    rewrite map_map; simpl.
    rewrite !rdp_list_to_of_nonterminal by assumption.
    rewrite <- list_to_productions_to_nonterminal.
    change default_to_nonterminal with rdp_list_to_nonterminal.
    rewrite rdp_list_to_of_nonterminal by assumption.
    induction (Lookup_string G nt) as [|p ps IHps]; simpl.
    { reflexivity. }
    { simpl.
      rewrite minus_diag; simpl.
      apply f_equal.
      etransitivity; [ | apply IHps ]; clear IHps.
      apply map_ext_in.
      intros a H; apply in_up_to_iff in H.
      rewrite NPeano.Nat.sub_succ_r.
      destruct (Datatypes.length ps - a) eqn:H'; try omega; [].
      reflexivity. }
  Qed.

  Lemma rdp_list_production_tl_valid
  : forall p,
      rdp_list_production_carrier_valid p -> rdp_list_production_carrier_valid (rdp_list_production_tl p).
  Proof.
    unfold rdp_list_production_carrier_valid, default_production_carrier_valid, rdp_list_production_tl, default_production_tl; simpl; trivial.
    repeat match goal with
             | _ => progress simpl in *
             | _ => intro
             | _ => progress unfold is_true in *
             | [ |- andb ?x ?y = true ] => apply Bool.andb_true_iff
             | [ H : andb ?x ?y = true |- _ ] => apply Bool.andb_true_iff in H
             | [ H : and _ _ |- _ ] => destruct H
             | [ H : ?x = true |- context[?x] ] => rewrite H
             | [ |- ?x = ?x ] => reflexivity
             | [ |- and _ _ ] => split
             | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
           end.
  Qed.

  Local Arguments leb !_ !_.

  Lemma rdp_list_nonterminal_to_production_valid
  : forall nt,
      rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt
      -> List.Forall rdp_list_production_carrier_valid (rdp_list_nonterminal_to_production nt).
  Proof.
    unfold rdp_list_production_carrier_valid, rdp_list_is_valid_nonterminal, rdp_list_initial_nonterminals_data, rdp_list_nonterminal_to_production.
    intros nt Hnt.
    apply Forall_map, Forall_forall; unfold compose; simpl; intros ? H.
    fix_list_bin_eq.
    apply list_in_bl in Hnt; [ | exact (EqNat.beq_nat_true) ].
    apply in_up_to_iff in Hnt.
    unfold default_production_carrier_valid; simpl.
    repeat (apply Bool.andb_true_iff; split); apply leb_iff.
    { rewrite map_length in Hnt.
      exact Hnt. }
    { apply in_up_to_iff in H.
      rewrite <- list_to_productions_to_nonterminal.
      exact H. }
    { omega. }
  Qed.

  Lemma rdp_list_production_carrier_valid_reachable (idx : rdp_list_production_carrierT)
        (Hvalid : rdp_list_production_carrier_valid idx)
  : production_is_reachable G (rdp_list_to_production idx).
  Proof.
    unfold production_is_reachable, rdp_list_production_carrier_valid, default_production_carrier_valid, rdp_list_production_carrierT in *.
    repeat setoid_rewrite Bool.andb_true_iff in Hvalid.
    repeat setoid_rewrite Compare_dec.leb_iff in Hvalid.
    destruct_head and.
    simpl in *.
    exists (rdp_list_to_nonterminal (fst idx)).
    unfold rdp_list_to_production, default_to_production in *; simpl in *.
    match goal with
      | [ |- appcontext[In (_ ++ Operations.List.drop ?n ?ls)%list _] ]
        => exists (Operations.List.take n ls)
    end.
    rewrite app_take_drop.
    split.
    { apply rdp_list_initial_nonterminals_correct'.
      unfold rdp_list_is_valid_nonterminal, rdp_list_initial_nonterminals_data.
      fix_list_bin_eq.
      apply list_in_lb; [ apply beq_nat_true_iff | ].
      rewrite map_length.
      apply in_up_to; assumption. }
    { unfold rdp_list_to_nonterminal.
      rewrite list_to_productions_to_nonterminal.
      destruct (Lookup_idx G (fst idx)) eqn:Heq.
      { simpl in *.
        omega. }
      { apply nth_In.
        simpl; omega. } }
  Qed.

  Definition filter_out_eq nt ls
    := Eval unfold filter_out in filter_out (EqNat.beq_nat nt) ls.

  Definition rdp_list_remove_nonterminal : rdp_list_nonterminals_listT -> rdp_list_nonterminal_carrierT -> rdp_list_nonterminals_listT
    := fun ls nt =>
         filter_out_eq nt ls.

  Local Ltac fix_filter_out_eq :=
    unfold rdp_list_remove_nonterminal;
    change filter_out_eq with (fun nt ls => filter_out (EqNat.beq_nat nt) ls); cbv beta;
    setoid_rewrite filter_out_filter.

  Local Ltac fix_eqs := try fix_filter_out_eq; try fix_list_bin_eq.

  Definition rdp_list_nonterminals_listT_R : rdp_list_nonterminals_listT -> rdp_list_nonterminals_listT -> Prop
    := ltof _ (@List.length _).
  Lemma filter_list_dec {T} f (ls : list T) : List.length (filter f ls) <= List.length ls.
  Proof.
    induction ls; trivial; simpl in *.
    repeat match goal with
             | [ |- context[if ?a then _ else _] ] => destruct a; simpl in *
             | [ |- S _ <= S _ ] => solve [ apply Le.le_n_S; auto ]
             | [ |- _ <= S _ ] => solve [ apply le_S; auto ]
           end.
  Qed.
  Lemma rdp_list_remove_nonterminal_dec : forall ls prods,
                                            @rdp_list_is_valid_nonterminal ls prods = true
                                            -> @rdp_list_nonterminals_listT_R (@rdp_list_remove_nonterminal ls prods) ls.
  Proof.
    intros ls prods H.
    unfold rdp_list_is_valid_nonterminal, rdp_list_nonterminals_listT_R, rdp_list_remove_nonterminal, ltof in *.
    fix_eqs.
    apply list_in_bl in H; [ | solve [ intros; apply beq_nat_true; trivial ] ].
    match goal with
      | [ H : In ?prods ?ls |- context[filter ?f ?ls] ]
        => assert (~In prods (filter f ls))
    end.
    { intro H'.
      apply filter_In in H'.
      destruct H' as [? H'].
      rewrite <- beq_nat_refl in H'.
      simpl in *; congruence. }
    { match goal with
        | [ |- context[filter ?f ?ls] ] => generalize dependent f; intros
      end.
      induction ls; simpl in *; try congruence.
      repeat match goal with
               | [ |- context[if ?x then _ else _] ] => destruct x; simpl in *
               | [ H : _ \/ _ |- _ ] => destruct H
               | _ => progress subst
               | [ H : ~(_ \/ _) |- _ ] => apply Decidable.not_or in H
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ H : ?x <> ?x |- _ ] => exfalso; apply (H eq_refl)
               | _ => apply Lt.lt_n_S
               | _ => apply Le.le_n_S
               | _ => apply filter_list_dec
               | [ H : _ -> _ -> ?G |- ?G ] => apply H; auto
             end. }
  Qed.
  Lemma rdp_list_ntl_wf : well_founded rdp_list_nonterminals_listT_R.
  Proof.
    unfold rdp_list_nonterminals_listT_R.
    intro.
    apply well_founded_ltof.
  Defined.

  Lemma rdp_list_remove_nonterminal_1
  : forall ls ps ps',
      rdp_list_is_valid_nonterminal (rdp_list_remove_nonterminal ls ps) ps' = true
      -> rdp_list_is_valid_nonterminal ls ps' = true.
  Proof.
    unfold rdp_list_is_valid_nonterminal, rdp_list_remove_nonterminal.
    fix_eqs.
    repeat match goal with
             | _ => exfalso; congruence
             | _ => reflexivity
             | _ => assumption
             | [ |- appcontext[if ?E then _ else _] ] => destruct E
             | _ => intro
             | [ H : In _ (filter _ _) |- _ ] => apply filter_In in H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
             | [ H : list_bin _ _ _ = true |- _ ] => apply list_in_bl in H; [ | solve [ intros; apply beq_nat_true; trivial ] ]
             | [ |- list_bin _ _ _ = true ] => apply list_in_lb
             | _ => progress subst
             | [ |- context[beq_nat ?x ?x] ] => rewrite <- beq_nat_refl
           end.
  Qed.

  Lemma rdp_list_remove_nonterminal_2
  : forall ls ps ps',
      rdp_list_is_valid_nonterminal (rdp_list_remove_nonterminal ls ps) ps' = false
      <-> rdp_list_is_valid_nonterminal ls ps' = false \/ ps = ps'.
  Proof.
    unfold rdp_list_is_valid_nonterminal, rdp_list_remove_nonterminal.
    fix_eqs.
    repeat match goal with
             | _ => exfalso; congruence
             | _ => reflexivity
             | _ => progress subst
             | _ => intro
             | [ H : @eq bool ?x ?y -> False |- _ ] => apply Bool.eq_true_not_negb in H
             | [ H : context[In _ (filter _ _)] |- _ ] => rewrite filter_In in H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
             | [ |- true = false \/ _ ] => right
             | [ |- ?x = ?x \/ _ ] => left; reflexivity
             | [ H : ~(_ /\ ?x = ?x) |- _ ] => specialize (fun y => H (conj y eq_refl))
             | [ H : ~(?T /\ _), H' : ?T |- _ ] => specialize (fun y => H (conj H' y))
             | [ H : (?T /\ _) -> False, H' : ?T |- _ ] => specialize (fun y => H (conj H' y))
             | [ H : _ \/ _ |- _ ] => destruct H
             | [ |- _ <-> _ ] => split
             | [ H : appcontext[match ?E with left _ => _ | right _ => _ end] |- _ ] => destruct E
             | [ |- appcontext[match ?E with left _ => _ | right _ => _ end] ] => destruct E
             | [ H : _ |- _ ] => rewrite Bool.negb_involutive in H
             | [ H : string_beq _ _ = true |- _ ] => apply string_bl in H
             | [ H : context[string_beq ?x ?x] |- _ ] => rewrite (string_lb (eq_refl x)) in H
             | _ => progress simpl in *
             | [ H : list_bin _ _ _ = true |- _ ] => apply list_in_bl in H; [ | solve [ intros; apply beq_nat_true; trivial ] ]
             | [ |- list_bin _ _ _ = true ] => apply list_in_lb
             | [ |- context[list_bin ?x ?y ?z = false] ] => case_eq (list_bin x y z)
             | [ H : list_bin _ _ _ = false |- _ ] => apply Bool.not_true_iff_false in H
             | [ H : list_bin _ _ _ <> true |- _ ] => specialize (fun pf H' => H (list_in_lb pf H'))
             | [ H : ?A -> ?B |- _ ]
               => let H' := fresh in
                  assert (H' : A) by (intros; subst; rewrite <- ?beq_nat_refl; reflexivity);
                    specialize (H H'); clear H'
             | [ H : beq_nat _ _ = true |- _ ] => apply beq_nat_true in H
             | [ H : context[beq_nat ?x ?x] |- _ ] => rewrite <- beq_nat_refl in H
           end.
  Qed.

  Lemma rdp_list_remove_nonterminal_noninc (ls : rdp_list_nonterminals_listT) nonterminal
  : ~ rdp_list_nonterminals_listT_R ls (rdp_list_remove_nonterminal ls nonterminal).
  Proof.
    simpl. unfold ltof, rdp_list_remove_nonterminal.
    fix_eqs.
    intro H.
    cut (Datatypes.length ls < Datatypes.length ls); try omega.
    eapply Lt.lt_le_trans; [ eassumption | ].
    apply filter_list_dec.
  Qed.

  Lemma rdp_list_nonterminals_length_zero
  : forall ls,
      List.length ls = 0
      -> forall nt, rdp_list_is_valid_nonterminal ls nt = false.
  Proof.
    destruct ls; simpl; trivial; intro; exfalso; omega.
  Qed.

  Global Instance rdp_list_predata : @parser_computational_predataT Char
    := { nonterminals_listT := rdp_list_nonterminals_listT;
         initial_nonterminals_data := rdp_list_initial_nonterminals_data;
         of_nonterminal := rdp_list_of_nonterminal;
         to_nonterminal := rdp_list_to_nonterminal;
         production_carrierT := rdp_list_production_carrierT;
         to_production := rdp_list_to_production;
         nonterminal_to_production := rdp_list_nonterminal_to_production;
         production_tl := rdp_list_production_tl;
         production_carrier_valid := rdp_list_production_carrier_valid;
         is_valid_nonterminal := rdp_list_is_valid_nonterminal;
         remove_nonterminal := rdp_list_remove_nonterminal;
         nonterminals_length := @List.length _ }.

  Global Instance rdp_list_rdata' : @parser_removal_dataT' _ G rdp_list_predata
    := { nonterminals_length_zero := rdp_list_nonterminals_length_zero;
         remove_nonterminal_dec := rdp_list_remove_nonterminal_dec;
         remove_nonterminal_noninc := rdp_list_remove_nonterminal_noninc;
         to_of_nonterminal := rdp_list_to_of_nonterminal;
         of_to_nonterminal := rdp_list_of_to_nonterminal;
         production_tl_correct := rdp_list_production_tl_correct;
         nonterminal_to_production_correct := rdp_list_nonterminal_to_production_correct;
         production_tl_valid := rdp_list_production_tl_valid;
         nonterminal_to_production_valid := rdp_list_nonterminal_to_production_valid;
         initial_nonterminals_correct := rdp_list_initial_nonterminals_correct;
         initial_nonterminals_correct' := rdp_list_initial_nonterminals_correct';
         remove_nonterminal_1 := rdp_list_remove_nonterminal_1;
         remove_nonterminal_2 := rdp_list_remove_nonterminal_2 }.
End recursive_descent_parser_list.


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Import type_sys_useful.
Require Import dest_close.

Lemma eq_term_equals_per_partial_eq_if {p} :
  forall lib (eqa1 eqa2 : per(p)),
    eq_term_equals eqa1 eqa2
    -> eq_term_equals (per_partial_eq lib eqa1) (per_partial_eq lib eqa2).
Proof.
  introv eqt.
  unfold eq_term_equals, per_partial_eq; introv; split; intro k; repnd;
  dands; auto; intro hv; autodimp k hyp.
  allrw <-; sp.
  allrw; sp.
Qed.

Lemma per_partial_eq_symmetric {p} :
  forall lib (eq : per(p)) t1 t2,
    term_equality_symmetric eq
    -> per_partial_eq lib eq t1 t2
    -> per_partial_eq lib eq t2 t1.
Proof.
  introv tes per.
  allunfold @per_partial_eq; exrepnd; dands; allrw; try (complete sp).
  introv hv.
  rw <- per0 in hv; sp.
Qed.

Lemma per_partial_eq_transitive {p} :
  forall lib (eq : per(p)) t1 t2 t3,
    term_equality_transitive eq
    -> per_partial_eq lib eq t1 t2
    -> per_partial_eq lib eq t2 t3
    -> per_partial_eq lib eq t1 t3.
Proof.
  introv tet per1 per2.
  allunfold @per_partial_eq; exrepnd.
  dands; try (allrw; complete sp).
  introv hv.
  dup hv as hv2.
  rw per3 in hv2.
  dup hv2 as hv3.
  rw per0 in hv3.
  autodimp per2 hyp.
  autodimp per1 hyp.
  apply tet with (t2 := t2); sp.
Qed.

Lemma per_partial_eq_cequiv {p} :
  forall lib (eq : per(p)) t1 t2,
    term_equality_respecting lib eq
    -> cequivc lib t1 t2
    -> per_partial_eq lib eq t1 t1
    -> per_partial_eq lib eq t1 t2.
Proof.
  introv res ceq per.
  allunfold @per_partial_eq; repnd; dands.

  split; intro k; spcast.
  apply @hasvaluec_cequivc with (t1 := t1); sp.
  apply @hasvaluec_cequivc with (t1 := t2); sp.
  apply cequivc_sym; sp.

  introv h.
  autodimp per hyp;
  try(apply res; sp; spcast; sp).
Qed.

Lemma close_type_system_partial {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         A1 A2 eqa,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_partial A1)
    -> computes_to_valc lib T' (mkc_partial A2)
    -> close lib ts A1 A2 eqa
    -> type_sys_props lib (close lib ts) A1 A2 eqa
    -> (forall a, eqa a a -> chaltsc lib a)
    -> (forall t t' : CTerm, eq t t' <=> per_partial_eq lib eqa t t')
    -> per_partial lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv tysys dou c1 c2 cla reca hv eqiff per.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  - SCase "uniquely_valued".
    dclose_lr.

    + SSCase "CL_partial".
      clear per.
      allunfold @per_partial; exrepd.
      unfold eq_term_equals; intros.
      allrw.
      ccomputes_to_eqval.
      revert t1 t2; rw @fold_eq_term_equals.
      apply eq_term_equals_per_partial_eq_if.
      onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
      generalize (uv A3 eqa0); sp.

  - SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_partial;
    clear per;
    allunfold @per_partial; exrepd;
    unfold per_partial;
    ccomputes_to_eqval.

    + exists A1 A3 eqa0; sp; spcast; sp.
      apply eq_term_equals_trans with (eq2 := eq); sp.
      apply eq_term_equals_sym; sp.

  - SCase "type_value_respecting"; repdors; subst;
    apply CL_partial; unfold per_partial.

    (* 1 *)
    generalize (cequivc_mkc_partial lib T T3 A1); introv k; repeat (autodimp k hyp); exrepnd.
    exists A1 b eqa; sp; spcast; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tyvr A1 b); sp.

    (* 2 *)
    generalize (cequivc_mkc_partial lib T' T3 A2); introv k; repeat (autodimp k hyp); exrepnd.
    exists A2 b eqa; sp; spcast; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tyvr A2 b); sp.

  - SCase "term_symmetric".
    unfold term_equality_symmetric; introv eqt.
    rw eqiff in eqt; rw eqiff.
    apply per_partial_eq_symmetric; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt; sp.

  - SCase "term_transitive".
    unfold term_equality_transitive; introv eqt1 eqt2.
    rw eqiff in eqt1; rw eqiff in eqt2; rw eqiff.
    apply @per_partial_eq_transitive with (t2 := t2); sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt; sp.

  - SCase "term_value_respecting".
    unfold term_equality_respecting; introv eqt ceq.
    rw eqiff in eqt; rw eqiff.
    spcast.
    apply per_partial_eq_cequiv; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt; sp.

  - SCase "type_gsymmetric".
    repdors; subst; split; sp; dclose_lr;
    apply CL_partial;
    clear per;
    allunfold @per_partial; exrepd;
    ccomputes_to_eqval;
    unfold per_partial.

    (* 1 *)
    exists A3 A1 eqa0; sp; spcast; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tygs A1 A3 eqa0); intro k; repeat (autodimp k hyp).
    rw <- k; sp.

    (* 2 *)
    exists A1 A0 eqa0; sp; spcast; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tygs A1 A0 eqa0); intro k; repeat (autodimp k hyp).
    rw k; sp.

  - SCase "type_gtransitive"; sp.

  - SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_partial lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_partial lib (close lib ts) T' T4 eq2));
    allunfold @per_partial; exrepd;
    ccomputes_to_eqval.

    + dands; apply CL_partial; unfold per_partial.

      * exists A4 A3 eqa1; sp; spcast; sp.
        onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
        generalize (tymt A1 A4 A3 eqa1 eqa0); sp.

      * exists A4 A3 eqa0; sp; spcast; sp.
        onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
        generalize (tymt A1 A4 A3 eqa1 eqa0); sp.

    + dands; apply CL_partial; unfold per_partial.

      * exists A4 A3 eqa1; sp; spcast; sp.
        onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
        generalize (tymt A2 A4 A3 eqa1 eqa0); sp.

      * exists A4 A3 eqa0; sp; spcast; sp.
        onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
        generalize (tymt A2 A4 A3 eqa1 eqa0); sp.
Qed.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e150m3_3limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition t_div_t1_bmap_list := [Build_varinfo Tdouble 1%positive (0) (999)].

Definition t_div_t1_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list t_div_t1_bmap_list) in exact z).

Definition t_div_t1 (z : ftype Tdouble) :=
  cast Tdouble ((z / (z + (1)%F64)%F64)%F64).

Definition t_div_t1_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive]) t_div_t1 in exact e').

Derive t_div_t1_b
SuchThat (forall vmap, prove_roundoff_bound t_div_t1_bmap vmap t_div_t1_expr t_div_t1_b)
As t_div_t1_bound.
idtac "Starting t_div_t1".
time "t_div_t1_bound" (
try (subst t_div_t1_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try (prove_roundoff_bound2);
try match goal with |-Rabs ?a <= _ =>
field_simplify a; try split; try field; try nra; try interval
end;
try match goal with |-Rabs ?a <= _ =>
interval_intro (Rabs a) with (i_taylor vxH, i_degree 10, i_bisect vxH,
i_depth 10)
end;
try (
eapply Rle_trans;
try apply H;
try apply Rle_refl)).
Qed.

Lemma check_t_div_t1_bound: ltac:(CheckBound t_div_t1_b 4.4e-16%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


(** Constructs the action of the endomorphisms by precomposition on a fixed hom-category of a bicategory

Author: Ralph Matthes 2021

 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored.
Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory.
Require Import UniMath.Bicategories.MonoidalCategories.Actions.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.

Import Bicat.Notations.

Local Open Scope cat.

Section Action_From_Precomposition.

Context {C : bicat}.
Context (c0 d0: ob C).

(* swapping is needed in the following due to the unconventional argument order of the action functor in the def. of actions *)
Local Definition Mon_endo: monoidal_cat := swapping_of_monoidal_cat (monoidal_cat_from_bicat_and_ob c0).

Local Definition homcat : category := hom c0 d0.

Definition precomp_odot : homcat ⊠ Mon_endo ⟶ homcat
  := functor_composite binswap_pair_functor hcomp_functor.

Definition precomp_right_unitor_nat_trans : odot_I_functor Mon_endo homcat precomp_odot ⟹ functor_identity homcat
  := lunitor_transf c0 d0.

Definition precomp_right_unitor : action_right_unitor Mon_endo homcat precomp_odot.
Proof.
  exists precomp_right_unitor_nat_trans.
  intro f. apply is_z_iso_lunitor.
Defined.

(* I would like to know how to use the library results better, but there are problems with the order of arguments *)
Definition precomp_convertor_nat_trans_data : nat_trans_data (odot_x_odot_y_functor Mon_endo homcat precomp_odot) (odot_x_otimes_y_functor Mon_endo homcat precomp_odot).
Proof.
  intro x.
  induction x as [x12 x3]. induction x12 as [x1 x2].
  apply lassociator.
Defined.

Lemma precomp_convertor_data_is_nat_trans : is_nat_trans _ _ precomp_convertor_nat_trans_data.
Proof.
  red. intros x x' f.
  unfold odot_x_odot_y_functor, odot_x_otimes_y_functor, precomp_odot.
  cbn.
  apply hcomp_lassoc.
Qed.

Definition precomp_convertor_nat_trans :
  odot_x_odot_y_functor Mon_endo homcat precomp_odot ⟹ odot_x_otimes_y_functor Mon_endo homcat precomp_odot
  := (precomp_convertor_nat_trans_data,,precomp_convertor_data_is_nat_trans).

Definition precomp_convertor : action_convertor Mon_endo homcat precomp_odot.
Proof.
  exists precomp_convertor_nat_trans.
  intro x.
  apply is_z_iso_lassociator.
Defined.

Lemma action_from_precomp_laws :
  action_triangle_eq Mon_endo homcat precomp_odot precomp_right_unitor precomp_convertor
                     × action_pentagon_eq Mon_endo homcat precomp_odot precomp_convertor.
Proof.
  split.
  - red. cbn. intros a x.
    rewrite hcomp_identity_right.
    rewrite hcomp_identity_left.
    apply pathsinv0. apply runitor_rwhisker.
  - red. cbn. intros a x y z.
    rewrite hcomp_identity_left.
    rewrite hcomp_identity_right.
    apply pathsinv0. apply lassociator_lassociator.
Qed.

Definition action_from_precomp : action Mon_endo homcat.
Proof.
  exists precomp_odot.
  exists precomp_right_unitor.
  exists precomp_convertor.
  exact action_from_precomp_laws.
Defined.

End Action_From_Precomposition.

Section Instantiation_To_Bicategory_Of_Categories.

  Context (C D : category).

  Local Definition actfromprecomp : action (Mon_endo(C:=bicat_of_cats) C)
                                           (homcat(C:=bicat_of_cats) C D)
    := action_from_precomp(C:=bicat_of_cats) C D.

  (* the following is not possible since the notions for functor the functor are not precise instances of the bicategorical ones:
  Lemma actfromprecomp_odot_ok : pr1 actfromprecomp = binswap_pair_functor ∙ (functorial_composition C C D hs hsD).
  Proof.
    UniMath.MoreFoundations.Tactics.show_id_type.
    cbn.
    unfold precomp_odot.
    apply idpath.
   *)

  Lemma actfromprecomp_odot_pointwise_ok (g : functor C D) (f: functor C C) : pr1 actfromprecomp (g,,f) = (binswap_pair_functor ∙ (functorial_composition _ _ _)) (g,,f).
  Proof.
    cbn.
    apply idpath.
  Qed.

End Instantiation_To_Bicategory_Of_Categories.


Require Import CSPEC.
Require Import MailboxAPI.
Require Import MailFSAPI.
Require Import MailFSStringAbsAPI.
Require Import MailServerAPI.
Require Import MailboxTmpAbsAPI.

Module MailFSStringAbsImpl' <:
  HLayerImplAbsT MailFSOp
    MailFSStringAbsState MailFSStringAbsAPI
    MailboxTmpAbsState MailFSAPI.

  Definition dirR (d1 : MailFSStringAbsState.dir_contents)
                  (d2 : MailServerState.dir_contents) : Prop :=
    d1 = FMap.map_keys (fun '(tid, fn) => encode_tid_fn tid fn) d2.

  Definition absR (s1 : MailFSStringAbsState.State) (s2 : MailboxTmpAbsState.State) :=
    dirR (MailFSStringAbsState.maildir s1) (MailboxTmpAbsState.maildir s2) /\
    dirR (MailFSStringAbsState.tmpdir  s1) (MailboxTmpAbsState.tmpdir  s2) /\
    MailFSStringAbsState.locked s1 = MailboxTmpAbsState.locked s2.

  Hint Extern 1 (MailFSAPI.step _ _ _ _ _ _) => econstructor.

  Lemma dirR_empty : dirR FMap.empty FMap.empty.
  Proof.
    unfold dirR; intros.
    symmetry.
    apply FMap.mapsto_empty_def; intros.
    unfold not; intros.
    apply FMap.map_keys_mapsto' in H; propositional.
  Qed.

  Lemma dirR_mapsto :
    forall d1 d2 tid fn data,
      dirR d1 d2 ->
      FMap.MapsTo (encode_tid_fn tid fn) data d1 ->
      FMap.MapsTo (tid, fn) data d2.
  Proof.
    unfold dirR; intros; subst.
    eapply FMap.map_keys_mapsto' in H0; deex.
    destruct k'.
    apply encode_tid_eq in H0; inversion H0; clear H0; subst.
    eauto.
  Qed.

  Lemma dirR_mapsto' :
    forall d1 d2 tid fn data,
      dirR d1 d2 ->
      FMap.MapsTo (tid, fn) data d2 ->
      FMap.MapsTo (encode_tid_fn tid fn) data d1.
  Proof.
    unfold dirR; intros; subst.
    eapply FMap.map_keys_mapsto in H0.
    exact H0.
    eauto.
  Qed.

  Lemma dirR_fmap_in :
    forall d1 d2 tid fn,
      dirR d1 d2 ->
      FMap.In (encode_tid_fn tid fn) d1 ->
      FMap.In (tid, fn) d2.
  Proof.
    intros.
    eapply FMap.in_mapsto_exists in H0; destruct H0.
    eapply FMap.mapsto_in.
    eapply dirR_mapsto; eauto.
  Qed.

  Lemma dirR_fmap_in' :
    forall d1 d2 tid fn,
      dirR d1 d2 ->
      FMap.In (tid, fn) d2 ->
      FMap.In (encode_tid_fn tid fn) d1.
  Proof.
    intros.
    eapply FMap.in_mapsto_exists in H0; destruct H0.
    eapply FMap.mapsto_in.
    eapply dirR_mapsto'; eauto.
  Qed.

  Lemma dirR_add :
    forall d1 d2 tid fn data,
      dirR d1 d2 ->
      dirR (FMap.add (encode_tid_fn tid fn) data d1)
           (FMap.add (tid, fn) data d2).
  Proof.
    unfold dirR; intros; subst.
    rewrite FMap.map_keys_add; eauto.
  Qed.

  Lemma dirR_remove :
    forall d1 d2 tid fn,
      dirR d1 d2 ->
      dirR (FMap.remove (encode_tid_fn tid fn) d1)
           (FMap.remove (tid, fn) d2).
  Proof.
    unfold dirR; intros; subst.
    rewrite FMap.map_keys_remove; eauto.
  Qed.

  Lemma dirR_is_permutation_key :
    forall d1 d2 l,
      dirR d1 d2 ->
      FMap.is_permutation_key l d1 ->
      FMap.is_permutation_key (map decode_tid_fn l) d2.
  Proof.
    unfold dirR, FMap.is_permutation_key.
    split; subst; intros.
    - eapply in_map_iff in H; deex.
      eapply H0 in H1.
      eapply FMap.map_keys_in' in H1; deex.
      destruct k'.
      rewrite encode_decode_tid_fn; eauto.
    - destruct x.
      eapply FMap.map_keys_in in H.
      eapply H0 in H.
      eapply in_map_iff.
      eexists; split; eauto.
      rewrite encode_decode_tid_fn; eauto.
  Qed.

  Hint Resolve dirR_fmap_in.
  Hint Resolve dirR_fmap_in'.
  Hint Resolve dirR_mapsto.
  Hint Resolve dirR_add.
  Hint Resolve dirR_remove.
  Hint Resolve dirR_is_permutation_key.

  Theorem absR_ok :
    op_abs absR MailFSStringAbsAPI.step MailFSAPI.step.
  Proof.
    unfold op_abs, absR; intros.
    destruct s1; simpl in *; subst.
    destruct s2; simpl in *; subst.
    intuition idtac.
    inversion H0; clear H0; subst; repeat sigT_eq; simpl in *.
    all:
      solve [ eexists; split; [ split | econstructor ]; simpl; intuition eauto ].
  Qed.

  Definition initP_map (s1: MailFSStringAbsState.State) :
    {s2:MailboxTmpAbsState.State |
     MailFSStringAbsState.initP s1 -> absR s1 s2 /\ MailboxTmpAbsState.initP s2}.
  Proof.
    unfold MailFSStringAbsState.initP, MailboxTmpAbsState.initP, absR.
    destruct s1; simpl.
    exists_econstructor; (intuition eauto); propositional.
  Qed.

End MailFSStringAbsImpl'.

Module MailFSStringAbsImpl :=
  HLayerImplAbs MailFSOp
    MailFSStringAbsState MailFSStringAbsAPI
    MailboxTmpAbsState MailFSAPI
    MailFSStringAbsImpl'.

Module MailFSStringAbsImplH' :=
  LayerImplAbsHT
    MailFSOp
    MailFSStringAbsState MailFSStringAbsAPI
    MailboxTmpAbsState MailFSAPI
    MailFSStringAbsImpl'
    UserIdx.

Module MailFSStringAbsImplH :=
  LayerImplAbs MailFSHOp
    MailFSStringAbsHState MailFSStringAbsHAPI
    MailboxTmpAbsHState MailFSHAPI
    MailFSStringAbsImplH'.


(* This program 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 program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export orthogonalite.
Require Export Plan_espace.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter orthogonales : DR -> DR -> Prop.

Axiom
  def_orthogonales :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    orthogonal (vec A B) (vec C D) -> orthogonales (droite A B) (droite C D).

Axiom
  def_orthogonales2 :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    orthogonales (droite A B) (droite C D) -> orthogonal (vec A B) (vec C D).
Parameter perpendiculaires : DR -> DR -> Prop.

Axiom
  def_perpendiculaires :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    coplanaires A B C D ->
    orthogonales (droite A B) (droite C D) ->
    perpendiculaires (droite A B) (droite C D).

Axiom
  def_perpendiculaires2 :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    perpendiculaires (droite A B) (droite C D) ->
    coplanaires A B C D /\ orthogonales (droite A B) (droite C D).
#[export] Hint Resolve ortho_somme ortho_combinaison_lineaire def_orthogonales2
  def_orthogonales def_perpendiculaires: geo.

Lemma perpendiculaires_orthogonales :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 perpendiculaires (droite A B) (droite C D) ->
 orthogonales (droite A B) (droite C D).
intros.
elim def_perpendiculaires2 with (A := A) (B := B) (C := C) (D := D);
 [ intros; try exact H3 | auto | auto | auto ].
Qed.

Lemma orthogonales_2droites_secantes :
 forall A B C D E F G : PO,
 ~ alignes A B C ->
 D <> E ->
 F <> G ->
 coplanaires A B C F ->
 coplanaires A B C G ->
 orthogonales (droite A B) (droite D E) ->
 orthogonales (droite A C) (droite D E) ->
 orthogonales (droite F G) (droite D E).
intros A B C D E F G H; try assumption.
assert (A <> B); auto with geo.
intros.
apply def_orthogonales; auto.
lapply (def_orthogonales2 (A:=A) (B:=B) (C:=D) (D:=E)); auto; intros.
lapply (def_orthogonales2 (A:=A) (B:=C) (C:=D) (D:=E)); auto; intros.
hcoplanaires H3 k k'.
hcoplanaires H4 k0 k'0.
replace (vec F G) with (add_PP (mult_PP (-1) (vec A F)) (vec A G)).
rewrite H4.
rewrite H3.
replace
 (add_PP (mult_PP (-1) (add_PP (mult_PP k (vec A B)) (mult_PP k' (vec A C))))
    (add_PP (mult_PP k0 (vec A B)) (mult_PP k'0 (vec A C)))) with
 (add_PP (mult_PP (-1 * k + k0) (vec A B))
    (mult_PP (-1 * k' + k'0) (vec A C))).
Simplortho.
Ringvec.
Ringvec.
apply non_alignes_distincts with B; auto.
Qed.
Parameter orthogonaux : DR -> PL -> Prop.

Axiom
  def_orthogonaux :
    forall A B C D E : PO,
    ~ alignes A B C ->
    D <> E ->
    orthogonales (droite A B) (droite D E) ->
    orthogonales (droite A C) (droite D E) ->
    orthogonaux (droite D E) (plan A B C).

Axiom
  def_orthogonaux2 :
    forall A B C D E : PO,
    ~ alignes A B C ->
    D <> E ->
    orthogonaux (droite D E) (plan A B C) ->
    orthogonales (droite A B) (droite D E) /\
    orthogonales (droite A C) (droite D E).

Lemma vecteurs_orthogonaux :
 forall A B C D E : PO,
 ~ alignes A B C ->
 D <> E ->
 orthogonal (vec A B) (vec D E) ->
 orthogonal (vec A C) (vec D E) -> orthogonaux (droite D E) (plan A B C).
intros.
deroule_triangle A B C.
apply def_orthogonaux; auto with geo.
Qed.

Lemma vecteurs_orthogonaux_rec :
 forall A B C D E : PO,
 ~ alignes A B C ->
 D <> E ->
 orthogonaux (droite D E) (plan A B C) ->
 orthogonal (vec A B) (vec D E) /\ orthogonal (vec A C) (vec D E).
intros.
deroule_triangle A B C.
elim def_orthogonaux2 with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ intros H5 H6; try clear def_orthogonaux2; try exact H6
 | auto
 | auto
 | auto ].
intros.
split; auto with geo.
Qed.

Lemma orthogonaux_orthogonales_toute_droite :
 forall A B C D E F G : PO,
 ~ alignes A B C ->
 D <> E ->
 F <> G ->
 coplanaires A B C F ->
 coplanaires A B C G ->
 orthogonaux (droite D E) (plan A B C) ->
 orthogonales (droite F G) (droite D E).
intros.
assert (A <> B); auto with geo.
apply orthogonales_2droites_secantes with (1 := H); auto.
elim def_orthogonaux2 with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ try clear def_orthogonaux2; intros; auto | auto | auto | auto ].
elim def_orthogonaux2 with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ try clear def_orthogonaux2; intros; auto | auto | auto | auto ].
Qed.

Lemma orthogonales_toute_droite_orthogonaux :
 forall A B C D E : PO,
 ~ alignes A B C ->
 D <> E ->
 (forall F G : PO,
  F <> G ->
  coplanaires A B C F ->
  coplanaires A B C G -> orthogonales (droite F G) (droite D E)) ->
 orthogonaux (droite D E) (plan A B C).
intros.
assert (A <> B); auto with geo.
apply def_orthogonaux; auto with geo.
apply H1; auto with geo.
apply non_alignes_distincts with B; auto with geo.
Qed.

Lemma orthogonaux_perce :
 forall A B C D E : PO,
 ~ alignes A B C ->
 D <> E ->
 orthogonaux (droite D E) (plan A B C) -> perce (droite D E) (plan A B C).
intros.
elim
 position_relative_droite_plan
  with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ intros H3; try clear position_relative_droite_plan; intros
 | intros H3; try clear position_relative_droite_plan; try exact H3
 | auto
 | auto ].
absurd (D = E); auto.
elim para_plan_dr_vecteur with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ intros k H4; elim H4; intros k' H5; try clear H4; try exact H5
 | auto
 | auto
 | auto ].
elim
 vecteurs_orthogonaux_rec with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ try clear vecteurs_orthogonaux_rec; intros | auto | auto | auto ].
apply vecteur_nul_conf.
apply scalaire_non_degenere.
pattern (vec D E) at 1 in |- *; rewrite H5.
cut
 (orthogonal (add_PP (mult_PP k (vec A B)) (mult_PP k' (vec A C))) (vec D E));
 intros.
elim
 existence_representant_comb_lin_vecteur
  with (A := A) (B := B) (C := A) (D := C) (a := k) (b := k');
 intros E0 H8; try clear existence_representant_comb_lin_vecteur;
 rewrite <- H8.
rewrite <- H8 in H6.
rewrite (def_orthogonal (A:=A) (B:=E0) (C:=D) (D:=E)); auto.
apply ortho_combinaison_lineaire; auto.
Qed.


(** * The congruence rules associated with a given rule *)

Require Import HoTT.
Require Import Auxiliary.Coproduct.
Require Import Auxiliary.Family.
Require Import Auxiliary.WellFounded.
Require Import Syntax.ScopeSystem.
Require Import Syntax.All.
Require Import Typing.Context.
Require Import Typing.Judgement.
Require Import Presented.AlgebraicExtension.
Require Import Presented.PresentedRawRule.

Section CongruenceRule.

  Context {σ : scope_system}.
  Context {Σ : signature σ}.

  Local Definition original_premise {obs eqs : arity σ}
    : (obs + obs) + (eqs + eqs + obs) -> (obs + eqs).
  Proof.
    intros p ; repeat destruct p as [p | p];
      try exact (inl p); exact (inr p).
  Defined.

  Arguments original_premise : simpl nomatch.

  (* The ordering of premises of the congruence rule associated to an object rule. *)
  Local Definition lt
      {obs eqs : Type} (lt : well_founded_order (obs + eqs))
    : well_founded_order ((obs + obs) + (eqs + eqs + obs)).
  Proof.
    refine (WellFounded.pullback _ (semi_reflexive_product lt Span.lt)).
    intros [ [ ob_l | ob_r ] | [ [ eq_l | eq_r ] | eq_new ] ].
    + exact (inl ob_l, Span.left).
    + exact (inl ob_r, Span.right).
    + exact (inr eq_l, Span.left).
    + exact (inr eq_r, Span.right).
    + exact (inl eq_new, Span.top).
  Defined.

  Local Arguments lt : simpl nomatch.

  (*  Unwinding this definition, the relation is be defined as follows:

           ob_l j   ob_r j   eq_l j   eq_r j   eq_new j

ob_l i     i < j    0        i < j    0        i ≤ j

ob_r i     0        i < j    0        i < j    i ≤ j

eq_l i     i < j    0        i < j    0        i < j

eq_r i     0        i < j    0        i < j    i < j

eq_new i   0        0        0        0        i < j

*)

  Local Definition original_constructor_translation
    {a} {jf_concl} (R : rule Σ a jf_concl)
    (p : (a + a)
         + (ae_equality_premise (rule_premise R)
            + ae_equality_premise (rule_premise R)
            + a))
    : Signature.map
        (ae_signature_of_premise (original_premise p))
        (Metavariable.extend Σ (Family.subfamily (a + a)
           (fun j => lt (ae_lt) (inl j) p))).
  Proof.
    (* In case [p] is one of the 2 copies of the original premises, there is a single canonical choice for this definition.

    In case [p] is one of the new equality premises (between the 2 copies of the old equality premises), there are in principle 2 possibilities; it should make no difference which one chooses. *)
    apply Metavariable.fmap2.
    simple refine (_;_).
    - intros q.
      destruct p as [ [ pob_l | pob_r ] | [ [ peq_l | peq_r ] | peq_new ] ].
      + (* pob_l *)
        exists (inl (pr1 q)).
        apply inr; cbn. split; try apply idpath. exact (pr2 q).
      + (* pob_r *)
        exists (inr (pr1 q)).
        apply inr; cbn. split; try apply idpath. exact (pr2 q).
      + (* peq_l *)
        exists (inl (pr1 q)).
        apply inr; cbn. split; try apply idpath. exact (pr2 q).
      + (* peq_r *)
        exists (inr (pr1 q)).
        apply inr; cbn. split; try apply idpath. exact (pr2 q).
      + (* peq_new *)
        exists (inr (pr1 q)). (* note both [inl], [inr] make this work *)
        apply inl, inl; cbn. split; try constructor. exact (pr2 q).
    - intros q.
      repeat destruct p as [ p | p ]; apply idpath.
  Defined.

  Definition congruence_rule
    {a} {jf_concl} (R : rule Σ a jf_concl)
    (H : Judgement.is_object jf_concl)
    (S : Σ)
    (e_a : symbol_arity S = a)
    (e_cl : symbol_class S = class_of jf_concl)
    : (rule Σ (Family.sum a a)
                 (form_equality (class_of jf_concl))).
  Proof.
    (* TODO: refactor the following, to unify it with def of raw congruence
       rules (once given). *)
    simple refine (Build_rule _ _ _ _ _).
    1: simple refine
           {| ae_equality_premise :=
                 ((ae_equality_premise (rule_premise R)) +
                 (ae_equality_premise (rule_premise R))) + a ;
              |}.
    - (* ae_lt *)
      exact (lt (ae_lt)).
    - (* ae_raw_context_type *)
      intros p i.
      refine (Expression.fmap
        (original_constructor_translation _ _) _).
      set (p_orig := original_premise p).
      recursive_destruct p;
      refine (ae_raw_context_type p_orig i).
      (* alternatively, instead of destructing [p], could use equality reasoning
      on the type of [i]. *)
    - (* ae_hypothetical_boundary *)
      intros p.
      set (p_orig := original_premise p).
      recursive_destruct p;
        try (refine (Judgement.fmap_hypothetical_boundary_expressions
          (original_constructor_translation _ _) _) ;
             refine (ae_hypothetical_boundary_expressions _ p_orig)).
      (* The cases where [p] is a copy of an original premise are all just translation,
      leaving just the new equality premises to give. *)
      intros i; simpl Judgement.boundary_slot in i.
      destruct i as [ i | | ]; [ idtac | simpl | simpl].
      + (* boundary of the corresponding original premise *)
        refine (Expression.fmap
          (original_constructor_translation _ _) _).
        apply (ae_hypothetical_boundary_expressions _ p_orig).
      + (* LHS of new equality premise *)
        cbn. simple refine (raw_symbol' _ _ _).
        * apply Metavariable.include_metavariable.
          refine (inl _; _).
          cbn. apply inl, inr; split; constructor.
        * apply idpath.
        * intros i.
          apply raw_variable, (coproduct_inj1 scope_is_sum), i.
      + (* RHS of new equality premise *)
        cbn. simple refine (raw_symbol' _ _ _).
        * apply Metavariable.include_metavariable.
          refine (inr _; _).
          cbn. apply inl, inr; split; constructor.
        * apply idpath.
        * intros i.
          apply raw_variable, (coproduct_inj1 scope_is_sum), i.
    - (* rule_conclusion_hypothetical_boundary *)
      intros [ i | | ]; simpl.
      + (* boundary of original conclusion *)
        refine (Expression.fmap _ _).
        * apply Metavariable.fmap2, Family.inl.
        * destruct jf_concl as [cl | ?].
          -- exact (rule_conclusion_hypothetical_boundary_expressions R i).
          -- destruct H. (* know [jf_concl] isn’t an equality judgement *)
      + (* LHS of new conclusion *)
        cbn. simple refine (raw_symbol' _ _ _).
        * apply Metavariable.include_symbol, S.
        * apply e_cl.
        * simpl symbol_arity.
          change (symbol_arity (Metavariable.include_symbol_carrier S))
            with (symbol_arity S).
          destruct (e_a^); clear e_a.
          intros p.
          simple refine (raw_symbol' _ _ _).
          -- apply Metavariable.include_metavariable.
             exact (inl p).
          -- apply idpath.
          -- cbn. intros i.
             apply raw_variable.
             apply (coproduct_inj1 scope_is_sum).
             apply (coproduct_inj2 scope_is_sum).
             exact i.
      + (* RHS of new conclusion *)
        cbn. simple refine (raw_symbol' _ _ _).
        * apply Metavariable.include_symbol, S.
        * apply e_cl.
        * simpl symbol_arity.
          change (symbol_arity (Metavariable.include_symbol_carrier S))
            with (symbol_arity S).
          destruct (e_a^); clear e_a.
          intros p.
          simple refine (raw_symbol' _ _ _).
          -- apply Metavariable.include_metavariable.
             exact (inr p).
          -- apply idpath.
          -- cbn. intros i.
             apply raw_variable.
             apply (coproduct_inj1 scope_is_sum).
             apply (coproduct_inj2 scope_is_sum).
             exact i.
  Defined.
  (* TODO: the above is a bit unreadable.  An alternative approach that might be clearer and more robust:
   - factor out the constructions of the head terms of conclusions and premises from [flatten], if doable.
   - here, invoke those, but (for the LHS/RHS of the new equalities), translate them under appropriate context morphisms “inl”, “inr”. *)

(* A good test proposition will be the following: whenever a rule is well-typed, then so is its associated congruence rule. *)

End CongruenceRule.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal31.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (IHx:@eq lst (qreva (qreva x Nil) Nil) x):@eq lst (qreva (append (qreva x Nil) (Cons n Nil)) Nil) (Cons n x).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal31_qreva_qreva_67_qreva_append/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x.
QuickChick collect_data.
Success.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^127 - 1
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 32;
    bitwidth := 32;
    s := 2^127;
    c := [(1, 1)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(* Copyright (c) 2008, 2011, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Three-clause BSD Licence
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

(* Types and notations presented in Chapter 6 *)

Set Implicit Arguments.
Set Asymmetric Patterns.

Declare Scope specif_scope.
Notation "!" := (False_rec _ _) : specif_scope.
Notation "[ e ]" := (exist _ e _) : specif_scope.
Notation "x <== e1 ; e2" := (let (x, _) := e1 in e2)
(right associativity, at level 60) : specif_scope.

Local Open Scope specif_scope.
Delimit Scope specif_scope with specif.

Notation "'Yes'" := (left _ _) : specif_scope.
Notation "'No'" := (right _ _) : specif_scope.
Notation "'Reduce' x" := (if x then Yes else No) (at level 50) : specif_scope.

Notation "x || y" := (if x then Yes else Reduce y) (at level 50, left associativity) : specif_scope.

Section sumbool_and.
  Variables P1 Q1 P2 Q2 : Prop.

  Variable x1 : {P1} + {Q1}.
  Variable x2 : {P2} + {Q2}.

  Definition sumbool_and : {P1 /\ P2} + {Q1 \/ Q2} :=
    match x1 with
      | left HP1 =>
        match x2 with
          | left HP2 => left _ (conj HP1 HP2)
          | right HQ2 => right _ (or_intror _ HQ2)
        end
      | right HQ1 => right _ (or_introl _ HQ1)
    end.
End sumbool_and.

Infix "&&" := sumbool_and (at level 40, left associativity) : specif_scope.

Inductive maybe (A : Set) (P : A -> Prop) : Set :=
| Unknown : maybe P
| Found : forall x : A, P x -> maybe P.

Notation "{{ x | P }}" := (maybe (fun x => P)) : specif_scope.
Notation "??" := (Unknown _) : specif_scope.
Notation "[| x |]" := (Found _ x _) : specif_scope.

Notation "x <- e1 ; e2" := (match e1 with
                             | Unknown => ??
                             | Found x _ => e2
                           end)
(right associativity, at level 60) : specif_scope.

Notation "!!" := (inright _ _) : specif_scope.
Notation "[|| x ||]" := (inleft _ [x]) : specif_scope.

Notation "x <-- e1 ; e2" := (match e1 with
                               | inright _ => !!
                               | inleft (exist x _) => e2
                             end)
(right associativity, at level 60) : specif_scope.

Notation "e1 ;; e2" := (if e1 then e2 else ??)
  (right associativity, at level 60) : specif_scope.

Notation "e1 ;;; e2" := (if e1 then e2 else !!)
  (right associativity, at level 60) : specif_scope.

Section partial.
  Variable P : Prop.

  Inductive partial : Set :=
  | Proved : P -> partial
  | Uncertain : partial.
End partial.

Notation "[ P ]" := (partial P) : type_scope.

Declare Scope partial_scope.
Notation "'Yes'" := (Proved _) : partial_scope.
Notation "'No'" := (Uncertain _) : partial_scope.

Local Open Scope partial_scope.
Delimit Scope partial_scope with partial.

Notation "'Reduce' v" := (if v then Yes else No) : partial_scope.
Notation "x || y" := (if x then Yes else Reduce y) : partial_scope.
Notation "x && y" := (if x then Reduce y else No) : partial_scope.


(* ll_prop library for yalla *)

(** * Properties relying on cut admissibility *)

Require Import Bool_more.
Require Import List_more.
Require Import Permutation_Type_more.
Require Import CyclicPerm_Type.
Require Import genperm_Type.

Require Export ll_cut.

(** Some additional reversibility statements *)
Lemma with_rev1_noax {P} : (projT1 (pgax P) -> False) ->
forall A B l1 l2, ll P (l1 ++ awith A B :: l2) -> ll P (l1 ++ A :: l2).
Proof with myeeasy.
intros Hgax A B l1 l2 pi.
assert (ll P (dual (awith A B) :: A :: nil)) as pi'.
{ apply plus_r1.
  eapply ex_r ; [ | apply PCperm_Type_swap ].
  apply ax_exp. }
eapply (ex_r _ ((l2 ++ l1) ++ A :: nil)) ; [ | PCperm_Type_solve ].
eapply cut_r_axfree ; try eassumption.
eapply ex_r ; [ apply pi | PCperm_Type_solve ].
Qed.

Lemma with_rev2_noax {P} : (projT1 (pgax P) -> False) ->
forall A B l1 l2, ll P (l1 ++ awith B A :: l2) -> ll P (l1 ++ A :: l2).
Proof with myeeasy.
intros Hgax A B l1 l2 pi.
assert (ll P (dual (awith B A) :: A :: nil)) as pi'.
{ apply plus_r2.
  eapply ex_r ; [ | apply PCperm_Type_swap ].
  apply ax_exp. }
eapply (ex_r _ ((l2 ++ l1) ++ A :: nil)) ; [ | PCperm_Type_solve ].
eapply cut_r_axfree ; try eassumption.
eapply ex_r ; [ apply pi | PCperm_Type_solve ].
Qed.

Lemma oc_rev_noax {P} : (projT1 (pgax P) -> False) ->
forall A l1 l2, ll P (l1 ++ oc A :: l2) -> ll P (l1 ++ A :: l2).
Proof with myeeasy.
intros Hgax A l1 l2 pi.
assert (ll P (dual (oc A) :: A :: nil)) as pi'.
{ apply de_r.
  eapply ex_r ; [ | apply PCperm_Type_swap ].
  apply ax_exp. }
eapply (ex_r _ ((l2 ++ l1) ++ A :: nil)) ; [ | PCperm_Type_solve ].
eapply cut_r_axfree ; try eassumption.
eapply ex_r ; [ apply pi | PCperm_Type_solve ].
Qed.

(** ** Subformula Property *)

(** version of ll with predicate parameter for constraining sequents *)
Inductive ll_ps P PS : list formula -> Type :=
| ax_ps_r : forall X, is_true (PS (covar X :: var X :: nil)) -> ll_ps P PS (covar X :: var X :: nil)
| ex_ps_r : forall l1 l2, is_true (PS l2) -> ll_ps P PS l1 -> PCperm_Type (pperm P) l1 l2 -> ll_ps P PS l2
| ex_wn_ps_r : forall l1 lw lw' l2, is_true (PS (l1 ++ map wn lw' ++ l2)) ->
                 ll_ps P PS (l1 ++ map wn lw ++ l2) ->
                 Permutation_Type lw lw' -> ll_ps P PS (l1 ++ map wn lw' ++ l2)
| mix0_ps_r {f : pmix0 P = true} : is_true (PS nil) -> ll_ps P PS nil
| mix2_ps_r {f : pmix2 P = true} : forall l1 l2, is_true (PS (l2 ++ l1)) ->
                                     ll_ps P PS l1 -> ll_ps P PS l2 -> ll_ps P PS (l2 ++ l1)
| one_ps_r : is_true (PS (one :: nil)) -> ll_ps P PS (one :: nil)
| bot_ps_r : forall l, is_true (PS (bot :: l)) -> ll_ps P PS l -> ll_ps P PS (bot :: l)
| tens_ps_r : forall A B l1 l2, is_true (PS (tens A B :: l2 ++ l1)) ->
                               ll_ps P PS (A :: l1) -> ll_ps P PS (B :: l2) ->
                               ll_ps P PS (tens A B :: l2 ++ l1)
| parr_ps_r : forall A B l, is_true (PS (parr A B :: l)) ->
                               ll_ps P PS (A :: B :: l) -> ll_ps P PS (parr A B :: l)
| top_ps_r : forall l, is_true (PS (top :: l)) -> ll_ps P PS (top :: l)
| plus_ps_r1 : forall A B l, is_true (PS (aplus A B :: l)) ->
                               ll_ps P PS (A :: l)-> ll_ps P PS (aplus A B :: l)
| plus_ps_r2 : forall A B l, is_true (PS (aplus B A :: l)) ->
                               ll_ps P PS (A :: l) -> ll_ps P PS (aplus B A :: l)
| with_ps_r : forall A B l, is_true (PS (awith A B :: l)) ->
                               ll_ps P PS (A :: l) -> ll_ps P PS (B :: l) ->
                               ll_ps P PS (awith A B :: l)
| oc_ps_r : forall A l, is_true (PS (oc A :: map wn l)) ->
                                ll_ps P PS (A :: map wn l) -> ll_ps P PS (oc A :: map wn l)
| de_ps_r : forall A l, is_true (PS (wn A :: l)) -> ll_ps P PS (A :: l) -> ll_ps P PS (wn A :: l)
| wk_ps_r : forall A l, is_true (PS (wn A :: l)) -> ll_ps P PS l -> ll_ps P PS (wn A :: l)
| co_ps_r : forall A l, is_true (PS (wn A :: l)) ->
                            ll_ps P PS (wn A :: wn A :: l) -> ll_ps P PS (wn A :: l)
| cut_ps_r {f : pcut P = true} : forall A l1 l2, is_true (PS (l2 ++ l1)) ->
                               ll_ps P PS (dual A :: l1) -> ll_ps P PS (A :: l2) ->
                               ll_ps P PS (l2 ++ l1)
| gax_ps_r : forall a, is_true (PS (projT2 (pgax P) a)) -> ll_ps P PS (projT2 (pgax P) a).

Lemma stronger_ps_pfrag P Q : le_pfrag P Q -> forall PS l,
  ll_ps P PS l -> ll_ps Q PS l.
Proof with myeeasy.
intros Hle PS l H.
induction H ; try (econstructor ; myeeasy ; fail).
- apply (ex_ps_r _ _ l1)...
  destruct Hle as (_ & _ & _ & _ & Hp).
  unfold PCperm_Type in p.
  unfold PCperm_Type.
  destruct (pperm P) ; destruct (pperm Q) ;
    simpl in Hp ; try inversion Hp...
  apply cperm_perm_Type...
- unfold le_pfrag in Hle.
  rewrite f in Hle.
  destruct Hle as (_ & _ & Hmix0 & _).
  simpl in Hmix0...
  apply (@mix0_ps_r _ _ Hmix0)...
- unfold le_pfrag in Hle.
  rewrite f in Hle.
  destruct Hle as (_ & _ & _ & Hmix2 & _).
  simpl in Hmix2...
  apply (@mix2_ps_r _ _ Hmix2)...
- destruct Hle as [Hle _].
  rewrite f in Hle.
  simpl in Hle.
  eapply (@cut_ps_r _ _ Hle)...
- destruct Hle as (_ & Hgax & _).
  destruct (Hgax a) as [b Heq].
  rewrite Heq in i ; rewrite Heq.
  apply gax_ps_r...
Qed.

Lemma ll_ps_stronger {P} : forall PS QS l,
  ll_ps P PS l -> (forall x, is_true (PS x) -> is_true (QS x)) -> ll_ps P QS l.
Proof with try eassumption.
intros PS QS l pi Hs.
induction pi ; try (econstructor ; try apply Hs ; eassumption ; fail).
Qed.

Lemma ll_ps_is_ps {P} : forall l PS, ll_ps P PS l -> is_true (PS l).
Proof.
intros l PS Hll.
inversion Hll ; assumption.
Qed.

Lemma ll_ps_is_ll {P} : forall l PS, ll_ps P PS l -> ll P l.
Proof with try eassumption.
intros l PS pi.
induction pi ; try (econstructor ; eassumption ; fail).
Qed.

Lemma ll_is_ll_ps {P} : forall l, ll P l -> ll_ps P (fun _ => true) l.
Proof with myeeasy.
intros l pi.
induction pi ; try (econstructor ; myeeasy ; fail).
Qed.

(** A fragment is a subset of formulas closed under subformula. *)
Definition fragment FS :=
  forall A, is_true (FS A) -> forall B, subform B A -> is_true (FS B).

(** Linear logic is conservative over its fragments (in the absence of cut). *)
Lemma conservativity {P} : pcut P = false -> forall FS, fragment FS ->
  forall l, ll_ps P (fun _ => true) l -> is_true (Forallb FS l) -> ll_ps P (Forallb FS) l.
Proof with try eassumption ; try reflexivity.
intros P_cutfree FS HFS l pi.
induction pi ; intros HFrag.
- apply ax_ps_r...
- apply (ex_ps_r _ _ l1)...
  apply IHpi.
  apply PCperm_Type_sym in p.
  apply Forallb_Forall in HFrag.
  apply Forallb_Forall.
  eapply PCperm_Type_Forall...
- eapply ex_wn_ps_r...
  apply IHpi.
  apply Forallb_Forall in HFrag.
  apply Forallb_Forall.
  apply (Permutation_Type_map wn) in p.
  eapply Permutation_Type_Forall...
  PCperm_Type_solve.
- apply (@mix0_ps_r _ _ f)...
- apply Forallb_Forall in HFrag.
  assert (HFrag2 := Forall_app_inv _ _ _ HFrag).
  destruct HFrag2 as [HFragl HFragr].
  apply Forallb_Forall in HFragl.
  apply Forallb_Forall in HFragr.
  apply (@mix2_ps_r _ _ f)...
  + apply Forallb_Forall...
  + apply IHpi1...
  + apply IHpi2...
- apply one_ps_r...
- apply bot_ps_r...
  inversion HFrag.
  apply andb_true_iff in H0.
  destruct H0.
  apply IHpi...
- assert (HFrag2 := HFrag).
  simpl in HFrag.
  apply andb_true_iff in HFrag.
  destruct HFrag as [HFragt HFrag].
  apply Forallb_Forall in HFrag.
  apply Forall_app_inv in HFrag.
  destruct HFrag as [HFragl HFragr].
  apply Forallb_Forall in HFragl.
  apply Forallb_Forall in HFragr.
  apply tens_ps_r...
  + apply IHpi1...
    simpl ; apply andb_true_iff ; split...
    eapply HFS...
    apply sub_tens_l...
  + apply IHpi2...
    simpl ; apply andb_true_iff ; split...
    eapply HFS...
    apply sub_tens_r...
- inversion HFrag ; subst.
  apply andb_true_iff in H0 ; destruct H0.
  apply parr_ps_r...
  apply IHpi.
  simpl ; apply andb_true_iff ; split ;
    [ | simpl ; apply andb_true_iff ; split ]...
  + eapply HFS...
    apply sub_parr_l...
  + eapply HFS...
    apply sub_parr_r...
- apply top_ps_r...
- inversion HFrag ; subst.
  apply andb_true_iff in H0 ; destruct H0.
  apply plus_ps_r1...
  apply IHpi.
  simpl ; apply andb_true_iff ; split...
  eapply HFS...
  apply sub_plus_l...
- inversion HFrag ; subst.
  apply andb_true_iff in H0 ; destruct H0.
  apply plus_ps_r2...
  apply IHpi.
  simpl ; apply andb_true_iff ; split...
  eapply HFS...
  apply sub_plus_r...
- inversion HFrag ; subst.
  apply andb_true_iff in H0 ; destruct H0.
  apply with_ps_r...
  + apply IHpi1...
    simpl ; apply andb_true_iff ; split...
    eapply HFS...
    apply sub_with_l...
  + apply IHpi2...
    simpl ; apply andb_true_iff ; split...
    eapply HFS...
    apply sub_with_r...
- inversion HFrag ; subst.
  apply andb_true_iff in H0 ; destruct H0.
  apply oc_ps_r...
  apply IHpi.
  simpl ; apply andb_true_iff ; split...
  eapply HFS...
  apply sub_oc...
- inversion HFrag ; subst.
  apply andb_true_iff in H0 ; destruct H0.
  apply de_ps_r...
  apply IHpi.
  simpl ; apply andb_true_iff ; split...
  eapply HFS...
  apply sub_wn...
- inversion HFrag ; subst.
  apply andb_true_iff in H0 ; destruct H0.
  apply wk_ps_r...
  apply IHpi...
- inversion HFrag ; subst.
  apply andb_true_iff in H0 ; destruct H0.
  apply co_ps_r...
  apply IHpi.
  simpl ; apply andb_true_iff ; split...
- rewrite P_cutfree in f.
  inversion f.
- apply gax_ps_r...
Qed.

(** Subformula property:
any provable sequent is provable by a proof containing only subformulas of this sequent. *)
Proposition subformula {P} : pcut P = false -> forall l,
  ll P l -> ll_ps P (fun x => subformb_list x l) l.
Proof with try eassumption ; try reflexivity.
intros P_cutfree l pi.
apply ll_is_ll_ps in pi.
apply conservativity...
- intros A Hf B Hs.
  revert Hf ; clear - Hs ; induction l ; intro Hf ; inversion Hf ; subst.
  simpl ; apply orb_true_iff.
  apply orb_true_iff in H0.
  destruct H0.
  + left.
    eapply subb_trans...
    apply subb_sub...
  + right.
    apply IHl...
- apply (subb_id_list l nil).
Qed.

(* Cut is admissible in any fragment with no axioms. *)
Lemma cut_admissible_fragment_axfree {P} : (projT1 (pgax P) -> False) ->
 forall FS, fragment FS -> forall l,
   ll_ps P (Forallb FS) l -> ll_ps (cutrm_pfrag P) (Forallb FS) l.
Proof with myeeasy.
intros P_axfree FS HFS l pi.
apply conservativity...
- apply ll_is_ll_ps.
  apply cut_admissible_axfree...
  eapply ll_ps_is_ll...
- destruct pi...
Qed.

(** Linear logic (with no axioms) is conservative over its fragments. *)
Lemma conservativity_axfree {P} : (projT1 (pgax P) -> False) ->
  forall FS, fragment FS -> forall l,
    ll P l -> is_true (Forallb FS l) -> ll_ps P (Forallb FS) l.
Proof with try eassumption ; try reflexivity.
intros P_axfree FS Hf l pi HFS.
apply cut_admissible_axfree in pi...
apply ll_is_ll_ps in pi.
eapply conservativity in pi...
clear - pi ; induction pi ;
  try (econstructor ; eassumption ; fail).
- eapply @cut_ps_r...
  destruct P.
  inversion f.
- revert a i.
  assert (pgax (cutrm_pfrag P) = pgax P) as Hcut by reflexivity.
  rewrite Hcut.
  apply gax_ps_r.
Qed.

(** ** Deduction Theorem *)

(** Deduction lemma for linear logic. *)
Lemma deduction_list {P} : pperm P = true -> pcut P = true -> forall lax l,
  ll (axupd_pfrag P (existT (fun x => x -> list formula) (sum _ { k | k < length lax })
                                (fun a => match a with
                                          | inl x => projT2 (pgax P) x
                                          | inr x => nth (proj1_sig x) lax one :: nil
                                          end))) l
  -> ll P (l ++ map wn (map dual lax)).
Proof with myeeasy.
intros P_perm P_cut lax.
induction lax ; intros l pi.
- list_simpl.
  eapply stronger_pfrag...
  nsplit 5...
  simpl ; intros a.
  destruct a.
  + exists p...
  + exfalso ; destruct s as [k Hlt] ; inversion Hlt.
- remember (axupd_pfrag P (existT (fun x => x -> list formula) (sum _ { k | k < length lax })
                                (fun a => match a with
                                          | inl x => projT2 (pgax P) x
                                          | inr x => nth (proj1_sig x) lax one :: nil
                                          end)))
    as Q.
  simpl.
  cons2app.
  rewrite app_assoc.
  apply IHlax.
  eapply (@ext_wn _ _ _ (dual a :: nil)) in pi.
  eapply ax_gen ; [ | | | | | apply pi ] ; try (now rewrite HeqQ).
  simpl in pi ; simpl ; intros a0.
  destruct a0.
  + eapply ex_r ; [ | apply PCperm_Type_last ].
    apply wk_r.
    assert ({ b | projT2 (pgax P) p = projT2 (pgax Q) b}) as [b Hgax]
      by (subst ; simpl ; exists (inl p) ; reflexivity).
    rewrite Hgax.
    apply gax_r.
  + destruct s as [k Hlen].
    destruct k ; simpl.
    * eapply ex_r ; [ | apply PCperm_Type_swap ].
      apply de_r.
      eapply ex_r ; [ | apply PCperm_Type_swap ].
      apply ax_exp.
    * eapply ex_r ; [ | apply PCperm_Type_swap ].
      apply wk_r.
      assert ({ b | nth k lax one :: nil = projT2 (pgax Q) b}) as [b Hgax].
      { subst ; simpl ; clear - Hlen.
        apply Lt.lt_S_n in Hlen.
        exists (inr (exist _ k Hlen))... }
      rewrite Hgax.
      apply gax_r.
Unshelve. assumption.
Qed.

Lemma deduction_list_inv {P} : pperm P = true -> pcut P = true -> forall lax l,
  ll P (l ++ map wn (map dual lax)) ->
  ll (axupd_pfrag P (existT (fun x => x -> list formula) (sum _ { k | k < length lax })
                                (fun a => match a with
                                          | inl x => projT2 (pgax P) x
                                          | inr x => nth (proj1_sig x) lax one :: nil
                                          end))) l.
Proof with myeeasy.
intros P_perm P_cut lax.
induction lax ; intros l pi.
- list_simpl in pi.
  eapply stronger_pfrag...
  nsplit 5...
  simpl ; intros a.
  exists (inl a)...
- list_simpl in pi.
  cons2app in pi.
  rewrite app_assoc in pi.
  apply IHlax in pi.
  rewrite <- (app_nil_r l).
  eapply (cut_r _ (wn (dual a)))...
  + simpl ; rewrite bidual.
    change nil with (map wn nil).
    apply oc_r ; simpl.
    assert ({ b | a :: nil = projT2 (pgax (axupd_pfrag P
     (existT (fun x => x -> list formula) (sum _ {k | k < S (length lax)})
        (fun a0 => match a0 with
                   | inl x => projT2 (pgax P) x
                   | inr x => match proj1_sig x with
                              | 0 => a
                              | S m => nth m lax one
                              end :: nil
                   end)))) b}) as [b Hgax]
      by (clear ; simpl ; exists (inr (exist _ 0 (le_n_S _ _ (le_0_n _)))) ; reflexivity).
    rewrite Hgax.
    apply gax_r.
  + eapply ex_r ; [ | apply PCperm_Type_sym ; apply PCperm_Type_last ].
    eapply stronger_pfrag...
    nsplit 5...
    simpl ; intros a'.
    destruct a'.
    * exists (inl p)...
    * destruct s as [k Hlen] ; simpl.
      apply Lt.lt_n_S in Hlen.
      exists (inr (exist _ (S k) Hlen))...
Unshelve. assumption.
Qed.

Lemma deduction {P} : pperm P = true -> (projT1 (pgax P) -> False) -> pcut P = true -> forall lax l,
  ll (axupd_pfrag P (existT (fun x => x -> list formula) { k | k < length lax }
                            (fun a => nth (proj1_sig a) lax one :: nil))) l
    -> ll (cutrm_pfrag P) (l ++ (map wn (map dual lax))).
Proof with myeeasy.
intros P_perm P_axfree P_cut lax l ; intros pi.
apply cut_admissible_axfree...
apply deduction_list...
eapply stronger_pfrag...
nsplit 5...
simpl ; intros a.
exists (inr a)...
Qed.

Lemma deduction_inv {P} : pperm P = true -> (projT1 (pgax P) -> False) -> pcut P = true -> forall lax l,
  ll (cutrm_pfrag P) (l ++ (map wn (map dual lax))) ->
  ll (axupd_pfrag P (existT (fun x => x -> list formula) { k | k < length lax }
                            (fun a => nth (proj1_sig a) lax one :: nil))) l.
Proof with myeeasy.
intros P_perm P_axfree P_cut lax l ; intros pi.
assert (ll P (l ++ (map wn (map dual lax)))) as pi'.
{ eapply stronger_pfrag...
  nsplit 5...
  simpl ; intros a.
  exists a... }
apply deduction_list_inv in pi'...
eapply stronger_pfrag...
nsplit 5...
simpl ; intros a.
destruct a.
- contradiction P_axfree.
- exists s...
Qed.


From stdpp Require Export countable coPset.
From stdpp Require Import options.

Definition namespace := list positive.
Global Instance namespace_eq_dec : EqDecision namespace := _.
Global Instance namespace_countable : Countable namespace := _.
Typeclasses Opaque namespace.

Definition nroot : namespace := nil.

Local Definition ndot_def `{Countable A} (N : namespace) (x : A) : namespace :=
  encode x :: N.
Local Definition ndot_aux : seal (@ndot_def). by eexists. Qed.
Definition ndot {A A_dec A_count}:= unseal ndot_aux A A_dec A_count.
Local Definition ndot_unseal : @ndot = @ndot_def := seal_eq ndot_aux.

Local Definition nclose_def (N : namespace) : coPset :=
  coPset_suffixes (positives_flatten N).
Local Definition nclose_aux : seal (@nclose_def). by eexists. Qed.
Global Instance nclose : UpClose namespace coPset := unseal nclose_aux.
Local Definition nclose_unseal : @nclose = @nclose_def := seal_eq nclose_aux.

Notation "N .@ x" := (ndot N x)
  (at level 19, left associativity, format "N .@ x") : stdpp_scope.
Notation "(.@)" := ndot (only parsing) : stdpp_scope.

Global Instance ndisjoint : Disjoint namespace := λ N1 N2, nclose N1 ## nclose N2.

Section namespace.
  Context `{Countable A}.
  Implicit Types x y : A.
  Implicit Types N : namespace.
  Implicit Types E : coPset.

  Global Instance ndot_inj : Inj2 (=) (=) (=) (@ndot A _ _).
  Proof. intros N1 x1 N2 x2; rewrite !ndot_unseal; naive_solver. Qed.

  Lemma nclose_nroot : ↑nroot = (⊤:coPset).
  Proof. rewrite nclose_unseal. by apply (sig_eq_pi _). Qed.

  Lemma nclose_subseteq N x : ↑N.@x ⊆ (↑N : coPset).
  Proof.
    intros p. unfold up_close. rewrite !nclose_unseal, !ndot_unseal.
    unfold nclose_def, ndot_def; rewrite !elem_coPset_suffixes.
    intros [q ->]. destruct (positives_flatten_suffix N (ndot_def N x)) as [q' ?].
    { by exists [encode x]. }
    by exists (q ++ q')%positive; rewrite <-(assoc_L _); f_equal.
  Qed.

  Lemma nclose_subseteq' E N x : ↑N ⊆ E → ↑N.@x ⊆ E.
  Proof. intros. etrans; eauto using nclose_subseteq. Qed.

  Lemma nclose_infinite N : ¬set_finite (↑ N : coPset).
  Proof. rewrite nclose_unseal. apply coPset_suffixes_infinite. Qed.

  Lemma ndot_ne_disjoint N x y : x ≠ y → N.@x ## N.@y.
  Proof.
    intros Hxy a. unfold up_close. rewrite !nclose_unseal, !ndot_unseal.
    unfold nclose_def, ndot_def; rewrite !elem_coPset_suffixes.
    intros [qx ->] [qy Hqy].
    revert Hqy. by intros [= ?%(inj encode)]%positives_flatten_suffix_eq.
  Qed.

  Lemma ndot_preserve_disjoint_l N E x : ↑N ## E → ↑N.@x ## E.
  Proof. intros. pose proof (nclose_subseteq N x). set_solver. Qed.

  Lemma ndot_preserve_disjoint_r N E x : E ## ↑N → E ## ↑N.@x.
  Proof. intros. by apply symmetry, ndot_preserve_disjoint_l. Qed.
End namespace.

(** The hope is that registering these will suffice to solve most goals
of the forms:
- [N1 ## N2]
- [↑N1 ⊆ E ∖ ↑N2 ∖ .. ∖ ↑Nn]
- [E1 ∖ ↑N1 ⊆ E2 ∖ ↑N2 ∖ .. ∖ ↑Nn] *)
Create HintDb ndisj discriminated.

(** Rules for goals of the form [_ ⊆ _] *)
(** If-and-only-if rules. Well, not quite, but for the fragment we are
considering they are. *)
Local Definition coPset_subseteq_difference_r := subseteq_difference_r (C:=coPset).
Global Hint Resolve coPset_subseteq_difference_r : ndisj.
Local Definition coPset_empty_subseteq := empty_subseteq (C:=coPset).
Global Hint Resolve coPset_empty_subseteq : ndisj.
Local Definition coPset_union_least := union_least (C:=coPset).
Global Hint Resolve coPset_union_least : ndisj.
(** For goals like [X ⊆ L ∪ R], backtrack for the two sides. *)
Local Definition coPset_union_subseteq_l' := union_subseteq_l' (C:=coPset).
Global Hint Resolve coPset_union_subseteq_l' | 50 : ndisj.
Local Definition coPset_union_subseteq_r' := union_subseteq_r' (C:=coPset).
Global Hint Resolve coPset_union_subseteq_r' | 50 : ndisj.
(** Fallback, loses lots of information but lets other rules make progress. *)
Local Definition coPset_subseteq_difference_l := subseteq_difference_l (C:=coPset).
Global Hint Resolve coPset_subseteq_difference_l | 100 : ndisj.
Global Hint Resolve nclose_subseteq' | 100 : ndisj.

(** Rules for goals of the form [_ ## _] *)
(** The base rule that we want to ultimately get down to. *)
Global Hint Extern 0 (_ ## _) => apply ndot_ne_disjoint; congruence : ndisj.
(** Trivial cases. *)
Local Definition coPset_disjoint_empty_l := disjoint_empty_l (C:=coPset).
Global Hint Resolve coPset_disjoint_empty_l : ndisj.
Local Definition coPset_disjoint_empty_r := disjoint_empty_r (C:=coPset).
Global Hint Resolve coPset_disjoint_empty_r : ndisj.
(** We prefer ∖ on the left of ## (for the [disjoint_difference] lemmas to
apply), so try moving it there. *)
Global Hint Extern 10 (_ ## (_ ∖ _)) =>
  lazymatch goal with
  | |- (_ ∖ _) ## _ => fail (* ∖ on both sides, leave it be *)
  | |- _ => symmetry
  end : ndisj.
(** Before we apply disjoint_difference, let's make sure we normalize the goal
to [_ ∖ (_ ∪ _)]. *)
Local Lemma coPset_difference_difference (X1 X2 X3 Y : coPset) :
  X1 ∖ (X2 ∪ X3) ## Y →
  X1 ∖ X2 ∖ X3 ## Y.
Proof. set_solver. Qed.
Global Hint Resolve coPset_difference_difference | 20 : ndisj.
(** Fallback, loses lots of information but lets other rules make progress.
Tests show trying [disjoint_difference_l1] first gives better performance. *)
Local Definition coPset_disjoint_difference_l1 := disjoint_difference_l1 (C:=coPset).
Global Hint Resolve coPset_disjoint_difference_l1 | 50 : ndisj.
Local Definition coPset_disjoint_difference_l2 := disjoint_difference_l2 (C:=coPset).
Global Hint Resolve coPset_disjoint_difference_l2 | 100 : ndisj.
Global Hint Resolve ndot_preserve_disjoint_l ndot_preserve_disjoint_r | 100 : ndisj.

Ltac solve_ndisj :=
  repeat match goal with
  | H : _ ∪ _ ⊆ _ |- _ => apply union_subseteq in H as [??]
  end;
  solve [eauto 12 with ndisj].
Global Hint Extern 1000 => solve_ndisj : solve_ndisj.


(** * Full subcategories *)

(** The category described by a subset of objects of an existing category. *)

(* begin hide *)
From Coq Require Import
     Setoid
     Morphisms.

From ITree Require Import
     Category
     CategoryFunctor.

Import CatNotations.
Local Open Scope cat_scope.
(* end hide *)

Set Universe Polymorphism.

Section Subcategory.

(** A function [Embed : sobj -> obj] from some collection of objects [sobj]
    to objects of a category [C] induces a category on [sobj].
    When that function [Embed] is injective, that is a subcategory. *)
Context
  {obj : Type}
  (C : obj -> obj -> Type)
  {sobj : Type}
  (Embed : sobj -> obj).

Definition sub (a b : sobj) : Type := C (Embed a) (Embed b).

Definition subm (a b : sobj) (f : C (Embed a) (Embed b)) : sub a b := f.
Definition unsubm (a b : sobj) (f : sub a b) : C (Embed a) (Embed b) := f.

Context
  {Eq2_C : Eq2 C}
  {Id_C : Id_ C}
  {Cat_C : Cat C}.

Global Instance Eq2_sub : Eq2 sub :=
  fun _ _ => eq2 (C := C).

Global Instance Id_sub : Id_ sub :=
  fun _ => id_ (C := C) _.

Global Instance Cat_sub : Cat sub :=
  fun _ _ _ => cat (C := C).

Context
  (bif : obj -> obj -> obj)
  (sbif : sobj -> sobj -> sobj).

Class ToBifunctor : Type :=
  to_bif : forall a b, C (Embed (sbif a b)) (bif (Embed a) (Embed b)).

Class FromBifunctor : Type :=
  from_bif : forall a b, C (bif (Embed a) (Embed b)) (Embed (sbif a b)).

Arguments to_bif {_ a b}.
Arguments from_bif {_ a b}.

Context
  {ToBif : ToBifunctor}
  {FromBif : FromBifunctor}
  {IsoBif : forall a b, Iso C (a := Embed (sbif a b)) to_bif from_bif}.

Section Bimap.

Context
  {Bimap_C : Bimap C bif}.

Definition Bimap_sub : Bimap sub sbif :=
  fun _ _ _ _ f g => to_bif >>> bimap (C := C) f g >>> from_bif.

End Bimap.

Context
  {Case_C : Case C bif}
  {Inl_C : Inl C bif}
  {Inr_C : Inr C bif}.

Global Instance Case_sub : Case sub sbif :=
  fun _ _ _ f g => to_bif >>> case_ (C := C) f g.

Global Instance Inl_sub : Inl sub sbif :=
  fun _ _ => inl_ (C := C) >>> from_bif.

Global Instance Inr_sub : Inr sub sbif :=
  fun _ _ => inr_ (C := C) >>> from_bif.

Context
  {Iter_C : Iter C bif}.

Global Instance Iter_sub : Iter sub sbif :=
  fun _ _ f => iter (C := C) (cat (C := C) f to_bif).

Section CatLaws.

Context
  {Equivalence_C : forall a b, @Equivalence (C a b) eq2}
  {Category_C : Category C}.

Global Instance Equivalence_sub {a b} : @Equivalence (sub a b) eq2 :=
  Equivalence_C _ _.

Global Instance Category_sub : Category sub.
Proof.
  destruct Category_C; constructor; red; eauto.
  do 2 red. intros. eapply category_proper_cat; eauto.
Qed.

Global Instance Proper_subm {a b} : Proper (eq2 ==> eq2) (subm a b).
Proof. hnf; auto. Qed.

Global Instance Proper_unsubm {a b} : Proper (eq2 ==> eq2) (subm a b).
Proof. hnf; auto. Qed.

Global Instance Functor_unsubm : Functor sub C Embed unsubm.
Proof.
  constructor; reflexivity + typeclasses eauto.
Qed.

End CatLaws.

Ltac unfold_sub :=
  repeat progress (
    try change (eq2 (C := sub) (a := ?a) (b := ?b))
      with (eq2 (C := C) (a := Embed a) (b := Embed b));
    try change (id_ (C := sub) ?a)
      with (id_ (C := C) (Embed a));
    try change (cat (C := sub) (a := ?a) (b := ?b) (c := ?c))
      with (cat (C := C) (a := Embed a) (b := Embed b) (c := Embed c));
    try change (case_ (C := sub) (a := ?a) (b := ?b) (c := ?c) ?f ?g)
      with (to_bif >>> case_ (C := C) (a := Embed a) (b := Embed b) (c := Embed c) f g);
    try change (inl_ (C := sub) (a := ?a) (b := ?b))
      with (inl_ (C := C) (a := Embed a) (b := Embed b) >>> from_bif);
    try change (inr_ (C := sub) (a := ?a) (b := ?b))
      with (inr_ (C := C) (a := Embed a) (b := Embed b) >>> from_bif);
    try change (iter (C := sub) (a := ?a) (b := ?b) ?f)
      with (iter (C := C) (cat (C := C) f to_bif))
  ).

Ltac simpl_bif :=
  try rewrite <- (cat_assoc to_bif from_bif), (semi_iso to_bif from_bif);
  try rewrite <- (cat_assoc from_bif to_bif), (semi_iso from_bif to_bif);
  rewrite cat_id_l.

Section CoproductLaws.

Context
  {Equivalence_C : forall a b, @Equivalence (C a b) eq2}
  {Category_C : Category C}
  {Coproduct_C : Coproduct C bif}.

Global Instance Coproduct_sub : Coproduct sub sbif.
Proof.
  destruct Coproduct_C; constructor; red; intros.
  all: unfold Morphisms.respectful.
  all: unfold_sub.
  all: try rewrite !cat_assoc.
  all: try simpl_bif; eauto.
  - enough (from_bif >>> fg ⩯ case_ (C := C) f g).
    { rewrite <- H1, <- cat_assoc, (semi_iso _ _), cat_id_l. reflexivity. }
    apply case_universal; rewrite <- cat_assoc; eauto.
  - intros. unfold case_, Case_sub.
    apply category_proper_cat. reflexivity.
    eapply coproduct_proper_case; eauto.
Qed.

Lemma bimap_sub_unfold a b c d (f : sub a c) (g : sub b d) :
  eq2 (C := C) (bimap (C := sub) f g)
      (to_bif >>> bimap (C := C) f g >>> from_bif).
Proof.
  unfold bimap at 1, Bimap_Coproduct at 1.
  unfold_sub.
  rewrite <- 2 cat_assoc.
  rewrite <- cat_case. rewrite cat_assoc.
  reflexivity.
Qed.

Context
  {Iterative_C : Iterative C bif}.

Global Instance Iterative_sub : Iterative sub sbif.
Proof.
  constructor; red; intros.
  all: unfold Morphisms.respectful; unfold_sub.
  - rewrite iter_unfold, cat_assoc at 1. reflexivity.
  - rewrite bimap_sub_unfold.
    rewrite !(cat_assoc to_bif).
    rewrite <- (cat_assoc (C := C) f).
    rewrite cat_assoc, (cat_assoc _ from_bif).
    rewrite (semi_iso _ _), cat_id_r.
    rewrite iter_natural.
    reflexivity.
  - rewrite <- !(cat_assoc _ to_bif).
    rewrite !(cat_assoc _ _ to_bif).
    rewrite !cat_case.
    rewrite !(cat_assoc _ from_bif), !(semi_iso _ _), !cat_id_r.
    rewrite iter_dinatural.
    reflexivity.
  - rewrite <- !(cat_assoc _ to_bif).
    rewrite (cat_assoc _ _ to_bif).
    rewrite cat_case, cat_id_l.
    rewrite (cat_assoc _ _ to_bif), (semi_iso _ _), cat_id_r.
    rewrite iter_natural, iter_codiagonal.
    rewrite (cat_assoc _ (bimap _ _)), bimap_case, cat_id_l, cat_id_r.
    reflexivity.
  - intros; unfold iter, Iter_sub.
    apply iterative_proper_iter, category_proper_cat; auto; reflexivity.
Qed.

End CoproductLaws.

End Subcategory.

Arguments subm {obj C sobj Embed a b}.
Arguments unsubm {obj C sobj Embed a b}.
Arguments to_bif {_ C _ _ _ _ _ a b}.
Arguments from_bif {_ C _ _ _ _ _ a b}.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** THIS FILE IS DEPRECATED. *)

Require Export BinInt Zcompare Zorder.

Local Open Scope Z_scope.

(** Definition [Z.max] is now [BinInt.Z.max]. *)

(** Exact compatibility *)

Notation Zmax_case := Z.max_case (compat "8.6").
Notation Zmax_case_strong := Z.max_case_strong (compat "8.6").
Notation Zmax_right := Z.max_r (only parsing).
Notation Zle_max_l := Z.le_max_l (compat "8.6").
Notation Zle_max_r := Z.le_max_r (compat "8.6").
Notation Zmax_lub := Z.max_lub (compat "8.6").
Notation Zmax_lub_lt := Z.max_lub_lt (compat "8.6").
Notation Zle_max_compat_r := Z.max_le_compat_r (only parsing).
Notation Zle_max_compat_l := Z.max_le_compat_l (only parsing).
Notation Zmax_idempotent := Z.max_id (only parsing).
Notation Zmax_n_n := Z.max_id (only parsing).
Notation Zmax_comm := Z.max_comm (compat "8.6").
Notation Zmax_assoc := Z.max_assoc (compat "8.6").
Notation Zmax_irreducible_dec := Z.max_dec (only parsing).
Notation Zmax_le_prime := Z.max_le (only parsing).
Notation Zsucc_max_distr := Z.succ_max_distr (compat "8.6").
Notation Zmax_SS := Z.succ_max_distr (only parsing).
Notation Zplus_max_distr_l := Z.add_max_distr_l (only parsing).
Notation Zplus_max_distr_r := Z.add_max_distr_r (only parsing).
Notation Zmax_plus := Z.add_max_distr_r (only parsing).
Notation Zmax1 := Z.le_max_l (only parsing).
Notation Zmax2 := Z.le_max_r (only parsing).
Notation Zmax_irreducible_inf := Z.max_dec (only parsing).
Notation Zmax_le_prime_inf := Z.max_le (only parsing).
Notation Zpos_max := Pos2Z.inj_max (only parsing).
Notation Zpos_minus := Pos2Z.inj_sub_max (only parsing).

(** Slightly different lemmas *)

Lemma Zmax_spec x y :
  x >= y /\ Z.max x y = x  \/ x < y /\ Z.max x y = y.
Proof.
 Z.swap_greater. destruct (Z.max_spec x y); auto.
Qed.

Lemma Zmax_left n m : n>=m -> Z.max n m = n.
Proof. Z.swap_greater. apply Z.max_l. Qed.

Lemma Zpos_max_1 p : Z.max 1 (Z.pos p) = Z.pos p.
Proof.
 now destruct p.
Qed.