(* A depth-first search algorithm. *)

Require Import PeanoNat.
From larith Require Import A_setup B1_utils.

Section Stateful_search.

Variable X state solution : Type.
Variable check : state -> X -> state + solution.

Fixpoint search s l : state + (X × solution) :=
  match l with
  | []      => inl s
  | x :: l' =>
    match check s x with
    | inl t => search t l'
    | inr y => inr (x, y)
    end
  end.

Theorem search_app s l1 l2 :
  search s (l1 ++ l2) =
  match search s l1 with
  | inl t => search t l2
  | _     => search s l1
  end.
Proof.
revert s; induction l1; simpl; intros. easy.
destruct (check s a); [apply IHl1|easy].
Qed.

Theorem search_inr_inv s l x y :
  search s l = inr (x, y) -> In x l /\ ∃t, check t x = inr y.
Proof.
revert s; induction l; simpl; intros. easy.
destruct (check s a) as [t|y'] eqn:Ha.
apply IHl in H; split; [now right|apply H].
inv H; split; [now left|exists s; apply Ha].
Qed.

End Stateful_search.

Arguments search {_ _ _}.

Section Depth_first_search.

Variable node : Type.
Variable adj : node -> list node.
Variable accept : node -> bool.
Hypothesis dec : ∀v w : node, {v = w} + {v ≠ w}.

Notation diff x y := (subtract dec x y).
Notation next v := (remove dec v (adj v)).
Notation Path := (RTC (λ v w, In w (next v))).
Notation Notin l := (λ x, ¬In x l).
Notation Inr x := (∃r, x = inr r).

Fixpoint dfs depth visited v : list node + list node :=
  match depth with
  | 0   => inl visited
  | S n =>
    if in_dec dec v visited then inl visited
    else if accept v then inr []
    else match search (dfs n) (v :: visited) (next v)
    with
    | inl visited'  => inl visited'
    | inr (w, path) => inr (w :: path)
    end
  end.

Definition DFS_path visited path :=
  Path path /\ Forall (Notin visited) path.
Definition DFS_solution visited v path :=
  DFS_path visited (v :: path) /\ accept (last path v) = true.

Section Utilities.

Theorem Inr_inr {X Y} y :
  Inr (@inr X Y y).
Proof.
exists y; reflexivity.
Qed.

Theorem DFS_solution_refl visited v :
  ¬In v visited /\ accept v = true <-> DFS_solution visited v [].
Proof.
split.
- repeat split. apply RTC_refl.
  apply Forall_cons; easy. simpl; apply H.
- intros [[]]; inv H0.
Qed.

Theorem DFS_path_cons visited v w path :
  DFS_path visited (w :: path) /\ ¬In v visited /\ In w (next v) <->
  DFS_path visited (v :: w :: path).
Proof.
split.
- intros [[] []]; repeat split.
  apply RTC_cons; easy. apply Forall_cons; easy.
- intros []; inv H; inv H0.
Qed.

Theorem DFS_path_incl vis_a vis_b path :
  (∀v, In v vis_a -> In v vis_b) ->
  DFS_path vis_b path -> DFS_path vis_a path.
Proof.
split. apply H0.
eapply Forall_impl. 2: apply H0.
intros v; apply contra, H.
Qed.

Corollary DFS_solution_cons visited v w path :
  DFS_solution visited w path /\ ¬In v visited /\ In w (next v) <->
  DFS_solution visited v (w :: path).
Proof.
unfold DFS_solution; rewrite <-DFS_path_cons, last_cons; easy.
Qed.

Corollary DFS_global_solution_refl v :
  accept v = true <-> DFS_solution [] v [].
Proof.
rewrite <-DFS_solution_refl; easy.
Qed.

Corollary DFS_global_solution_cons v w path :
  DFS_solution [] w path /\ In w (next v) <->
  DFS_solution [] v (w :: path).
Proof.
rewrite <-DFS_solution_cons; easy.
Qed.

End Utilities.

Section Soundness.

(* Visited nodes are remembered. *)
Lemma dfs_inl_incl n vis_a v vis_z z :
  dfs n vis_a v = inl vis_z -> In z vis_a -> In z vis_z.
Proof.
revert vis_a v vis_z; induction n; simpl; intros. inv H.
destruct (in_dec _); [inv H|].
destruct (accept v); [easy|].
destruct (search _) as [vis_z'|[]] eqn:Hs; [inv H|easy].
remember (v :: vis_a) as vis_b.
assert(In z vis_b) by (subst; apply in_cons, H0).
clear H0 Heqvis_b; revert H Hs; revert vis_b.
induction (next v) as [|w ws]; simpl; intros.
inv Hs. destruct (dfs _) as [vis_c|] eqn:Hw; [|easy].
(* The inclusion relation is preserved over the induction. *)
destruct (in_dec dec z vis_c); [|exfalso].
apply IHws with (vis_b:=vis_c); easy.
apply IHn in Hw; easy.
Qed.

(* Solutions given by dfs are correct. *)
Theorem dfs_sound n vis_a v path :
  dfs n vis_a v = inr path -> DFS_solution vis_a v path.
Proof.
revert vis_a v path; induction n; simpl; intros. easy.
destruct (in_dec _); [easy|].
destruct (accept v) eqn:Hv. inv H.
repeat split; [apply RTC_refl|apply Forall_cons; easy|apply Hv].
destruct (search _) as [|[z from_z]] eqn:Hs; [easy|inv H].
(* Abstract over (v :: vis_a) and (next v). *)
remember (v :: vis_a) as vis_b; remember (next v) as nextv.
assert(∀x, In x vis_a -> In x vis_b) by (intros; subst; apply in_cons, H).
assert(∀x, In x nextv -> In x (next v)) by (subst; easy).
clear Hv Heqvis_b Heqnextv; revert Hs H H0; revert vis_b.
(* Do induction over nextv. *)
induction nextv as [|w ws]; simpl; intros.
easy. destruct (dfs _) as [vis_c|] eqn:Hw.
- apply IHws in Hs. apply Hs.
  intros; eapply dfs_inl_incl. apply Hw. apply H, H1.
  intros; apply H0; right; apply H1.
- inv Hs; apply IHn in Hw.
  apply DFS_solution_cons; split; split.
  eapply DFS_path_incl; [apply H|apply Hw].
  apply Hw. apply n0. apply H0; left; easy.
Qed.

End Soundness.

Section Completeness.

Variable graph : list node.
Hypothesis graph_spec : ∀v, In v graph.

(* Two DFS paths can be appended. *)
Lemma DFS_path_trans visited v path1 path2 :
  DFS_path visited (v :: path1) ->
  DFS_path visited (last path1 v :: path2) ->
  DFS_path visited (v :: path1 ++ path2).
Proof.
intros [H1a H1b] [H2a H2b].
rewrite app_comm_cons; split. eapply RTC_trans with (d:=v).
apply H1a. rewrite last_cons; apply H2a.
apply Forall_app; split; [apply H1b|inv H2b].
Qed.

(* Each new visited node can be reached by a path. *)
Lemma path_to_visited n vis_a v vis_z z :
  dfs n vis_a v = inl vis_z -> ¬In z vis_a -> In z vis_z ->
  ∃path, DFS_path vis_a (v :: path) /\ last path v = z.
Proof.
revert vis_a v vis_z; induction n; simpl; intros. inv H.
destruct (in_dec _); [inv H|].
destruct (accept v); [easy|].
destruct (search _) as [vis_z'|[]] eqn:Hs; [inv H|easy].
(* Discard the case z = v. *)
destruct (dec z v). exists []; subst; repeat split.
apply RTC_refl. apply Forall_cons; easy.
(* Abstract over (v :: vis_a) and (next v). *)
remember (v :: vis_a) as vis_b; remember (next v) as nextv.
assert(¬In z vis_b) by (subst; apply not_in_cons; easy).
assert(∀x, In x vis_a -> In x vis_b) by (intros; subst; apply in_cons, H2).
assert(∀x, In x nextv -> In x (next v)) by (subst; easy).
clear H0 n1 Heqvis_b Heqnextv; revert Hs H H2; revert vis_b.
induction nextv as [|w ws]; simpl; intros. inv Hs.
(* Destruct the recursive call, and check if it visits z. *)
destruct (dfs _) as [vis_c|] eqn:Hw; [|easy].
destruct (in_dec dec z vis_c).
- (* If the recursive call visits z; use IHn. *)
  apply IHn in Hw as [path []]; try easy.
  exists (w :: path); split; [|rewrite last_cons; apply H4].
  apply DFS_path_cons; split. eapply DFS_path_incl; [apply H2|apply H0].
  split. apply n0. apply H3, in_eq.
- (* If it doesn't; use IHnextv. *)
  apply IHws with (vis_b:=vis_c); try easy.
  intros; apply H3; apply in_cons, H0.
  intros; eapply dfs_inl_incl. apply Hw. apply H2, H0.
Qed.

(* If a solution exists, then, given enough fuel, dfs will also find one. *)
Theorem dfs_complete vis_a n :
  length (diff graph vis_a) <= n ->
  ∀v path, DFS_solution vis_a v path -> Inr (dfs n vis_a v).
Proof.
revert vis_a; induction n; intros vis_a Hn; intros.
(* Zero case. Contradition since v ∈ graph \ visited. *)
destruct H as [[_ H]]; inv H.
exfalso; apply in_nil with (a:=v).
apply Nat.le_0_r, length_zero_iff_nil in Hn.
rewrite <-Hn; apply subtract_spec; easy.
(* Successor case. *)
destruct H as [[]]; inv H0; simpl.
destruct (in_dec _); [easy|]; clear n0.
destruct (accept v) eqn:Hv; [apply Inr_inr|].
(* Get a sub-path without v. *)
destruct split_at_last_instance with (x:=v)(l:=v::path)
as [pre [path' []]]. apply dec. apply in_eq.
rewrite <-last_cons with (d:=v) in H1; rewrite H0 in H, H1.
apply RTC_app_inv in H as [_ H]; rewrite last_app in H1.
assert(Forall (Notin vis_a) path'). {
  destruct pre; inv H0. apply Forall_app in H5 as [_ H5]; inv H5. }
clear H0 H5 path pre.
(* The given path cannot be empty; obtain the next node. *)
inv H3; [simpl in H1; rewrite H1 in Hv; easy|].
inv H; rewrite last_cons in H1; apply in_remove in H9 as ?.
rename x into w, l into path.
(* Wrap hypotheses back together and clean up. *)
assert(H' : DFS_solution (v :: vis_a) w path). {
  repeat split; try easy. apply Forall_cons.
  apply not_in_cons; easy. apply not_in_cons in H2.
  apply Forall_forall; intros u Hu [F|F]; subst. easy.
  eapply Forall_forall with (x:=u) in H5; easy. }
assert(Hn' : length (diff graph (v :: vis_a)) <= n). {
  simpl; eapply Nat.lt_succ_r, Nat.lt_le_trans.
  apply subtract_length_lt_cons_r; [apply graph_spec|apply H4]. apply Hn. }
clear H H0 H1 H2 H4 H5 H7 Hv Hn.
remember (v :: vis_a) as vis_b; clear Heqvis_b vis_a.
(* Split (next v) into (next1 ++ w :: next2). *)
apply split_list in H9 as [next1 [next2 H9]]; rewrite H9.
cut(Inr (search (dfs n) vis_b (next1 ++ [w]))). intros [[w' path']].
rewrite cons_app, app_assoc, search_app, H; apply Inr_inr.
clear H9 v; revert H' Hn'; revert vis_b.
(* Do induction on the nodes that are checked before w. *)
induction next1 as [|u]; simpl; intros.
- (* At w the previous induction hypothesis guarantees a solution. *)
  apply IHn in H' as [path' H']. rewrite H'; apply Inr_inr. easy.
- (* Check if the search terminates before w. *)
  destruct (dfs _) as [vis_c|] eqn:Hu; [|apply Inr_inr].
  (* If not, then we can use IHnext1. *)
  apply IHnext1; clear IHnext1 next1.
  + (* Show that the path does not go through visited nodes. *)
    destruct H' as [[]]; repeat split; try easy.
    rewrite Forall_Exists_neg, Exists_exists; intros [e [H1e H2e]].
    apply Forall_forall with (x:=e) in H0 as H3e; [|apply H1e].
    (* If it does, then there exists a contradictory solution for v. *)
    eapply path_to_visited in H2e as [to_e ?]; [|apply Hu|apply H3e].
    destruct H2; subst. apply split_list in H1e as [path1 [path2 H1e]].
    rewrite <-last_cons with (d:=w) in H1; rewrite H1e in H, H0, H1.
    apply RTC_app_inv in H as [_ H]; apply Forall_app in H0 as [_ H0];
    rewrite last_app in H1.
    (* to_e ++ path2 is now a solution for u. *)
    assert(DFS_solution vis_b u (to_e ++ path2)).
    * split. apply DFS_path_trans; easy.
      destruct path2. rewrite app_nil_r; apply H1.
      rewrite last_app; rewrite last_cons in H1; apply H1.
    * apply IHn in H3. rewrite Hu in H3; destruct H3; easy. easy.
  + (* Show that n is big enough. *)
    etransitivity; [|apply Hn'].
    apply length_subtract_le_incl_r.
    intros; eapply dfs_inl_incl; [apply Hu|apply H].
Qed.

End Completeness.

Variable upper_bound : nat.
Hypothesis finite_graph : ∃l, length l <= upper_bound /\ ∀v : node, In v l.

Theorem depth_first_search visited v :
  (Σ path, DFS_solution visited v path) +
  {∀path, ¬DFS_solution visited v path}.
Proof.
destruct (dfs upper_bound visited v) as [visited'|path] eqn:H.
- right; intros path Hpath.
  destruct finite_graph as [graph [graph_len graph_spec]].
  assert(Hlen : length (diff graph visited) <= upper_bound).
  + rewrite subtract_length; etransitivity.
    apply Nat.le_sub_l. apply graph_len.
  + eapply dfs_complete with (v:=v) in Hlen as [path' H'].
    congruence. apply graph_spec. apply Hpath.
- left; exists path. eapply dfs_sound, H.
Defined.

End Depth_first_search.

Arguments dfs {_}.
Arguments DFS_path {_}.
Arguments DFS_solution {_}.


Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Notations.
Local Open Scope Z_scope.

Module Z.
  Lemma combine_at_bitwidth_correct bitwidth lo hi
  : Z.combine_at_bitwidth bitwidth lo hi = lo + (hi << bitwidth).
  Proof. reflexivity. Qed.

  Lemma combine_at_bitwidth_Proper bitwidth
    : Proper (Z.le ==> Z.le ==> Z.le) (Z.combine_at_bitwidth bitwidth).
  Proof.
    cbv [Proper respectful]; intros; rewrite !combine_at_bitwidth_correct.
    destruct bitwidth as [|bitwidth|bitwidth];
      [ | assert (0 <= 2^Z.pos bitwidth) by (apply Z.pow_nonneg; lia).. ];
      rewrite ?Z.shiftl_mul_pow2, ?Z.shiftl_div_pow2, ?Z.pow_0_r by lia; cbn [Z.opp]; try nia;
        Z.div_mod_to_quot_rem; nia.
  Qed.
#[global]
  Hint Resolve combine_at_bitwidth_Proper : zarith.

  Lemma combine_at_bitwidth_Proper1 bitwidth x
    : Proper (Z.le ==> Z.le) (Z.combine_at_bitwidth bitwidth x).
  Proof. repeat intro; eapply combine_at_bitwidth_Proper; (eassumption + reflexivity). Qed.
#[global]
  Hint Resolve combine_at_bitwidth_Proper1 : zarith.

  Lemma combine_at_bitwidth_Proper2 bitwidth x
    : Proper (Z.le ==> Z.le) (fun y => Z.combine_at_bitwidth bitwidth y x).
  Proof. repeat intro; eapply combine_at_bitwidth_Proper; (eassumption + reflexivity). Qed.
#[global]
  Hint Resolve combine_at_bitwidth_Proper2 : zarith.
End Z.


Require Import propInv4.
Require Import verif_cond_2.
Require Import extra2.
Local Open Scope Z.

Theorem proof4_2: (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\ cond2->
 (inv hands1 dryer2 ctrlState2 ctrlTimer2 timer1).

Proof.
intros.
split.
unfold propInv4.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
inversion_clear H3.
intros.
(*analysis of cases i<timer1 and i=timer1*)
elim Zle_lt_or_eq with i timer1.
intros.
(*prove that dryer1 and dryer2 are equal in all indexes j<timer1*)
assert (Hdryer1_dryer2_same : (forall j, j<timer1 -> dryer1.[of_Z j]=dryer2.[of_Z j])).
intros.
apply arr_same_before_upd with ON timer1.
split; assumption.
rewrite <- Hdryer1_dryer2_same.
rewrite <- Hdryer1_dryer2_same in H5.
apply startnewloop_to_propInv.
assumption.
split.
apply H3.
inversion_clear H0.
auto with zarith.
assumption.
auto with zarith.
assumption.
(*analysis of case i=timer1*)
intros.
rewrite H6.
rewrite H2.
apply get_set_same.
inversion_clear H0.
inversion_clear H8.
inversion_clear H9.
inversion_clear H10.
inversion_clear H11.
rewrite H10.
rewrite length_set.
apply dryer_inf.
inversion_clear H3.
assumption.
apply extra2.
split.
inversion_clear H.
inversion_clear H0.
split.
apply H.
assumption.
apply H.
Qed.


Require Import Omega Arith List Eqdep_dec Program.
Require Import Schema Category Instance Translation.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

(** * The empty category *)

Definition empty : Schema.
  refine {| Vertex := Empty_set;
    Edge := fun _ _ => Empty_set;
    PathsEquivalent := (fun _ _ _ _ => True) |};
  abstract (repeat intuition).
Defined.

Definition emptyI : Instance empty.
  refine {| TypeOf := fun x : empty => match x with end;
    FunctionOf := fun _ _ (x : Empty_set) _ => match x with end |};
  abstract destruct s.
Defined.

(** * The Booleans with "implies" edges *)

Definition booleans : Schema.
  refine {| Vertex := bool;
    Edge := (fun b1 b2 => b2 = false \/ b1 = true);
    PathsEquivalent := (fun _ _ _ _ => True) |};
  abstract (repeat intuition).
Defined.

(** * The naturals with >= edges *)

Definition naturals : Schema.
  refine {| Vertex := nat;
    Edge := ge;
    PathsEquivalent := (fun _ _ _ _ => True) |};
  abstract (repeat intuition).
Defined.

(** * Silly functor from Booleans to naturals *)

Definition boolToNat (b : bool) := if b then 1 else 0.

Theorem boolToNat_ge : forall b1 b2, (b2 = false \/ b1 = true)
  -> boolToNat b1 >= boolToNat b2.
  destruct b1; destruct b2; simpl; intuition.
Qed.

Definition booleans_to_naturals : Translation booleans naturals.
  refine {| VertexOf := (boolToNat : booleans -> naturals);
    PathOf := fun _ _ e => AddEdge NoEdges (boolToNat_ge e) |};
  abstract auto.
Defined.

(** Give an instance by interpreting naturals as bitvectors and edges as forgetting of initial bits. *)

Inductive bitvector : nat -> Type :=
| BO : bitvector O
| BS : forall n, bool -> bitvector n -> bitvector (S n).

Fixpoint forget (n m : nat) (bv : bitvector n) : bitvector (n - m) :=
  match bv in bitvector n return bitvector (n - m) with
    | BO => BO
    | BS n' b bv' => match m return bitvector (S n' - m) with
                       | O => BS b bv'
                       | S m' => forget _ bv'
                     end
  end.

Theorem bitvector_case : forall n (bv : bitvector n),
  match n return bitvector n -> Prop with
    | O => fun bv => bv = BO
    | S _ => fun bv => exists b, exists bv', bv = BS b bv'
  end bv.
  destruct bv; eauto.
Qed.

Fixpoint erase n (bv : bitvector n) : list bool :=
  match bv with
    | BO => nil
    | BS _ b bv' => b :: erase bv'
  end.

Theorem erase_eq : forall n (bv bv' : bitvector n),
  erase bv = erase bv'
  -> bv = bv'.
  induction bv; intro bv'; specialize (bitvector_case bv'); firstorder; subst; simpl in *.
  injection H0; intros.
  f_equal; eauto.
Qed.

Fixpoint forget' (m : nat) (bv : list bool) : list bool :=
  match bv with
    | nil => nil
    | b :: bv' => match m with
                    | O => b :: bv'
                    | S m' => forget' m' bv'
                  end
  end.

Theorem forget_forget' : forall n (bv : bitvector n) m,
  erase (forget m bv) = forget' m (erase bv).
  induction bv; destruct m; simpl; intuition.
Qed.

Theorem double_sub : forall n1 n2, n1 >= n2 -> n1 - (n1 - n2) = n2.
  intros; omega.
Qed.

Theorem push_app : forall dom (ran : nat -> Type) n1 n2 (f : dom -> ran n1) x (pf : n1 = n2),
  match pf in _ = N return dom -> ran N with
    | refl_equal => f
  end x = match pf in _ = N return ran N with
            | refl_equal => f x
          end.
  intros; subst; reflexivity.
Qed.

Theorem push_erase : forall n1 n2 (Heq : n1 = n2) bv,
  erase (match Heq in _ = N return bitvector N with
           | refl_equal => bv
         end) = erase bv.
  intros; subst; reflexivity.
Qed.

Theorem double_forget' : forall m2 bv m1,
  forget' m2 (forget' m1 bv) = forget' (m1 + m2) bv.
  induction bv; destruct m1; simpl; intuition.
  induction m2; auto.
Qed.

Lemma path_ge : forall n1 n2, path' ge n1 n2 -> n1 >= n2.
  induction 1; simpl; intuition.
Qed.

Lemma compose_unique' : forall n1 n2 (p : path' ge n1 n2) bv,
  erase (compose bitvector (fun n1 n2 pf => match double_sub pf in _ = N return _ -> bitvector N with
                                              | refl_equal => @forget n1 (n1 - n2)
                                            end) p bv)
  = erase (forget (n1 - n2) bv).
  induction p; simpl; intuition.

  rewrite minus_diag.
  destruct bv; reflexivity.

  rewrite push_app.
  rewrite push_erase.
  repeat rewrite forget_forget'.
  rewrite IHp.
  rewrite forget_forget'.
  rewrite <- forget_forget'.
  rewrite forget_forget'.
  rewrite double_forget'.
  f_equal.
  specialize (path_ge p).
  omega.
Qed.

Lemma compose_unique : forall n1 n2 Heq (p : path' ge n1 n2) bv,
  compose bitvector (fun n1 n2 pf => match double_sub pf in _ = N return _ -> bitvector N with
                                       | refl_equal => @forget n1 (n1 - n2)
                                     end) p bv
  = match Heq in _ = N return bitvector N with
      | refl_equal => forget (n1 - n2) bv
    end.
  intros; apply erase_eq.
  rewrite compose_unique'.
  generalize (forget (n1 - n2) bv), Heq.
  rewrite Heq; intros.
  rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)).
  reflexivity.
Qed.

Definition bitvectors : Instance naturals.
  refine {| TypeOf := (bitvector : Vertex naturals -> _);
    FunctionOf := (fun n1 n2 pf => match double_sub pf in _ = N return _ -> bitvector N with
                                     | refl_equal => @forget n1 (n1 - n2)
                                   end) |}.
  abstract (intros; assert (Heq : s - (s - d) = d) by (specialize (path_ge p1); omega);
    repeat rewrite (compose_unique Heq); reflexivity).
Defined.

(** * A sample schema and database *)

Inductive emailsV :=
| SelfEmails
| Emails
| People.

Inductive emailsE : emailsV -> emailsV -> Type :=
| SelfEmails_Emails : emailsE SelfEmails Emails
| Sender : emailsE Emails People
| Receiver : emailsE Emails People.

Inductive emailsEq : forall s d, path' emailsE s d -> path' emailsE s d -> Prop :=
| Refl : forall s d (p : path' emailsE s d), emailsEq p p
| Law : emailsEq (AddEdge (AddEdge NoEdges SelfEmails_Emails) Sender)
  (AddEdge (AddEdge NoEdges SelfEmails_Emails) Receiver)
| LawSymm : emailsEq (AddEdge (AddEdge NoEdges SelfEmails_Emails) Receiver)
  (AddEdge (AddEdge NoEdges SelfEmails_Emails) Sender).

Hint Constructors emailsEq.

Inductive selfEmailId := S181.
Inductive emailId := E180 | E181.
Inductive person := Bob | Sue | David.

Ltac dep_destruct H := generalize H; intro H'; dependent destruction H'.

Ltac destructor := simpl; intuition;
  repeat (match goal with
            | [ H : ?T |- _ ] =>
              match eval hnf in T with
                | emailsEq ?X ?Y =>
                  match goal with
                    | [ x : _ |- _ ] =>
                      match x with
                        | X => hnf in H; dep_destruct H
                        | Y => hnf in H; dep_destruct H
                      end
                  end
                | emailsE _ _ => dep_destruct H
                | selfEmailId => destruct H
              end
          end; simpl in *); auto.

Definition emailsSchema : Schema.
  refine {| Vertex := emailsV;
    Edge := emailsE;
    PathsEquivalent := emailsEq
    |}; abstract (repeat destructor; try split; hnf; destructor).
Defined.

Definition emailsTypeof (v : emailsSchema) : Set :=
  match v with
    | SelfEmails => selfEmailId
    | Emails => emailId
    | People => person
  end.

Definition emailsInstance : Instance emailsSchema.
  refine {| TypeOf := emailsTypeof;
    FunctionOf := (fun s d (E : Edge emailsSchema s d) =>
      match E in emailsE s d return emailsTypeof s -> emailsTypeof d with
        | SelfEmails_Emails => fun id => match id with
                                           | S181 => E181
                                         end
        | Sender => fun id => match id with
                                | E180 => Bob
                                | E181 => David
                              end
        | Receiver => fun id => match id with
                                  | E180 => Sue
                                  | E181 => David
                                end
      end)
   |}; abstract destructor.
Defined.


Require Import XR_Rinv_r.
Require Import XR_Rmult_1_l.

Local Open Scope R_scope.

Lemma Rinv_r_simpl_r : forall r1 r2, r1 <> R0 -> r1 * / r1 * r2 = r2.
Proof.
  intros x y h.
  rewrite Rinv_r.
  {
    rewrite Rmult_1_l.
    reflexivity.
  }
  { exact h. }
Qed.


Require Import Coq.Program.Tactics.
Require Import Coq.Program.Equality.
Require Import LibLN.
Require Import STLCNew.
Require Import CoherenceBasicBDNew.
Require Import STLCred.

Inductive VChk : PExp -> PTyp -> Prop :=
  | VLam : forall A B t, VChk (PLam t) (Fun A B).

Inductive VInf : PExp -> PTyp -> Prop :=
  | VInt : forall n, VInf (PLit n) PInt
  | VMerge : forall v1 v2 A B, VInf v1 A ->
                          VInf v2 B ->
                          VInf (PMerge v1 v2) (And A B)
  | VAnn : forall v A, VChk v A -> VInf (PAnn v A) A.

Hint Constructors VChk VInf.

Definition value (v : PExp) := exists A, VInf v A.

Inductive subred : PExp -> PExp -> PTyp -> Prop :=
  | SRed_Fun :
      forall v A B C D,
        VInf v (Fun A B) ->
        subred v (PAnn (PLam (PAnn (PApp v (PBVar 0)) D)) (Fun C D)) (Fun C D)
  | SRed_AndR : forall v A B, value v ->
                         subred v (PMerge (PAnn v A) (PAnn v B)) (And A B)
  | SRed_AndL1 : forall v1 v2 A B, VInf v1 B ->
                              value v2 ->
                              Atomic A ->
                              Sub B A ->
                              subred (PMerge v1 v2) v1 A
  | SRed_AndL2 : forall v1 v2 A C, value v1 ->
                              VInf v2 C ->
                              Atomic A ->
                              Sub C A ->
                              subred (PMerge v1 v2) v2 A.

Inductive bired : PExp -> PExp -> Prop :=
  | Red_App1 : forall e1 e2 e3,
                 bired e1 e3 ->
                 bired (PApp e1 e2) (PApp e3 e2)
  | Red_App2 : forall e1 e2 v,
                 value v ->
                 bired e1 e2 ->
                 bired (PApp v e1) (PApp v e2)
  | Red_App3 : forall A B C v1 v2 e,
                 VInf v1 (Fun A B) ->
                 VInf v2 C ->
                 A <> C ->
                 subred v2 e A ->
                 bired (PApp v1 v2) (PApp v1 e)
  | Red_App4 : forall A B e v,
                 VChk v A ->
                 bired (PApp (PAnn (PLam e) (Fun A B)) v)
                       (PAnn (open_source e (PAnn v A)) B)
  | Red_App5 : forall A B e v,
                 VInf v A ->
                 bired (PApp (PAnn (PLam e) (Fun A B)) v)
                       (PAnn (open_source e v) B)
  | Red_Merge1 : forall e1 e2 e3,
                   bired e1 e3 ->
                   bired (PMerge e1 e2) (PMerge e3 e2)
  | Red_Merge2 : forall e1 e2 v,
                   value v ->
                   bired e1 e2 ->
                   bired (PMerge v e1) (PMerge v e2)
  | Red_Ann1 : forall e1 e2 A,
                 bired e1 e2 ->
                 bired (PAnn e1 A) (PAnn e2 A)
  | Red_Ann2 : forall v e A B,
                 VInf v B ->
                 A <> B ->
                 subred v e A ->
                 bired (PAnn v A) (PAnn e A)
  | Red_Ann3 : forall v A, VInf v A ->
                      bired (PAnn v A) v.

Hint Constructors WFTyp subred bired.

(* We didn't prove this before?! See: Pfenning *)
Theorem sub_trans : forall A B, Sub A B -> forall C, Sub B C -> Sub A C. Admitted.

Hint Resolve reflex sub_trans.
Hint Unfold Sub.

Hint Unfold erase.

Theorem VInf_bityping_eq :
  forall A v, VInf v A -> forall B Gamma, bidityping Gamma v Inf B -> A = B.
Proof.
  intros A v HIn.
  induction HIn; eauto 3.
  - intros; inversion H; subst; eauto.
  - intros; inversion H; subst.
    erewrite IHHIn1; erewrite IHHIn2; eauto.
  - intros; now inversion H0; subst.
Qed.

Hint Resolve VInf_bityping_eq.

Theorem VInf_bityping_sub :
  forall A v, VInf v A -> forall B Gamma m, bidityping Gamma v m B -> Sub A B.
Proof.
  intros A v HIn.
  induction HIn.
  - intros; inversion H; subst; auto.
    inversion H0; subst; eauto.
  - intros; dependent induction H; [ clear IHbidityping1 IHbidityping2 | eauto 5 ].
    apply sand1; [ apply sand2 | apply sand3 ]; eauto.
  - intros; inversion H; subst; auto.
    inversion H0; subst; eauto.
    inversion H1; subst; eauto.
Qed.

Hint Resolve VInf_bityping_sub.

Theorem bityping_inf_chk :
  forall Gamma e A,
    bidityping Gamma e Inf A -> bidityping Gamma e Chk A.
Proof.
  intros Gamma e A Htyping.
  assert (Ha : Sub A A) by eauto; destruct Ha.
  eapply ATySub' with (A := A); eauto.
Qed.

Hint Resolve bityping_inf_chk.

(** Theorem 1. Subject reduction **)

Theorem subject_reduction_sub' :
  forall Gamma v A, bidityping Gamma v Inf A ->
           forall e B, subred v e B ->
                  Sub A B ->
                  WFTyp B ->
                  bidityping Gamma e Inf B.
Proof.
  intros Gamma v A Htyping e B Hred HTyp.
  generalize dependent Gamma.
  induction Hred; intros.
  - inverts H. dependent induction Htyping; subst; eauto; clear IHHtyping.
    inverts H0.
    assert (Ha1 : Sub (Fun C D) (Fun C D)). eauto. destruct Ha1.
    apply ATyAnnCT'.
    assert (Ha : WFTyp (Fun A0 B)) by
        (now assert (Ha := bityping_wf Htyping); inversion Ha).
    inverts Ha.
    apply_fresh ATyLam' as x; auto.
    unfold open_source; simpl.
    case_nat*.
    assert (Ha2 : Sub D D) by eauto; destruct Ha2.
    eapply ATySub' with (A := D); eauto 2.
    apply ATyAnnCT'.
    inverts HTyp; inverts H2.
    eapply ATySub' with (A := B); eauto 2.
    eapply ATyApp' with (A := A0).
    + apply ATyAnnCT'.
      rewrite <- open_rec_source_term; eauto 3.
      rewrite <- concat_empty_r with (E := Gamma & y ~ C).
      apply bityping_weaken; rewrite concat_empty_r; autos*.
    + assert (Ha1 : Sub C C) by apply reflex; destruct Ha1.
      eapply ATySub' with (A := C); eauto 2.
      apply* ATyVar'.
  - inverts H.
    inverts HTyp. inverts H; try now inversion H3.
    inverts H0.
    assert (Ha : Sub (And A0 B) (And A0 B)) by eauto.
    destruct Ha.
    apply* ATyMerge'.
  - dependent induction Htyping; subst; eauto. clear IHHtyping1 IHHtyping2.
    assert (B = A) by eauto; subst. admit.
  - dependent induction Htyping; subst; eauto. clear IHHtyping1 IHHtyping2.
    assert (C = B) by eauto; subst. admit.
Admitted.

Theorem subject_reduction_sub :
  forall Gamma v A, bidityping Gamma v Inf A ->
           forall e B, subred v e B ->
                  Sub A B ->
                  WFTyp B ->
                  bidityping Gamma e Chk B.
Proof.
  intros Gamma v A Htyping e B Hred HTyp.
  generalize dependent Gamma.
  induction Hred; intros.
  - inverts H. dependent induction Htyping; subst; eauto; clear IHHtyping.
    inverts H0.
    assert (Ha1 : Sub (Fun C D) (Fun C D)). eauto. destruct Ha1.
    apply ATySub' with (A := Fun C D) (C := x); eauto.
    apply ATyAnnCT'.
    assert (Ha : WFTyp (Fun A0 B)) by
        (now assert (Ha := bityping_wf Htyping); inversion Ha).
    inverts Ha.
    apply_fresh ATyLam' as x; auto.
    unfold open_source; simpl.
    case_nat*.
    assert (Ha2 : Sub D D) by eauto; destruct Ha2.
    eapply ATySub' with (A := D); eauto 2.
    apply ATyAnnCT'.
    inverts HTyp; inverts H2.
    eapply ATySub' with (A := B); eauto 2.
    eapply ATyApp' with (A := A0).
    + apply ATyAnnCT'.
      rewrite <- open_rec_source_term; eauto 3.
      rewrite <- concat_empty_r with (E := Gamma & y ~ C).
      apply bityping_weaken; rewrite concat_empty_r; autos*.
    + assert (Ha1 : Sub C C) by apply reflex; destruct Ha1.
      eapply ATySub' with (A := C); eauto 2.
      apply* ATyVar'.
  - inverts H.
    inverts HTyp. inverts H; try now inversion H3.
    inverts H0.
    assert (Ha : Sub (And A0 B) (And A0 B)) by eauto.
    destruct Ha.
    apply* ATySub'.
    apply* ATyMerge'.
  - dependent induction Htyping; subst; eauto. clear IHHtyping1 IHHtyping2.
    assert (B = A) by eauto; subst. destruct H2; apply* ATySub'.
  - dependent induction Htyping; subst; eauto. clear IHHtyping1 IHHtyping2.
    assert (C = B) by eauto; subst. destruct H2; apply* ATySub'.
Qed.

Theorem subject_reduction :
  forall Gamma e1 A m, bidityping Gamma e1 m A ->
              forall e2, bired e1 e2 ->
                    bidityping Gamma e2 m A.
Proof.
  intros Gamma e1 A m Htyping e2 Hred;
  generalize dependent A; generalize dependent Gamma; generalize dependent m.
  induction Hred; intros; try now (dependent induction Htyping; subst; eauto).
  - (* R_App3 *)
    dependent induction Htyping; subst; eauto; clear IHHtyping1 IHHtyping2.
    inversion H; subst; inversion Htyping1; subst.
    apply ATyApp' with (A := A0); auto.
    inverts Htyping2. inverts H0.
    assert (Ha : C = A) by eauto; subst.
    apply* subject_reduction_sub.
  - (* R_App4 *)
    dependent induction Htyping; eauto; clear IHHtyping1 IHHtyping2.
    inverts* Htyping1.
    apply ATyAnnCT'. inverts H.
    inverts H4.
    eapply open_body_bityping; eauto.
    inverts H.
  - (* R_App5 *)
    dependent induction Htyping; subst; eauto.
    clear IHHtyping1 IHHtyping2.
    inversion Htyping1; subst.
    apply ATyAnnCT'; clear Htyping1.
    apply open_body_bityping with (A := A0); eauto.
    inversion H4; subst; eauto.
    inversion H0.
    dependent induction Htyping2; subst; eauto.
    inversion H2.
    assert (B = A) by eauto; now subst.
  - (* R_Ann2 *)
    dependent induction Htyping; eauto; subst; clear IHHtyping.
    inverts Htyping. inverts H.
    apply ATyAnnCT'; apply* subject_reduction_sub.
  - (* R_Ann3 *)
    dependent induction Htyping; eauto; clear IHHtyping.
    inverts Htyping. inverts H.
    assert (A = A0) by eauto; now subst.
Qed.

(** Theorem 2. Reduction is deterministic **)

Hint Extern 1 =>
  match goal with
    | [ H : bired (PLam ?e2) ?e1 |- _ ] => inversion H
    | [ H : VInf (PLam ?e) ?A |- _ ] => inversion H
    | [ H : VInf (PInt ?e) ?A |- _ ] => inversion H
  end.

Lemma value_inf_chk_false : forall v A B, VChk v A -> VInf v B -> False.
Proof.
  introv H1 H2; inverts H1; inverts H2.
Qed.

Hint Resolve value_inf_chk_false.

Lemma value_not_red : forall e1 e2 A, VInf e1 A -> bired e1 e2 -> False.
Proof.
  intros e1 e2 A Hin Hred. generalize dependent A.
  induction Hred; intros; try now inversion Hin; subst; eauto.
  inverts Hin. inverts H2. inverts Hred.
Qed.

Hint Extern 1 =>
  match goal with
    | [ H1 : VInf ?e1 ?A,
        H2 : bired ?e1 ?e2 |- _ ] => exfalso; apply (value_not_red _ _ _ H1 H2)
    | [ H1 : value ?v,
        H2 : bired ?e1 ?e2 |- _ ] => destruct H1 as [HHH1 HHH2]; exfalso;
                                    apply (value_not_red _ _ _ HHH1 H2)
  end.

Lemma VInf_unique : forall v A B, VInf v A -> VInf v B -> A = B.
Proof.
  intros v A B HIn1 HIn2. generalize dependent B.
  induction HIn1; intros; inversion HIn2; subst; auto.
  apply IHHIn1_1 in H1; apply IHHIn1_2 in H3; now subst.
Qed.

Hint Rewrite VInf_unique.
Hint Resolve value_not_red.

Hint Extern 1 =>
  match goal with
    | [ H : VInf (PLam ?e) ?A |- _ ] => inverts H
    | [ H : bired (PLam ?e1) ?e2 |- _ ] => inverts H
  end.

Theorem subred_unique : forall v e1 A, subred v e1 A -> forall e2 Gamma, subred v e2 A ->
                                                          bidityping Gamma v Chk A -> e1 = e2.
Proof.
  introv Hred1.
  induction Hred1; introv Hred2 Typ.
  - inverts H. inverts* Hred2.
  - inverts* Hred2. inverts H2. inverts H2.
  - inverts* Hred2. inverts H3. inverts H1.
    inverts Typ. inverts H3.
    assert (Ha1 : B = A1) by eauto.
    assert (Ha2 : C = B0) by eauto. substs.
    assert (Ha3 : Sub (And A1 B0) A) by eauto.
    lets* Ha4 : uniquesub H15 Ha3.
  - inverts* Hred2. inverts H3. inverts H1.
    inverts Typ. inverts H3.
    assert (Ha1 : B = A1) by eauto.
    assert (Ha2 : C = B0) by eauto. substs.
    assert (Ha3 : Sub (And A1 B0) A) by eauto.
    lets* Ha4 : uniquesub H15 Ha3.
Qed.

Theorem bired_unique :
  forall e1 e2, bired e1 e2 -> forall e3, bired e1 e3 -> forall Gamma A m,
                                               bidityping Gamma e1 m A -> e2 = e3.
Proof.
  introv Hred.
  induction Hred; intros.
  - dependent induction H0; eauto; clear IHbidityping1 IHbidityping2.
    inverts* H.
    + forwards* Ha : IHHred; substs*.
    + destruct H2; tryfalse*.
    + inverts H0_; inverts* Hred.
    + inverts* Hred.
  - dependent induction H1; eauto; clear IHbidityping1.
    inverts* H0.
    + destruct* H.
    + forwards* Ha : IHHred; substs*.
    + inverts* H4.
  - dependent induction H4; eauto; clear IHbidityping1 IHbidityping2.
    inverts* H3.
    + assert (Ha1 : Fun A1 B1 = Fun A B). apply VInf_unique with (v := v1); auto.
      assert (Ha2 : Fun A1 B1 = Fun A0 B0) by eauto.
      inverts Ha1; inverts Ha2.
      lets* Ha : subred_unique H2 H10 H4_0; substs*.
    + tryfalse*.
    + inverts H. assert (C = A) by apply* VInf_unique. substs*.
  - dependent induction H1; eauto; clear IHbidityping1 IHbidityping2.
    inverts H1_. inverts H0; tryfalse*. auto.
  - dependent induction H1; eauto; clear IHbidityping1 IHbidityping2.
    inverts* H0.
    + inverts* H4.
    + inverts H3. assert (C = A1) by apply* VInf_unique. substs*.
    + tryfalse*.
  - dependent induction H0; eauto; clear IHbidityping1 IHbidityping2.
    inverts H.
    forwards* Ha : IHHred. substs*.
    destruct H3.
    tryfalse*.
  - dependent induction H1; eauto; clear IHbidityping1 IHbidityping2.
    inverts H0. destruct* H. forwards* Ha : IHHred. substs*.
  - dependent induction H0; eauto.
    inverts* H.
    forwards* Ha : IHHred; substs*.
  - dependent induction H3; eauto; clear IHbidityping.
    inverts* H2.
    lets* Ha : subred_unique H1 H9 H3; substs*.
    assert (A = B) by apply* VInf_unique. substs*.
  - dependent induction H1; eauto; clear IHbidityping.
    inverts* H0.
    assert (A = B) by apply* VInf_unique. substs*.
Qed.

(** Theorem 3. Reduction is complete **)

(*
Lemma value_ann_red_id :
  forall v A e, In v A -> red (PAnn CT v A) e -> v = e.
Proof.
  intros v A e Hin Hred.
  dependent induction Hred; eauto.
  - inversion Hin; subst; exfalso. now apply H.
  - inversion Hin; subst; inversion H0.
  - inversion Hin; subst; inversion H0.
  - inversion Hin; subst.
    assert (Ha : And C D = And A0 B) by (eapply In_unique; eauto).
    inversion Ha; subst; contradiction.
Qed.

Hint Rewrite value_ann_red_id.
 *)

Hint Constructors equiv_.
Hint Resolve fullred_regular.

Lemma fullred_equiv_regular :
  forall e1 e2, equiv_ fullred e1 e2 -> STTerm e1 /\ STTerm e2.
Proof. introv H; induction* H. Qed.

Lemma fullred_equiv_regular_l :
  forall e1 e2, equiv_ fullred e1 e2 -> STTerm e1.
Proof. introv H; forwards* Ha : fullred_equiv_regular e1 e2. Qed.

Lemma fullred_equiv_regular_r :
  forall e1 e2, equiv_ fullred e1 e2 -> STTerm e2.
Proof. introv H; forwards* Ha : fullred_equiv_regular e1 e2. Qed.

Hint Resolve fullred_equiv_regular_l fullred_equiv_regular_r.

Lemma fullred_equiv_app_l :
  forall e1 e2, equiv_ fullred e1 e2 ->
           forall e3, STTerm e3 ->
                 equiv_ fullred (STApp e1 e3) (STApp e2 e3).
Proof. introv Equiv; induction* Equiv. Qed.

Lemma fullred_equiv_app_r :
  forall e2 e3, equiv_ fullred e2 e3 ->
           forall e1, STTerm e1 ->
                 equiv_ fullred (STApp e1 e2) (STApp e1 e3).
Proof. introv Equiv; induction* Equiv. Qed.

Hint Resolve fullred_equiv_app_l fullred_equiv_app_r.

Lemma fullred_equiv_pair_l :
  forall e1 e2, equiv_ fullred e1 e2 ->
           forall e3, STTerm e3 ->
                 equiv_ fullred (STPair e1 e3) (STPair e2 e3).
Proof. introv Equiv; induction* Equiv. Qed.

Lemma fullred_equiv_pair_r :
  forall e2 e3, equiv_ fullred e2 e3 ->
           forall e1, STTerm e1 ->
                 equiv_ fullred (STPair e1 e2) (STPair e1 e3).
Proof. introv Equiv; induction* Equiv. Qed.

Lemma fullred_equiv_pair :
  forall e1 e3, equiv_ fullred e1 e3 ->
           forall e2 e4, equiv_ fullred e2 e4 ->
                 equiv_ fullred (STPair e1 e2) (STPair e3 e4).
Proof.
  introv H1 H2.
  apply equiv_trans with (t2 := (STPair e3 e2)).
  apply* fullred_equiv_pair_l.
  apply* fullred_equiv_pair_r.
Qed.

Hint Resolve fullred_equiv_pair_l fullred_equiv_pair_r fullred_equiv_pair.

Lemma subred_equiv : forall v t A,
              subred v t A ->
              forall E1 E2,
                has_type_source_alg empty v Chk A E1 ->
                has_type_source_alg empty t Chk A E2 ->
                equiv_ fullred E1 E2.
Proof.
  introv Subred.
  induction Subred; introv Typ1 Typ2.
  - inverts H; inverts H0.
    inverts Typ1; inverts Typ2.
    inverts H.
    inverts H2.
    inverts H3.
    inverts H0.
    inverts H6; inverts H7; try now inverts H.
    admit.
  - inverts Typ1. inverts Typ2.
    inverts H3.
    inverts H1; try now inverts H6.
    inverts H4; try now inverts H14.
    inverts H.
    inverts H8. inverts H10.
    assert (x = A0) by eauto. substs.
    inverts* H4. inverts* H6.
    assert (A0 = A) by eauto. substs.
    assert (A = A1) by eauto. symmetry in H6; substs.
    assert (C0 = c2). apply @sub_coherent with (A := A) (B := B0); eauto.
    assert (C = c1). apply @sub_coherent with (A := A) (B := A2); eauto. substs.
    assert (E1 = E) by apply* typ_coherence.
    assert (E0 = E) by apply* typ_coherence. substs.
    clear H2 H5 H9 H10 H0 H4.
    admit.
  - inverts Typ1; inverts Typ2.
    inverts H.
    assert (B = A1) by eauto. substs.
    inverts H3.
    assert (A1 = A2) by eauto. substs.
    assert (E1 = E0). eapply typ_coherence; eauto. substs.
    inverts H4.
    inverts H1.
    assert (Ha : WFTyp A2) by eauto.
    assert (c = C0). eapply sub_coherent. apply Ha. apply H5. auto. auto. substs.
    admit. (* seems provable *)
    assert (Ha : Sub (And A2 B) A) by eauto.
    lets Ha1 : uniquesub H14 Ha.
    destruct Ha1; unfold Sub; split; eauto.
  - inverts Typ1; inverts Typ2.
    inverts H0.
    assert (C = A1) by eauto. substs.
    inverts H3.
    assert (A1 = B) by eauto. substs.
    assert (E2 = E0). eapply typ_coherence; eauto. substs.
    inverts H4.
    inverts H1.
    assert (Ha : Sub (And A2 B) A) by eauto.
    lets Ha1 : uniquesub H14 Ha.
    destruct Ha1; unfold Sub; split; eauto.
    assert (Ha : WFTyp B) by eauto.
    assert (c = C1). eapply sub_coherent. apply Ha. apply H5. auto. auto. substs.
    admit. (* seems provable *)
Admitted.

Definition id := STLam (STBVar 0).
Definition idType a := STFun a a.

Definition app := STLam (STLam (STApp (STBVar 1) (STBVar 0))).
Definition appType a b := STFun (STFun a b) (STFun a b).

Lemma app_id :
  forall A B,
    has_type_st empty app (appType A B) ->
    forall f, has_type_st empty f (STFun A B) ->
         STValue f ->
         equiv_ fullred (STApp app f) f.
Proof.
  introv Typ1 Typ2 Value.
  inverts Value; inverts Typ2.
  unfold app.
  apply* equiv_trans.
  unfold open; simpls; repeat case_nat.

Admitted.

Lemma consistency_fullred :
  forall e A c1 m, has_type_source_alg empty e m A c1 ->
              forall e', bired e e' ->
                    forall c2, has_type_source_alg empty e' m A c2 ->
                         equiv_ fullred c1 c2.
Proof.
  introv Typ.
  gen_eq E: (empty:env PTyp). lets Typ': Typ.
  induction* Typ; intros; substs.
  - inverts* H3.
  - inverts* H2; inverts H1.
  - inverts* H0.
    + inverts* H1.
      assert (HH : exists c, has_type_source_alg empty e3 Inf (Fun A B) c).
      apply soundness; apply completeness in Typ1; lets* Ha : subject_reduction Typ1.
      destruct HH.
      assert (Ha : Fun A0 B = Fun A B) by (eapply typ_inf_unique; eauto); inverts Ha; clear H.
      assert (E2 = E3) by apply* typ_coherence; subst.
      lets* Ha1 : IHTyp1 Typ1 H4 H3.
    + inverts H3; inverts H. inverts H1. inverts Typ1.
      inverts H1.
      inverts H6.
      inverts H1.
      inverts H4.
      inverts Typ1.
      lets* Ha1 : IHTyp2 Typ2 H5 H6.
      assert (E0 = E1) by apply* typ_coherence; subst.
      lets Ha2 : type_preservation H6.
      unfold conv_context in Ha2; rewrite map_empty in Ha2. eauto.
    + inverts H3.
      inverts Typ1.
      inverts H.
      inverts H1.
      inverts H3.
      clear IHTyp1 IHTyp2.
      assert (E1 = E0) by (eapply typ_coherence; eauto).
      subst.
      apply* fullred_equiv_app_r.

      inverts Typ2. inverts H4.
      assert (Ha : exists E4, has_type_source_alg empty e Inf A E4). admit.
      destruct Ha.
      inverts H6.
      inverts H2.
      forwards* Ha : typ_unique H2 H3. destruct Ha.
      assert (x = E1). apply* typ_coherence. substs.
      assert (C1 = C0). apply @sub_coherent with (A := A) (B := A0); eauto. substs.

      admit. (* property about subred ? *)
    + clear IHTyp1 IHTyp2.
      inverts Typ1.
      inverts H1; clear H5.
      inverts H4.
      admit. (* beta reduction *)
    + clear IHTyp1 IHTyp2.
      inverts Typ1.
      admit. (* beta reduction *)
  - inverts H1; inverts H2.
    + lets* Ha1 : IHTyp1 Typ1 ___ H7.
      assert (E2 = E3) by apply* typ_coherence; substs*.
    + lets* Ha1 : IHTyp2 Typ2 ___ H9.
      assert (E1 = E0) by apply* typ_coherence; substs*.
  - inverts H0.
    + inverts H1; forwards* Ha : IHTyp Typ.
    + inverts H1.
      admit. (* property about subred ? *)
    + inverts Typ.
      inverts H1.
      clear IHTyp.
      inverts Typ'; clear H8.
      assert (Ha : A = A0) by eauto. symmetry in Ha; subst.
      assert (c2 = E0). eapply typ_coherence; eauto. subst; clear H1.
      admit. (* induction H0 and discharge cases using H4? *)
  - lets* Ha : IHTyp Typ H2.
    inverts H3.
    inverts* H2.
    assert (A = A0).
    lets* Ha1 : completeness Typ.
    lets* Ha2 : subject_reduction Ha1 H2.
    apply soundness in Ha2; destruct Ha2; eapply typ_inf_unique; eauto.
    subst.
    lets* Ha3 : Ha H1.
    assert (C0 = C).
    eapply @sub_coherent with (B := B) (A := A0); auto; apply* typing_wf_source_alg.
    subst.
    lets* Ha4 : type_correct_coercions H4 ___.
Admitted.


From Undecidability.L Require Export Datatypes.LBool Datatypes.LNat Datatypes.LTerm.
Require Import Nat.
From Undecidability.L Require Import Tactics.LTactics Functions.EqBool.
Import EqBool.
(* * Extracted Functions *)

(* ** Extracted equality of encoded terms *)

Fixpoint term_eqb s t :=
  match s,t with
  | var n, var m => eqb n m
  | L.app s1 t1, L.app s2 t2 => andb (term_eqb s1 s2) (term_eqb t1 t2)
  | lam s',lam t' => term_eqb s' t'
  | _,_ => false
  end.

Lemma term_eqb_spec : forall x y1 : term, reflect (x = y1) (term_eqb x y1).
Proof with try (constructor;congruence).
  induction x;cbn; destruct y1...
  - destruct (eqb_spec n n0)...
  -destruct (IHx1 y1_1)...
   destruct (IHx2 y1_2)...
  -destruct (IHx y1)...
Qed.

#[global]
Instance eqbTerm : eqbClass term_eqb.
Proof.
  exact term_eqb_spec.
Qed.

Global
Instance eqbComp_nat : eqbComp term.
Proof.
  constructor. unfold term_eqb.
  extract.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.lib.Coqlib.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.TheoryOfSequentCalculus.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.

Module ModalLogic_Pub.

Inductive L_Pub : Type :=
  |atomp : nat -> L_Pub
  |falsep : L_Pub
  |impp : L_Pub -> L_Pub -> L_Pub
  |boxa : L_Pub -> L_Pub
  |boxb : L_Pub -> L_Pub
  |boxc : L_Pub -> L_Pub
  |A0 : L_Pub
  |B0 : L_Pub
  |C0 : L_Pub.

Definition negp (l : L_Pub) :=
  impp l falsep.
Definition orp (l1 l2 : L_Pub) :=
  impp (negp l1) l2.
Definition andp (l1 l2 : L_Pub) :=
  negp (orp (negp l1) (negp l2)).
Definition iffp (l1 l2 : L_Pub) :=
  andp (impp l1 l2)(impp l2 l1).
Definition truep := negp falsep.
Definition diamonda (l : L_Pub) :=
  negp (boxa (negp l)).
Definition diamondb (l : L_Pub) :=
  negp (boxb (negp l)).
Definition diamondc (l : L_Pub) :=
  negp (boxc (negp l)).

Notation "~~ x" := (negp x) (at level 35).
Notation "x --> y" := (impp x y)(at level 55, right associativity).
Notation "x || y" := (orp x y)(at level 50, left associativity).
Notation "x && y" := (andp x y)(at level 40, left associativity).
Notation "x <--> y" := (iffp x y) (at level 60, no associativity).
Reserved Notation "|-- P " (at level 71, no associativity).

Inductive T_Pub : L_Pub -> Prop:=
  | A_P1: forall p q, |-- (p --> (q --> p))
  | A_P2: forall p q r, |-- ((p --> q --> r) --> (p --> q) --> (p --> r))
  | A_P3: forall p q, |-- (~~p --> q) --> ((~~p --> ~~q) --> p)
  (*代入规则在Coq中总是被承认的*)
  | MP: forall a b, |-- (a --> b) -> |--a -> |-- b

  | K_AXIOM_A: forall p q, |-- boxa (p --> q) --> (boxa p --> boxa q)
  | T_AXIOM_A: forall p, |-- (boxa p) --> p
  | N_RULE_A: forall a, |-- a -> |-- boxa a
  | PUB_ASSERT_A: |-- boxa A0 || boxa (~~A0)

  | K_AXIOM_B: forall p q, |-- boxb (p --> q) --> (boxb p --> boxb q)
  | T_AXIOM_B: forall p, |-- (boxb p) --> p
  | N_RULE_B: forall a, |-- a -> |-- boxb a
  | PUB_ASSERT_B: |-- boxb B0 || boxb (~~B0)

  | K_AXIOM_C: forall p q, |-- boxc (p --> q) --> (boxc p --> boxc q)
  | T_AXIOM_C: forall p, |-- (boxc p) --> p
  | N_RULE_C: forall a, |-- a -> |-- boxc a
  | PUB_ASSERT_C: |-- boxc C0 || boxc (~~C0)
where "|-- P" := (T_Pub P).
(* in this Module, we always try to use a/b/c... when talking
abort rule, and use p/q/r... when talking abort axiom or lemma*)

Instance MLPubL: Language := {|
  expr := ModalLogic_Pub.L_Pub
|}.

Instance MLPubminL: MinimumLanguage MLPubL := {|
  Logic.MinimumLogic.Syntax.impp := ModalLogic_Pub.impp
|}.

Instance MLPubpL: PropositionalLanguage MLPubL := {|
  Logic.PropositionalLogic.Syntax.andp := ModalLogic_Pub.andp;
  Logic.PropositionalLogic.Syntax.orp := ModalLogic_Pub.orp;
  Logic.PropositionalLogic.Syntax.falsep := ModalLogic_Pub.falsep
|}.

Instance MLPubGamma: Provable MLPubL := {|
  provable := ModalLogic_Pub.T_Pub
|}.

Instance MLPubminAX: MinimumAxiomatization MLPubL MLPubGamma.
Proof.
  constructor.
  + apply ModalLogic_Pub.MP.
  + apply ModalLogic_Pub.A_P1.
  + apply ModalLogic_Pub.A_P2.
Qed.

Instance T_Pub_impp_rewrite: RewriteRelation (fun x y => |-- x --> y).
Qed.
Instance T_Pub_impp_refl : Reflexive (fun x y => |-- impp x y).
Proof.
  pose proof provable_impp_refl_instance.
  apply H.
Qed.
Instance T_Pub_proper_impp : Proper ((fun x y => |-- impp x y) ==> Basics.impl) T_Pub.
Proof.
  pose proof provable_proper_impp.
  apply H.
Qed.
Instance impp_proper_impp : Proper ((fun x y => |-- impp x y) --> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) impp.
Proof.
  pose proof impp_proper_impp.
  apply H.
Qed.

Lemma RG : forall a b, |-- a -> |-- b --> a.
Proof.
  intros.
  pose proof A_P1 a b.
  pose proof MP _ _ H0 H.
  apply H1. Qed.

Lemma impp_refl: forall (p: L_Pub), |-- p --> p.
Proof.
  intros.
  pose proof provable_impp_refl p.
  apply H.
  Qed.

Lemma impp_substitute: forall p q, |-- p --> (p --> q) --> q.
Proof.
  intros.
  pose proof aux_minimun_theorem02 p q.
  apply H. Qed.

Lemma impp_trans: forall (p q r: L_Pub), |--  (q --> r) --> (p --> q) --> (p --> r).
Proof.
  intros.
  pose proof aux_minimun_theorem00 p q r.
  apply H. Qed.

Lemma RS_pre: forall (a b c: L_Pub), |-- (b --> c) -> |-- (a --> b) --> (a --> c).
Proof.
  intros a b c.
  pose proof aux_minimun_rule01 b c a.
  apply H. Qed.

Lemma RS: forall (a b c: L_Pub), |-- (b --> c) -> |-- (a --> b) -> |--(a --> c).
Proof.
  intros.
  pose proof RS_pre a b c H.
  pose proof MP _ _ H1 H0.
  apply H2. Qed.

Lemma impp_trans_infer1: forall p q r s, |-- (r --> s) --> (p --> q --> r) --> (p --> q --> s).
Proof.
  intros.
  pose proof impp_trans q r s.
  pose proof impp_trans p (q --> r) (q --> s).
  pose proof RS _ _ _ H0 H.
  apply H1. Qed.

Lemma RS_infer1: forall a b c d, |-- c --> d -> |-- a --> b --> c -> |-- a --> b --> d.
Proof.
  intros.
  pose proof impp_trans_infer1 a b c d.
  pose proof MP _ _ H1 H.
  pose proof MP _ _ H2 H0.
  apply H3. Qed.

Lemma impp_switch: forall p q r, |-- (p --> (q --> r)) --> (q --> (p --> r)).
Proof.
  intros.
  pose proof provable_impp_arg_switch p q r.
  apply H. Qed.

Lemma RIS: forall a b c, |-- a --> b --> c -> |-- b --> a --> c.
Proof.
  intros.
  pose proof impp_switch a b c.
  pose proof MP _ _ H0 H.
  apply H1. Qed.

Lemma RIS_infer1: forall a b c d, |-- a --> b --> c --> d -> |-- c --> a --> b --> d.
Proof.
  intros.
  pose proof impp_switch b c d.
  pose proof impp_switch a c (b --> d).
  rewrite H0 in H.
  pose proof MP _ _ H1 H.
  apply H2. Qed.

Lemma negp_double1: forall p, |-- ~~(~~p) --> p.
Proof.
  intros.
  pose proof A_P3 p (~~p).
  pose proof impp_refl (~~p).
  pose proof MP _ _ H H0.
  pose proof A_P1 (~~(~~p)) (~~p).
  pose proof RS _ _ _ H1 H2.
  apply H3. Qed.

Lemma negp_double2: forall p, |-- p --> ~~(~~p).
Proof.
  intros.
  unfold negp.
  pose proof impp_substitute p falsep.
  apply H. Qed.

Lemma impp_comm1: forall p q, |--(~~p --> q) --> (~~q --> p).
Proof.
  intros.
  pose proof A_P1 (~~q) (~~p).
  pose proof A_P3 p (~~q).
  pose proof RS _ _ _ H0 H.
  pose proof RIS _ _ _ H1.
  pose proof negp_double2 q.
  rewrite -> H3 at 1.
  apply H2. Qed.

Lemma impp_comm2: forall p q, |--(p --> ~~q) --> (q --> ~~p).
Proof.
  intros.
  pose proof impp_comm1 (~~p) (~~q).
  pose proof negp_double1 p.
  pose proof negp_double2 q.
  rewrite <- H0 at 1.
  rewrite -> H1 at 2.
  apply H. Qed.

Lemma impp_comm3: forall p q, |--(p --> q) --> (~~q --> ~~p).
Proof.
  intros.
  pose proof impp_comm2 p (~~q).
  pose proof negp_double2 q.
  rewrite H0 at 1.
  apply H. Qed.

Lemma impp_reduc: forall p q, |-- (p --> q) --> (~~p --> q) --> q.
Proof.
  intros.
  pose proof A_P3 q (~~p).
  pose proof impp_comm3 p q.
  rewrite H0.
  pose proof impp_comm1 p q.
  rewrite H1.
  pose proof negp_double2 p.
  rewrite H2 at 2.
  apply H. Qed.

Lemma DS: forall a b, |-- a --> a --> b -> |-- a --> b.
Proof.
  intros.
  pose proof aux_minimun_theorem04 a b.
  pose proof MP _ _ H0 H.
  apply H1. Qed.

Lemma orp_intros1 : forall p q, |-- p --> (p || q).
Proof.
  unfold orp.
  intros.
  pose proof A_P1 p (~~q).
  pose proof impp_comm1 q p.
  pose proof RS _ _ _ H0 H.
  apply H1. Qed.

Lemma orp_intros2 : forall p q, |-- q --> (p || q).
Proof.
  unfold orp.
  intros.
  pose proof A_P1 q (~~p).
  apply H. Qed.

Lemma orp_elim : forall p q r, |-- (p --> r) --> (q --> r) --> ((p || q) --> r).
Proof.
  unfold orp.
  intros.
  pose proof impp_trans (~~p) q r.
  pose proof impp_reduc p r.
  pose proof RIS _ _ _ H0.
  pose proof RS_infer1 _ _ _ _ H1 H.
  pose proof RIS_infer1 _ _ _ _ H2.
  apply H3. Qed.

Lemma andp_intros : forall p q, |-- p --> (q --> (p && q)).
Proof.
  unfold andp.
  unfold orp.
  intros.
  pose proof impp_substitute p (~~q).
  pose proof impp_comm2 (p --> ~~ q) q.
  pose proof RS _ _ _ H0 H.
  pose proof impp_comm2 q (p --> ~~ q).
  rewrite H2 in H1.
  pose proof negp_double2 p.
  rewrite H3 in H1 at 2.
  pose proof impp_comm2 (~~ (~~ p) --> ~~ q) q.
  rewrite H4 in H1.
  apply H1. Qed.

Lemma andp_elim1 : forall p q,  |-- (p && q) --> p.
Proof.
  unfold andp.
  unfold orp.
  intros.
  pose proof impp_comm1 p (~~ (~~ p) --> ~~ q).
  pose proof orp_intros1 (~~p) (~~q). unfold orp in H0.
  pose proof MP _ _ H H0.
  apply H1. Qed.

Lemma andp_elim2 : forall p q, |-- (p && q) --> q.
Proof.
  unfold andp.
  unfold orp.
  intros.
  pose proof A_P1 (~~q) (~~ (~~ p)).
  pose proof impp_comm1 q (~~ (~~ p) --> ~~ q).
  pose proof MP _ _ H0 H.
  apply H1. Qed.

Lemma falsep_elim : forall p, |-- (falsep --> p).
Proof.
  intros.
  pose proof A_P3 p falsep.
  unfold negp in H.
  pose proof impp_refl falsep.
  pose proof RG _ (p --> falsep) H0.
  pose proof RG _ falsep H1.
  pose proof RIS _ _ _ H1.
  rewrite <- H3 in H.
  rewrite <- H2 in H.
  pose proof DS _ _ H.
  apply H4. Qed.

Instance MLPubipGamma: IntuitionisticPropositionalLogic MLPubL MLPubGamma.
Proof.
  constructor.
  + apply ModalLogic_Pub.andp_intros.
  + apply ModalLogic_Pub.andp_elim1.
  + apply ModalLogic_Pub.andp_elim2.
  + apply ModalLogic_Pub.orp_intros1.
  + apply ModalLogic_Pub.orp_intros2.
  + apply ModalLogic_Pub.orp_elim.
  + apply ModalLogic_Pub.falsep_elim.
Qed.

Lemma excluded_middle : forall p, |-- p || ~~ p.
Proof.
  intros.
  unfold orp.
  pose proof impp_refl (~~p).
  apply H. Qed.

Instance MLPubcpGamma: ClassicalPropositionalLogic MLPubL MLPubGamma.
Proof.
  constructor.
  + apply ModalLogic_Pub.excluded_middle.
Qed.

Lemma weak_excluded_middle: forall p, |-- ~~ p || ~~ ~~p.
Proof.
  intros.
  pose proof excluded_middle (~~p).
  apply H.
Qed.

Instance MLPubdmpGamma: DeMorganPropositionalLogic MLPubL MLPubGamma.
Proof.
  constructor.
  + apply ModalLogic_Pub.weak_excluded_middle.
Qed.

Instance T_Pub_iffp_rewrite: RewriteRelation (fun x y => |-- x <--> y).
Qed.
Instance T_Pub_iffp_equiv: Equivalence (fun x y => |-- x <--> y).
Proof.
  pose proof provable_iffp_equiv.
  apply H.
Qed.
Instance T_Pub_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> iff) T_Pub.
Proof.
  pose proof provable_proper_iffp.
  apply H.
Qed.
Instance impp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) impp.
Proof.
  pose proof impp_proper_iffp.
  apply H.
Qed.
Instance andp_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) andp.
Proof.
  pose proof andp_proper_impp.
  apply H.
Qed.
Instance orp_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) orp.
Proof.
  pose proof orp_proper_impp.
  apply H.
Qed.
Instance negp_proper_impp: Proper ((fun x y => |-- impp x y) --> (fun x y => |-- impp x y)) negp.
Proof.
  pose proof negp_proper_impp.
  apply H.
Qed.
Instance andp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) andp.
Proof.
  pose proof andp_proper_iffp.
  apply H.
Qed.
Instance orp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) orp.
Proof.
  pose proof orp_proper_iffp.
  apply H.
Qed.
Instance iffp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) iffp.
Proof.
  pose proof iffp_proper_iffp.
  apply H.
Qed.
Instance negp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) negp.
Proof.
  pose proof negp_proper_iffp.
  apply H.
Qed.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Class PubBaseLanguage (L: Language): Type := {
  boxp : expr -> expr;
  P0 : expr
}.

Definition diamondp {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {pbL: PubBaseLanguage L} (p : expr): expr :=
  Syntax.negp (boxp (Syntax.negp p)).

Class PubBaseAxiomatization (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {pbL: PubBaseLanguage L} (Gamma: Provable L) {minAX: MinimumAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {cpGamma: ClassicalPropositionalLogic L Gamma} := {
  K_AXIOM: forall p q, |-- boxp (p --> q) --> (boxp p --> boxp q);
  T_AXIOM: forall p, |-- (boxp p) --> p;
  N_RULE: forall a, |-- a -> |-- boxp a;
  PUB_ASSERT: |-- boxp P0 || boxp (~~P0)
}.

Section RewriteClass_Pub.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {pbL: PubBaseLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {cpGamma: ClassicalPropositionalLogic L Gamma}
        {dmpAX: DeMorganPropositionalLogic L Gamma}
        {pbAX: PubBaseAxiomatization L Gamma}.

Instance boxp_proper_impp : Proper ((fun x y => |-- Syntax.impp x y) ==> (fun x y => |-- Syntax.impp x y)) boxp.
Proof.
  hnf; intros x1 x2 ?.
  apply N_RULE in H.
  pose proof K_AXIOM x1 x2.
  pose proof modus_ponens _ _ H0 H.
  apply H1. Qed.

Instance boxp_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) boxp.
Proof.
  hnf; intros x1 x2 ?.
  unfold iffp in H.
  pose proof Intuitionistic.andp_elim1 (x1 --> x2) (x2 --> x1).
  pose proof modus_ponens _ _ H0 H.
  pose proof Intuitionistic.andp_elim2 (x1 --> x2) (x2 --> x1).
  pose proof modus_ponens _ _ H2 H.
  pose proof boxp_proper_impp x1 x2. hnf in H4.
  pose proof boxp_proper_impp x2 x1. hnf in H5.
  apply H4 in H1.
  apply H5 in H3.
  pose proof Intuitionistic.andp_intros (boxp x1 --> boxp x2) (boxp x2 --> boxp x1).
  pose proof modus_ponens _ _ H6 H1.
  pose proof modus_ponens _ _ H7 H3.
  unfold iffp.
  apply H8. Qed.

End RewriteClass_Pub.

Existing Instances boxp_proper_impp boxp_proper_iffp.

Section LemmaFromPubBaseAxiomatization.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {pbL: PubBaseLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {cpGamma: ClassicalPropositionalLogic L Gamma}
        {dmpAX: DeMorganPropositionalLogic L Gamma}
        {pbAX: PubBaseAxiomatization L Gamma}.

Lemma boxp_impp_refl: forall (p: expr), |-- (boxp (p --> p)).
Proof.
  intros.
  pose proof provable_impp_refl p as H1.
  pose proof N_RULE _ H1.
  apply H.
  Qed.

Lemma RK: forall (p q: expr), |-- p --> q -> |-- boxp p --> boxp q.
Proof.
  intros.
  pose proof N_RULE _ H.
  pose proof K_AXIOM p q.
  rewrite H1 in H0.
  apply H0. Qed.

Lemma T_AXIOM_infer1: forall (p: expr), |-- ~~p --> ~~ (boxp p).
Proof.
  intros.
  pose proof T_AXIOM p.
  pose proof contrapositivePP p (boxp p).
  pose proof modus_ponens _ _ H0 H.
  apply H1. Qed.

Lemma falsep_truthp_intros: forall (p q: expr), |-- (~~p) --> q --> ~~(p && q).
Proof.
  intros.
  pose proof Intuitionistic.andp_elim1 p q.
  pose proof contrapositivePP p (p && q).
  rewrite H0 in H.
  pose proof aux_minimun_rule00 _ q H.
  pose proof provable_impp_arg_switch q (~~p) (~~ (p && q)).
  rewrite H2 in H1.
  apply H1. Qed.

Lemma impp2orp_infer1: forall (p q: expr), |-- (p || q) --> (~~p --> q).
Proof.
  intros.
  pose proof impp2orp (~~p) q.
  pose proof double_negp p.
  rewrite H0 in H.
  rewrite H.
  pose proof provable_impp_refl (p || q).
  apply H1. Qed.

Lemma P_impp_boxp1: |-- P0 --> boxp P0.
Proof.
  pose proof PUB_ASSERT.
  pose proof impp2orp_infer1 (boxp P0) (boxp (~~P0)).
  rewrite H0 in H.
  pose proof T_AXIOM (~~P0).
  rewrite H1 in H.
  pose proof contrapositiveNP (~~P0) (boxp P0).
  rewrite H2 in H.
  pose proof double_negp_intros P0.
  rewrite <- H3 in H.
  apply H. Qed.

Lemma boxp_andp_elim: forall (p q: expr), |-- boxp(p && q) --> (boxp p && boxp q).
Proof.
  intros.
  pose proof Intuitionistic.andp_elim1 p q.
  pose proof Intuitionistic.andp_elim2 p q.
  pose proof RK _ _ H.
  pose proof RK _ _ H0.
  pose proof solve_impp_andp _ _ _ H1 H2.
  apply H3. Qed.

Lemma boxp_andp_intros: forall (p q: expr), |-- (boxp p && boxp q) --> boxp(p && q).
Proof.
  intros.
  pose proof Intuitionistic.andp_intros p q.
  pose proof RK _ _ H.
  pose proof K_AXIOM q (p && q).
  rewrite -> H1 in H0.
  pose proof Intuitionistic.impp_curry_uncurry (boxp p) (boxp q) (boxp (p && q)).
  rewrite H2 in H0.
  apply H0. Qed.

Lemma boxp_orp_intros: forall (p q: expr), |-- (boxp p || boxp q) --> boxp(p || q).
Proof.
  intros.
  pose proof Intuitionistic.orp_intros1 p q.
  pose proof RK _ _ H.
  pose proof Intuitionistic.orp_intros2 p q.
  pose proof RK _ _ H1.
  pose proof solve_orp_impp _ _ _ H0 H2.
  apply H3. Qed.

Lemma diamondp_boxp_intros: forall (p q: expr), |-- diamondp q --> boxp p --> diamondp (p && q).
Proof.
  intros.
  pose proof Intuitionistic.andp_intros p q.
  pose proof contrapositivePP (p&&q) q.
  rewrite H0 in H.
  pose proof RK _ _ H.
  pose proof K_AXIOM (~~ (p && q)) (~~q).
  rewrite H2 in H1.
  pose proof contrapositivePP (boxp (~~ q)) (boxp (~~ (p && q))).
  rewrite H3 in H1.
  pose proof provable_impp_arg_switch (boxp p) (~~ boxp (~~ q)) (~~ boxp (~~ (p && q))).
  rewrite H4 in H1.
  unfold diamondp.
  apply H1. Qed.

Lemma basic_situation1: forall (A B: expr), |-- ((diamondp B) && (diamondp (~~B))) --> boxp A --> (~~boxp (A&&B)).
Proof.
  intros.
  pose proof falsep_truthp_intros (boxp B) (boxp A).
  pose proof boxp_andp_elim B A.
  rewrite <- H0 in H.
  pose proof aux_minimun_rule00 _ (~~ boxp (~~B)) H.
  pose proof impp_curry (~~ boxp (~~ B)) (~~ boxp B) (boxp A --> ~~ boxp (B && A)).
  rewrite H2 in H1.
  pose proof andp_comm A B.
  rewrite <- H3 in H1.
  unfold diamondp.
  pose proof double_negp B.
  rewrite <- H4 in H1 at 2.
  apply H1. Qed.

Lemma basic_situation2: forall (A B: expr), |-- ((diamondp B) && (diamondp (~~B))) --> boxp A --> (~~boxp (~~(A&&B))).
Proof.
  intros.
  pose proof diamondp_boxp_intros A B.
  rewrite <- H.
  pose proof Intuitionistic.andp_elim1 (diamondp B) (diamondp (~~B)).
  apply H0. Qed.

Lemma andp_impp_orp: forall (p q: expr), |-- (p && q) --> (p || q).
Proof.
  intros.
  pose proof Intuitionistic.andp_elim1 p q.
  pose proof Intuitionistic.orp_intros1 p q.
  rewrite H0 in H at 2.
  apply H. Qed.

Lemma diamondp_negp_elim: forall (p q: expr), |-- diamondp (p && ~~q) && diamondp (~~p && q) && diamondp (~~p && ~~q) --> diamondp(~~(p && q)).
Proof.
  intros.
  unfold diamondp.
  pose proof andp_impp_orp p q.
  pose proof RK _ _ H.
  pose proof demorgan_negp_andp (~~p) (~~q).
  pose proof double_negp p.
  rewrite -> H2 in H1.
  pose proof double_negp q.
  rewrite -> H3 in H1.
  rewrite <- H1 in H0.
  pose proof double_negp (p && q).
  rewrite <- H4 in H0.
  rewrite <- H0.
  pose proof Minimum.provable_impp_refl (~~ boxp (~~ (~~ (p && q)))).
  pose proof aux_minimun_rule00 _ (~~ boxp (~~ (p && ~~ q)) && ~~ boxp (~~ (~~ p && q))) H5.
  pose proof impp_curry (~~ boxp (~~ (p && ~~ q)) && ~~ boxp (~~ (~~ p && q))) (~~ boxp (~~ (~~ (p && q)))) (~~ boxp (~~ (~~ (p && q)))).
  rewrite -> H7 in H6.
  apply H6. Qed.

Lemma diamondp_negp_elim_infer1: forall (p q: expr), |-- diamondp (p && q) && diamondp (p && ~~q) && diamondp (~~p && q) && diamondp (~~p && ~~q) --> diamondp (p && q) && diamondp(~~(p && q)).
Proof.
  intros.
  pose proof andp_assoc (diamondp (p && q) && diamondp (p && ~~ q)) (diamondp (~~ p && q)) (diamondp (~~ p && ~~ q)).
  rewrite -> H.
  pose proof andp_assoc (diamondp (p && q)) (diamondp (p && ~~ q)) (diamondp (~~ p && q) && diamondp (~~ p && ~~ q)).
  rewrite -> H0.
  pose proof andp_assoc (diamondp (p && ~~ q)) (diamondp (~~ p && q)) (diamondp (~~ p && ~~ q)).
  rewrite <- H1.
  pose proof diamondp_negp_elim p q.
  rewrite -> H2.
  pose proof Minimum.provable_impp_refl (diamondp (p && q) && diamondp (~~ (p && q))).
  apply H3. Qed.

Lemma andp_intros_infer1: forall (A B C: expr), |-- ~~A --> ~~(A&&B&&C).
Proof.
  intros.
  pose proof Intuitionistic.andp_elim1 A (B&&C).
  pose proof contrapositivePP A (A && (B && C)).
  pose proof modus_ponens _ _ H0 H.
  pose proof andp_assoc A B C.
  rewrite H2.
  apply H1. Qed.

Lemma P_impp_boxp2: |-- ~~P0 --> boxp (~~P0).
Proof.
  pose proof PUB_ASSERT.
  pose proof orp_comm (boxp P0) (boxp (~~ P0)).
  rewrite H0 in H.
  pose proof impp2orp_infer1 (boxp (~~ P0)) (boxp P0).
  rewrite H1 in H.
  pose proof T_AXIOM P0.
  rewrite H2 in H.
  pose proof contrapositiveNP P0 (boxp (~~ P0)).
  rewrite H3 in H.
  apply H. Qed.

Lemma boxp_orp_intros_infer1: forall (p q: expr), |-- boxp p --> boxp (p || ~~q).
Proof.
  intros.
  pose proof boxp_orp_intros p (~~q).
  pose proof Intuitionistic.orp_intros1 (boxp p) (boxp (~~q)).
  rewrite <- H0 in H.
  apply H. Qed.

Lemma diamondp_andp_minus: forall (p q: expr), |-- (diamondp (p && q) && diamondp (p && ~~q) && diamondp (~~p && q) && diamondp (~~p && ~~q)) --> boxp p --> diamondp q && diamondp (~~ q).
Proof.
  intros.
  unfold diamondp.
  pose proof boxp_orp_intros_infer1 p q.
  pose proof aux_minimun_rule00 _ (~~ (~~ boxp (~~ q) && ~~ boxp (~~ (~~ q)))) H.
  pose proof provable_impp_arg_switch (~~ (~~ boxp (~~ q) && ~~ boxp (~~ (~~ q)))) (boxp p) (boxp (p || ~~ q)).
  rewrite -> H1 in H0.
  pose proof contrapositiveNP (boxp (p || ~~ q)) (~~ boxp (~~ q) && ~~ boxp (~~ (~~ q))).
  rewrite -> H2 in H0.
  pose proof provable_impp_arg_switch (boxp p) (~~ boxp (p || ~~ q)) (~~ boxp (~~ q) && ~~ boxp (~~ (~~ q))).
  rewrite -> H3 in H0.
  pose proof demorgan_negp_andp (~~p) q.
  pose proof double_negp p.
  rewrite -> H5 in H4.
  rewrite <- H4 in H0.
  pose proof Intuitionistic.andp_elim1 (~~ boxp (~~ (~~ p && q))) (~~ boxp (~~ (~~ p && ~~ q))).
  rewrite <- H6 in H0.
  pose proof aux_minimun_rule00 _ (~~ boxp (~~ (p && q)) && ~~ boxp (~~ (p && ~~ q))) H0.
  pose proof impp_curry (~~ boxp (~~ (p && q)) && ~~ boxp (~~ (p && ~~ q))) (~~ boxp (~~ (~~ p && q)) && ~~ boxp (~~ (~~ p && ~~ q))) (boxp p --> ~~ boxp (~~ q) && ~~ boxp (~~ (~~ q))).
  rewrite -> H8 in H7.
  pose proof andp_assoc (~~ boxp (~~ (p && q)) && ~~ boxp (~~ (p && ~~ q))) (~~ boxp (~~ (~~ p && q))) (~~ boxp (~~ (~~ p && ~~ q))).
  rewrite <- H9 in H7.
  apply H7. Qed.

Lemma andp_dup_infer1: forall (p q r: expr), |-- (p&&q&&r) --> (p&&q&&q&&r).
Proof.
  intros.
  pose proof andp_dup q.
  rewrite <- H at 1.
  pose proof andp_assoc p q q.
  rewrite <- H0.
  pose proof Minimum.provable_impp_refl (p && q && q && r).
  apply H1. Qed.

Lemma andp_assoc_infer1: forall (p q r s: expr), |-- (p&&q) --> (q&&r) --> s -> |-- (p --> q --> r --> s).
Proof.
  intros.
  pose proof Intuitionistic.impp_curry_uncurry p q (r-->s).
  pose proof Intuitionistic.impp_curry_uncurry (p && q) r s.
  rewrite -> H1 in H0.
  rewrite H0.
  pose proof andp_dup_infer1 p q r.
  rewrite -> H2.
  pose proof Intuitionistic.impp_curry_uncurry (p && q) (q && r) s.
  pose proof andp_assoc (p&&q) q r.
  rewrite -> H4.
  rewrite <- H3.
  apply H. Qed.

Lemma andp_intros_infer2: forall (A B C: expr), |-- A --> B --> C --> (A&&B&&C).
Proof.
  intros.
  pose proof Intuitionistic.andp_intros (A&&B) C.
  rewrite <- H.
  pose proof Intuitionistic.andp_intros A B.
  apply H0. Qed.

Lemma boxp_one_unknown1: forall (B C: expr), |--(diamondp (B && C) && diamondp (B && ~~C) && diamondp (~~B && C) && diamondp (~~B && ~~C)) --> P0 --> (~~boxp (P0&&B&&C)).
Proof.
  intros.
  pose proof basic_situation1 P0 (B&&C).
  pose proof P_impp_boxp1.
  rewrite <- H0 in H.
  pose proof diamondp_negp_elim_infer1 B C.
  rewrite <- H1 in H.
  pose proof andp_assoc P0 B C.
  rewrite <- H2 in H.
  apply H. Qed.

Lemma boxp_one_unknown2: forall (B C: expr), |-- (diamondp (B && C) && diamondp (B && ~~C) && diamondp (~~B && C) && diamondp (~~B && ~~C)) --> P0 --> (~~boxp (~~(P0&&B&&C))).
Proof.
  intros.
  pose proof basic_situation2 P0 (B&&C).
  pose proof P_impp_boxp1.
  rewrite <- H0 in H.
  pose proof diamondp_negp_elim_infer1 B C.
  rewrite <- H1 in H.
  pose proof andp_assoc P0 B C.
  rewrite <- H2 in H.
  apply H. Qed.

Lemma boxp_from_unknown1: forall (B C: expr), |-- (~~ boxp (P0&&B&&C) && ~~ boxp (~~(P0&&B&&C))) --> P0.
Proof.
  intros.
  pose proof andp_intros_infer1 P0 B C.
  pose proof N_RULE _ H.
  pose proof K_AXIOM (~~ P0) (~~ (P0 && B && C)).
  pose proof modus_ponens _ _ H1 H0.
  pose proof P_impp_boxp2.
  rewrite <- H3 in H2.
  pose proof contrapositiveNP (boxp (~~ (P0 && B && C))) P0.
  pose proof modus_ponens _ _ H4 H2.
  pose proof aux_minimun_rule00 _ (~~ boxp (P0 && B && C)) H5.
  pose proof impp_curry (~~ boxp (P0 && B && C)) (~~ boxp (~~(P0 && B && C))) P0.
  pose proof modus_ponens _ _ H7 H6.
  apply H8. Qed.

Lemma boxp_from_unknown2: forall (A C: expr), |-- (~~ boxp (A&&P0&&C) && ~~ boxp (~~(A&&P0&&C))) --> P0.
Proof.
  intros.
  pose proof boxp_from_unknown1 A C.
  pose proof andp_comm A P0.
  rewrite H0.
  apply H. Qed.

Lemma boxp_two_unknown1: forall (A C: expr), |-- (diamondp (A && C) && diamondp (A && ~~C) && diamondp (~~A && C) && diamondp (~~A && ~~C)) --> boxp A --> P0 --> (~~boxp (A&&P0&&C)).
Proof.
  intros.
  pose proof basic_situation1 (A&&P0) C.
  pose proof boxp_andp_intros A P0.
  pose proof P_impp_boxp1.
  rewrite <- H1 in H0.
  rewrite <- H0 in H.
  pose proof diamondp_andp_minus A C.
  pose proof impp_curry (diamondp (A && C) && diamondp (A && ~~ C) && diamondp (~~ A && C) && diamondp (~~ A && ~~ C)) (boxp A) (diamondp C && diamondp (~~ C)).
  rewrite -> H3 in H2.
  rewrite <- H2 in H.
  pose proof andp_assoc_infer1 _ _ _ _ H.
  apply H4. Qed.

Lemma boxp_two_unknown2: forall (A C: expr), |-- (diamondp (A && C) && diamondp (A && ~~C) && diamondp (~~A && C) && diamondp (~~A && ~~C)) --> boxp A --> P0 --> (~~boxp (~~(A&&P0&&C))).
Proof.
  intros.
  pose proof basic_situation2 (A&&P0) C.
  pose proof boxp_andp_intros A P0.
  pose proof P_impp_boxp1.
  rewrite <- H1 in H0.
  rewrite <- H0 in H.
  pose proof diamondp_andp_minus A C.
  pose proof impp_curry (diamondp (A && C) && diamondp (A && ~~ C) && diamondp (~~ A && C) && diamondp (~~ A && ~~ C)) (boxp A) (diamondp C && diamondp (~~ C)).
  rewrite -> H3 in H2.
  rewrite <- H2 in H.
  pose proof andp_assoc_infer1 _ _ _ _ H.
  apply H4. Qed.

Lemma boxp_from_hear: forall (p q: expr), |-- boxp p --> boxp (p --> q) --> boxp q.
Proof.
  intros.
  pose proof aux_minimun_theorem02 p q.
  pose proof RK _ _ H.
  pose proof K_AXIOM (p --> q) q.
  rewrite -> H1 in H0.
  apply H0. Qed.

Lemma boxp_three_know: forall (A B: expr), |-- boxp A --> boxp B --> P0 --> boxp (A&&B&&P0).
Proof.
  intros.
  pose proof andp_intros_infer2 A B P0.
  pose proof N_RULE _ H.
  pose proof K_AXIOM A (B --> P0 --> A && B && P0).
  rewrite H1 in H0.
  pose proof K_AXIOM B (P0 --> A && B && P0).
  rewrite H2 in H0.
  pose proof K_AXIOM P0 (A && B && P0).
  rewrite H3 in H0.
  pose proof P_impp_boxp1.
  rewrite <- H4 in H0.
  apply H0. Qed.

End LemmaFromPubBaseAxiomatization.

Instance MLPubpbL_a: PubBaseLanguage MLPubL := {|
  boxp := ModalLogic_Pub.boxa;
  P0 := ModalLogic_Pub.A0
|}.

Instance MLPubpbAX_a: @PubBaseAxiomatization MLPubL _ _ MLPubpbL_a MLPubGamma _ _ _.
Proof.
  constructor.
  + apply ModalLogic_Pub.K_AXIOM_A.
  + apply ModalLogic_Pub.T_AXIOM_A.
  + apply ModalLogic_Pub.N_RULE_A.
  + apply ModalLogic_Pub.PUB_ASSERT_A.
Qed.

Instance boxa_proper_impp : Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) boxa.
Proof.
  pose proof boxp_proper_impp.
  apply H.
Qed.

Instance boxa_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) boxa.
Proof.
  pose proof boxp_proper_iffp.
  apply H.
Qed.

Instance MLPubpbL_b: PubBaseLanguage MLPubL := {|
  boxp := ModalLogic_Pub.boxb;
  P0 := ModalLogic_Pub.B0
|}.

Instance MLPubpbAX_b: @PubBaseAxiomatization MLPubL _ _ MLPubpbL_b MLPubGamma _ _ _.
Proof.
  constructor.
  + apply ModalLogic_Pub.K_AXIOM_B.
  + apply ModalLogic_Pub.T_AXIOM_B.
  + apply ModalLogic_Pub.N_RULE_B.
  + apply ModalLogic_Pub.PUB_ASSERT_B.
Qed.

Instance boxb_proper_impp : Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) boxb.
Proof.
  pose proof boxp_proper_impp.
  apply H.
Qed.

Instance boxb_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) boxb.
Proof.
  pose proof boxp_proper_iffp.
  apply H.
Qed.

Instance MLPubpbL_c: PubBaseLanguage MLPubL := {|
  boxp := ModalLogic_Pub.boxc;
  P0 := ModalLogic_Pub.C0
|}.

Instance MLPubpbAX_c: @PubBaseAxiomatization MLPubL _ _ MLPubpbL_c MLPubGamma _ _ _.
Proof.
  constructor.
  + apply ModalLogic_Pub.K_AXIOM_C.
  + apply ModalLogic_Pub.T_AXIOM_C.
  + apply ModalLogic_Pub.N_RULE_C.
  + apply ModalLogic_Pub.PUB_ASSERT_C.
Qed.

Instance boxc_proper_impp : Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) boxc.
Proof.
  pose proof boxp_proper_impp.
  apply H.
Qed.

Instance boxc_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) boxc.
Proof.
  pose proof boxp_proper_iffp.
  apply H.
Qed.

Lemma boxa_one_unknown1: |--(diamonda (B0 && C0) && diamonda (B0 && ~~C0) && diamonda (~~B0 && C0) && diamonda (~~B0 && ~~C0)) --> A0 --> (~~boxa (A0&&B0&&C0)).
Proof.
  pose proof @boxp_one_unknown1 MLPubL _ _ MLPubpbL_a MLPubGamma _ _ _ _ _ B0 C0.
  apply H.
Qed.

Lemma boxa_one_unknown2: |-- (diamonda (B0 && C0) && diamonda (B0 && ~~C0) && diamonda (~~B0 && C0) && diamonda (~~B0 && ~~C0)) --> A0 --> (~~boxa (~~(A0&&B0&&C0))).
Proof.
  pose proof @boxp_one_unknown2 MLPubL _ _ MLPubpbL_a MLPubGamma _ _ _ _ _ B0 C0.
  apply H.
Qed.

Lemma boxa_from_unknown: |-- (~~ boxa (A0&&B0&&C0) && ~~ boxa (~~(A0&&B0&&C0))) --> A0.
Proof.
  pose proof @boxp_from_unknown1 MLPubL _ _ MLPubpbL_a MLPubGamma _ _ _ _ B0 C0.
  apply H.
Qed.

Lemma boxb_two_unknown1: |-- (diamondb (A0 && C0) && diamondb (A0 && ~~C0) && diamondb (~~A0 && C0) && diamondb (~~A0 && ~~C0)) --> boxb A0 --> B0 --> (~~boxb (A0&&B0&&C0)).
Proof.
  pose proof @boxp_two_unknown1 MLPubL _ _ MLPubpbL_b MLPubGamma _ _ _ _ _ A0 C0.
  apply H.
Qed.

Lemma boxb_two_unknown2: |-- (diamondb (A0 && C0) && diamondb (A0 && ~~C0) && diamondb (~~A0 && C0) && diamondb (~~A0 && ~~C0)) --> boxb A0 --> B0 --> (~~boxb (~~(A0&&B0&&C0))).
Proof.
  pose proof @boxp_two_unknown2 MLPubL _ _ MLPubpbL_b MLPubGamma _ _ _ _ _ A0 C0.
  apply H.
Qed.

Lemma boxb_from_unknown: |-- (~~ boxb (A0&&B0&&C0) && ~~ boxb (~~(A0&&B0&&C0))) --> B0.
Proof.
  pose proof @boxp_from_unknown2 MLPubL _ _ MLPubpbL_b MLPubGamma _ _ _ _ A0 C0.
  apply H.
Qed.

Lemma boxc_from_hear: forall (p q: L_Pub), |-- boxc p --> boxc (p --> q) --> boxc q.
Proof.
  intros.
  pose proof @boxp_from_hear MLPubL _ _ MLPubpbL_c MLPubGamma _ _ _ _ p q.
  apply H.
Qed.

Lemma boxc_three_know: |-- boxc A0 --> boxc B0 --> C0 --> boxc (A0&&B0&&C0).
Proof.
  pose proof boxp_three_know A0 B0.
  apply H.
Qed.

Lemma impp_curry_uncurry: forall p q r, |-- (p --> q --> r) <--> (p && q --> r).
Proof.
  intros.
  pose proof Intuitionistic.impp_curry_uncurry p q r.
  apply H.
Qed.

Lemma solve_impp_andp_infer1: forall p q r s, |-- p --> q --> r -> |-- p --> q --> s -> |-- p --> q --> r&&s.
Proof.
  intros.
  pose proof impp_curry_uncurry p q r.
  rewrite H1 in H.
  pose proof impp_curry_uncurry p q s.
  rewrite H2 in H0.
  pose proof solve_impp_andp (p && q) r s H H0.
  pose proof impp_curry_uncurry p q (r && s).
  rewrite <- H4 in H3.
  apply H3.
Qed.

Lemma solve_impp_andp_infer2: forall p q r s t, |-- p --> q --> r --> s -> |-- p --> q --> r --> t -> |-- p --> q --> r --> s&&t.
Proof.
  intros.
  pose proof impp_curry_uncurry p q (r --> s).
  pose proof impp_curry_uncurry (p && q) r s.
  rewrite H2 in H1.
  rewrite H1 in H.
  pose proof impp_curry_uncurry p q (r --> t).
  pose proof impp_curry_uncurry (p && q) r t.
  rewrite H4 in H3.
  rewrite H3 in H0.
  pose proof solve_impp_andp (p && q && r) s t H H0.
  pose proof impp_curry_uncurry p q (r --> s && t).
  pose proof impp_curry_uncurry (p && q) r (s && t).
  rewrite H7 in H6.
  rewrite <- H6 in H5.
  apply H5.
Qed.

Lemma impp_curry_uncurry_infer1: forall a b c p q, |-- (a --> p && q --> b --> c) -> |-- (a --> p --> q --> b --> c).
Proof.
  intros.
  pose proof impp_curry_uncurry p q (b --> c).
  rewrite <- H0 in H.
  apply H.
Qed.

Lemma A_DONT_KNOW: |-- boxa ((diamonda (B0 && C0) && diamonda (B0 && ~~C0) && diamonda (~~B0 && C0) && diamonda (~~B0 && ~~C0)) --> A0 --> (~~boxa (A0&&B0&&C0)) && (~~boxa (~~(A0&&B0&&C0)))).
Proof.
  pose proof boxa_one_unknown1.
  pose proof boxa_one_unknown2.
  pose proof solve_impp_andp_infer1 _ _ _ _ H H0.
  pose proof N_RULE_A _ H1.
  apply H2. Qed.

Lemma B_DONT_KNOW: |-- boxb ((diamondb (A0 && C0) && diamondb (A0 && ~~C0) && diamondb (~~A0 && C0) && diamondb (~~A0 && ~~C0)) --> boxb (~~boxa (A0&&B0&&C0) && ~~boxa (~~(A0&&B0&&C0))) --> B0 --> (~~boxb (A0&&B0&&C0)) && (~~boxb (~~(A0&&B0&&C0)))).
Proof.
  pose proof boxa_from_unknown.
  rewrite -> H.
  pose proof boxb_two_unknown1.
  pose proof boxb_two_unknown2.
  pose proof solve_impp_andp_infer2 _ _ _ _ _ H0 H1.
  pose proof N_RULE_B _ H2.
  apply H3. Qed.

Lemma C_KNOW: |-- boxc (boxc (~~boxa (A0&&B0&&C0) && ~~boxa (~~(A0&&B0&&C0))) --> boxc (boxb (~~boxa (A0&&B0&&C0) && ~~boxa (~~(A0&&B0&&C0)))) --> boxc (boxb (~~boxa (A0&&B0&&C0) && ~~boxa (~~(A0&&B0&&C0))) --> ~~boxb (A0&&B0&&C0) && ~~boxb (~~(A0&&B0&&C0))) --> C0 --> boxc (A0&&B0&&C0)).
Proof.
  pose proof boxc_from_hear (boxb (~~ boxa (A0 && B0 && C0) && ~~ boxa (~~ (A0 && B0 && C0)))) (~~ boxb (A0 && B0 && C0) && ~~ boxb (~~ (A0 && B0 && C0))).
  pose proof impp_curry_uncurry (boxc (boxb (~~ boxa (A0 && B0 && C0) && ~~ boxa (~~ (A0 && B0 && C0))))) (boxc (boxb (~~ boxa (A0 && B0 && C0) && ~~ boxa (~~ (A0 && B0 && C0))) --> ~~ boxb (A0 && B0 && C0) && ~~ boxb (~~ (A0 && B0 && C0)))) (boxc (~~ boxb (A0 && B0 && C0) && ~~ boxb (~~ (A0 && B0 && C0)))).
  rewrite -> H0 in H.
  pose proof boxa_from_unknown.
  pose proof boxb_from_unknown.
  pose proof boxc_three_know.
  rewrite <- H2 in H3 at 1.
  rewrite <- H1 in H3 at 1.
  rewrite <- H in H3.
  pose proof impp_curry_uncurry_infer1 _ _ _ _ _ H3.
  pose proof N_RULE_C _ H4.
  apply H5. Qed.

End ModalLogic_Pub.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require real.Real.
Require real.RealInfix.

Parameter pow2: Z -> R.

Axiom Power_0 : ((pow2 0%Z) = 1%R).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_s_all : forall (n:Z), ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (Rdiv 1%R 2%R)%R).

Axiom Power_1 : ((pow2 1%Z) = 2%R).

Axiom Power_neg1 : ((pow2 (-1%Z)%Z) = (05 / 10)%R).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 2.

(* Why3 goal *)
Theorem Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z ->
  ~ ((pow2 n) = 0%R).
intros n Hn.
generalize Hn.
pattern n; apply Z_lt_induction; auto.
ae.
Qed.


Load ch2_ref.

(* Chapter 2 Exercises *)
Section Chapter_2_Exercises.

  (* Exercise 2.1 *)
  (* let's redefine path composition 3 ways for the exercise *)
  Lemma pc1 {A : UU} {x y z : A} (p : x=y) (q : y=z) : x=z.
  Proof. induction p; induction q; reflexivity. Defined.
  Lemma pc2 {A : UU} {x y z : A} (p : x=y) (q : y=z) : x=z.
  Proof. induction p; apply q. Defined.
  Lemma pc3 {A : UU} {x y z : A} (p : x=y) (q : y=z) : x=z.
  Proof. induction q; apply p. Defined.

  Lemma pc1_is_2 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc1 p q = pc2 p q.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc2_is_3 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc2 p q = pc3 p q.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc1_is_3 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc1 p q = pc3 p q.
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.2 *)
  Lemma pc_proof_triangle {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc1 (pc1_is_2 p q) (pc2_is_3 p q) = pc1_is_3 p q.
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.3 *)
  Lemma pc4 {A : UU} {x y z : A} (p : x=y) (q : y=z) : x=z.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc4_is_1 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc4 p q = pc1 p q.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc4_is_2 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc4 p q = pc2 p q.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc4_is_3 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc4 p q = pc3 p q.
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.4 *)
  (* from the book:
       Define, by induction on n, a general notion of
       'n-dimensional path' in a type A, simultaneously with
       the type of boundaries for such paths.

     fill in here... *)

  (* Exercise 2.5 *)
  (* function 2.3.6 *)
  Definition ap_to_apd {A B : UU} {x y : A} (f : A -> B) (p : x=y)
        (apf : f x = f y)
    : p # (f x) = f y
    := transport_const B p (f x) ∙ apf.
  (* function 2.3.7 *)
  Definition apd_to_ap {A B : UU} {x y : A} (f : A -> B) (p : x=y)
             (apdf : p # (f x) = f y)
    : f x = f y
    := inv (transport_const B p (f x)) ∙ apdf.
  (* state and prove that these are inverse equivalences *)
  (* fill in here... *)

  (* Exercise 2.6 *)
  (* note that this was left as an example in the chapter... *)
  Example example_2_4_8 {A : UU} {x y z : A} (p : x=y)
    : isequiv (λ q:y=z, p ∙ q).
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.7 *)
  Print ap_paireq.
  (* generalize the theorem just printed to Σ-types *)
  (* hint: try drawing topological pictures to get an intuition
           for why and where to use transports etc. *)
  (* fill in here *)

  (* Exercise 2.8 *)
  (* generalize the theorem from the last exercise to coproduct types
     instead of Σ-types now *)
  (* fill in here... *)
  (* not sure what this should be *)

  (* Exercise 2.9 *)
  Theorem univf_coprod {A B : UU} {X : UU}
    : (A + B -> X) ≃ (A -> X) × (B -> X).
  Proof. (* fill in here... *)
  Defined.
  (* state and prove a theorem 'univ_coprod', a dependent version *)
  (* note: can you basically copy and paste the proof from above?
           what does it mean to have a more general proposition
           proved by the same proof in light of Curry-Howard? *)
  (* fill in here... *)

  (* Exercise 2.10 *)
  Lemma sig_assoc {A : UU} {B : A -> UU} {C : total B -> UU}
    : (Σ (x:A) (y:B x), C{x;y}) ≃ (Σ (p:total B), C p).
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.11 *)
  (* how this all gets formalized might be tricky or up for debate. *)
  (* fill in here... *)

  (* Exercise 2.12 *)
  (* TODO... *)

  (* Exercise 2.13 *)
  Theorem two_is_two_is_two : (𝟚 ≃ 𝟚) ≃ 𝟚.
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.14 *)
  (* left for paper work... *)

  (* Exercise 2.15 *)
  Lemma stronger_2_10_5 {A : UU} {B : A->UU} {x y : A} {p : x=y}
    : transport B p = (idtoeqv (ap B p)).1 .
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.16 *)
  (* skipping, due to comments on difficulty/reliance on
     un-covered material *)

  (* Exercise 2.17 *)
  Theorem prodeqv1 {A A' B B' : UU}
    : (A ≃ A')×(B ≃ B') -> (A×B) ≃ (A'×B').
  Proof. (* fill in here... *)
  Defined.

  Theorem prodeqv2 {A A' B B' : UU}
    : (A ≃ A')×(B ≃ B') -> (A×B) ≃ (A'×B').
  Proof. (* fill in here... *)
  Defined.

End Chapter_2_Exercises.


C02W82DBHV2R:~ i847419$ coqtop
Welcome to Coq 8.8.0 (April 2018)

Coq < Require Import Classical.

Coq < Theorem exp003: (forall M V : Prop, ((M /\ ~V) /\ ~M) -> V).
1 subgoal

  ============================
  forall M V : Prop, (M /\ ~ V) /\ ~ M -> V

exp003 < intros.
1 subgoal

  M, V : Prop
  H : (M /\ ~ V) /\ ~ M
  ============================
  V

exp003 < destruct H.
1 subgoal

  M, V : Prop
  H : M /\ ~ V
  H0 : ~ M
  ============================
  V

exp003 < destruct H.
1 subgoal

  M, V : Prop
  H : M
  H1 : ~ V
  H0 : ~ M
  ============================
  V

exp003 < tauto.
No more subgoals.

exp003 < Qed.
exp003 is defined


From discprob.basic Require Import base order nify exp_ext.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp quickselect_rec.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coquelicot Require Import Derive.
From Coquelicot Require AutoDerive.
Require Import Reals Fourier FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.

Module Type rec_factor.
  Parameter alpha : R.
  Parameter alpha_range: 1/2 < alpha < 1.
  Parameter ln_alpha: -/ln alpha > 1/alpha.
End rec_factor.

Module recurrence_log (ALPHA: rec_factor).
  Import ALPHA.
  Definition d := 1.
  Definition umin := 1.

  Definition a x :=
    match Rle_dec x 1 with
      | left _ => 0
      | _ =>
        match Rlt_dec x 2 with
        | left _ => (x - 1)
        | _ => 1
        end
    end.

  Definition m x :=
    match Rlt_dec x (1/alpha) with
      | left _ => 0
      | _ => x * alpha
    end.

  Definition k := -/ ln(alpha).

  Definition u x :=
    match Rle_dec x 1 with
      | left _ => 1
      | _ => ((k * ln x + 1))
    end.

  Definition u' x :=
    match Rle_dec x 1 with
      | left _ => 1
      | _ => exp ((x - 1) / k)
    end.

  Lemma umin_non_neg: 0 ≤ umin.
  Proof. rewrite /umin; fourier. Qed.

  Lemma Rlt_0_ln x: 1 < x → 0 < ln x.
  Proof.
    intros Hlt; rewrite -ln_1; apply ln_increasing; fourier.
  Qed.

  Lemma one_lt_inv_alpha:
    1 < / alpha.
  Proof.
    generalize (alpha_range), ln_alpha; intros.
    apply (Rmult_lt_reg_l alpha); first nra. field_simplify; nra.
  Qed.

  Lemma kgt1: 1 < k.
  Proof.
    generalize (alpha_range), ln_alpha; intros.
    rewrite /k.
    transitivity (/ alpha); last auto; try nra.
    apply one_lt_inv_alpha.
  Qed.

  Lemma kgt0: 0 < k.
  Proof.
    etransitivity; last apply kgt1. fourier.
  Qed.

  Lemma u_mono x y: x ≤ y → u x ≤ u y.
  Proof.
    rewrite /u/a/m/d => Hle.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    -
      cut (0 ≤ ln y).
      {
        intros. generalize kgt1 => ?.
        assert (k * ln y ≥ 0).
        { transitivity (1 * ln y); last fourier.
          apply Rle_ge, Rmult_le_compat; try fourier.
        }
        fourier.
      }
      left. apply Rlt_0_ln; nra.
    - specialize (kgt0) => Hk.
      apply Rplus_le_compat; last nra.
      cut (ln x ≤ ln y).
      {
        specialize (kgt0); cut (0 ≤ ln x); intros; first apply Rmult_le_compat; auto; try fourier.
        rewrite -(ln_1). left; apply ln_increasing; nra.
      }
      * inversion Hle; auto; subst; last by nra. left. apply ln_increasing; intros; nra.
  Qed.

  (* This basically covers half the case for the above, so could remove some redundancy *)
  Lemma u_strict_inc x y: x ≥ d → x < y → u x < u y.
  Proof.
    rewrite /u/a/m/d => Hle Hlt.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    - specialize (kgt0) => Hk.
      assert (0 < k * ln y).
      {
        apply Rmult_lt_0_compat; first nra.
        apply Rlt_0_ln; fourier.
      }
      rewrite ?Rmult_1_r //=; nra.
    - specialize (kgt0) => Hk.
      apply Rplus_lt_compat_r.
      cut (ln x < ln y).
      {
        specialize (kgt0); cut (0 < ln x); intros; first apply Rmult_lt_compat_l; auto; try fourier.
        rewrite -(ln_1). apply ln_increasing; nra.
      }
      apply ln_increasing; nra.
  Qed.

  Lemma u'_mono x y: x ≤ y → u' x ≤ u' y.
  Proof.
    rewrite /u'/a/m/d => Hle.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    - rewrite -{1}exp_0.
      left; apply exp_increasing.
      rewrite /Rdiv. apply Rlt_mult_inv_pos; last apply kgt0. nra.
    - apply exp_increasing_le.
      generalize (kgt0) => Hk.
      apply Rdiv_le_compat_contra; nra.
  Qed.

  Lemma u'_pos x: u' x > 0.
  Proof.
    rewrite /u'/a/m/d.
    destruct (Rle_dec _); try nra.
    apply exp_pos.
  Qed.

  Lemma u'_inv_above x: d < x → u' (u x) = x.
  Proof.
    rewrite /u/u'/d.
    destruct (Rle_dec) as [Hc1|Hc1] => //=; try nra;
    destruct (Rle_dec) as [Hc2|Hc2] => //=; try nra.
    - intros. exfalso.
      assert (0 < ln x) by (apply Rlt_0_ln; auto).
      assert (0 < k * ln x) by (apply Rmult_lt_0_compat; auto using kgt0).
      assert (0 < (k * ln x) * (k * ln x)) by (repeat apply Rmult_lt_0_compat; auto using kgt0).
      nra.
    - rewrite -[a in _ = a]exp_ln; last nra.
      intros; do 1 f_equal.
      assert (0 < ln x) by (apply Rlt_0_ln; auto).
      assert (0 < k * ln x) by (apply Rmult_lt_0_compat; auto using kgt0).
      field. apply Rgt_not_eq, kgt0.
  Qed.

  Lemma u'u x: x ≤ u' (u x).
  Proof.
    destruct (Rlt_dec 1 x) as [Hlt|Hnlt].
    - rewrite u'_inv_above //. reflexivity.
    - rewrite /u/u'.
      apply Rnot_lt_le in Hnlt.
      destruct (Rle_dec) => //=; try nra.
      destruct (Rle_dec) => //=; try nra.
  Qed.

  Lemma u_inv_above x: umin < x → u (u' x) = x.
  Proof.
    rewrite /u/u'/umin.
    destruct (Rle_dec) as [Hc1|?] => //=; try nra;
    destruct (Rle_dec) as [?|?] => //=; try nra.
    - exfalso. rewrite -{2}exp_0 in Hc1.
      apply exp_le_embedding in Hc1.
      specialize (kgt1) => Hk.
      cut (0 < (x - 1) / k).
      { by intros ?%Rlt_not_le. }
      apply Rdiv_lt_0_compat; nra.
    - rewrite ln_exp. rewrite /Rdiv. intros.
      field. apply Rgt_not_eq, kgt0.
  Qed.

  Lemma ud_umin: u d = umin.
  Proof.
    rewrite /u/d/umin//=.
    destruct (Rle_dec); nra.
  Qed.

  Lemma u_cont: continuity u.
  Proof.
    apply piecewise_continuity' with (g := λ x, (k * ln x + 1))
                                      (f := λ x, 1) (z := 1).
    - intros; apply continuity_const => ? //.
    - intros. repeat apply continuity_pt_mult.
      * apply continuity_pt_plus.
        ** apply continuity_pt_mult.
           *** apply continuity_pt_const => ? //.
           *** apply ln_continuity_pt; fourier.
        ** apply continuity_pt_const => ? //.
    - rewrite /u => x. destruct (Rle_dec); nra.
    - rewrite /u => x.
      destruct (Rle_dec); intros.
      * assert (x = 1) as -> by (apply Rle_antisym; fourier).
        rewrite ln_1 Rmult_0_r Rplus_0_l. done.
      * done.
  Qed.

  Lemma a_cont_pt: ∀ x, d < x → continuity_pt a x.
  Proof.
    rewrite /d. intros.
    apply piecewise_continuity_pt with (P := λ x, d < x)
                                               (g := λ x,
                                                     match Rlt_dec x 2 with
                                                     | left _ => (x - 1)
                                                     | _ => 1
                                                     end)
                                               (f := λ x, 0) (z := 1).
    - intros. apply continuity_const => ??. done.
    - intros. apply piecewise_continuity_pt with (g := λ x, 1)
                                                 (f := λ x, (x - 1))
                                                 (z := 2)
                                                 (P := λ x, d < x);
                try (intros; destruct (Rlt_dec); nra); try nra.
      * rewrite /d. intros.
        ** apply continuity_minus.
           *** apply continuity_id => ??.
           *** apply continuity_const => ??. done.
      * intros. apply continuity_const => ?? //=.
    - intros x'. rewrite /a. destruct Rle_dec; try nra; destruct Rlt_dec; nra.
    - intros x'. rewrite /a. destruct Rle_dec; nra.
    - rewrite /d. intros. fourier.
    - rewrite /d. fourier.
  Qed.

  Lemma kinv: /k = ln (/alpha).
  Proof.
    rewrite /k.
    generalize (alpha_range), ln_alpha; intros.
    rewrite ln_Rinv; last by nra.
    assert (0 < ln (/alpha)).
    { rewrite -ln_1. apply ln_increasing; first nra. apply one_lt_inv_alpha. }
    rewrite Ropp_inv_permute.
    - rewrite Rinv_involutive //.
      cut (ln alpha ≠ 0); first by nra.
      apply Rlt_not_eq. rewrite -ln_1.
      apply ln_increasing; nra.
    - cut (ln alpha ≠ 0); first by nra.
      apply Rlt_not_eq. rewrite -ln_1.
      apply ln_increasing; nra.
  Qed.

  Lemma urec0 x: x > d → u x ≥ a x + u (m x).
  Proof.
    generalize (alpha_range), ln_alpha => ??.
    rewrite /u/a/m/d.
    destruct (Rle_dec) as [Hc1|Hc1] => //=; first nra.
    destruct (Rle_dec) as [Hc2|Hc2] => //=.
    - destruct (Rlt_dec) as [?|?].
      {
        destruct (Rlt_dec) as [?|?]; try nra; last first.
        { intros.
          assert (1 / alpha < 2).
          { destruct alpha_range as (Hlt&?).
            apply Rinv_lt_contravar in Hlt; last nra.
            nra.
          }
          nra.
        }
        intros.
        transitivity (x - 1 +  1); last first.
        { right. field. }
        cut (k * ln x > x - 1); first by (intros; fourier).
        cut (k * ln x - (x - 1) > 0); first by (intros; fourier).
        apply Rlt_gt.
        eapply (Rle_lt_trans _ (k * ln(1) - (1 - 1))).
        { right. rewrite ln_1 Rmult_0_r. field. }
        eapply incr_function_le with (f := λ x, k * ln x - (x - 1))
                                               (x := 1)
                                               (y := x)
                                               (a := 1)
                                               (b := /alpha)
                                               (df := λ x, k * 1/x - 1); try fourier; eauto.
        * rewrite //= => ???. AutoDerive.auto_derive; nra.
        * rewrite //=. intros x' ? ?.
          cut (k */ x' > 1).
          { intros. set (p := k */ x'). assert (p > 1) by (rewrite /p; auto).
            nra.
          }
          apply Rlt_gt, (Rmult_lt_reg_r x'); first fourier.
          rewrite Rmult_assoc Rinv_l; first (rewrite /k; nra).
          apply Rgt_not_eq; fourier.
        * rewrite //=. nra.
        * rewrite //=. nra.
      }
      assert (x = /alpha) as ->.
      {
        apply (Rmult_le_compat_r (/alpha)) in Hc2; last first.
        {
          left. transitivity 1; first nra. apply one_lt_inv_alpha.
        }
        rewrite Rmult_assoc Rinv_r in Hc2; last first.
        { apply Rgt_not_eq. nra. }
        rewrite Rmult_1_l Rmult_1_r in Hc2.
        apply Rle_antisym; nra.
      }
      destruct (Rlt_dec); last by nra.
      intros; rewrite -kinv Rinv_r; first nra.
      apply Rgt_not_eq, kgt0.
    - assert (0 < ln x) by (apply Rlt_0_ln; nra).
      destruct (Rlt_dec); first by nra; intros.
      intros; rewrite ln_mult; try nra.
      rewrite (Rmult_plus_distr_l k _).
      assert (k * ln (alpha) = -1) as ->.
      { rewrite /k. field. apply Rlt_not_eq.
        rewrite -(ln_1). apply ln_increasing; nra.
      }
      destruct Rlt_dec.
      * field_simplify; last nra.
      * rewrite /Rdiv; first fourier.
  Qed.

  Lemma alower: ∀ x, x ≤ d → a x = 0.
  Proof.
    rewrite /a => x; destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma a_nonneg: ∀ x, a x ≥ 0.
  Proof.
    intros. rewrite /a. destruct (Rlt_dec); destruct (Rle_dec); nra.
  Qed.

  Lemma a_pos: ∀ x, d < x → 0 < a x.
  Proof.
    rewrite /d/a => ??. destruct (Rlt_dec); destruct (Rle_dec); nra.
  Qed.

  Lemma a_mono: Rmono a.
  Proof.
    rewrite /Rmono. intros x x' Hle.
    inversion Hle; subst; try reflexivity.
    destruct (Rle_dec d x) as [?|?%Rnot_le_gt].
    * rewrite /a. do 2 (destruct (Rle_dec); try destruct (Rlt_dec)); nra.
    * rewrite alower; auto; try fourier. apply Rge_le, a_nonneg.
  Qed.

  Lemma mnondec: ∀ y y', 0 < y → y ≤ y' → (m y / y) ≤ (m y' / y').
  Proof.
    generalize (alpha_range), ln_alpha => ??.
    intros y y' Hlt Hle.
    rewrite /m.
    destruct (Rlt_dec).
    {  destruct (Rlt_dec).
       - intros. rewrite /Rdiv ?Rmult_0_l. fourier.
       - intros. rewrite /Rdiv ?Rmult_0_l.
         rewrite Rmult_comm -Rmult_assoc Rinv_l; nra.
    }
    destruct (Rlt_dec); first by nra.
    intros. right. field. split; apply Rgt_not_eq; fourier.
  Qed.

  Lemma d_non_neg: 0 ≤ d.
  Proof.
    rewrite /d. fourier.
  Qed.

End recurrence_log.


Require Import Arith.
Require Import Coq.Logic.JMeq.
Inductive fin:nat->Type:=
|car:forall m,fin m
|cdr:forall m:nat,fin m->fin(S m).
Program Fixpoint getfin(i n:nat):fin n:=
match n as x with
|0=>car n
|S n'=>match i with
|0=>car n
|S i'=>cdr _ (getfin i' n')
end end.

Definition cons n(i0:nat)(rest:fin n->nat):fin (S n)->nat.
intro.
generalize (refl_equal (S n)).
pattern n at 2.
refine match H in (fin k)
return (S n=k->nat)
with
|car Sn=>(fun _ _=>i0) Sn
|cdr n0 rest'=> _ n0
end.
intros.
SearchPattern (S _=S _->_=_).
apply eq_add_S in H0.
rewrite <-H0 in rest'.
exact (rest rest').
Defined.

Definition nil(_:fin 0):nat:=0.

Notation "[ a , b ]" := (cons _ a b).

Eval compute in getfin 3 4.
Inductive Recu:nat->Type:=
|add:Recu 2
|mul:Recu 2
|proj:forall k,fin k->Recu k
|equal:Recu 2
|synth:forall n:nat,forall m:nat,(fin n->Recu m)->Recu n->Recu m
|mu:forall n:nat,forall con:nat->fin n->Prop,forall argv:fin n,(exists b:nat,con b argv)->Recu n.
Definition nth n(argv:fin n->nat)(i:nat):nat
:=
if negb(leb i n) then argv (getfin i n) else 0.

Notation "a [ b ]":=(nth _ a b) (at level 200).

Definition eqtest m n(H:m=n)(i:fin m->nat):fin n->nat.
rewrite <-H.
exact i.
Defined.
Print eqtest.
Print eq_rec.

Program Fixpoint eval n (f:Recu n)(a:fin n->nat):nat:=
match f with
|add=>((nth _ a 0) + (nth _ a 1))
|mul=>((nth _ a 0) * (nth _ a 1))
|proj k ind=>a _
|equal=> if(beq_nat (nth _ a 0)(nth _ a 1)) then 1 else 0
|synth k n funcs g=> eval k g (fun i:fin k=>eval n ( funcs i) (eqtest _ _ _ a))
|mu n con argv proof=> match proof  as H with
|ex_intro x H00=>
((fix tmp0(y:nat):nat:=
match y with
|0=>x
|S y'=>if (negb (leb x (x-y)))
then x-y else tmp0 y' end)x)
end
end.
Obligation 1.
apply ind.
Defined.