Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype fingraph  finfun  finset.

Require Import misc.
Require Import regexp.

Set Implicit Arguments.

(** Finite automata. ***)
Section FA.

Variable char: finType.

(** Type of input sequences ***)
Definition word := misc.word char.

(** Deterministic finite automata. **)
Section DFA.

(** The type of deterministic finite automata. ***)
Record dfa : Type :=
  {
    dfa_state :> finType;
    dfa_s: dfa_state;
    dfa_fin: pred dfa_state;
    dfa_step: dfa_state -> char -> dfa_state
    }.

(** Acceptance on DFAs **)
Section Acceptance.

(** Assume some automaton **)
Variable A: dfa.

(** We define a run of w on the automaton A
   to be the list of states x_1 .. x_|w|
   traversed when following the edges labeled
   w_1 .. w_|w| starting in x. **)
Fixpoint dfa_run' (x: A) (w: word) : seq A :=
match w with
  | [::] => [::]
  | a::w => (dfa_step A x a) ::dfa_run' (dfa_step A x a) w
end.

(** A simplifying function for a "aux2" run
   (i.e. starting at s). **)
Definition dfa_run := [fun w => dfa_run' (dfa_s A) w].

(** Acceptance of w in x is defined as
   finality of the last state of a run of w on A
   starting in x. **)
Fixpoint dfa_accept x w :=
match w with
  | [::] => dfa_fin A x
  | a::w => dfa_accept (dfa_step A x a) w
end.

Lemma dfa_accept_cons x a w:
  a::w \in dfa_accept x = (w \in dfa_accept (dfa_step A x a)).
Proof. by rewrite -simpl_predE /=. Qed.

(** We define the language of the deterministic
   automaton, i.e. acceptance in the starting state. **)
Definition dfa_lang := [pred w | dfa_accept (dfa_s A) w].

(** take lemma. **)
Lemma dfa_run'_take x w n: take n (dfa_run' x w) = dfa_run' x (take n w).
Proof. elim: w x n => [|a w IHw] x n //.
case: n => [|n] //=. by rewrite IHw.
Qed.

(** rcons and cat lemmas. **)
Lemma dfa_run'_cat x w1 w2 :
  dfa_run' x (w1 ++ w2) = dfa_run' x w1 ++ dfa_run' (last x (dfa_run' x w1)) w2.
Proof. elim: w1 w2 x => [|a w1 IHw1] w2 x //.
simpl. by rewrite IHw1.
Qed.

(* slightly altered acceptance statement. *)
Lemma dfa_run_accept x w: last x (dfa_run' x w) \in dfa_fin A = (w \in dfa_accept x).
Proof. elim: w x => [|a w IHw] x //. by rewrite /= IHw. Qed.

End Acceptance.

End DFA.

Implicit Arguments Build_dfa [dfa_state].

(** Non-deterministic automata. **)
Section NFA.

(** The type of non-deterministic finite automata. ***)
Record nfa : Type :=
  {
    nfa_state :> finType;
    nfa_s: nfa_state;
    nfa_fin: pred nfa_state;
    nfa_step: nfa_state -> char -> pred nfa_state
    }.

(** Acceptance on non-deterministic automata. **)
Section Acceptance.

Variable A: nfa.

(** Non-deterministic acceptance. **)
Fixpoint nfa_accept (x: A) w :=
match w with
  | [::] => nfa_fin A x
  | a::w => [ exists y, (nfa_step A x a y) && nfa_accept y w ]
end.

(** We define the language of the non-deterministic
   automaton, i.e. acceptance in the starting state. **)
Definition nfa_lang := [pred w | nfa_accept (nfa_s A) w].

(** We define labeled paths over the non-deterministic step relation **)
Fixpoint nfa_run x (xs : seq A) (w: word) {struct xs} :=
match xs,w with
  | y :: xs', a::w' => nfa_step A x a y && nfa_run y xs' w'
  | [::]    , [::]  => true
  | _       , _     => false
end.

Lemma nfa_run_accept x w:
  reflect (exists2 xs, nfa_run x xs w & last x xs \in nfa_fin A)
          (nfa_accept x w).
Proof.
  elim: w x => [|a w IHw] x.
    case H: (nfa_accept x [::]); constructor.
      by exists [::].
    move => [[|y xs]] //.
    move: H => /= H _.
    by rewrite -topredE /= H.
  case H: nfa_accept => /=; constructor.
    move/existsP: H => [] y /andP [] H1 /IHw [] xs H2 H3.
    exists (y::xs) => //=.
    by rewrite H1 H2 /=.
  move => [[|y xs]] //= /andP [] H1 H2 H3.
  move/existsP: H => H.
  apply: H. exists y.
  rewrite H1 /=.
  apply/IHw.
  by exists xs.
Qed.

(** Helpful facts **)
Lemma nfa_accept_cat x w1 w2:
  nfa_accept x (w1 ++ w2) <->
  exists xs,
    nfa_run x xs w1
    && nfa_accept (last x xs) w2.
Proof. split.
  elim: w1 w2 x => [|a w1 IHw1] w2 x.
    simpl. exists [::]. simpl. exact: H.
  move/existsP => [] y /andP [] H0 /IHw1 [] ys /andP [] H1 H2.
  exists (y::ys) => /=. by rewrite H0 H1 H2.
elim: w1 w2 x => [|a w1 IHw1] w2 x; move => [] [|y ys] /andP [] H0 H1 //.
move: H0 => /= /andP [] H2 H3.
apply/existsP. exists y. rewrite H2 /=.
apply: IHw1.
exists ys. by rewrite H3 H1.
Qed.

End Acceptance.

End NFA.

Implicit Arguments Build_nfa [nfa_state].

(** We define the powerset construction to obtain
   a deterministic automaton from a non-deterministic one. **)
Section PowersetConstruction.

Variable A: nfa.

Definition nfa_to_dfa :=
  {| dfa_s := set1 (nfa_s A);
    dfa_fin := [ pred X: {set A} | [ exists x: A, (x \in X) && nfa_fin A x] ];
    dfa_step := [ fun X a => \bigcup_(x | x \in X) finset (nfa_step A x a) ]
   |}.

(** We prove that for every state x, the new automaton
   accepts at least the language of the given automaton
   when starting in a set containing x. **)
Lemma nfa_to_dfa_aux2 (x: A) w (X: nfa_to_dfa):
  x \in X -> nfa_accept A x w -> dfa_accept nfa_to_dfa X w.
Proof. move => H0.
  elim: w X x H0 => [|a w IHw] X x H0.
    (* [::] *)
    move => /= H1. apply/existsP. exists x.
    by rewrite H0 H1.
  (* a::w *)
  move => /= /existsP [] y /andP [] H1.
  apply (IHw).
  apply/bigcupP.
  exists x => //.
  by rewrite in_set.
Qed.

(** Next we prove that in any set of states X, for every word w,
   if the powerset automaton accepts w in X, there exists one
   representative state of that set in which the given automaton
   accepts w. **)
Lemma nfa_to_dfa_aux1 (X: nfa_to_dfa) w:
  dfa_accept nfa_to_dfa X w -> [ exists x, (x \in X) && nfa_accept A x w ].
Proof. elim: w X => [|a w IHw] X => //.
  move/IHw => /existsP [] y /andP [].
  rewrite /dfa_step /nfa_to_dfa.
  move/bigcupP => [] x H0. rewrite in_set => H1 H2 /=.
  apply/existsP. exists x. rewrite H0 /=.
  apply/existsP. exists y.
  by rewrite H1 H2.
Qed.

(** Finally, we prove that the language of the powerset
   automaton is exactly the language of the given
   automaton. **)
Lemma nfa_to_dfa_correct : nfa_lang A =i dfa_lang nfa_to_dfa.
Proof. move => w. apply/idP/idP => /=.
  apply: nfa_to_dfa_aux2. by apply/set1P.
by move/nfa_to_dfa_aux1 => /existsP [] x /andP [] /set1P ->.
Qed.

End PowersetConstruction.

(** Embedding deterministic automata in non-deterministic automata. **)
Section Embed.

Variable A: dfa.

Definition dfa_to_nfa : nfa :=
  {|
    nfa_s := dfa_s A;
    nfa_fin := dfa_fin A;
    nfa_step := fun x a y => y == dfa_step A x a
  |}.

(** We prove that dfa_to_nfa accepts the same language as
   the given automaton in any state. **)
Lemma dfa_to_nfa_correct' x w : dfa_accept A x w = nfa_accept dfa_to_nfa x w.
Proof. elim: w x => [|b w IHw] x.
  by [].
simpl. rewrite IHw.
apply/idP/existsP.
  move => H0. exists (dfa_step A x b). by rewrite eq_refl H0.
by move => [] y /andP [] /eqP ->.
Qed.

(** We prove that dfa_to_nfa accepts the same language
   as the given automaton in the starting state, i.e. their
   languages are equal. **)
Lemma dfa_to_nfa_correct : dfa_lang A =i nfa_lang dfa_to_nfa.
Proof.
  exact: dfa_to_nfa_correct'.
Qed.

End Embed.

(** Primitive automata **)
Section Primitive.
  Definition dfa_void :=
   {|
      dfa_s := tt;
      dfa_fin := pred0;
      dfa_step := [fun x a => tt]
   |}.

  Lemma dfa_void_correct x w: ~~ dfa_accept dfa_void x w.
  Proof. by elim: w x => [|a w IHw] //= x. Qed.

  Definition dfa_eps :=
    {|
      dfa_s := true;
      dfa_fin := pred1 true;
      dfa_step := [fun x a => false]
     |}.

  Lemma dfa_eps_correct: dfa_lang dfa_eps =i pred1 [::].
  Proof.
    have H: (forall w, ~~ dfa_accept dfa_eps false w).
      by elim => [|a v IHv] //=.
    move => w.
    elim: w => [|a w IHw] //.
    apply/idP/idP.
    exact: H.
  Qed.

  Definition dfa_char a :=
    {|
      dfa_s := None;
      dfa_fin := pred1 (Some true);
      dfa_step := [fun x b => if x == None then if b == a then Some true else Some false else Some false ]
    |}.

  Lemma dfa_char_correct'' a w: ~~ dfa_accept (dfa_char a) (Some false) w.
  Proof. by elim: w => [|b v IHv] //=. Qed.
  Lemma dfa_char_correct' a w: dfa_accept (dfa_char a) (Some true) w = (w == [::]).
  Proof.
    elim: w a => [|b w IHw] a //=.
    apply/idP/idP.
    exact: dfa_char_correct''.
  Qed.
  Lemma dfa_char_correct a w: dfa_lang (dfa_char a) w = (w == [::a]).
  Proof.
    elim: w a => [|b w IHw] a //=.
    case H: (b == a).
      move/eqP: H => ->.
      rewrite dfa_char_correct'.
      by apply/eqP/eqP => [-> | []].
    apply/idP/eqP.
      move => H0. move: (dfa_char_correct'' a w). by rewrite H0.
    move => [] /eqP. by rewrite H.
  Qed.

  Definition dfa_dot :=
    {|
      dfa_s := None;
      dfa_fin := pred1 (Some true);
      dfa_step := [fun x b => if x == None then Some true else Some false ]
    |}.

  Lemma dfa_dot_correct'' w: ~~ dfa_accept dfa_dot (Some false) w.
  Proof. by elim: w => [|b v IHv] //=. Qed.
  Lemma dfa_dot_correct' w: dfa_accept dfa_dot (Some true) w = (w == [::]).
  Proof.
    elim: w => [|b w IHw] //=.
    apply/idP/idP.
    exact: dfa_dot_correct''.
  Qed.
  Lemma dfa_dot_correct w: dfa_lang dfa_dot w = (size w == 1).
  Proof.
    elim: w => [|b w IHw] //=.
    rewrite dfa_dot_correct'.
    apply/eqP/eqP => [-> | []] //=.
    exact: size0nil.
  Qed.

End Primitive.

(** Operations on non-deterministic automata. **)
Section DFAOps.

Variable A1: dfa.

(** Complement automaton **)

(** We construct the resulting automaton. **)
Definition dfa_compl :=
 {|
    dfa_s := dfa_s A1;
    dfa_fin := [ fun x1 => ~~ dfa_fin A1 x1 ];
    dfa_step := (dfa_step A1)
  |}.

(** We prove that the complement automaton accepts exactly
   the words not accepted by the original automaton. **)
Lemma dfa_compl_correct' x:
  [ predC dfa_accept A1 x ] =i dfa_accept dfa_compl x.
Proof. move => w. elim: w x => [|a w IHw] x.
    by apply/idP/idP.
  simpl. rewrite -topredE dfa_accept_cons /= -IHw.
  apply/negP/idP; rewrite dfa_accept_cons; by move/negP.
Qed.

(** Language correctness for dfa_compl **)
Lemma dfa_compl_correct:
  [ predC dfa_lang A1 ] =i dfa_lang dfa_compl.
Proof. exact: dfa_compl_correct'. Qed.

(** Operations on two automata. **)
Section BinaryOps.

Variable A2: dfa.

(** Disjunction automaton **)

Definition dfa_disj :=
  {|
    dfa_s := (dfa_s A1, dfa_s A2);
    dfa_fin := (fun q => let (x1,x2) := q in dfa_fin A1 x1 || dfa_fin A2 x2);
    dfa_step := [fun x a => (dfa_step A1 x.1 a, dfa_step A2 x.2 a)]
   |}.

(** Correctness w.r.t. any state. **)
Lemma dfa_disj_correct' x:
  [ predU dfa_accept A1 x.1 & dfa_accept A2 x.2 ]
    =i dfa_accept dfa_disj x.
Proof. move => w. elim: w x => [|a w IHw].
  by move => [].
move => x /=. by rewrite dfa_accept_cons -IHw.
Qed.

(** Language correctness. **)
Lemma dfa_disj_correct:
  [ predU  dfa_lang A1 & dfa_lang A2 ]
    =i dfa_lang dfa_disj.
Proof. move => w /=. by rewrite -dfa_disj_correct'. Qed.

(** Conjunction **)

Definition dfa_conj :=
 {|
    dfa_s := (dfa_s A1, dfa_s A2);
    dfa_fin := (fun x => dfa_fin A1 x.1 && dfa_fin A2 x.2);
    dfa_step := [fun x a => (dfa_step A1 x.1 a, dfa_step A2 x.2 a)]
  |}.

(** Correctness w.r.t. any state. **)
Lemma dfa_conj_correct' x1 x2 :
  [ predI  dfa_accept A1 x1 & dfa_accept A2 x2 ]
  =i dfa_accept dfa_conj (x1, x2).
Proof. move => w. elim: w x1 x2 => [|a w IHw].
  by [].
move => x1 x2.
exact: IHw.
Qed.

(** Language correctness. **)
Lemma dfa_conj_correct:
  [ predI dfa_lang A1 & dfa_lang A2 ]
  =i dfa_lang dfa_conj.
Proof. move => w. by rewrite -dfa_conj_correct'  /=. Qed.

End BinaryOps.

(* Remove unreachable states *)
Section Reachability.
  Definition reachable1 := [ fun x y => [ exists a, dfa_step A1 x a == y ] ].

  Definition reachable := enum (connect reachable1 (dfa_s A1)).

  Lemma reachable_step x a: x \in reachable ->  dfa_step A1 x a \in reachable.
  Proof.
    rewrite 2!mem_enum -2!topredE /= => Hx.
    eapply connect_trans.
      eassumption.
    apply/connectP.
    exists [::dfa_step A1 x a] => //=.
    rewrite andbT. apply/existsP. by exists a.
  Qed.

  Lemma reachable0 : dfa_s A1 \in reachable.
  Proof. rewrite mem_enum -topredE /=. by apply connect0. Qed.

  Definition dfa_connected :=
   {|
      dfa_s := SeqSub reachable0;
      dfa_fin := fun x => match x with SeqSub x _ => dfa_fin A1 x end;
      dfa_step := fun x a => match x with
        | SeqSub _ Hx => SeqSub (reachable_step _ a Hx)
        end
    |}.

  Lemma dfa_connected_correct' x (Hx: x \in reachable) :
    dfa_accept dfa_connected (SeqSub Hx) =i dfa_accept A1 x.
  Proof. move => w. elim: w x Hx => [|a w IHw] x Hx //=.
    by rewrite 2!dfa_accept_cons IHw.
  Qed.

  Lemma dfa_connected_correct: dfa_lang dfa_connected =i dfa_lang A1.
  Proof.
    move => w. by rewrite /dfa_lang /= dfa_connected_correct'.
  Qed.

  Definition reachable1_connected := [ fun x y => [ exists a, dfa_step dfa_connected x a == y ] ].
  Lemma reachable1_connected_aux2 x y (Hx: x \in reachable) (Hy: y \in reachable) : connect reachable1 x y -> connect reachable1_connected (SeqSub Hx) (SeqSub Hy).
  Proof.
    move/connectP => [p].
    elim: p x Hx y Hy => [|z p IHp] x Hx y Hy //=.
      move => _ H.
      move: Hx Hy. rewrite H => Hx Hy.
      have: (Hx = Hy).
        by apply: bool_irrelevance.
      move => ->.
      apply: connect0.
    move/andP => [] /existsP [] a /eqP Ha Hpz H.
    have Hz: (z \in reachable).
      rewrite -Ha. by apply reachable_step.
    pose H0 := (IHp _ Hz _ Hy Hpz H).
    eapply connect_trans.
      apply connect1.
      instantiate (1 := SeqSub Hz).
      apply/existsP. exists a.
      simpl. move: Hz H0.
      rewrite -Ha => Hz H0.
      have: Hz = reachable_step x a Hx.
        apply bool_irrelevance.
      by move => ->.
    assumption.
  Qed.

  Lemma dfa_connected_repr' (x y: dfa_connected):
    connect reachable1_connected y x ->
    exists w, last y (dfa_run' dfa_connected y w) = x.
  Proof.
    move/connectP => [] p.
    elim: p x y => [|z p IHp] x y.
      move => _ -> /=. by exists [::].
    move => /= /andP [] /existsP [] a /eqP Ha Hp Hx.
    destruct (IHp x z) as [w Hw] => //.
    exists (a::w).
    by rewrite /= Ha.
  Qed.

  Lemma dfa_connected_repr x :
    exists w, last (dfa_s dfa_connected) (dfa_run dfa_connected w) = x.
  Proof.
    apply dfa_connected_repr'.
    destruct x as [x Hx].
    apply (reachable1_connected_aux2 (dfa_s A1) x reachable0).
    by rewrite mem_enum -topredE /= in Hx.
  Qed.

  Lemma dfa_connected_repr_pred x :
    exists w, last (dfa_s dfa_connected) (dfa_run dfa_connected w) == x.
  Proof.
    move: (dfa_connected_repr x) => [w /eqP].
    by eauto.
  Defined.

  Lemma dfa_connected_repr_fun (x: dfa_connected):
    word.
  Proof.
    move: (dfa_connected_repr_pred x).
    apply (xchoose).
  Defined.

  Lemma dfa_connected_repr_fun_correct x: last (dfa_s dfa_connected) (dfa_run dfa_connected (dfa_connected_repr_fun x)) = x.
  Proof.
    rewrite /dfa_connected_repr_fun.
    by move: (xchooseP (dfa_connected_repr_pred x)) => /eqP.
  Qed.

  Lemma dfa_connected_repr_fun_injective: injective dfa_connected_repr_fun.
  Proof.
    move => x y.
    rewrite /dfa_connected_repr_fun => H.
    move: (xchooseP (dfa_connected_repr_pred x)) => /eqP.
    move: (xchooseP (dfa_connected_repr_pred y)) => /eqP.
    rewrite H. by move => -> ->.
  Qed.

  Lemma dfa_connected_size: #|A1| >= #|dfa_connected|.
  Proof.
    rewrite /dfa_connected /= /reachable card_seq_sub.
    by rewrite -cardE max_card.
    exact: enum_uniq.
  Qed.

End Reachability.

Section Emptiness.

  Definition dfa_lang_empty := #|dfa_fin dfa_connected| == 0.

  Lemma dfa_lang_empty_aux2: dfa_lang dfa_connected =i pred0 -> dfa_lang_empty.
  Proof.
    rewrite /dfa_lang_empty.
    move => H.
    apply/eqP/eq_card0.
    move => x.
    apply/idP/idP.
    apply/negP.
    move: (dfa_connected_repr x) => [w Hw].
    move: (H w).
    rewrite /dfa_lang /= -dfa_run_accept.
    rewrite Hw.
    by move/negP.
  Qed.

  Lemma dfa_lang_empty_aux1: dfa_lang_empty -> dfa_lang dfa_connected =i pred0.
  Proof.
    rewrite /dfa_lang_empty.
    move => H w.
    apply/idP/idP.
    apply/negP.
    rewrite /dfa_lang /= -dfa_run_accept.
    by move/eqP/card0_eq: H => ->.
  Qed.

  Lemma dfa_lang_empty_correct:
    reflect (dfa_lang A1 =i pred0)
            dfa_lang_empty.
  Proof.
    apply/iffP.
    eexact (@idP dfa_lang_empty ).
      move => H w. rewrite -dfa_connected_correct.
      exact: dfa_lang_empty_aux1.
    move => H.
    apply: dfa_lang_empty_aux2.
    move => w.
    by rewrite dfa_connected_correct.
  Qed.

End Emptiness.

End DFAOps.

Section Equivalence.
  Definition dfa_sym_diff A1 A2 :=
    dfa_disj (dfa_conj A1 (dfa_compl A2)) (dfa_conj A2 (dfa_compl A1)).

  Definition dfa_equiv A1 A2 := dfa_lang_empty (dfa_sym_diff A1 A2).

  Lemma dfa_equiv_correct A1 A2:
    dfa_equiv A1 A2 <-> dfa_lang A1 =i dfa_lang A2.
  Proof.
    split; rewrite /dfa_sym_diff.
      move/dfa_lang_empty_correct => H w.
      move: (H w).
      rewrite -dfa_disj_correct -topredE /= -2!dfa_conj_correct -2!topredE /= -2!dfa_compl_correct.
      move/norP => [] /nandP [] /negP H1 /nandP [] /negP H2;
      apply/idP/idP; try by [];
      move/negP: H1; move/negP: H2;
      by auto using negbNE.
    move => H. apply/dfa_lang_empty_correct => w. move: (H w).
    rewrite -dfa_disj_correct -3!topredE /= -2!dfa_conj_correct -2!topredE /= -2!dfa_compl_correct.
    rewrite -H -4!topredE /= -2!topredE /= andbN => ->.
    by rewrite andbN.
Qed.

End Equivalence.

(** Operations on non-deterministic automata. **)
Section NFAOps.
Variable A1: nfa.
Variable A2: nfa.

(** Concatenation of two non-deterministic automata. **)

Definition nfa_conc : nfa :=
  {|
    nfa_s := inl _ (nfa_s A1);
    nfa_fin := [fun x =>
        match x with
          | inl x => nfa_fin A1 x && nfa_fin A2 (nfa_s A2)
          | inr x => nfa_fin A2 x
        end];
     nfa_step := fun x a y =>
        match x,y with
          | inl x, inl y => nfa_step A1 x a y
          | inl x, inr y => nfa_fin A1 x && nfa_step A2 (nfa_s A2) a y
          | inr x, inr y => nfa_step A2 x a y
          | inr x, inl y => false
        end
   |}.

(** We prove that every path of A2 can be mapped to a path
   of nfa_conc. **)
Lemma nfa_conc_cont x xs w:
  nfa_run A2 x xs w
  -> nfa_run nfa_conc (inr _ x) (map (@inr A1 A2) xs) w.
Proof. elim: xs x w => [|y xs IHxs] x w; case: w => [|a w] => //.
simpl. by move/andP => [] -> /IHxs ->.
Qed.

(** We prove that every word in the language of A2
   is also accepted by any final state of A1 in
   nfa_conc. **)
Lemma nfa_conc_fin1 x1 w:
  nfa_fin A1 x1 ->
  nfa_lang A2 w ->
  nfa_accept nfa_conc (inl _ x1) w.
Proof.
move => H0 /nfa_run_accept [] ys.
elim: ys w x1 H0 => [|y ys IHys] [|a w] x1 H0 //=.
  rewrite -topredE /=.
  by move: H0 => -> _ ->.
move => /andP [] H1 H2 H3.
apply/existsP. exists (inr _ y).
rewrite H0 H1 /=.
apply/nfa_run_accept.
  eexists _.
  apply nfa_conc_cont.
  by eassumption.
by rewrite last_map /nfa_fin.
Qed.

(** We prove that for every word w1 accepted by A1 in
   some state x and for every word w2 in the language of A2
   w1 ++ w2 will be accepted by the corresponding state in
   nfa_conc. **)
Lemma nfa_conc_aux2 x w1 w2:
  nfa_accept A1 x w1 ->
  nfa_lang A2 w2 ->
  nfa_accept nfa_conc (inl _ x) (w1 ++ w2).
Proof. elim: w1 w2 x => [|a w1 IHw1] w2 x.
    move => H0 /nfa_run_accept [] xs [] H1 H2.
    move: (nfa_conc_cont _ _ _ H1) => H3.
    apply/nfa_accept_cat.
    exists [::] => /=.
    apply: nfa_conc_fin1 => //.
    apply/nfa_run_accept.
    by eauto.
  move => /existsP [] y /andP [] H1 H2 H3 /=.
  apply/existsP. exists (inl _ y).
  rewrite H1 /=.
  apply: IHw1.
    exact: H2.
  exact: H3.
Qed.

(** We prove that every word accepted by some state X in nfa_conc is
   - EITHER a concatenation of two words w1, w2 which are accpeted
   by A1, A2 (resp.) if X corresponds to one of A1's states
   - OR accepted by A2 in the state corresponding to X if X
   corresponds to one of A2's states. **)
Lemma nfa_conc_aux1 X w :
  nfa_accept nfa_conc X w ->
  match X with
  | inl x => exists w1, exists w2, (w == w1 ++ w2) && (nfa_accept A1 x w1) && nfa_lang A2 w2
  | inr x => nfa_accept A2 x w
end.
Proof.
  elim: w X => [|a w IHw] [x|x] //=.
      move => /andP [] H0 H1. exists [::]. exists [::].
      by rewrite /= H0 H1.
    move/existsP => [] [y|y] /andP [] H0 /IHw.
      (* inl / inl *)
      move => [] w1 [] w2 /andP [] /andP [] /eqP H1 H2 /= H3.
      exists (a::w1). exists w2.
      rewrite H1 eq_refl H3 andTb andbT.
      apply/existsP. exists y.
      move: H0 => /= ->. rewrite andTb.
      exact H2.
    (* inl / inr *)
    move: H0 => /= /andP [] H0 H1 /= H2.
    exists [::]. exists (a::w) => /=.
    rewrite H0 eq_refl 2!andTb.
    apply/existsP. exists y.
    by rewrite H1 H2.
  (* inr / inl  *)
  move/existsP => [] [y|y] /andP [] H0 /IHw.
  by [].
(* inr / inr *)
move: H0 => /= H0 H1.
apply/existsP. exists y.
by rewrite H0 H1.
Qed.

Lemma nfa_conc_correct: nfa_lang nfa_conc =i conc (nfa_lang A1) (nfa_lang A2).
Proof.
  move => w.
  apply/idP/concP.
    move/nfa_conc_aux1.
    rewrite /nfa_conc /nfa_s.
    move => [] w1 [] w2 /andP [] /andP [] /eqP H0 H1 H2.
    by eauto.
  move => [] w1 H0 [] w2 H2 ->.
  by apply/nfa_conc_aux2.
  Qed.

(** Plus operator for non-deterministic automata. **)

(** The step relation implements the following rule:
   - every edge to a final state will also be duplicated
   to point to s0.
   **)
Definition step_plus x a y : bool :=
nfa_step A1 x a y || (
                      (y == nfa_s A1)
                      && [ exists z, (nfa_fin A1 z) && (nfa_step A1 x a z) ]
                    ).

(** **)
Definition nfa_repeat : nfa :=
  {|
    nfa_s := nfa_s A1;
    nfa_fin := nfa_fin A1;
    nfa_step := fun x a y =>
        nfa_step A1 x a y || (
                      (y == nfa_s A1)
                      && [ exists  z, (nfa_fin A1 z) && (nfa_step A1 x a z) ]
                    )
   |}.

(** We prove that every path of A1 can be mapped to a path
   of nfa_repeat. **)
Lemma nfa_repeat_cont x xs w:
  nfa_run A1 x xs w
  -> nfa_run nfa_repeat x xs w.
Proof. elim: xs x w => [|y xs IHxs] x w; case: w => [|a w] => //.
move/andP => [] H0 /= /IHxs ->.
by rewrite /step_plus H0 orTb.
Qed.

(** We prove that every accepting path labeled (a::w) in A1
   exists in nfa_repeat with only the last state changed to
   A1's starting state. This new path need not be accepting. **)
Lemma nfa_repeat_lpath x y xs a w:
  nfa_fin nfa_repeat (last x (y::xs)) ->
  nfa_run nfa_repeat x (y::xs) (a::w) ->
  nfa_run nfa_repeat x (rcons (belast y xs) (nfa_s A1)) (a::w).
Proof. elim: xs x y a w => [|z xs IHxs] x y a [|b w] //=.
      rewrite 2!andbT.
      move => H0 /orP [|/andP [] /eqP].
        move => H1. rewrite/step_plus.
        apply/orP. right. rewrite eq_refl.
        apply/existsP. exists y. by rewrite H0 H1.
      move => H1 /existsP [] z /andP [] H2 H3. move: H1 H0 => -> H4.
      apply/orP. right. rewrite eq_refl /=.
      apply/existsP. exists z. by rewrite H2 H3.
    by rewrite andbF.
  by rewrite andbF.
rewrite -(last_cons y). move => H0 /andP [] H1 /andP [] H3 H4.
rewrite H1 /=. apply: IHxs.
  by rewrite H0.
simpl. by rewrite H3 H4.
Qed.

(** We prove that every word accepted by A1 in
   some state x is also accepted by nfa_repeat in
   that state. **)
Lemma nfa_repeat_correct0' x w1 :
  nfa_accept A1 x w1 ->
  nfa_accept nfa_repeat x w1.
Proof.
  move/nfa_run_accept => [] xs [].
  move/nfa_repeat_cont => H0 H1.
  apply/nfa_run_accept.
  by exists xs.
Qed.

(** We prove that every word accepted by A1 is also
   accepted by nfa_repeat. **)
Lemma nfa_repeat_correct0 w :
  nfa_lang A1 w ->
  nfa_lang nfa_repeat w.
Proof. exact: nfa_repeat_correct0'. Qed.

(** We prove that every prefix accpeted by A1 followed
   by a suffix accepted by nfa_repeat is again accepted
   by nfa_repeat. This is the first part of the proof of
   language correctness for nfa_repeat. **)
Lemma nfa_repeat_aux2 w1 w2:
  nfa_lang A1 w1 ->
  nfa_lang nfa_repeat w2 ->
  nfa_lang nfa_repeat (w1 ++ w2).
Proof.
move => /nfa_run_accept [] [|x xs] []; case: w1 => [|a w1] => //.
move => H0 H1 H2.
apply/(nfa_accept_cat).
exists (rcons (belast x xs) (nfa_s A1)).
apply/andP. split.
  apply: nfa_repeat_lpath.
    exact: H1.
  apply: nfa_repeat_cont.
  exact: H0.
rewrite last_rcons.
exact H2.
Qed.

(** We prove that every word accepted by some state x in nfa_repeat
   is a concatenation of two words w1, w2 which are accpeted by
   A1 in x and nfa_repeat (resp.). **)
Lemma nfa_repeat_aux1' x w :
  nfa_accept nfa_repeat x w ->
  ((exists w1, exists w2, (w == w1 ++ w2) && (w1 != [::]) && (nfa_accept A1 x w1) && nfa_lang nfa_repeat w2
    ) \/ nfa_accept A1 x w ).
Proof. elim: w x => [|a w IHw] x.
  move => H0. right.
  exact: H0.
case/existsP => y /andP [H0 H1].
case: (IHw _ H1) => [[w1 [w2 /andP [/andP [/andP [/eqP H2 H9] H3] H4]]]|H2].
  move: H0 => /orP [H5|].
    left. exists (a::w1). exists w2.
    rewrite H2 eq_refl H4 andbT /=.
    apply/existsP. exists y.
    by rewrite H5 H3.
  move/andP => [] H5 /existsP [] z /andP [H6 H7].
  move: H5 H1 H3 => /eqP -> H1 H3.
  left. exists ([::a]). exists w.
  rewrite eq_refl /=. apply/andP. split.
    apply/existsP. exists z. by rewrite H6 H7.
  exact: H1.
move: H0 => /orP [H5|].
  right => /=. apply/existsP. exists y.
  by rewrite H5 H2.
  move/andP => [/eqP H3 /existsP [z /andP [H4 H5]]].
move: H3 H1 H2 => -> H1 H2.
left. exists [::a]. exists w.
rewrite eq_refl /=. apply/andP. split.
  apply/existsP. exists z. by rewrite H5 H4.
exact H1.
Qed.

(** We prove the second part of language correctness
   for nfa_repeat. **)
Lemma nfa_repeat_aux1 w:
  nfa_lang nfa_repeat w ->
  ((exists w1, exists w2, (w == w1 ++ w2) && (w1 != [::]) && (nfa_lang A1 w1) && nfa_lang nfa_repeat w2
    ) \/ nfa_lang A1 w ).
Proof. exact: nfa_repeat_aux1'. Qed.

(* Star operator *)
Definition nfa_star := (dfa_disj dfa_eps (nfa_to_dfa nfa_repeat)).

Lemma nfa_star_aux1 w: w \in dfa_lang nfa_star -> w \in star (nfa_lang A1).
Proof.
  rewrite /nfa_star -dfa_disj_correct -topredE /=.
    rewrite dfa_eps_correct => /orP [].
      move => /eqP ->.
      apply/starP. by exists [::].
    rewrite -nfa_to_dfa_correct.
    move: w.
    apply: (size_induction size).
    move => w IHw.
    move/nfa_repeat_aux1' => [].
      move => [] w1 [] w2 [/andP [/andP [/andP [/eqP H1 H2] H3] H4]].
      have H5: (size w2 < size w).
        rewrite H1 size_cat addnC -{1}(addn0 (size w2)).
        rewrite ltn_add2l.
        by destruct w1.
      move: (IHw w2 H5 H4) => /starP [] vv H6 H7.
      apply/starP. exists (w1::vv).
          by rewrite /= H6 -topredE /= /eps /= H2 /nfa_lang /= -topredE /= H3.
        by rewrite H1 H7.
      rewrite /nfa_lang /=.

      case: w IHw => [|a w] IHw H.
        apply/starP. by exists [::].
      apply/starP.
        exists [::(a::w)] => //=.
        by rewrite -topredE andbT.
      by rewrite cats0.
Qed.

Lemma nfa_star_aux2 w: w \in star (nfa_lang A1) -> w \in dfa_lang nfa_star.
Proof.
    rewrite /nfa_star -dfa_disj_correct -2!topredE /= -nfa_to_dfa_correct.
    move/starP => [] vv. elim: vv w => [|v vv IHvv] w.
      rewrite /= => _ ->. move: (dfa_eps_correct [::]).
      by rewrite /dfa_lang /=.
    rewrite [all _ _]/=.
    move/andP => [] /andP [] H0 H1 H2 H3.
    rewrite H3 [flatten _]/=.
    move/orP: (IHvv (flatten vv) H2 (Logic.eq_refl _)) => [].
      rewrite dfa_eps_correct => /eqP H4.
      move: H3. rewrite [flatten _]/= H4 cats0.
      move => H5. subst. apply/orP. right.
      rewrite H4 in IHvv.
      by apply nfa_repeat_correct0.
    move => H4.
    apply/orP. right.
    by apply: nfa_repeat_aux2.
Qed.

Lemma nfa_star_correct: dfa_lang nfa_star =i star (nfa_lang A1).
Proof.
  move => w.
  apply/idP/idP.
    by move/nfa_star_aux1.
  by move/nfa_star_aux2.
Qed.

End NFAOps.

End FA.


Require Import ZArith.
Require Import Psatz.

From mathcomp
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path div choice.
From mathcomp
Require Import fintype tuple finfun bigop prime finset binomial.
From mathcomp
Require Import ssralg ssrnum ssrint rat.

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

Import GRing.Theory.
Import Num.Theory.

Local Open Scope ring_scope.
Delimit Scope Z_scope with coqZ.

(* Translation of type int into type Z *)
Definition Z_of_int (n : int) : Z :=
match n with
  |Posz k => Z_of_nat k
  |Negz k => Zopp (Z_of_nat k.+1)
end.

(* Correspondance bewteen comparison relations *)
Lemma Z_of_intP n m : n = m <-> Z_of_int n = Z_of_int m.
Proof.
split; first by move->.
case: n=> [[|nn]|nn]; case: m => [[|mm]|mm] //=.
- by rewrite !Zpos_P_of_succ_nat; move/Zsucc_inj/inj_eq_rev->.
- case; move/(f_equal Zpos); rewrite !Zpos_P_of_succ_nat.
  by move/Zsucc_inj/inj_eq_rev->.
Qed.

Lemma Z_of_intbP n m : n == m <-> Z_of_int n = Z_of_int m.
Proof. by rewrite <- Z_of_intP; split; move/eqP. Qed.

Lemma Z_of_intbPn n m : n != m <-> Z_of_int n <> Z_of_int m.
Proof. by rewrite <- Z_of_intP; split; move/eqP. Qed.

Lemma Z_ltP (x y : int) : (x < y) <-> (Zlt (Z_of_int x) (Z_of_int y)).
Proof.
split; case: x=> [[|xx]|xx]; case: y => [[|yy]|y] //.
- move=> h; rewrite /= !Zpos_P_of_succ_nat; apply: Zsucc_lt_compat; apply: inj_lt.
  exact: ltP.
- rewrite /Z_of_int; rewrite !NegzE => h.
  have {h} : (Z_of_nat y.+1 < Z_of_nat xx.+1)%coqZ by apply/inj_lt/ltP.
  by lia.
- by rewrite /= !Zpos_P_of_succ_nat; move/Zsucc_lt_reg/inj_lt_rev/ltP.
- rewrite /Z_of_int !NegzE => h.
- have {h} : (Z_of_nat y.+1 < Z_of_nat xx.+1)%coqZ by lia.
  by move/inj_lt_rev/ltP.
Qed.

Lemma Z_leP (x y : int) : (x <= y) <-> Zle (Z_of_int x) (Z_of_int y).
Proof.
split.
- rewrite ler_eqVlt; case/orP; first by move/eqP->; exact: Zle_refl.
  move/Z_ltP; exact: Zlt_le_weak.
case/Z_le_lt_eq_dec; first by move/Z_ltP/ltrW.
by move/Z_of_intP->.
Qed.

(*Transformation of a constraint (x # y) where (x y : int) and # is a comparison
relation into the corresponding constraint (Z_of_int x #' Z_of_int y) where #' is
the analogue of # on Z. The transformation is performed on the first such formula
found either in the context or the conclusion of the goal *)
Ltac zify_int_rel :=
 match goal with
  (* Prop equalities *)
  | H : (@eq _ _ _) |- _ => move/Z_of_intP: H => H
  | |- (@eq _ _ _) => rewrite -> Z_of_intP
  | H : context [ @eq _ ?a ?b ] |- _ => rewrite -> (Z_of_intP a b) in H
  | |- context [ @eq _ ?a ?b ] => rewrite -> (Z_of_intP a b)
  (* less than *)
  | H : is_true (@Num.Def.ltr _ _ _) |- _ => move/Z_ltP: H => H
  | |- is_true (@Num.Def.ltr _ _ _) => rewrite -> Z_ltP
  | H : context [  is_true (@Num.Def.ltr _ ?a ?b) ] |- _ => rewrite -> (Z_ltP a b) in H
  | |- context [ is_true (@Num.Def.ltr _ ?a ?b) ] => rewrite -> (Z_ltP a b)
  (* less or equal *)
  | H : is_true (@Num.Def.ler _ _ _) |- _ => move/Z_leP: H => H
  | |- is_true (@Num.Def.ler _ _ _) => rewrite -> Z_leP
  | H : context [  is_true (@Num.Def.ler _ ?a ?b) ] |- _ => rewrite -> (Z_leP a b) in H
  | |- context [  is_true (@Num.Def.ler _ ?a ?b) ] => rewrite -> (Z_leP a b)
  (* Boolean equality *)
  |H : is_true (@eq_op _  _ _) |- _ => rewrite -> Z_of_intbP in H
  | |- is_true (@eq_op _  _ _) => rewrite -> Z_of_intbP
  |H : context [ is_true (@eq_op _  _ _)] |- _ => rewrite -> Z_of_intbP in H
  | |- context [ is_true (@eq_op _  _ _)] => rewrite -> Z_of_intbP
  (* Negated boolean equality *)
  |H : is_true (negb (@eq_op _  _ _)) |- _ => rewrite -> Z_of_intbPn in H
  | |- is_true (negb (@eq_op _  _ _)) => rewrite -> Z_of_intbPn
  |H : context [ is_true (negb (@eq_op _  _ _))] |- _ => rewrite -> Z_of_intbPn in H
  | |- context [ is_true (negb (@eq_op _  _ _))] => rewrite -> Z_of_intbPn
 end.

(* Distribution of Z_of_int over arithmetic operations *)
Lemma Z_of_intmorphD  : {morph Z_of_int : x y  /  x + y >-> (Zplus x y) }.
Proof.
have aux (n m : nat) :
  Z_of_int (Posz n.+1 + Negz m) = (Z_of_int n.+1 + Z_of_int (Negz m))%coqZ.
  rewrite {2 3}/Z_of_int NegzE; case: (ltngtP m n)=> hmn.
  + rewrite subzn; last exact: ltn_trans hmn _.
    rewrite subSn // /Z_of_int -subSn // inj_minus1 //; apply/leP.
    exact: ltn_trans hmn _.
  + rewrite -[_ - _]opprK opprB subzn; last exact: ltn_trans hmn _.
    rewrite subSn // -NegzE /Z_of_int -subSn // inj_minus1; first by lia.
    apply/leP; exact: ltn_trans hmn _.
  + by rewrite hmn subrr Zplus_opp_r.
move=> x y /=; case: x=> [[|xx]|xx]; case: y => [[|yy]|y] //.
- by rewrite /= subn0.
- by rewrite addr0 Zplus_0_r.
- by rewrite -PoszD addnS /Z_of_int -inj_plus -addnS.
- by rewrite addr0 Zplus_0_r.
- by rewrite addrC aux Zplus_comm.
- rewrite {2 3}/Z_of_int !NegzE -opprD -PoszD addnS -NegzE /Z_of_int -addnS.
  by rewrite inj_plus Zopp_plus_distr.
Qed.

Lemma Z_of_intmorphM  : {morph Z_of_int : x y  / x * y  >-> (Zmult x y) }.
have aux (n m : nat) :
  Z_of_int (Posz n.+1 * Negz m) = (Z_of_int n.+1 * Z_of_int (Negz m))%coqZ.
  rewrite {2 3}/Z_of_int NegzE mulrN -PoszM mulnS addSn -NegzE /Z_of_int -addSn.
  by rewrite -mulnS inj_mult; lia.
move=> x y /=; case: x=> [[|xx]|xx]; case: y => [[|yy]|y] //.
- by rewrite mulr0 Zmult_0_r.
- by rewrite -PoszM /Z_of_int inj_mult.
- by rewrite mulrC aux Zmult_comm.
- rewrite ![in LHS]NegzE mulrN mulNr opprK -PoszM /Z_of_int inj_mult; lia.
Qed.

Lemma Z_of_intmorphN  : {morph Z_of_int : x / - x >-> Zopp x}.
Proof. by case=> [] [|xx]. Qed.

(*Pushing Z_of_int at the leaves of expressions.The transformation is *)
(*performed on the first such formula found either in the context or *)
(*the conclusion of the goal *)
(* We (boldly?) assume here that all operations are ring ones *)
Ltac zify_int_op :=
 match goal with
  (* add -> Zplus *)
  | H : context [ Z_of_int (@GRing.add _ _ _) ] |- _ => rewrite Z_of_intmorphD in H
  | |- context [ Z_of_int (@GRing.add _ _ _) ] => rewrite Z_of_intmorphD
  (* opp -> Zopp *)
  | H : context [ Z_of_int (@GRing.opp _ _) ] |- _ => rewrite Z_of_intmorphN in H
  | |- context [ Z_of_int (@GRing.opp _  _) ] => rewrite Z_of_intmorphN
  (* mul -> Zmult *)
  | H : context [ Z_of_int (@GRing.mul _ _ _) ] |- _ => rewrite Z_of_intmorphM in H
  | |- context [ Z_of_int (@GRing.mul _ _ _) ] => rewrite Z_of_intmorphM
  (* (* O -> Z0 *) *)
  | H : context [ Z_of_int (GRing.zero _) ] |- _ => rewrite [Z_of_int O]/= in H
  | |- context [ Z_of_int (GRing.zero _) ] => rewrite [Z_of_int O]/=
  (* (* 1 -> 1 *) *)
  | H : context [ Z_of_int (GRing.one _) ] |- _ => rewrite [Z_of_int 1]/= in H
  | |- context [ Z_of_int (GRing.one _) ] => rewrite [Z_of_int 1]/=
  (* (* n -> n *) *)
  | H : context [ Z_of_int _ ] |- _ => rewrite [Z_of_int (S _)]/= in H
  | |- context [ Z_of_int _ ] => rewrite [Z_of_int (S _)]/=
  | H : context [ Z_of_nat _ ] |- _ => rewrite [Z_of_nat 0]/= [Z_of_nat (S _)]/= in H
  | |- context [ Z_of_nat _ ] => rewrite [Z_of_nat 0]/= [Z_of_nat (S _)]/=
 end.

(* Preparing a goal to be solved by lia by translating every formula *)
(* in the context or the conclusion which expresses a constraint on *)
(* some int into the analogue on Z *)
Ltac zify_int :=
  repeat progress zify_int_rel;
  repeat progress zify_int_op.

(* Preprocessing + lia *)
Ltac intlia := zify_int; lia.

(*Transformation of a constraint (x # y) where (x y : nat) and # is a comparison
relation into the corresponding constraint (x #' y) where #' is
the std lib analogue of #. The transformation is performed on the first such formula
found either in the context or the conclusion of the goal *)
Ltac ssrnatify_rel :=
 match goal with
  (* less or equal (also codes for strict comparison in ssrnat) *)
  | H : is_true (leq _ _) |- _ => move/leP: H => H
  | H : context [ is_true (leq ?a ?b)] |- _ =>
     rewrite <- (rwP (@leP a b)) in H
  | |- is_true (leq _ _) => apply/leP
  | |- context [ is_true (leq ?a ?b)] => rewrite <- (rwP (@leP a b))
  (* Boolean equality *)
  | H : is_true (@eq_op _ _ _) |- _ => move/eqP: H => H
  | |- is_true (@eq_op _ _ _) => apply/eqP
  | H : context [ is_true (@eq_op _ _ _)] |- _ =>
     rewrite <-  (rwP (@eqP _ _ _)) in H
  | |- context [ is_true (@eq_op _ ?x ?y)] => rewrite <- (rwP (@eqP _ x y))
  (* Negated boolean equality *)
  | H : is_true (negb (@eq_op _  _ _)) |- _ => move/eqP: H => H
  | |- is_true (negb (@eq_op _  _ _)) => apply/eqP
  | H : context [ is_true (negb (@eq_op _ _ _))] |- _ =>
     rewrite <-  (rwP (@eqP _ _ _)) in H
  | |- context [ is_true (negb (@eq_op _ ?x ?y))] =>
     rewrite <- (rwP (@eqP _ x y))
 end.

(* Converting ssrnat operation to their std lib analogues *)
Ltac ssrnatify_op :=
 match goal with
  (* subn -> minus *)
  | H : context [subn _ _] |- _ => rewrite -!minusE in H
  | |- context [subn _ _] => rewrite -!minusE
  (* addn -> plus *)
  | H : context [addn _ _] |- _ => rewrite -!plusE in H
  | |- context [addn _ _] => rewrite -!plusE
  (* muln -> mult *)
  | H : context [muln _ _] |- _ => rewrite -!multE in H
  | |- context [muln _ _] => rewrite -!multE
 end.

(* Preparing a goal to be solved by lia by translating every formula *)
(* in the context or the conclusion which expresses a constraint on *)
(* some nat into the std lib, Prop, analogues *)
Ltac ssrnatify :=
  repeat progress ssrnatify_rel;
  repeat progress ssrnatify_op.

(* Preprocessing + lia *)
Ltac ssrnatlia := ssrnatify; lia.

(* Preprocessing + lia *)
Ltac ssrnatomega := ssrnatify; omega.

(*** Below starts the code of goal_to_lia, to be cleaned as well ***)

(* goal_to_lia is a pre-prcoessing heuristic to be performed when the goal is
   more intricate and features more casts and boolean connectives. It is
   not polished as it does not scale on larger goals. *)

Lemma eqr_int_prop (x y : int) :
 (x%:~R = y%:~R :> rat) <-> x = y.
Proof.
split; last by move ->.
by move/eqP; rewrite eqr_int; move/eqP.
Qed.

Ltac rat_to_ring_lia :=
  rewrite -?[0%Q]/((Posz 0)%:~R : rat) -?[1%Q]/((Posz 1)%:~R : rat)
          -?[(_ - _)%Q]/(_ - _ : rat)%R -?[(_ / _)%Q]/(_ / _ : rat)%R
          -?[(_ + _)%Q]/(_ + _ : rat)%R -?[(_ * _)%Q]/(_ * _ : rat)%R
          -?[(- _)%Q]/(- _ : rat)%R -?[(_ ^-1)%Q]/(_ ^-1 : rat)%R /=.

Ltac rat_to_ring_hyp hyp :=
  rewrite -?[0%Q]/((Posz 0)%:~R : rat) -?[1%Q]/((Posz 1)%:~R : rat)
          -?[(_ - _)%Q]/(_ - _ : rat)%R -?[(_ / _)%Q]/(_ / _ : rat)%R
          -?[(_ + _)%Q]/(_ + _ : rat)%R -?[(_ * _)%Q]/(_ * _ : rat)%R
          -?[(- _)%Q]/(- _ : rat)%R -?[(_ ^-1)%Q]/(_ ^-1 : rat)%R /= in hyp.

Ltac propify_bool_connectives :=
rewrite ?(negb_and, negb_or);
repeat (match goal with
 | H : context [ is_true (andb _ _) ] |- _ => rewrite -(rwP andP) in H
 | |-  context [ is_true (andb _ _) ]      => rewrite -(rwP andP)
 | H : context [ is_true (orb _ _) ] |- _ => rewrite -(rwP orP) in H
 | |-  context [ is_true (orb _ _) ]      => rewrite -(rwP orP) end);
rewrite ?(=^~ ltrNge, =^~ lerNgt).

Ltac goal_to_lia :=
propify_bool_connectives;
rat_to_ring_lia;
rewrite ?NegzE;
(* unpropagate morZ_of_intsms to get, where that is pertinent,*)
(* propositions of the form _%:~R =/<=/< _%:~R *)
rewrite -?(rmorphD,rmorphN, rmorphB,rmorphM);
(* get rid of the cast %:~R around various compare operations *)
rewrite ?(eqr_int,ler_int, ltr_int, eqr_int_prop); (* TODO: add nats here *)
(* put Z_of_int around the sides of the operation =,<=,or < (on ints)  *)
try (rewrite -> !Z_of_intbPn);
try (rewrite -> !Z_of_intbP);
try (rewrite -> !Z_ltP);
try (rewrite -> !Z_leP);
try (rewrite -> !Z_of_intP); (* TODO: add nats here *)
(* just in case there were some trapped nats inside the goal *)
rewrite ?(PoszD,PoszM);
(* distribute Z_of_int to the leaves of the arithmetic expressions *)
rewrite ?(Z_of_intmorphN, Z_of_intmorphM, Z_of_intmorphD)
?[Z_of_int 1]/= ?[Z_of_int 0]/= ?[Z_of_int (S _)]/=;
(* somehow we obtain (is_true true) somewhere and lia dislikes it *)
repeat (rewrite [true](erefl : true = (0 < (1 : int))));
repeat (rewrite [false](erefl : false = (0 < (0 : int)))).


(*

   Benedikt Ahrens and Régis Spadotti

   Terminal semantics for codata types in intensional Martin-Löf type theory

   http://arxiv.org/abs/1401.1053

*)

(*

  Content of this file:

  definition of the category of sets, proof that it has products

*)

Require Import Theory.Category.
Require Import Theory.Product.

(*------------------------------------------------------------------------------
  -- ＣＡＴＥＧＯＲＹ  ＯＦ  ＴＹＰＥＳ
  ----------------------------------------------------------------------------*)
(** * Category of Types **)

(** ** Type category definition **)

Program Definition Hom (A B : Type) : Setoid := Setoid.make ⦃ Carrier ≔ A → B
                                                           ; Equiv   ≔ λ f g ∙ ∀ x, f x = g x ⦄.
(** equivalence **)
Next Obligation.
  constructor; hnf; simpl; [ reflexivity | now symmetry | etransitivity ; eauto ].
Qed.

Local Infix "⇒" := Hom.

Definition id {A} : A ⇒ A := λ x ∙ x.

Program Definition compose {A B C} : [ B ⇒ C ⟶ A ⇒ B ⟶ A ⇒ C ] :=
  Π₂.make (λ g f x ∙ g (f x)).
(** g-cong₂ **)
Next Obligation.
  intros f₁ f₂ eq_f₁f₂ g₁ g₂ eq_g₁g₂ x.
  now rewrite eq_f₁f₂, eq_g₁g₂.
Qed.

Local Infix "∘" := compose.

Lemma left_id A B (f : A ⇒ B) : id ∘ f ≈ f.
Proof.
  hnf ; intuition.
Qed.

Lemma right_id A B (f : A ⇒ B) : f ∘ id ≈ f.
Proof.
  hnf ; intuition.
Qed.

Lemma compose_assoc A B C D (f : A ⇒ B) (g : B ⇒ C) (h : C ⇒ D) : h ∘ g ∘ f ≈ h ∘ (g ∘ f).
Proof.
  hnf ; intuition.
Qed.

Canonical Structure 𝑻𝒚𝒑𝒆 : Category :=
  mkCategory left_id right_id compose_assoc.

(*------------------------------------------------------------------------------
  -- ＴＹＰＥＳ  ＨＡＶＥ  ＢＩＮＡＲＹ  ＰＲＯＤＵＣＴ
  ----------------------------------------------------------------------------*)
(** ** Types have binary product **)

Program Instance 𝑻𝒚𝒑𝒆_BinaryProduct : BinaryProduct 𝑻𝒚𝒑𝒆 :=
  BinaryProduct.make  ⦃ Category  ≔ 𝑻𝒚𝒑𝒆
                      ; _×_       ≔ _⟨×⟩_
                      ; ⟨_,_⟩     ≔ λ C f g (c : C) ∙ (f c , g c)
                      ; π₁        ≔ fst
                      ; π₂        ≔ snd ⦄.
(** Pmor-cong₂ **)
Next Obligation.
  intros f₁ f₂ eq_f₁f₂ g₁ g₂ eq_g₁g₂ x. now f_equal.
Qed.
(** Pmor-universal **)
Next Obligation.
  rewrite <- H. rewrite <- H0.
  remember (i x); destruct (i x); now subst.
Qed.


Require Import HoTT.

(** a characterization of the relations (dependent types over simple products)
that represent Functions.
*)

Local Open Scope path_scope.

Definition sigMap { A B : Type } ( P : A -> B -> Type )
  : { y : A * B & P (fst y) (snd y) } -> A.
Proof.
  intros [ [ a _ ] _ ].
  auto.
Defined.

Definition IsFunctional { A B : Type } ( P : A -> B -> Type )
  :=
  IsEquiv (sigMap P).

Definition underlyingFunction { A B : Type }
 ( P : A -> B -> Type )
 : ( IsFunctional P ) -> A -> B.
Proof.
  intros [ inv retr sect adj ] a.
  exact (snd (projT1 (inv a))).
Defined.

Definition valPath { A B } ( f : A -> B ) :
 A -> B -> Type :=
  fun a => fun b => ( b = f a ).

Definition valSectn { A B } ( f : A -> B ) :
  A -> { ab : A * B & (valPath f) (fst ab) (snd ab) }.
Proof.
  intro a.
  exists ( a, f a ).
  exact idpath.
Defined.

Lemma isfunc_valpath { A B } ( f : A -> B ) :
  IsFunctional (valPath f).
Proof.
  apply isequiv_adjointify with (valSectn f).
  intro.
    auto.
    intro.
    destruct x.
    destruct x as [ a b ].
    simpl in *.
    unfold valPath in v.
   assert
    ( @paths { z : B & z = f a } ( f a ; idpath ) ( b ; v ) ).
      apply path_sigma with (inverse v).
      simpl. destruct v. auto.
   refine ( transport (fun bp : { z : B & z = f a } =>
    valSectn f a = ( ( a , bp .1 ) ; bp .2 ) ) X _ ).
    exact idpath.
Defined.

Lemma htp_valpath { A B } ( f : A -> B ) :
  f == (underlyingFunction (valPath f) (isfunc_valpath f)).
Proof.
  intro. auto.
Defined.

Lemma map_valpath { A B } ( P : A -> B -> Type ) ( H : IsFunctional P ) :
  forall a b, ( valPath (underlyingFunction P H) a b ) ->  ( P a b ).
Proof.
  intros.
  destruct H as [ inv sect retr adj ].
    simpl in X.
    assert ( heq := sect a ).
    cbv in X. cbv.
    destruct (inv a) as [ [ r s ] t ].
      simpl in *. cbv.
      destruct X. destruct heq. auto.
Defined.

Lemma inv_valpath { A B } ( P : A -> B -> Type ) ( H : IsFunctional P ) :
  forall a b, (P a b) -> ( valPath (underlyingFunction P H) a b ).
Proof.
  intros.
  destruct H as [ inv sect retr adj ].
  simpl in *.
  lazy.
   set ( thePoint := @existT (A * B) (fun z => P (fst z)(snd z)) (a,b) X ).
    assert ( help := retr thePoint ).
    assert ( helq := ap snd (ap (@projT1 _ _) help ) ).
      lazy in helq.
  exact (inverse helq).
Defined.

Lemma hfibr_IsFunc { A B } ( P : A -> B -> Type ) ( H : IsFunctional P ) :
  forall a, (sigT (P a)) -> hfiber (sigMap P) a.
Proof.
  intros a [ b x ].
  exists (@existT _ (fun z => P (fst z) (snd z)) (a,b) x).
  auto.
Defined.

Lemma fibrMap_IsFunc { A B } ( P : A -> B -> Type ) ( H : IsFunctional P ) :
  forall a,  hfiber (sigMap P) a -> (sigT (P a)) .
Proof.
  intros a [ abp eq ].
  destruct abp as [ [ a' b' ] x ].
  simpl in eq. destruct eq.
  exists b'. auto.
Defined.

Lemma equiv_hfibr_IsFunc { A B } ( P : A -> B -> Type ) ( H : IsFunctional P ) :
  forall a, IsEquiv (hfibr_IsFunc P H a).
Proof.
  intros.
  apply isequiv_adjointify with (fibrMap_IsFunc P H a).
  intro.
    destruct x as [ [ [ a' b' ] p ] eq ].
    simpl in *.
    destruct eq.
    auto.
  intro.
    destruct x as [ b x ].
    auto.
Defined.

Lemma contr_IsFunc { A B } ( P : A -> B -> Type ) ( H : IsFunctional P ) :
  forall a, Contr (sigT (P a)).
Proof.
  assert ( help := fcontr_isequiv _ H ).
  intro a.
    set ( theEquiv := BuildEquiv _ _ (hfibr_IsFunc P H a) (equiv_hfibr_IsFunc P H a) ).
  refine ( contr_equiv (theEquiv ^-1)%equiv).
Defined.


Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.

Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.ZUtil.Land.
Require Import Crypto.Util.ZUtil.Testbit.
Require Import Crypto.Util.ZUtil.TwosComplement.

Require Import Crypto.Util.ZUtil.Tactics.SolveRange.

Import Notations.

Local Open Scope Z_scope.

Module Z.
  Lemma sign_bit_0_land_pow2 a m :
    Z.sign_bit m a = 0 -> a &' 2 ^ (m - 1) = 0.
  Proof.
    intros H; apply Z.shiftr_eq_0_iff in H; destruct H as [? |[? ?] ]; subst.
    - rewrite Z.land_0_l; reflexivity.
    - rewrite Z.land_pow2_testbit, Z.bits_above_log2; lia. Qed.

  Lemma sign_bit_testbit a m
        (Hm : 0 < m)
        (H : 0 <= a < 2 ^ m) :
    Z.sign_bit m a = Z.b2z (Z.testbit a (m - 1)).
  Proof.
    rewrite Z.testbit_spec', Z.mod_small, <- Z.shiftr_div_pow2 by Z.solve_range.
    reflexivity. Qed.

  Lemma sign_bit_equiv a m
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m) :
    Z.sign_bit m a = Z.b2z (negb (a <? 2 ^ (m - 1))).
  Proof. rewrite <- (Z.mod_small _ _ Ha) at 2.
         rewrite Z.twos_complement_cond_equiv, sign_bit_testbit, negb_involutive; lia. Qed.

  Lemma sign_bit_1_land_pow2 a m
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m) :
    Z.sign_bit m a <> 0 -> a &' 2 ^ (m - 1) = 2 ^ (m - 1).
  Proof.
    intros H. rewrite Z.land_pow2_testbit, Z.testbit_b2z, <- sign_bit_testbit by assumption.
    apply Z.eqb_neq in H; rewrite H; reflexivity. Qed.

  Lemma sign_bit_0_testbit a m
        (Hm : 0 < m) :
    Z.sign_bit m a = 0 -> Z.testbit a (m - 1) = false.
  Proof.
    assert (Hnz : 2 ^ (m - 1) <> 0) by (apply Z.pow_nonzero; lia).
    intro H; apply sign_bit_0_land_pow2 in H. rewrite Z.land_pow2_testbit in H;
                                                destruct (Z.testbit a (m - 1));
                                                [contradiction|reflexivity]. Qed.

  Lemma sign_bit_1_testbit a m
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m) :
    Z.sign_bit m a <> 0 -> Z.testbit a (m - 1) = true.
  Proof.
    rewrite Z.testbit_b2z, <- sign_bit_testbit by lia; intro H.
    apply Z.eqb_neq in H; rewrite H; reflexivity. Qed.
End Z.


Require Import Arith List.
Set Implicit Arguments.
Require Export Coq.Init.Datatypes.
Require Import Coq.Program.Equality.

(** * Heterogeneous Environment List
    This doesn't diverge too wildly from standard HList implemenations.
    A good reference, and the implementation this version is based on is
    http://adam.chlipala.net/cpdt/html/DataStruct.html
*)

Section envlist.
  (*Definition var := nat.
  Definition var_dec := eq_nat_decide.*)
  Inductive var : Type :=
    | VZero : var
    | VSucc : var -> var.
  Lemma var_dec : forall (a b:var), {a=b}+{a<>b}.
    intro a. induction a; intros; dependent inversion b. left; reflexivity. right. discriminate. right. discriminate.
    induction (IHa v). subst. left; reflexivity. right. intro bad. inversion bad. apply b0. auto.
  Defined.

  Definition tyenv := list (var * Set).
  Inductive tymember (x:var) (t:Set) : list (var*Set) -> Type :=
  | TFirst : forall tl, tymember x t ((x,t)::tl)
  | TLater : forall y ty tl, tymember x t tl -> tymember x t ((y,ty)::tl).
  Fixpoint tyrem (x:var) (t:Set) {l:list(var*Set)} (m:tymember x t l) : list(var*Set):=
    match m with
    | TFirst tl => tl
    | TLater y ty tl tm0 => tyrem tm0
    end.

  Inductive envlist : list (var*Set) -> Type:=
  | ENil : envlist nil
  | ECons : forall (x:var) (t:Set) (ls:list (var*Set)), t -> envlist ls -> envlist ((x,t)::ls).

  Check ECons.
  Inductive envmember : forall (x:var) (t:Set) (l:list(var*Set)), envlist l -> Type :=
  | EFirst : forall x t val l tl, @envmember x t ((x,t)::l) (ECons x val tl)
  | ELater : forall x t y ty val l tl,
                    @envmember x t _ tl ->
                    @envmember x t ((y,ty)::l) (ECons y val tl).
  Fixpoint envlookup (x:var) (t:Set) {l:list(var*Set)} (e:envlist l) (mem:envmember x t e) : t :=
    match mem with
      | EFirst _ _ v _ _ => v
      | ELater x' t' _ _ _ _ _ next => envlookup (*x' t' _ _*) next
      end.
  Print envlookup.

  (* This generates a hideous term, but fortunately we never really need to extract it. *)
  Fixpoint tymem2envmem (x:var) (t:Set) {l:list(var*Set)} (tm:tymember x t l) (e:envlist l) : envmember x t e.
  destruct tm. dependent induction e. constructor.
  dependent induction e. constructor. firstorder. Defined.

  Fixpoint envrem (x:var) (t:Set) {l:list(var*Set)} (e:envlist l) (mem:envmember x t e) (tm:tymember x t l): envlist (tyrem tm).
  destruct tm. dependent induction e; compute[tyrem]; fold tyrem; auto.
  unfold tyrem; fold tyrem.
  assert (etl : envlist tl). dependent induction e. assumption.
  eapply (envrem x t tl etl). eapply tymem2envmem. assumption.
  Defined.

  Parameter x : var.
  Check envlookup.
  Definition test : nat. refine(@envlookup x nat _ (ECons x 0 ENil) _). constructor. Defined.
  Lemma findx : test = 0. eauto. Qed.

End envlist.

Notation "'ε'" := (@nil (var*Set)).
Notation " x : t , Γ " := ((x,t)::Γ) (at level 30, right associativity).
Notation "∅" := ENil.
Notation " x ↦ v , E " := (ECons x v E) (at level 30, right associativity).

Section env_notation_tests.
  Parameter y : var. Parameter z : var.
  Check (y:nat,z:bool,ε).

  Check (y↦3,z↦true,∅).

End env_notation_tests.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Problem(s):
    Simple Semi-unification (SSemiU)
    Semi-unification (SemiU)
    Right-uniform Two-Inequality Semi-unification (RU2SemiU)
    Left-uniform Two-Inequality Semi-unification (LU2SemiU)
*)

(*
  Literature:
  [1] Andrej Dudenhefner. "Undecidability of Semi-Unification on a Napkin"
      5th International Conference on Formal Structures for Computation and Deduction (FSCD 2020): 9:1-9:16
      https://drops.dagstuhl.de/opus/volltexte/2020/12331
*)

Require Import List.

(* terms are built up from atoms and a binary term constructor arr *)
Inductive term : Set :=
  | atom : nat -> term
  | arr : term -> term -> term.

Definition valuation : Set := nat -> term.

(* substitute atoms n of a term t by (f n) *)
Fixpoint substitute (f: valuation) (t: term) : term :=
  match t with
  | atom n => f n
  | arr s t => arr (substitute f s) (substitute f t)
  end.

(* Simple Semi-unification Definition *)

(* simple semi unification constraint
  ((a, x), (y, b)) mechanizes the constraint (a|x|ϵ ≐ ϵ|y|b) *)
Definition constraint : Set := ((bool * nat) * (nat * bool)).

(* constraint semantics,
  (φ, ψ0, ψ1) models a|x|ϵ ≐ ϵ|y|b if ψa (φ (x)) = πb (φ (y)) *)
Definition models (φ ψ0 ψ1: valuation) : constraint -> Prop :=
  fun '((a, x), (y, b)) =>
    match φ y with
    | atom _ => False
    | arr s t => (if b then t else s) = substitute (if a then ψ1 else ψ0) (φ x)
    end.

(* Simple Semi-unification *)
(* are there substitutions (φ, ψ0, ψ1) that model each constraint? *)
Definition SSemiU (p : list constraint) :=
  exists (φ ψ0 ψ1: valuation), forall (c : constraint), In c p -> models φ ψ0 ψ1 c.

(* Semi-unification Definition *)

(* inequality: s ≤ t *)
Definition inequality : Set := (term * term).

(* φ solves s ≤ t, if there is ψ such that ψ (φ (s)) = φ (s) *)
Definition solution (φ : valuation) : inequality -> Prop :=
  fun '(s, t) => exists (ψ : valuation), substitute ψ (substitute φ s) = substitute φ t.

(* Semi-unification *)
(* is there a substitution φ that solves all inequalities? *)
Definition SemiU (p: list inequality) :=
  exists (φ: valuation), forall (c: inequality), In c p -> solution φ c.

(* Right-uniform Two-Inequality Semi-unification *)
(* All right-hand sides of inequalities are identical, there are exactly two inequlities *)
Definition RU2SemiU : term * term * term -> Prop :=
  fun '(s0, s1, t) => exists (φ ψ0 ψ1: valuation),
    substitute ψ0 (substitute φ s0) = substitute φ t /\ substitute ψ1 (substitute φ s1) = substitute φ t.

(* Left-uniform Two-Inequality Semi-unification *)
(* All right-hand sides of inequalities are identical, there are exactly two inequlities *)
Definition LU2SemiU : term * term * term -> Prop :=
  fun '(s, t0, t1) => exists (φ ψ0 ψ1: valuation),
    substitute ψ0 (substitute φ s) = substitute φ t0 /\ substitute ψ1 (substitute φ s) = substitute φ t1.


Require Import Coq.Relations.Relation_Definitions.

Require Import Axioms.

Require Import Tactics.
Require Import Equality.
Require Import Sigma.

Local Open Scope type_scope.

(* Ordered families of equivalences *)

Record ofe : Type :=
mk_ofe
  { car : Type;
    dist : nat -> (relation car);
    dist_eqrel : forall n, equiv car (dist n);
    dist_limeq : forall x y, (forall n, dist n x y) -> x = y;
    dist_downward : forall n x y, dist (S n) x y -> dist n x y;
    dist_zero : forall x y, dist 0 x y }.

Arguments dist {o} n x y.

Definition dist_refl (A : ofe) n := dist_eqrel A n andel.
Definition dist_trans (A : ofe) n := dist_eqrel A n anderl.
Definition dist_symm (A : ofe) n := dist_eqrel A n anderr.

Lemma dist_refl' :
  forall A n (x y : car A),
    x = y
    -> dist n x y.
Proof.
intros A n x y H.
subst y.
apply dist_refl.
Qed.

Lemma downward_leq :
  forall (A : Type) (R : nat -> relation A) m n (x y : A),
    (forall n x y, R (S n) x y -> R n x y)
    -> m <= n
    -> R n x y
    -> R m x y.
Proof.
intros A R m n x y Hdownward Hleq Hdist.
revert Hdist.
induct Hleq; auto.
Qed.

Lemma dist_downward_leq :
  forall (A : ofe) m n (x y : car A),
    m <= n
    -> dist n x y
    -> dist m x y.
Proof.
intros A m n x y Hleq Hdist.
eapply downward_leq; eauto; [].
intros; apply dist_downward; auto.
Qed.

Lemma dist_downward_pred :
  forall (A : ofe) n (x y : car A),
    dist n x y
    -> dist (pred n) x y.
Proof.
intros A n x y H.
destruct n as [| n'].
- simpl.
  apply dist_zero.

- simpl.
  apply dist_downward; auto.
Qed.

Lemma dist_if_pos :
  forall (A : ofe) n (x y : car A),
    (n > 0 -> dist n x y)
    -> dist n x y.
Proof.
intros A n x y Hdist.
destruct n as [| n].
  {
  apply dist_zero.
  }
apply Hdist.
omega.
Qed.

(* Nonexpansiveness/Contractiveness *)

Definition nonexpansive {A B : ofe} (f : car A -> car B) :=
  forall n x y, dist n x y -> dist n (f x) (f y).

Definition contractive {A B : ofe} (f : car A -> car B) :=
  forall n x y, dist n x y -> dist (S n) (f x) (f y).

Lemma ident_nonexpansive :
  forall (A : ofe),
    @nonexpansive A A (fun x => x).
Proof.
intros A n x y Hxy.
assumption.
Qed.

Lemma const_nonexpansive :
  forall (A B : ofe) (x : car B),
    @nonexpansive A B (fun _ => x).
Proof.
intros A B x.
intros n _ _ _.
apply dist_refl.
Qed.

Lemma transport_nonexpansive :
  forall A (B : A -> ofe) i a a' (x y : car (B a)) (h : a = a'),
    @dist (B a) i x y
    -> @dist (B a') i (transport h (fun z => car (B z)) x) (transport h (fun z => car (B z)) y).
Proof.
intros A B i a a' x y h Hdist.
subst a'.
cbn.
exact Hdist.
Qed.

(* not used anywhere *)
Lemma transport_noncontractive :
  forall A (B : A -> ofe) i a a' (x y : car (B a)) (h : a = a'),
    dist i (transport h (fun z => car (B z)) x) (transport h (fun z => car (B z)) y)
    -> dist i x y.
Proof.
intros A B i a a' x y h H.
subst a'.
auto.
Qed.

Lemma compose_ne_ne :
  forall (A B C : ofe) f g,
    @nonexpansive B C f
    -> @nonexpansive A B g
    -> nonexpansive (fun x => f (g x)).
Proof.
intros A B C f g Hnef Hneg.
intros n x y Hxy.
so (Hneg _#3 Hxy) as Hgxy.
so (Hnef _#3 Hgxy) as Hfgxy.
exact Hfgxy.
Qed.

(* Convergence *)

Definition convergent {A : Type} (d : nat -> relation A) (f : nat -> A) :=
  forall n, d n (f n) (f (S n)).

Lemma convergent_leq_gen :
  forall A (R : nat -> relation A) f,
    (forall n, equiv _ (R n))
    -> (forall n x y, R (S n) x y -> R n x y)
    -> convergent R f
    -> forall m n, m <= n -> R m (f m) (f n).
Proof.
intros A R f Hequiv Hdownward Hconv m n Hleq.
induct Hleq.

(* eq *)
{
apply (Hequiv _ andel).
}

(* S *)
{
intros n Hleq IH.
apply (Hequiv m anderl _ (f n)); auto; [].
eapply downward_leq; eauto.
}
Qed.

Lemma convergent_leq :
  forall A f,
    convergent (@dist A) f
    -> forall m n, m <= n -> dist m (f m) (f n).
Proof.
intros A f Hconv m n Hleq.
apply convergent_leq_gen; auto.
- auto using dist_eqrel.

- auto using dist_downward.
Qed.

Lemma const_convergent :
  forall A x,
    convergent (@dist A) (fun _ => x).
Proof.
intros A x.
intros n.
apply dist_refl; done.
Qed.

Lemma map_convergent_prim :
  forall (A B : Type) (d : nat -> relation A) (d' : nat -> relation B) (ch : nat -> A) (f : A -> B),
    (forall n x y, d n x y -> d' n (f x) (f y))
    -> convergent d ch
    -> convergent d' (fun i => f (ch i)).
Proof.
intros A B d d' ch f Hne Hconv.
intro i.
apply Hne; [].
apply Hconv.
Qed.

Lemma map_convergent :
  forall (A B : ofe) (ch : nat -> car A) (f : car A -> car B),
    nonexpansive f
    -> convergent (@dist A) ch
    -> convergent (@dist B) (fun i => f (ch i)).
Proof.
intros A B ch f Hne Hconv.
eapply map_convergent_prim; eauto.
Qed.

(* Limits *)

(* It's convenient to require that cofes be nonempty, since they are easier
   to work with, and all the cofes we consider are nonempty anyway.

   Now that I've embraced the description axiom, I would probably state
   completeness more conveniently, as an existence statement in Prop.
   Maybe change it if I ever make serious use of completeness.
*)
Record complete (A : ofe) : Type :=
mk_complete
  { limit : forall ch, convergent dist ch -> car A;
    inhabitant : car A;

    complete_dist : forall ch n (p : convergent dist ch), dist n (limit ch p) (ch n) }.

Arguments limit {A} c.
Arguments inhabitant {A} c.

(* Give limit a less-awful interface. *)
Definition limits {A : ofe} (ch : nat -> car A) (x : car A) :=
  forall n,
    dist n (ch n) x.

Lemma limits_to_limit :
  forall (A : ofe) (C : complete A) (ch : nat -> car A) (x : car A),
    limits ch x
    -> forall p, limit C ch p = x.
Proof.
intros A C ch x Hlimits Hconv.
apply dist_limeq; [].
intro n.
eapply dist_trans.
  - apply complete_dist.

  - apply Hlimits.
Qed.

Lemma limit_to_limits :
  forall (A : ofe) (C : complete A) (ch : nat -> car A) (p : convergent (@dist A) ch),
    limits ch (limit C ch p).
Proof.
intros A C ch p.
intro n.
apply dist_symm; [].
apply complete_dist.
Qed.

Lemma limits_unique :
  forall (A : ofe) (ch : nat -> car A) (x y : car A),
    limits ch x
    -> limits ch y
    -> x = y.
Proof.
intros A ch x y Hlimx Hlimy.
apply dist_limeq; [].
intro n.
eapply dist_trans.
- apply dist_symm; [].
  apply Hlimx.

- apply Hlimy.
Qed.

Lemma limits_const :
  forall (A : ofe) (x : car A),
    limits (fun i => x) x.
Proof.
intros A x.
intro n.
apply dist_refl.
Qed.

Lemma limits_truncate :
  forall (A : ofe) (ch : nat -> car A) (x : car A) n,
    limits ch x
    -> limits (fun i => ch (Nat.add n i)) x.
Proof.
intros A ch x n Hlim.
intro i.
apply (dist_downward_leq _ i (n+i)).
- omega.

- apply Hlim.
Qed.

(* We could strengthen this lemma (eliminate the convergent requirement)
   if we weakened the definition of limits to permit slower convergence.
   But the stronger convergence is awfully convenient, and this isn't unworkable.
*)
Lemma limits_prepend :
  forall (A : ofe) (C : complete A) (ch : nat -> car A) (x : car A) n,
    convergent (@dist A) ch
    -> limits (fun i => ch (n + i)%nat) x
    -> limits ch x.
Proof.
intros A C ch x n Hconv Hlim.
so (limit_to_limits _ C _ Hconv) as Hlim'.
so (limits_truncate _#3 n Hlim') as Hlim''.
so (limits_unique _#4 Hlim Hlim'').
subst x.
exact Hlim'.
Qed.

Lemma limits_convergent :
  forall (A : ofe) (ch : nat -> car A) (x : car A),
    limits ch x
    -> convergent (@dist A) ch.
Proof.
intros A ch x Hlim.
intro i.
apply (dist_trans _ _ _ x).
- apply Hlim.

- apply dist_symm; [].
  apply dist_downward; [].
  apply Hlim.
Qed.

Lemma ofe_fixpoint :
  forall (A : ofe) (C : complete A) (f : car A -> car A),
    contractive f
    -> existsT! (x : car A), f x = x.
Proof.
intros A C f Hcontract.
set (ch := @nat_rect (fun _ => car A) (inhabitant C) (fun _ x => f x)).
assert (convergent (@dist A) ch) as p.
  {
  intros i.
  induct i.
  - apply dist_zero.

  - intros i IH.
    simpl.
    apply Hcontract; [].
    exact IH.
  }
exists (limit C ch p).
assert (f (limit C ch p) = limit C ch p) as Hfix.
  {
  so (limit_to_limits A C ch p) as Hlimits.
  apply (limits_unique _ ch); auto; [].
  apply (limits_prepend _ C _ _ 1); auto; [].
  simpl.
  intro i.
  apply dist_downward; [].
  apply Hcontract; [].
  apply Hlimits.
  }
split; auto; [].
intros y Hfix'.
apply dist_limeq; [].
intro i.
induct i.
- apply dist_zero.

- intros i IH.
  rewrite <- Hfix; [].
  rewrite <- Hfix'; [].
  apply Hcontract.
  assumption.
Qed.

(* Nonexpansive function space *)

Definition nearrow (A B : ofe) : Type := exT (car A -> car B) (@nonexpansive A B).

Notation "A -n> B" := (nearrow A B)
  (at level 99, right associativity) : ofe_scope.

Open Scope ofe_scope.

Definition nearrow_const (A : ofe) (B : ofe) (x : car B) : A -n> B :=
  expair (fun _ => x) (const_nonexpansive A B x).

Definition idne {A : ofe} : A -n> A := expair _ (ident_nonexpansive A).

Definition dist_ne {A B : ofe} n (f g : A -n> B) := forall x, dist n (pi1 f x) (pi1 g x).

Definition limit_ne {A B : ofe} (C : complete B) :
  forall ch, convergent (@dist_ne A B) ch -> A -n> B.
Proof.
intros f Hconv.
exists (fun x : car A => limit C (fun i => pi1 (f i) x) (fun n => Hconv n x)).
intros n x y Hdist.
apply (dist_trans B n _ (pi1 (f n) x)).
- so (complete_dist B C _ n (fun n => Hconv n x)) as H.
  simpl in H.
  exact H.

- apply (dist_trans B n _ (pi1 (f n) y)).
  + so (pi2 (f n)) as Hne.
    exact (Hne n x y Hdist).

  + apply (dist_symm B n); [].
    so (complete_dist B C _ n (fun n => Hconv n y)) as H.
    simpl in H.
    exact H.
Defined.

Lemma nearrow_extensionality :
  forall A B (f g : A -n> B),
    (forall x, pi1 f x = pi1 g x)
    -> f = g.
Proof.
intros A B f g H.
apply exT_extensionality_prop.
fextensionality 1.
exact H.
Qed.

Lemma nearrow_extensionality_dep :
  forall A (B : A -> ofe) (C : ofe) (a a' : A) (f : B a -n> C) (g : B a' -n> C),
    eq_dep A (fun a => car (B a) -> car C) a (pi1 f) a' (pi1 g)
    -> eq_dep A (fun a => B a -n> C) a f a' g.
Proof.
intros A B C a a' f g Heq.
so (eq_dep_impl_eq_fst _#6 Heq); subst a'.
so (eq_dep_impl_eq_snd _#5 Heq) as Heq'.
apply eq_impl_eq_dep_snd.
apply exT_extensionality_prop; auto.
Qed.

Definition nearrow_ofe (A B : ofe) : ofe.
Proof.
apply
  (mk_ofe
     (A -n> B)
     (@dist_ne A B)).

(* eqrel *)
{
intro n.
do2 2 split.
+ intros f x.
  apply (dist_refl B n).

+ intros f g h Hfg Hgh x.
  eapply (dist_trans B n); eauto.

+ intros f g H x.
  apply (dist_symm B n); [].
  apply H.
}

(* limeq *)
{
intros f g Hsim.
destruct f as [f Hnef].
destruct g as [g Hneg].
cut (f = g).
  {
  intro.
  subst g.
  f_equal; [].
  apply proof_irrelevance.
  }
apply functional_extensionality; [].
intro x.
apply (dist_limeq B); [].
intro n.
exact (Hsim n x).
}

(* downward *)
{
intros n f g Hdist.
intro x.
apply (dist_downward B); [].
exact (Hdist x).
}

(* zero *)
{
intros f g x.
apply dist_zero.
}
Defined.

Definition nearrow_complete (A : ofe) (B : ofe) (C : complete B) : complete (nearrow_ofe A B).
Proof.
apply
  (mk_complete (nearrow_ofe A B)
     (@limit_ne A B C)
     (expair (fun _ => inhabitant C) (const_nonexpansive _ _ _))).
intros f n Hconv.
intro x.
cbn.
apply (complete_dist B).
Defined.

Definition nearrow_id (A : ofe) : A -n> A :=
  expair _ (ident_nonexpansive A).

Definition nearrow_compose {A B C : ofe} (f : B -n> C) (g : A -n> B) : A -n> C :=
  expair _ (compose_ne_ne A B C (pi1 f) (pi1 g) (pi2 f) (pi2 g)).

Lemma nearrow_compose_id_left :
  forall A B (f : A -n> B),
    nearrow_compose (nearrow_id B) f = f.
Proof.
intros A B f.
destruct f as [f Hne].
unfold nearrow_compose.
f_equal; [].
apply proof_irrelevance; done.
Qed.

Lemma nearrow_compose_id_right :
  forall A B (f : A -n> B),
    nearrow_compose f (nearrow_id A) = f.
Proof.
intros A B f.
destruct f as [f Hne].
unfold nearrow_compose.
f_equal; [].
apply proof_irrelevance; done.
Qed.

Lemma nearrow_compose_assoc :
  forall A B C D (f : C -n> D) (g : B -n> C) (h : A -n> B),
    nearrow_compose (nearrow_compose f g) h = nearrow_compose f (nearrow_compose g h).
Proof.
intros A B C D f g h.
destruct f as [f Hnef].
destruct g as [g Hneg].
destruct h as [h Hneh].
unfold nearrow_compose; simpl.
f_equal; [].
apply proof_irrelevance.
Qed.

Lemma nearrow_compose_nonexpansive :
  forall A B C n (f f' : B -n> C) (g g' : A -n> B),
    dist_ne n f f'
    -> dist_ne n g g'
    -> dist_ne n (nearrow_compose f g) (nearrow_compose f' g').
Proof.
intros A B C n f f' g g' Hdistf Hdistg.
intro x.
simpl.
destruct f as [f Hnef].
destruct f' as [f' Hnef'].
destruct g as [g Hneg].
destruct g' as [g' Hneg'].
simpl.
apply (dist_trans C n _ (f' (g x))).
- apply Hdistf; done.

- apply Hnef'; [].
  apply Hdistg; done.
Qed.

Definition composer (A B C : ofe) (f : B -n> C) : nearrow_ofe A B -n> nearrow_ofe A C.
Proof.
exists (fun g => nearrow_compose f g).
intros n g g' Hg.
refine (nearrow_compose_nonexpansive _#8 _ Hg).
apply (@dist_refl (nearrow_ofe B C)).
Defined.

Lemma eq_nearrow_ne :
  forall (A B : ofe) (h : A = B),
    nonexpansive (fun x => transport h car x).
Proof.
intros A B h.
subst B.
apply ident_nonexpansive.
Qed.

Definition eq_nearrow {A B : ofe} (h : A = B) : A -n> B
  :=
  expair (fun x => transport h car x) (eq_nearrow_ne A B h).

Definition transport_ne {A} {a a' : A} (h : a = a') (B : A -> ofe)
  : B a -n> B a'
  :=
  @expair
    _ (@nonexpansive (B a) (B a'))
    (fun x => transport h (fun z => car (B z)) x)
    (fun i m n Hdist => transport_nonexpansive A B i a a' m n h Hdist).

Definition dep_transport_ne {A} {a a' : A} (h : a = a')
  (B : A -> Type)
  (C : forall a, B a -> ofe)
  (b : B a)
  : C a b -n> C a' (transport h B b)
  :=
  match h
    as h
    in _ = a'
    return C a b -n> C a' (transport h B b)
  with
  | eq_refl _ => idne
  end.

Definition dep_transport_ne' {A} {a a' : A} (h : a = a')
  (B : A -> Type)
  (C : forall a, B a -> ofe)
  (b : B a)
  : C a' (transport h B b) -n> C a b
  :=
  match h
    as h
    in _ = a'
    return C a' (transport h B b) -n> C a b
  with
  | eq_refl _ => idne
  end.

(* We could reuse nearrow_compose, but it seems cleaner to do it directly. *)
Definition nearrow_compose2 {A B C D : ofe} (f : A -n> B) (h : C -n> D)
  (g : B -n> C) : A -n> D.
Proof.
refine (expair (fun x => pi1 h (pi1 g (pi1 f x))) _).
intros n x y Hxy.
apply (pi2 h).
apply (pi2 g).
apply (pi2 f); auto.
Defined.

Lemma nearrow_compose2_nonexpansive :
  forall A B C D (f : A -n> B) (h : C -n> D),
    @nonexpansive (nearrow_ofe B C) (nearrow_ofe A D) (nearrow_compose2 f h).
Proof.
intros A B C D f h.
intros n g g' Hg.
cbn.
intros x.
cbn.
apply (pi2 h).
apply Hg.
Qed.

Definition nearrow_compose2_ne {A B C D : ofe} (f : A -n> B) (h : C -n> D)
  : nearrow_ofe B C -n> nearrow_ofe A D
  :=
  expair (nearrow_compose2 f h) (nearrow_compose2_nonexpansive _#4 f h).

Lemma nearrow_compose2_compose :
  forall (A B C D E F : ofe)
    (f1 : A -n> B) (f2 : B -n> C) (g : C -n> D) (h2 : D -n> E) (h1 : E -n> F),
      nearrow_compose2 f1 h1 (nearrow_compose2 f2 h2 g)
      =
      nearrow_compose2 (nearrow_compose f2 f1) (nearrow_compose h1 h2) g.
Proof.
intros A B C D E F f1 f2 g h2 h1.
apply nearrow_extensionality.
intro x.
cbn.
reflexivity.
Qed.

Lemma nearrow_compose2_split :
  forall A B C D (f : C -n> D) (g : B -n> C) (h : A -n> B),
    nearrow_compose2 h f g
    =
    nearrow_compose f (nearrow_compose g h).
Proof.
intros A B C D f g h.
apply nearrow_extensionality.
intro x.
cbn.
reflexivity.
Qed.

(* Product spaces *)

Definition dist_prod {A B : ofe} n (p q : car A * car B) :=
  dist n (fst p) (fst q) /\ dist n (snd p) (snd q).

Definition prod_ofe (A B : ofe) : ofe.
Proof.
apply (mk_ofe (car A * car B) (@dist_prod A B)).

(* eqrel *)
{
intro n.
do2 2 split.
+ intros (x, y).
  split; apply dist_refl.

+ intros (x1, y1) (x2, y2) (x3, y3) H12 H23.
  destruct H12 as (H12x, H12y).
  destruct H23 as (H23x, H23y).
  split; eapply dist_trans; eauto.

+ intros (x1, y1) (x2, y2) H.
  destruct H as (Hx, Hy).
  split; eapply dist_symm; eauto.
}

(* limeq *)
{
intros (x, y) (x', y') Hsim.
f_equal.
+ apply dist_limeq; [].
  intro n.
  destruct (Hsim n); auto.

+ apply dist_limeq; [].
  intro n.
  destruct (Hsim n); auto.
}

(* downward *)
{
intros n (x, y) (x', y') Hdist.
destruct Hdist.
split; apply dist_downward; eauto.
}

(* zero *)
{
intros (x, y) (x', y').
split; apply dist_zero.
}
Defined.

Definition pair_ne {A B C : ofe} (f : A -n> B) (g : A -n> C)
  : A -n> prod_ofe B C.
Proof.
exists (fun x => (pi1 f x, pi1 g x)).
exact (fun n x y H => conj (pi2 f n x y H) (pi2 g n x y H)).
Defined.

Definition fst_ne {A B : ofe} : prod_ofe A B -n> A.
Proof.
exists fst.
intros n x y Hxy.
exact (Hxy andel).
Defined.

Definition snd_ne {A B : ofe} : prod_ofe A B -n> B.
Proof.
exists snd.
intros n x y Hxy.
exact (Hxy ander).
Defined.

Definition mpair_ne {A B C D : ofe} (f : A -n> C) (g : B -n> D)
  : prod_ofe A B -n> prod_ofe C D.
Proof.
exists (fun x => (pi1 f (fst x), pi1 g (snd x))).
exact (fun n x y H => conj (pi2 f n _ _ (carp H)) (pi2 g n _ _ (cdrp H))).
Defined.

Lemma dist_prod_fst :
  forall A B n (p q : car (prod_ofe A B)),
    dist n p q
    -> dist n (fst p) (fst q).
Proof.
intros A B n p q Hdist.
destruct Hdist.
auto.
Qed.

Lemma dist_prod_snd :
  forall A B n (p q : car (prod_ofe A B)),
    dist n p q
    -> dist n (snd p) (snd q).
Proof.
intros A B n p q Hdist.
destruct Hdist.
auto.
Qed.

Definition limit_prod (A B : ofe) (C : complete A) (D : complete B) :
  forall ch, convergent (@dist_prod A B) ch -> car A * car B.
Proof.
intros ch Hconv.
split.
  {
  refine (limit C (fun i => fst (ch i)) _); [].
  eapply map_convergent_prim; eauto; [].
  intros n p q Hdist.
  destruct Hdist; auto.
  }

  {
  refine (limit D (fun i => snd (ch i)) _); [].
  eapply map_convergent_prim; eauto; [].
  intros n p q Hdist.
  destruct Hdist; auto.
  }
Defined.

Definition prod_complete (A B : ofe) (C : complete A) (D : complete B) : complete (prod_ofe A B).
Proof.
apply (mk_complete (prod_ofe A B) (limit_prod A B C D) (inhabitant C, inhabitant D)).
intros ch n Hconv.
so (Hconv n) as (H1 & H2).
split.
+ apply complete_dist.

+ apply complete_dist.
Defined.

Definition unit_ofe : ofe.
Proof.
apply
  (mk_ofe
     unit
     (fun _ _ _ => True)).

- do2 2 split; intro; auto.

- intros x y _.
  destruct x; destruct y.
  reflexivity.

- auto.

- auto.
Defined.

Definition unit_complete : complete unit_ofe.
Proof.
apply
  (mk_complete unit_ofe
     (fun _ _ => tt)
     tt).
intros ch n _.
set (x := ch n).
destruct x.
apply dist_refl.
Defined.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. lfind.  reflexivity.
Admitted.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite rev_rev. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite rev_append. simpl. rewrite (eq_refl : Cons n Nil = rev (Cons n Nil)). rewrite IHx. rewrite rev_rev. simpl. reflexivity.
Qed.


Require Export Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.SubsT.

(* If one type subsumes another, and we substitute some third
   type into both, then the results are also subsumptive.

   NOTE: The more general form where t1 and t2 are open should also
         be true, but we don't need it for the main proofs.
*)
Lemma subsT_closed_liftT_liftT
 :  forall sp t1 t2 k d
 ,  SubsT nil sp t1 t2 k
 -> SubsT nil sp (liftTT 1 d t1) (liftTT 1 d t2) k.
Proof.
 intros.
 have (ClosedT t1).
 have (ClosedT t2).
 rrwrite (liftTT 1 d t1 = t1).
 rrwrite (liftTT 1 d t2 = t2).
 auto.
Qed.
Hint Resolve subsT_closed_liftT_liftT.


Require Import Rbase MyRIneq.
Require Import Rsequence_def Rsequence_facts Rsequence_cv_facts.

Require Import List.
Require Import Option.
Require Import Ass_handling.

(* Reifications of sequences, limits and being the limit of a
   particular sequence. *)

Inductive rseq :=
  | rseq_cst   : forall (r : R), rseq
  | rseq_var   : forall (n : nat), rseq
  | rseq_opp   : forall (r : rseq), rseq
  | rseq_plus  : forall (rl rr : rseq), rseq
  | rseq_minus : forall (rl rr : rseq), rseq.

Inductive rseq_limit :=
  | minus_inf : rseq_limit
  | finite : forall (l : R), rseq_limit
  | plus_inf : rseq_limit.

Definition is_limit r l := match l with
  | minus_inf => Rseq_cv_neg_infty r
  | finite l => Rseq_cv r l
  | plus_inf => Rseq_cv_pos_infty r
end.

(* Two extensionally equal sequences have the same limit. *)

Lemma is_limit_ext : forall r s k l,
  is_limit r k ->
  r == s -> k = l ->
  is_limit s l.
Proof.
intros r s k [] Hrk Hrs Hkl ;
 [ eapply Rseq_cv_neg_infty_eq_compat
 | eapply Rseq_cv_eq_compat ; [symmetry |]
 | eapply Rseq_cv_pos_infty_eq_compat ]
 ; subst ; eassumption.
Qed.

Definition Rseq_with_limit := {r : Rseq & {l : rseq_limit | is_limit r l}}.

Definition rseq_limit_opp l := match l with
  | minus_inf => plus_inf
  | finite u  => finite (- u)
  | plus_inf  => minus_inf
end.

Lemma rseq_limit_opp_is_limit : forall r l,
  is_limit r l ->
  is_limit (- r) (rseq_limit_opp l).
Proof.
intros r [] Hl ; simpl ;
 [ apply Rseq_cv_neg_infty_opp_compat
 | apply Rseq_cv_opp_compat
 | apply Rseq_cv_pos_infty_opp_compat] ;
 assumption.
Qed.

Definition rseq_limit_add ll lr := match ll, lr with
  | minus_inf, plus_inf  => None
  | plus_inf , minus_inf => None
  | minus_inf, _         => Some minus_inf
  | _        , minus_inf => Some minus_inf
  | plus_inf , _         => Some plus_inf
  | _        , plus_inf  => Some plus_inf
  | finite u , finite v  => Some (finite (u + v))
end.

Fixpoint comp_limit (r : rseq) (env : list Rseq_with_limit) : option rseq_limit :=
match r with
  | rseq_cst r => Return (finite r)
  | rseq_var n => Bind (nth_error env n) (fun x => Return (proj1_sig (projT2 x)))
  | rseq_opp r => Bind (comp_limit r env) (fun l => Some (rseq_limit_opp l))
  | rseq_plus rl rr => Bind (comp_limit rl env) (fun ll =>
                       Bind (comp_limit rr env) (fun lr => rseq_limit_add ll lr))
  | rseq_minus rl rr => Bind (comp_limit rl env) (fun ll =>
                        Bind (comp_limit rr env) (fun lr => rseq_limit_add ll (rseq_limit_opp lr)))
end.

Fixpoint comp_rseq (r : rseq) (env : list Rseq_with_limit) := match r with
  | rseq_cst r => Return (Rseq_constant r)
  | rseq_var n => Bind (nth_error env n) (fun un => Some (projT1 un))
  | rseq_opp r => Bind (comp_rseq r env) (fun un => Some (Rseq_opp un))
  | rseq_plus rl rr => Bind (comp_rseq rl env) (fun un =>
                       Bind (comp_rseq rr env) (fun vn => Some (Rseq_plus un vn)))
  | rseq_minus rl rr => Bind (comp_rseq rl env) (fun un =>
                       Bind (comp_rseq rr env) (fun vn => Some (Rseq_minus un vn)))
end.

Ltac fold_is_limit := match goal with
  | |- Rseq_cv ?r ?l => fold (is_limit r (finite l))
  | |- Rseq_cv_neg_infty ?r => fold (is_limit r minus_inf)
  | |- Rseq_cv_pos_infty ?r => fold (is_limit r plus_inf)
end.

Lemma comp_rseq_limit_compat : forall r env un l,
  comp_rseq r env = Some un ->
  comp_limit r env = Some l ->
  is_limit un l.
Proof.
intros r env ; induction r ; intros un l Hun Hl ; simpl in *.
 inversion Hun ; inversion Hl ; apply Rseq_constant_cv.
 destruct (nth_error env n) as [Hget |].
  inversion Hun ; inversion Hl ; apply (proj2_sig (projT2 Hget)).
  inversion Hl.
 destruct (comp_rseq r env) as [vn |] ; [| inversion Hun] ;
  destruct (comp_limit r env) as [lo |] ; [| inversion Hl] ;
  inversion Hun ; inversion Hl.
  apply rseq_limit_opp_is_limit, IHr ; reflexivity.
 destruct (comp_rseq r1 env) as [vn |] ; [| inversion Hun] ;
  destruct (comp_limit r1 env) as [ll |] ; [| inversion Hl] ;
  destruct (comp_rseq r2 env) as [wn |] ; [| inversion Hun] ;
  destruct (comp_limit r2 env) as [lr |] ; [| inversion Hl].
   destruct ll ; destruct lr ; inversion Hun ; inversion Hl ;
   subst.
    apply Rseq_cv_neg_infty_plus_compat ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_neg_infty_l ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_neg_infty_r ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_plus_compat ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_pos_infty_r ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_pos_infty_l ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    apply Rseq_cv_pos_infty_plus_compat ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
 destruct (comp_rseq r1 env) as [vn |] ; [| inversion Hun] ;
  destruct (comp_limit r1 env) as [ll |] ; [| inversion Hl] ;
  destruct (comp_rseq r2 env) as [wn |] ; [| inversion Hun] ;
  destruct (comp_limit r2 env) as [lr |] ; [| inversion Hl].
   inversion Hun ; eapply (is_limit_ext (Rseq_plus vn (Rseq_opp wn))) ;
    [| intro n ; unfold Rseq_plus, Rseq_minus, Rseq_opp ; ring | reflexivity].
   destruct ll ; destruct lr ; inversion Hl ; subst.
    apply Rseq_cv_finite_plus_neg_infty_l with (- l0)%R ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp (finite l0)) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_neg_infty_plus_compat ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp plus_inf) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_finite_plus_pos_infty_r with l0 ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp minus_inf) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_plus_compat ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp (finite l1)) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_neg_infty_r ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp plus_inf) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_pos_infty_plus_compat ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp minus_inf) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_finite_plus_pos_infty_l with (- l0)%R ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp (finite l0)) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
Qed.

Definition rseq_precondition r env un l :=
match comp_rseq r env with
  | None    => False
  | Some vn =>
  match comp_limit r env with
    | None => False
    | Some v => (un == vn) /\ (l = v)
  end
end.

Lemma tactic_correctness : forall r env un l,
   rseq_precondition r env un l ->
   is_limit un l.
Proof.
unfold rseq_precondition ; intros r env un l ;
 destruct_eq (comp_rseq r env) ;
 destruct_eq (comp_limit r env) ;
 intros [].
 intros ; eapply is_limit_ext ;
  [ eapply comp_rseq_limit_compat | |] ;
  symmetry ; eassumption.
Qed.

(*

Section Test.

Ltac add_var v l :=
  let rec aux v l n := match l with
    | nil       => constr: (n , v :: nil)
    | v  :: _   => constr: (n , l)
    | ?a :: ?tl => match aux v tl (S n) with | (?m , ?tl') => constr: (m , cons a tl') end
    end in
  aux v l O.

Ltac known_limit An := match goal with
  | [ H: is_limit An ?a |- _ ] => constr: (Some (An , a , H))
  | _                          => constr: (None  )
end.

Ltac reify_rseq_aux f l := match f with
  | Rseq_constant ?v  => constr: (rseq_cst v , l)
  | Rseq_opp  ?un     =>
        match reify_rseq_aux un l  with | (?UN , ?l1) => constr: (rseq_opp UN , l1) end
  | Rseq_plus ?un ?vn =>
        match reify_rseq_aux un l  with | (?UN , ?l1) =>
        match reify_rseq_aux vn l1 with | (?VN , ?l2) => constr: (rseq_plus UN VN , l2) end end
  | Rseq_minus ?un ?vn =>
        match reify_rseq_aux un l  with | (?UN , ?l1) =>
        match reify_rseq_aux vn l1 with | (?VN , ?l2) => constr: (rseq_minus UN VN , l2) end end
  | ?An =>
        match known_limit An with | None => fail | Some ?a =>
        match add_var a l with | (?A , ?l1) => constr: (rseq_var A , l1) end end
end.

Check tactic_correctness.

Ltac reify_rseq := match goal with
  | |- Rseq_cv ?f ?l =>
        match reify_rseq_aux f (@nil Rseq_with_limit) with | (?r , ?env) =>
        change (is_limit f (finite l)) end end.

Variable Un Vn : Rseq.
Variable u  v  : R.

Hypothesis Un_cv : Rseq_cv Un u.
Hypothesis Vn_cv : Rseq_cv Vn v.

Goal Rseq_cv Un u.
Proof.
fold (is_limit Un (finite u)) in *.
fold (is_limit Vn (finite v)) in *.
reify_rseq.
  apply (tactic_correctness (rseq_var 0) (Un :: nil) Un (finite u)).

  with (r := r) (env := env)
 eapply tactic_correctness.
*)


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

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.

Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.Combinatorics.FiniteSets.

Local Open Scope cat.
Local Open Scope stn.

(** * Standard graphs and diagrams.

    Contents
    1. Graphs
    2. Diagram constructors
    3. Cocone constructors

 *)

Section graphs.
  (**
   1. Graphs.
   *)

  Definition empty_graph : graph
    := make_graph empty (λ _ _, empty).

  Definition unit_graph : graph
    := make_graph unit (λ _ _, empty).

  (* The graph with two verticies, true and false, no edges. *)
  Definition bool_graph : graph
    := make_graph bool (λ _ _, empty).

    (* The interval graph: true ---tt---> false *)
  Definition interval_graph : graph.
  Proof.
    use make_graph.
    - exact bool.
    - intros a b.
      induction a; induction b.
      + exact empty.
      + exact unit.             (* true --> false *)
      + exact empty.
      + exact empty.
  Defined.

  (* (● 1) <------ (● 0) ------> (● 2) *)
  Definition span_graph : graph.
  Proof.
    use make_graph.
    - exact three.
    - use three_rec.
      + apply three_rec.
        * exact empty.
        * exact unit.
        * exact unit.
      + exact(λ _, empty).
      + exact(λ _, empty).
  Defined.

  (* X as verticies, no edges. *)
  Definition discrete_graph (X : UU) : graph
    := make_graph X (λ _ _, empty).

  (* The graph with two verticies: (● 0) and (● 1),
     and X as edges from (● 0) to (● 1), no other edges.

     Input \mdlgblkcircle for ●, or use (stnpr 0) and (stnpr 1) *)

  Definition parallell_graph (X : UU) : graph.
  Proof.
    use make_graph.
    - exact two.
    - use two_rec_dep.
      + exact(two_rec empty X).
      + exact(λ _, empty).
  Defined.

  Definition parallell_start {X : UU}
    : vertex (parallell_graph X)
    := (● 0).

  Definition parallell_end {X : UU}
    : vertex (parallell_graph X)
    := (● 1).

  Definition parallell_edge {X : UU}
    (e : X)
    : @edge (parallell_graph X) parallell_start parallell_end
    := e.

  (* Two parallell edges, pair_left, pair_right : : pair_src --> pair_end. *)

  Definition pair_graph : graph
    := parallell_graph (unit ⨿ unit).

  Definition pair_src : vertex pair_graph
    := (● 0).

  Definition pair_dst : vertex pair_graph
    := (● 1).

  Definition pair_left : @edge pair_graph pair_src pair_dst
    := inl tt.

  Definition pair_right : @edge pair_graph pair_src pair_dst
    := inr tt.

  (* Multi span: One base vertex (inr tt) and X verticies
     with one unique edge from the base each, no other edges. *)
  Definition multispan_graph (X : UU) : graph.
  Proof.
    use make_graph.
    - exact(X ⨿ unit).          (* inr tt is the base point. *)
    - use coprod_rect.
      + exact(λ _ _, empty).    (* No edges x --> unit *)
      + apply unit_rect.
        apply coprod_rect.
        * exact(λ _, unit).     (* One edge unit --> x *)
        * exact(λ _, empty).    (* No edge unit --> unit *)
  Defined.

  Definition multispan_vertex {X : UU}
    (x : X)
    : vertex (multispan_graph X)
    := (inl x).

  Definition multispan_base {X : UU}
    : vertex (multispan_graph X)
    := (inr tt).

  Definition multispan_edge {X : UU}
    (x : X)
    : edge multispan_base (multispan_vertex x)
    := tt.

End graphs.

Section diagrams.
  (**
   2. Diagram constructors.
   *)

  Definition make_empty_diagram {C : category}
    : diagram empty_graph C
    := make_diagram
         (fromempty : vertex empty_graph -> C)
         (λ _ _, fromempty).

  Definition make_unit_diagram {C : category}
    (point : C)
    : diagram unit_graph C.
  Proof.
    use make_diagram.
    - exact(unit_rect _ point).
    - exact(λ _ _, empty_rect _).
  Defined.

  Definition make_bool_diagram {C : category}
    (a b : C)
    : diagram bool_graph C.
  Proof.
    use make_diagram.
    - exact(bool_rect _ a b).
    - intros *; exact fromempty.
  Defined.

  Definition make_interval_diagram {C : category}
    (x : C)
    (y : C)
    (f : x --> y)
    : diagram interval_graph C.
  Proof.
    use make_diagram.
    - exact(bool_rect _ x y).
    - intros a b; destruct a, b; try (exact fromempty).
      exact(λ _ , f).
  Defined.

  Definition make_span_diagram {C : category }
    (a b c : C)
    (f : C ⟦a, b⟧)
    (g : C⟦a, c⟧)
    : diagram span_graph C.
  Proof.
    use make_diagram.
    - exact(three_rec a b c).
    - use three_rec_dep; use three_rec_dep; try exact(empty_rect _).
      + exact(unit_rect _ f).
      + exact(unit_rect _ g).
  Defined.

  Definition make_discrete_diagram {J : category} {X : UU}
    (objects : X -> J)
    : diagram (discrete_graph X) J.
  Proof.
    use make_diagram.
    - exact objects.
    - exact(λ _ _, empty_rect _).
  Defined.

  (* Given any diagram we can obtain a new diagram, forgetting the edges in the original graph. *)
  Definition make_discrete_diagram' {J : category}
    {g : graph}
    (d : diagram g J)
    : diagram (discrete_graph (vertex g)) J.
  Proof.
    use make_diagram.
    - exact(dob d).
    - exact(λ _ _, empty_rect _).
  Defined.

  Definition make_parallell_diagram {C : category}
    (X : UU)
    (x y : C)
    (f : ∏ (t : X), x --> y)
    : diagram (parallell_graph X) C.
  Proof.
    use make_diagram.
    - exact(two_rec x y).
    - use two_rec_dep.
      + use(two_rec_dep _ (empty_rect _) f).
      + exact(λ _, empty_rect _).
  Defined.

  Definition make_pair_diagram {C : category}
    (a b : C)
    (f g : a --> b)
    : diagram pair_graph C.
  Proof.
    apply(make_parallell_diagram (unit ⨿ unit) a b).
    exact(sumofmaps (λ _, f) (λ _, g)).
  Defined.

  Definition make_multispan_diagram {J : category}
    (X : UU)
    (base : J)
    (endpoint : ∏ (x : X), J)
    (morphism : ∏ (x : X), J⟦ base, endpoint x ⟧)
    : diagram (multispan_graph X) J.
  Proof.
    use make_diagram.
    - exact(sumofmaps endpoint (λ _, base)).
    - use coprod_rect.
      + exact(λ _ _, empty_rect _).
      + apply unit_rect.
        use coprod_rect.
        * exact(λ (a : X) (_ : unit), morphism a).
        * exact(λ _, empty_rect _).
  Defined.
End diagrams.

Section cocones.

  (**
   3. Constructors of cocones.
   *)
  Definition make_empty_cocone {J : category}
    (d : diagram empty_graph J)
    (j : J)
    : cocone d j.
  Proof.
    use make_cocone.
    - exact(empty_rect _).
    - exact(λ _ _, empty_rect _).
  Defined.

  Definition make_discrete_cocone {J : category} {X : UU}
    (d : diagram (discrete_graph X) J)
    (z : J)
    (f : ∏ (x : X), J⟦dob d x, z⟧)
    : cocone d z.
  Proof.
    use make_cocone.
    - exact f.
    - exact(λ _ _, empty_rect _).
  Defined.

  Definition make_parallell_cocone {J : category} {X : UU}
    (d : diagram (parallell_graph X) J)
    (z : J)
    (in₀ : dob d (stnpr 0) --> z)
    (in₁ : dob d (stnpr 1) --> z)
    (commutes : ∏ (x : X), dmor d (x : @edge (parallell_graph X) (stnpr 0) (stnpr 1)) · in₁ = in₀)
    : cocone d z.
  Proof.
    use make_cocone.
    - exact(two_rec_dep _ in₀ in₁).
    - abstract(use(two_rec_dep _ (two_rec_dep _ (empty_rect _) commutes)); exact(λ _, empty_rect _)).
  Defined.

  Lemma parallell_cocone_commutes {J : category} {X : UU}
    {d : diagram (parallell_graph X) J}
    {j : J}
    (cc : cocone d j)
    (x : X)
    : dmor d (parallell_edge x) · coconeIn cc parallell_end = coconeIn cc parallell_start.
  Proof.
    exact(coconeInCommutes cc parallell_start parallell_end (parallell_edge x)).
  Qed.

  Definition make_pair_cocone {J : category} {X : UU}
    (d : diagram pair_graph J)
    (j : J)
    (src_in : J⟦dob d pair_src, j⟧)
    (dst_in : J⟦dob d pair_dst, j⟧)
    (com_left : dmor d pair_left · dst_in = src_in)
    (com_right : dmor d pair_right · dst_in = src_in)
    : cocone d j.
  Proof.
    use make_parallell_cocone.
    - exact src_in.
    - exact dst_in.
    - abstract(use coprod_rect; apply unit_rect; assumption).
  Defined.

  Lemma pair_cocone_commutes {J : category}
    {d : diagram pair_graph J}
    {j : J}
    (cc : cocone d j)
    (e : edge pair_src pair_dst)
    : dmor d e · coconeIn cc pair_dst = coconeIn cc pair_src.
  Proof.
    exact(coconeInCommutes cc pair_src pair_dst e).
  Qed.

  Definition make_multispan_cocone {J : category} {X : UU}
    (d : diagram (multispan_graph X) J)
    (apex : J)
    (base_inject : J⟦ dob d multispan_base, apex ⟧)
    (inject : ∏ (x : X), J⟦ dob d (multispan_vertex x), apex ⟧)
    (commutes : ∏ (x : X), dmor d (multispan_edge x) · inject x = base_inject)
    : cocone d apex.
  Proof.
    use make_cocone.
    - apply coprod_rect.
      + exact inject.
      + apply unit_rect.
        exact base_inject.
    - abstract(use coprod_rect; [exact(λ _ _, empty_rect _) | use unit_rect ];
               use coprod_rect; cbn; [exact(λ a, unit_rect _ (commutes a))
                                       |exact(λ _, empty_rect _)]).
  Defined.

  Lemma multispan_cocone_commutes {J : category} {X : UU}
    {d : diagram (multispan_graph X) J}
    {apex : J}
    (cc : cocone d apex)
    (z : X)
    : (dmor d (multispan_edge z)) · coconeIn cc (multispan_vertex z) =  coconeIn cc multispan_base.
  Proof.
    exact(coconeInCommutes cc multispan_base (multispan_vertex z) tt).
  Qed.

End cocones.

Section finite.
  Definition is_finite_graph (g : graph) : UU
    := isfinite (vertex g)
         × ∏ (a b : vertex g), isfinite (edge a b).

  Definition finite_vertexset {g : graph} (gfinite : is_finite_graph g)
    : isfinite (vertex g)
    := pr1 gfinite.

  Definition finite_edgeset {g : graph} (gfinite : is_finite_graph g)
    : ∏ (a b : vertex g), isfinite (edge a b)
    := pr2 gfinite.

  (* Proofs that some of the above graphs are finite. *)
  Lemma is_finite_graph_empty
    : is_finite_graph empty_graph.
  Proof.
    split.
    - exact isfiniteempty.
    - exact(λ _ _, isfiniteempty).
  Qed.

  Lemma is_finite_graph_unit
    : is_finite_graph unit_graph.
  Proof.
    split.
    - exact isfiniteunit.
    - exact(λ _ _, isfiniteempty).
  Qed.

  Lemma is_finite_graph_bool
    : is_finite_graph bool_graph.
  Proof.
    split.
    - exact isfinitebool.
    - exact(λ _ _, isfiniteempty).
  Qed.

  Lemma is_finite_graph_pair
    : is_finite_graph pair_graph.
  Proof.
    split.
    - exact(isfinitestn 2).
    - use two_rec_dep; use two_rec_dep; try exact isfiniteempty.
      apply isfinitecoprod; apply isfiniteunit.
  Qed.

  Lemma is_finite_graph_interval
    : is_finite_graph interval_graph.
  Proof.
    split.
    - exact isfinitebool.
    - use bool_rect; use bool_rect; try exact isfiniteempty.
      exact isfiniteunit.
  Qed.
End finite.


From Hammer Require Import Hammer.

Require Export Ensembles.
Require Export Relations_1.
Require Export Partial_Order.

Section Bounds.
Variable U : Type.
Variable D : PO U.

Let C := @Carrier_of U D.

Let R := @Rel_of U D.

Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop :=
Upper_Bound_definition :
In U C x -> (forall y:U, In U B y -> R y x) -> Upper_Bound B x.

Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop :=
Lower_Bound_definition :
In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x.

Inductive Lub (B:Ensemble U) (x:U) : Prop :=
Lub_definition :
Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x.

Inductive Glb (B:Ensemble U) (x:U) : Prop :=
Glb_definition :
Lower_Bound B x -> (forall y:U, Lower_Bound B y -> R y x) -> Glb B x.

Inductive Bottom (bot:U) : Prop :=
Bottom_definition :
In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot.

Inductive Totally_ordered (B:Ensemble U) : Prop :=
Totally_ordered_definition :
(Included U B C ->
forall x y:U, Included U (Couple U x y) B -> R x y \/ R y x) ->
Totally_ordered B.

Definition Compatible : Relation U :=
fun x y:U =>
In U C x ->
In U C y ->  exists z : _, In U C z /\ Upper_Bound (Couple U x y) z.

Inductive Directed (X:Ensemble U) : Prop :=
Definition_of_Directed :
Included U X C ->
Inhabited U X ->
(forall x1 x2:U,
Included U (Couple U x1 x2) X ->
exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) ->
Directed X.

Inductive Complete : Prop :=
Definition_of_Complete :
(exists bot : _, Bottom bot) ->
(forall X:Ensemble U, Directed X ->  exists bsup : _, Lub X bsup) ->
Complete.

Inductive Conditionally_complete : Prop :=
Definition_of_Conditionally_complete :
(forall X:Ensemble U,
Included U X C ->
(exists maj : _, Upper_Bound X maj) ->
exists bsup : _, Lub X bsup) -> Conditionally_complete.
End Bounds.

Hint Resolve Totally_ordered_definition Upper_Bound_definition
Lower_Bound_definition Lub_definition Glb_definition Bottom_definition
Definition_of_Complete Definition_of_Complete
Definition_of_Conditionally_complete.

Section Specific_orders.
Variable U : Type.

Record Cpo : Type := Definition_of_cpo
{PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}.

Record Chain : Type := Definition_of_chain
{PO_of_chain : PO U;
Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}.

End Specific_orders.