Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e384m317_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q R S T U : Universe, ((wd_ P T /\ (wd_ T Q /\ (wd_ R T /\ (wd_ T S /\ (wd_ P R /\ (wd_ R U /\ (wd_ P U /\ (wd_ R S /\ (wd_ P Q /\ (col_ P Q R /\ (col_ R T S /\ col_ P T Q))))))))))) -> col_ S Q P)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export SystemFR.ReducibilitySubtype.
Require Export SystemFR.ErasedArrow.
Require Export SystemFR.RedTactics.
Require Export SystemFR.ScalaDepSugar.

Opaque reducible_values.

Lemma subtype_pi: forall ρ S S' T T',
  valid_interpretation ρ ->
  is_erased_type T ->
  is_erased_type T' ->
  wf T 1 ->
  wf T' 1 ->
  pfv T term_var = nil ->
  pfv T' term_var = nil ->
  [ ρ ⊨ S' <: S ] ->
  (forall a, [ ρ ⊨ a : S' ]v -> [ ρ ⊨ open 0 T a <: open 0 T' a ]) ->
  [ ρ ⊨ T_arrow S T <: T_arrow S' T' ].
Proof.
  intros;
    repeat step || simp_red_goal || rewrite reducibility_rewrite;
    t_closer.

  apply subtype_reducible with (open 0 T a); eauto.
  eapply reducible_app; eauto using reducible_value_expr; steps.
Qed.

Lemma open_subpi_helper: forall Θ Γ S S' T T' x,
  is_erased_type T ->
  is_erased_type T' ->
  wf T 1 ->
  wf T' 1 ->
  subset (fv T) (support Γ) ->
  subset (fv T') (support Γ) ->
  ~ x ∈ pfv S' term_var ->
  ~ x ∈ pfv_context Γ term_var ->
  [ Θ; Γ ⊨ S' <: S ] ->
  [ Θ; (x, S') :: Γ ⊨ open 0 T (fvar x term_var) <: open 0 T' (fvar x term_var) ] ->
  [ Θ; Γ ⊨ T_arrow S T <: T_arrow S' T' ].
Proof.
  unfold open_subtype; repeat step; t_closer.
  apply subtype_pi with (psubstitute S l term_var) (psubstitute T l term_var);
    repeat step; t_closer.

  unshelve epose proof (H8 ρ ((x, a) :: l) _ _ _);
    repeat step || apply SatCons || t_substitutions; t_closer.
Qed.

Lemma open_subpi: forall Γ S S' T T' x,
  is_erased_type T ->
  is_erased_type T' ->
  wf T 1 ->
  wf T' 1 ->
  subset (fv T) (support Γ) ->
  subset (fv T') (support Γ) ->
  ~ x ∈ pfv S' term_var ->
  ~ x ∈ pfv_context Γ term_var ->
  [ Γ ⊫ S' <: S ] ->
  [ (x, S') :: Γ ⊫ open 0 T (fvar x term_var) <: open 0 T' (fvar x term_var) ] ->
  [ Γ ⊫ T_arrow S T <: T_arrow S' T' ].
Proof.
  eauto using open_subpi_helper.
Qed.


(* A carrier type for regular predicates. *)

From larith Require Import A_setup B1_utils C2_order C1_norm D1_automaton.

Section A_regular_predicate.

Variable letter : Set.
Variable P : list letter -> Prop.

(* P is regular iff its domain can be decided using a finite automaton. *)
(* An optional proof of determinism may be provided (for optimization). *)
(* We also request that the automaton states are comparable. *)
Record regular := Regular {
  r_fsa    : automaton letter;
  r_size   : nat;
  r_finite : Finite r_fsa r_size;
  r_spec   : ∀w, Language r_fsa w <-> P w;
  r_det    : option (Deterministic r_fsa);
  r_cmp    : state r_fsa -> state r_fsa -> comparison;
  r_ord    : Order r_cmp;
}.

(* Regular predicates over a finite alphabet can be decided. *)
Variable alphabet : list letter.
Hypothesis full_alphabet : ∀c, In c alphabet.
Hypothesis is_regular : regular.

Theorem regular_dec :
  (Σ w, P w) + {∀w, ¬P w}.
Proof.
destruct is_regular as [A size fin spec _ cmp ord].
edestruct Language_inhabited_dec with (A:=A).
apply full_alphabet. eapply cmp_dec, ord. apply fin.
- left; destruct s as [w H]; exists w; apply spec, H.
- right; intros; rewrite <-spec; apply n.
Defined.

End A_regular_predicate.

Arguments regular {_}.

(* Replace predicate with an equivalent one. *)
Theorem regular_ext {letter : Set} (P Q : list letter -> Prop) :
  regular P -> (∀w, P w <-> Q w) -> regular Q.
Proof.
intros [A size fin spec det cmp ord] H.
eapply Regular with (r_fsa:=A). apply fin.
intros; rewrite <-H; apply spec. apply det. apply ord.
Defined.

(* Change the alphabet. *)
Theorem regular_proj {letter letter' : Set} P Q (pr : letter' -> letter) :
  regular P -> (∀w, P (map pr w) <-> Q w) -> regular Q.
Proof.
intros [A size fin spec det cmp ord] H.
pose(B := Automata.proj _ A _ (λ c, [pr c])).
eapply Regular with (r_fsa:=B).
- apply fin.
- intros. rewrite <-H, <-spec.
  unfold B; rewrite Automata.proj_spec.
  unfold Automata.Image; rewrite map_map_singleton. split.
  + intros [v [H1 H2]]. apply Forall2_In_singleton in H1; congruence.
  + intros Hfw; exists (map pr w); split.
    now apply Forall2_In_singleton. easy.
- destruct det.
  + apply Some, Automata.proj_det; [apply d|easy].
  + apply None.
- apply ord.
Defined.

Section Closure_under_logical_operations.

Variable letter : Set.
Variable P Q : list letter -> Prop.

Theorem regular_conjunction :
  regular P -> regular Q -> regular (λ w, P w /\ Q w).
Proof.
intros [A sizeA finA specA detA cmpA ordA];
intros [B sizeB finB specB detB cmpB ordB].
eapply Regular with (r_fsa:=Automata.prod _ A B)(r_cmp:=cmp_pair _ _ cmpA cmpB).
- apply Automata.prod_size. apply finA. apply finB.
- intros; rewrite Automata.prod_spec, specA, specB; reflexivity.
- destruct detA, detB. apply Some, Automata.prod_det; easy. all: apply None.
- apply Order_pair; easy.
Defined.

Theorem regular_negation :
  regular P -> regular (λ w, ¬P w).
Proof.
intros [A size fin spec [det|] cmp ord].
- (* A is deterministic. *)
  eapply Regular with (r_fsa:=Automata.compl _ A).
  + apply fin.
  + intros; etransitivity.
    apply Automata.compl_spec, det.
    split; apply contra, spec.
  + apply Some, det.
  + apply ord.
- (* A is not deterministic; use the powerset construction. *)
  pose(leb := cmp_leb _ cmp);
  assert(Hleb := Linear_order_cmp_leb _ cmp ord);
  assert(dec := cmp_dec cmp ord).
  eapply Regular with (r_fsa:=Automata.compl _ (Automata.pow _ A leb Hleb)).
  + apply Automata.pow_size. apply dec. apply fin.
  + intros; etransitivity.
    apply Automata.compl_spec, Automata.pow_det.
    rewrite Automata.pow_spec.
    split; apply contra, spec.
  + apply Some, Automata.pow_det.
  + eapply Order_sig. apply Order_list, ord.
    apply Automata.pow_state_pir, dec.
Defined.

End Closure_under_logical_operations.


(* representation of thread states as a a finite partial map, with an explicit
bound beyond which no more threads are mapped *)

Require Import Arith.
Require Import Omega.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import ProofAutomation.
Require Import Helpers.Instances.
Require Import List.
Require Import ListStuff.

Require Import Spec.ConcurProc.

Set Implicit Arguments.

Section Map.
  Notation A := nat.

  Variable Op : Type -> Type.
  Notation V := (maybe_proc Op).

  Record threads_state :=
    { thread_get :> A -> V;
      thread_max : nat;
      mapping_finite : forall a, thread_max < a -> thread_get a = NoProc;
      thread_max_minimal : (thread_get thread_max <> NoProc) \/ thread_max = 0 }.

  Notation t := threads_state.

  Hint Extern 4 (_ < _) => omega.
  Hint Resolve mapping_finite.
  Hint Extern 2 (_ <> _) => congruence.
  Hint Extern 2 (_ = _ -> False) => congruence.
  Hint Resolve thread_max_minimal.

  Fixpoint lower_mapping (x:threads_state) n : A :=
    match n with
    | 0 => 0
    | S n' => match x n' with
             | Proc _ => n'
             | NoProc => lower_mapping x n'
             end
    end.

  Theorem lower_mapping_smaller : forall x n,
      lower_mapping x n < n \/ n = 0.
  Proof.
    induction n; simpl; auto.
    destruct (x n); intuition auto.
    subst; auto.
  Qed.

  Theorem lower_mapping_not_none : forall (x:t) n,
      x (lower_mapping x n) <> NoProc \/
      lower_mapping x n = 0.
  Proof.
    induction n; simpl; auto.
    destruct_with_eqn (x n); intuition auto.
  Qed.

  Theorem lower_mapping_thread_maximal : forall x n,
      forall a, lower_mapping x n < a -> a < n -> x a = NoProc.
  Proof.
    intros.
    induction n; simpl in *; intros.
    exfalso; omega.
    destruct_with_eqn (x n); auto.
    destruct (a == n); subst; auto.
  Qed.

  Definition thread_upd (x:t) (a:A) (v:V) : t.
    refine {| thread_get :=
                fun a' => if a == a' then v else x a';
              thread_max :=
                if lt_dec (thread_max x) a then
                  (* modification past current end *)
                  match v with
                  | Proc _ => a
                  | NoProc => thread_max x (* no-op *)
                  end else
                  match v with
                  | Proc _ => thread_max x
                  | NoProc => (* deleting from the middle; might need to lower thread_max *)
                    if a == thread_max x then
                      lower_mapping x (thread_max x) else
                      thread_max x
                  end|};
      intros.
    - destruct (lt_dec (thread_max x) a), (a == a0), v; subst; try omega; auto.
      destruct (a == thread_max x); subst; auto.
      destruct (lt_dec a0 (thread_max x)); auto.
      apply lower_mapping_thread_maximal with (n := thread_max x); auto.
    - destruct (lt_dec (thread_max x) a), v; subst;
        repeat match goal with
               | |- context[if equal_dec ?a ?b then _ else _] => destruct (a == b)
               end; subst; try omega; auto.
      destruct (lower_mapping_smaller x (thread_max x)); try omega.
      rewrite H; simpl; auto.
      destruct (lower_mapping_not_none x (thread_max x)); auto.
  Defined.

  Theorem thread_ext_eq : forall (x y:t),
      (forall tid, x tid = y tid) ->
      x = y.
  Proof.
    intros.
    destruct x as [x x_thread_max mapping_finite_x thread_max_minimal_x].
    destruct y as [y y_thread_max mapping_finite_y thread_max_minimal_y].
    simpl in *.
    assert (x = y).
    extensionality tid; auto.
    subst y.
    clear H.
    assert (x_thread_max = y_thread_max). { (* the main proof *)
      destruct thread_max_minimal_x, thread_max_minimal_y; subst; auto.
      - assert (~x_thread_max < y_thread_max) by (intro; eauto).
        assert (~y_thread_max < x_thread_max) by (intro; eauto).
        omega.
      - specialize (mapping_finite_y x_thread_max).
        destruct x_thread_max; auto.
        exfalso; auto.
      - specialize (mapping_finite_x y_thread_max).
        destruct y_thread_max; auto.
        exfalso; auto.
    }
    subst.
    f_equal; auto using proof_irrelevance.
  Qed.

  Ltac t :=
    intros;
    try lazymatch goal with
        | |- @eq t _ _ => apply thread_ext_eq; intros
        end;
    simpl;
    repeat match goal with
           | [ |- context[equal_dec ?a ?a'] ] =>
             destruct (a == a')
           | _ => congruence
           end.

  Theorem thread_upd_eq : forall x a v,
      thread_upd x a v a = v.
  Proof.
    t.
  Qed.

  Theorem thread_upd_ne: forall (x:t) a a' v,
      a <> a' ->
      thread_upd x a v a' = x a'.
  Proof.
    t.
  Qed.

  Theorem thread_upd_thread_upd_eq : forall x a v v',
      thread_upd (thread_upd x a v) a v' = thread_upd x a v'.
  Proof.
    t.
  Qed.

  Theorem thread_upd_ne_comm : forall (ts:t) tid tid' p p',
      tid <> tid' ->
      thread_upd (thread_upd ts tid p) tid' p' =
      thread_upd (thread_upd ts tid' p') tid p.
  Proof.
    t.
  Qed.

  Theorem thread_upd_same_eq : forall (ts:t) tid p,
      ts tid = p ->
      thread_upd ts tid p = ts.
  Proof.
    t.
  Qed.

  Theorem thread_upd_thread_max_bound : forall (x:t) a v,
      a <= thread_max x ->
      thread_max (thread_upd x a v) <= thread_max x.
  Proof.
    simpl; intros.
    generalize dependent (thread_max x); intros m **.
    destruct (lt_dec m a).
    destruct v; auto.
    destruct v; auto.
    destruct (a == m); subst; auto.
    destruct (lower_mapping_smaller x m); subst; auto.
    omega.
  Qed.

  Theorem thread_upd_thread_max_extend : forall (x:t) a T v,
      a > thread_max x ->
      thread_max (thread_upd x a (Proc (T:=T) v)) > thread_max x.
  Proof.
    simpl; intros.
    generalize dependent (thread_max x); intros m **.
    destruct (lt_dec m a); auto.
  Qed.

  Theorem thread_upd_thread_max_extend_bound : forall (x:t) a v,
      a >= thread_max x ->
      thread_max (thread_upd x a v) <= a.
  Proof.
    simpl; intros.
    generalize dependent (thread_max x); intros m **.
    destruct (lt_dec m a); auto.
    destruct v; auto; try omega.
    destruct v; auto; try omega.
    destruct (a == m); subst; auto.
    destruct (lower_mapping_smaller x m); subst; auto.
    omega.
  Qed.

  Theorem thread_upd_thread_max_shrink : forall (x:t) a,
      thread_max (thread_upd x a NoProc) <= thread_max x.
  Proof.
    simpl; intros.
    generalize dependent (thread_max x); intros m **.
    destruct (lt_dec m a); auto.
    destruct (a == m); subst; auto.
    destruct (lower_mapping_smaller x m); subst; auto.
    omega.
  Qed.

  Theorem thread_upd_unchanged : forall (x:t) a T (v: proc Op T),
      a <= thread_max x ->
      thread_max (thread_upd x a (Proc v)) = thread_max x.
  Proof.
  Abort.

  Theorem past_thread_max_empty : forall (x:t),
      x (1 + thread_max x) = NoProc.
  Proof.
    intros.
    apply mapping_finite; omega.
  Qed.

  Definition thread_empty : t.
    refine {| thread_get := fun _ => NoProc;
              thread_max := 0; |}; auto.
  Defined.

  Theorem empty_is_empty : forall a,
      thread_empty a = NoProc.
  Proof.
    simpl; auto.
  Qed.

  Theorem thread_empty_not_some : forall a T (v: proc Op T),
      ~thread_empty a = Proc v.
  Proof.
    simpl; auto.
  Qed.

  Theorem thread_empty_unique : forall (x:t),
      (forall a, x a = NoProc) ->
      x = thread_empty.
  Proof.
    t.
  Qed.

  Theorem empty_thread_max :
    thread_max thread_empty = 0.
  Proof.
    t.
  Qed.

  Definition thread_Forall (P: forall T, proc Op T -> Prop) (ts:t) :=
    forall tid T (p: proc Op T), ts tid = Proc p -> P _ p.

  Theorem thread_Forall_some : forall P x a T (v: proc Op T),
      thread_Forall P x ->
      x a = Proc v ->
      P _ v.
  Proof.
    unfold thread_Forall; eauto.
  Qed.

  Theorem empty_thread_Forall : forall P,
      thread_Forall P thread_empty.
  Proof.
    unfold thread_Forall; intros.
    apply thread_empty_not_some in H; contradiction.
  Qed.

  Theorem thread_Forall_thread_upd_some : forall P ts tid T (p: proc Op T),
      thread_Forall P ts ->
      P _ p ->
      thread_Forall P (thread_upd ts tid (Proc p)).
  Proof.
    unfold thread_Forall.
    t.
    destruct (tid == tid0); subst;
      rewrite ?Map.thread_upd_eq, ?Map.thread_upd_ne in * by auto;
      subst;
      eauto.
    invert H1.
  Qed.

  Theorem thread_Forall_forall : forall (P: forall T, proc Op T -> Prop) (x:t),
      (forall a T (v: proc _ T), x a = Proc v -> P _ v) ->
      thread_Forall P x.
  Proof.
    unfold thread_Forall; eauto.
  Qed.

  Theorem thread_Forall_thread_upd_none : forall P x tid,
      thread_Forall P x ->
      thread_Forall P (thread_upd x tid NoProc).
  Proof.
    unfold thread_Forall.
    t.
    destruct (tid == tid0); subst;
      rewrite ?Map.thread_upd_eq, ?Map.thread_upd_ne in * by auto;
      subst;
      eauto.
    congruence.
  Qed.

  Definition thread_from_list (l: list {T & proc Op T}) : t.
    refine {| thread_get := fun a => match List.nth_error l a with
                                  | Some (existT _ _ p) => Proc p
                                  | None => NoProc
                                  end;
              thread_max := length l - 1; |}.
    intros.
    assert (length l <= a) by omega.
    apply List.nth_error_None in H0.
    simpl_match; auto.
    destruct_with_eqn (List.nth_error l (length l - 1)); eauto.
    destruct s; left; congruence.
    right.
    apply List.nth_error_None in Heqo.
    omega.
  Defined.

  Local Fixpoint _to_list (x:t) n : list V :=
    match n with
    | 0 => nil
    | S n' => _to_list x n' ++ (x n'::nil)
    end.

  Definition thread_to_list (x:t) : list V := _to_list x (1 + thread_max x).

  Lemma firstn_map : forall A B (f: A -> B) n (l: list A),
      List.firstn n (List.map f l) = List.map f (List.firstn n l).
  Proof.
    induction n; simpl; intros; auto.
    destruct l; simpl; eauto.
    rewrite IHn; auto.
  Qed.

  Lemma nth_error_nil : forall A n,
      List.nth_error (@nil A) n = None.
  Proof.
    induction n; simpl; eauto.
  Qed.

  Lemma from_list__to_list : forall l n,
      n <= length l ->
      _to_list (thread_from_list l) n = List.firstn n (List.map (fun '(existT _ _ p) => Proc p) l).
  Proof.
    induction n; intros; auto.
    cbn [_to_list thread_get thread_from_list].
    rewrite IHn by omega.
    rewrite ?firstn_map.
    clear IHn.
    fold (lt n (length l)) in H.
    assert (length (firstn n l) = n) by ( apply firstn_length_le; omega ).
    replace (firstn (S n) l) with (firstn n l ++ (firstn 1 (skipn n l))).
    2: {
      replace (S n) with (length (firstn n l) + 1) by omega.
      replace l with (firstn n l ++ skipn n l) at 4 by apply firstn_skipn.
      rewrite firstn_app_2.
      reflexivity.
    }

    assert (skipn n l <> nil).
    {
      erewrite <- firstn_skipn with (l := l) in H.
      rewrite app_length in H.
      rewrite H0 in H.
      destruct (skipn n l); simpl in *; try congruence.
      omega.
    }

    rewrite map_app.
    f_equal.
    rewrite <- firstn_skipn with (l := l) (n := n) at 1.
    rewrite nth_error_app2 by omega.
    replace (n - length (firstn n l)) with 0 by omega.

    destruct (skipn n l); try congruence; simpl.
    reflexivity.
  Qed.

  Theorem thread_from_list_to_list : forall l,
      0 < length l ->
      thread_to_list (thread_from_list l) = List.map (fun '(existT _ _ p) => Proc p) l.
  Proof.
    unfold thread_to_list; intros.
    unfold thread_to_list.
    rewrite from_list__to_list by (simpl; omega).
    rewrite List.firstn_all2; auto.
    rewrite List.map_length.
    simpl; omega.
  Qed.

End Map.

Theorem thread_max_eq : forall Op1 Op2 (ts1:threads_state Op1) (ts2:threads_state Op2),
    (forall tid, ts1 tid = NoProc <-> ts2 tid = NoProc) ->
    thread_max ts1 = thread_max ts2.
Proof.
  (* will do proof by symmetry *)
  assert (forall V1 V2 (x1:threads_state V1) (x2:threads_state V2),
             (forall a, x1 a = NoProc <-> x2 a = NoProc) ->
             thread_max x1 < thread_max x2 -> False).
  intros.
  pose proof (@mapping_finite _ x1 (thread_max x2) ltac:(omega)).
  apply H in H1.
  destruct (thread_max_minimal x2); try congruence.
  omega.

  intros.
  assert (forall a, ts2 a = NoProc <-> ts1 a = NoProc).
  split; intuition auto.
  apply H0; auto.
  apply H0; auto.
  pose proof (H _ _ ts1 ts2).
  pose proof (H _ _ ts2 ts1).
  intuition auto.
  omega.
Qed.

Section Map_map.

  Variable Op1:Type -> Type.
  Variable Op2:Type -> Type.
  Variable f:forall T, proc Op1 T -> proc Op2 T.

  Definition thread_map (x:threads_state Op1) : threads_state Op2.
    refine {| thread_get := fun a => match x a with
                                  | NoProc => NoProc
                                  | Proc v => Proc (f v)
                                  end;
              thread_max := thread_max x; |}; intros.
    destruct_with_eqn (x a); eauto.
    rewrite mapping_finite in Heqm by auto; congruence.

    destruct (thread_max_minimal x); auto.
    destruct (x (thread_max x)); auto.
    left; congruence.
  Defined.

  Theorem thread_map_get_match : forall (x:threads_state Op1) a,
      thread_map x a = match x a with
                       | Proc v => Proc (f v)
                       | NoProc => NoProc
                       end.
  Proof.
    simpl; auto.
  Qed.

  Theorem map_thread_get_some : forall (x:threads_state Op1) a T (v: proc Op1 T),
      x a = Proc v ->
      thread_map x a = Proc (f v).
  Proof.
    simpl; intros.
    rewrite H; auto.
  Qed.

  Theorem map_thread_get_none : forall (x:threads_state Op1) a,
      x a = NoProc ->
      thread_map x a = NoProc.
  Proof.
    simpl; intros.
    rewrite H; auto.
  Qed.

  Theorem map_thread_Forall : forall (P: forall T, proc Op1 T -> Prop) (Q:forall T, proc Op2 T -> Prop) (x:threads_state Op1),
      thread_Forall P x ->
      (forall T v, P T v -> Q T (f v)) ->
      thread_Forall Q (thread_map x).
  Proof.
    unfold thread_Forall; simpl; intros.
    destruct_with_eqn (x tid).
    inversion H1; subst; eauto.
    congruence.
  Qed.

End Map_map.

Theorem thread_map_eq :
  forall Op1 Op2
         (f g : forall T, proc Op1 T -> proc Op2 T)
         ts,
    (forall T p, f T p = g T p) ->
    thread_map f ts = thread_map g ts.
Proof.
  intros.
  replace g with f; auto.
  apply functional_extensionality_dep; intros.
  apply functional_extensionality; eauto.
Qed.

Theorem thread_map_thread_map :
  forall Op1 Op2 Op3
         (f : forall T, proc Op1 T -> proc Op2 T)
         (g : forall T, proc Op2 T -> proc Op3 T)
         ts,
    thread_map g (thread_map f ts) = thread_map (fun T t => g T (f T t)) ts.
Proof.
  intros.
  apply thread_ext_eq; intros; cbn.
  destruct matches.
Qed.

Theorem map_nth_error_none :
  forall A B (f : A -> B) n l,
    nth_error l n = None -> nth_error (map f l) n = None.
Proof.
  intros.
  apply nth_error_None in H.
  apply nth_error_None.
  rewrite map_length; auto.
Qed.

Theorem thread_map_thread_from_list :
  forall Op1 Op2
         (f : forall T, proc Op1 T -> proc Op2 T)
         tl,
    thread_map f (thread_from_list tl) =
    thread_from_list (map (fun '(existT _ T p) => existT _ T (f T p)) tl).
Proof.
  intros.
  apply thread_ext_eq; intros; cbn.
  destruct_with_eqn (nth_error tl tid).
  - erewrite map_nth_error by eauto.
    destruct matches.
  - erewrite map_nth_error_none; eauto.
Qed.

Theorem thread_upd_thread_from_list :
  forall Op tl tid T (p : proc Op T),
    tid < length tl ->
    thread_upd (thread_from_list tl) tid (Proc p) =
    thread_from_list (list_upd tl tid (existT _ T p)).
Proof.
  intros.
  apply thread_ext_eq; intros; simpl.
  destruct (tid == tid0); propositional.
  - rewrite nth_error_list_upd_eq; eauto.
  - rewrite nth_error_list_upd_ne; eauto.
Qed.

Global Opaque
       thread_get
       thread_upd
       thread_empty
       thread_Forall
       thread_from_list
       thread_to_list
       thread_map.

Arguments thread_empty {Op}.

Hint Rewrite thread_upd_eq : t.
Hint Rewrite thread_upd_ne using solve [ auto ] : t.
Hint Rewrite thread_upd_thread_upd_eq : t.
Hint Rewrite thread_upd_same_eq using solve [ auto ] : t.
Hint Rewrite map_thread_get_none using solve [ auto ] : t.
Hint Rewrite empty_thread_max : t.
Hint Rewrite thread_map_thread_map : t.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                            2004 -2005                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Set Implicit Arguments.
Require Export natDedGram.
Require Export lambda_bruijn.
Require Export logic_const.
(* definition of semantic lexicon *)

(* a list formed of pairs of forms and lambda-terms is well typed
 iff forall (f,l)member of this list, l is of type (map f) *)

Fixpoint isWellTyped_pairs (I J A :Set)(map:A -> semType)
(l:list ((Form I J A) * (option (lambda_terms logic_cst))))
{struct l}:Prop:=
match l with
|nil => False
|(f,None)::nil=>True
|(f,(Some te))::nil => type_check setTypeLog nil te=Some (mapExt map f)
|(f,None)::l1=>isWellTyped_pairs map l1
|(f,(Some te))::l1=> type_check  setTypeLog nil te =Some (mapExt map f)/\
                               isWellTyped_pairs map l1
end.

Definition isWellTyped_lex (I J A W :Set)(map:A -> semType)
(lex:W->list ((Form I J A) * (option (lambda_terms logic_cst))))
:=forall (w:W), isWellTyped_pairs map (lex w).

Lemma well_typed_no_empty:forall(I J A W:Set)(map:A -> semType)
(lex:W->list ((Form I J A) * (option (lambda_terms logic_cst)))),
   isWellTyped_lex map  lex->
  forall (w:W),lex w <>nil.
Proof.
 unfold isWellTyped_lex in |- *; intros.
 generalize (H w); case (lex w).
 simpl in |- *; induction 1.
 intros; auto with datatypes.
Qed.

(* lexicon for syntactic and semantic analysis *)
Record lexicon : Type:=
mk_lex {
I :Set;
J:Set;
A:Set;
W:Set;
eqdecI:eqdec I;
eqdecJ :eqdec J;
eqdecA:eqdec A;
map:A -> semType;
lex: W -> (list (prod (Form I J A) (option (lambda_terms logic_cst))));
wt_lex:isWellTyped_lex map  lex
}.

Definition set_syn_sem_Lex(I J :Set)(A:Set)(W:Set)(consSem:Set)
(eqdecI:eqdec I) (eqdecJ:eqdec J)(eqdecA :eqdec A)(map:A -> semType)
(lex: W -> (list (prod (Form I J A) (option (lambda_terms
logic_cst)))))(wf_lex:isWellTyped_lex map lex)
:lexicon:=
(mk_lex eqdecI eqdecJ eqdecA wf_lex).

Record syn_sem_gram:Type:=
mk_gram{
lexic:lexicon;
ext:extension lexic.(I) lexic.(J)}.

Fixpoint extract_sub_list (I J A:Set)
(l:list ((Form I J A)*(option (lambda_terms logic_cst)))){struct l}:list (Form I J A):=
match l with
|nil=> nil
|(a,s)::l1=>a::(extract_sub_list l1)
end.

Definition extract_lex_syn(I J A W :Set)(l:W->list ((Form I J
A)*(option (lambda_terms logic_cst))))(w:W):list (Form I J A):=
extract_sub_list  (l w).

Definition deriveTo (gr:syn_sem_gram):=
reduceTo  (gr.(lexic)).(eqdecI) (gr.(lexic)).(eqdecJ)
  (extract_lex_syn (gr.(lexic)).(lex)) gr.(ext).

Hint Unfold deriveTo:ctl_db.

(* some notations *)

Notation "'||' gr  '||s:' sent '>>' f ":= (deriveTo gr sent f) (at level
30).

(* to be applied only if W is inductuvely defined *)
Ltac solve_wf:=match goal with
| |-isWellTyped_lex _ _  =>
let wo:=fresh "w" in (
unfold isWellTyped_lex in |- *;intro wo;elim wo;simpl;tauto)
| |- _=>idtac
end.

(*
(* other representation of lexicon using coq-terms
  for semantic *)
Record lexicon_coq : Type:=
mk_lex_coq {
I_coq :Set;
J_coq:Set;
A_coq:Set;
W_coq:Set;
eqdecI_coq:eqdec I_coq;
eqdecJ_coq :eqdec J_coq;
eqdecA_coq:eqdec A_coq;
map_coq:A_coq -> semType;
lex_coq: W_coq -> (list (prod (Form I_coq J_coq A_coq) pair_var_type))
(*wt_lex:isWellTyped_lex_coq lex*)
}.

*)


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * Okamoto.v : Okamoto protocol *)

Require Import SigmaPhi.
Require Import FilterMap.
Require Import LtIrrelevance.
Require Import Schnorr.

Set Implicit Arguments.

Module Type OKAMOTO_PARAMETERS.

 Open Scope Z_scope.

 Parameters p q g g' : nat -> Z.

 Parameter p_prime : forall k, prime (p k).

 Parameter q_prime : forall k, prime (q k).

 Parameter q_divides_pred_p : forall k, (q k | p k - 1).

 Parameter p_poly : polynomial.

 Parameter p_poly_spec : forall k, (size_Z (p k) < peval p_poly k)%nat.

 Parameter g_range : forall k, 1 < g k < p k.

 Parameter g'_range : forall k, 1 < g' k < p k.

 Parameter g_order : forall k, g k ^ q k mod p k = 1.

 Parameter g'_order : forall k, g' k ^ q k mod p k = 1.

End OKAMOTO_PARAMETERS.

Module Okamoto_Homomorphism (OP:OKAMOTO_PARAMETERS).

 Module SPP := Schnorr_Parameters_Properties OP.
 Import SPP.
 Import OP.

 Module G1 := Schnorr_G OP.
 Module G2 := Schnorr_G OP.
 Module G := Group_Prod G1 G2.

 Module H := Schnorr_H OP.
 Module HP := Group_Properties H.
 Import HP.

 Open Scope nat_scope.

 Definition g1 k : H.t k.
  intro k.
  refine (exist _ (Zabs_nat (OP.g k)) _).
  destruct (OP.g_range k).
  apply <- H.P_prop; split.
  change 0%nat with (Zabs_nat 0).
  split; apply Zabs_nat_lt; auto with zarith.
  rewrite inj_Zabs_nat, Zabs_eq, OP.g_order; auto with zarith.
 Defined.

 Definition g2 k : H.t k.
  intro k.
  refine (exist _ (Zabs_nat (OP.g' k)) _).
  destruct (OP.g'_range k).
  apply <- H.P_prop; split.
  change 0%nat with (Zabs_nat 0).
  split; apply Zabs_nat_lt; auto with zarith.
  rewrite inj_Zabs_nat, Zabs_eq, OP.g'_order; auto with zarith.
 Defined.

 Definition phi k (x:G.t k) : H.t k :=
  match x with
   | (exist a _, exist a' _) => H.mul (H.pow (g1 k) a) (H.pow (g2 k) a')
  end.

 Definition cost_phi k (x:G.t k) :=
  match x with
   | (exist a _,exist a' _) => H.cost_pow (g1 k) (Z_of_nat a) * H.cost_pow (g2 k) (Z_of_nat a )
  end.

 Definition cost_phi_poly : polynomial := pmult H.cost_pow_poly H.cost_pow_poly.

 Lemma cost_phi_poly_spec : forall k (x:G.t k),
  cost_phi x <= peval cost_phi_poly k.
 Proof.
  intros k ((a1,H1),(a2,H2)); unfold cost_phi, cost_phi_poly.
  rewrite pmult_spec.
  apply mult_le_compat; apply H.cost_pow_poly_spec.
 Qed.

 Lemma Hpow_simpl : forall k a H n,
  exists H1,
   H.pow (exist (H.P k) a H) n = exist (H.P k) (Zabs_nat (Z_of_nat (a^n) mod p k)) H1.
 Proof.
  intro k.
  assert (Hp:=prime_ge_2 _ (p_prime k)).
  induction n; intros.
  simpl; rewrite Zmod_1_l.
  exists (proj2_sig (H.e k)); trivial.
  auto with zarith.

  change (S n) with (1 + n).
  destruct IHn.
  rewrite <- mul_pow_plus, H0; clear H0; simpl.
  match goal with
   |- context [exist _ _ ?H] => generalize H
  end.
  rewrite mult_1_r, inj_mult, inj_mult.
  repeat (rewrite Zabs_nat_Z_of_nat || rewrite inj_Zabs_nat || fail).
  rewrite Zabs_eq, Zabs_eq, Zmult_mod_idemp_l, Zmult_mod_idemp_r.
  intros H1; exists H1; trivial.
  generalize (Z_mod_lt (Z_of_nat (a ^ n)) (p k)); auto with zarith.
  generalize (Z_mod_lt (Z_of_nat a) (p k)); auto with zarith.
 Qed.

 Lemma cyclic : forall k x, H.pow x (Zabs_nat (q k)) = H.e k.
 Proof.
  intros.
  assert (Hin:=H.elems_full x).
  unfold H.elems in Hin.
  apply filter_map_In in Hin.
  destruct Hin as [a [H [Heq _] ] ]; subst.
  destruct (Hpow_simpl _ a H (Zabs_nat (q k))).
  rewrite H0; generalize x; clear x H0.
  rewrite H.P_prop in H; destruct H as [Hlt Heq].
  assert (a = Zabs_nat (Z_of_nat a)) by (symmetry; apply Zabs_nat_Z_of_nat).
  rewrite H, Zpower_pow_nat, Heq.
  change (Zabs_nat 1) with 1; intro.
  rewrite (H.eq_P _ _ x (proj2_sig (H.e k))); trivial.
  auto with zarith.
  generalize (prime_ge_2 _ (q_prime k)); auto with zarith.
 Qed.

 Lemma phi_homo : forall k (x y:G.t k),
  phi (G.mul x y) = H.mul (phi x) (phi y).
 Proof.
  intros k ((x1,Hx1),(x2,Hx2)) ((y1,Hy1),(y2,Hy2)); unfold phi; simpl.

  rewrite H.mul_assoc, <- (H.mul_assoc (H.pow (g1 k) x1) (H.pow (g2 k) x2) (H.pow (g1 k) y1)).
  rewrite (H.mul_comm (H.pow (g2 k) x2) (H.pow (g1 k) y1)).
  rewrite H.mul_assoc, HP.mul_pow_plus, <- H.mul_assoc, HP.mul_pow_plus.
  case (le_gt_dec (Zabs_nat (q k)) (x1 + y1));
  case (le_gt_dec (Zabs_nat (q k)) (x2 + y2));
  intros; trivial.

  assert (x1 + y1 = x1 + y1 - Zabs_nat (q k) + Zabs_nat (q k)) by omega.
  assert (x2 + y2 = x2 + y2 - Zabs_nat (q k) + Zabs_nat (q k)) by omega.
  rewrite H, H0 at 2.
  rewrite <- (HP.mul_pow_plus (g2 k) (x2 + y2 - Zabs_nat (q k)) (Zabs_nat (q k))), cyclic, HP.mul_e_r; trivial.
  rewrite <- (HP.mul_pow_plus (g1 k) (x1 + y1 - Zabs_nat (q k)) (Zabs_nat (q k))), cyclic, HP.mul_e_r; trivial.

  assert (x1 + y1 = x1 + y1 - Zabs_nat (q k) + Zabs_nat (q k)) by omega.
  rewrite H at 2.
  rewrite <- (HP.mul_pow_plus (g1 k) (x1 + y1 - Zabs_nat (q k)) (Zabs_nat (q k))), cyclic, HP.mul_e_r; trivial.

  assert (x2 + y2 = x2 + y2 - Zabs_nat (q k) + Zabs_nat (q k)) by omega.
  rewrite H at 2.
  rewrite <- (HP.mul_pow_plus (g2 k) (x2 + y2 - Zabs_nat (q k)) (Zabs_nat (q k))), cyclic, HP.mul_e_r; trivial.
 Qed.

 (* [phi] is a special homomorphism *)
 Definition special_v k := Z_of_nat (Zabs_nat (OP.q k)).

 Lemma special_v_spec : forall k, special_v k <> 0%Z.
 Proof.
  intro k; unfold special_v.
  generalize (q_pos k); auto with zarith.
 Qed.

 Definition special_v_poly : polynomial := OP.p_poly.

 Lemma size_nat_special_v : forall k,
  size_nat (Zabs_nat (special_v k)) <= peval special_v_poly k.
 Proof.
  intro k; unfold special_v, special_v_poly.
  apply lt_le_weak.
  rewrite Zabs_nat_Z_of_nat.
  apply q_size.
 Qed.

 Definition cost_special_v (k:nat) := 1.

 Definition cost_special_v_poly : polynomial := 1.

 Lemma cost_special_v_poly_spec : forall k,
  cost_special_v k <= peval cost_special_v_poly k.
 Proof.
  intro k; unfold cost_special_v_poly; rewrite pcst_spec; trivial.
 Qed.

 Definition special_u k (x:H.t k) : G.t k := G.e k.

 Definition cost_special_u k (x:H.t k) := 1.

 Definition cost_special_u_poly : polynomial := 1.

 Lemma cost_special_u_poly_spec : forall k (x:H.t k),
  cost_special_u x <= peval cost_special_u_poly k.
 Proof.
  intro k; unfold cost_special_u_poly; rewrite pcst_spec; trivial.
 Qed.

 Lemma phi_special : forall k (y:H.t k),
  phi (special_u y) = H.powZ y (special_v k).
 Proof.
  intros; unfold special_u, special_v.
  rewrite powZ_pow, cyclic.
  unfold G.e, phi, G1.e, G2.e.
  rewrite <- pow_mul_distr; trivial.
 Qed.

End Okamoto_Homomorphism.

(** Instantiation *)
Declare Module SP : OKAMOTO_PARAMETERS.

Module HM := Okamoto_Homomorphism SP.
Module CS := Largest_Challenge_Set HM.G HM.H HM.

Module S := SigmaPhi.SigmaPhi HM.G HM.H HM CS.


(* General results about arbitrary integer implementations. *)
Require Import
  HoTT.Types.Universe
  HoTT.Basics.Decidable.
Require Import
 HoTT.Classes.theory.nat_distance
 HoTT.Classes.implementations.peano_naturals
 HoTT.Classes.interfaces.naturals
 HoTT.Classes.interfaces.abstract_algebra
 HoTT.Classes.interfaces.orders
 HoTT.Classes.implementations.natpair_integers
 HoTT.Classes.theory.rings
 HoTT.Classes.isomorphisms.rings.
Require Export
 HoTT.Classes.interfaces.integers.

Import NatPair.Instances.
Generalizable Variables N Z R f.

Lemma to_ring_unique `{Integers Z} `{IsRing R} (f: Z -> R)
  {h: IsSemiRingPreserving f} x
  : f x = integers_to_ring Z R x.
Proof.
symmetry. apply integers_initial.
Qed.

Lemma to_ring_unique_alt `{Integers Z} `{IsRing R} (f g: Z -> R)
  `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x :
  f x = g x.
Proof.
rewrite (to_ring_unique f), (to_ring_unique g);reflexivity.
Qed.

Lemma to_ring_involutive Z `{Integers Z} Z2 `{Integers Z2} x :
  integers_to_ring Z2 Z (integers_to_ring Z Z2 x) = x.
Proof.
change (Compose (integers_to_ring Z2 Z) (integers_to_ring Z Z2) x = id x).
apply to_ring_unique_alt;apply _.
Qed.

Lemma morphisms_involutive `{Integers Z} `{IsRing R} (f: R -> Z) (g: Z -> R)
  `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x : f (g x) = x.
Proof. exact (to_ring_unique_alt (f ∘ g) id _). Qed.

Lemma to_ring_twice `{Integers Z} `{IsRing R1} `{IsRing R2}
  (f : R1 -> R2) (g : Z -> R1) (h : Z -> R2)
  `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} `{!IsSemiRingPreserving h} x
  : f (g x) = h x.
Proof. exact (to_ring_unique_alt (f ∘ g) h _). Qed.

Lemma to_ring_self `{Integers Z} (f : Z -> Z) `{!IsSemiRingPreserving f} x : f x = x.
Proof. exact (to_ring_unique_alt f id _). Qed.

(* A ring morphism from integers to another ring is injective
   if there's an injection in the other direction: *)
Lemma to_ring_injective `{Integers Z} `{IsRing R} (f: R -> Z) (g: Z -> R)
  `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g}
  : IsInjective g.
Proof.
intros x y E.
change (id x = id y).
rewrite <-(to_ring_twice f g id x), <-(to_ring_twice f g id y).
apply ap,E.
Qed.

Instance integers_to_integers_injective `{Integers Z} `{Integers Z2}
  (f: Z -> Z2) `{!IsSemiRingPreserving f}
  : IsInjective f.
Proof. exact (to_ring_injective (integers_to_ring Z2 Z) _). Qed.

Instance naturals_to_integers_injective `{Funext} `{Univalence}
  `{Integers@{i i i i i i i i} Z} `{Naturals@{i i i i i i i i} N}
  (f: N -> Z) `{!IsSemiRingPreserving f}
  : IsInjective f.
Proof.
intros x y E.
apply (injective (cast N (NatPair.Z N))).
rewrite <-2!(naturals.to_semiring_twice (integers_to_ring Z (NatPair.Z N))
  f (cast N (NatPair.Z N))).
apply ap,E.
Qed.

Section retract_is_int.
  Context `{Funext} `{Univalence}.
  Context `{Integers Z} `{IsRing Z2}
    {Z2ap : Apart Z2} {Z2le Z2lt} `{!FullPseudoSemiRingOrder (A:=Z2) Z2le Z2lt}.
  Context (f : Z -> Z2) `{!IsEquiv f} `{!IsSemiRingPreserving f}
    `{!IsSemiRingPreserving (f^-1)}.

  (* If we make this an instance, then instance resolution will often loop *)
  Definition retract_is_int_to_ring : IntegersToRing Z2 := fun Z2 _ _ _ _ _ _ =>
    integers_to_ring Z Z2 ∘ f^-1.

  Section for_another_ring.
    Context `{IsRing R}.

    Instance: IsSemiRingPreserving (integers_to_ring Z R ∘ f^-1) := {}.
    Context (h :  Z2 -> R) `{!IsSemiRingPreserving h}.

    Lemma same_morphism x : (integers_to_ring Z R ∘ f^-1) x = h x.
    Proof.
    transitivity ((h ∘ (f ∘ f^-1)) x).
    - symmetry. apply (to_ring_unique (h ∘ f)).
    - unfold Compose. apply ap.
      apply eisretr.
    Qed.
  End for_another_ring.

  (* If we make this an instance, then instance resolution will often loop *)
  Lemma retract_is_int: Integers Z2 (U:=retract_is_int_to_ring).
  Proof.
  split;try apply _.
  - unfold integers_to_ring, retract_is_int_to_ring. apply _.
  - intros;apply same_morphism;apply _.
  Qed.
End retract_is_int.

Section int_to_int_iso.

Context `{Integers Z1} `{Integers Z2}.

Global Instance int_to_int_equiv : IsEquiv (integers_to_ring Z1 Z2).
Proof.
apply Equivalences.isequiv_adjointify with (integers_to_ring Z2 Z1);
red;apply (to_ring_involutive _ _).
Defined.

End int_to_int_iso.

Section contents.
Universe U.

Context `{Funext} `{Univalence}.
Context (Z : Type@{U}) `{Integers@{U U U U U U U U} Z}.

Lemma from_int_stmt  (Z':Type@{U}) `{Integers@{U U U U U U U U} Z'}
  : forall (P : Rings.Operations -> Type),
  P (Rings.BuildOperations Z') -> P (Rings.BuildOperations Z).
Proof.
apply Rings.iso_leibnitz with (integers_to_ring Z' Z);apply _.
Qed.

Global Instance int_dec : DecidablePaths Z | 10.
Proof.
apply decidablepaths_equiv with (NatPair.Z nat)
  (integers_to_ring (NatPair.Z nat) Z);apply _.
Qed.

Global Instance slow_int_abs `{Naturals N} : IntAbs Z N | 10.
Proof.
intros x.
destruct (int_abs_sig (NatPair.Z N) N (integers_to_ring Z (NatPair.Z N) x))
as [[n E]|[n E]];[left|right];exists n.
- apply (injective (integers_to_ring Z (NatPair.Z N))).
  rewrite <-E. apply (naturals.to_semiring_twice _ _ _).
- apply (injective (integers_to_ring Z (NatPair.Z N))).
  rewrite rings.preserves_negate, <-E.
  apply (naturals.to_semiring_twice _ _ _).
Qed.

Instance int_nontrivial : PropHolds ((1:Z) <>0).
Proof.
intros E.
apply (rings.is_ne_0 (1:nat)).
apply (injective (naturals_to_semiring nat Z)).
exact E. (* because [naturals_to_semiring nat] plays nice with 1 *)
Qed.

Global Instance int_zero_product : ZeroProduct Z.
Proof.
intros x y E.
destruct (zero_product (integers_to_ring Z (NatPair.Z nat) x)
  (integers_to_ring Z (NatPair.Z nat) y)).
- rewrite <-(rings.preserves_mult (A:=Z)), E, (rings.preserves_0 (A:=Z)).
  trivial.
- left. apply (injective (integers_to_ring Z (NatPair.Z nat))).
  rewrite rings.preserves_0. trivial.
- right. apply (injective (integers_to_ring Z (NatPair.Z nat))).
  rewrite rings.preserves_0. trivial.
Qed.

Global Instance int_integral_domain : IsIntegralDomain Z := {}.

End contents.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal10.

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.

Lemma lfind_hyp_test : (@eq lst (rev (rev (Nil))) (Nil)).
Admitted.
QuickChick lfind_hyp_test.


(* 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 homothetie_plane.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter similitude : PO -> R -> R -> PO -> PO.

Axiom
  similitude_def :
    forall (I A B : PO) (k a : R),
    k > 0 ->
    I <> A ->
    B = similitude I k a A ->
    distance I B = k * distance I A /\
    image_angle a = cons_AV (vec I A) (vec I B).

Axiom
  similitude_def_centre :
    forall (I : PO) (k a : R), k > 0 -> I = similitude I k a I.

Axiom
  similitude_def2 :
    forall (I A B : PO) (k a : R),
    k > 0 ->
    I <> A ->
    distance I B = k * distance I A ->
    image_angle a = cons_AV (vec I A) (vec I B) -> B = similitude I k a A.

Lemma composee_rotation_homothetie_pos :
 forall (I M M' M1 : PO) (k a : R),
 k > 0 ->
 M1 = rotation I a M -> M' = homothetie k I M1 -> M' = similitude I k a M.
intros I M M' M1 k a H; try assumption.
discrimine I M.
rewrite <- similitude_def_centre; auto; rewrite <- rotation_def_centre;
 intros.
rewrite H2; rewrite H1; rewrite <- homothetie_centre; auto.
intros.
elim rotation_def with (I := I) (A := M) (B := M1) (a := a);
 [ intros | auto | auto ].
cut (distance I M' = Rabs k * distance I M1); intros.
2: apply distance_homothetie with I; auto with geo.
apply similitude_def2; auto.
rewrite H5; rewrite H3; rewrite Rabs_right; auto.
lra.
rewrite H4; auto.
cut (vec I M' = mult_PP k (vec I M1)); intros.
symmetry  in |- *;
 rewrite
  (angle_produit_positif_r (k:=k) (A:=I) (B:=M1) (C:=M') (D:=I) (E:=M))
  ; auto.
apply image_distinct_centre with (2 := H1); auto.
apply homothetie_vecteur; auto.
Qed.

Lemma composee_homothetie_pos_rotation :
 forall (I M M' M1 : PO) (k a : R),
 k > 0 ->
 M1 = homothetie k I M -> M' = rotation I a M1 -> M' = similitude I k a M.
intros I M M' M1 k a H; try assumption.
discrimine I M.
rewrite <- similitude_def_centre; auto; rewrite <- homothetie_centre; intros.
rewrite H2; rewrite H1; rewrite <- rotation_def_centre; auto.
intros.
cut (vec I M1 = mult_PP k (vec I M)); intros.
cut (distance I M1 = Rabs k * distance I M); intros.
2: apply distance_homothetie with I; auto with geo.
cut (I <> M1); intros.
cut (I <> M'); intros.
elim rotation_def with (I := I) (A := M1) (B := M') (a := a);
 [ intros | auto | auto ].
apply similitude_def2; auto.
rewrite <- H7; rewrite H4; rewrite Rabs_right; auto.
lra.
rewrite H8.
apply permute_angles; auto.
rewrite (angle_produit_positif_r (k:=k) (A:=I) (B:=M) (C:=M1) (D:=I) (E:=M'));
 auto.
apply image_distinct_centre with (2 := H2); auto with geo.
apply distinct_produit_vecteur with (3 := H3); auto.
auto with real.
apply homothetie_vecteur; auto.
Qed.

Lemma existence_similitude_Ika :
 forall (I M : PO) (k a : R),
 k > 0 -> exists M' : PO, M' = similitude I k a M.
intros.
elim existence_rotation_Ia with (I := I) (M := M) (a := a); intros M1; intros.
elim existence_homothetique with (k := k) (I := I) (A := M1); intros M' H1;
 try clear existence_homothetique; try exact H1.
exists M'.
apply composee_rotation_homothetie_pos with M1; auto.
Qed.

Lemma similitude_rapport_un :
 forall (I A : PO) (a : R), rotation I a A = similitude I 1 a A.
intros.
discrimine I A.
rewrite <- rotation_def_centre; rewrite <- similitude_def_centre; auto.
lra.
elim existence_rotation_Ia with (I := I) (M := A) (a := a); intros B; intros.
cut (B = homothetie 1 I B); intros.
2: apply homothetie_identite.
rewrite <- H0.
apply composee_rotation_homothetie_pos with B; auto.
lra.
Qed.

Lemma similitude_angle_nul :
 forall (I A : PO) (k : R), k > 0 -> homothetie k I A = similitude I k 0 A.
intros.
discrimine I A.
rewrite <- homothetie_centre; rewrite <- similitude_def_centre; auto.
cut (A = rotation I 0 A); intros.
2: apply rotation_angle_nul.
elim existence_homothetique with (k := k) (I := I) (A := A); intros M';
 intros.
rewrite <- H2.
apply composee_rotation_homothetie_pos with A; auto.
Qed.

Lemma similitude_identite : forall I A : PO, A = similitude I 1 0 A.
intros.
rewrite <- similitude_rapport_un.
rewrite <- rotation_angle_nul; auto.
Qed.

Lemma image_sim_distinct_centre :
 forall (I A B : PO) (k a : R),
 I <> A -> k > 0 -> B = similitude I k a A -> I <> B.
intros.
elim similitude_def with (I := I) (A := A) (B := B) (k := k) (a := a);
 [ intros | auto | auto | auto ].
apply dist_non_nulle.
rewrite H2.
apply prod_neq_R0; auto with geo.
auto with real.
Qed.

Lemma similitude_decomposition :
 forall (I M M' : PO) (k a : R),
 k > 0 ->
 M' = similitude I k a M ->
 exists M1 : PO, M1 = rotation I a M /\ M' = homothetie k I M1.
intros.
elim existence_rotation_Ia with (I := I) (M := M) (a := a); intros M1; intros.
exists M1.
split; [ try assumption | idtac ].
discrimine I M.
rewrite <- H2 in H1; rewrite <- H2 in H0.
rewrite <- similitude_def_centre in H0; auto;
 rewrite <- rotation_def_centre in H1.
rewrite <- H2; rewrite H0; rewrite H1; auto with geo.
cut (I <> M1); intros.
cut (I <> M'); intros.
apply vecteur_homothetie.
elim similitude_def with (I := I) (A := M) (B := M') (k := k) (a := a);
 [ intros | auto | auto | auto ].
elim rotation_def with (I := I) (A := M) (B := M1) (a := a);
 [ intros | auto | auto ].
apply alignes_distance_positif_colineaire; auto.
replace (cons_AV (vec I M1) (vec I M')) with
 (plus (cons_AV (vec I M) (vec I M')) (opp (cons_AV (vec I M) (vec I M1)))).
rewrite def_opp; auto.
rewrite <- (mes_oppx (A:=I) (B:=M) (C:=I) (D:=M1) (x:=a)); auto.
rewrite <- H6.
repeat rewrite <- add_mes_compatible.
replace (a + - a) with 0; auto.
ring.
apply Chasles_diff; auto.
rewrite <- H7; auto.
apply image_sim_distinct_centre with (3 := H0); auto.
apply image_distinct_centre with (2 := H1); auto.
Qed.

Lemma rotation_homothetie_pos_I_commutent :
 forall (I M M1 M2 : PO) (k a : R),
 k > 0 ->
 M1 = homothetie k I M ->
 M2 = rotation I a M -> homothetie k I M2 = rotation I a M1.
intros.
elim existence_rotation_Ia with (I := I) (M := M1) (a := a); intros N; intros.
elim existence_homothetique with (k := k) (I := I) (A := M2); intros N';
 intros.
rewrite <- H3; rewrite <- H2.
rewrite
 (composee_rotation_homothetie_pos (I:=I) (M:=M) (M':=N') (M1:=M2) (k:=k)
    (a:=a)); auto.
rewrite
 (composee_homothetie_pos_rotation (I:=I) (M:=M) (M':=N) (M1:=M1) (k:=k)
    (a:=a)); auto.
Qed.

Lemma similitudes_meme_centre_commutent :
 forall (I M M1 M2 : PO) (k m a b : R),
 k > 0 ->
 m > 0 ->
 M1 = similitude I k a M ->
 M2 = similitude I m b M -> similitude I k a M2 = similitude I m b M1.
intros I M M1 M2 k m a b H H0; try assumption.
discrimine I M.
repeat (rewrite <- similitude_def_centre; auto).
intros H2 H3; try assumption.
rewrite H2; rewrite H3.
repeat (rewrite <- similitude_def_centre; auto).
intros H2 H3; try assumption.
elim existence_similitude_Ika with (I := I) (M := M1) (k := m) (a := b);
 [ intros N H4 | auto ].
elim existence_similitude_Ika with (I := I) (M := M2) (k := k) (a := a);
 [ intros M' H5 | auto ].
rewrite <- H5.
cut (I <> M1); intros.
2: apply image_sim_distinct_centre with (3 := H2); auto.
cut (I <> M2); intros.
2: apply image_sim_distinct_centre with (3 := H3); auto.
cut (I <> M'); intros.
2: apply image_sim_distinct_centre with (3 := H5); auto.
cut (I <> N); intros.
2: apply image_sim_distinct_centre with (3 := H4); auto.
elim similitude_def with (I := I) (A := M2) (B := M') (k := k) (a := a);
 [ intros | auto | auto | auto ].
elim similitude_def with (I := I) (A := M1) (B := N) (k := m) (a := b);
 [ intros | auto | auto | auto ].
elim similitude_def with (I := I) (A := M) (B := M2) (k := m) (a := b);
 [ intros | auto | auto | auto ].
elim similitude_def with (I := I) (A := M) (B := M1) (k := k) (a := a);
 [ intros | auto | auto | auto ].
apply similitude_def2; auto.
rewrite H16; rewrite H10; rewrite H14; ring.
replace (cons_AV (vec I M1) (vec I M')) with
 (plus
    (plus (cons_AV (vec I M) (vec I M2)) (opp (cons_AV (vec I M) (vec I M1))))
    (cons_AV (vec I M2) (vec I M'))).
rewrite def_opp; auto.
rewrite <- (mes_oppx (A:=I) (B:=M) (C:=I) (D:=M1) (x:=a)); auto.
rewrite <- H15; rewrite <- H11.
repeat rewrite <- add_mes_compatible.
replace (b + - a + a) with b; auto.
ring.
rewrite Chasles_diff; auto.
rewrite Chasles; auto.
Qed.

Lemma homothetie_neg :
 forall (I M M' : PO) (k : R),
 k < 0 -> M' = homothetie k I M -> M' = similitude I (- k) pi M.
intros I M M' k H; try assumption.
discrimine I M.
rewrite <- homothetie_centre.
rewrite <- similitude_def_centre; auto.
lra.
intros.
cut (vec I M' = mult_PP k (vec I M)); intros.
cut (distance I M' = Rabs k * distance I M); intros.
2: apply distance_homothetie with I; auto with geo.
2: apply homothetie_vecteur; auto.
cut (I <> M'); intros.
apply similitude_def2; auto.
lra.
rewrite <- Rabs_left; auto.
rewrite (angle_produit_negatif_r (k:=k) (A:=I) (B:=M) (C:=M') (D:=I) (E:=M));
 auto.
rewrite <- angle_nul; auto.
repeat rewrite <- add_mes_compatible.
replace (0 + pi) with pi; auto.
ring.
apply distinct_produit_vecteur with (3 := H2); auto.
auto with real.
Qed.

Lemma homothetie_neg2 :
 forall (I M : PO) (k : R),
 k < 0 -> homothetie k I M = similitude I (- k) pi M.
intros.
elim existence_homothetique with (k := k) (I := I) (A := M); intros M';
 intros.
rewrite <- H0.
apply homothetie_neg; auto.
Qed.

Lemma rotation_homothetie_I_commutent :
 forall (I M M1 M2 : PO) (k a : R),
 k <> 0 ->
 M1 = homothetie k I M ->
 M2 = rotation I a M -> homothetie k I M2 = rotation I a M1.
intros I M M1 M2 k a H; try assumption.
repeat rewrite similitude_rapport_un.
elim Rtotal_order with (r1 := k) (r2 := 0);
 [ intros H4; try clear total_order
 | intros H4;
    (elim H4;
      [ intros H5; try clear H4 total_order
      | intros H5; try clear H4 total_order; try exact H5 ]) ].
repeat (rewrite homothetie_neg2; auto).
intros.
apply similitudes_meme_centre_commutent with (3 := H0) (4 := H1); auto.
auto with real.
lra.
absurd (k = 0); auto with real.
repeat (rewrite similitude_angle_nul; auto).
intros.
apply similitudes_meme_centre_commutent with (3 := H0) (4 := H1); auto.
lra.
Qed.

Lemma similitude_conserve_angle :
 forall (I A B C A' B' C' : PO) (k a : R),
 k > 0 ->
 A <> B ->
 A <> C ->
 A' = similitude I k a A ->
 B' = similitude I k a B ->
 C' = similitude I k a C ->
 cons_AV (vec A B) (vec A C) = cons_AV (vec A' B') (vec A' C').
intros.
elim
 similitude_decomposition with (I := I) (M := A) (M' := A') (k := k) (a := a);
 [ intros A1 H7; elim H7; intros H8 H9; try clear H7 | auto | auto ].
elim
 similitude_decomposition with (I := I) (M := B) (M' := B') (k := k) (a := a);
 [ intros B1 H7; elim H7; intros H10 H11; try clear H7; try exact H11
 | auto
 | auto ].
elim
 similitude_decomposition with (I := I) (M := C) (M' := C') (k := k) (a := a);
 [ intros C1 H7; elim H7; intros H12 H13; try clear H7; try exact H13
 | auto
 | auto ].
cut (A1 <> B1); intros.
cut (A1 <> C1); intros.
cut (cons_AV (vec A B) (vec A C) = cons_AV (vec A1 B1) (vec A1 C1)); intros.
rewrite H7.
apply
 (homothetie_conserve_angle (I:=I) (A:=A1) (B:=B1) (C:=C1) (A':=A') (B':=B')
    (C':=C') (k:=k)); auto with real.
apply
 (rotation_conserve_angle (I:=I) (A:=A) (B:=B) (C:=C) (A':=A1) (B':=B1)
    (C':=C1) (a:=a)); auto.
apply image_bipoint_distinct with (2 := H8) (3 := H12); auto.
apply image_bipoint_distinct with (2 := H8) (3 := H10); auto.
Qed.

Lemma distance_similitude :
 forall (k a : R) (I A B A' B' : PO),
 k > 0 ->
 A' = similitude I k a A ->
 B' = similitude I k a B -> distance A' B' = k * distance A B.
intros.
elim
 similitude_decomposition with (I := I) (M := A) (M' := A') (k := k) (a := a);
 [ intros A1 H7; elim H7; intros H8 H9; try clear H7 | auto | auto ].
elim
 similitude_decomposition with (I := I) (M := B) (M' := B') (k := k) (a := a);
 [ intros B1 H7; elim H7; intros H10 H11; try clear H7; try exact H11
 | auto
 | auto ].
cut (distance A1 B1 = distance A B); intros.
rewrite <- H2.
rewrite (distance_homothetie (k:=k) (I:=I) (A:=A1) (A':=A') (B:=B1) (B':=B'));
 auto.
rewrite Rabs_right; auto.
red in |- *; auto.
apply rotation_isometrie with (1 := H8) (2 := H10).
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Lists.ListDec.
From MetaCoq.Lob.Template Require Export QuoteGround.Coq.Init.
Import ListNotations.
Local Open Scope list_scope.

(* not decidable *)
(*
#[export] Instance quote_Add {A a ls1 ls2} {qA : quotation_of A} {quoteA : ground_quotable A} : ground_quotable (@Add A a ls1 ls2) := ltac:(destruct 1; exact _). (a:A) : list A -> list A -> Prop :=
#[export] Instance quote_NoDup {A} {qA : quotation_of A} {quoteA : ground_quotable A} {quote_neg_In : forall (a : A) ls, ground_quotable (~In a ls)} {ls} : ground_quotable (@NoDup A ls).
Proof.
  induction ls; adjust_ground_quotable_by_econstructor_inversion ().
Defined.
#[export] Instance quote_Exists : ground_quotable Exists := ltac:(destruct 1; exact _). : list A -> Prop :=
 *)
#[export] Instance quote_Forall {A R ls} {qA : quotation_of A} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteR : forall x, ground_quotable (R x:Prop)} : ground_quotable (@Forall A R ls).
Proof.
  induction ls as [|a ls IH].
  all: adjust_ground_quotable_by_econstructor_inversion ().
Defined.
#[export] Instance quote_Forall2 {A B R lsA lsB} {qA : quotation_of A} {qB : quotation_of B} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@Forall2 A B R lsA lsB).
Proof.
  revert lsB; induction lsA as [|a lsA IH], lsB as [|b lsB].
  all: try solve [ intro pf; exfalso; inversion pf ].
  all: adjust_ground_quotable_by_econstructor_inversion ().
Defined.
#[export] Instance quote_ForallOrdPairs {A R ls} {qA : quotation_of A} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@ForallOrdPairs A R ls).
Proof.
  induction ls as [|a ls IH].
  all: adjust_ground_quotable_by_econstructor_inversion ().
Defined.
#[export] Instance quote_eqlistA {A R ls1 ls2} {qA : quotation_of A} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@SetoidList.eqlistA A R ls1 ls2).
Proof.
  revert ls2; induction ls1 as [|a ls1 IH], ls2 as [|b ls2].
  all: try solve [ intro pf; exfalso; inversion pf ].
  all: adjust_ground_quotable_by_econstructor_inversion ().
Defined.
(*
#[export] Instance quote_PermutationA : ground_quotable PermutationA := ltac:(destruct 1; exact _). : list A -> list A -> Prop :=
 *)
(*
#[export] Instance quote_memo_val : ground_quotable memo_val := ltac:(destruct 1; exact _). {A : nat -> Type} : Type :=
Co#[export] Instance quote_Stream : ground_quotable Stream := ltac:(destruct 1; exact _). (A : Type) :=
Co#[export] Instance quote_EqSt : ground_quotable EqSt := ltac:(destruct 1; exact _). (s1 s2: Stream) : Prop :=
#[export] Instance quote_Exists : ground_quotable Exists := ltac:(destruct 1; exact _). : Stream -> Prop :=
#[export] Instance quote_Exists : ground_quotable Exists := ltac:(destruct 1; exact _). ( x: Stream ) : Prop :=
Co#[export] Instance quote_ForAll : ground_quotable ForAll := ltac:(destruct 1; exact _). (x: Stream) : Prop :=
*)

Definition list_eq_nil_dec_r {A} {l : list A} : {l = []} + {l <> []}.
Proof. destruct l; [ left | right ]; try reflexivity; congruence. Defined.
Definition list_eq_nil_dec_l {A} {l : list A} : {[] = l} + {[] <> l}.
Proof. destruct l; [ left | right ]; try reflexivity; congruence. Defined.
#[export] Instance quote_list_neq_nil_r {A} {qA : quotation_of A} (l : list A) {ql : quotation_of l} : ground_quotable (l <> [])
  := ground_quotable_neg_of_dec list_eq_nil_dec_r.
#[export] Instance quote_list_neq_nil_l {A} {qA : quotation_of A} (l : list A) {ql : quotation_of l} : ground_quotable ([] <> l)
  := ground_quotable_neg_of_dec list_eq_nil_dec_l.


Inductive vector {A : Type} : nat -> Type :=
| vnil : vector 0
| vcons : A -> forall {n'}, vector n' -> vector (S n').

Arguments vector A : clear implicits.

Require Import Coq.Program.Program.

Program Definition head {A : Type} {n : nat} (v : vector A (S n)) : vector A n :=
  match v with
    | vnil => !
    | vcons a v' => v'
  end.

Fixpoint app {A : Type} {n m : nat} (v : vector A n) (w : vector A m) : vector A (n + m) :=
  match v in vector _ n return vector A (n + m) with
    | vnil => w
    | vcons a v' => vcons a (app v' w)
  end.

(* Test sharing information between different hypotheses *)

Parameters (a:_) (b:a=0).

(* These examples were failing due to a lifting wrongly taking let-in into account *)

Definition foo6 (x:=1) : forall {n:nat}, n=n := fun n => eq_refl.

Fixpoint foo7 (x:=1) (n:nat) {p:nat} {struct n} : nat.

(* Some example which should succeed with local implicit arguments *)

Inductive A {P:forall m {n}, n=m -> Prop} := C : P 0 eq_refl -> A.
Inductive B (P:forall m {n}, n=m -> Prop) := D : P 0 eq_refl -> B P.


Require Import List.
Require Import MirrorCore.ExprI.

Set Implicit Arguments.
Set Strict Implicit.

Section with_expr.
  Variable typ : Type.
  Variable typD : list Type -> typ -> Type.
  Variable expr : Type.
  Variable Expr_expr : Expr typD expr.

  Class ExprOps : Type :=
  { mentionsV : nat -> expr -> bool
  ; mentionsU : nat -> expr -> bool
  ; replace : (nat -> expr) -> (nat -> expr) -> expr -> expr
  }.
(*
Section substitute.
  Context {ts : types}.

  Fixpoint exprSubstVar (l : nat) (v : nat) (e' : expr ts) (e : expr ts) : expr ts :=
    match e with
      | Const _ _ => e
      | UVar _ => e
      | Func _ _ => e
      | App e es => App (exprSubstVar l v e' e) (map (exprSubstVar l v e') es)
      | Abs t e => Abs t (exprSubstVar (S l) v e' e)
      | Var v' =>
        match Compare_dec.nat_compare v v' with
          | Eq => lift 0 l e'
          | Lt => Var (v' - 1)
          | Gt => Var v'
        end
      | Equal t e1 e2 => Equal t (exprSubstVar l v e' e1) (exprSubstVar l v e' e2)
      | Not e => Not (exprSubstVar l v e' e)
    end.

End substitute.
*)


Require Import VerdiRaft.Raft.

Section MatchIndexLeader.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition match_index_leader net :=
    forall leader,
      type (nwState net leader) = Leader ->
      assoc_default name_eq_dec (matchIndex (nwState net leader)) leader 0 =
      maxIndex (log (nwState net leader)).

  Class match_index_leader_interface : Prop :=
    {
      match_index_leader_invariant :
        forall net,
          raft_intermediate_reachable net ->
          match_index_leader net
    }.

End MatchIndexLeader.


  (***************************************************************)
  (*   This file is part of the static analyses developement -   *)
  (*   specification of kildall's algorithm, and proof it is a   *)
  (*   bytecode verifier -                                       *)
  (*							         *)
  (*   File : itera_property.v			                 *)
  (*   Authors : S. Coupet-Grimal, W. Delobel 		         *)
  (*   Content : properties of function iterate needed to        *)
  (*	       establish that Kildall's algorithm is a dfa       *)
  (***************************************************************)

Unset Standard Proposition Elimination Names.

Section itera_property.

  Require Export itera_eq.
  Require Export propa_property2.

  Variable Sigma : Set. (* state set *)
  Variable n : nat. (* bytecode size *)
  Variable succs : forall p:nat, p<n -> nb_list n. (* successor function *)
  Variable step : forall p:nat, p<n->Sigma->list Sigma. (* flow function *)
  Variable wi : vector Sigma n-> nat -> Prop. (* correct state for instruction predicate *)
  Variable r : relation Sigma. (* order on state set *)
  Variable T : Sigma. 		(* Top element *)
  Variable sup : binop Sigma. (* sup on state set *)

  Hypothesis step_succs_same_length : forall (q:nat) (C:q<n) (s : Sigma),
    nb_length (succs q C) = length (step q C s).
  Hypothesis eq_Sigma_dec : forall x y : Sigma, {x = y} + {x <> y}.
  Hypothesis r_is_semilattice : semilattice Sigma r sup.
  Hypothesis wfr : ascending_chain r.
  Hypothesis succs_equiv : forall (p : nat) (C C' : p<n),
    (succs p C) =nb= (succs p C').
  Hypothesis step_equiv : forall (p:nat) (C C' : p<n) (s:Sigma),
    (step p C s) = (step p C' s).

  Notation Step' := (step' Sigma n succs step step_succs_same_length).

  Notation Propa := (propagate sup eq_Sigma_dec).
  Notation Itera := (itera Sigma n succs step r sup step_succs_same_length
    eq_Sigma_dec r_is_semilattice wfr).
  Notation Itera_eq := (itera_eq succs step_succs_same_length
    eq_Sigma_dec r_is_semilattice wfr).
  Notation Propa_nondep_lexprod := (propa_nondep_lexprod Sigma n succs step
    r sup step_succs_same_length eq_Sigma_dec r_is_semilattice).
  Notation ra := (SI_vector_pointwise Sigma r).
  Notation Acc_ssw := (acc_ssw Sigma n r eq_Sigma_dec wfr).

  Lemma iter_preserves_stable :
    forall (x : vector Sigma n * nb_list n),
      (forall (p : nat) (C : p < n),
        ~ p INnb (snd x) ->
        stable Sigma n succs step r step_succs_same_length (fst x) p C) ->
      stables Sigma n succs step r step_succs_same_length (Itera x).
  Proof.
    intro x.
    elim (Acc_ssw x).
    clear x.
    intros x Hrec.
    destruct x as [ss w].
    destruct w.
    cut (Itera (ss, pred_nil (P n)) = ss).
    simpl; intros Heq H Hstable.
    intros p C; rewrite <- Heq in Hstable.
    apply Hstable.
    unfold not; trivial.
    generalize (Itera_eq (ss, pred_nil (P n))); trivial.
        (* w "=" a "::" w *)
    intros H Hstable.
    intros p0 C0; cut (stable  Sigma n succs step r
      step_succs_same_length (Itera (Propa ss w (Step' a p (ss[a|p])))) p0 C0).
    replace (Itera (Propa ss w (Step' a p (ss[a|p]))))
      with (Itera (ss, pred_cons (P n) a p w)).
    trivial.
    generalize (Itera_eq (ss, pred_cons (P n) a p w)); trivial.
    cut (nondep_lexprod (vector Sigma n) (nb_list n)
      (SI_vector_pointwise Sigma r n) (rb n)
      (Propa ss w (Step' a p (ss[a|p]))) (ss, pred_cons (P n)a p w));
    [intro Hpropa | apply (propa_nondep_lexprod Sigma n succs step r sup
      step_succs_same_length eq_Sigma_dec r_is_semilattice ss a w p); trivial].
    cut ((forall (p' : nat) (C' : p' < n),
      ~ p' INp (snd (Propa ss w (Step' a p (ss[a|p])))) ->
      stable Sigma n succs step r step_succs_same_length (fst (Propa
        ss w (Step' a p (ss[a|p])))) p' C')); [intro Hstab | idtac].
    apply (H (Propa ss w (Step' a p (ss[a|p]))) Hpropa Hstab p0 C0); auto.
    (intros p' C' H').
    compare p' a; intro e.
    (*p' = a*)
    subst a.
    unfold stable.
    intros q t H0.
    apply (stable_p_by_propa Sigma n succs step r sup
      step_succs_same_length eq_Sigma_dec  r_is_semilattice p' q (ss[p'|p]) t ss w p); trivial.
    rewrite (no_change_at_p_not_in_w Sigma n r sup eq_Sigma_dec r_is_semilattice) in H0; trivial.
    generalize H0.
    rewrite (element_at_irrel Sigma n ss p' C' p).
    unfold m_list_belong; apply pred_list_equiv_belong.
    unfold step'; apply m_list_equiv_combine.
    apply (succs_equiv p' C' p).
    apply step_equiv.
    (* p' <> a *)
    inversion_clear r_is_semilattice as [O LC].
    inversion_clear O.
    intros q t H0.
    cut ((q,t) INm (Step' p' C' ((fst (ss, pred_cons (P n) a p w))[p'|C']))).
    intro H1.
    apply ord_trans with (y := (fst (ss, pred_cons (P n) a p w))[q|
      (m_list_get_witness
        (Step' p' C' ((fst (ss, pred_cons (P n) a p w))[p'|C'])) (q, t) H1)]).
    apply Hstable.
    intro h; elim h.
    apply e.
    intro; apply H'.
    apply inc_w_propa_w.
    assumption.
    generalize H0 H1 (r_ss_propa_ss Sigma n r sup eq_Sigma_dec
      r_is_semilattice (Step' a p (ss[a|p]))
      q (fst (ss, pred_cons (P n) a p w)) w
      (m_list_get_witness
        (Step' p' C' ((fst (ss, pred_cons (P n) a p w))[p'|C']))
        (q, t) H1)).
    simpl.
    destruct (Propa ss w (Step' a p (ss[a|p]))); simpl.
    clear H0 H1.
    intros H0 H1.
    generalize (m_list_get_witness (Step' p' C' (ss[p'|C'])) (q, t) H1).
    intros Cq H'0.
    rewrite <- (element_at_irrel Sigma n v q Cq (m_list_get_witness
      (Step' p' C' (v[p'|C'])) (q, t) H0)); assumption.
    rewrite (no_change_at_p_not_in_w Sigma n r sup eq_Sigma_dec) in H0; auto.
  Qed.

  Remark transition :
    forall (ss : vector Sigma n) (a : nat) (w : nb_list n) (C : a < n),
      let PSS := (Propa ss w (Step' a C (ss[a|C]))) in
        let IPSS := (Itera PSS) in
          ra n (fst PSS) (fst (ss, pred_cons (P n) a C w)) \/
          (fst PSS = fst (ss, pred_cons (P n) a C w))  ->
          ra n IPSS (fst PSS) \/ (IPSS = (fst PSS))
          -> ra n IPSS (fst (ss, pred_cons (P n) a C w)) \/
          IPSS=(fst (ss, pred_cons (P n) a C w)).
  Proof.
    intros.
    inversion_clear r_is_semilattice as [O LC].
    inversion O.
    case H; case H0; intros.
    left.
    generalize H1 H2.
    generalize (fst (ss, pred_cons (P n) a C w)); generalize (fst PSS);
      generalize IPSS.
    apply transitive_SI_vector_pointwise; try assumption.
    left.
    rewrite H1.
    assumption.
    left.
    rewrite <- H2.
    assumption.
    right.
    rewrite  H1.
    assumption.
  Qed.

  Lemma iter_decrease :
    forall (x : vector Sigma n * nb_list n),
      ra n (Itera x) (fst x) \/ Itera x = fst x.
  Proof.
    intro x.
    generalize (Acc_ssw x).
    intro Hacc; elim Hacc; clear Hacc x.
    intros x H Hrec.
    generalize (Itera_eq x).
    CaseEq x.
    intros ss' w'.
    case w'.
    simpl; intros Heq1 Heq2.
    right; trivial.
    intros a Ca wa ex Heq.
    rewrite <- ex.
    replace (Itera x) with (Itera (Propa ss' wa (Step' a Ca (ss'[a|Ca])))).
    subst x; apply transition.
    apply (propa_decrease Sigma n succs step r sup step_succs_same_length
      eq_Sigma_dec r_is_semilattice ss' a wa Ca).
    apply Hrec.
    apply (Propa_nondep_lexprod ss' a wa Ca).
    subst x; symmetry; trivial.
  Qed.

  Lemma iter_lub :
    forall (x:vector Sigma n * nb_list n) (ts:vector Sigma n),
      (monotonestep Sigma n step r)->
      (ra n ts (fst x) \/ ts = fst x) /\
      stables Sigma n succs step r step_succs_same_length ts ->
      ra n ts (Itera x) \/ ts = Itera x.
  Proof.
    intro x.
    generalize (Acc_ssw x).
    intro Hacc; elim Hacc; clear Hacc x.
    intros x H Hrec.
    generalize (Itera_eq x).
    CaseEq x.
    intros ss w.
    case w.
    simpl; intros eq H' ts monostep H''.
    cut (ra n ts ss \/ ts = ss);
      [intro H'''; rewrite <- H' in H'''; trivial | idtac].
    elim H''; trivial.
    intros a Ca wa ex Heq ts monostep H'.
    cut (ra n ts (Itera (Propa ss wa (Step' a Ca (ss[a|Ca])))) \/
      ts = Itera (Propa ss wa (Step' a Ca (ss[a|Ca]))));
    [intro H'''; rewrite <- Heq in H'''; trivial | idtac].
    apply Hrec; auto.
    rewrite ex.
    apply (Propa_nondep_lexprod ss a wa Ca).
    inversion_clear H' as [H0 H1].
    split; auto.
    inversion r_is_semilattice as [O LC]; inversion O.
    apply vector_pointwise_imp_SI_vector_pointwise_or_eq; try assumption.
    apply forall_element_to_vector_pointwise.
    intros q Cq.
    apply (r_propa_ss_ts Sigma n succs step r sup step_succs_same_length eq_Sigma_dec r_is_semilattice); auto.
  Qed.

  Theorem Theorem_iter :
    forall (x : vector Sigma n * nb_list n),
      ascending_chain r ->
      (monotonestep Sigma n step r)->
      (forall (p : nat) (C : p < n),
        ~ p INnb (snd x) ->
        stable Sigma n succs step r step_succs_same_length (fst x) p C) ->
      stables Sigma n succs step r step_succs_same_length (Itera x) /\
      vector_pointwise Sigma r n (fst x) (Itera x) /\
      (forall ts : vector Sigma n,
        vector_pointwise Sigma r n (fst x) ts /\
        stables Sigma n succs step r step_succs_same_length ts ->
        vector_pointwise Sigma r n (Itera x) ts).
  Proof.
    Semi r_is_semilattice.
    intro x; CaseEq x.
    intros ss w; intros eq asc_r monostep H'.
    split.
    apply (iter_preserves_stable (ss, w)); assumption.
    split.
    apply  SI_vector_pointwise_or_eq_imp_vector_pointwise; try assumption.
    apply (iter_decrease (ss,w)).
    intros ts H''.
    apply  SI_vector_pointwise_or_eq_imp_vector_pointwise; try assumption.
    apply (iter_lub (ss,w) ts).
    assumption.
    split.
    inversion H'' as [h h'].
    apply (vector_pointwise_imp_SI_vector_pointwise_or_eq Sigma r n ts (fst (ss,w))); try assumption.
    elim H''; trivial.
  Qed.

End itera_property.


(** Interface file to the package SubstitutionSystems *)

(**
  The purpose of this file is to provide a stable interface to
  the formalization of heterogeneous substitution systems as
  defined by Matthes and Uustalu

    version for simplified notion of HSS by Ralph Matthes (2022, 2023)
    the file is very close to the homonymous file in the parent directory
    basically, the changes in SimplifiedHSS.SubstitutionSystems are propagated

    WARNING: the last part of the previous development is commented out since
    SimplifiedHSS.Lam is an incomplete adaptation

*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.PointedFunctors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.PointedFunctorsComposition.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.BinSumOfSignatures.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems.
Require Import UniMath.SubstitutionSystems.GenMendlerIteration.
Require Import UniMath.CategoryTheory.RightKanExtension.
Require Import UniMath.SubstitutionSystems.GenMendlerIteration.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems.
Require Import UniMath.SubstitutionSystems.LamSignature.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.Lam.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.

Notation "⦃ f ⦄_{ Z }" := (fbracket _ Z f)(at level 0).
Notation "G • F" := (functor_composite F G).

(** * Generalized Iteration in Mendler-style and fusion law *)

(** Lemma 8 *)

Definition GenMendlerIteration :
   ∏ (C : category) (F : functor C C)
   (μF_Initial : Initial (FunctorAlg F)) (C' : category)
   (X : C') (L : functor C C'),
   is_left_adjoint L
   → ∏ ψ : ψ_source C C' X L ⟹ ψ_target C F C' X L,
     ∃! h : C' ⟦ L ` (InitialObject μF_Initial), X ⟧,
     # L (alg_map F (InitialObject μF_Initial)) · h =
     ψ ` (InitialObject μF_Initial) h.
Proof.
  simpl.
  apply GenMendlerIteration.
Defined.

Arguments It {_ _} _ {_} _ _ _ _.

(** Lemma 9 *)

Theorem fusion_law
     : ∏ (C : category)
       (F : functor C C)
       (μF_Initial : Initial (category_FunctorAlg F))
       (C' : category)
       (X X' : C') (L : functor C C')
       (is_left_adj_L : is_left_adjoint L)
       (ψ : ψ_source C C' X L ⟹ ψ_target C F C' X L)
       (L' : functor C C')
       (is_left_adj_L' : is_left_adjoint L')
       (ψ' : ψ_source C C' X' L' ⟹ ψ_target C F C' X' L')
       (Φ : yoneda_objects C' X • functor_opp L
              ⟹
            yoneda_objects C' X' • functor_opp L'),
       let T:= (` (InitialObject μF_Initial)) in
       ψ T · Φ (F T) = Φ T · ψ' T
       →
       Φ T (It μF_Initial X L is_left_adj_L ψ) =
       It μF_Initial X' L' is_left_adj_L' ψ'.
Proof.
  apply fusion_law.
Qed.

(** * Heterogeneous Substitution Systems *)

(** Lemma 15 *)

Lemma fbracket_natural
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Presignature C C C) (T : hss CP H) (Z Z' : category_Ptd C)
       (f : category_Ptd C ⟦ Z, Z' ⟧)
       (g : [C,C] ⟦ U Z', `T ⟧),
       (`T ∘ # U f : [C, C] ⟦ `T • U Z , `T • U Z' ⟧) · ⦃g⦄_{Z'} = ⦃#U f · g⦄_{Z} .
Proof.
  apply fbracket_natural.
Qed.

Lemma compute_fbracket
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Presignature C C C) (T : hss CP H) (Z : category_Ptd C)
       (f : category_Ptd C ⟦ Z, ptd_from_alg T ⟧),
       ⦃#U f⦄_{Z} = (`T ∘ # U f : [C, C] ⟦ `T • U Z , `T • U _ ⟧) · ⦃ identity (U (ptd_from_alg T)) ⦄_{ptd_from_alg T}.
Proof.
  apply compute_fbracket.
Qed.

(** * Monads from hss *)

(** Theorem 24 *)

Definition Monad_from_hss
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Signature C C C), hss CP H → Monad C.
Proof.
  apply Monad_from_hss.
Defined.

(** Theorem 25 *)

Definition hss_to_monad_functor
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Signature C C C),
       functor (hss_precategory CP H) (category_Monad C).
Proof.
  apply hss_to_monad_functor.
Defined.

(** Lemma 26 *)

Lemma faithful_hss_to_monad
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Signature C C C), faithful (hss_to_monad_functor C CP H).
Proof.
  apply faithful_hss_to_monad.
Defined.

(** * Lifting initiality *)

(** Theorem 28 in three steps:
    - the operation itself
    - its compatibility with variables
    - its compatibility with signature-dependent constructions
*)

Definition bracket_for_initial_algebra
 : ∏ (C : category) (CP : BinCoproducts C),
     (∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C)
       → ∏ (H : Presignature C C C)
           (IA : Initial (FunctorAlg (Id_H C CP H)))
           (Z : category_Ptd C),
           [C, C] ⟦ U Z, U (ptd_from_alg (InitAlg C CP H IA)) ⟧
           →
           [C, C] ⟦ ℓ (U Z) ` (InitialObject IA), ` (InitAlg C CP H IA) ⟧.
Proof.
  apply bracket_Thm15.
Defined.

Lemma bracket_Thm15_ok_η
     : ∏ (C : category) (CP : BinCoproducts C)
       (KanExt : ∏ Z : category_Ptd C,
                 GlobalRightKanExtensionExists C C (U Z) C)
       (H : Presignature C C C)
       (IA : Initial (FunctorAlg (Id_H C CP H)))
       (Z : category_Ptd C)
       (f : [C,C] ⟦ U Z, U (ptd_from_alg (InitAlg C CP H IA))⟧),
       f =
       # (pr1 (ℓ (U Z))) (η (InitAlg C CP H IA)) ·
       bracket_Thm15 C CP KanExt H IA Z f.
Proof.
  apply bracket_Thm15_ok_part1.
Qed.

Lemma bracket_Thm15_ok_τ
  : ∏ (C : category) (CP : BinCoproducts C)
      (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C)
      (H : Presignature C C C)
      (IA : Initial (FunctorAlg (Id_H C CP H)))
      (Z : category_Ptd C)
      (f : [C,C] ⟦ U Z, U (ptd_from_alg (InitAlg C CP H IA)) ⟧),
    (theta H) (` (InitAlg C CP H IA) ⊗ Z) ·
    # H (bracket_Thm15 C CP KanExt H IA Z f) ·
    τ (InitAlg C CP H IA)
    =
    # (pr1 (ℓ (U Z))) (τ (InitAlg C CP H IA)) ·
      bracket_Thm15 C CP KanExt H IA Z f.
Proof.
  apply bracket_Thm15_ok_part2.
Qed.

(** Theorem 29 *)

Definition Initial_HSS :
   ∏ (C : category) (CP : BinCoproducts C),
     (∏ Z : category_Ptd C,
         GlobalRightKanExtensionExists C C (U Z) C)
     → ∏ H : Presignature C C C,
       Initial (FunctorAlg (Id_H C CP H))
       → Initial (hss_category CP H).
Proof.
  apply InitialHSS.
Defined.

(** * Sum of signatures *)

(** Lemma 30 *)

Definition Sum_of_Signatures
  : ∏ (C D D': category),
       BinCoproducts D → Signature C D D' → Signature C D D' → Signature C D D'.
Proof.
  apply BinSum_of_Signatures.
Defined.

(** * Arities of signatures for lambda calculus *)

(** Definition 31 *)

Definition App_Sig
  : ∏ (C : category), BinProducts C → Signature C C C.
Proof.
  apply App_Sig.
Defined.

(** Definition 32 *)

Definition Lam_Sig
  : ∏ (C : category),
    Terminal C → BinCoproducts C → BinProducts C → Signature C C C.
Proof.
  apply Lam_Sig.
Defined.

(** Definition 33 *)

Definition Flat_Sig
  : ∏ (C : category), Signature C C C.
Proof.
  apply Flat_Sig.
Defined.

(** * Evaluation of explicit substitution as initial morphism *)

(** this part not compatible with current modifications to the notion of hss

(** Definition 36 *)

Definition Lam_Flatten
  :  ∏ (C : category) (terminal : Terminal C)
       (CC : BinCoproducts C) (CP : BinProducts C),
    (∏ Z : category_Ptd C,
        GlobalRightKanExtensionExists C C (U Z) C)
    → ∏ Lam_Initial : Initial (FunctorAlg (Id_H C CC (Lam_Sig C terminal CC CP))),
  [C, C] ⟦ (Flat_H C) ` (InitialObject Lam_Initial), ` (InitialObject Lam_Initial) ⟧.
Proof.
  apply Lam_Flatten.
Defined.

(** Lemma 37, construction of the bracket *)

Definition fbracket_for_LamE_algebra_on_Lam
  : ∏ (C : category) (terminal : Terminal C)
      (CC : BinCoproducts C) (CP : BinProducts C)
      (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C)
      (Lam_Initial : Initial (FunctorAlg (Id_H C CC (Lam_Sig C terminal CC CP))))
      (Z : category_Ptd C),
    category_Ptd C ⟦ Z ,
                           (ptd_from_alg_functor CC (LamE_Sig C terminal CC CP))
                             (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial) ⟧
    → [C, C]
             ⟦ functor_composite (U Z)
                                 ` (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial),
               ` (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial) ⟧.
Proof.
  apply fbracket_for_LamE_algebra_on_Lam.
Defined.

(** Morphism from initial hss to construed hss, consequence of Lemma 37 *)

Definition EVAL
  : ∏ (C : category) (terminal : Terminal C)
      (CC : BinCoproducts C) (CP : BinProducts C)
      (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C)
       (Lam_Initial : Initial
                        (FunctorAlg
                           (Id_H C CC
                              (LamSignature.Lam_Sig C terminal CC CP))))
       (LamE_Initial : Initial
                         (FunctorAlg
                            (Id_H C CC (LamE_Sig C terminal CC CP)))),
       hss_category CC (LamE_Sig C terminal CC CP)
                       ⟦ InitialObject
                           (LamEHSS_Initial C terminal CC CP KanExt LamE_Initial),
                         LamE_model_on_Lam C terminal CC CP KanExt Lam_Initial ⟧.
Proof.
  apply FLATTEN.
Defined.

*)


(*
This is the last file which concludes that the bicategory of univalent monoidal categories is again univalent.
In this file we conclude that both the bicategory of univalent monoidal categories with lax monoidal functors, denoted by UMONCAT, is univalent
and that the result still holds when we replace lax by strong monoidal functors, we denote this bicategory by UMONCAT_strong.
*)

Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.TensorLayer.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.UnitLayer.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.TensorUnitLayer.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.AssociatorUnitorsLayer.

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell.
Require Import UniMath.Bicategories.Core.Univalence.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Import Bicat.Notations.

Import AssociatorUnitorsNotations.

Local Definition bicat_univlaxmon_noprop : bicat := total_bicat disp_tensor_unit_unitors_associator.

Section MonoidalCategoryLayer.

  Definition P_triangle_pentagon : bicat_univlaxmon_noprop -> UU
    :=  λ C,
        triangle_pentagon (pr2 (assunitors_from_layer (uc (pr1 C,, pr12 C))  (pr2 C))).

  Definition P_assinv : bicat_univlaxmon_noprop -> UU
    :=  λ C,
        associator_invertible (pr2 (assunitors_from_layer (pr1 C)  (pr2 C))).

   Definition P_luinv : bicat_univlaxmon_noprop -> UU
    :=  λ C,
        lunitor_invertible (pr2 (assunitors_from_layer (pr1 C)  (pr2 C))).
    Definition P_ruinv : bicat_univlaxmon_noprop -> UU
    :=  λ C,
        runitor_invertible (pr2 (assunitors_from_layer (pr1 C)  (pr2 C))).

  Definition P_inv : bicat_univlaxmon_noprop -> UU
    := λ C, P_assinv C × P_luinv C × P_ruinv C.

  Definition P_prop : bicat_univlaxmon_noprop -> UU
    := λ C, P_triangle_pentagon C × P_inv C.

  Lemma isaprop_P_prop (C : bicat_univlaxmon_noprop) : isaprop (P_prop C).
  Proof.
    repeat (apply isapropdirprod).
    - apply isaprop_triangle.
    - apply isaprop_pentagon.
    - apply isaprop_associator_invertible.
    - apply isaprop_lunitor_invertible.
    - apply isaprop_runitor_invertible.
  Qed.

  Definition disp_bicat_univmon : disp_bicat bicat_univlaxmon_noprop
    := disp_fullsubbicat bicat_univlaxmon_noprop P_prop.

  Lemma disp_bicat_tripent_is_univalent_2 : disp_univalent_2 disp_bicat_univmon.
  Proof.
    split.
    - apply disp_univalent_2_0_fullsubbicat.
      + apply bidisp_assunitors_is_univalent_2.
      + intro ; apply isaprop_P_prop.
    - apply disp_fullsubbicat_univalent_2_1.
  Qed.

  Definition disp_univmon : disp_bicat bicat_of_univ_cats
    := sigma_bicat _ _ disp_bicat_univmon.

  Definition disp_univmon_is_univalent_2
    : disp_univalent_2 disp_univmon.
  Proof.
    apply sigma_disp_univalent_2_with_props.
    - apply univalent_cat_is_univalent_2.
    - apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop.
    - apply disp_2cells_isaprop_fullsubbicat.
    - apply disp_tensor_unit_unitors_associator_is_disp_univalent_2.
    - apply disp_fullsubbicat_univalent_2_1.
    - apply disp_tensor_unit_unitors_associator_disp_locally_groupoid.
    - apply disp_locally_groupoid_fullsubbicat.
    - apply disp_tensor_unit_unitors_associator_is_disp_univalent_2.
    - apply disp_bicat_tripent_is_univalent_2.
  Qed.

  Lemma disp_univmon_disp_2cells_isaprop :  disp_2cells_isaprop disp_univmon.
  Proof.
    apply disp_2cells_isaprop_sigma.
    + apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop.
    + apply disp_2cells_isaprop_fullsubbicat.
  Qed.

  Lemma disp_univmon_disp_locally_groupoid :  disp_locally_groupoid disp_univmon.
  Proof.
    apply disp_locally_groupoid_sigma.
    - apply univalent_cat_is_univalent_2.
    - apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop.
    - apply disp_2cells_isaprop_fullsubbicat.
    - apply disp_tensor_unit_unitors_associator_disp_locally_groupoid.
    - apply disp_locally_groupoid_fullsubbicat.
  Qed.

  (* UMONCAT is the bicategory defined as follows:
     - Objects: Monoidal categories (over univalent categories).
     - Morphisms: Lax monoidal functors.
     - 2-cells: Monoidal natural transformations.

     This bicategory is constructed precisely such that
     we are able to carry out a modular proof of univalence,
     as seen in UMONCAT_is_univalent_2.
   *)
  Definition UMONCAT : bicat := total_bicat disp_univmon.

  Definition UMONCAT_is_univalent_2 : is_univalent_2 UMONCAT.
  Proof.
    apply total_is_univalent_2.
    - apply disp_univmon_is_univalent_2.
    - apply univalent_cat_is_univalent_2.
  Qed.

  Definition UMONCAT_category (C : UMONCAT) : univalent_category := pr1 C.

  Definition UMONCAT_tensorunit (C : UMONCAT) : tensor_unit (UMONCAT_category C)
    := (pr112 C).
  Definition UMONCAT_tensor (C : UMONCAT) : tensor (UMONCAT_category C)
    := pr1 (UMONCAT_tensorunit C).
  Definition UMONCAT_unit (C : UMONCAT) : UMONCAT_category C
    := pr2 (UMONCAT_tensorunit C).

  Definition UMONCAT_lunitor (C : UMONCAT) : CurriedMonoidalCategories.lunitor (UMONCAT_tensorunit C)
    := pr11 (pr212 C).
  Definition UMONCAT_runitor (C : UMONCAT) : CurriedMonoidalCategories.runitor (UMONCAT_tensorunit C)
    := (pr21 (pr212 C)).
  Definition UMONCAT_associator (C : UMONCAT) : CurriedMonoidalCategories.associator (UMONCAT_tensorunit C)
    := (pr2 (pr212 C)).
  Definition UMONCAT_unitorsassociator (C : UMONCAT)
    : unitors_associator (UMONCAT_tensorunit C)
    := UMONCAT_lunitor C ,, UMONCAT_runitor C ,, UMONCAT_associator C.

  Definition UMONCAT_functor {C D : UMONCAT} (F : UMONCAT⟦C,D⟧)
    : functor (UMONCAT_category C) (UMONCAT_category D)
    := pr1 F.

  Definition UMONCAT_functortensorunit {C D : UMONCAT} (F : UMONCAT⟦C,D⟧)
    : functor_tensor_unit (UMONCAT_tensorunit C) (UMONCAT_tensorunit D) (UMONCAT_functor F)
    := (pr112 F).

  Definition UMONCAT_functortensor {C D : UMONCAT} (F : UMONCAT⟦C,D⟧)
    : preserves_tensor (UMONCAT_tensor C) (UMONCAT_tensor D) (UMONCAT_functor F)
    := pr1 (UMONCAT_functortensorunit F).

  Definition UMONCAT_functorunit {C D : UMONCAT} (F : UMONCAT⟦C,D⟧)
    : preserves_unit (UMONCAT_unit C) (UMONCAT_unit D) (UMONCAT_functor F)
    := pr2 (UMONCAT_functortensorunit F).

  Definition UMONCAT_functorlunitor {C D : UMONCAT} (F : UMONCAT⟦C,D⟧)
    : preserves_lunitor (UMONCAT_functortensorunit F) (UMONCAT_lunitor C) (UMONCAT_lunitor D)
    :=  pr11 (pr212 F).
  Definition UMONCAT_functorrunitor {C D : UMONCAT} (F : UMONCAT⟦C,D⟧)
    : preserves_runitor (UMONCAT_functortensorunit F) (UMONCAT_runitor C) (UMONCAT_runitor D)
    := pr21 (pr212 F).
  Definition UMONCAT_functorassociator {C D : UMONCAT} (F : UMONCAT⟦C,D⟧)
    : preserves_associator (UMONCAT_functortensorunit F) (UMONCAT_associator C) (UMONCAT_associator D)
    := pr2 (pr212 F).

  Definition UMONCAT_functorunitorsassociator {C D : UMONCAT} (F : UMONCAT⟦C,D⟧)
    : functor_unitors_associator (UMONCAT_unitorsassociator C) (UMONCAT_unitorsassociator D) (UMONCAT_functortensorunit F)
    := UMONCAT_functorlunitor F ,, UMONCAT_functorrunitor F ,, UMONCAT_functorassociator F.

End MonoidalCategoryLayer.

Module UMONCAT_Notations.

  Notation "cat( C )" := (UMONCAT_category C).
  Notation "tensor( C )" := (UMONCAT_tensor C).
  Notation "unit( C )" := (UMONCAT_unit C).
  Notation "lunitor( C )" := (UMONCAT_lunitor C).
  Notation "runitor( C )" := (UMONCAT_runitor C).
  Notation "associator( C )" := (UMONCAT_associator C).

  Notation "functor( F )" := (UMONCAT_functor F).
  Notation "functortensorunit( F )" := (UMONCAT_functortensorunit F).
  Notation "functortensor( F )" := (UMONCAT_functortensor F).
  Notation "functorunit( F )" := (UMONCAT_functorunit F).
  Notation "functorunitorsassociator( F )" := (UMONCAT_functorunitorsassociator F).
  Notation "functorlunitor( F )" := (UMONCAT_functorlunitor F).
  Notation "functorrunitor( F )" := (UMONCAT_functorrunitor F).
  Notation "functorassociator( F )" := (UMONCAT_functorassociator F).

End UMONCAT_Notations.

Section StrongLayer.

  Import UMONCAT_Notations.
  Import Bicat.Notations.

  Definition P_strong_preserving : ∏ (C D : UMONCAT), UMONCAT⟦C,D⟧ -> UU
    := λ _ _ F, functor_strong functorunitorsassociator(F).

  Lemma isaprop_P_strong_preserving {C D : UMONCAT} (F : UMONCAT⟦C,D⟧)
    : isaprop (P_strong_preserving C D F).
  Proof.
    apply isapropdirprod.
    - apply isaprop_is_z_isomorphism.
    - repeat (apply impred_isaprop ; intro).
      apply isaprop_is_z_isomorphism.
  Qed.

  Definition Pid_strong_preserving :
    ∏ (C : UMONCAT), P_strong_preserving _ _ (id₁ C).
  Proof.
    intro C.
    use tpair.
    - apply identity_is_z_iso.
    - intro ; intro.
      apply identity_is_z_iso.
  Defined.

  Definition Pcomp_strong_preserving :
    ∏ (C D E : UMONCAT) (F : UMONCAT⟦C,D⟧) (G : UMONCAT⟦D,E⟧),
      P_strong_preserving _ _ F → P_strong_preserving _ _ G -> P_strong_preserving _ _ (F·G).
  Proof.
    intros C D E F G sF sG.
    use tpair.
    - apply is_z_isomorphism_comp.
      + apply sG.
      + apply functor_on_is_z_isomorphism.
        apply sF.
    - intro ; intro.
      apply is_z_isomorphism_comp.
      + apply sG.
      + simpl.
        apply functor_on_is_z_isomorphism.
        apply sF.
  Defined.

  Definition disp_bicat_univstrongfunctor : disp_bicat UMONCAT
    := disp_sub1cell_bicat UMONCAT P_strong_preserving Pid_strong_preserving Pcomp_strong_preserving.

  Definition disp_bicat_univstrongfunctor_is_univalent_2 : disp_univalent_2 disp_bicat_univstrongfunctor.
  Proof.
    apply disp_sub1cell_univalent_2.
    - apply UMONCAT_is_univalent_2.
    - intro ; intros.
      apply isaprop_P_strong_preserving.
  Qed.

  Definition disp_univstrongfunctor : disp_bicat bicat_of_univ_cats
    := sigma_bicat _ _ disp_bicat_univstrongfunctor.

  Lemma disp_univstrongfunctor_disp_2cells_isaprop : disp_2cells_isaprop disp_bicat_univstrongfunctor.
  Proof.
    apply disp_2cells_isaprop_sub1cell_bicat.
  Qed.

  Lemma disp_univstrongfunctor_disp_locally_groupoid : disp_locally_groupoid disp_bicat_univstrongfunctor.
  Proof.
    apply disp_locally_groupoid_sub1cell_bicat.
  Qed.

  Definition disp_univstrongfunctor_is_univalent_2
    : disp_univalent_2 disp_univstrongfunctor.
  Proof.
    apply sigma_disp_univalent_2_with_props ; try (apply disp_univmon_is_univalent_2).
    - apply univalent_cat_is_univalent_2.
    - apply disp_univmon_disp_2cells_isaprop.
    - apply disp_univstrongfunctor_disp_2cells_isaprop.
    - apply disp_sub1cell_univalent_2.
      + apply UMONCAT_is_univalent_2.
      + intro ; intros ; apply isaprop_P_strong_preserving.
    - apply disp_univmon_disp_locally_groupoid.
    - apply disp_univstrongfunctor_disp_locally_groupoid.
    - apply disp_bicat_univstrongfunctor_is_univalent_2.
  Qed.

  (* UMONCAT_strong is the bicategory defined as follows:
     - Objects: Monoidal categories (over univalent categories).
     - Morphisms: Strong monoidal functors (not requiring any functorial strength).
     - 2-cells: Monoidal natural transformations.

     This bicategory is constructed precisely such that
     we are able to carry out a modular proof of univalence,
     as seen in UMONCAT_strong_is_univalent_2.
   *)
  Definition UMONCAT_strong : bicat := total_bicat disp_univstrongfunctor.

  Definition UMONCAT_strong_is_univalent_2 : is_univalent_2 UMONCAT_strong.
  Proof.
    apply total_is_univalent_2.
    - apply disp_univstrongfunctor_is_univalent_2.
    - apply univalent_cat_is_univalent_2.
  Qed.

End StrongLayer.