Require Import Coq.Classes.RelationClasses.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
From ChargeCore.Logics Require Import ILogic ILEmbed.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Definition Fun (A B : Type) := A -> B.

Section ILogic_Pre.
  Context T (ord: relation T) {HPre : PreOrder ord}.
  Context {A : Type} `{IL: ILogic A}.

  Record ILPreFrm := mkILPreFrm {
    ILPreFrm_pred :> T -> A;
    ILPreFrm_closed: forall t t': T, ord t t' ->
      ILPreFrm_pred t |-- ILPreFrm_pred t'
  }.

  Notation "'mk'" := @mkILPreFrm.

  Global Instance ILPreFrm_m (P: ILPreFrm): Proper (ord ++> lentails) (ILPreFrm_pred P).
  Proof.
    intros t t' Ht. apply ILPreFrm_closed; assumption.
  Qed.

  Program Definition ILPreFrm_atom (a : A) := mk (fun t => a) _.

  Local Obligation Tactic :=
    repeat match goal with
    | |- ord _ _ -> _ => intros Hord; try setoid_rewrite Hord; reflexivity
    | |- _ => intro
    end.

  Global Program Instance ILPre_Ops : ILogicOps ILPreFrm := {|
    lentails P Q := forall t:T, (ILPreFrm_pred P) t |-- (ILPreFrm_pred Q) t;
    ltrue        := mk (fun t => ltrue) _;
    lfalse       := mk (fun t => lfalse) _;
    limpl    P Q := mk (fun t => Forall t', Forall Ht' : ord t t', (ILPreFrm_pred P) t' -->> (ILPreFrm_pred Q) t') _;
    land     P Q := mk (fun t => (ILPreFrm_pred P) t //\\ (ILPreFrm_pred Q) t) _;
    lor      P Q := mk (fun t => (ILPreFrm_pred P) t \\// (ILPreFrm_pred Q) t) _;
    lforall  A P := mk (fun t => Forall a, (ILPreFrm_pred (P a)) t) _;
    lexists  A P := mk (fun t => Exists a, (ILPreFrm_pred (P a)) t) _
  |}.
  Next Obligation.
    apply lforallR; intro t''.
    apply lforallR; intro Ht'.
    apply lforallL with t''.
    assert (ord t t'') as Ht'' by (transitivity t'; assumption).
    apply lforallL with Ht''; reflexivity.
  Defined.
  Next Obligation.
    simpl; rewrite H; reflexivity.
  Defined.
  Next Obligation.
    simpl; rewrite H; reflexivity.
  Defined.
  Next Obligation.
    simpl; setoid_rewrite H; reflexivity.
  Defined.
  Next Obligation.
    simpl; setoid_rewrite H; reflexivity.
  Defined.

  Program Definition ILPre_ILogic : ILogic ILPreFrm.
  Proof.
   split; unfold lentails; simpl; intros.
    - split; red; [reflexivity|].
      intros P Q R HPQ HQR t.
      transitivity ((ILPreFrm_pred Q) t); [apply HPQ | apply HQR].
    - apply ltrueR.
    - apply lfalseL.
    - apply lforallL with x; apply H.
    - apply lforallR; intro x; apply H.
    - apply lexistsL; intro x; apply H.
    - apply lexistsR with x; apply H.
    - apply landL1; eapply H; assumption.
    - apply landL2; eapply H; assumption.
    - apply lorR1; eapply H; assumption.
    - apply lorR2; eapply H; assumption.
    - apply landR; [eapply H | eapply H0]; assumption.
    - apply lorL; [eapply H | eapply H0]; assumption.
    - apply landAdj.
      etransitivity; [apply H|]. apply lforallL with t.
      apply lforallL; reflexivity.
    - apply lforallR; intro t'; apply lforallR; intro Hord. apply limplAdj.
      rewrite ->Hord; eapply H; assumption.
  Qed.

  Global Existing Instance ILPre_ILogic.

  Global Instance ILPreFrm_pred_m {H : PreOrder ord}:
    Proper (lentails ++> ord ++> lentails) ILPreFrm_pred.
  Proof.
    intros P P' HPt t t' Ht. rewrite ->Ht. apply HPt.
  Qed.

  Global Instance ILPreFrm_pred_equiv_m:
    Equivalence ord ->
    Proper (lequiv ==> ord ==> lequiv) ILPreFrm_pred.
  Proof.
    intros Hord P P' HPt t t' Ht. split.
    - rewrite ->Ht. apply HPt.
    - symmetry in Ht. rewrite <-Ht. apply HPt.
  Qed.

  Global Instance ILPreFrm_pred_entails_eq_m:
    Proper (lentails ++> eq ++> lentails) ILPreFrm_pred.
  Proof.
    intros P P' HPt t t' Ht. subst; apply HPt.
  Qed.

  Global Instance ILPreFrm_pred_equiv_eq_m:
    Proper (lequiv ==> eq ==> lequiv) ILPreFrm_pred.
  Proof.
    intros P P' HPt t t' Ht. split; subst; apply HPt.
  Qed.

  Program Definition ILPreAtom {HPre : PreOrder ord} (t: T) :=
    mk (fun t' => Exists x : ord t t', ltrue) _.
  Next Obligation.
    apply lexistsL; intro H1.
    apply lexistsR; [transitivity t0; assumption | apply ltrueR].
  Qed.

End ILogic_Pre.

Arguments ILPreFrm [T] _ _ {ILOps} : rename.
Arguments mkILPreFrm {T} [ord] [A] {ILOps} _ _ : rename.

Section Embed_ILogic_Pre.
  Context T (ord: relation T) {HPre : PreOrder ord}.
  Context {A : Type} `{ILA: ILogic A}.
  Context {B : Type} `{ILB: ILogic B}.
  Context {HEmbOp : EmbedOp A B} {HEmb : Embed A B}.

(*
  Program Instance EmbedILPreDropOpEq : EmbedOp A (ILPreFrm ord A) := {
     embed := fun a => mkILPreFrm (fun x => a) _
  }.

  Instance EmbedILPreDropEq : Embed A (ILPreFrm ord A).
  Proof.
    split; intros.
    + simpl; intros. assumption.
    + split; intros t; simpl; reflexivity.
    + split; intros t; simpl; reflexivity.
    + split; intros t; simpl.
      * lforallL t. apply lforallL; reflexivity.
      * lforallR x H; reflexivity.
  Qed.
 *)
   Global Program Instance EmbedILPreDropOp : EmbedOp A (ILPreFrm ord B) := {
     embed := fun a => mkILPreFrm (fun x => embed a) _
  }.

  Global Instance EmbedILPreDrop : Embed A (ILPreFrm ord B).
  Proof.
    split; intros.
    + simpl; intros. apply embed_sound; assumption.
    + split; intros t; simpl; apply embedlforall.
    + split; intros t; simpl; apply embedlexists.
    + split; intros t; simpl.
      * apply lforallL with t. apply lforallL; [reflexivity | apply embedImpl].
      * apply lforallR; intro x; apply lforallR; intro H. apply embedImpl.
  Qed.

  Global Program Instance EmbedILPreOp : EmbedOp (ILPreFrm ord A) (ILPreFrm ord B) := {
     embed := fun a => mkILPreFrm (fun x => embed ((ILPreFrm_pred a) x)) _
  }.
  Next Obligation.
  	rewrite H. reflexivity.
  Defined.

  Global Instance EmbedILPre : Embed (ILPreFrm ord A) (ILPreFrm ord B).
  Proof.
    split; intros.
    + simpl; intros. apply embed_sound; apply H.
    + split; intros t; simpl; apply embedlforall.
    + split; intros t; simpl; apply embedlexists.
    + split; intros t; simpl;
      do 2 setoid_rewrite <- embedlforall;
      apply lforallR; intro t'; apply lforallR; intro H;
      apply lforallL with t'; apply lforallL with H; apply embedImpl.
  Qed.

End Embed_ILogic_Pre.

(** If [Frm] is a ILogic, then the function space [T -> Frm] is also an ilogic,
    for any type [T]. All connectives are just pointwise liftings. *)

Section ILogic_Fun.
  Context (T: Type).
  Context {A : Type} `{IL: ILogic A}.

  Global Program Instance ILFun_Ops : ILogicOps ((fun x y => x -> y) T A) := {|
    lentails P Q := forall t:T, P t |-- Q t;
    ltrue        := fun t => ltrue;
    lfalse       := fun t => lfalse;
    limpl    P Q := fun t => P t -->> Q t;
    land     P Q := fun t => P t //\\ Q t;
    lor      P Q := fun t => P t \\// Q t;
    lforall  A P := fun t => Forall a, P a t;
    lexists  A P := fun t => Exists a, P a t
  |}.

  Program Definition ILFun_ILogic : @ILogic _ ILFun_Ops.
  Proof.
    split; unfold lentails; simpl; intros.
    - split; red; [reflexivity|].
      intros P Q R HPQ HQR t. transitivity (Q t); [apply HPQ | apply HQR].
    - apply ltrueR.
    - apply lfalseL.
    - apply lforallL with x; apply H.
    - apply lforallR; intros; apply H.
    - apply lexistsL; intros; apply H.
    - apply lexistsR with x; apply H.
    - apply landL1; intuition.
    - apply landL2; intuition.
    - apply lorR1; intuition.
    - apply lorR2; intuition.
    - apply landR; intuition.
    - apply lorL; intuition.
    - apply landAdj; intuition.
    - apply limplAdj; intuition.
  Qed.

  Global Existing Instance ILFun_ILogic.

End ILogic_Fun.

Section ILogic_Option.
  Context {A : Type} `{IL: ILogic A}.

  Definition toProp (P : option A) :=
    match P with
    | Some P => P
    | None => lfalse
    end.

  Global Program Instance ILOption_Ops : ILogicOps (option A) :=
  {| lentails P Q := toProp P |-- toProp Q
   ; ltrue        := Some ltrue
   ; lfalse       := Some lfalse
   ; limpl    P Q := Some (toProp P -->> toProp Q)
   ; land     P Q := Some (toProp P //\\ toProp Q)
   ; lor      P Q := Some (toProp P \\// toProp Q)
   ; lforall  A P := Some (Forall a, toProp (P a))
   ; lexists  A P := Some (Exists a, toProp (P a))
   |}.

  Program Definition ILOption_ILogic : ILogic (option A).
  Proof.
    split; unfold lentails; simpl; intros.
    - split; red; [reflexivity|].
      intros P Q R HPQ HQR. transitivity (toProp Q); [apply HPQ | apply HQR].
    - apply ltrueR.
    - apply lfalseL.
    - apply lforallL with x; apply H.
    - apply lforallR; intros; apply H.
    - apply lexistsL; intros; apply H.
    - apply lexistsR with x; apply H.
    - apply landL1; intuition.
    - apply landL2; intuition.
    - apply lorR1; intuition.
    - apply lorR2; intuition.
    - apply landR; intuition.
    - apply lorL; intuition.
    - apply landAdj; intuition.
    - apply limplAdj; intuition.
  Qed.

End ILogic_Option.

Section Embed_ILogic_Fun.
  Context {A : Type} `{ILA: ILogic A}.
  Context {B : Type} `{ILB: ILogic B}.
  Context {HEmbOp : EmbedOp A B} {HEmb : Embed A B}.

  Program Instance EmbedILFunDropOp {T} : EmbedOp A (T -> B) :=
  { embed := fun a t => embed a }.

  Local Existing Instance ILFun_Ops.

  Instance EmbedILFunDrop {T} : Embed A (T -> B).
  Proof.
    split; intros.
    + simpl; intros. apply embed_sound; assumption.
    + split; intros t; simpl; apply embedlforall.
    + split; intros t; simpl; apply embedlexists.
    + split; intros t; simpl; apply embedImpl.
  Qed.

  Program Instance EmbedILFunOp {T} : EmbedOp (T -> A) (T -> B) :=
  { embed := fun a x => embed (a x) }.

  Instance EmbedILFun {T} : Embed (T -> A) (T -> B).
  Proof.
    split; intros.
    + simpl; intros. apply embed_sound; apply H.
    + split; intros t; simpl; apply embedlforall.
    + split; intros t; simpl; apply embedlexists.
    + split; intros t; simpl; apply embedImpl.
  Qed.

End Embed_ILogic_Fun.
(*
Section ILogicFunInv.

	Context {A B} `{IL : ILogic (A -> B)}.

  Program Definition ILFun_Ops : ILogicOps (T -> A) := {|
    lentails P Q := forall t:T, P t |-- Q t;
    ltrue        := fun t => ltrue;
    lfalse       := fun t => lfalse;
    limpl    P Q := fun t => P t -->> Q t;
    land     P Q := fun t => P t //\\ Q t;
    lor      P Q := fun t => P t \\// Q t;
    lforall  A P := fun t => Forall a, P a t;
    lexists  A P := fun t => Exists a, P a t
  |}.

End ILogicFunInv.
*)
Global Opaque ILOption_Ops.
Global Opaque ILFun_Ops.
Global Opaque ILPre_Ops.


From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude.
From VLSM.Lib Require Import ListExtras.
From VLSM.Core Require Import VLSM VLSMProjections Validator Composition.

(** * State-annotated VLSMs

  This module describes the VLSM obtained by augmenting the states of an existing
  VLSM with annotations and providing additional validity constraints taking into
  account the annotations, and a function for updating the annotations following a
  transition.
*)

Section sec_annotated_vlsm.

Context
  {message : Type}
  (X : VLSM message)
  (annotation : Type)
  .

Record annotated_state : Type :=
{
  original_state : vstate X;
  state_annotation : annotation;
}.

Definition annotated_type : VLSMType message :=
  {| label := vlabel X;
     state := annotated_state
  |}.

Context
  (initial_annotation_prop : annotation -> Prop)
  `{Inhabited (sig initial_annotation_prop)}
  .

Definition annotated_initial_state_prop (sa : annotated_state) : Prop :=
  vinitial_state_prop X (original_state sa) /\ initial_annotation_prop (state_annotation sa).

#[export] Program Instance annotated_initial_state_prop_inhabited :
  Inhabited {sa : annotated_state | annotated_initial_state_prop sa} :=
    populate (exist _ {| original_state := `(vs0 X); state_annotation := `inhabitant; |} _).
Next Obligation.
Proof.
  split; cbn.
  - by destruct (vs0 X).
  - by destruct inhabitant.
Qed.

Context
  (annotated_constraint :
    @label _ annotated_type -> annotated_state * option message -> Prop)
  (annotated_transition_state :
    @label _ annotated_type -> annotated_state * option message -> annotation)
  .

Definition annotated_valid
  (l : @label _ annotated_type)
  (som : annotated_state * option message)
  : Prop :=
  vvalid X l (original_state som.1, som.2) /\
  annotated_constraint l som.

Definition annotated_transition
  (l : @label _ annotated_type)
  (som : annotated_state * option message)
  : annotated_state * option message :=
  let (s', om') := vtransition X l (original_state som.1, som.2) in
  ({| original_state := s'; state_annotation := annotated_transition_state l som |}, om').

Definition annotated_vlsm_machine : VLSMMachine annotated_type :=
  {| initial_state_prop := fun s : @state _ annotated_type => annotated_initial_state_prop s
  ; initial_message_prop := fun m : message => vinitial_message_prop X m
  ; valid := annotated_valid
  ; transition := annotated_transition
  |}.

Definition annotated_vlsm : VLSM message := mk_vlsm annotated_vlsm_machine.

Definition annotate_trace_item
  (item : vtransition_item X)
  (k : annotated_state -> list (@transition_item _ annotated_type))
  (sa : annotated_state)
  : list (@transition_item _ annotated_type) :=
    let sa' :=
      {|
        original_state := destination item;
        state_annotation := annotated_transition_state (l item) (sa, input item);
      |}
    in
      @Build_transition_item _ annotated_type (l item) (input item) sa' (output item) :: k sa'.

Lemma annotate_trace_item_project
  (item : vtransition_item X)
  (k : annotated_state -> list (@transition_item _ annotated_type))
  (sa : annotated_state)
  : pre_VLSM_embedding_finite_trace_project
      annotated_type (type X) id original_state
      (annotate_trace_item item k sa)
      = item ::
        pre_VLSM_embedding_finite_trace_project
            annotated_type (type X) id original_state
            (k {| original_state := destination item;
                  state_annotation := annotated_transition_state (l item) (sa, input item) |}).
Proof.
  by destruct item.
Qed.

Definition annotate_trace_from (sa : @state _ annotated_type) (tr : list (vtransition_item X))
  : list (@transition_item _ annotated_type) :=
  fold_right annotate_trace_item (fun sa => []) tr sa.

Lemma annotate_trace_from_unroll sa item tr
  : annotate_trace_from sa (item :: tr) =
    let sa' :=
      {|
        original_state := destination item;
        state_annotation := annotated_transition_state (l item) (sa, input item)
      |}
    in
      @Build_transition_item _ annotated_type (l item) (input item) sa' (output item)
        ::
      annotate_trace_from sa' tr.
Proof.
  by destruct item.
Qed.

Lemma annotate_trace_from_app sa tr1 tr2
  : annotate_trace_from sa (tr1 ++ tr2) =
    annotate_trace_from sa tr1 ++
      annotate_trace_from (finite_trace_last sa (annotate_trace_from sa tr1)) tr2.
Proof.
  revert sa.
  induction tr1 as [| item tr1]; [done |].
  by intro sa; rewrite <- app_comm_cons, !annotate_trace_from_unroll
  ; simpl; rewrite IHtr1, finite_trace_last_cons.
Qed.

Lemma annotate_trace_from_last_original_state sa sa' tr
  : original_state (finite_trace_last sa (annotate_trace_from sa' tr)) =
    finite_trace_last (original_state sa) tr.
Proof.
  destruct_list_last tr tr' item Heqtr; subst; [done |].
  rewrite annotate_trace_from_app.
  cbn; unfold annotate_trace_item.
  by rewrite! finite_trace_last_is_last.
Qed.

Definition annotate_trace (s : vstate X) (tr : list (vtransition_item X))
  : list (@transition_item _ annotated_type) :=
  annotate_trace_from {| original_state := s; state_annotation := ` inhabitant |} tr.

Lemma annotate_trace_last_original_state s s' tr
  : original_state (finite_trace_last s (annotate_trace s' tr)) =
    finite_trace_last (original_state s) tr.
Proof. by apply annotate_trace_from_last_original_state. Qed.

Lemma annotate_trace_project is tr
  : pre_VLSM_embedding_finite_trace_project
      annotated_type (type X) id original_state
      (annotate_trace is tr)
      = tr.
Proof.
  unfold annotate_trace
  ; remember {| original_state := is |} as sa; clear Heqsa; revert sa.
  induction tr as [| item]; [done | intro sa].
  setoid_rewrite annotate_trace_item_project; f_equal.
  by apply IHtr.
Qed.

End sec_annotated_vlsm.

Arguments original_state {_ _ _} _ : assert.
Arguments state_annotation {_ _ _} _ : assert.

Section sec_annotated_vlsm_projections.

Context
  {message : Type}
  (X : VLSM message)
  {annotation : Type}
  (initial_annotation_prop : annotation -> Prop)
  `{Inhabited (sig initial_annotation_prop)}
  (annotated_constraint :
    @label _ (annotated_type X annotation) ->
      annotated_state X annotation  * option message -> Prop)
  (annotated_transition_state :
    @label _ (annotated_type X annotation) ->
      annotated_state X annotation * option message -> annotation)
  (AnnotatedX : VLSM message :=
    annotated_vlsm X annotation initial_annotation_prop annotated_constraint
      annotated_transition_state)
  .

Definition forget_annotations_projection
  : VLSM_embedding AnnotatedX X id original_state.
Proof.
  apply basic_VLSM_strong_embedding; cycle 1; [| by cbv; itauto..].
  intros l [s a] om [s' a'] om'.
  cbn; unfold annotated_transition; cbn
  ; destruct (vtransition _ _ _) as (_s', _om').
  by inversion 1.
Qed.

End sec_annotated_vlsm_projections.

Section sec_composite_annotated_vlsm_projections.

(** ** Specializing [projection_validator_prop]erties to annotated compositions. *)

Context
  {message : Type}
  `{EqDecision index}
  (IM : index -> VLSM message)
  (Free := free_composite_vlsm IM)
  {annotation : Type}
  (initial_annotation_prop : annotation -> Prop)
  `{Inhabited (sig initial_annotation_prop)}
  (annotated_constraint :
    @label _ (annotated_type Free annotation) ->
      annotated_state Free annotation  * option message -> Prop)
  (annotated_transition_state :
    @label _ (annotated_type Free annotation) ->
      annotated_state Free annotation * option message -> annotation)
  (AnnotatedFree : VLSM message :=
    annotated_vlsm Free annotation initial_annotation_prop annotated_constraint
      annotated_transition_state)
  (i : index)
  .

Definition annotated_composite_label_project : vlabel AnnotatedFree -> option (vlabel (IM i))
  := composite_project_label IM i.

Definition annotated_composite_state_project : vstate AnnotatedFree -> vstate (IM i)
  := fun s => original_state s i.

Definition annotated_projection_validator_prop : Prop :=
  @projection_validator_prop _ AnnotatedFree (IM i)
    annotated_composite_label_project annotated_composite_state_project.

Definition annotated_message_validator_prop : Prop :=
  @message_validator_prop _ AnnotatedFree (IM i).

Definition annotated_composite_label_lift : vlabel (IM i) -> vlabel AnnotatedFree
  := lift_to_composite_label IM i.

Definition annotated_composite_state_lift : vstate (IM i) -> vstate AnnotatedFree
  := fun si =>
     @Build_annotated_state _ (free_composite_vlsm IM) _
      (lift_to_composite_state' IM i si) (` inhabitant).

Definition annotated_projection_validator_prop_alt : Prop :=
  @projection_validator_prop_alt _ AnnotatedFree (IM i)
    annotated_composite_label_project annotated_composite_state_project
    annotated_composite_label_lift annotated_composite_state_lift.

Lemma annotated_composite_preloaded_projection
  : VLSM_projection AnnotatedFree (pre_loaded_with_all_messages_vlsm (IM i))
    annotated_composite_label_project annotated_composite_state_project.
Proof.
  apply basic_VLSM_projection.
  - intros [_i _li] li.
    unfold annotated_composite_label_project, composite_project_label; cbn.
    case_decide; [| congruence].
    subst _i; cbn; inversion_clear 1.
    by intros (s, ann) om (_ & _ & [Hv _] & _) _ _.
  - intros [_i _li] li.
    unfold annotated_composite_label_project, composite_project_label; cbn.
    case_decide; [| congruence].
    subst _i; cbn; inversion_clear 1.
    intros [s ann] iom [s' ann'] oom.
    unfold input_valid_transition; cbn
    ; unfold annotated_transition; cbn
    ; destruct (vtransition _ _ _) as (si', om').
    intros [_ Ht]; inversion Ht.
    by state_update_simpl.
  - intros [j lj].
    unfold annotated_composite_label_project, composite_project_label; cbn.
    case_decide as Hij; [by congruence |].
    intros _ [s ann] iom [s' ann'] oom.
    unfold input_valid_transition; cbn
    ; unfold annotated_transition; cbn
    ; destruct (vtransition _ _ _) as (si', om').
    intros [_ Ht]; inversion Ht.
    by state_update_simpl.
  - by intros [s ann] [Hs _]; cbn; apply Hs.
  - by intro; intros; apply any_message_is_valid_in_preloaded.
Qed.

Definition annotated_composite_induced_validator : VLSM message
  := projection_induced_validator AnnotatedFree (type (IM i))
    annotated_composite_label_project annotated_composite_state_project
    annotated_composite_label_lift annotated_composite_state_lift.

Lemma annotated_composite_induced_validator_transition_None :
  weak_projection_transition_consistency_None _ _ annotated_composite_label_project
    annotated_composite_state_project.
Proof.
  intros [j lj].
  unfold annotated_composite_label_project, composite_project_label; cbn.
  case_decide as Hij; [by congruence |].
  intros _ sX omX s'X om'X [_ Ht]; revert Ht; cbn.
  unfold annotated_transition; cbn
  ; destruct (vtransition _ _ _) as (si', om')
  ; inversion 1; clear Ht; subst om' s'X; cbn.
  by state_update_simpl.
Qed.

Lemma annotated_composite_induced_validator_label_lift
  : induced_validator_label_lift_prop annotated_composite_label_project annotated_composite_label_lift.
Proof. by apply component_label_projection_lift. Qed.

Lemma annotated_composite_induced_validator_state_lift
  : induced_validator_state_lift_prop annotated_composite_state_project annotated_composite_state_lift.
Proof. by intros si; apply state_update_eq. Qed.

Lemma annotated_composite_induced_validator_initial_lift
  : strong_projection_initial_state_preservation (IM i) AnnotatedFree
    annotated_composite_state_lift.
Proof.
  split; cbn.
  - by apply composite_initial_state_prop_lift.
  - by destruct inhabitant.
Qed.

Lemma annotated_composite_induced_validator_transition_consistency
  : induced_validator_transition_consistency_Some _ _
    annotated_composite_label_project annotated_composite_state_project.
Proof.
  intros [i1 li1] [i2 li2] li.
  unfold annotated_composite_label_project, composite_project_label; cbn.
  case_decide as Hi1; [| by congruence].
  subst i1; cbn; inversion_clear 1.
  case_decide as Hi2; [| by congruence].
  subst i2; cbn; inversion_clear 1.
  intros [s1 ann1] [s2 ann2]
  ; unfold annotated_transition; cbn
  ; intros <- iom sX1' oom1
  ; destruct (vtransition _ _ _) as (si', om').
  inversion_clear 1; intros sX2' oom2; inversion_clear 1.
  by cbn; state_update_simpl.
Qed.

Definition annotated_composite_induced_validator_is_projection :=
  projection_induced_validator_is_projection _ _ _ _ _ _
    annotated_composite_induced_validator_label_lift
    annotated_composite_induced_validator_state_lift
    annotated_composite_induced_validator_transition_consistency
    annotated_composite_induced_validator_transition_None.

Lemma annotated_projection_validator_prop_alt_iff
  : annotated_projection_validator_prop_alt <-> annotated_projection_validator_prop.
Proof.
  apply projection_validator_prop_alt_iff.
  - by apply annotated_composite_induced_validator_transition_None.
  - by apply annotated_composite_induced_validator_label_lift.
  - by apply annotated_composite_induced_validator_state_lift.
  - by apply annotated_composite_induced_validator_initial_lift.
  - by apply annotated_composite_induced_validator_transition_consistency.
  - by apply annotated_composite_preloaded_projection.
Qed.

End sec_composite_annotated_vlsm_projections.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Theory.Adjunction.
Require Import Category.Adjunction.Natural.Transformation.
Require Import Category.Construction.Product.
Require Import Category.Construction.Opposite.
Require Import Category.Functor.Hom.
Require Import Category.Functor.Construction.Product.
Require Import Category.Functor.Opposite.
Require Import Category.Instance.Fun.
Require Import Category.Instance.Sets.

Generalizable All Variables.

Section AdjunctionHom.

Context {C : Category}.
Context {D : Category}.
Context {F : D ⟶ C}.
Context {U : C ⟶ D}.

(* Wikipedia: "A hom-set adjunction between two categories C and D consists of
   two functors F : C ← D and G : C → D and a natural isomorphism

     Φ : homC(F −, −) → homD(−, G −).

   "This specifies a family of bijections

     Φy,x : homC(F y, x) → homD(y, G x)

   for all objects x in C and y in D.

   "In this situation we say that F is left adjoint to G and G is right
   adjoint to F, and may indicate this relationship by writing Φ : F ⊣ G, or
   simply F ⊣ G.

   "This definition is a logical compromise in that it is somewhat more
   difficult to satisfy than the universal morphism definitions [see
   Category.Theory.Adjunction], and has fewer immediate implications than the
   counit-unit definition [see Category.Adjunction.Natural.Transformation]. It
   is useful because of its obvious symmetry, and as a stepping-stone between
   the other definitions.

   "In order to interpret Φ as a natural isomorphism, one must recognize
   homC(F –, –) and homD(–, G –) as functors. In fact, they are both
   bifunctors from D^op × C to Set (the category of sets)." *)

Class Adjunction_Hom := {
  hom_adj : Hom C ◯ F^op ∏⟶ Id ≅[[D^op ∏ C, Sets]] Hom D ◯ Id^op ∏⟶ U
}.

Context `{Adjunction_Hom}.

Program Definition hom_unit : Id ⟹ U ◯ F := {|
  transform := fun x => @morphism _ _ _ _ (to hom_adj (x, F x)) id
|}.
Next Obligation.
  spose (naturality[to hom_adj] (x, F x) (x, F y) (id, fmap[F] f) id) as X.
  rewrite id_right in X.
  rewrites.

  spose (naturality[to hom_adj] (y, F y) (x, F y) (f, id) id) as X.
  rewrite fmap_id, id_left in X.
  rewrites.

  apply proper_morphism; cat.
Qed.
Next Obligation.
  symmetry.
  apply hom_unit_obligation_1.
Qed.

Program Definition hom_counit : F ◯ U ⟹ Id := {|
  transform := fun x => @morphism _ _ _ _ (from hom_adj (U x, x)) id
|}.
Next Obligation.
  spose (naturality[from hom_adj] (U x, x) (U x, y) (id, f) id) as X.
  rewrite fmap_id, id_right in X.
  rewrites.

  spose (naturality[from hom_adj] (U y, y) (U x, y) (fmap[U] f, id) id) as X.
  rewrite id_left in X.
  rewrites.

  apply proper_morphism; cat.
Qed.
Next Obligation.
  symmetry.
  apply hom_counit_obligation_1.
Qed.

Theorem hom_unit_naturality_consequence {x y} (f : F x ~> y) :
  to hom_adj (x, y) f ≈ fmap[U] f ∘ hom_unit _.
Proof.
  unfold hom_unit; simpl.
  spose (naturality[to hom_adj] (x, F x) (x, y) (id, f) id) as X.
  rewrite id_right in X.
  rewrites.
  apply proper_morphism; cat.
Qed.

Theorem hom_counit_naturality_consequence {x y} (f : x ~> U y) :
  from hom_adj (x, y) f ≈ hom_counit _ ∘ fmap[F] f.
Proof.
  unfold hom_counit; simpl.
  spose (naturality[from hom_adj] (U y, y) (x, y) (f, id) id) as X.
  rewrite id_left in X.
  rewrites.
  apply proper_morphism; cat.
Qed.

Theorem hom_counit_fmap_unit {x} :
  hom_counit (F x) ∘ fmap[F] (hom_unit x) ≈ id.
Proof.
  spose (@hom_counit_naturality_consequence x (F x) (hom_unit x)) as X.
  rewrites.
  unfold hom_unit; simpl.
  srewrite (iso_from_to hom_adj (x, F x) id); cat.
Qed.

Theorem hom_fmap_counit_unit {x} :
  fmap[U] (hom_counit x) ∘ hom_unit (U x) ≈ id.
Proof.
  spose (@hom_unit_naturality_consequence (U x) x (hom_counit x)) as X.
  rewrites.
  unfold hom_unit; simpl.
  srewrite (iso_to_from hom_adj (U x, x) id); cat.
Qed.

Program Definition Adjunction_Hom_to_Transform : F ∹ U := {|
  unit   := hom_unit;
  counit := hom_counit;
  counit_fmap_unit := @hom_counit_fmap_unit;
  fmap_counit_unit := @hom_fmap_counit_unit
|}.

Program Definition Adjunction_Transform_to_Hom (A : F ∹ U) : Adjunction_Hom := {|
  hom_adj :=
    {| to   := {| transform := fun _ =>
        {| morphism := fun f => fmap[U] f ∘ unit _ |} |}
     ; from := {| transform := fun _ =>
        {| morphism := fun f => counit _ ∘ fmap[F] f |} |} |}
|}.
Next Obligation.
  proper; rewrites; reflexivity.
Qed.
Next Obligation.
  simpl.
  rewrite <- !comp_assoc.
  srewrite_r (naturality[unit]).
  rewrite !comp_assoc.
  rewrite <- !fmap_comp.
  reflexivity.
Qed.
Next Obligation.
  simpl.
  rewrite <- !comp_assoc.
  srewrite_r (naturality[unit]).
  rewrite !comp_assoc.
  rewrite <- !fmap_comp.
  reflexivity.
Qed.
Next Obligation.
  proper; rewrites; reflexivity.
Qed.
Next Obligation.
  simpl.
  rewrite !comp_assoc.
  srewrite (naturality[counit]).
  rewrite <- !comp_assoc.
  rewrite <- !fmap_comp.
  reflexivity.
Qed.
Next Obligation.
  simpl.
  rewrite !comp_assoc.
  srewrite (naturality[counit]).
  rewrite <- !comp_assoc.
  rewrite <- !fmap_comp.
  reflexivity.
Qed.
Next Obligation.
  simpl; cat.
  rewrite fmap_comp.
  rewrite <- comp_assoc.
  srewrite (naturality[unit]).
  rewrite comp_assoc.
  srewrite (@fmap_counit_unit _ _ _ _ A); cat.
Qed.
Next Obligation.
  simpl; cat.
  rewrite fmap_comp.
  rewrite comp_assoc.
  srewrite_r (naturality[counit]).
  rewrite <- comp_assoc.
  srewrite (@counit_fmap_unit _ _ _ _ A); cat.
Qed.

Program Definition Adjunction_Hom_to_Universal : F ⊣ U := {|
  adj := fun a b =>
    {| to   := transform (to hom_adj) (a, b)
     ; from := transform (from hom_adj) (a, b) |}
|}.
Next Obligation.
  simpl; srewrite (iso_to_from hom_adj (a, b) x); cat.
Qed.
Next Obligation.
  simpl; srewrite (iso_from_to hom_adj (a, b) x); cat.
Defined.
Next Obligation.
  spose (naturality (to hom_adj) (y, z) (x, z) (g, id) f) as X.
  rewrite fmap_id, id_left in X.
  rewrites.
  apply proper_morphism; cat.
Qed.
Next Obligation.
  spose (naturality (to hom_adj) (x, y) (x, z) (id, f) g) as X.
  rewrite id_right in X.
  rewrites.
  apply proper_morphism; cat.
Qed.
Next Obligation.
  spose (naturality (from hom_adj) (y, z) (x, z) (g, id) f) as X.
  rewrite id_left in X.
  rewrites.
  apply proper_morphism; cat.
Qed.
Next Obligation.
  spose (naturality (from hom_adj) (x, y) (x, z) (id, f) g) as X.
  rewrite fmap_id, id_right in X.
  rewrites.
  apply proper_morphism; cat.
Qed.

Program Definition Adjunction_Universal_to_Hom (A : F ⊣ U) : Adjunction_Hom := {|
  hom_adj :=
    {| to   := {| transform := fun _ =>
        {| morphism := fun f => to adj f |} |}
     ; from := {| transform := fun _ =>
        {| morphism := fun f => from adj f |} |} |}
|}.
Next Obligation.
  proper; rewrites; reflexivity.
Qed.
Next Obligation.
  rewrite <- comp_assoc.
  rewrite to_adj_nat_l.
  rewrite comp_assoc.
  rewrite to_adj_nat_r.
  reflexivity.
Qed.
Next Obligation.
  rewrite <- comp_assoc.
  rewrite to_adj_nat_r.
  rewrite <- comp_assoc.
  rewrite to_adj_nat_l.
  reflexivity.
Qed.
Next Obligation.
  proper; rewrites; reflexivity.
Qed.
Next Obligation.
  rewrite <- comp_assoc.
  rewrite from_adj_nat_l.
  rewrite comp_assoc.
  rewrite from_adj_nat_r.
  reflexivity.
Qed.
Next Obligation.
  rewrite <- comp_assoc.
  rewrite from_adj_nat_r.
  rewrite <- comp_assoc.
  rewrite from_adj_nat_l.
  reflexivity.
Qed.
Next Obligation.
  simpl; cat.
  apply (iso_to_from adj _).
Qed.
Next Obligation.
  simpl; cat.
  apply (iso_from_to adj _).
Qed.

End AdjunctionHom.

Arguments Adjunction_Hom {C D} F%functor U%functor.


Require Import List ListDec Lia PeanoNat Relation_Operators.
Import ListNotations.

Require Import Undecidability.CounterMachines.Util.Facts.
Require Import Undecidability.CounterMachines.CM2.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".
Set Default Proof Using "Type".

Definition path M k x := map (fun n => steps M n x) (seq 0 k).

Lemma Config_eta (x : Config) : x = (state x, (value1 x, value2 x)).
Proof. by move: x => [? [? ?]]. Qed.

Lemma Config_eq_dec (x y : Config) : {x = y} + {x <> y}.
Proof. by do ? decide equality. Qed.

Lemma option_Config_eq_dec (x y : option Config) : {x = y} + {x <> y}.
Proof. by do ? decide equality. Qed.

Definition reaches_plus (M: Cm2) (x y: Config) := exists k, 0 < k /\ steps M k x = Some y.
Definition non_terminating (M: Cm2) (x: Config) := forall k, steps M k x <> None.

Section Facts.
Context {M : Cm2}.

#[local] Notation step := (CM2.step M).
#[local] Notation steps := (CM2.steps M).
#[local] Notation reaches := (CM2.reaches M).
#[local] Notation reaches_plus := (reaches_plus M).
#[local] Notation terminating := (CM2.terminating M).
#[local] Notation non_terminating := (non_terminating M).
#[local] Notation mortal := (CM2.mortal M).
#[local] Notation bounded := (CM2.bounded M).
#[local] Notation path := (path M).

Lemma step_neq x : step x <> Some x.
Proof.
  rewrite /step. case: (nth_error M (state x)); last done.
  move: x => [p [a b]] /=.
  case.
  - move=> ? []. lia.
  - move: a b => [|a] [|b] [] ? []; lia.
Qed.

Lemma steps_k_monotone {k x} k' : steps k x = None -> k <= k' -> steps k' x = None.
Proof.
  move=> + ?. have ->: k' = (k' - k) + k by lia.
  elim: (k' - k); first done.
  by move=> ? IH /IH /= ->.
Qed.

Lemma reaches_refl x : reaches x x.
Proof. by exists 0. Qed.

Lemma step_reaches {x y} : step x = Some y -> reaches x y.
Proof. move=> ?. by exists 1. Qed.

Lemma step_reaches_plus {x y} : step x = Some y -> reaches_plus x y.
Proof. move=> ?. exists 1. split; [lia|done]. Qed.

Lemma steps_plus {k x k' y} :
  steps k x = Some y -> steps (k + k') x = steps k' y.
Proof. rewrite /steps iter_plus. by move=> ->. Qed.

Lemma steps_sub {i j x y z} :
  i <= j ->
  steps i x = Some y ->
  steps j x = Some z ->
  steps (j-i) y = Some z.
Proof.
  move=> ? Hi. rewrite [in steps j x](ltac:(lia) : j = i + (j - i)).
  by rewrite /steps iter_plus -/(steps _ _) Hi.
Qed.

Lemma step_None x : step x = None <-> nth_error M (state x) = None.
Proof.
  rewrite /step. case: (nth_error M (state x)) => [i|]; last done.
  case: i; first done.
  by move: (value1 x) (value2 x) => [|?] [|?] [].
Qed.

Lemma step_None' x : step x = None <-> length M <= state x.
Proof. rewrite step_None. by apply: nth_error_None. Qed.

Lemma reaches_plus_reaches {x y z} : reaches_plus x y -> reaches y z -> reaches_plus x z.
Proof.
  move=> [k [? Hk]] [k' Hk']. exists (k+k'). split; first by lia.
  move: Hk. by rewrite /steps iter_plus => ->.
Qed.

Lemma reaches_reaches_plus {x y z} : reaches x y -> reaches_plus y z -> reaches_plus x z.
Proof.
  move=> [k Hk] [k' [? Hk']]. exists (k+k'). split; first by lia.
  move: Hk. by rewrite /steps iter_plus => ->.
Qed.

Lemma reaches_plus_incl {x y} : reaches_plus x y -> reaches x y.
Proof. move=> [k [? Hk]]. by exists k. Qed.

Lemma reaches_neq_incl {x y} : reaches x y -> x <> y -> reaches_plus x y.
Proof.
  move=> [[|k]]; first by move=> [->].
  move=> ? _. exists (S k). split; [lia|done].
Qed.

Lemma reaches_terminating {x y} : reaches x y -> terminating y -> terminating x.
Proof.
  move=> [k Hk] [k' Hk']. exists (k+k').
  move: Hk. by rewrite /steps iter_plus => ->.
Qed.

Lemma reaches_non_terminating {x y} : reaches x y -> non_terminating y -> non_terminating x.
Proof.
  move=> [k Hk] Hy k'.
  have [|->] : k' <= k \/ k' = k + (k' - k) by lia.
  - by move: Hk => + /steps_k_monotone H /H => ->.
  - rewrite (steps_plus Hk). by apply: Hy.
Qed.

Lemma reaches_non_terminating' {x y} : reaches x y -> non_terminating x -> non_terminating y.
Proof.
  move=> [k' Hk'] Hx k Hk.
  apply: (Hx (k' + k)).
  by rewrite (steps_plus Hk').
Qed.

Lemma reaches_plus_state_bound {x y} : reaches_plus x y -> state x < length M.
Proof.
  move=> [k [? Hk]].
  suff: not (length M <= state x) by lia.
  move=> /nth_error_None Hx.
  move: Hk. have ->: k = S (k - 1) by lia.
  by rewrite /= obind_oiter /step Hx oiter_None.
Qed.

Lemma reaches_plus_trans {x y z} : reaches_plus x y -> reaches_plus y z -> reaches_plus x z.
Proof. by move=> /reaches_plus_incl /reaches_reaches_plus H /H. Qed.

Lemma reaches_trans {x y z} : reaches x y -> reaches y z -> reaches x z.
Proof. move=> [k Hk] [k' Hk']. exists (k+k'). by rewrite (steps_plus Hk). Qed.

Lemma reaches_plus_invariant_loop (P : Config -> Prop) :
  (forall x, P x -> exists y, reaches_plus x y /\ P y) ->
  forall x, P x -> non_terminating x.
Proof.
  move=> H x Hx k. elim: k x Hx; first done.
  move=> k IH x /H [y] [[k' [? Hk']]] /IH Hk.
  move=> /(steps_k_monotone (k' + k)) /(_ ltac:(lia)).
  by rewrite (steps_plus Hk').
Qed.

Corollary reaches_plus_self_loop x : reaches_plus x x -> non_terminating x.
Proof.
  move=> ?. apply: (reaches_plus_invariant_loop (fun y => y = x)); last done.
  move=> y ->. by exists x.
Qed.

Lemma steps_loop_mod {K x k} : steps (S K) x = Some x ->
  steps k x = steps (k mod (S K)) x.
Proof.
  rewrite [in steps k x](Nat.div_mod_eq k (S K)).
  move: (k mod (S K)) => k' Hx. elim: (k / S K).
  - congr steps. lia.
  - move=> n IH. have ->: S K * S n + k' = S K + (S K * n + k') by lia.
    by move: Hx => /steps_plus ->.
Qed.

Lemma step_values_bound x y : step x = Some y ->
  value1 y + value2 y <= 1 + value1 x + value2 x /\
  value1 x + value2 x <= 1 + value1 y + value2 y /\
  value1 x <= 1 + value1 y /\ value1 y <= 1 + value1 x /\
  value2 x <= 1 + value2 y /\ value2 y <= 1 + value2 x.
Proof.
  rewrite /step.
  case: (nth_error M (state x)); last done.
  case.
  - move=> [] [<-] /=; lia.
  - move=> [] ? [<-].
    + case Hx: (value2 x) => [|?] /=; lia.
    + case Hx: (value1 x) => [|?] /=; lia.
Qed.

Lemma steps_values_bound k x y : steps k x = Some y ->
  value1 y + value2 y <= k + value1 x + value2 x /\
  value1 x + value2 x <= k + value1 y + value2 y /\
  value1 x <= k + value1 y /\ value1 y <= k + value1 x /\
  value2 x <= k + value2 y /\ value2 y <= k + value2 x.
Proof.
  elim: k x. { move=> ? [<-]. lia. }
  move=> k IH x. rewrite /= obind_oiter.
  case Hxz: (step x) => [z|]; last by rewrite oiter_None.
  move=> /IH.
  move: Hxz => /step_values_bound. lia.
Qed.

Lemma bounded_monotone {k k' x} : k <= k' -> bounded k x -> bounded k' x.
Proof. move=> ? [L [? ?]]. exists L. split; [lia|done]. Qed.

#[local] Arguments Nat.min !n !m /.

Lemma shift_steps k p a b :
  steps k (p, (a, b)) =
  match steps k (p, (Nat.min k a, Nat.min k b)) with
  | Some (p', (a', b')) => Some (p', (a' + (a - k), b' + (b - k)))
  | None => None
  end.
Proof.
  set x := (p, (a, b)).
  have ->: p = state x by done.
  have ->: a = value1 x by done.
  have ->: b = value2 x by done.
  elim: k (x); clear x p a b.
  { move=> [p [a b]] /=. congr (Some (_, (_, _))); lia. }
  move=> k IH [p [a b]].
  rewrite /steps /= ?obind_oiter /step -/step /=.
  case: (nth_error M p); last by rewrite ?oiter_None.
  case.
  - move=> c. rewrite -?/(steps _ _).
    rewrite [in LHS]IH [in RHS]IH /=.
    set oy1 := (steps k _).
    set oy2 := (steps k _).
    have <- : oy1 = oy2.
    { congr (steps k (_, (_, _))); move: (a) (b) (c) => [|?] [|?] [|] /=; lia. }
    case: (oy1) => [[? [? ?]]|]; last done.
    congr (Some (_, (_, _))); move: (a) (b) (c) => [|?] [|?] [|]; lia.
  - move=> c q. rewrite -?/(steps _ _).
    rewrite [in LHS]IH [in RHS]IH /=.
    set oy1 := (steps k _).
    set oy2 := (steps k _).
    have <- : oy1 = oy2.
    { congr (steps k (_, (_, _))); move: (a) (b) (c) => [|?] [|?] [|] /=; lia. }
    case: (oy1) => [[? [? ?]]|]; last done.
    congr (Some (_, (_, _))); move: (k) (a) (b) (c) => [|?] [|?] [|?] [|] /=; lia.
Qed.

Lemma mortal_K_bound K p a b :
  mortal K (p, (a, b)) <-> mortal K (p, (Nat.min K a, Nat.min K b)).
Proof.
  rewrite /mortal (shift_steps K p a b).
  by case: (steps K (p, (Nat.min K a, Nat.min K b))) => [[? [? ?]]|].
Qed.

(* path notion *)

Lemma path_length {k x} : length (path k x) = k.
Proof. by rewrite /path map_length seq_length. Qed.

Lemma In_pathE K x oy : In oy (path K x) -> exists k, k < K /\ steps k x = oy.
Proof.
  move=> /in_map_iff [k] [<-] /in_seq ?.
  exists k. split; [lia|done].
Qed.

Lemma In_pathI k x K : k < K -> In (steps k x) (path K x).
Proof.
  move=> ?. apply /in_map_iff. exists k. split; first done.
  apply /in_seq. lia.
Qed.

Lemma path_S {k x} y : step x = Some y -> path (S k) x = (Some x) :: (path k y).
Proof.
  move=> Hxy. rewrite /path /= -seq_shift map_map.
  congr cons. apply: map_ext => - ?.
  by rewrite /= obind_oiter Hxy.
Qed.

Lemma path_plus {k k' x} y : steps k x = Some y ->
  path (k+k') x = path k x ++ path k' y.
Proof.
  move=> Hxy. rewrite /path seq_app map_app /=.
  congr app.
  have ->: seq k k' = map (fun i => k+i) (seq 0 k').
  { elim: k'; first done.
    move=> k' IH. have ->: S k' = k' + 1 by lia.
    by rewrite ?seq_app IH map_app. }
  rewrite map_map. apply: map_ext => - ?.
  by move: Hxy => /steps_plus ->.
Qed.

Lemma path_S_last {k x} : path (S k) x = (path k x) ++ [steps k x].
Proof. by rewrite /path seq_S map_app. Qed.

Lemma path_loopE K x : In (steps K x) (path K x) ->
  forall k, In (steps k x) (path K x).
Proof.
  elim: K x; first done.
  move=> K IH x. rewrite [steps _ _]/= obind_oiter.
  case Hxz: (step x) => [z|].
  - move=> H. rewrite (path_S z Hxz) /= in H. case: H.
    + move=> Hzx k. have /steps_loop_mod -> : steps (S K) x = Some x.
      { by rewrite /steps /= obind_oiter Hxz. }
      by apply /In_pathI /(Nat.mod_upper_bound k (S K)).
    + rewrite (path_S z Hxz).
      move=> /IH {}IH [|k]; first by left.
      rewrite /= obind_oiter Hxz. right. by apply: IH.
  - rewrite oiter_None. move=> /in_map_iff [k] [Hk] /in_seq HK.
    move=> k'. have [|Hkk'] : k' < k \/ k <= k' by lia.
    + move=> ?. apply: In_pathI. lia.
    + move: (Hk) => /(steps_k_monotone k') /(_ Hkk') ->.
      rewrite -Hk. apply: In_pathI. lia.
Qed.

Lemma path_loopE' K x : In (steps K x) (path K x) ->
  forall y, reaches x y -> In (Some y) (path K x).
Proof.
  move=> /path_loopE H y [k] H'. move: (H k).
  by congr In.
Qed.

Lemma loop_bounded K x : In (steps K x) (path K x) -> bounded K x.
Proof.
  move=> /path_loopE' H.
  exists (map (fun oy => if oy is Some y then y else x) (path K x)).
  split. { by rewrite map_length path_length. }
  move=> y /H {}H. apply /in_map_iff. by exists (Some y).
Qed.

Lemma path_noloopI k x :
  ~ In (steps k x) (path k x) -> NoDup (path (k + 1) x).
Proof.
  elim: k x.
  { move=> ??. constructor; [done| constructor]. }
  move=> k IH x.
  rewrite path_S_last /steps in_app_iff /= -/(steps k x).
  move=> /Decidable.not_or.
  have [|/IH ?] := In_dec option_Config_eq_dec (steps k x) (path k x).
  - move=> /path_loopE /(_ (S k)). tauto.
  - move=> [?] ?.
    apply /(NoDup_Add (a := steps (S k) x) (l := path (k + 1) x)).
    + rewrite path_S_last.
      have := Add_app (steps (k + 1) x) (path (k + 1) x) [].
      congr Add.
      * congr steps. lia.
      * by rewrite app_nil_r.
    + constructor; first done.
      have ->: k + 1 = S k by lia.
      rewrite path_S_last in_app_iff /=. tauto.
Qed.

Lemma mortal_bounded {K x} : steps K x = None -> bounded K x.
Proof.
  move=> HK.
  exists (map (fun oy => if oy is Some y then y else x) (path K x)).
  split. { by rewrite map_length path_length. }
  move=> y [k]. have [?|?] : k < K \/ K <= k by lia.
  - move=> Hk. apply /in_map_iff. exists (Some y).
    split; first done.
    rewrite -Hk. by apply: In_pathI.
  - by move: HK => /(steps_k_monotone k) /(_ ltac:(lia)) ->.
Qed.

Lemma In_None_pathE k x :
  In None (path k x) -> steps k x = None.
Proof.
  move=> /In_pathE [k' [?]] /(steps_k_monotone k). apply. lia.
Qed.

Lemma NoDup_not_bounded {K x y} :
  steps K x = Some y -> NoDup (path (K + 1) x) -> not (bounded K x).
Proof.
  move=> Hxy HK [L [? HL]].
  apply: (pigeonhole (path (K+1) x) (map Some L)).
  - move=> [z|] /in_map_iff [k] [Hk] /in_seq ?.
    { apply /in_map_iff. exists z. split; first done.
      apply: HL. by exists k. }
    by move: Hk Hxy => /(steps_k_monotone K) /(_ ltac:(lia)) ->.
  - rewrite map_length path_length. lia.
  - done.
Qed.

Lemma boundedE {K x} : bounded K x ->
  (In (steps K x) (path K x)) + (steps K x = None).
Proof.
  move=> HK.
  case Hy: (steps K x) => [y|]; last by right.
  have [?|] := In_dec option_Config_eq_dec (Some y) (path K x).
  { by left. }
  rewrite -Hy. move=> /path_noloopI /NoDup_not_bounded.
  by move=> /(_ y Hy HK).
Qed.

Lemma reaches_bounded {K k x y} : steps k x = Some y -> bounded K y -> bounded (k+K) x.
Proof.
  move=> Hxy /boundedE [HK|HK].
  - apply: loop_bounded.
    move: Hxy (Hxy) => /path_plus -> /steps_plus ->.
    apply /in_app_iff. by right.
  - apply: mortal_bounded.
    by move: Hxy => /steps_plus ->.
Qed.

Lemma bounded_mortal_bound {K k x} : bounded K x -> mortal k x -> mortal K x.
Proof.
  rewrite /mortal => /boundedE + Hk.
  case; last done.
  move=> /path_loopE /(_ k).
  by rewrite Hk => /In_None_pathE.
Qed.

End Facts.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool ssrnat eqtype.
Require Import ZArith.

(* We axiomatize a random number generator
   (currently written in OCaml only) *)
Axiom RandomSeed : Type.
Axiom randomSeed_inhabited : inhabited RandomSeed.

Axiom randomNext     : RandomSeed -> Z * RandomSeed.
Axiom randomGenRange : RandomSeed -> Z * Z.
Axiom mkRandomSeed   : Z          -> RandomSeed.
Axiom newRandomSeed  : RandomSeed.

(* begin randomSplitAssumption *)
Axiom randomSplit : RandomSeed -> RandomSeed * RandomSeed.
Axiom randomSplitAssumption :
  forall s1 s2 : RandomSeed, exists s, randomSplit s = (s1,s2).
(* end randomSplitAssumption *)

CoInductive RandomSeedTree :=
| RstNode : RandomSeed -> RandomSeedTree -> RandomSeedTree -> RandomSeedTree.

Definition root_rst (rst : RandomSeedTree) : RandomSeed :=
  match rst with
  | RstNode root _ _ => root
  end.

Definition left_rst (rst : RandomSeedTree) : RandomSeedTree :=
  match rst with
  | RstNode _ t1 _ => t1
  end.

Definition right_rst (rst : RandomSeedTree) : RandomSeedTree :=
  match rst with
  | RstNode _ _ t2 => t2
  end.

Lemma rst_eta : forall rst : RandomSeedTree,
  rst = RstNode (root_rst rst) (left_rst rst) (right_rst rst).
Proof. destruct rst. reflexivity. Qed.

CoFixpoint mkSeedTree (s : RandomSeed) : RandomSeedTree :=
  let (s1, s2) := randomSplit s in
  RstNode s (mkSeedTree s1) (mkSeedTree s2).

Lemma mkSeedTreeHelper r :
  mkSeedTree r = RstNode r (mkSeedTree (randomSplit r).1) (mkSeedTree (randomSplit r).2).
Proof. by rewrite [mkSeedTree _]rst_eta /=; case: (randomSplit r). Qed.

Inductive SplitDirection := Left | Right.

Definition SplitPath := list SplitDirection.

Require Import List. Import ListNotations.
Fixpoint varySeedAux (p : SplitPath) (rst : RandomSeedTree) : RandomSeed :=
  let '(RstNode s t1 t2) := rst in
  match p with
    | [] => s
    | Left  :: p' => varySeedAux p' t1
    | Right :: p' => varySeedAux p' t2
  end.

Definition varySeed (p : SplitPath) (s : RandomSeed) : RandomSeed :=
  varySeedAux p (mkSeedTree s).

Inductive SeedTree :=
| SeedTreeUndef : SeedTree
| SeedTreeLeaf : RandomSeed -> SeedTree
| SeedTreeNode : SeedTree -> SeedTree -> SeedTree.

Inductive SubSeedTree : SeedTree -> RandomSeedTree -> Prop :=
| SubUndef : forall (rst : RandomSeedTree), SubSeedTree SeedTreeUndef rst
| SubLeaf  : forall (s : RandomSeed) (rst1 rst2 : RandomSeedTree),
               SubSeedTree (SeedTreeLeaf s) (RstNode s rst1 rst2)
| SubNode  : forall (st1 st2 : SeedTree) (rst1 rst2 : RandomSeedTree) (s : RandomSeed),
               SubSeedTree st1 rst1 ->
               SubSeedTree st2 rst2 ->
               SubSeedTree (SeedTreeNode st1 st2) (RstNode s rst1 rst2).

Fixpoint varySeed' (st : SeedTree) (p : SplitPath) : option RandomSeed :=
  match st with
    | SeedTreeUndef => None
    | SeedTreeLeaf s =>
      match p with
        | [] => Some s
        | _  => None
      end
    | SeedTreeNode st1 st2 =>
      match p with
        | [] => None
        | Left  :: p' => varySeed' st1 p'
        | Right :: p' => varySeed' st2 p'
      end
  end.

Lemma pathAgreesOnSubTree : forall (st : SeedTree) (rst : RandomSeedTree) (p : SplitPath)
                                   (s : RandomSeed),
                              SubSeedTree st rst ->
                              varySeed' st p = Some s ->
                              varySeedAux p rst = s.
Proof.
induction st.
+ intros. simpl in H0. congruence.
+ intros. simpl in H0.
  destruct p eqn:P.
  - inversion H. simpl. inversion H0. reflexivity.
  - inversion H0.
+ intros. simpl in H0.
  destruct p eqn:P.
  - inversion H0.
  - inversion H; subst.
    destruct s0 eqn:S0.
    * simpl. apply IHst1; auto.
    * simpl. apply IHst2; auto.
Qed.

Lemma splitExpand st : exists s, SubSeedTree st (mkSeedTree s).
Proof.
elim: st => [|r|st1 [s1 st_s1] st2 [s2 st_s2]].
+ by case: randomSeed_inhabited=> seed; exists seed; apply: SubUndef.
+ by exists r; rewrite mkSeedTreeHelper; constructor.
have [s eq_s] := randomSplitAssumption s1 s2.
by exists s; rewrite mkSeedTreeHelper eq_s; constructor.
Qed.

Inductive PrefixFree : list SplitPath -> Prop :=
| FreeNil : PrefixFree []
| FreeCons : forall (p : SplitPath) (l : list SplitPath),
               PrefixFree l ->
               (forall (p' : SplitPath), In p' l ->
                                        (forall p1 p2, p' ++ p1 = p ++ p2-> False)) ->
                                        PrefixFree (p :: l).

Lemma prefixFreeSingleton : forall p, PrefixFree [p].
intro.
apply FreeCons.
+ apply FreeNil.
+ intros. inversion H.
Qed.

Lemma prefixFreeEmpty : forall l, PrefixFree ([] :: l) -> l = [].
intros.
destruct l; auto.
inversion H.
subst.
pose proof H3 l.
assert (In l (l :: l0)) by (left; auto).
eapply H0 in H1. inversion H1.
instantiate (2 := []). rewrite app_nil_r; simpl; eauto.
Qed.

Inductive correspondingSeedTree (l : list SplitPath) (f : SplitPath -> RandomSeed)
          (st : SeedTree) : Prop :=
| Corresponding : (forall (p : SplitPath) s, varySeed' st p = Some s -> In p l) ->
                  (forall (p : SplitPath), In p l -> varySeed' st p = Some (f p)) ->
                  PrefixFree l ->
                  correspondingSeedTree l f st.

Lemma corrEmptyUndef : forall f, correspondingSeedTree [] f SeedTreeUndef.
  intro f.
  apply Corresponding.
  + intros p s Contra.
    inversion Contra.
  + intros p InNil. inversion InNil.
  + apply FreeNil.
Qed.

Ltac fireInLeft name :=
  match goal with
    | [H : In ?X (?X :: ?XS) -> _ |- _ ] =>
      assert (In X (X :: XS)) as name by (left; auto); apply H in name; clear H
  end.

Lemma corrUndefEmpty : forall l f, correspondingSeedTree l f SeedTreeUndef -> l = [].
intros l f Corr.
inversion Corr as [Vary_In In_Vary Pref]; clear Corr.
destruct l as [ | p ps]; auto.
clear Vary_In Pref.
pose proof (In_Vary p) as Contra; clear In_Vary.
fireInLeft Hyp.
inversion Hyp.
Qed.

Lemma PrefixFreeWithNil : forall l, PrefixFree ([] :: l) -> l = [].
  intros.
  inversion H; subst.
  destruct l eqn:L; auto.
  pose proof (H3 l0).
  assert (In l0 (l0 :: l1)) by (left; auto).
  eapply H0 in H1.
  + inversion H1.
  + instantiate (1 := l0). instantiate (1 := []). rewrite app_nil_r. auto.
Qed.

Lemma corrEmptyLeaf : forall s l f, correspondingSeedTree l f (SeedTreeLeaf s) ->
                                    l = [[]] /\ s = f [].
  intros s l f Corr.
  inversion Corr as [Vary_In In_Vary Pref]; clear Corr.
  pose proof (Vary_In [] s) as Hyp; clear Vary_In.
  simpl in Hyp.
  assert (InNilL : In [] l) by (apply Hyp; auto); clear Hyp.
  split.
  + destruct l eqn:L.
    - inversion InNilL.
    - destruct s0 eqn : S0.
      * apply PrefixFreeWithNil in Pref; subst; auto.
      * pose proof (In_Vary (s1 :: s2)) as Hyp; clear In_Vary.

  + inversion Pref.
    fireInLeft Hyp'. simpl in Hyp'. inversion Hyp'.

  + pose proof In_Vary [] as Hyp; clear In_Vary.
    apply Hyp in InNilL; clear Hyp.
    simpl in *.
    congruence.
Qed.

Lemma corrNodeNonEmpty : forall st1 st2 l p f,
                           correspondingSeedTree l f (SeedTreeNode st1 st2) ->
                           In p l -> p <> [].
unfold not; intros st1 st2 l p f Corr InPL PNil; subst.
inversion Corr as [_ In_Vary _]; clear Corr.
pose proof (In_Vary []) as Hyp; clear In_Vary.
apply Hyp in InPL; clear Hyp.
simpl in InPL.
inversion InPL.
Qed.

Hint Resolve corrEmptyUndef.
Hint Resolve corrNodeNonEmpty.
Definition Direction_eq_dec : forall (d1 d2 : SplitDirection),
                                {d1 = d2} + {d1 <> d2}.
decide equality.
Qed.

Definition eq_dir_b (d1 d2 : SplitDirection) : bool :=
  match d1,d2 with
    | Left, Left => true
    | Right, Right => true
    | _, _ => false
  end.

Lemma eq_dir_b_eq : forall d1 d2, eq_dir_b d1 d2 = true <-> d1 = d2.
intros.
unfold eq_dir_b.
destruct d1; destruct d2; split; auto; intro Contra; inversion Contra.
Qed.

Definition refineList (d : SplitDirection) (l : list SplitPath) : list SplitPath :=
  map (@tl SplitDirection) (filter (fun p => match hd_error p with
                             | Some d' => eq_dir_b d d'
                             | _       => false
                           end) l).

Lemma refineCorrect : forall d l p, In p (refineList d l) -> In (d :: p) l.
intros d l p.
unfold refineList.
rewrite in_map_iff.
intros.
inversion H; clear H.
inversion H0; clear H0.
generalize H1; clear H1.
rewrite filter_In.
intros.
inversion H0; clear H0.
unfold tl in H.
destruct x eqn:X.
+ simpl in H2. inversion H2.
+ simpl in H2. apply eq_dir_b_eq in H2. subst. auto.
Qed.

Lemma refineCorrect' : forall d l p, In (d :: p) l -> In p (refineList d l).
intros.
unfold refineList.
apply in_map_iff.
exists (d :: p).
split; auto.
apply filter_In.
split; simpl; auto.
unfold eq_dir_b; destruct d; auto.
Qed.

Lemma refinePreservesPrefixFree : forall d l, PrefixFree l -> PrefixFree (refineList d l).
  intros.
  induction l.
  - unfold refineList; constructor.
  - destruct a eqn:A; subst.
    * apply prefixFreeEmpty in H. subst. unfold refineList. simpl. constructor.
    * destruct s eqn:S; destruct d; subst.
      + unfold refineList; simpl.
        eapply FreeCons.
        - apply IHl. inversion H; auto.
        - intros. inversion H; subst; clear H.
          apply in_map_iff in H0.
          inversion H0; subst; clear H0.
          inversion H; subst; clear H.
          apply filter_In in H2. inversion H2; subst; clear H2.
          destruct x eqn:X; simpl in *. inversion H0.
          destruct s eqn:S; simpl in *.
          pose proof H5 (Left :: l0).
          eapply H2 in H; auto.
          simpl. instantiate (1 := p2). instantiate (1:= p1). rewrite H1. auto.
          inversion H0.
      + unfold refineList; simpl. apply IHl.
        inversion H. auto.
      + unfold refineList; simpl. apply IHl.
        inversion H. auto.
      + unfold refineList; simpl.
        eapply FreeCons.
        - apply IHl. inversion H; auto.
        - intros. inversion H; subst; clear H.
          apply in_map_iff in H0.
          inversion H0; subst; clear H0.
          inversion H; subst; clear H.
          apply filter_In in H2. inversion H2; subst; clear H2.
          destruct x eqn:X; simpl in *. inversion H0.
          destruct s eqn:S; simpl in *.
          inversion H0.
          pose proof H5 (Right :: l0).
          eapply H2 in H; auto.
          simpl. instantiate (1 := p2). instantiate (1:= p1). rewrite H1. auto.
Qed.

Definition refineFunction (f : SplitPath -> RandomSeed) (d : SplitDirection) (arg : SplitPath) :
RandomSeed :=
  f (d :: arg).

Lemma refineFunCorrect : forall f d p, f (d :: p) = (refineFunction f d) p.
auto.
Qed.

Hint Rewrite refineFunCorrect.
Hint Unfold refineFunction.
Program Fixpoint addToTree (st : SeedTree) (p : SplitPath) (f : SplitPath -> RandomSeed)
        (l : list SplitPath)
        (Corr : correspondingSeedTree l f st)
        (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False))
: SeedTree :=
  match st with
    | SeedTreeUndef =>
      match p with
        | [] => SeedTreeLeaf (f p)
        | Left  :: p' => SeedTreeNode (addToTree SeedTreeUndef p' (refineFunction f Left) [] _ _) SeedTreeUndef
        | Right :: p' => SeedTreeNode SeedTreeUndef (addToTree SeedTreeUndef p' (refineFunction f Right) [] _ _)
      end
    | SeedTreeLeaf s => _  (* Contradiction! *)
    | SeedTreeNode st1 st2 =>
      match p with
        | [] => SeedTreeLeaf (f p)
        | Left  :: p' => SeedTreeNode (addToTree st1 p' (refineFunction f Left) (refineList Left l) _ _) st2
        | Right :: p' => SeedTreeNode st1 (addToTree st2 p' (refineFunction f Right) (refineList Right l) _ _)
      end
  end.
Next Obligation.
apply corrEmptyLeaf in Corr. inversion Corr; clear Corr; subst.
pose proof (Pref []).
exfalso.
eapply H.
+ left; auto.
+ instantiate (2 := []). rewrite app_nil_r. simpl. eauto.
Qed.
Next Obligation.
eapply Corresponding; intros.
+ apply refineCorrect'.
  inversion Corr as [Vary_In _ _ ]; clear Corr.
  pose proof (Vary_In (Left :: p) s) as Hyp; clear Vary_In.
  auto.
+ apply refineCorrect in H.
  inversion Corr as [_ In_Vary _]; clear Corr.
  pose proof (In_Vary (Left :: p)) as Hyp; clear In_Vary.
  apply Hyp in H; clear Hyp.
  simpl in H.
  unfold refineFunction; auto.
+ inversion Corr.
  apply refinePreservesPrefixFree.
  auto.
Qed.
Next Obligation.
eapply Pref.
instantiate (1:= Left :: p'0).
apply refineCorrect; auto.
instantiate (1:= p2). instantiate (1:=p1). simpl. rewrite H0. auto.
Qed.
Next Obligation.
eapply Corresponding; intros.
+ apply refineCorrect'.
  inversion Corr as [Vary_In _ _ ]; clear Corr.
  pose proof (Vary_In (Right :: p) s) as Hyp; clear Vary_In.
  auto.
+ apply refineCorrect in H.
  inversion Corr as [_ In_Vary _]; clear Corr.
  pose proof (In_Vary (Right :: p)) as Hyp; clear In_Vary.
  apply Hyp in H; clear Hyp.
  simpl in H.
  unfold refineFunction; auto.
+ inversion Corr.
  apply refinePreservesPrefixFree.
  auto.
Qed.
Next Obligation.
eapply Pref.
instantiate (1:= Right :: p'0).
apply refineCorrect; auto.
instantiate (1:= p2). instantiate (1:=p1). simpl. rewrite H0. auto.
Qed.

Lemma addToTreeCorrect1 : forall (st : SeedTree) (p : SplitPath)
  (f : SplitPath -> RandomSeed)
  (l : list SplitPath) (Corr : correspondingSeedTree l f st)
  (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)),
  varySeed' (addToTree st p f l Corr Pref) p = Some (f p).
intros st p.
generalize dependent st.
induction p.
+ intros st f l Corr Pref.
  unfold addToTree.
  destruct st.
  - auto.
  - exfalso.
    apply corrEmptyLeaf in Corr.
    inversion Corr; clear Corr.
    subst.
    pose proof Pref [] as Contra; clear Pref.
    eapply Contra; clear Contra.
    * left; auto.
    * instantiate (1 := []). instantiate (1 := []). auto.
  - simpl. auto.
+ intros.
  destruct st; destruct a; simpl; auto.
  - rewrite refineFunCorrect.
    apply IHp.
  - rewrite refineFunCorrect; apply IHp.
  - exfalso. eapply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    pose proof (Pref []).
    eapply H.
    - subst; left; auto.
    - simpl. instantiate (2:= []); rewrite app_nil_r. instantiate (1 := Left ::p); auto.
  - exfalso. eapply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    pose proof (Pref []).
    eapply H.
    - subst; left; auto.
    - simpl. instantiate (2:= []); rewrite app_nil_r. instantiate (1 := Right ::p); auto.
  - rewrite refineFunCorrect; apply IHp.
  - rewrite refineFunCorrect; apply IHp.
Qed.

Lemma addToTreeCorrect2 : forall (st : SeedTree) (p : SplitPath)
  (f : SplitPath -> RandomSeed)
  (l : list SplitPath) (Corr : correspondingSeedTree l f st)
  (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)),
  forall p' seed, varySeed' st p' = Some seed ->
             varySeed' (addToTree st p f l Corr Pref) p' = Some seed.
intros st p.
generalize dependent st.
induction p as [ | d ds].
+ intros.
  exfalso.
  eapply Pref.
  - inversion Corr as [Vary_In In_Vary Pref']; clear Corr.
    eapply Vary_In; eassumption.
  - instantiate (1 := []); instantiate (1 := p'); rewrite app_nil_r; auto.
+ intros st f l Corr Pref p' seed VarySome.
  destruct st; destruct d; simpl; auto.
  * exfalso. apply corrUndefEmpty in Corr. subst. inversion VarySome.
  * exfalso. apply corrUndefEmpty in Corr. subst. inversion VarySome.
  * exfalso.
    apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    eapply Pref.
    instantiate (1 := []); left; auto.
    instantiate (1:= Left :: ds). instantiate (1 := []). rewrite app_nil_r; simpl; auto.
  * exfalso.
    apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    eapply Pref.
    instantiate (1 := []); left; auto.
    instantiate (1:= Right :: ds). instantiate (1 := []). rewrite app_nil_r; simpl; auto.
  * destruct p'.
    - simpl in VarySome. inversion VarySome.
    - destruct s.
      + apply IHds; auto.
      + auto.
  * destruct p'.
    - simpl in VarySome; inversion VarySome.
    - destruct s.
      + auto.
      + apply IHds; auto.
Qed.

Lemma addToTreeCorrect3 : forall (st : SeedTree) (p : SplitPath)
  (f : SplitPath -> RandomSeed)
  (l : list SplitPath) (Corr : correspondingSeedTree l f st)
  (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)),
  forall p' seed, varySeed' (addToTree st p f l Corr Pref) p' = Some seed ->
             p = p' \/ varySeed' st p' = Some seed.
intros st p. generalize dependent st.
induction p.
+ intros.
  destruct p'.
  - left; auto.
  - right.
    exfalso.
    unfold addToTree in H; simpl in H.
    destruct st; simpl in H.
    * inversion H.
    * clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
      subst.
      eapply Pref.
      instantiate (1 := []). left; auto.
      instantiate (1 := []); instantiate (1 := []); auto.
    * inversion H.
+ intros.
  destruct p'; destruct st; destruct a; simpl in *;
  try solve [match goal with [ H : None = Some _ |- _ ] => inversion H end].
  + exfalso. clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    eapply Pref.
    subst.
    instantiate (1 := []) ; left; auto.
    instantiate (1 := (Left :: p)); instantiate (1 := []); rewrite app_nil_r; auto.
  + exfalso. clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    eapply Pref.
    subst.
    instantiate (1 := []) ; left; auto.
    instantiate (1 := (Right :: p)); instantiate (1 := []); rewrite app_nil_r; auto.
  + destruct s; simpl in *.
    - assert (p = p' \/ varySeed' SeedTreeUndef p' = Some seed)
             by (eapply IHp; eauto).
      inversion H0.
      * left; subst; auto.
      * simpl in H1. inversion H1.
    - inversion H.
  + destruct s; simpl in *.
    - inversion H.
    - assert (p = p' \/ varySeed' SeedTreeUndef p' = Some seed)
        by (eapply IHp; eauto).
      inversion H0.
      * left; subst; auto.
      * simpl in H1. inversion H1.
  + exfalso.
    clear H.
    apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    subst.
    eapply Pref.
    instantiate (1 := []).
    - left; auto.
    - instantiate (1 := Left :: p); instantiate (1 := []); rewrite app_nil_r; auto.
  + exfalso.
    clear H.
    apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
    subst.
    eapply Pref.
    instantiate (1 := []).
    - left; auto.
    - instantiate (1 := Right :: p); instantiate (1 := []); rewrite app_nil_r; auto.
  + destruct s eqn:S; simpl in *.
    - assert (p = p' \/ varySeed' st1 p' = Some seed)
        by (eapply IHp; eauto).
      inversion H0.
      * left; subst; auto.
      * right; auto.
    - right; auto.
  + destruct s eqn:S; simpl in *.
    - right; auto.
    - assert (p = p' \/ varySeed' st2 p' = Some seed)
        by (eapply IHp; eauto).
      inversion H0.
      * left; subst; auto.
      * right; auto.
Qed.

Lemma addToTreeCorrect : forall (st : SeedTree) (p : SplitPath)
  (f : SplitPath -> RandomSeed)
  (l : list SplitPath) (Corr : correspondingSeedTree l f st)
  (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)),
  correspondingSeedTree (p :: l) f (addToTree st p f l Corr Pref).
intros.
apply Corresponding.
+ intros p' s VarySome.
  inversion Corr as [Vary_In In_Vary Pref'].
  apply addToTreeCorrect3 in VarySome.
  inversion VarySome.
  - left; auto.
  - right. eapply Vary_In; eassumption.
+ intros p' InP'.
  inversion Corr as [Vary_In In_Vary Pref'].
  inversion InP'.
  - subst.
    apply addToTreeCorrect1.
  - apply addToTreeCorrect2. apply In_Vary. auto.
+ apply FreeCons.
  - inversion Corr; auto.
  - intros.
    eapply Pref.
    eassumption.
    instantiate (1 := p1); instantiate (1:= p2); subst; auto.
Qed.

Lemma PrefixFreeTail : forall a l, PrefixFree (a :: l) -> PrefixFree l.
intros.
inversion H.
auto.
Qed.

(* LL: Why was it easier to do it like this? :P *)
Fixpoint listToTree (l : list SplitPath) (f : SplitPath -> RandomSeed)
        ( Pref : PrefixFree l) : {s : SeedTree | correspondingSeedTree l f s}.
Proof.
induction l.
+ exists SeedTreeUndef. apply corrEmptyUndef.
+ remember Pref as Pref'. clear HeqPref'. apply PrefixFreeTail in Pref'.
  apply IHl in Pref'.
  inversion Pref'; clear Pref'.
  assert (forall p', In p' l -> forall p1 p2, a ++ p1 = p' ++ p2 -> False) by
      (inversion Pref; intros; subst; eapply H3; [eassumption |
    instantiate (1 := p1); instantiate (1 := p2); subst; auto]).
  exists (addToTree x a f l H H0).
  apply addToTreeCorrect.
Qed.

(* begin SplitPathCompleteness *)
Theorem SplitPathCompleteness (l : list SplitPath) (f : SplitPath -> RandomSeed) :
  PrefixFree l -> exists (s : RandomSeed), forall p, In p l -> varySeed p s = f p.
(* end SplitPathCompleteness *)
intros Pref.
pose proof (listToTree l f Pref) as ExSeedTree.
inversion ExSeedTree as [st Corr]; clear ExSeedTree.
inversion Corr as [Vary_In In_Vary Pref']; clear Corr.
pose proof (splitExpand st) as ExRst.
inversion ExRst as [rst Sub]; clear ExRst.
exists rst.
intros p InPL.
pose proof (pathAgreesOnSubTree st (mkSeedTree rst) p (f p)) as Hyp.
auto.
Qed.

(* Primitive generator combinators and some basic soundness
   assumptions about them *)
Axiom randomRBool : bool * bool -> RandomSeed -> bool * RandomSeed.
Axiom randomRBoolCorrect :
  forall b b1 b2, implb b1 b2 ->
    (implb b1 b && implb b b2 <->
    exists seed, (fst (randomRBool (b1, b2) seed)) = b).
Axiom randomRNat  : nat  * nat -> RandomSeed -> nat * RandomSeed.
Axiom randomRNatCorrect:
  forall n n1 n2, n1 <= n2 ->
    (n1 <= n <= n2 <->
    exists seed, (fst (randomRNat (n1, n2) seed)) = n).
Axiom randomRInt  : Z * Z    -> RandomSeed -> Z * RandomSeed.
Axiom randomRIntCorrect:
  forall z z1 z2, Z.leb z1 z2 ->
    (Z.leb z1 z && Z.leb z z2 <->
    exists seed, (fst (randomRInt (z1, z2) seed)) = z).
Axiom randomRN    : N * N    -> RandomSeed -> N * RandomSeed.
Axiom randomRNCorrect:
  forall n n1 n2,
    N.leb n1 n2 ->
    N.leb n1 n && N.leb n n2 <->
    exists seed, fst (randomRN (n1, n2) seed) = n.

(* A small experiment showing that infinite random trees
   are a potential model of the randomSplitAssumption *)

Module InfiniteTrees.
  CoInductive RandomSeed : Type :=
  | Node : bool -> RandomSeed -> RandomSeed -> RandomSeed.

  Definition randomSplit (s : RandomSeed) :=
    match s with
    | Node b s1 s2 => (s1,s2)
    end.

  Lemma randomSplitAssumption :
    forall s1 s2 : RandomSeed, exists s, randomSplit s = (s1,s2).
  Proof.
    move => s1 s2. by exists (Node true s1 s2).
  Qed.
End InfiniteTrees.

(* Type class machinery for generating things in intervals *)

Class OrdType (A: Type) :=
  {
    leq     : A -> A -> bool;
    refl    : reflexive leq;
    trans   : transitive leq;
    antisym : antisymmetric leq
  }.

Program Instance OrdBool : OrdType bool :=
  {
    leq b1 b2 := implb b1 b2
  }.
Next Obligation.
  by case.
Qed.
Next Obligation.
  by do 3! case.
Qed.
Next Obligation.
  by do 2! case.
Qed.

Program Instance OrdNat : OrdType nat :=
  {
    leq := ssrnat.leq;
    refl := leqnn;
    trans := leq_trans;
    antisym := anti_leq
  }.

Program Instance OrdZ : OrdType Z :=
  {
    leq := Z.leb;
    refl := Z.leb_refl
  }.
Next Obligation.
move=> x y z le_yx le_xz.
exact: (Zle_bool_trans y x z).
Qed.
Next Obligation.
move=> x y /andP[].
exact: Zle_bool_antisym.
Qed.

Program Instance OrdN : OrdType N :=
  {
    leq := N.leb;
    refl := N.leb_refl
  }.
Next Obligation.
  move=> x y z le_yx le_xz.
  unfold is_true in *.
  apply N.leb_le in le_yx.
  apply N.leb_le in le_xz.
  apply N.leb_le.
  eapply N.le_trans; eauto.
Qed.
Next Obligation.
  move=> x y /andP[].
  unfold is_true.
  repeat rewrite N.leb_le.
  intros.
  apply N.le_antisymm; auto.
Qed.

Class ChoosableFromInterval (A : Type)  :=
  {
    super :> OrdType A;
    randomR : A * A -> RandomSeed -> A * RandomSeed;
    randomRCorrect :
      forall (a a1 a2 : A), leq a1 a2 ->
      (leq a1 a && leq a a2 <->
       exists seed, fst (randomR (a1, a2) seed) = a)
  }.

Program Instance ChooseBool : ChoosableFromInterval bool :=
  {
    randomR := randomRBool;
    randomRCorrect := randomRBoolCorrect
  }.

Instance ChooseNat : ChoosableFromInterval nat :=
  {
    randomR := randomRNat;
    randomRCorrect := randomRNatCorrect
  }.

Instance ChooseZ : ChoosableFromInterval Z :=
  {
    randomR := randomRInt;
    randomRCorrect := randomRIntCorrect
  }.

Instance ChooseN : ChoosableFromInterval N :=
  {
    randomR := randomRN;
    randomRCorrect := randomRNCorrect
  }.


Require Import defns.

Fixpoint struct_nTy_cs (A A' : nTy) (i : Ixc) (H : cs_nTy A i A'):
  struct_nTy A = struct_nTy A'
with struct_nte_cs (M M' : nte) (i : Ixc) (H : cs_nte M i M'):
  struct_nte M = struct_nte M'.
Proof.
  induction H.
  constructor.
  cbv; f_equal;  eauto.
  cbv; f_equal; eauto using struct_nte_cs.
  induction H.
  constructor.
  constructor.
  constructor.
  constructor.
  constructor.
  cbv; f_equal; eauto using struct_nTy_cs.
  cbv; f_equal; eauto.
Qed.

Fixpoint struct_nTy_cstu (A A' : nTy) (i : Ixc) (H : cstu_nTy A i A'):
  struct_nTy A = struct_nTy A'
with struct_nte_cstu (M M' : nte) (i : Ixc) (H : cstu_nte M i M'):
  struct_nte M = struct_nte M'.
Proof.
  induction H.
  constructor.
  cbv; f_equal; auto.
  cbv; f_equal; eauto using struct_nte_cstu.
  (* lemma 2 *)
  induction H.
  auto.
  auto.
  auto.
  auto.
  cbv; f_equal; eauto using struct_nTy_cstu.
  cbv; f_equal; auto.
Qed.


From Hammer Require Import Hammer.

Ltac destr_bool :=
intros; destruct_all bool; simpl in *; trivial; try discriminate.

Definition Is_true (b:bool) :=
match b with
| true => True
| false => False
end.

Lemma bool_dec : forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}.
Proof. hammer_hook "Bool" "Bool.bool_dec".
decide equality.
Defined.

Lemma diff_true_false : true <> false.
Proof. hammer_hook "Bool" "Bool.diff_true_false".
discriminate.
Qed.
Hint Resolve diff_true_false : bool.

Lemma diff_false_true : false <> true.
Proof. hammer_hook "Bool" "Bool.diff_false_true".
discriminate.
Qed.
Hint Resolve diff_false_true : bool.
Hint Extern 1 (false <> true) => exact diff_false_true.

Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False.
Proof. hammer_hook "Bool" "Bool.eq_true_false_abs".
destr_bool.
Qed.

Lemma not_true_is_false : forall b:bool, b <> true -> b = false.
Proof. hammer_hook "Bool" "Bool.not_true_is_false".
destr_bool; intuition.
Qed.

Lemma not_false_is_true : forall b:bool, b <> false -> b = true.
Proof. hammer_hook "Bool" "Bool.not_false_is_true".
destr_bool; intuition.
Qed.

Lemma not_true_iff_false : forall b, b <> true <-> b = false.
Proof. hammer_hook "Bool" "Bool.not_true_iff_false".
destr_bool; intuition.
Qed.

Lemma not_false_iff_true : forall b, b <> false <-> b = true.
Proof. hammer_hook "Bool" "Bool.not_false_iff_true".
destr_bool; intuition.
Qed.

Definition leb (b1 b2:bool) :=
match b1 with
| true => b2 = true
| false => True
end.
Hint Unfold leb: bool.

Lemma leb_implb : forall b1 b2, leb b1 b2 <-> implb b1 b2 = true.
Proof. hammer_hook "Bool" "Bool.leb_implb".
destr_bool; intuition.
Qed.

Definition eqb (b1 b2:bool) : bool :=
match b1, b2 with
| true, true => true
| true, false => false
| false, true => false
| false, false => true
end.

Lemma eqb_subst :
forall (P:bool -> Prop) (b1 b2:bool), eqb b1 b2 = true -> P b1 -> P b2.
Proof. hammer_hook "Bool" "Bool.eqb_subst".
destr_bool.
Qed.

Lemma eqb_reflx : forall b:bool, eqb b b = true.
Proof. hammer_hook "Bool" "Bool.eqb_reflx".
destr_bool.
Qed.

Lemma eqb_prop : forall a b:bool, eqb a b = true -> a = b.
Proof. hammer_hook "Bool" "Bool.eqb_prop".
destr_bool.
Qed.

Lemma eqb_true_iff : forall a b:bool, eqb a b = true <-> a = b.
Proof. hammer_hook "Bool" "Bool.eqb_true_iff".
destr_bool; intuition.
Qed.

Lemma eqb_false_iff : forall a b:bool, eqb a b = false <-> a <> b.
Proof. hammer_hook "Bool" "Bool.eqb_false_iff".
destr_bool; intuition.
Qed.

Definition ifb (b1 b2 b3:bool) : bool :=
match b1 with
| true => b2
| false => b3
end.

Open Scope bool_scope.

Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2.
Proof. hammer_hook "Bool" "Bool.negb_orb".
destr_bool.
Qed.

Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2.
Proof. hammer_hook "Bool" "Bool.negb_andb".
destr_bool.
Qed.

Lemma negb_involutive : forall b:bool, negb (negb b) = b.
Proof. hammer_hook "Bool" "Bool.negb_involutive".
destr_bool.
Qed.

Lemma negb_involutive_reverse : forall b:bool, b = negb (negb b).
Proof. hammer_hook "Bool" "Bool.negb_involutive_reverse".
destr_bool.
Qed.

Notation negb_elim := negb_involutive (only parsing).
Notation negb_intro := negb_involutive_reverse (only parsing).

Lemma negb_sym : forall b b':bool, b' = negb b -> b = negb b'.
Proof. hammer_hook "Bool" "Bool.negb_sym".
destr_bool.
Qed.

Lemma no_fixpoint_negb : forall b:bool, negb b <> b.
Proof. hammer_hook "Bool" "Bool.no_fixpoint_negb".
destr_bool.
Qed.

Lemma eqb_negb1 : forall b:bool, eqb (negb b) b = false.
Proof. hammer_hook "Bool" "Bool.eqb_negb1".
destr_bool.
Qed.

Lemma eqb_negb2 : forall b:bool, eqb b (negb b) = false.
Proof. hammer_hook "Bool" "Bool.eqb_negb2".
destr_bool.
Qed.

Lemma if_negb :
forall (A:Type) (b:bool) (x y:A),
(if negb b then x else y) = (if b then y else x).
Proof. hammer_hook "Bool" "Bool.if_negb".
destr_bool.
Qed.

Lemma negb_true_iff : forall b, negb b = true <-> b = false.
Proof. hammer_hook "Bool" "Bool.negb_true_iff".
destr_bool; intuition.
Qed.

Lemma negb_false_iff : forall b, negb b = false <-> b = true.
Proof. hammer_hook "Bool" "Bool.negb_false_iff".
destr_bool; intuition.
Qed.

Lemma orb_true_iff :
forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof. hammer_hook "Bool" "Bool.orb_true_iff".
destr_bool; intuition.
Qed.

Lemma orb_false_iff :
forall b1 b2, b1 || b2 = false <-> b1 = false /\ b2 = false.
Proof. hammer_hook "Bool" "Bool.orb_false_iff".
destr_bool; intuition.
Qed.

Lemma orb_true_elim :
forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}.
Proof. hammer_hook "Bool" "Bool.orb_true_elim".
destruct b1; simpl; auto.
Defined.

Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true.
Proof. hammer_hook "Bool" "Bool.orb_prop".
intros; apply orb_true_iff; trivial.
Qed.

Lemma orb_true_intro :
forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true.
Proof. hammer_hook "Bool" "Bool.orb_true_intro".
intros; apply orb_true_iff; trivial.
Qed.
Hint Resolve orb_true_intro: bool.

Lemma orb_false_intro :
forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false.
Proof. hammer_hook "Bool" "Bool.orb_false_intro".
intros. subst. reflexivity.
Qed.
Hint Resolve orb_false_intro: bool.

Lemma orb_false_elim :
forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false.
Proof. hammer_hook "Bool" "Bool.orb_false_elim".
intros. apply orb_false_iff; trivial.
Qed.

Lemma orb_diag : forall b, b || b = b.
Proof. hammer_hook "Bool" "Bool.orb_diag".
destr_bool.
Qed.

Lemma orb_true_r : forall b:bool, b || true = true.
Proof. hammer_hook "Bool" "Bool.orb_true_r".
destr_bool.
Qed.
Hint Resolve orb_true_r: bool.

Lemma orb_true_l : forall b:bool, true || b = true.
Proof. hammer_hook "Bool" "Bool.orb_true_l".
reflexivity.
Qed.

Notation orb_b_true := orb_true_r (only parsing).
Notation orb_true_b := orb_true_l (only parsing).

Lemma orb_false_r : forall b:bool, b || false = b.
Proof. hammer_hook "Bool" "Bool.orb_false_r".
destr_bool.
Qed.
Hint Resolve orb_false_r: bool.

Lemma orb_false_l : forall b:bool, false || b = b.
Proof. hammer_hook "Bool" "Bool.orb_false_l".
destr_bool.
Qed.
Hint Resolve orb_false_l: bool.

Notation orb_b_false := orb_false_r (only parsing).
Notation orb_false_b := orb_false_l (only parsing).

Lemma orb_negb_r : forall b:bool, b || negb b = true.
Proof. hammer_hook "Bool" "Bool.orb_negb_r".
destr_bool.
Qed.
Hint Resolve orb_negb_r: bool.

Notation orb_neg_b := orb_negb_r (only parsing).

Lemma orb_comm : forall b1 b2:bool, b1 || b2 = b2 || b1.
Proof. hammer_hook "Bool" "Bool.orb_comm".
destr_bool.
Qed.

Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3.
Proof. hammer_hook "Bool" "Bool.orb_assoc".
destr_bool.
Qed.
Hint Resolve orb_comm orb_assoc: bool.

Lemma andb_true_iff :
forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof. hammer_hook "Bool" "Bool.andb_true_iff".
destr_bool; intuition.
Qed.

Lemma andb_false_iff :
forall b1 b2:bool, b1 && b2 = false <-> b1 = false \/ b2 = false.
Proof. hammer_hook "Bool" "Bool.andb_false_iff".
destr_bool; intuition.
Qed.

Lemma andb_true_eq :
forall a b:bool, true = a && b -> true = a /\ true = b.
Proof. hammer_hook "Bool" "Bool.andb_true_eq".
destr_bool. auto.
Defined.

Lemma andb_false_intro1 : forall b1 b2:bool, b1 = false -> b1 && b2 = false.
Proof. hammer_hook "Bool" "Bool.andb_false_intro1".
intros. apply andb_false_iff. auto.
Qed.

Lemma andb_false_intro2 : forall b1 b2:bool, b2 = false -> b1 && b2 = false.
Proof. hammer_hook "Bool" "Bool.andb_false_intro2".
intros. apply andb_false_iff. auto.
Qed.

Lemma andb_false_r : forall b:bool, b && false = false.
Proof. hammer_hook "Bool" "Bool.andb_false_r".
destr_bool.
Qed.

Lemma andb_false_l : forall b:bool, false && b = false.
Proof. hammer_hook "Bool" "Bool.andb_false_l".
reflexivity.
Qed.

Notation andb_b_false := andb_false_r (only parsing).
Notation andb_false_b := andb_false_l (only parsing).

Lemma andb_diag : forall b, b && b = b.
Proof. hammer_hook "Bool" "Bool.andb_diag".
destr_bool.
Qed.

Lemma andb_true_r : forall b:bool, b && true = b.
Proof. hammer_hook "Bool" "Bool.andb_true_r".
destr_bool.
Qed.

Lemma andb_true_l : forall b:bool, true && b = b.
Proof. hammer_hook "Bool" "Bool.andb_true_l".
reflexivity.
Qed.

Notation andb_b_true := andb_true_r (only parsing).
Notation andb_true_b := andb_true_l (only parsing).

Lemma andb_false_elim :
forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}.
Proof. hammer_hook "Bool" "Bool.andb_false_elim".
destruct b1; simpl; auto.
Defined.
Hint Resolve andb_false_elim: bool.

Lemma andb_negb_r : forall b:bool, b && negb b = false.
Proof. hammer_hook "Bool" "Bool.andb_negb_r".
destr_bool.
Qed.
Hint Resolve andb_negb_r: bool.

Notation andb_neg_b := andb_negb_r (only parsing).

Lemma andb_comm : forall b1 b2:bool, b1 && b2 = b2 && b1.
Proof. hammer_hook "Bool" "Bool.andb_comm".
destr_bool.
Qed.

Lemma andb_assoc : forall b1 b2 b3:bool, b1 && (b2 && b3) = b1 && b2 && b3.
Proof. hammer_hook "Bool" "Bool.andb_assoc".
destr_bool.
Qed.

Hint Resolve andb_comm andb_assoc: bool.

Lemma andb_orb_distrib_r :
forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3.
Proof. hammer_hook "Bool" "Bool.andb_orb_distrib_r".
destr_bool.
Qed.

Lemma andb_orb_distrib_l :
forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3.
Proof. hammer_hook "Bool" "Bool.andb_orb_distrib_l".
destr_bool.
Qed.

Lemma orb_andb_distrib_r :
forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3).
Proof. hammer_hook "Bool" "Bool.orb_andb_distrib_r".
destr_bool.
Qed.

Lemma orb_andb_distrib_l :
forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3).
Proof. hammer_hook "Bool" "Bool.orb_andb_distrib_l".
destr_bool.
Qed.

Notation demorgan1 := andb_orb_distrib_r (only parsing).
Notation demorgan2 := andb_orb_distrib_l (only parsing).
Notation demorgan3 := orb_andb_distrib_r (only parsing).
Notation demorgan4 := orb_andb_distrib_l (only parsing).

Lemma absorption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1.
Proof. hammer_hook "Bool" "Bool.absorption_andb".
destr_bool.
Qed.

Lemma absorption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1.
Proof. hammer_hook "Bool" "Bool.absorption_orb".
destr_bool.
Qed.

Notation absoption_andb := absorption_andb (only parsing).
Notation absoption_orb := absorption_orb (only parsing).

Lemma xorb_false_r : forall b:bool, xorb b false = b.
Proof. hammer_hook "Bool" "Bool.xorb_false_r".
destr_bool.
Qed.

Lemma xorb_false_l : forall b:bool, xorb false b = b.
Proof. hammer_hook "Bool" "Bool.xorb_false_l".
destr_bool.
Qed.

Notation xorb_false := xorb_false_r (only parsing).
Notation false_xorb := xorb_false_l (only parsing).

Lemma xorb_true_r : forall b:bool, xorb b true = negb b.
Proof. hammer_hook "Bool" "Bool.xorb_true_r".
reflexivity.
Qed.

Lemma xorb_true_l : forall b:bool, xorb true b = negb b.
Proof. hammer_hook "Bool" "Bool.xorb_true_l".
reflexivity.
Qed.

Notation xorb_true := xorb_true_r (only parsing).
Notation true_xorb := xorb_true_l (only parsing).

Lemma xorb_nilpotent : forall b:bool, xorb b b = false.
Proof. hammer_hook "Bool" "Bool.xorb_nilpotent".
destr_bool.
Qed.

Lemma xorb_comm : forall b b':bool, xorb b b' = xorb b' b.
Proof. hammer_hook "Bool" "Bool.xorb_comm".
destr_bool.
Qed.

Lemma xorb_assoc_reverse :
forall b b' b'':bool, xorb (xorb b b') b'' = xorb b (xorb b' b'').
Proof. hammer_hook "Bool" "Bool.xorb_assoc_reverse".
destr_bool.
Qed.

Notation xorb_assoc := xorb_assoc_reverse (only parsing).

Lemma xorb_eq : forall b b':bool, xorb b b' = false -> b = b'.
Proof. hammer_hook "Bool" "Bool.xorb_eq".
destr_bool.
Qed.

Lemma xorb_move_l_r_1 :
forall b b' b'':bool, xorb b b' = b'' -> b' = xorb b b''.
Proof. hammer_hook "Bool" "Bool.xorb_move_l_r_1".
destr_bool.
Qed.

Lemma xorb_move_l_r_2 :
forall b b' b'':bool, xorb b b' = b'' -> b = xorb b'' b'.
Proof. hammer_hook "Bool" "Bool.xorb_move_l_r_2".
destr_bool.
Qed.

Lemma xorb_move_r_l_1 :
forall b b' b'':bool, b = xorb b' b'' -> xorb b' b = b''.
Proof. hammer_hook "Bool" "Bool.xorb_move_r_l_1".
destr_bool.
Qed.

Lemma xorb_move_r_l_2 :
forall b b' b'':bool, b = xorb b' b'' -> xorb b b'' = b'.
Proof. hammer_hook "Bool" "Bool.xorb_move_r_l_2".
destr_bool.
Qed.

Lemma negb_xorb_l : forall b b', negb (xorb b b') = xorb (negb b) b'.
Proof. hammer_hook "Bool" "Bool.negb_xorb_l".
destruct b,b'; trivial.
Qed.

Lemma negb_xorb_r : forall b b', negb (xorb b b') = xorb b (negb b').
Proof. hammer_hook "Bool" "Bool.negb_xorb_r".
destruct b,b'; trivial.
Qed.

Lemma xorb_negb_negb : forall b b', xorb (negb b) (negb b') = xorb b b'.
Proof. hammer_hook "Bool" "Bool.xorb_negb_negb".
destruct b,b'; trivial.
Qed.

Lemma eq_iff_eq_true : forall b1 b2, b1 = b2 <-> (b1 = true <-> b2 = true).
Proof. hammer_hook "Bool" "Bool.eq_iff_eq_true".
destr_bool; intuition.
Qed.

Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2.
Proof. hammer_hook "Bool" "Bool.eq_true_iff_eq".
apply eq_iff_eq_true.
Qed.

Notation bool_1 := eq_true_iff_eq (only parsing).

Lemma eq_true_negb_classical : forall b:bool, negb b <> true -> b = true.
Proof. hammer_hook "Bool" "Bool.eq_true_negb_classical".
destr_bool; intuition.
Qed.

Notation bool_3 := eq_true_negb_classical (only parsing).

Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true.
Proof. hammer_hook "Bool" "Bool.eq_true_not_negb".
destr_bool; intuition.
Qed.

Notation bool_6 := eq_true_not_negb (only parsing).

Hint Resolve eq_true_not_negb : bool.

Lemma absurd_eq_bool : forall b b':bool, False -> b = b'.
Proof. hammer_hook "Bool" "Bool.absurd_eq_bool".
contradiction.
Qed.

Lemma absurd_eq_true : forall b, False -> b = true.
Proof. hammer_hook "Bool" "Bool.absurd_eq_true".
contradiction.
Qed.
Hint Resolve absurd_eq_true.

Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z.
Proof. hammer_hook "Bool" "Bool.trans_eq_bool".
apply eq_trans.
Qed.
Hint Resolve trans_eq_bool.

Hint Unfold Is_true: bool.

Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true.
Proof. hammer_hook "Bool" "Bool.Is_true_eq_true".
destr_bool; tauto.
Qed.

Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x.
Proof. hammer_hook "Bool" "Bool.Is_true_eq_left".
intros; subst; auto with bool.
Qed.

Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x.
Proof. hammer_hook "Bool" "Bool.Is_true_eq_right".
intros; subst; auto with bool.
Qed.

Notation Is_true_eq_true2 := Is_true_eq_right (only parsing).

Hint Immediate Is_true_eq_right Is_true_eq_left: bool.

Lemma eqb_refl : forall x:bool, Is_true (eqb x x).
Proof. hammer_hook "Bool" "Bool.eqb_refl".
destr_bool.
Qed.

Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y.
Proof. hammer_hook "Bool" "Bool.eqb_eq".
destr_bool; tauto.
Qed.

Lemma orb_prop_elim :
forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b.
Proof. hammer_hook "Bool" "Bool.orb_prop_elim".
destr_bool; tauto.
Qed.

Notation orb_prop2 := orb_prop_elim (only parsing).

Lemma orb_prop_intro :
forall a b:bool, Is_true a \/ Is_true b -> Is_true (a || b).
Proof. hammer_hook "Bool" "Bool.orb_prop_intro".
destr_bool; tauto.
Qed.

Lemma andb_prop_intro :
forall b1 b2:bool, Is_true b1 /\ Is_true b2 -> Is_true (b1 && b2).
Proof. hammer_hook "Bool" "Bool.andb_prop_intro".
destr_bool; tauto.
Qed.
Hint Resolve andb_prop_intro: bool.

Notation andb_true_intro2 :=
(fun b1 b2 H1 H2 => andb_prop_intro b1 b2 (conj H1 H2))
(only parsing).

Lemma andb_prop_elim :
forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b.
Proof. hammer_hook "Bool" "Bool.andb_prop_elim".
destr_bool; auto.
Qed.
Hint Resolve andb_prop_elim: bool.

Notation andb_prop2 := andb_prop_elim (only parsing).

Lemma eq_bool_prop_intro :
forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2.
Proof. hammer_hook "Bool" "Bool.eq_bool_prop_intro".
destr_bool; tauto.
Qed.

Lemma eq_bool_prop_elim : forall b1 b2, b1 = b2 -> (Is_true b1 <-> Is_true b2).
Proof. hammer_hook "Bool" "Bool.eq_bool_prop_elim".
destr_bool; tauto.
Qed.

Lemma negb_prop_elim : forall b, Is_true (negb b) -> ~ Is_true b.
Proof. hammer_hook "Bool" "Bool.negb_prop_elim".
destr_bool; tauto.
Qed.

Lemma negb_prop_intro : forall b, ~ Is_true b -> Is_true (negb b).
Proof. hammer_hook "Bool" "Bool.negb_prop_intro".
destr_bool; tauto.
Qed.

Lemma negb_prop_classical : forall b, ~ Is_true (negb b) -> Is_true b.
Proof. hammer_hook "Bool" "Bool.negb_prop_classical".
destr_bool; tauto.
Qed.

Lemma negb_prop_involutive : forall b, Is_true b -> ~ Is_true (negb b).
Proof. hammer_hook "Bool" "Bool.negb_prop_involutive".
destr_bool; tauto.
Qed.

Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool),
(if b && b' then a else a') =
(if b then if b' then a else a' else a').
Proof. hammer_hook "Bool" "Bool.andb_if".
destr_bool.
Qed.

Lemma negb_if : forall (A:Type)(a a':A)(b:bool),
(if negb b then a else a') =
(if b then a' else a).
Proof. hammer_hook "Bool" "Bool.negb_if".
destr_bool.
Qed.

Notation "a &&& b" := (if a then b else false)
(at level 40, left associativity) : lazy_bool_scope.
Notation "a ||| b" := (if a then true else b)
(at level 50, left associativity) : lazy_bool_scope.

Local Open Scope lazy_bool_scope.

Lemma andb_lazy_alt : forall a b : bool, a && b = a &&& b.
Proof. hammer_hook "Bool" "Bool.andb_lazy_alt".
reflexivity.
Qed.

Lemma orb_lazy_alt : forall a b : bool, a || b = a ||| b.
Proof. hammer_hook "Bool" "Bool.orb_lazy_alt".
reflexivity.
Qed.

Inductive reflect (P : Prop) : bool -> Set :=
| ReflectT : P -> reflect P true
| ReflectF : ~ P -> reflect P false.
Hint Constructors reflect : bool.

Lemma reflect_iff : forall P b, reflect P b -> (P<->b=true).
Proof. hammer_hook "Bool" "Bool.reflect_iff".
destruct 1; intuition; discriminate.
Qed.

Lemma iff_reflect : forall P b, (P<->b=true) -> reflect P b.
Proof. hammer_hook "Bool" "Bool.iff_reflect".
destr_bool; intuition.
Defined.

Lemma reflect_dec : forall P b, reflect P b -> {P}+{~P}.
Proof. hammer_hook "Bool" "Bool.reflect_dec".
destruct 1; auto.
Defined.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


(** * The simplex category Δ, and the precategory of simplicial sets, [Δᵒᵖ → set] *)
Require Import Basics Types Spaces.Nat.
Require Import Category.Core Functor.Core Functor.Paths.
Require Import SetCategory.Core.
Require Import ChainCategory FunctorCategory.Core.
Require Import Category.Dual.
Require Import Functor.Identity Functor.Composition.Core Functor.Composition.Laws.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.
Local Open Scope category_scope.

(** We define the precategory Δ of simplexes, or finite non-empty linear
    orders *)

Module Export Core.
  Section simplicial_sets.
    Context `{Funext}.

    (** We say that the objects of Δ are natural numbers, where a
        number [n] is morally considered as the canonical [n]-simplex,
        a finite linear order on [n + 1] elements.  By declaring
        [chain] to be a local coercion from [nat] to [PreCategory], we
        can rely on on-the-fly eta-expansion to make this moral
        consideration a reality, telling Coq that it can unify, for
        example, [nat -> nat -> Type] with [PreCategory -> PreCategory
        -> Type] by silently inserting [chain]. *)

    Local Coercion chain : nat >-> PreCategory.

    Definition simplex_category
      := @Build_PreCategory
           nat
           Functor
           identity
           compose
           associativity
           left_identity
           right_identity
           _.

    Definition simplicial_category (C : PreCategory) : PreCategory
      := simplex_category^op -> C.

    Definition simplicial_set := simplicial_category set_cat.
    Definition simplicial_prop := simplicial_category prop_cat.
  End simplicial_sets.

  Notation simplicial_of obj := (simplicial_category (cat_of obj)).
End Core.

Module Utf8.
  Notation Δ := simplex_category.
End Utf8.


Require Import Coq.ZArith.ZArith.
Require Import Coq.setoid_ring.Ring_theory.
Require Export riscv.util.Word.
Require Import riscv.util.Monads.
Require Export riscv.util.ZBitOps.

Local Open Scope Z_scope.

(* Meaning of MachineInt: an integer big enough to hold an integer of a RISCV machine,
   no matter whether it's a 32-bit or 64-bit machine. *)
Definition MachineInt := Z.

Class MachineWidth(t: Set) := mkMachineWidth {
  (* arithmetic operations (inherited from Integral in Haskell) *)
  add: t -> t -> t;
  sub: t -> t -> t;
  mul: t -> t -> t;
  div: t -> t -> t;
  rem: t -> t -> t;

  negate: t -> t;

  (* comparison operators *)
  reg_eqb: t -> t -> bool;
  signed_less_than: t -> t -> bool;
  ltu: t -> t -> bool;

  (* logical operations (inherited from Bits in Haskell) *)
  xor: t -> t -> t;
  or: t -> t -> t;
  and: t -> t -> t;

  (* bitwidth of type t: *)
  XLEN: Z;

  (* operations also defined in MachineWidth in Haskell: *)

  regToInt8: t -> word 8;
  regToInt16: t -> word 16;
  regToInt32: t -> word 32;
  regToInt64: t -> word 64;

  uInt8ToReg: word 8 -> t;
  uInt16ToReg: word 16 -> t;
  uInt32ToReg: word 32 -> t;
  uInt64ToReg: word 64 -> t;

  int8ToReg: word 8 -> t;
  int16ToReg: word 16 -> t;
  int32ToReg: word 32 -> t;
  int64ToReg: word 64 -> t;

  s32: t -> t;
  u32: t -> t;

  regToZ_signed: t -> Z;
  regToZ_unsigned: t -> Z;

  sll: t -> Z -> t;
  srl: t -> Z -> t;
  sra: t -> Z -> t;

  divu: t -> t -> t;
  remu: t -> t -> t;

  maxSigned: t;
  maxUnsigned: t;
  minSigned: t;

  regToShamt5: t -> Z;
  regToShamt: t -> Z;

  highBits: Z -> t;

  (* additional conversions: *)
  ZToReg: Z -> t;

  (* properties of operations: *)
  (* TODO list separately to make them more discoverable by "Search" *)
  regRing: @ring_theory t (ZToReg 0) (ZToReg 1) add mul sub negate (@eq t);
  ZToReg_morphism: @ring_morph t (ZToReg 0) (ZToReg 1) add mul sub negate (@eq t)
                               Z 0 1 Z.add Z.mul Z.sub Z.opp Z.eqb ZToReg;

  reg_eqb_spec: forall a b, reg_eqb a b = true <-> a = b;

  regToZ_signed_bounds: forall a, - 2 ^ (XLEN - 1) <= regToZ_signed a < 2 ^ (XLEN - 1);
  regToZ_unsigned_bounds: forall a, 0 <= regToZ_unsigned a < 2 ^ XLEN;

  add_def_signed: forall a b, add a b = ZToReg (regToZ_signed a + regToZ_signed b);
  sub_def_signed: forall a b, sub a b = ZToReg (regToZ_signed a - regToZ_signed b);
  mul_def_signed: forall a b, mul a b = ZToReg (regToZ_signed a * regToZ_signed b);

  regToZ_ZToReg_signed: forall n : Z,
      - 2 ^ (XLEN - 1) <= n < 2 ^ (XLEN - 1) ->
      regToZ_signed (ZToReg n) = n;
  regToZ_ZToReg_unsigned_mod: forall n : Z, regToZ_unsigned (ZToReg n) = n mod 2 ^ XLEN;

  ZToReg_regToZ_unsigned: forall a: t, ZToReg (regToZ_unsigned a) = a;
  ZToReg_regToZ_signed: forall a: t, ZToReg (regToZ_signed a) = a;

  XLEN_lbound: 8 <= XLEN;

  (* Note: There are 3 ways to define div and mod:
     - truncate division (aka round towards zero, aka "T"), define mod as remainder wrt division
       Defined in Coq in Module ZDivTrunc and available as Z.quot and Z.rem.
       That's also what RISC-V does, according to
       https://github.com/riscv/riscv-isa-manual/commit/3de73dedf7822bf35f0fa603e400c4f25c99b6d9
     - floor division (aka "F"), define mod as remainder wrt division
       Defined in Coq in Module ZDivFloor and available as Z.div and Z.modulo.
     - Euclidian division, where the remainder never is negative (aka "E"):
       forall a b, b<>0 -> exists r q, a = b*q+r /\ 0 < r < |b|
       Defined in Coq in Module ZDivEucl.
     Note: The corner cases (division by 0, overflow) are handled in ExecuteM.
  *)
  div_def : forall a b, div  a b = ZToReg (Z.quot (regToZ_signed   a) (regToZ_signed   b));
  rem_def : forall a b, rem  a b = ZToReg (Z.rem  (regToZ_signed   a) (regToZ_signed   b));
  divu_def: forall a b, divu a b = ZToReg (Z.quot (regToZ_unsigned a) (regToZ_unsigned b));
  remu_def: forall a b, remu a b = ZToReg (Z.rem  (regToZ_unsigned a) (regToZ_unsigned b));
}.

Notation fromImm := (@ZToReg _ _) (only parsing).

Section Derived.

  Context {t: Set}.
  Context {MW: MachineWidth t}.

  Definition XLEN_in_bytes: Z := XLEN / 8.

  Definition lnot(x: t): t := xor x maxUnsigned.

  Lemma reg_eqb_true: forall a b, reg_eqb a b = true -> a = b.
  Proof. apply reg_eqb_spec. Qed.

  Lemma reg_eqb_eq: forall a b, a = b -> reg_eqb a b = true.
  Proof. apply reg_eqb_spec. Qed.

  Lemma reg_eqb_false: forall a b, reg_eqb a b = false -> a <> b.
  Proof.
    intros. intro. rewrite reg_eqb_eq in H; congruence.
  Qed.

  Lemma reg_eqb_ne: forall a b, a <> b -> reg_eqb a b = false.
  Proof.
    intros. destruct (reg_eqb a b) eqn: E; try congruence.
    exfalso. apply H. apply reg_eqb_true in E. assumption.
  Qed.

  Lemma regToZ_ZToReg_unsigned: forall n : Z,
      0 <= n < 2 ^ XLEN ->
      regToZ_unsigned (ZToReg n) = n.
  Proof.
    intros.
    rewrite regToZ_ZToReg_unsigned_mod.
    apply Z.mod_small.
    assumption.
  Qed.

  Lemma add_def_unsigned: forall a b, add a b = ZToReg (regToZ_unsigned a + regToZ_unsigned b).
  Proof.
    intros.
    rewrite ZToReg_morphism.(morph_add). rewrite? ZToReg_regToZ_unsigned.
    reflexivity.
  Qed.

  Lemma sub_def_unsigned: forall a b, sub a b = ZToReg (regToZ_unsigned a - regToZ_unsigned b).
  Proof.
    intros.
    rewrite ZToReg_morphism.(morph_sub). rewrite? ZToReg_regToZ_unsigned.
    reflexivity.
  Qed.

  Lemma mul_def_unsigned: forall a b, mul a b = ZToReg (regToZ_unsigned a * regToZ_unsigned b).
  Proof.
    intros.
    rewrite ZToReg_morphism.(morph_mul). rewrite? ZToReg_regToZ_unsigned.
    reflexivity.
  Qed.

  Lemma ZToReg_inj_unsigned: forall a b,
      0 <= a < 2 ^ XLEN ->
      0 <= b < 2 ^ XLEN ->
      ZToReg a = ZToReg b ->
      a = b.
  Proof.
    intros.
    (* Check (ZToReg_morphism.(morph_eq)). the wrong way *)
  Abort.

End Derived.

Notation "a <|> b" := (or a b)  (at level 50, left associativity) : alu_scope.
Notation "a <&> b" := (and a b) (at level 40, left associativity) : alu_scope.
Notation "a + b"   := (add a b) (at level 50, left associativity) : alu_scope.
Notation "a - b"   := (sub a b) (at level 50, left associativity) : alu_scope.
Notation "a * b"   := (mul a b) (at level 40, left associativity) : alu_scope.

Notation "a /= b" := (negb (reg_eqb a b))        (at level 38, no associativity) : alu_scope.
Notation "a == b" := (reg_eqb a b)               (at level 38, no associativity) : alu_scope.
Notation "a < b"  := (signed_less_than a b)         (at level 70, no associativity) : alu_scope.
Notation "a >= b" := (negb (signed_less_than a b))  (at level 70, no associativity) : alu_scope.
Notation "'when' a b" := (if a then b else Return tt)
  (at level 60, a at level 0, b at level 0) : alu_scope.

Definition machineIntToShamt: MachineInt -> Z := id.