     (* Time-stamp: <Mon 2/9/15 16:19 Dan Dougherty Strands.v> *)

(* TO FIX:

 - better name for "path", "is_path", ...

 - can we avoid the default-value trick in the "ith" function?

*)
(* Things to learn how to do:

 1) once you prove "exists x, blah(x)"
    how to introduce, in a Section, a named Variable
    satifying blah, to use>

 2) How to extract minimum elements for a predicate?  Ie. would like a
    function from inhabited predicates to nodes, rturning minimal
    nodes.
*)

(* Add LoadPath "./". *)
(* Add LoadPath "./Classical_Wf". *)
Require Import Classical.
Require Import Message_Algebra.
Require Import Lists.ListSet.
Require Import Lists.List.
Require Import Omega ZArith.

Open Scope list_scope.
Import ListNotations.
Open Scope ma_scope.

(** * The signature (vocabulary) for the models *)
(*  *************************************** *)

Variable node : Set.
(* Variable strand : Set. *)
Definition strand : Type := list smsg.
Variable role : Set.
(* Predicate for positive and negative nodes *)
Variable xmit : node -> Prop.
Variable recv : node -> Prop.

Variable smsg_of : node -> smsg.
Definition msg_of : node -> msg :=
  fun (n:node) => smsg_2_msg (smsg_of n).
Hint Resolve msg_of.

Variable msg_deliver : node -> node -> Prop.
Variable ssucc : node ->  node -> Prop.
Definition path : Type := list (prod node msg).
(* Variable regular_strand : set strand. *)
(* Variable penetrable_strand : set strand.*)
Variable strand_of: node -> strand.
(* Predicates for regular nodes and penetrable nodes *)
Variable p_node : node -> Prop.
Variable r_node : node -> Prop.

(* not needed here...do it in protocol specs *)
(* Variable role_of: strand -> role.   (** maybe should be a relation *) *)

(** * Some defined notions *)
(*  ************************ *)

(** *** Predecessor along a strand *)
Definition spred : node -> node -> Prop := fun x y => ssucc y x.

(** *** Strand-predecessor or message-deliver *)
Definition prec_generator : node -> node -> Prop  :=
  fun n m => ssucc n m \/ msg_deliver n m.

(** *** Transitive closures *)
(*  ------------------- *)

(* Transitive closure of strand-successor *)
Inductive ssuccs (x z: node) : Prop :=
| ssuccs_step : ssucc x z -> ssuccs x z
| ssuccs_trans (y': node) : ssucc x y'-> ssuccs y' z  -> ssuccs x z.

(* Transitive closure of strand-predecessor *)
Inductive spreds (x z: node) : Prop :=
| spreds_step : spred x z -> spreds x z
| spreds_trans (y': node) : spred x y'-> spreds y' z  -> spreds x z.

(* Transitive closure of (ssucc \/ msg_deliver) *)
Inductive prec (x z: node) : Prop :=
| prec_ssucc_step : ssucc x z -> prec x z
| prec_msg_step :  msg_deliver x z -> prec x z
| prec_ssucc_trans (y': node) : ssucc x y'-> prec y' z  -> prec x z
| prec_msg_trans (y': node) : msg_deliver x y'-> prec y' z  -> prec x z.

(** *** Reflexive-Transitive closures *)
(*  ---------------------------- *)

(* Reflexive_Transitive closure of strand-successor *)
Inductive ssuccseq (x z: node) : Prop :=
| ssuccseq_refl : x = z -> ssuccseq x z
| ssuccseq_trans : ssuccs x z -> ssuccseq x z.

(* Reflexive_Transitive closure of strand-predecessor *)
Inductive spredseq  (x z: node) : Prop :=
| spredseq_refl : x = z -> spredseq x z
| spredseq_trans : spreds x z -> spredseq x z.

(* Reflexive_Transitive closure of (ssucc \/ msg_deliver) *)
Inductive preceq  (x z: node) : Prop :=
| preceq_refl : x = z -> preceq x z
| preceq_trans : prec x z -> preceq x z.

(** Minimal nodes *)

Definition is_minimal: (node -> Prop) -> node -> Prop :=
  fun P x => (P x) /\ forall y, (prec y x) -> ~( P y).

Definition has_min_elt: (node -> Prop) -> Prop :=
  fun P  =>   exists x:node, is_minimal P x.

(** *** Origination *)

Definition orig_at : node -> msg -> Prop :=
  fun (n:node) (m:msg) =>
    xmit(n) /\  (ingred m (msg_of n)) /\
    (forall (n':node), ( (ssuccs n' n) ->
      (ingred m (msg_of n')) ->
      False)).

Definition non_orig : msg -> Prop :=
  fun (m:msg) =>
    forall (n:node), ~orig_at n m.

Definition unique : msg -> Prop :=
  fun (m:msg) =>
    (exists (n:node), orig_at n m) /\
    (forall  (n n':node),
      (orig_at n m) /\ (orig_at n' m) ->
      n=n').

(* (*  Need this? *) *)

(* Definition sent_by : node -> msg -> Prop :=  *)
(*   fun (n: node) (m: msg) => *)
(*     exists (n' :node) , (preceq n' n) /\ (msg_of n') = m. *)

(** ** Decidable equality *)
(*  ---------------------------  *)

(** Q: what's the difference between Variable and Axiom here? %\\%
*)
Variable eq_msg_dec : forall x y : msg, {x = y} + {x <> y}.
Hint Resolve eq_msg_dec.
Variable eq_node_dec : forall x y : node, {x = y} + {x <> y}.
Hint Resolve eq_node_dec.
(* Variable eq_strand_dec : forall x y : strand, {x = y} + {x <> y}.
Hint Resolve eq_strand_dec.
*)

(** * Axioms *)
(*  ******** *)

(** ** xmit and recv *)

(** no node is both transmit and receive %\\% *)
Axiom xmit_vs_recv: forall (n:node),  xmit(n) /\ recv(n) -> False.

(** every  node is either transmit or receive %\\% *)
Axiom xmit_or_recv: forall (n: node), xmit n \/ recv n.

(** strand-successor is irreflexive %\\% *)
Axiom ssucc_not_ref: forall (n:node),  ssucc n n -> False.

(** strand-successors are unique %\\% *)
Axiom ssucc_partial_fun:
  forall (n n1 n2: node),  ssucc n n1 /\ ssucc n n2  -> n1 = n2.

(** Every node and its successor are on the same strand *)
Axiom ssucc_same_strand :
  forall (n1 n2 : node), ssucc n1 n2 -> strand_of n1 = strand_of n2.
Hint Resolve ssucc_same_strand.

(** Every sign message of a node must belong to node's strand *)
Axiom smsg_on_strand :
  forall n l, strand_of n = l -> set_In (smsg_of n) l.

(** If a sign message of a node is possitive, then it is a positive node *)
Axiom positive_smsg :
  forall (n:node) (m:msg), smsg_of n = + m -> xmit n.

(** If a sign message of a node is negative, then it is a negative node *)
Axiom negative_smsg :
  forall (n:node) (m:msg), smsg_of n = - m -> recv n.

(** Every regular node lies on a regular strand *)

(** Every penetrator node lies on a penetrator strand *)

(** Lemma for strand_of *)
Lemma ssuccs_same_strand :
  forall (n1 n2 : node), ssuccs n1 n2 -> strand_of n1 = strand_of n2.
Proof.
  intros n1 n2 Hs.
  induction Hs.
  auto.
  assert (Hs' : strand_of x = strand_of y'). auto.
  rewrite IHHs in Hs'. auto.
Qed.

(** ** Message-delivery relation *)
(*  ---------------------------  *)

(** *** Messages match *)
Axiom msg_deliver_ax :
  forall x y : node, (msg_deliver x y) ->
    (xmit x /\ recv y /\ msg_of x = msg_of y).

(** *** The bundle axiom: every received  message was sent  *)
Axiom was_sent : forall x : node, (recv x) ->
  (exists y : node,  msg_deliver y x).

(** ** Well-foundedness *)

(* Better would be to just postulate well_founded for (ssucc \/ msg-deliver)
*)
Axiom wf_prec: well_founded prec.

(** * Theorems *)
(*  ********** *)

(** ** Baby results about xmit and recv *)

Lemma xmit_not_recv: forall n, xmit n -> ~(recv n).
Proof.
  intros.
  unfold not.
  intros.
  apply xmit_vs_recv with (n:=n).
  tauto.
Qed.

Lemma recv_not_xmit: forall n, recv n -> ~(xmit n).
Proof.
  intros n0 H0 H.
  apply xmit_vs_recv with (n:=n0).
  tauto.
Qed.

Lemma not_xmit_recv: forall n,  ~(xmit n) -> (recv n).
Proof.
  unfold not.
  intro.
  assert (a1: (xmit n \/ recv n)).
  exact (xmit_or_recv n).
  tauto.
Qed.

Lemma not_recv_xmit: forall n,  ~(recv n) -> (xmit n).
Proof.
  unfold not.
  intro.
  assert (a1: (xmit n \/ recv n)).
  exact (xmit_or_recv n).
  tauto.
Qed.

(** ** Baby results about prec *)

Theorem prec_transitive:
  forall x y z, (prec x y) -> (prec y z) -> (prec x z).
Proof.
  intros.
  induction H.
  eapply (prec_ssucc_trans). apply H.
  auto.

  eapply (prec_msg_trans). apply H.
  auto.

  eapply (prec_ssucc_trans).
  apply H.
  auto.
  eapply (prec_msg_trans).
  apply H.
  auto.
Qed.

Lemma deliver_prec:
  forall n0 n1, (msg_deliver n0 n1) -> (prec n0 n1).
Proof.
  intros.
  apply prec_msg_step; auto.
Qed.

Lemma ssucc_prec:
  forall n0 n1, (ssucc n0 n1) -> (prec n0 n1).
Proof.
  intros.
  apply prec_ssucc_step; auto.
Qed.

Lemma ssuccs_prec:
  forall n0 n1, (ssuccs n0 n1) -> (prec n0 n1).
Proof.
  intros.
  induction H.
  apply ssucc_prec; auto.
  assert (prec x y').
  apply ssucc_prec; auto.
  apply prec_transitive with (y:=y'); auto.
Qed.

(** ** Baby results about origination
   Some of these would be axioms, in a first-order axiomatization
*)

(* (these are ugly proofs, I'm just flailing around) :*)

Lemma
  orig_is_sent :
  forall (n : node) (m : msg), orig_at n m ->  (ingred m (msg_of n)).

Proof.
  unfold orig_at.
  tauto.
Qed.

Lemma
  non_not_originate :
  forall (n : node) (m : msg), non_orig m -> orig_at n m -> False.
Proof.
  intros n0 m0 H0.
  unfold non_orig in H0.
  intros H1.
  unfold orig_at in H1.
  destruct H1.
  destruct H1.
  assert (a0: orig_at n0 m0).
  unfold orig_at.
  auto.
  assert (na0: ~ (orig_at n0 m0)).
  apply H0.
  tauto.
Qed.

Lemma
  unique_only_once :
  forall (m : msg) (n n' : node),
    unique m -> orig_at n m -> orig_at n' m -> n = n'.
Proof.
  intros.
  unfold unique in  H.
  destruct H.
  apply H2.
  tauto.
Qed.

Lemma
  orig_not_sent_earlier :
  forall (n n' : node) (m : msg),
    (orig_at n m) ->  (ssucc n' n) ->  (ingred m (msg_of n')) -> False.
Proof.
  intros n0 n'0 m0 H0.
  intros H1.
  intros H2.
  unfold orig_at in H0.
  destruct H0.
  destruct H0.
  apply (H3 n'0).
  apply (ssuccs_step); auto.
  auto.
Qed.

Lemma
  unique_does_originate :
  forall m : msg, unique m -> exists n : node, orig_at n m.
Proof.
  intros.
  unfold unique in H.
  destruct H.
  destruct H.
  exists x. auto.
Qed.

Lemma msg_deliver_prec:
  forall n0 n1, (msg_deliver n0 n1) -> (prec n0 n1).
Proof.
  intros.
  apply prec_msg_step; auto.
Qed.

(** ** Every inhabited predicate has a prec-minimal element *)
Theorem always_min_elt :  forall P: node-> Prop,
  (exists (x:node), (P x)) -> has_min_elt P.
Proof.
  intros.
  destruct H.
  revert x H.
  unfold has_min_elt.
  unfold is_minimal.
  apply (@well_founded_ind node prec (wf_prec)
    (fun x:node =>
      P x -> exists y:node, P y /\ (forall z:node, prec z y  ->   ~ (P z) ))).
  intros.
  case (classic (forall y:node, P y -> ~ prec y x)).
  intros.
  exists x.
  split.
  auto.
  intros.
  assert (a2: P z -> ~ prec z x).
  apply H1.
  tauto.
  intros.
  apply not_all_ex_not in H1.
  destruct H1.
  apply imply_to_and in H1.
  destruct H1.
  apply NNPP in H2.
  apply H with (y:=x0).
  assumption.
  assumption.
Qed.

(** ** prec is acyclic *)

Theorem prec_is_acyclic: forall (x:node), (prec x x) -> False.
Proof.
  intros x H.
  assert (has_min_elt (fun x => prec x x )).
  apply always_min_elt.
  exists x;  auto.
  unfold has_min_elt in H0.
  destruct H0.
  destruct H0.
  assert (prec x0 x0 -> ~ prec x0 x0 ).
  apply H1.
  tauto.
Qed.

(** * Ingredients must originate *)

Section IngredientsOriginate.

  Variable the_m: msg.
  Definition m_ingred (n: node): Prop := ingred the_m (msg_of n).

(** If m is an ingredient somewhere then there is a minimal such place *)

  Lemma
    ingred_min:
    (exists n:node,  (m_ingred n)) ->
    (exists n:node, (is_minimal m_ingred n)).
  Proof.
    intros H.
    apply always_min_elt; auto.
  Qed.

(** A minimal node can't be a reception *)

  Lemma
    minimal_not_recv:
    forall (n:node), (is_minimal m_ingred n) ->
      ~ (recv n).
  Proof.
    unfold not.
    intros.
    unfold is_minimal in H.
    destruct H.
    assert (a1: exists n1, msg_deliver n1 n).
    apply was_sent; auto.

    destruct a1.
    assert (a2: prec x n).
    apply deliver_prec; auto.

    assert (a3: ~(m_ingred x)).
    apply H1; auto.
    assert (a4: m_ingred x).

    assert (a5: msg_of x = msg_of n).
    apply msg_deliver_ax; auto.
    unfold m_ingred.
    unfold m_ingred in H.
    rewrite a5; auto.
    tauto.
  Qed.

(** So, a minimal node must be a transmission *)

  Lemma minimal_is_xmit:   forall (n:node), (is_minimal m_ingred n) ->
    (xmit n).
  Proof.
    intros.
    apply not_recv_xmit.
    apply minimal_not_recv; auto.
  Qed.

(** Main result of this section: an ingredient must originate *)

  Theorem
    ingred_originates_2:
    (exists n:node, (ingred the_m (msg_of n))) ->
    (exists n:node, (orig_at n the_m)).
  Proof.
    intros.
    assert (a1: has_min_elt m_ingred).
    apply always_min_elt.
    unfold m_ingred; auto.
    unfold orig_at.
    unfold has_min_elt in a1.
    destruct a1.
    assert (a0: xmit x).
    apply minimal_is_xmit; auto.

    unfold m_ingred in H0.
    unfold is_minimal in H0.
    destruct H0.
    exists x.
    split.
    auto.
    split.
    auto.
    intros.
    assert (a1: prec n' x).
    apply ssuccs_prec; auto.
    revert H3.
    unfold not in H1.
    apply H1; auto.
  Qed.

End IngredientsOriginate.

(*********************************************************************)

(** * Penetrator Strands *)
Section PenetratorStrand.
  Parameter K_p : set Key.

  Inductive MStrand (s : strand) : Prop :=
  | P_M : forall t : Text, s = [+ (T t)] -> MStrand s.
  Hint Constructors MStrand.

  Inductive KStrand (s : strand) : Prop :=
  | P_K : forall k : Key, set_In k K_p -> s = [+ (K k)] -> KStrand s.
  Hint Constructors KStrand.

  Inductive CStrand (s : strand) : Prop :=
  | P_C : forall (g h : msg), s = [- g; - h; + (P g h)] -> CStrand s.
  Hint Constructors CStrand.

  Inductive SStrand (s : strand) : Prop :=
  | P_S : forall (g h : msg), s = [- (P g h); + g ; + h] -> SStrand s.
  Hint Constructors SStrand.

  Inductive EStrand (s : strand) : Prop :=
  | P_E : forall (k : Key) (h :msg), s = [- (K k); - h; + (E h k)] -> EStrand s.
  Hint Constructors EStrand.

  Inductive DStrand (s : strand) : Prop :=
  | P_D : forall (k k' : Key) (h :msg),
    inv k k' -> s = [- ( K k'); - (E h k); + h] -> DStrand s.
  Hint Constructors DStrand.

  (*Definition PenetratorStrand (s : strand) : Prop :=
    MStrand s \/ KStrand s \/ CStrand s \/ SStrand s \/ EStrand s \/ DStrand s.*)
  Inductive PenetratorStrand (s:strand) :Prop :=
  | PM : MStrand s -> PenetratorStrand s
  | PK : KStrand s -> PenetratorStrand s
  | PC : CStrand s -> PenetratorStrand s
  | PS : SStrand s -> PenetratorStrand s
  | PE : EStrand s -> PenetratorStrand s
  | PD : DStrand s -> PenetratorStrand s.

(* Inductive PenetratorStrand (s : strand) : Prop :=
  | P_M : forall t : Text, s = [+ (T t)] -> PenetratorStrand s
  | P_K : forall k : Key, set_In k K_p -> s = [+ (K k)] -> PenetratorStrand s
  | P_C : forall (g h : msg), s = [- g; - h; + (P g h)] -> PenetratorStrand s
  | P_S : forall (g h : msg), s = [- (P g h); + g ; + h] -> PenetratorStrand s
  | P_E : forall (k : Key) (h :msg), s = [- (K k); - h; + (E h k)] -> PenetratorStrand s
  | P_D : forall (k k' : Key) (h :msg),
          inv k k' -> s = [- ( K k'); - (E h k); + h] -> PenetratorStrand s.
Hint Constructors PenetratorStrand.
*)

(** ** Axiom about penetrator strands and penetrator nodes *)
  Axiom P_node_strand :
    forall (n:node), p_node n -> PenetratorStrand (strand_of n).

(** ** Basic Results for Penetrator Strands *)
(* If n is a node of a MStrand or KStrand, then n is a positive node *)
  Lemma MStrand_xmit_node :
    forall (n:node), MStrand (strand_of n) -> xmit n.
  Proof.
    intros n Hm.
    inversion Hm.
    assert (Hl : set_In (smsg_of n) [+ T t]).
    apply smsg_on_strand. auto.
    elim Hl.
    intros Hp. apply positive_smsg with (m:= T t). auto.
    intros He. elim He.
  Qed.

  Lemma KStrand_xmit_node :
    forall (n:node), KStrand (strand_of n) -> xmit n.
  Proof.
    intros n Hm.
    inversion Hm.
    assert (Hl : set_In (smsg_of n) [+ K k]).
    apply smsg_on_strand. auto.
    elim Hl.
    intros Hp. apply positive_smsg with (m:= K k). auto.
    intros He. elim He.
  Qed.

(** TODO : move to right place *)
  Lemma pair_not_ingred_comp_l :
    forall x y, ~(P x y) <st x.
  Proof.
    intros x y Hst.
    assert (Hlt : size (P x y ) <= size x).
    apply ingred_lt. auto.
    assert (Hgt : size (P x y) > size x).
    simpl. apply size_lt_plus_l. omega.
  Qed.

  Lemma pair_not_ingred_comp_r :
    forall x y, ~(P x y) <st y.
  Proof.
    intros x y Hst.
    assert (Hlt : size (P x y ) <= size y).
    apply ingred_lt. auto.
    assert (Hgt : size (P x y) > size y).
    simpl.
  Admitted.

  Lemma CStrand_not_falling :
    forall (s:strand), CStrand s ->
      ~ exists (n1 n2 : node), recv n1 /\ xmit n2 /\
        strand_of n1 = s /\ strand_of n2 = s /\
        ingred (msg_of n2) (msg_of n1).
  Proof.
    intros s Hcs Hc.
    destruct Hc as (n1,(n2,(Hre, (Hxmit,(Hs1,(Hs2,Hingred)))))).
    assert (Hin1 : set_In (smsg_of n1) s).
    apply smsg_on_strand. auto.
    inversion Hcs.
    assert (Hin2 : set_In (smsg_of n2) s).
    apply smsg_on_strand. auto.
    rewrite H in Hin2. elim Hin2.
    intros. apply xmit_vs_recv with (n:=n2).
    split. auto. apply negative_smsg with (m:= g). auto.
    intros Hin21. elim Hin21.
    intros. apply xmit_vs_recv with (n:=n2).
    split. auto. apply negative_smsg with (m:= h). auto.
    intros Hin22. elim Hin22.
    intros. assert (Hmsg : msg_of n2 = P g h).
    unfold msg_of. symmetry in H0. rewrite H0. unfold smsg_2_msg. auto.
    rewrite H in Hin1. inversion Hin1.
    symmetry in H1. assert (Hmsg1 : msg_of n1 = g).
    unfold msg_of. rewrite H1. unfold smsg_2_msg. auto.
    rewrite Hmsg, Hmsg1 in Hingred. apply (pair_not_ingred_comp_l g h). auto.
    elim H1. intros. symmetry in H2. assert (Hmsg1 : msg_of n1 = h).
    unfold msg_of. rewrite H2. unfold smsg_2_msg. auto.
    rewrite Hmsg, Hmsg1 in Hingred. apply (pair_not_ingred_comp_r g h). auto.
    intros Hin12. elim Hin12. intros. apply xmit_vs_recv with (n:=n1).
    split. auto. apply positive_smsg with (m:=P g h). auto. auto.
    auto. auto.
  Qed.

  Axiom EStrand_not_falling :
    forall (s:strand), EStrand s ->
      ~ exists (n1 n2 : node), n1 <> n2 /\
        strand_of n1 = s /\ strand_of n2 = s /\
        ingred (msg_of n2) (msg_of n1).

End PenetratorStrand.

(*********************************************************************)

(** * New Component *)
(** ** Component of a node *)
(** A message is a component of a node if it is a component
of the message at that node *)
Definition comp_of_node : msg -> node -> Prop :=
  fun (m:msg) (n:node) => comp m (msg_of n).
Notation "x <[node] y" := (comp_of_node x y) (at level 50) : ss_scope.

Lemma msg_deliver_comp :
  forall (n1 n2:node) (m:msg),
    msg_deliver n1 n2 /\
    comp_of_node m n2 -> comp_of_node m n1.
Proof.
  intros.
  destruct H as (H1,H2).
  unfold comp_of_node.
  assert (msg_of n1 = msg_of n2).
  apply msg_deliver_ax. auto.
  rewrite H.
  unfold comp_of_node in H2. auto.
Qed.
Hint Resolve msg_deliver_comp.

Lemma comp_of_node_imp_ingred :
  forall (m:msg) (n:node), m <[node] n -> m <st (msg_of n).
Proof.
  intros.
  unfold comp_of_node in H.
  apply comp_imp_ingred.
  assumption.
Qed.

(** ** New at *)
(** A message is new at a node if it is a component of that node
and the message is not a component of any ealier node in the same
strand with the node *)
Definition new_at : msg -> node -> Prop :=
  fun (m : msg) (n : node) =>
    m <[node] n /\
    forall (n' : node) , ssuccs n' n -> m <[node] n'-> False.

Lemma new_at_imp_comp : forall m n, new_at m n -> m <[node] n.
Proof.
  intros m n H.
  unfold new_at in H.
  apply H.
Qed.

Lemma not_new_exists :
  forall n L, L <[node] n -> ~ new_at L n ->
    exists n', ssuccs n' n /\ L <[node] n'.
Proof.
  unfold not.
  intros n L Hcom Hnnew.
  apply Peirce. intros.
  apply False_ind. apply Hnnew.
  unfold new_at. split.
  assumption.
  intros n' Hssucc Hcomn'.
  apply H. exists n'.
  split; auto.
Qed.

(** ** Basic results about penetrator strands related to components *)
(* A MStrand or KStrand cannot have an edge *)
Lemma MStrand_not_edge :
  forall (s:strand), MStrand s -> ~ exists (n1 n2 : node),
    strand_of n1 = s /\ strand_of n2 = s /\ ssuccs n1 n2.
Proof.
intros s Hm Hex.
destruct Hex as (n1, (n2, (Hs1, (Hs2, Hss)))).
inversion Hm.
assert (Hin1 : set_In (smsg_of n1) s). apply smsg_on_strand. auto.
assert (Hin2 : set_In (smsg_of n2) s). apply smsg_on_strand. auto.
rewrite H in Hin1, Hin2. elim Hin1.
intro. elim Hin2.
Admitted.
Axiom KStrand_not_edge :
  forall (s:strand), KStrand s -> ~ exists (n1 n2 : node),
    strand_of n1 = s /\ strand_of n2 = s /\ ssuccs n1 n2.

Axiom CStrand_not :
  forall (s:strand), CStrand s -> ~ exists (n1 n2 : node),
    strand_of n1 = s /\ strand_of n2 = s /\
    recv n1 /\ xmit n2 /\ ssuccs n1 n2 /\
    exists L1 L2, L1 <[node] n1 /\ L2 <[node] n2 /\ L1 <> L2.

Axiom SStrand_not :
  forall (s:strand), SStrand s -> ~ exists (n1 n2 : node),
    strand_of n1 = s /\ strand_of n2 = s /\
    recv n1 /\ xmit n2 /\ ssuccs n1 n2 /\
    exists L1 L2, L1 <[node] n1 /\ L2 <[node] n2 /\ L1 <> L2.

(*********************************************************************)

(** * Penetrable Keys and Safe Keys *)
(* Penetrable key is already penetrated (K_p) or some regular strand
puts it in a form that could allow it to be penetrated, because for each key
protecting it, the matching key decryption key is already pentrable *)
Section Penetrable_Keys.
  Parameter Kp : Set.
  Parameter Pk : nat -> Key -> Prop.
  Axiom init_pkeys : sig (Pk 0) = Kp.
  Axiom next_pkeys : forall (i:nat) (k:Key), (exists (n:node) (t:msg),
    r_node n /\ xmit n /\ new_at t n /\
    k_ingred (sig (Pk i)) (K k) t) -> Pk (i+1) k.

  Inductive PKeys (k:Key) : Prop :=
  | pkey_step : (exists (i:nat), Pk i k) -> PKeys k.

End Penetrable_Keys.

(*********************************************************************)

(** * Paths *)
Section Path.
(** ** Path condition *)
  Inductive path_cond (m n : node) : Prop :=
  | path_cond_single :  msg_deliver m n -> path_cond m n
  | path_cond_double : ssuccs m n /\ recv(m) /\ xmit(n) -> path_cond m n.
  Hint Constructors path_cond.
  Notation "m |--> n" := (path_cond m n) (at level 30) : ss_scope.

(** ** Path condition implies prec *)
  Lemma path_imp_prec :
    forall (m n:node), m |--> n -> prec m n.
  Proof.
    intros.
    apply path_cond_ind with (m:=m) (n:=n).
    apply deliver_prec.
    intros.
    apply ssuccs_prec. apply H0.
    auto.
  Qed.

(** MAYBE WE CAN AVOID THIS?? *)
  Variable default_n : node.

(** ** ith node of a path *)
  Definition nth_node : nat -> list node -> node :=
    fun (n:nat) (p:list node) => nth n p default_n.
  Hint Resolve nth_node.

(** ** Definitions for paths *)
  Definition is_path : list node -> Prop :=
    fun  (p: list node) => forall (n : nat),
      n < length(p) - 1 ->
      path_cond (nth_node n p ) (nth_node (n+1) p).

(** ** Axiom for paths *)
(** All paths begin on a positive node and end on a negative node *)
  Axiom path_begin_pos_end_neg : forall (p : list node),
    is_path p -> xmit(nth_node 0 p) /\ recv(nth_node (length p - 1)  p).

(** ** Penetrator Paths *)
  Definition p_path : list node -> Prop :=
    fun (p:list node) => is_path p ->
      forall (i:nat), (i > 0 /\ i < length p - 1) ->
        p_node (nth i p default_n).

(** ** Falling paths *)
  Definition falling_path :=
    fun (p:list node) => p_path p -> forall (i:nat), i < length p -1 ->
      ingred (msg_of (nth (i+1) p default_n)) (msg_of (nth i p default_n)).

(** ** Rising paths *)
  Definition rising_path :=
    fun (p:list node) => p_path p -> forall (i:nat), i < length p -1 ->
      ingred (msg_of (nth i p default_n)) (msg_of (nth (i+1) p default_n)).

(** ** Basic results for falling and rising paths *)
  Lemma falling_imp_D_or_S :
    forall (p:list node), falling_path p ->
      forall (i:nat), 0 < i /\ i < length p - 1 /\ recv (nth i p default_n) ->
        DStrand (strand_of (nth i p default_n)) \/
        SStrand (strand_of (nth i p default_n)).
Admitted.

Lemma rising_imp_E_or_C :
  forall (p:list node), rising_path p ->
    forall (i:nat), 0 < i /\ i < length p - 1 /\ recv (nth i p default_n) ->
      EStrand (strand_of (nth i p default_n)) \/
      CStrand (strand_of (nth i p default_n)).
Admitted.

(*********************************************************************)

(** * Edges *)
(** ** Transformed edges *)
(** ** Transforming edges *)

(*********************************************************************)

(* I want to define some constant of type msg here but we don't know any constant
of this type, so I just say it is some variable *)
Variable default_msg : msg.

(** * Transformation paths *)
Section Trans_path.
  Variable p : path.
  Definition ln := fst (split p).
  Hint Resolve ln.
  Definition lm := snd (split p).
  Hint Resolve lm.

  Definition nth_msg : nat -> list msg -> msg :=
    fun (n:nat) (p:list msg) => nth n p default_msg.
  Hint Resolve nth_msg.

  Definition L (n:nat) := nth_msg n lm.
  Hint Resolve L.
  Definition nd (n:nat) := nth_node n ln.
  Hint Resolve nd.

  Definition is_trans_path : Prop :=
    (is_path ln /\
      (True \/
        (ssuccs (nd 0) (nd 1) /\  xmit (nd 0) /\ xmit (nd 1)))) /\
    forall (n:nat), (n < length p -> (L n) <[node] (nd n)) /\
      (n < length p - 1 -> (L n = L (n+1) \/ (L n <> L (n+1) ->
        recv (nd n) /\ xmit (nd (n+1)) /\ ssuccs (nd n) (nd (n+1)) /\
        (exists m, xmit m /\ new_at (L (n+1)) m  /\
          ssuccs (nd n) m /\ ssuccseq m (nd (n+1)))))).

End Trans_path.

(* Baby result : a single pair (n, L) is a trans-foramtion path *)
Open Scope list_scope.
Check [1].
Lemma anode_trans_path :
  forall (n:node) (t:msg),
    t <[node] n -> is_trans_path [(n,t)].
Proof.
  intros n t Hcom.
  unfold is_trans_path.
  simpl. split.
  split. constructor. simpl in H.
  apply False_ind; omega.
  left; auto.
  intros n1; split.
  intro Hn1_lt. assert (n1=0). omega. subst. apply Hcom.
  intros Hn1_lt. apply False_ind. omega.
Qed.

(*********************************************************************)
(** * Proposition 7 *)
Section P7_1.
  Variable pl : path.
  Variable i : nat.
  Let p := fst (split pl).
  Let l := snd (split pl).
  Let p_i := nth_node i p.
  Let p_i1 := nth_node (i+1) p.
  Hypothesis Hc : 0 < i /\ i < length pl - 1.
  Hypothesis Hfp : falling_path p.
  Hypothesis Hrec : recv p_i.
  Hypothesis Hpn : p_node p_i.
  Let s := strand_of p_i.

  Lemma P7_1_aux : DStrand (strand_of p_i) \/ SStrand (strand_of p_i).
  Admitted.

  Lemma P7_1 :
    enc (msg_of p_i) \/ pair (msg_of p_i).

  Admitted.
Section P7_1_a.
  Variable h : msg.
  Variable k : Key.
  Hypothesis Heq : msg_of p_i = E h k.
  Lemma P7_1a :
    EStrand s /\ msg_of p_i1 = h.
Admitted.
End P7_1_a.

Section P7_1_b.
  Variable g h : msg.
  Lemma P7_1_b :
    SStrand s /\ (msg_of p_i1 = h \/ msg_of p_i1 = g).
Admitted.
End P7_1_b.
End P7_1.

(*********************************************************************)

(** * Proposition 10 *)
Section Proposition_10.
  Variable p : path.
  Variable n : nat.
  Hypothesis Htp : is_trans_path p.
  Hypothesis Hn : n < length p - 1.
  Hypothesis Hcom : L p n <> L p (n+1).

(* TODO : move to right place *)
  Lemma ssuccs_trans' :
    forall x y z, ssuccs x y -> ssuccs y z -> ssuccs x z.
  Proof.
    intros x y z Hxy. induction Hxy.
    intros. apply ssuccs_trans with (y':= z0).
    auto. auto.
    intros. apply ssuccs_trans with (y':= y').
    auto.
    apply IHHxy. auto.
  Qed.

  Lemma ssuccs_eq :
    forall x y z, ssuccs x y -> ssuccseq y z -> ssuccs x z.
  Proof.
    intros x y z Hxy Hyz.
    inversion Hyz.
    rewrite H in Hxy. auto.
    apply ssuccs_trans' with (y:=y); auto.
  Qed.

  Lemma trans_path_ssuccs :
      ssuccs (nd p n) (nd p (n+1)) /\ recv (nd p n) /\ xmit (nd p (n+1)).
  Proof.
    unfold is_trans_path in Htp.
    destruct Htp as ((H3,H4),H5).
    remember (H5 n) as H6.
    destruct H6 as (H61, H62).
    remember (H62 Hn) as H7.
    case H7.
    intros. apply False_ind. apply Hcom. auto.
    intros. remember (H Hcom) as H8.
    destruct H8 as (Hrec, (Hxmit, (Hss, (m, (H9, (H10, (H11, H12))))))).
    repeat split.
    apply ssuccs_eq with (y:= m); auto.
    auto.
    auto.
  Qed.

  Lemma Proposition_10 : p_node (nd p n) ->
    ssuccs (nd p n) (nd p (n+1)) /\
    (DStrand (strand_of (nd p n)) \/ EStrand (strand_of (nd p n))).
  Proof.
    intro Hpn.
    assert (Hs : ssuccs (nd p n) (nd p (n + 1)) /\ recv (nd p n) /\ xmit (nd p (n+1))).
    apply trans_path_ssuccs; auto.
    unfold is_trans_path in Htp.
    destruct Htp as (Ha, Hb).
    split.
    apply Hs.

    assert (Hp : PenetratorStrand (strand_of (nd p n))).
    apply (P_node_strand (nd p n)); auto.
    elim Hp.
    intro. apply False_ind. apply (MStrand_not_edge (strand_of (nd p n))).
    auto.
    exists (nd p n).
    exists (nd p (n+1)).
    split. auto.
    split. symmetry. apply ssuccs_same_strand. apply Hs.
    apply Hs.

    intro. apply False_ind. apply (KStrand_not_edge (strand_of (nd p n))).
    auto.
    exists (nd p n).
    exists (nd p (n+1)).
    split. auto.
    split. symmetry. apply ssuccs_same_strand; apply Hs.
    apply Hs.

    intro. apply False_ind. apply (CStrand_not (strand_of (nd p n))).
    auto.
    exists (nd p n).
    exists (nd p (n+1)).
    split. auto.
    split. symmetry. apply ssuccs_same_strand. apply Hs.
    repeat split. apply Hs. apply Hs. apply Hs.
    exists (L p n). exists (L p (n+1)).
    split. apply Hb. omega.
    split. apply Hb with (n:= n+1). omega.
    auto.

    intro. apply False_ind. apply (SStrand_not (strand_of (nd p n))).
    auto.
    exists (nd p n).
    exists (nd p (n+1)).
    split. auto.
    split. symmetry. apply ssuccs_same_strand. apply Hs.
    repeat split. apply Hs. apply Hs. apply Hs.
    exists (L p n). exists (L p (n+1)).
    split. apply Hb. omega.
    split. apply Hb with (n:= n+1). omega.
    auto.

    auto.
    auto.
  Qed.

End Proposition_10.

(*********************************************************************)

(** * Proposition 11 *)
(** For every atomic ingredient of a message, there exists
a component of the message so that the atomic value is
an ingredient of that component *)
Lemma ingred_exists_comp:
  forall m a, atomic a -> a <st m -> exists L, a <st L /\ comp L m.
Proof.
  intros m a Hatom Hingred.
  induction m.
  exists a; split.
  constructor.
  assert (a = T t). apply atomic_ingred_eq; auto.
  subst. apply comp_atomic_cyclic; assumption.

  exists a; split.
  constructor.
  assert (a = K k). apply atomic_ingred_eq; auto.
  subst. apply comp_atomic_cyclic; assumption.

  assert (Hor : ingred a m1 \/ ingred a m2).
  apply ingred_pair. inversion Hatom; discriminate.
  assumption.
  case Hor.
  intro Hst.
  assert (Hex : exists L : msg, ingred a L /\ comp L m1).
  exact (IHm1 Hst). destruct Hex as (L, (HaL, Hcom)).
  exists L; split.
  assumption.
  apply preserve_comp_l; assumption.

  intros Hst.
  assert (Hex : exists L : msg, ingred a L /\ comp L m2).
  exact (IHm2 Hst). destruct Hex as (L, (HaL, Hcom)).
  exists L; split.
  assumption.
  apply preserve_comp_r; assumption.

  assert (Hex : exists L : msg, a <st L /\ L <com m).
  apply IHm. apply ingred_enc with (k:=k).
  inversion Hatom; discriminate.
  assumption.
  destruct Hex as (L, (HaL, Hcom)).
  exists (E m k); split.
  assumption.
  apply comp_simple_cyclic.
  apply simple_step. unfold not. intros Hpair.
  inversion Hpair.
Qed.

Lemma ingred_exists_comp_of_node:
  forall (n:node) (a:msg), atomic a -> a <st (msg_of n)
    -> exists L, a <st L /\ L <[node] n.
Proof.
  intros.
  apply ingred_exists_comp; assumption.
Qed.

Section Proposition11.
  Variable a : msg.
  Variable n : node.
  Definition P_ingred : node -> Prop:=
    fun (n':node) => ssuccs n' n /\ ingred a (msg_of n').

(* Since ssuccs implies prec, if a element x is prec-accessible
then it is ssuccs-accessible *)
  Lemma acc_prec_ssuccs : forall x, Acc prec x -> Acc ssuccs x.
  Proof.
    intros x Hprec.
    induction Hprec. constructor.
    intros. apply H0.
    apply ssuccs_prec; auto.
  Qed.

(* Ssuccs is a well-founded relation *)
(* Notice that every sub-relation of a well-founded relation is
also well-founded *)
  Lemma wf_ssuccs : well_founded ssuccs.
  Proof.
    unfold well_founded. intros x.
    apply acc_prec_ssuccs.
    apply wf_prec.
  Qed.

  Lemma ingred_of_earlier :
    forall (n':node),
      a <st (msg_of n) -> xmit n -> ~ orig_at n a -> exists n', P_ingred n'.
  Proof.
    intros n' Hst Hxmit Hnorig.
    apply Peirce.
    intros.
    apply False_ind.
    apply Hnorig. unfold orig_at.
    repeat split.
    auto.
    auto.
    intros n1 Hssuc Hastn1. apply H.
    exists n1. split; auto.
  Qed.

  Lemma not_orig_exists :
    a <st (msg_of n) -> xmit n -> ~ orig_at n a -> has_min_elt P_ingred.
  Proof.
    intros Hxmit Hst Hnorig.
    apply always_min_elt.
    apply ingred_of_earlier; assumption.
  Qed.

End Proposition11.

(** Backward construction *)
Lemma backward_construction :
  forall (n:node) (a L:msg),
    atomic a -> L <[node] n -> ~ orig_at n a -> a <st L ->
    exists (n':node) (L':msg),
      (msg_deliver n' n \/ ssuccs n' n) /\ a <st L' /\ L' <[node] n' /\
      (L' = L \/ (ssuccs n' n /\ new_at L n)).
Proof.
  intros n a L Hatom Hcom Hnorig Hst.
  assert (Hx_r : xmit n \/ recv n). apply xmit_or_recv.
  case Hx_r.
  Focus 2. intros Hrecv.
  assert (Hex : exists (n':node), msg_deliver n' n).
  apply was_sent. auto.
  destruct Hex as (n', Hmsg_deli).
  exists n'; exists L.
  split. left; auto.
  split. exact Hst.
  split. apply msg_deliver_comp with (n1:=n') (n2:=n).
  split; assumption.
  left. trivial.

  intros Hxmit.
  assert (Hdec : new_at L n \/ ~(new_at L n)). tauto.
  case Hdec.
  intros Hnew.
  assert (Hex2 :exists n1, ssuccs n1 n /\ ingred a (msg_of n1)).
  apply ingred_of_earlier. repeat split; auto.
  apply ingred_trans with (y:=L).
  assumption.
  apply comp_of_node_imp_ingred; assumption.
  assumption.
  assumption.
  destruct Hex2 as (n1, (Hssucc, Hastn1)).
  assert (HexL1 : exists L1, ingred a L1 /\ comp_of_node L1 n1).
  apply ingred_exists_comp_of_node; assumption.
  destruct HexL1 as (L1, (H1, H2)).
  exists n1; exists L1.
  split. right. assumption.
  split. assumption.
  split. assumption.
  right. split; auto.

  intros Hnnew.
  assert (Hex : exists n', ssuccs n' n /\ L <[node] n').
  apply not_new_exists; auto.
  destruct Hex as (n', (Hssucc, Hn)).
  exists n'; exists L.
  split. right. auto.
  split. auto.
  split. assumption.
  left; trivial.
Qed.

Definition Proposition_11_aux : node -> Prop :=
  fun (n':node) =>
    forall (a t:msg),
      atomic a -> a <st t /\ t <[node] n' ->
      exists p, let ln := fst (split p) in
        let lm := snd (split p) in
          is_trans_path p /\
          orig_at (nth_node 0 ln) a /\
          nth_node (length p - 1) ln = n' /\
          nth_msg (length p -1) lm = t /\
          forall (i:nat), i < length p -> a <st (nth_msg i lm).

(* The main result *)
Lemma proposition11 :
  forall (n':node), Proposition_11_aux n'.
Proof.
  apply well_founded_ind with (R:=prec).
  exact wf_prec.
  intros.
  unfold Proposition_11_aux.
  unfold Proposition_11_aux in H.
  intros.
  destruct H1 as (H1, H2).
  assert (orig_at x a \/ ~ orig_at x a). tauto.
  case H3.
  intros.
  exists (cons (x, t) nil).
  simpl. split.
  apply anode_trans_path with (n:=x) (t:=t). exact H2.
  split; auto; split; auto; split; auto.
  intros.
  assert (i=0). omega.
  rewrite H6;auto.

  intros.
  assert (Hex : exists (n':node) (L':msg),
    (msg_deliver n' x \/ ssuccs n' x) /\ a <st L' /\ L' <[node] n' /\
    (L' = t \/ (ssuccs n' x /\ new_at t x))).
  apply backward_construction; assumption.
  destruct Hex as (n', (L', (Hor, (Hst, (Hcom, Hlast))))).
  assert (IH : forall a t : msg,
    atomic a ->
    a <st t /\ t<[node]n' ->
    exists p : list (node * msg),
      is_trans_path p /\
      orig_at (nth_node 0 (fst (split p))) a /\
      nth_node (length p - 1) (fst (split p)) = n' /\
      nth_msg (length p - 1) (snd (split p)) = t /\
      (forall i : nat, i < length p -> a <st nth_msg i (snd (split p)))).
  apply H with (y:= n'). case Hor.
  apply msg_deliver_prec.
  apply ssuccs_prec.
  assert (Hex2 : exists p : list (node * msg),
    is_trans_path p /\
    orig_at (nth_node 0 (fst (split p))) a /\
    nth_node (length p - 1) (fst (split p)) = n' /\
    nth_msg (length p - 1) (snd (split p)) = L' /\
    (forall i : nat, i < length p -> a <st nth_msg i (snd (split p)))).
  apply IH. assumption. split; assumption.
  destruct Hex2 as (p0, (Hex2, (Hex3, (Hex4, (Hex5, Hex6))))).
  assert (orig_at n' a \/ ~orig_at n' a). tauto.
  case H5.
  intro Horign'.
  exists ((n', L')::(x,t)::nil). simpl.
  split. admit.
  split. auto.
  split. auto.
  split. auto.
  intros. assert (i=0 \/ i=1). omega.
  case H7.
  intro. subst; auto.
  intro; subst; auto.
  intro Hnorig.
  exists (p0++(n',L')::nil).
Admitted.

(*********************************************************************)

(** * Proposition 13 *)
Section P13.
  Variable pl : path.
  Let p := fst (split pl).
  Let l := snd (split pl).
  Hypothesis Hpp : p_path p.
  Hypothesis Hp1 : simple (msg_of (nth_node 0 p)).
  Definition P13_1_aux (n:nat) : Prop :=
    msg_of (nth_node n p) = (nth_msg (length p - 1) l) /\
    forall (i:nat), i >= n -> i <= length p - 1 ->
      nth_msg i l = nth_msg (length p - 1) l.
  Lemma P13_1 :
    exists (n:nat), P13_1_aux n /\
      (forall m, m > n -> ~ P13_1_aux m) /\
      exists i, i < length p - 1 -> nth_msg i l <> nth_msg (i+1) l ->
        xmit (nth_node n p) /\ EStrand (strand_of (nth_node n p)).
Admitted.
End P13.
End Path.


Inductive tp : Set :=
  | tp_nat: tp
  | tp_exp: tp -> tp -> tp.
Hint Constructors tp.

Notation "t -o t0" := (tp_exp t t0) (at level 51, right associativity).

Inductive term : tp -> Set :=
  | ap: forall {a b : tp}, term (a -o b) -> term a -> term b
  | sub: forall {a b c : tp}, term ((a -o b -o c) -o (a -o b) -o a -o c)
  | const: forall {a b : tp}, term (a -o b -o a)
  | zero: term tp_nat
  | succ: term (tp_exp tp_nat tp_nat)
  | rec: forall {a : tp}, term (tp_nat -o (tp_nat -o a -o a) -o a -o a).
Hint Constructors term.

Notation "x * y" := (ap x y) (at level 40, left associativity).

Fixpoint eval_tp (a : tp) : Set :=
  match a with
    | tp_nat => nat
    | a -o a0 => (eval_tp a) -> (eval_tp a0)
  end.

Inductive step : forall {a}, term a -> term a -> Set :=
  | step_ap_1: forall {a b} (f f0 : term (b -o a)) (x : term b),
    step f f0 -> step (f*x) (f0*x)
  | step_ap_2: forall {a b} (f : term (b -o a)) (x x0 : term b),
    step x x0 -> step (f*x) (f*x0)
  | step_const: forall {a b} x y, step ((@const a b)*x*y) x
  | step_subs: forall {a b c} x y z, step ((@sub b c a)*x*y*z) (x*z*(y*z))
  | step_zero: forall {a} f x, step ((@rec a)*zero*f*x) x
  | step_succ: forall {a} f x n, step ((@rec a)*(succ*n)*f*x) (f*n*(rec*n*f*x)).
Hint Constructors step.

Inductive terminates {a} (x : term a) : Prop :=
  terminates_intro: (forall y, step x y -> terminates y) -> terminates x.
Hint Constructors terminates.

Ltac value :=
  match goal with
  | [  |- terminates ?X ] => apply terminates_intro; intros y H; inversion H
  end.

Lemma const_val {a b}: terminates (@const a b).
Proof.  value.  Qed.

Lemma const_x_val {a b}:
  forall x, terminates x -> terminates ((@const a b) * x).
Proof.
  intros.
  apply terminates_intro.
  intros.
  inversion H0.
  (* TODO *)
Admitted.

(* Tait's hereditary termination predicate *)
Fixpoint ht a (x : term a) : Prop :=
  match a, x with
  | tp_nat, x => terminates x
  | tp_exp b c, x => terminates x /\ forall y, ht b y -> ht c (x * y)
  end.

Lemma ht_terminates a (x : term a) : ht a x -> terminates x.
Proof.
  intros H; unfold ht in H; induction a; compute; apply H.
Qed.

Lemma ht_ap:
  forall {a b} (x : term (a -o b)) (y : term a),
  ht _ x -> ht _ y -> ht _ (x * y).
Proof.
  intros.
  inversion H.
  apply H2.
  apply H0.
Qed.
Hint Resolve ht_ap.

Theorem hereditary_termination: forall a (x : term a), ht a x.
Proof.
  induction x.
            inversion IHx1; apply ht_ap; assumption.
          admit.
        unfold ht; fold ht; split.
          apply const_val.
        fold ht; intros y H; split.
          apply const_x_val.
          apply ht_terminates; assumption.
        intros z IH.
        induction a; compute; fold ht.
        apply terminates_intro; intros y' Hs; inversion Hs.
        (* TODO *)
Admitted.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Set Transparent Obligations.

Program Instance Cat : Category := {
obj     := Category;
hom     := @Functor;
homset  := @Functor_Setoid;
id      := @Id;
compose := @Compose;

compose_respects := @Compose_respects
}.

Record Isomorphism_FullyFaithful `(iso : C ≅ D) := {
to_full       : Full (to iso);
to_faithful   : Faithful (to iso);
from_full     : Full (from iso);
from_faithful : Faithful (from iso)
}.

Theorem Cat_Iso_FullyFaithful `(iso : C ≅ D) :
let φ := to iso in
let ψ := from iso in
let η x := to (`1 (iso_from_to iso) x) in
let μ x := to (`1 (iso_to_from iso) x) in

(∀ x, fmap[φ] (η x) ≈ μ (φ x)) ->
(∀ x, fmap[ψ] (μ x) ≈ η (ψ x)) ->
Isomorphism_FullyFaithful iso.
Proof. hammer_hook "Cat" "Cat.Cat_Iso_FullyFaithful".
construct.
- construct.
+ exact (to (`1 (iso_from_to iso) y)
∘ fmap[from iso] g
∘ from (`1 (iso_from_to iso) x)).
+ abstract
(proper;
now rewrite X1).
+ abstract
(simpl;
rewrite fmap_id, id_right;
now apply iso_to_from).
+ abstract
(simpl;
comp_left;
comp_right;
rewrite <- !comp_assoc;
rewrite (comp_assoc (`1 (iso_from_to iso) y)⁻¹);
rewrite (iso_from_to (`1 (iso_from_to iso) y)), id_left;
now apply fmap_comp).
+ abstract
(simpl;
rewrite !fmap_comp;
srewrite X;
srewrite (`2 (iso_to_from iso));
rewrite !comp_assoc;
rewrite iso_to_from, id_left;
srewrite_r X;
rewrite <- comp_assoc;
rewrite <- fmap_comp;
rewrite iso_to_from, fmap_id, id_right;
reflexivity).
- construct.
abstract
(rewrite <- id_left;
rewrite <- id_right;
symmetry;
rewrite <- id_left;
rewrite <- id_right;
symmetry;
spose (`2 (iso_from_to iso)) as X2;
rewrite <- (iso_to_from (`1 (iso_from_to iso) y));
rewrite <- (iso_to_from (`1 (iso_from_to iso) x));
rewrite <- !comp_assoc;
rewrite (comp_assoc _ f _);
rewrite (comp_assoc _ g _);
rewrite (comp_assoc (_ ∘ _) _ _);
rewrite (comp_assoc (_ ∘ _) _ _);
rewrite <- (X2 x y f);
rewrite <- (X2 x y g);
comp_left;
comp_right;
now apply (@fmap_respects D C iso⁻¹)).
- construct.
+ exact (to (`1 (iso_to_from iso) y)
∘ fmap[to iso] g
∘ from (`1 (iso_to_from iso) x)).
+ abstract
(proper;
now rewrite X1).
+ abstract
(simpl;
rewrite fmap_id, id_right;
now apply iso_to_from).
+ abstract
(simpl;
comp_left;
comp_right;
rewrite <- !comp_assoc;
rewrite (comp_assoc (`1 (iso_to_from iso) y)⁻¹);
rewrite (iso_from_to (`1 (iso_to_from iso) y)), id_left;
now apply fmap_comp).
+ abstract
(simpl;
rewrite !fmap_comp;
srewrite X0;
srewrite (`2 (iso_from_to iso));
rewrite !comp_assoc;
rewrite iso_to_from, id_left;
srewrite_r X0;
rewrite <- comp_assoc;
rewrite <- fmap_comp;
rewrite iso_to_from, fmap_id, id_right;
reflexivity).
- construct.
abstract
(rewrite <- id_left;
rewrite <- id_right;
symmetry;
rewrite <- id_left;
rewrite <- id_right;
symmetry;
spose (`2 (iso_to_from iso)) as X2;
rewrite <- (iso_to_from (`1 (iso_to_from iso) y));
rewrite <- (iso_to_from (`1 (iso_to_from iso) x));
rewrite <- !comp_assoc;
rewrite (comp_assoc _ f _);
rewrite (comp_assoc _ g _);
rewrite (comp_assoc (_ ∘ _) _ _);
rewrite (comp_assoc (_ ∘ _) _ _);
rewrite <- (X2 x y f);
rewrite <- (X2 x y g);
comp_left;
comp_right;
now apply (@fmap_respects C D (to iso))).
Defined.


Require Import Iron.Language.SystemF2Effect.Base.

(********************************************************************)
(* Store Property *)
Inductive stprop :=
 (* A region descriptor.
    One of these exists in the store for every live region in the store. *)
 | SRegion : nat -> stprop.

(* Store Properties *)
Definition stprops
 := list stprop.

(********************************************************************)
(* Take a region back from a store property *)
Fixpoint regionOfStProp (s : stprop) : option nat :=
 match s with
 | SRegion p      => Some p
 end.

(* Check if this is a store property with the given
   region identifier. *)
Definition isSRegion (p : nat) (pp : stprop) : bool :=
 match pp with
 | SRegion p' => beq_nat p p'
 end.

(* Check if any of the given store properties include this
   region identifier *)
Definition hasSRegion (p : nat) (sp : stprops)
 := elem (isSRegion p) sp.

(********************************************************************)
(* Allocate a fresh region. *)
Definition allocRegion (sp : stprops) : nat
 := S (max_list (catOptions (map regionOfStProp sp))).

Lemma allocRegion_weaken
 :  forall sp s p
 ,  allocRegion sp        >= p
 -> allocRegion (sp :> s) >= p.
Proof.
 intros.
  destruct p.
  omega.
  unfold allocRegion in *.
   snorm.
   have (max_list (catOptions (map regionOfStProp sp)) >= p)
    by omega. clear H.
   cut  (max n (max_list (catOptions (map regionOfStProp sp))) >= p).
    intros. omega.
    apply max_weaken_left.
    auto.
Qed.
Hint Resolve allocRegion_weaken.

(* A freshly allocated region is greater than all regions already
   in the store properties. *)
Lemma allocRegion_above
 : forall sp
 , Forall (fun s => match regionOfStProp s with
                    | Some p => allocRegion sp > p
                    | None   => True
                    end)
          sp.
Proof.
 induction sp; intros.
  snorm.
  snorm.
  inverts H.
   destruct x.
    snorm.
    unfold allocRegion.
     simpl.
     remember (max_list (catOptions (map regionOfStProp sp))) as X.
     cut (max n0 X >= n0).
      intros. omega.
     apply max_ge_left1.
   destruct x.
    snorm.
    spec IHsp H0.
    snorm.
    apply allocRegion_weaken. auto.
Qed.

(* Allocated region is fresh wrt existing store properties. *)
Lemma allocRegion_fresh
 : forall sp
 , not (In (SRegion (allocRegion sp)) sp).
Proof.
 intros.
 unfold not. intros.
 lets D: allocRegion_above sp.
  snorm.
 spec D H.
  snorm. omega.
Qed.
Hint Resolve allocRegion_fresh.

(* Old store properties do not contain allocated region. *)
Lemma allocRegion_fresh_has
 :  forall p sp
 ,  p = allocRegion sp
 -> hasSRegion p sp = false.
Proof.
 intros.
 subst.
  unfold hasSRegion.
  eapply elem_get_not.
  unfold not. intros.
   destruct H as [ix].
   destruct H as [x].
   rip.
   destruct x.
    simpl in H1.
    snorm. symmetry in H1. subst.
    apply get_in in H0.
    have (not (In (SRegion (allocRegion sp)) sp))
     by apply allocRegion_fresh.
    tauto.
Qed.
Hint Resolve allocRegion_fresh_has.


Module tic_tac_toe.
Notation new_line := (String "010" EmptyString) (only parsing).

Inductive player := player_1 | player_2.
Definition cell := option player.
Definition cell_to_string (c : cell) : string :=
  match c with
  |None => " "
  |Some player_1 => "X"
  |Some player_2 => "O"
  end.
Definition board := seq (seq cell).
Definition empty : cell := None.
Coercion some_player (p : player) : cell := Some p.
Definition set_cell (b : board) (r : nat) (c : nat) (p : player) : board
  := set_nth [::] b r (set_nth empty (nth [::] b r) c p).
Definition get_cell (b : board) (r : nat) (c : nat) : cell
  := nth empty (nth [::] b r ) c.
Definition get_column (b : board) (c : nat) : seq cell
  := map (fun r => get_cell b r c) [:: 0 ; 1 ; 2 ].
Definition rows (b: board) : seq (seq cell) := b.
Definition columns (b : board) : seq (seq cell) :=
  map (fun c => get_column b c) [:: 0 ; 1 ; 2 ].
Definition diagonals (b : board) : seq (seq cell)
  := [:: [:: get_cell b 0 0 ; get_cell b 1 1 ; get_cell b 2 2]
      ; [:: get_cell b 0 2 ; get_cell b 1 1 ; get_cell b 2 0] ].
Definition cells_same_non_empty (s : seq cell) : bool
  := foldr andb true (map (fun c => c == nth empty s 0) s)
     && (nth empty s 0 != empty).
Definition any_cells_same_non_empty (s : seq (seq cell)) : bool :=
  foldr orb false (map cells_same_non_empty s).
Definition any_row (b: board) : bool :=
  any_cells_same_non_empty (rows b).
Definition any_column (b : board) : bool :=
  any_cells_same_non_empty (columns b).
Definition any_diagonal (b : board) : bool
  := any_cells_same_non_empty (diagonals b).
Definition other_player (current_player : player) : player
  := match current_player with
     |player_1 => player_2
     |player_2 => player_1
     end.
Definition initial_board : board
  := nseq 3 (nseq 3 empty).
Definition output_row (s: seq cell) : string
  := foldr String.append ""%string (map cell_to_string s) ++ new_line.
Definition output_board (b : board) : string :=
  foldr String.append ""%string (map output_row b).
Definition game_result (state : board * player) : option player
  := let (b, current_player) := state in
     if any_row b || any_column b
        || any_diagonal b
     then Some (other_player current_player)
     else None.
Definition initial_state : board * player
  := (initial_board, player_1).
Definition game_result_string (p : option player) : string := later.
Definition game_intro : string := later.
Definition main_game (b : board) : unit := later.
Definition input_and_make_move (current_player : player) (b : board)
  : player * board := later.
Definition move_is_valid (b : board) (r : nat) (c : nat) : bool
  := (r <= 3) && (c <= 3) && (get_cell b r c == empty).
Definition make_move (b: board) (current_player : player)
           (r : nat) (c : nat) : board * bool
  := if move_is_valid b r c
     then (set_cell b r c current_player, true)
     else (b, false).
Definition make_single_move (state : board*player) (next_move : nat*nat)
  : (board*player)*bool
  := let (r, c) := next_move in
     let (b, p) := state in
     let (new_board, is_valid)
         := make_move b p r c in
     ((new_board, other_player p), is_valid).
Fixpoint make_moves (moves : seq (nat*nat)) (state : board*player) : board*player
  := match moves with
     |[::] => state
     |move :: moves =>
      let new_state := fst (make_single_move state move) in
      make_moves moves new_state
     end.

Definition next_move_is_valid
  (moves_so_far : seq (nat * nat)) (next_move : nat * nat) : bool
  := let (r, c) := next_move in
     let (b, _) := make_moves moves_so_far initial_state in
     move_is_valid b r c.

Fixpoint game_outcome (moves : seq (nat * nat)) (state : board*player) : option player
  := (*None means game is still in progress,
       some player means game is over and that player won*)
    match moves with
    | [::] => None
    | move :: moves =>
      let (new_state, is_valid) := make_single_move state move in
      if is_valid
      then match game_result new_state with
           | None => game_outcome moves new_state
           | Some winner => Some winner
           end
      else
        Some (other_player (snd state))
    end.

Compute output_board
  (fst (make_move initial_board player_1 1 2) ).
Compute output_board
  (fst (make_move (fst (make_move initial_board player_1 1 2)) player_2 1 1) ).
Compute output_board
  (fst (make_moves [:: (1, 1) ; (2, 2) ; (1, 0) ; (0,0) ; (1, 2)] initial_state)).
Compute game_result
  (make_moves [:: (1, 1) ; (2, 2) ; (1, 0) ; (0,0) ; (1, 2)] initial_state).

Definition next_move_is_valid_or_game_finished (moves_so_far : seq (nat * nat))
  (next_move : nat * nat) : bool
  := next_move_is_valid moves_so_far next_move
     || (game_outcome moves_so_far initial_state != None).

End tic_tac_toe.


Require Import
        Coq.Lists.List
        Coq.Strings.String
        Coq.Setoids.Setoid
        Coq.Arith.PeanoNat
        Coq.omega.Omega
        Coq.setoid_ring.Ring
        Coq.setoid_ring.Ring_theory
        Matrix
        SparseMatrix
        DenseMatrix
        MyHelpers.

Notation SDM n := (Mt (Matrix := DenseMatrix) n n).
Notation SSM n := (Mt (Matrix := SparseMatrix) n n).
Notation Vt n := (Mt (Matrix := DenseMatrix) n 1).

Global Opaque DenseMatrix.
Global Opaque SparseMatrix.

Section MatrixLemmas.

Context {E: MatrixElem}.

Definition transpose {n m MM} (A : @Mt E MM n m) :=
  @Mfill E MM m n (fun i j => Mget A j i).
Definition MVtimes {n} (M: SDM n) (v: Vt n) := M @* v.
Axiom inversion : forall {n}, SDM n -> SDM n.

Global Add Parametric Morphism n: (MVtimes ) with
      signature (Meq (m:=n)(n:=n)) ==> (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) as MVtimes_mor.
Admitted.

Global Add Parametric Morphism n m MM: (transpose ) with
      signature (Meq (m:=m)(n:=n)(M1:=MM)) ==> (Meq (m:=n)(n:=m)(M1:=MM)) as transpose_mor.
Admitted.

Global Add Parametric Morphism n: (inversion ) with
      signature (Meq (m:=n)(n:=n)) ==> (Meq (m:=n)(n:=n)) as inversion_mor.
Admitted.

Global Add Parametric Morphism m n: (Mget) with
      signature (Meq (m:=m)(n:=n)(ME:=E)(M1:=DenseMatrix)) ==> (eq) ==> (eq) ==> (eq) as mget_mor.
Admitted.

Infix "&*" := MVtimes (at level 40, left associativity) : matrix_scope.
Definition Vplus {n} (v: Vt n) (u: Vt n):= v @+ u.
Infix "&+" := Vplus (at level 50, left associativity) : matrix_scope.

Global Add Parametric Morphism n: (Vplus ) with
      signature (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) as Vplus_mor.
Admitted.

Definition Vminus {n} (v: Vt n) (u: Vt n):= v @- u.
Infix "&-" := Vminus (at level 50, left associativity) : matrix_scope.

Global Add Parametric Morphism n: (Vminus ) with
      signature (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) as Vminus_mor.
Admitted.

Definition Id {n} := @I n E DenseMatrix.

Arguments Mtimes : simpl never.

Definition sparsify {n} (A: SDM n) := @Mfill E SparseMatrix n n (fun i j => Mget A i j).
Lemma sparsify_correct: forall n: nat, forall M : SDM n, M @= sparsify M.
Proof.
  intros.
  unfold sparsify.
  unfold "@=".
  intros.
  rewrite Mfill_correct; try assumption.
  reflexivity.
Qed.

(* can be optimized *)
Definition densify {n} (A: SSM n) := @Mfill E DenseMatrix n n (fun i j => Mget A i j).
Lemma densify_correct: forall n: nat, forall M : SSM n, M @= densify M.
Proof.
  intros.
  unfold densify.
  unfold "@=".
  intros.
  rewrite Mfill_correct; try assumption.
  reflexivity.
Qed.
Lemma densify_correct_rev: forall n: nat, forall M : SSM n,  densify M @= M.
Proof.
  intros.
  unfold densify.
  unfold "@=".
  intros.
  rewrite Mfill_correct; try assumption.
  reflexivity.
Qed.

Lemma matrix_eq_commutes :
  forall (m n: nat) ME M1 M2 (m1: @Mt ME M1 m n) (m2: @Mt ME M2 m n),
    m1 @= m2 -> m2 @= m1.
Proof.
  intros.
  unfold "@=" in *.
  intros.
  rewrite H; auto.
Qed.

Axiom solveR: forall {n}, SDM n -> SDM n -> SDM n.
Axiom solveR_correct: forall n: nat, forall M1 M2:SDM n,
  M1 @* (inversion M2) = solveR M2 M1.
Lemma multi_assoc: forall n: nat, forall M1 M2 M3 : SDM n,
      (M1 @* M2) @* M3 @= M1 @* (M2 @* M3).
Proof.
  intros.
  rewrite mult_assoc.
  reflexivity.
Qed.

Axiom Cholesky_DC: forall {n}, SDM n -> SDM n.
Axiom solveR_lower: forall {n}, SDM n -> SDM n -> SDM n.
Axiom solveR_upper: forall {n}, SDM n -> SDM n -> SDM n.
Lemma ABv_assoc: forall n:nat, forall A B: SDM n, forall v : Vt n,
        MVtimes (A @* B) v @=  MVtimes A (MVtimes B v).
Proof.
  intros.
  unfold "&*".
  rewrite mult_assoc.
  reflexivity.
Qed.

Axiom Cholesky_DC_correct: forall n:nat, forall M1 M2 : SDM n,
      solveR M1 M2 = solveR_upper (transpose (Cholesky_DC M1)) (solveR_lower (Cholesky_DC M1) M2).

Axiom Densify_correct: forall n:nat, forall M : SDM n, forall S : SSM n,
        M @= S -> M @= densify S.

Lemma Densify_correct_rev: forall n:nat, forall M : SDM n, forall S : SSM n,
        M @= densify S -> M @= S.
Proof.
  intros.
  unfold densify in H.
  unfold "@=" in *.
  intros.
  rewrite H; auto.
  rewrite Mfill_correct; auto.
Qed.

Axiom dense_sparse_mul: forall {n}, SDM n -> SSM n -> SDM n.
Axiom dense_sparse_mul_correct: forall {n}, forall A: SDM n, forall B: SSM n,
        dense_sparse_mul A B = A @* densify B.
Axiom sparse_dense_mul: forall {n}, SSM n -> SDM n -> SDM n.
Axiom sparse_dense_mul_correct: forall {n}, forall A: SSM n, forall B: SDM n,
        sparse_dense_mul A B = densify A @*  B.
Axiom dense_sparse_mul_to_sparse: forall {n}, SDM n -> SSM n -> SSM n.
Axiom dense_sparse_mul_to_sparse_correct: forall {n}, forall A: SDM n, forall B: SSM n,
        sparsify (dense_sparse_mul A B) = dense_sparse_mul_to_sparse A B.

Lemma if_cond_helper {n m MM} : forall x1:bool, forall A B C D: @Mt E MM n m, A @= B -> C @= D -> (if x1 then A else C) @= (if x1 then B else D).
Proof.
  intros.
  destruct x1; auto.
Qed.

End MatrixLemmas.

Hint Resolve sparsify_correct densify_correct densify_correct_rev matrix_eq_commutes solveR_correct multi_assoc Densify_correct Densify_correct_rev dense_sparse_mul_correct sparse_dense_mul_correct dense_sparse_mul_to_sparse_correct eq_Mt_refl: matrices.

Infix "&*" := MVtimes (at level 40, left associativity) : matrix_scope.
Infix "&+" := Vplus (at level 50, left associativity) : matrix_scope.
Infix "&-" := Vminus (at level 50, left associativity) : matrix_scope.


(**
  [TypeTheory.CwF_TypeCat.CwF_Cats]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).
*)

(**
This module defines an isomorphism of categories for slightly
different definitions of CwF structures.
Since the difference is merely how components of objects and morphisms
are "packed" the proof boils down to a simple repackaging.

See [weq_cwf'_cwf_structure] for the "repackaging" of objects
and [weq_cwf'_to_cwf_structure_mor] for morphisms.

Main definitions are

- [cwf'_to_cwf_functor], [cwf'_to_cwf_is_catiso] — isomorphism of categories of [cwf_structure] and [cwf'_structure] (composed of [obj_ext_structure] and [term_fun_structure])
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.
Require Import TypeTheory.Auxiliary.TypeOfMorphisms.

Require Import TypeTheory.CwF.CwF_def.
Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Defs.

Require Import TypeTheory.CwF.CwF_Cats.
Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Cats.
Require Import UniMath.CategoryTheory.catiso.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences.

Section CwF_Cat_Equiv.

  Context (C : category).

  Definition cwf_to_cwf'_structure : cwf_structure C → cwf'_structure C.
  Proof.
    intros [[[Ty Tm] p] ΓAπ_te_axiom_isPullback].
    set (ΓAπ      := λ Γ A, pr1 (ΓAπ_te_axiom_isPullback Γ A)).
    set (te       := λ Γ A, pr1 (pr1 (pr2 (ΓAπ_te_axiom_isPullback Γ A)))).
    set (te_axiom := λ Γ A, pr2 (pr1 (pr2 (ΓAπ_te_axiom_isPullback Γ A)))).
    set (pullback := λ Γ A, pr2 (pr2 (ΓAπ_te_axiom_isPullback Γ A))).
    set (axioms   := λ Γ A, (te_axiom Γ A, pullback Γ A)).
    exact ((Ty ,, ΓAπ) ,, ((Tm ,, p ,, te) ,, axioms)).
  Defined.

  Definition cwf'_to_cwf_structure : cwf'_structure C → cwf_structure C.
  Proof.
    intros [[Ty ΓAπ] [[Tm [p te]] axioms]].
    set (te_axiom := λ Γ A, pr1 (axioms Γ A)).
    set (pullback := λ Γ A, pr2 (axioms Γ A)).

    set (pp := ((Ty ,, Tm) ,, p) : mor_total (preShv C)).
    set (r := (λ Γ A,
               (ΓAπ Γ A ,, (te Γ A ,, te_axiom Γ A) ,, pullback Γ A))
              : cwf_representation pp).
    exact (pp ,, r).
  Defined.

  Definition isweq_cwf'_to_cwf_structure : isweq cwf'_to_cwf_structure.
  Proof.
    apply (isweq_iso cwf'_to_cwf_structure cwf_to_cwf'_structure).
    - intros x. apply idpath.
    - intros x. apply idpath.
  Defined.

  Definition weq_cwf'_cwf_structure
    : cwf'_structure C ≃ cwf_structure C.
  Proof.
    use tpair.
    - apply cwf'_to_cwf_structure.
    - apply isweq_cwf'_to_cwf_structure.
  Defined.

  (* Morphisms of CwF' structures *)
  Definition cwf'_structure_mor (X Y : cwf'_structure C) : UU
    := ∑ (ext : obj_ext_mor (pr1 X) (pr1 Y)),
       term_fun_mor X Y ext.

  Section mor.

    Context (X' Y' : cwf'_structure C).

    Local Definition X := cwf'_to_cwf_structure X'.
    Local Definition Y := cwf'_to_cwf_structure Y'.

    Definition cwf'_to_cwf_structure_mor
      : cwf'_structure_mor X' Y' → cwf_structure_mor X Y.
    Proof.
      intros [[F_TY p_ax1] [F_TM [ax2 ax3]]].
      set (p   := λ Γ A, pr1 (p_ax1 Γ A)).
      set (ax1 := λ Γ A, pr2 (p_ax1 Γ A)).
      exact ((F_TM ,, F_TY ,, p) ,, (ax1 ,, ax2 ,, ax3)).
    Defined.

    Definition cwf_to_cwf'_structure_mor
      : cwf_structure_mor X Y → cwf'_structure_mor X' Y'.
    Proof.
      intros [[F_TM [F_TY p]] [ax1 [ax2 ax3]]].
      set (ext := (F_TY ,, λ Γ A, (p Γ A ,, ax1 Γ A))
                  : obj_ext_mor (pr1 X') (pr1 Y')).
      set (tfm := (F_TM ,, ax2 ,, ax3) : term_fun_mor X' Y' ext).
      exact (ext ,, tfm).
    Defined.

    Definition isweq_cwf'_to_cwf_structure_mor : isweq cwf'_to_cwf_structure_mor.
    Proof.
      apply (isweq_iso cwf'_to_cwf_structure_mor
                       cwf_to_cwf'_structure_mor).
      - intros x. apply idpath.
      - intros x. apply idpath.
    Defined.

    Definition weq_cwf'_to_cwf_structure_mor
        : cwf'_structure_mor X' Y' ≃ cwf_structure_mor X Y.
    Proof.
      use tpair.
      - apply cwf'_to_cwf_structure_mor.
      - apply isweq_cwf'_to_cwf_structure_mor.
    Defined.

  End mor.

  (* CwF' to CwF functor *)

  Definition cwf'_to_cwf_functor_data
    : functor_data (cwf'_structure_precat C) (@cwf_structure_cat C).
  Proof.
    use make_functor_data.
    - apply cwf'_to_cwf_structure.
    - apply cwf'_to_cwf_structure_mor.
  Defined.

  Definition cwf'_to_cwf_functor_idax
    : functor_idax cwf'_to_cwf_functor_data.
  Proof.
    intros c.
    use total2_paths_f.
    + apply idpath.
    + use total2_paths_f.
      * apply idpath.
      * use total2_paths_f.
        -- apply idpath.
        -- apply impred_isaprop. intros Γ.
           apply impred_isaprop. intros A.
           apply setproperty.
  Defined.

  Definition cwf'_to_cwf_functor_compax
    : functor_compax cwf'_to_cwf_functor_data.
  Proof.
    intros a b c.
    intros f g.

    use total2_paths_f.
    + apply idpath.
    + apply dirprod_paths.
      - apply impred_isaprop. intros Γ.
        apply impred_isaprop. intros A.
        apply homset_property.
      - apply dirprod_paths.
        * apply homset_property.
        * apply impred_isaprop. intros Γ.
          apply impred_isaprop. intros A.
          apply setproperty.
  Defined.

  Definition cwf'_to_cwf_is_functor
    : is_functor cwf'_to_cwf_functor_data
    := (cwf'_to_cwf_functor_idax ,, cwf'_to_cwf_functor_compax).

  Definition cwf'_to_cwf_functor
    : functor (cwf'_structure_precat C)
              (@cwf_structure_precategory_data C).
  Proof.
    use (make_functor cwf'_to_cwf_functor_data).
    apply cwf'_to_cwf_is_functor.
  Defined.

  Definition cwf'_to_cwf_is_catiso : is_catiso cwf'_to_cwf_functor.
  Proof.
    use tpair.
    - unfold fully_faithful.
      intros X Y.
      apply isweq_cwf'_to_cwf_structure_mor.
    - apply isweq_cwf'_to_cwf_structure.
  Defined.

End CwF_Cat_Equiv.


(* The type 'v' represents the set of variables symbols.        *)
(* The type T v is the set of lambda terms with variables in v. *)

Inductive T (v:Type) : Type :=
| Var : v -> T v                    (* variable                 *)
| App : T v -> T v -> T v           (* application              *)
| Lam : v -> T v -> T v             (* lambda abstraction       *)
.

Arguments Var {v} _.
Arguments App {v} _ _.
Arguments Lam {v} _ _.


Require Import Coq.Bool.Bool.

Require Export Stlc.

Scheme Equality for type.

Lemma type_beq_refl : forall t,
  type_beq t t = true.
Proof.
  induction t.
  - reflexivity.
  - simpl.
    rewrite IHt1.
    rewrite IHt2.
    reflexivity.
Qed.

Lemma type_beq_eq_iff : forall t1 t2,
  type_beq t1 t2 = true <-> t1 = t2.
Proof.
  intros t1 t2.
  split; intros H.
  - generalize dependent t2.
    induction t1; intros t2 H.
    + destruct t2; try discriminate; reflexivity.
    + destruct t2; try discriminate.
      simpl in H.
      apply andb_true_iff in H as [H1 H2].
      apply IHt1_1 in H1.
      apply IHt1_2 in H2.
      subst.
      reflexivity.
  - rewrite H.
    apply type_beq_refl.
Qed.

(******************************************************************************)
(* has_type                                                                   *)
(******************************************************************************)
Print has_type.

Fixpoint fhas_type (c : context) (e : expr) : option type :=
  match e with
  | eunit => Some tunit
  | evar x => Context.find x c
  | eabs x t1 e =>
      option_map (tfun t1) (fhas_type (Context.add x t1 c) e)
  | eapp e1 e2 =>
      match fhas_type c e1 with
      | Some (tfun t1 t2) =>
          match fhas_type c e2 with
          | Some t3 =>
              if type_beq t1 t3 then Some t2 else None
          | None => None
          end
      | Some _ => None
      | None => None
      end
  | elet x e1 e2 =>
      match fhas_type c e1 with
      | Some t1 => fhas_type (Context.add x t1 c) e2
      | None => None
      end
  end.

Theorem fhas_type_if_has_type : forall c e t,
  has_type c e t -> fhas_type c e = Some t.
Proof.
  intros c e t HAS_TYPE.
  induction HAS_TYPE.
  - reflexivity.
  - simpl.
    rewrite H.
    reflexivity.
  - simpl.
    rewrite IHHAS_TYPE.
    reflexivity.
  - simpl.
    rewrite IHHAS_TYPE1.
    rewrite IHHAS_TYPE2.
    rewrite type_beq_refl.
    reflexivity.
  - simpl.
    rewrite IHHAS_TYPE1.
    assumption.
Qed.

Theorem has_type_if_fhas_type : forall c e t,
  fhas_type c e = Some t -> has_type c e t.
Proof.
  intros c e.
  generalize dependent c.
  induction e; intros c ty H.
  - inversion H; clear H.
    apply has_type_unit.
  - inversion H; clear H.
    apply has_type_var.
    assumption.
  - inversion H; clear H.
    destruct (fhas_type (Context.add v t c) e) eqn:Heqn.
    + inversion H1; clear H1.
      apply has_type_abs.
      auto.
    + discriminate.
  - inversion H; clear H.
    destruct (fhas_type c e1) eqn:Heqn1.
    + destruct t eqn:Heqn2.
      * discriminate.
      * destruct (fhas_type c e2) eqn:Heqn3.
        { destruct (type_beq t0_1 t0) eqn:Heqn4.
          - apply type_beq_eq_iff in Heqn4; subst.
            inversion H1; clear H1; subst.
            eapply has_type_app; eauto.
          - discriminate.
        }
        { discriminate. }
    + discriminate.
  - inversion H; clear H.
    destruct (fhas_type c e1) eqn:Heqn1; try discriminate.
    destruct (fhas_type (Context.add v t c) e2) eqn:Heqn2; try discriminate.
    inversion H1; subst.
    eauto using has_type_let.
Qed.

Theorem has_type_iff_fhas_type : forall c e t,
  has_type c e t <-> fhas_type c e = Some t.
Proof.
  intros. split.
  - eauto 2 using fhas_type_if_has_type.
  - eauto 2 using has_type_if_fhas_type.
Qed.

(******************************************************************************)
(* value                                                                      *)
(******************************************************************************)

Definition is_value (e : expr) : bool :=
  match e with
  | eunit => true
  | eabs _ _ _ => true
  | _ => false
  end.

Theorem value_iff_is_value : forall e,
  value e <-> is_value e = true.
Proof.
  intros e. split; intros H.
  - induction H; reflexivity.
  - induction e; auto using value; inversion H.
Qed.

Theorem not_value_iff_is_value_false : forall e,
  ~ value e <-> is_value e = false.
Proof.
Admitted.

(******************************************************************************)
(* feval                                                                      *)
(******************************************************************************)

Print eval.

Fixpoint feval (h : heap) (e : expr) : option expr :=
  match e with
  | eunit => None
  | evar x => Heap.find x h
  | eabs _ _ _ => None
  | eapp (eabs x t e) e2 =>
      if is_value e2 then
        Some (subst x e2 e)
      else
        match feval h e2 with
        | Some v2 => Some (eapp (eabs x t e) v2)
        | None => None
        end
  | eapp e1 e2 =>
      match feval h e1 with
      | Some v1 => Some (eapp v1 e2)
      | None => None
      end
  | elet x e1 e2 =>
      if is_value e1 then
        Some (subst x e1 e2)
      else
        match feval h e1 with
        | Some v1 => Some (elet x v1 e2)
        | None => None
        end
  end.

Lemma not_value_if_eval : forall h e1 e2, eval h e1 e2 -> ~ value e1.
Proof.
  intros h e1 e2 H.
  inversion H; rewrite value_iff_is_value; try discriminate.
Qed.

Theorem feval_if_eval : forall c h e1 e2 t,
  has_type c e1 t ->
  eval h e1 e2 ->
  feval h e1 = Some e2.
Proof.
  intros c h e1 e2 t HAS_TYPE EVAL.
  generalize dependent t.
  generalize dependent c.
  induction EVAL; intros c ty HAS_TYPE.
  - assumption.
  - simpl.
    destruct e1;
      inversion EVAL; inversion HAS_TYPE; subst;
      erewrite IHEVAL; eauto.
  - simpl.
    destruct v1.
    + inversion HAS_TYPE; subst.
      inversion H3.
    + inversion H.
    + inversion HAS_TYPE; subst.
      apply not_value_if_eval in EVAL.
      rewrite value_iff_is_value in EVAL.
      apply not_true_is_false in EVAL.
      rewrite EVAL.
      erewrite IHEVAL; eauto.
    + inversion H.
    + inversion H.
  - apply value_iff_is_value in H.
    simpl.
    rewrite H.
    reflexivity.
  - simpl.
    inversion HAS_TYPE; clear HAS_TYPE; subst.
    apply not_value_if_eval in EVAL.
    rewrite value_iff_is_value in EVAL.
    apply not_true_is_false in EVAL.
    destruct (is_value e1) eqn:Heqn.
    + discriminate.
    + erewrite IHEVAL; eauto 1.
  - simpl.
    apply value_iff_is_value in H.
    rewrite H.
    reflexivity.
Qed.

Lemma eval_if_not_value : forall e1,
  ~ value e1 -> exists h e2, eval h e1 e2.
Proof.
Admitted.

Theorem eval_if_feval : forall c h e1 e2 t,
  has_type c e1 t ->
  feval h e1 = Some e2 ->
  eval h e1 e2.
Proof.
  intros c h e1.
  generalize dependent h.
  generalize dependent c.
  induction e1; intros c h e2 ty HAS_TYPE H.
  - inversion H.
  - simpl in H.
    apply eval_var.
    assumption.
  - inversion H.
  - inversion HAS_TYPE; clear HAS_TYPE; subst.
    destruct e1_1 eqn:Heqn.
    + discriminate.
    + simpl in H.
      destruct (Heap.find (elt:=expr) v h) eqn:Heqn2.
      * inversion H.
        apply eval_app1.
        apply eval_var.
        assumption.
      * discriminate.
    + simpl in H.
      destruct (is_value e1_2) eqn:Heqn2.
      * inversion H.
        apply eval_beta.
        apply value_iff_is_value.
        assumption.
      * destruct (feval h e1_2) eqn:Heqn3;
          inversion H; clear H; subst;
          eauto using eval_app2, vabs.
    + rewrite <- Heqn in *.
      simpl in H.
      destruct (feval h e1_1) eqn:Heqn2.
      * rewrite Heqn in *.
        inversion H.
        eauto using eval_app1.
      * rewrite Heqn in *.
        discriminate.
    + rewrite <- Heqn in *.
      simpl in H.
      destruct (feval h e1_1) eqn:Heqn2.
      * rewrite Heqn in *.
        inversion H.
        eauto using eval_app1.
      * rewrite Heqn in *.
        discriminate.
  - inversion HAS_TYPE; clear HAS_TYPE; subst.
    simpl in H.
    destruct (is_value e1_1) eqn:Heqn1.
    + inversion H; clear H; subst.
      apply eval_let2.
      apply value_iff_is_value.
      assumption.
    + destruct (feval h e1_1) eqn:Heqn2;
        inversion H; clear H; subst;
        eauto using eval_let1.
Qed.

Theorem eval_iff_feval : forall c h e1 e2 t,
  has_type c e1 t ->
  eval h e1 e2 <-> feval h e1 = Some e2.
Proof.
  intros. split.
  - eauto 2 using feval_if_eval.
  - eauto 2 using eval_if_feval.
Qed.


(** printing \2/ $\cup$ #∪# *)
(** printing <2= $\subseteq$ #⊆# *)
(** printing forall $\forall$ #∀# *)
(** printing -> $\rightarrow$ #→# *)
(** printing /\ $\land$ #∧# *)

Require Import Setoid Program.
Require Import Paco.paco.

(** * Illustrating the [paco] library

    This tutorial shows how to use our [paco] library to reason about
    coinductive predicates in Coq.  By coinductive predicates we mean
    objects that one can define using [CoInductive] and whose type
    ends in [Prop].  The library implements _parameterized
    coinduction_, as described in our draft paper entitled ## _The Power of
    Parameterization in Coinductive Proof_ ##.

    How does parameterized coinduction compare to Coq's existing
    support for coinductive proofs?

    For proofs by _induction_, Coq provides a tactic called [fix], but
    proofs done directly with [fix] are required to satisfy a
    _syntactic guardedness_ criterion.  Fortunately, Coq also
    generates induction _lemmas_ for every inductive definition, which
    eliminate the need to ever use the low-level [fix] tactic and
    worry about guardedness.  For proofs by coinduction, Coq provides
    a tactic [cofix] analogous to [fix], i.e., also based on a
    syntactic guardedness criterion.  However, Coq does not generate
    any lemmas for coinductive definitions.  Consequently, to reason
    about such definitions, the user must use the low-level [cofix]
    tactic.  Due to its syntactic nature, [cofix] is problematic in
    several ways (please see the paper linked above for detailed
    discussion of these points):

    - It is non-compositional.
    - It is inefficient.
    - It is not user-friendly.
    - It interacts poorly with builtin automation tactics.

    The [paco] library provides a tactic, [pcofix], which can be seen
    as a replacement for Coq's builtin [cofix] tactic (in the case of
    predicates) that does not involve any syntactic guardedness
    criterion and thus avoids all of these problems.  In addition,
    like Coq's [cofix], [pcofix] provides built-in support for
    _incremental_ proofs, i.e., proofs in which the coinduction
    hypothesis is extended gradually as the proof progresses.

    We believe this combination of compositionality, incrementality,
    robustness, and ease of use makes [pcofix] a superior alternative
    to [cofix] for proofs about coinductive predicates.

    The rest of this tutorial illustrates the use of the [paco]
    library with the help of three examples.
*)(* *)

(** ** Example: stream equality

    The first example involves streams of natural numbers and an
    equality thereon.  We prove a particular equality via [cofix], and
    then explain how that proof can be turned into one via [pcofix].
*)

(** We start by defining a type of streams of natural numbers.
*)

CoInductive stream :=
  | cons : nat -> stream -> stream.

(** The following, seemingly useless, lemma is a common trick for
    working with corecursive terms such as our streams.  (It will be
    used in the example proofs.)  For details, see for instance #Adam
    Chlipala's book on Certified Programming with Dependent
    Types#.
*)

Definition sunf s :=
  match s with cons n s' => cons n s' end.

Lemma sunf_eq : forall s, s = sunf s.
Proof.
  destruct s; auto.
Qed.

(** In order to state our example equality, we define an enumeration
    stream and a map operation for streams.
*)

CoFixpoint enumerate n : stream :=
  cons n (enumerate (S n)).

CoFixpoint map f s : stream :=
  match s with cons n s' => cons (f n) (map f s') end.

(** *** A proof using [cofix]

    We will now prove, using [cofix], that for any [n] the stream
    [enumerate n] is equal to the stream [cons n (map S (enumerate n))].
*)

(** First, we define an equality [seq] on streams.  Usually, one would
    do this as follows.

    [CoInductive seq : stream -> stream -> Prop :=] #
#
    [  | seq_fold : forall n s1 s2 (R : seq s1 s2), seq (cons n s1) (cons n s2).]

    Instead, we define the generating function, [seq_gen], beforehand,
    and then define [seq] as its greatest fixed point using
    [CoInductive].  The reason is simply that we need [seq_gen] later
    when using [paco].  If applying parameterized coinduction to an
    existing development where the generating function is not
    explicit, it can always easily be made explicit.

    Note that, albeit the use of [Inductive], the definition
    of [seq_gen] is not recursive.
*)

Inductive seq_gen seq : stream -> stream -> Prop :=
  | _seq_gen : forall n s1 s2 (R : seq s1 s2 : Prop), seq_gen seq (cons n s1) (cons n s2).
#[export] Hint Constructors seq_gen : core.

CoInductive seq : stream -> stream -> Prop :=
  | seq_fold : forall s1 s2, seq_gen seq s1 s2 -> seq s1 s2.

(** Second, we do the actual proof.
*)

Theorem example : forall n, seq (enumerate n) (cons n (map S (enumerate n))).
Proof.
  cofix CIH.
  intros; apply seq_fold.
  pattern (enumerate n) at 1; rewrite sunf_eq; simpl.
  constructor.
  rewrite (sunf_eq (enumerate n)); simpl.
  rewrite (sunf_eq (map _ _)); simpl.
  apply CIH.
Qed.

(** _Note_: One might want to eliminate the use of [pattern] in the
    proof script by replacing the corresponding line with the
    following:

    [rewrite sunf_eq at 1; simpl.]

    However, doing so will result in an invalid proof (rejected at
    [Qed]-time).  The reason is that the proof term created by
    [rewrite] ... [at 1] involves some lemmas from the [Setoid]
    library.  Like most lemmas, these are opaque, so guardedness
    checking cannot inspect their proofs and thus fails.  This is a
    great example of two of the previously mentioned problems with the
    [cofix] approach, namely lack of compositionality and poor
    interaction with standard tactics.
*)(* *)

(** *** A proof using our [pcofix]

    We will now do the same proof, but using the [paco] library.  We
    first simply show the new (but equivalent) definition of stream
    equality and the new proof of the example, and then explain what
    is going on behind the scenes.  In both, we use [paco] constructs
    with suffix "2" because we are dealing with predicates of arity 2
    here.

    _Note_: [Paco] supports predicates of arity up to 8.  Also, it
    supports up to three mutually coinductive predicates (see the last
    example of this tutorial).  In either case, extending this is just
    a matter of copy and paste.

    We also have to prove monotonicity of the generating function
    [seq_gen], which can be discharged by the tactic [pmonauto], and
    register it in the Hint databse [paco].

    _Remark_: Unlike [CoInductive], [paco] does not care whether the
    generating function is given in a _strictly positive_ syntactic
    form; all that matters is that the function is monotone. More
    specifically, [paco2 f] is well defined for an arbitrary generating
    function [f] regardless of whether it is monotone or not. However,
    in order to ensure that [paco2 f bot2] is the greatest fixed point
    of [f], we need monotonicity of [f].
*)

Definition seq' s1 s2 := paco2 seq_gen bot2 s1 s2.
#[export] Hint Unfold seq' : core.
Lemma seq_gen_mon: monotone2 seq_gen. Proof. pmonauto. Qed.
#[export] Hint Resolve seq_gen_mon : paco.

Theorem example' : forall n, seq' (enumerate n) (cons n (map S (enumerate n))).
Proof.
  pcofix CIH.
  intros; pfold.
  rewrite sunf_eq at 1; simpl.
  constructor.
  rewrite (sunf_eq (enumerate n)); simpl.
  rewrite (sunf_eq (map _ _)); simpl.
  right; apply CIH.
Qed.

(** Observe that the proof script is essentially the same as before
    (this is no accident).  The main change is the use of [pcofix]
    instead of [cofix], which allows us to avoid any syntactic
    guardedness checking at [Qed]-time.  As a minor benefit of that,
    we are able to use [rewrite] ... [at 1], which we could not do
    before.  *)

(** **** How it works:

    To understand [seq'] and the proof of [example'], we have to
    explain some background.  Given a monotone function [f], we call
    [paco2 f] the _parameterized_ greatest fixed point of [f].  For a
    relation [r], [paco2 f r] is defined as the greatest fixed point
    of the function [fun x => f (x \2/ r)].  Clearly, [paco2 f bot2]
    (where [bot2] is the empty relation) is just the ordinary greatest
    fixed point of [f].

    Let us look at our example domain to understand better.  A proof
    of [paco2 seq_gen r s1 s2] can be seen as a proof of [r <2= seq ->
    seq s1 s2], where the use of the premise is guarded
    _semantically_, rather than syntactically.  More precisely, [paco2
    seq_gen r] relates two streams iff their heads are equal and their
    tails are either related by [r] or again related by [paco2 seq_gen
    r].  Compare this to [seq], the ordinary greatest fixed point of
    [seq_gen], which relates two streams iff their heads are equal and
    their tails are again related by [seq].  This should also make it
    clear why our definition of [seq'] is equivalent to [seq].

    To fold and unfold parameterized fixed points, we provide two
    tactics, where [upaco2 f r := paco2 f r \2/ r]:

    - [pfold] : when the conclusion is [paco2 f r] for some [f] and
      [r], [pfold] converts it to [f (upaco2 f r)]
    - [punfold H] : when the hypothesis [H] is [paco2 f r] for some
      [f] and [r], [punfold H] converts it to [f (upaco2 f r)]

    Other useful lemmas are:

    - [paco2_mon f : monotone2 (paco2 f)]
    - [paco2_mult f : forall r, paco2 f (paco2 f r) <2= paco2 f r]
    - [paco2_mult_strong f : forall r, paco2 f (upaco2 f r) <2= paco2 f r]

    We will see an example involving [paco2_mult] in a moment.  But
    first let us have another look at the proof scripts of [example]
    and [example'].  In the former, after calling [cofix], the proof
    state is as follows:

    [CIH : forall n : nat, seq (enumerate n) (cons n (map S (enumerate n)))] #
#
    [============================] #
#
    [forall n : nat, seq (enumerate n) (cons n (map S (enumerate n)))] #
#

    In this state, the hypothesis precisely matches the conclusion,
    and there is nothing preventing one from simply concluding the
    goal directly.  Of course, if one were to do that, one's "proof"
    would be subsequently rejected by [Qed] for failing to obey
    syntactic guardedness.

    Calling [pcofix] results in a similar state, except that the added
    hypothesis [CIH] now governs a fresh relation variable [r], which
    represents the current coinduction hypothesis relating [enumerate n]
    and [cons n (map S (enumerate n))] for all [n].  The new goal
    then says that, in proving the two streams equal, we can use [r]
    coinductively, but only in a semantically guarded position,
    i.e. after unfolding [paco2 seq_gen r].  In particular, one
    _cannot_ apply [CIH] immediately to "solve" the goal:

    [r : stream -> stream -> Prop] #
#
    [CIH : forall n : nat, r (enumerate n) (cons n (map S (enumerate n)))] #
#
    [============================] #
#
    [forall n : nat, paco2 seq_gen r (enumerate n) (cons n (map S (enumerate n)))] #
#

    The remaining differences between the proof scripts of [example]
    and [example'] are as follows.  First, let us examine [example].
    After applying [seq_fold] and unfolding [enumerate n] in the proof
    of [example], we have the following goal:

    [CIH : forall n : nat, seq (enumerate n) (cons n (map S (enumerate n)))] #
#
    [n : nat] #
#
    [============================] #
#
    [seq_gen seq (cons n (enumerate (S n))) (cons n (map S (enumerate n)))] #
#

    By the definition of [seq_gen] and unfolding [map S (enumerate n)],
    this reduces to showing

    [CIH : forall n : nat, seq (enumerate n) (cons n (map S (enumerate n)))] #
#
    [n : nat] #
#
    [============================] #
#
    [seq (enumerate (S n)) (cons (S n) (map S (enumerate (S n))))] #
#

    which follows directly by applying the coinduction hypothesis [CIH].

    In the case of [example'], the proof is slightly different.
    First, we use the tactic [pfold] rather than [apply seq_fold],
    simply because we now reason about [seq'] rather than [seq].
    After applying [pfold] and unfolding [enumerate n], we have:

    [r : stream -> stream -> Prop] #
#
    [CIH : forall n : nat, r (enumerate n) (cons n (map S (enumerate n)))] #
#
    [n : nat] #
#
    [============================] #
#
    [seq_gen (paco2 seq_gen r \2/ r) (cons n (enumerate (S n))) (cons n (map S (enumerate n)))] #
#

    As you see, the relation [r] appears in the argument of
    [seq_gen]. Thus by definition of [seq_gen] and unfolding [map S
    (enumerate n)], we need to show [enumerate (S n)] and [cons (S n)
    (map S (enumerate (S n)))] are related by either [paco2 seq_gen r]
    or [r]:

    [r : stream -> stream -> Prop] #
#
    [CIH : forall n : nat, r (enumerate n) (cons n (map S (enumerate n)))] #
#
    [n : nat] #
#
    [============================] #
#
    [paco2 seq_gen r (enumerate (S n)) (cons (S n) (map S (enumerate (S n))))] #
#
    [ \/ r (enumerate (S n)) (cons (S n) (map S (enumerate (S n))))] #
#

    As the coinduction hypothesis gives us that they are related by [r],
    we first have to select the [right] disjunct, before we apply
    [CIH].

    Summing up, the two proofs are very similar, but in the one using
    [paco], the guardedness of the coinduction is guaranteed at every
    step by the way the proof is constructed, rather than by a
    syntactic check of the whole proof term after the fact.
 *)(* *)

(** *** Another example

    Before moving on to the second part, we briefly demonstrate the
    use of the tactics [punfold] and [pclearbot].
*)(* *)

(** Here is a proof for [seq].
*)

Theorem seq_cons : forall n1 n2 s1 s2 (SEQ : seq (cons n1 s1) (cons n2 s2)),
  n1 = n2 /\ seq s1 s2.
Proof.
  intros.
  inversion_clear SEQ; rename H into SEQ.
  inversion_clear SEQ; auto.
Qed.

(** And here is the corresponding proof for [seq'].

  Note that the tactic [pclearbot] simplifies all hypotheses of the form [upaco{n} gf bot{n}] to [paco{n} gf bot{n}].
*)

Theorem seq'_cons : forall n1 n2 s1 s2 (SEQ : seq' (cons n1 s1) (cons n2 s2)),
  n1 = n2 /\ seq' s1 s2.
Proof.
  intros.
  punfold SEQ.
  inversion_clear SEQ; pclearbot; auto.
Qed.

(** We also provide two tactics [pdestruct] and [pinversion].
    They are simply defined as follows:

    - [pdestruct H] := [punfold H; destruct H; pclearbot]
    - [pinversion H] := [punfold H; inversion H; pclearbot]

    Using this the proof of the above theorem [seq'_cons] can be
    simplified as [intros; pinversion SEQ; auto.]
*)(* *)

(** ** Example: infinite tree equality

    The second example involves infinite binary trees of natural
    numbers and an equality thereon.  We prove two particular
    equalities via [cofix] in an incremental fashion, and then show
    how these proofs can be done just as easily via [pcofix].
    We then show how, using [pcofix], the proofs can additionally
    be modularly decomposed.

*)

(** As before, we first define the coinductive type and the unfolding
    trick.
*)

CoInductive inftree :=
  | node : nat -> inftree -> inftree -> inftree.

Definition tunf t : inftree :=
  match t with node n tl tr => node n tl tr end.

Lemma tunf_eq : forall t, t = tunf t.
Proof.
  destruct t; auto.
Qed.

(** In order to state our example equalities, we define the following
    four trees.
*)

CoFixpoint one : inftree := node 1 one two
with       two : inftree := node 2 one two.

CoFixpoint eins : inftree := node 1 eins (node 2 eins zwei)
with       zwei : inftree := node 2 eins zwei.

(** *** Incremental proofs using [cofix]

    As before, we define the tree equality as the greatest fixed point
    of its generating function.
*)

Inductive teq_gen teq : inftree -> inftree -> Prop :=
  | _teq_gen : forall n t1l t1r t2l t2r (Rl : teq t1l t2l : Prop) (Rr : teq t1r t2r),
                 teq_gen teq (node n t1l t1r) (node n t2l t2r).
#[export] Hint Constructors teq_gen : core.

CoInductive teq t1 t2 : Prop :=
  | teq_fold (IN : teq_gen teq t1 t2).

(** We now prove, using [cofix], that [one] equals [eins] and,
    separately, that [two] equals [zwei].  Note the nested use of
    [cofix] in either proof script, which lets us strengthen the
    coinductive hypothesis in the middle of the proof.  For instance,
    in the proof [teq_one], we start out with the coinductive
    hypothesis that [one] and [eins] are equal ([CIH]).  Later on, we
    use [cofix] again to additionally assume that [two] and [zwei] are
    equal ([CIH']).  This is a prime example of _incremental_ proof:
    we start with no coinductive assumptions, and we progressively add
    more coinductive assumptions as the proof progresses.
*)

Theorem teq_one : teq one eins.
Proof.
  cofix CIH.
  apply teq_fold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  apply teq_fold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
  cofix CIH'.
  apply teq_fold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
Qed.

Theorem teq_two : teq two zwei.
Proof.
  cofix CIH.
  apply teq_fold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
  cofix CIH'.
  apply teq_fold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  apply teq_fold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
Qed.

(** *** Incremental proofs using our [pcofix]

    As before, we can easily turn the above [cofix]-proofs into
    [pcofix]-proofs.
*)

Definition teq' t1 t2 := paco2 teq_gen bot2 t1 t2.
#[export] Hint Unfold teq' : core.
Lemma teq_gen_mon: monotone2 teq_gen. Proof. pmonauto. Qed.
#[export] Hint Resolve teq_gen_mon : paco.

Theorem teq'_one : teq' one eins.
Proof.
  pcofix CIH.
  pfold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  left; pfold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
  left; pcofix CIH'.
  pfold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
Qed.

Theorem teq'_two : teq' two zwei.
Proof.
  pcofix CIH.
  pfold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
  left; pcofix CIH'.
  pfold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  left; pfold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
Qed.

(** *** Pseudo-compositional proofs using [cofix]

    It is easy to see that the proofs of [teq_one] and [teq_two] are
    essentially the same.  We can avoid duplicating some work by
    decomposing the proofs as follows.

    First we prove that [teq two zwei] holds under the coinductive
    assumption [teq one eins].  This is basically the second part of
    the proof of [teq_one] (and the first part of the proof of
    [teq_two]).  Then we prove the converse, i.e., that [teq one
    eins] holds under the coinductive assumption [teq two zwei].
    This is basically the first part of the proof of [teq_one] (and
    the second part of the proof of [teq_two]).

    The issue is that there seems to be no way to express these two
    properties.  The best we can do is prove [teq two zwei -> teq one
    eins] and [teq one eins -> teq two zwei], and make sure that in
    these proofs any use of the assumption is syntactically guarded.
    For instance, we are not allowed to prove [teq two zwei -> teq
    one eins] by inspecting [teq two zwei] and extracting [teq one
    eins] from that (see the proof of [teq_two_one_bad] below).
    Although a valid proof of that goal by itself, it could not be
    composed later to yield a proof of [teq one eins] or [teq two
    zwei] (see the aborted theorem [teq_eins_bad] below).

    Moreover, both lemmas must then be made transparent by using
    [Defined] instead of [Qed] at the end, such that, when composing
    them to prove [teq one eins] or [teq two zwei], guardedness
    checking can inspect their proof terms.  In other words, [cofix]
    is not properly compositional.
*)

Lemma teq_two_one_bad : teq two zwei -> teq one eins.
Proof.
  intros; rewrite (tunf_eq two), (tunf_eq zwei) in H.
  destruct H; inversion IN; auto.
Defined.

Lemma teq_two_one : teq two zwei -> teq one eins.
Proof.
  intros; cofix CIH.
  apply teq_fold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  apply teq_fold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
Defined.

Lemma teq_one_two : teq one eins -> teq two zwei.
Proof.
  intros; cofix CIH.
  apply teq_fold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
Defined.

Theorem teq_eins : teq one eins.
Proof.
  cofix CIH.
  apply teq_two_one, teq_one_two, CIH.
Qed.

Theorem teq_zwei : teq two zwei.
Proof.
  cofix CIH.
  apply teq_one_two, teq_two_one, CIH.
Qed.

(** The following proof would fail guardedness checking at [Qed]-time,
    because in the proof of the lemma [teq_two_one_bad] the
    assumption is used "too early".
*)

Theorem teq_eins_bad : teq one eins.
Proof.
  cofix CIH.
  apply teq_two_one_bad, teq_one_two, CIH.
Abort.

(** *** Compositional proofs using our [pcofix]

    Using parameterized coinduction, we can state the actual desired
    lemmas as follows and prove them using [pcofix] (again, only
    minimal changes to the previous proof scripts are required).
    Observe that (i) the earlier "wrong" proof of [teq two zwei -> teq
    one eins] ([teq_two_one_bad]) is _not_ a proof of the
    corresponding lemma here, and (ii) we are not forced to make the
    lemmas transparent.
*)

Lemma teq'_two_one : forall r,
  (r two zwei : Prop) -> paco2 teq_gen r one eins.
Proof.
  intros; pcofix CIH.
  pfold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  left; pfold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
Qed.

Lemma teq'_one_two : forall r,
  (r one eins : Prop) -> paco2 teq_gen r two zwei.
Proof.
  intros; pcofix CIH.
  pfold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
Qed.

(** We now compose them with the help of the lemma [paco2_mult]:
    - [paco2_mult f : paco2 f (paco2 f r) <2= paco2 f r]

    The tactic [pmult] applies [paco{n}_mult] to the conclusion
    for an appropriate [n].
*)

Theorem teq'_eins : teq' one eins.
Proof.
  pcofix CIH.
  pmult; apply teq'_two_one, teq'_one_two, CIH.
Qed.

Theorem teq'_zwei : teq' two zwei.
Proof.
  pcofix CIH.
  pmult; apply teq'_one_two, teq'_two_one, CIH.
Qed.

(** ** Example: mutual coinduction

    The third and last example shows that [paco] also works for mutual
    coinduction.  Here, the mutuality involves two predicates.
*)(* *)

(** We define two generating functions (using the [inftree] type from
    before).
*)

(** *** A proof via [cofix]

    Using these, we now define two mutually coinductive predicates
    [eqone] and [eqtwo].  It is easy to see intuitively that they
    contain all trees that are equal to [one] and [two] from above,
    respectively.  We then prove that [eqone] contains [eins].
*)

CoInductive eqone : inftree -> Prop :=
  | eqone_fold tl tr (EQL : eqone tl : Prop) (EQR : eqtwo tr : Prop):
      eqone (node 1 tl tr)
with eqtwo : inftree -> Prop :=
  | eqtwo_fold tl tr (EQL : eqone tl : Prop) (EQR : eqtwo tr : Prop):
      eqtwo (node 2 tl tr).

Lemma eqone_eins : eqone eins.
Proof.
  cofix CIH0.
  rewrite (tunf_eq eins); simpl.
  constructor; [apply CIH0|].
  cofix CIH1.
  constructor; [apply CIH0|].
  rewrite (tunf_eq zwei).
  apply CIH1.
Qed.

(** *** A proof via [pcofix]

    To define the [paco] versions of [eqone] and [eqtwo], we apply
    the two constructors [paco1_2_0] and [paco1_2_1], respectively ("1"
    because we are dealing with unary predicates).  Again, the
    translation of the lemma and of its proof is almost trivial.
 *)

Inductive eqonetwo_gen eqonetwo : inftree+inftree -> Prop :=
  | eqonetwo_left: forall tl tr (EQL: eqonetwo (inl tl) : Prop) (EQR: eqonetwo (inr tr) : Prop),
      eqonetwo_gen eqonetwo (inl (node 1 tl tr))
  | eqonetwo_right: forall tl tr (EQL: eqonetwo (inl tl) : Prop) (EQR: eqonetwo (inr tr) : Prop),
      eqonetwo_gen eqonetwo (inr (node 2 tl tr))
.
#[export] Hint Constructors eqonetwo_gen : core.

Definition eqone' t := paco1 eqonetwo_gen bot1 (inl t).
Definition eqtwo' t := paco1 eqonetwo_gen bot1 (inr t).
#[export] Hint Unfold eqone' eqtwo' : core.
Lemma eqonetwo_gen_mon: monotone1 eqonetwo_gen.
Proof. pmonauto. Qed.
#[export] Hint Resolve eqonetwo_gen_mon : paco.

Lemma eqone'_eins: eqone' eins.
Proof.
  pcofix CIH0; pfold.
  rewrite (tunf_eq eins); simpl.
  constructor; [right; apply CIH0|].
  left; pcofix CIH1; pfold.
  constructor; [right; apply CIH0|].
  rewrite (tunf_eq zwei).
  right; apply CIH1.
Qed.