Require Export SystemFR.Syntax.
Require Export SystemFR.WFLemmas.
Require Import Coq.Lists.List.
Import ListNotations.
Open Scope bool_scope.

(* Decidable equality for trees *)
Definition fv_tag_dec : forall (x y : fv_tag), {x = y} + {x <> y}.
Proof.
  intros.
  destruct x, y; try solve [(left; reflexivity) || (right; congruence)].
Defined.

Definition tree_eq_dec : forall (x y : tree), {x = y} + {x <> y}.
Proof.
  repeat decide equality || apply fv_tag_dec.
Defined.
Definition tree_eq t1 t2 : bool := if (tree_eq_dec t1 t2) then true else false.

Lemma tree_eq_prop : forall t1 t2, (tree_eq t1 t2 = true) <-> t1 = t2.
Proof.
  unfold tree_eq.
  steps.
Qed.

Definition mod_tree_eq a b t1 t2 :=
  exists C, t1 = open 0 C a /\ t2 = open 0 C b.

(* If t and t' are equal modulo substitutions of a for b, it returns true
 *)
Fixpoint mod_tree_eqb t1 t2 a b : bool :=
  if (tree_eq t1 t2) then true
  else
    if (tree_eq t1 a && tree_eq t2 b) then true
    else
      match (t1, t2) with
      | (err T1, err T2) => mod_tree_eqb T1 T2 a b
      | (tsize t1, tsize t2) => mod_tree_eqb t1 t2 a b

      | (notype_lambda t1, notype_lambda t2) => mod_tree_eqb t1 t2 a b
      | (lambda T1 t1, lambda T2 t2) => (mod_tree_eqb T1 T2 a b) && (mod_tree_eqb t1 t2 a b)

      | ((pp t11 t12), (pp t21 t22)) => (mod_tree_eqb t11 t21 a b) && (mod_tree_eqb t12 t22 a b)
      | _ => false
      end
.

Lemma mod_tree_eqb_correct :
  forall a b t2 t1,
    wf t1 0 ->
    wf t2 0 ->
    mod_tree_eqb t1 t2 a b = true ->
    mod_tree_eq t1 t2 a b.
Proof.
  unfold mod_tree_eq; intros.
  unfold mod_tree_eqb in H1.
Abort.


(* -*- coq-prog-args: ("-emacs-U" "-R" "." "FingerTree" "-R" "../safe" " "-R" "../monads" ") -*- *)
Require Import Coq.subtac.Utils.
Require Import Coq.Lists.List.
Require Import Monoid.
Set Implicit Arguments.

Section ListMonoid.
  Variable A : Type.

  Program Definition listMonoid := @mkMonoid (list A) nil (@app A) _ _ _.

  Next Obligation.
  Proof.
    intros.
    red ; intros.
    rewrite app_nil_end ; reflexivity.
  Qed.

  Next Obligation.
  Proof.
    intros.
    red ; intros.
    apply app_ass.
  Qed.

End ListMonoid.


Section ml.
Variables A B:Prop.
Theorem AndABBA: iff A B -> B -> A.
Proof.
    intros Hab Hb.
    apply Hab.
    assumption.
Qed.
End ml.

Check AndABBA.


Require Import Coq.Lists.List.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Lists.SetoidList.
Require Import Rewriter.Util.Option.

Import ListNotations.

Lemma list_elementwise_eqlistA : forall {T R} (l1 l2 : list T),
  (forall i, option_eq R (nth_error l1 i) (nth_error l2 i)) -> eqlistA R l1 l2.
Proof.
  induction l1, l2; intros H; try solve [ constructor ];
    pose proof (H 0%nat) as Hfirst; cbn in Hfirst; try solve [ inversion Hfirst ].
  constructor; [ assumption | ].
  apply IHl1.
  intros i; specialize (H (S i)).
  assumption.
Qed.

Lemma nth_error_Proper_eqlistA {T R}
  : Proper (eqlistA R ==> eq ==> option_eq R) (@nth_error T).
Proof.
  intros ls1 ls2 Hls n n' ?; subst n'.
  revert ls1 ls2 Hls.
  induction n; intros ls1 ls2 Hls; destruct Hls; cbn; auto.
Qed.

Lemma eqlistA_eq_iff {A}
  : forall ls1 ls2, eqlistA (@eq A) ls1 ls2 <-> ls1 = ls2.
Proof.
  induction ls1 as [|x xs IHxs], ls2 as [|y ys].
  all: split; intro H; inversion_clear H; repeat constructor; subst; f_equal; try reflexivity.
  apply IHxs; assumption.
Qed.

Lemma InA_map A B (f : A -> B) (eqA eqB : relation _) a b l
      (f_Proper_a_b : forall v, eqA a v -> eqB b (f v))
  : InA eqA a l -> InA eqB b (List.map f l).
Proof.
  rewrite !InA_alt.
  intros [v H]; exists (f v); split; [ now apply f_Proper_a_b | now apply in_map ].
Qed.

Lemma InA_map_iff A B (f : A -> B) (eqA eqB : relation _) a b l
      (f_Proper_a_b : forall v, eqA a v <-> eqB b (f v))
  : InA eqB b (List.map f l) <-> InA eqA a l.
Proof.
  split; [ | solve [ apply InA_map, f_Proper_a_b ] ].
  rewrite !InA_alt; intros [v [H1 H2]].
  induction l as [|? ? IH]; cbn [List.map List.In] in *;
    [ easy | ].
  destruct H2; subst; firstorder eauto.
Qed.

Lemma NoDupA_map_inv A B (f : A -> B) (eqA eqB : relation _) (l : list A)
      {f_Proper : Proper (eqA ==> eqB) f}
  : NoDupA eqB (List.map f l) -> NoDupA eqA l.
Proof.
  induction l as [|? ? IH]; cbn [List.map]; intro H; inversion_clear H;
    [ constructor | ].
  specialize (IH ltac:(assumption)).
  constructor; [ | assumption ].
  let H := match goal with H : ~ InA _ _ _ |- _ => H end in
  intro H'; apply H; clear H.
  eapply InA_map; [ | eassumption ].
  intro; apply f_Proper.
Qed.

Global Instance InA_Proper_impl {A} {eqA : relation A}
       {eqA_Proper : Proper (eqA ==> eqA ==> Basics.impl) eqA}
  : Proper (eqA ==> eqlistA eqA ==> Basics.impl) (@InA A eqA) | 10.
Proof.
  cbv [Basics.impl] in *.
  intros a a' Ha l l' Hl.
  induction Hl as [|?????? IH].
  { intro H'; inversion H'. }
  { intro H'; inversion_clear H';
      try solve [ constructor; eapply eqA_Proper; eassumption
                | constructor; eauto ]. }
Qed.

Global Instance InA_Proper_flip_impl {A} {eqA : relation A}
       {eqA_Proper : Proper (eqA ==> eqA ==> Basics.flip Basics.impl) eqA}
  : Proper (eqA ==> eqlistA eqA ==> Basics.flip Basics.impl) (@InA A eqA) | 10.
Proof.
  cbv [Basics.impl] in *.
  intros a a' Ha l l' Hl.
  induction Hl as [|?????? IH].
  { intro H'; inversion H'. }
  { intro H'; inversion_clear H';
      try solve [ constructor; eapply eqA_Proper; eassumption
                | constructor; eauto ]. }
Qed.

(** We could just use [now typeclasses eauto with core] in Coq >= 8.10, but it doesn't work in 8.9 :-( *)
Local Ltac grepeat_eapply :=
  multimatch goal with
  | [ H : _ |- _ ] => eapply H; clear H
  end;
  solve [ grepeat_eapply ].

Global Instance InA_Proper_iff {A} {eqA : relation A}
       {eqA_Proper : Proper (eqA ==> eqA ==> iff) eqA}
  : Proper (eqA ==> eqlistA eqA ==> iff) (@InA A eqA) | 10.
Proof.
  unshelve (split; (eapply InA_Proper_impl + eapply InA_Proper_flip_impl); assumption).
  all: repeat intro; solve [ edestruct eqA_Proper; grepeat_eapply ].
Qed.

Global Instance NoDupA_Proper_eqlistA_impl {A eqA}
       {eqA_Proper : Proper (eqA ==> eqA ==> flip impl) eqA}
  : Proper (eqlistA eqA ==> impl) (@NoDupA A eqA) | 10.
Proof.
  cbv [flip impl].
  intros l1 l2 Hl.
  induction Hl as [|? ? ? ? ? ? IH].
  { constructor. }
  { intro H'; inversion_clear H'; constructor; eauto.
    all: match goal with
         | [ H : ~InA _ _ _ |- ~ InA _ _ _ ] => intro H'; apply H; clear H
         end.
    eapply InA_Proper_flip_impl; eassumption. }
Qed.

Global Instance NoDupA_Proper_eqlistA_flip_impl {A eqA}
       {eqA_Proper : Proper (eqA ==> eqA ==> impl) eqA}
  : Proper (eqlistA eqA ==> flip impl) (@NoDupA A eqA) | 10.
Proof.
  cbv [flip impl].
  intros l1 l2 Hl.
  induction Hl as [|? ? ? ? ? ? IH].
  { constructor. }
  { intro H'; inversion_clear H'; constructor; eauto.
    all: match goal with
         | [ H : ~InA _ _ _ |- ~ InA _ _ _ ] => intro H'; apply H; clear H
         end.
    eapply InA_Proper_impl; eassumption. }
Qed.

Global Instance NoDupA_Proper_eqlistA_iff {A eqA}
       {eqA_Proper : Proper (eqA ==> eqA ==> iff) eqA}
  : Proper (eqlistA eqA ==> iff) (@NoDupA A eqA) | 10.
Proof.
  unshelve (split; (eapply NoDupA_Proper_eqlistA_impl + eapply NoDupA_Proper_eqlistA_flip_impl); assumption).
  all: repeat intro; solve [ edestruct eqA_Proper; grepeat_eapply ].
Qed.


Require Import Coq.Init.Datatypes.
Require Import Coq.Lists.List.
Import ListNotations.

Module Nondeterminism.
  Record t (A : Type) := mk { ahead : list A;
                                       behind : list A;
                                       default : A; }.

  Definition Decider {A : Type} (s : t A) : (t A * A) :=
    match ahead A s with
      [] => let rev_behind := List.rev (behind A s) in
            match rev_behind with
              [] => (mk A [] [] (default A s), default A s)
            | h::t => (mk A t (h::[]) (default A s), h)
            end
    | h::t => (mk A t (h::(behind A s)) (default A s), h)
    end.

  Definition init {A : Type} (pattern : list A) (default_val : A)
    : t A :=
    mk A pattern [] default_val.

  Fixpoint ToListN {A : Type} (s : t A) (n : nat) : list A :=
    match n with
    | 0 => []
    | S p =>
        let '(s, a) := Decider s in
        a :: (ToListN s p)
    end.

  Example test_repeats
    : ToListN (init [1; 2; 3] 4) 7 = [1; 2; 3; 1; 2; 3; 1].
  Proof.
    simpl.
    reflexivity.
  Qed.

  Example test_defaults : ToListN (init [] 4) 3 = [4; 4; 4].
  Proof.
    simpl.
    reflexivity.
  Qed.
End Nondeterminism.

Module Countdown.
  Record t :=
    mk { starting : nat; current : nat }.

  Definition init (starting_val : nat) : t :=
    {| starting := starting_val;
      current := starting_val |}.

  Definition reset (countdown : t) : t :=
    init (starting countdown).

  Definition decrement
    (countdown : t) (decrement_val : nat) : t :=
    {| starting := starting countdown;
      current := (current countdown) - decrement_val |}.

  Search (nat -> nat -> bool).

  Definition at_zero
    (countdown : t)
    : bool :=
    Nat.eqb (current countdown) 0.

  Example test_init1 : at_zero (init 0) = true.
  Proof.
    simpl.
    reflexivity.
  Qed.

  Example test_init2 : at_zero (init 1) = false.
  Proof.
    simpl.
    reflexivity.
  Qed.

  Example test_decr1 : forall x y : nat, x - y = 0 -> at_zero (decrement (init x) y) = true.
  Proof.
    intros x y H.
    unfold init.
    unfold decrement.
    unfold at_zero.
    unfold current.
    rewrite H.
    simpl.
    reflexivity.
  Qed.

  Example test_decr2 : at_zero (decrement (init 5) 3) = false.
  Proof.
    simpl.
    reflexivity.
  Qed.

  Example test_decr3 : at_zero (decrement (decrement (init 5) 3) 3) = true.
  Proof.
    simpl.
    reflexivity.
  Qed.

  Example test_reset : at_zero (decrement (reset (decrement (init 5) 3)) 3) = false.
  Proof.
    simpl.
    reflexivity.
  Qed.
End Countdown.

Module Name.
  Inductive t :=
    Sender
  | Receiver.

  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
    decide equality.
  Defined.
End Name.

Module Seq.
  Inductive t :=
    Zero
  | One.
  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
    decide equality.
  Defined.

  Definition flip (t : t) :=
    match t with
    | Zero => One
    | One => Zero
    end.

  Definition eq (a b : t) :=
    match (a, b) with
    | (Zero, Zero) | (One, One) => true
    | (_, _) => false
    end.
End Seq.

Module Packet.
  Definition t := nat.
  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
    decide equality.
  Defined.
End Packet.

Module Msg.
  Inductive t : Type :=
    Send : Packet.t -> Seq.t -> t
  | Ack : Seq.t -> t.
  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
    decide equality.
    - (* Seq *)
      apply Seq.eq_dec.
    - (* Packet *)
      apply Packet.eq_dec.
    - (* Seq *)
      apply Seq.eq_dec.
  Defined.
End Msg.

Module SendOrDrop.
  Inductive t :=
  | Send
  | Drop.
  Definition eq_dec
    : forall x y : t, {x = y} + {x <> y}.
    decide equality.
  Defined.
End SendOrDrop.

Module Input.
  Module ToSender.
    Inductive t : Type :=
      Packet : Packet.t -> t.
    Definition eq_dec
      : forall x y : t, {x = y} + {x <> y}.
      decide equality.
      - (* UserToSender *)
        apply Packet.eq_dec.
    Defined.
  End ToSender.

  Module ToReceiver.
    Inductive t : Type := .
    Definition eq_dec
      : forall x y : t, {x = y} + {x <> y}.
      decide equality.
    Defined.
  End ToReceiver.

  Module ToNetwork.
    Inductive t := .
    Definition eq_dec
      : forall x y : t, {x = y} + {x <> y}.
      decide equality.
    Defined.
  End ToNetwork.

  Inductive t :=
    Sender : ToSender.t -> t
  | Receiver : ToReceiver.t -> t
  | Network : ToNetwork.t -> t
  | Poll : t.
  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
    decide equality.
    - (* Sender *)
      apply ToSender.eq_dec.
    - (* Receiver *)
      apply ToReceiver.eq_dec.
    - (* Network *)
      apply ToNetwork.eq_dec.
  Defined.

  Definition packet (n : nat) :=
    Sender (ToSender.Packet n).

End Input.

Module Output.
  Module FromSender.
    Inductive t :=
      Reject : Packet.t -> t.
    Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
      decide equality.
      - (* Packet *)
        apply Packet.eq_dec.
    Defined.
  End FromSender.

  Module FromReceiver.
    Inductive t :=
      Success : Packet.t -> t.
    Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
      decide equality.
      - (* Packet *)
        apply Packet.eq_dec.
    Defined.
  End FromReceiver.

  Inductive t :=
    SenderOutput : FromSender.t -> t
  | ReceiverOutput : FromReceiver.t -> t.
  (*| Debug : -> t.*)
  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
    decide equality.
    - (* FromSender *)
      apply FromSender.eq_dec.
    - (* FromReceiver *)
      apply FromReceiver.eq_dec.
  Defined.
End Output.

Module State.
  Module Sender.
    Record t
      := mk { sent_unacked : option Packet.t;
              timeout : Countdown.t;
              seq : Seq.t;
              outgoing : list Msg.t}.

    Definition init (timeout_val : nat) : t :=
      mk None (Countdown.init timeout_val) Seq.Zero [].

    Definition append_outgoing
      (sender : t) (additional_outgoing : list Msg.t)
      : t :=
      {| sent_unacked := sent_unacked sender;
        timeout := timeout sender;
        seq := seq sender;
        outgoing := (outgoing sender) ++ additional_outgoing |}.

    Definition set_sent_unacked_reset_timer
      (sender : t) (packet : Packet.t)
      : t :=
      {| sent_unacked := Some packet;
        timeout := Countdown.reset (timeout sender);
        seq := seq sender;
        outgoing := outgoing sender |}.

    Definition flip_seq
      (sender : t)
      : t :=
      {| sent_unacked := sent_unacked sender;
        timeout := timeout sender;
        seq := Seq.flip (seq sender);
        outgoing := outgoing sender |}.

    Definition flush_outgoing
      (sender : t)
      : list Msg.t * t :=
      (outgoing sender,
        {| sent_unacked := sent_unacked sender;
          timeout := timeout sender;
          seq := seq sender;
          outgoing := [] |}).

    Definition decrement_timeout
      (sender : t) (decrement_val : nat)
      : t :=
      {| sent_unacked := sent_unacked sender;
        timeout := Countdown.decrement (timeout sender) decrement_val;
        seq := seq sender;
        outgoing := outgoing sender |}.

    Definition timeout_expired
      (sender : t)
      : bool :=
      Countdown.at_zero (timeout sender).

    Definition receive_ack
      (sender : t) (ack_seq : Seq.t)
      : t :=
      match Seq.eq ack_seq (seq sender) with
          | true =>
              {| sent_unacked := None;
                timeout := Countdown.reset (timeout sender);
                seq := Seq.flip ack_seq;
                outgoing := outgoing sender |}
          | false =>
              sender
      end.

    Definition update_by_poll
      (sender : t)
      : list Output.t * t :=
      match sent_unacked sender with
      | None =>
          ([], sender)
      | Some in_flight =>
          let seq := seq sender in
          let sender_timeout_decr :=
            decrement_timeout
              sender
              1 in
          match timeout_expired sender_timeout_decr with
          | true =>
              let sender_timeout_reset :=
                set_sent_unacked_reset_timer
                  sender
                  in_flight in
              let message := Msg.Send in_flight seq in
              let sender :=
                append_outgoing
                  sender_timeout_reset
                  [message] in
              ([],
                sender)
          | false =>
              ([],
                sender_timeout_decr)
          end
      end.

    Definition poll
      (sender : t)
      : list Output.t * list Msg.t * t :=
      let (outputs, sender) := update_by_poll sender in
      let (outgoing, sender) := flush_outgoing sender in
      (outputs, outgoing, sender).

    Definition handle_message
      (sender : t) (message : Msg.t)
      : list Output.t * t :=
      match message with
      | Msg.Send _ _ => ([], sender)
      | Msg.Ack ack_seq =>
          ([], receive_ack sender ack_seq)
      end.

    Fixpoint rec_handle_messages
      (sender : t) (messages : list Msg.t) (accum_outputs : list Output.t)
      : list Output.t * t :=
      match messages with
      | [] => (accum_outputs, sender)
      | first::rest =>
          let '(additional_outputs, sender) :=
            handle_message sender first in
          rec_handle_messages
            sender
            rest
            (accum_outputs ++ additional_outputs)
      end.

    Definition handle_messages
      (sender : t) (messages : list Msg.t)
      : list Output.t * t :=
      rec_handle_messages sender messages [].

    Definition handle_input
      (sender : t) (input : Input.ToSender.t)
      : list Output.t * t :=
      let seq := seq sender in
      match input with
      | Input.ToSender.Packet packet =>
          match sent_unacked sender with
          | None =>
              let messages := [Msg.Send packet seq] in
              let sender := append_outgoing sender messages in
              let sender := set_sent_unacked_reset_timer sender packet in
              ([], sender)
          | Some in_flight =>
              ([Output.SenderOutput (Output.FromSender.Reject packet)],
                sender)
          end
      end.
  End Sender.

  Module Receiver.
    Record t
      := mk { seq : Seq.t;
              outgoing : list Msg.t}.

    Definition init : t :=
      mk Seq.Zero [].

    Definition append_outgoing
      (receiver : t) (additional_outgoing : list Msg.t)
      : t :=
      {| seq := seq receiver;
        outgoing := (outgoing receiver) ++ additional_outgoing |}.

    Definition flip_seq
      (receiver : t)
      : t :=
      {| seq := Seq.flip (seq receiver);
        outgoing := outgoing receiver |}.

    Definition flush_outgoing
      (receiver : t)
      : list Msg.t * t :=
      (outgoing receiver,
        {| seq := seq receiver;
          outgoing := [] |}).

    Definition update_by_poll
      (receiver : t)
      : list Output.t * t :=
      ([], receiver).

    Definition poll
      (receiver : t)
      : list Output.t * list Msg.t * t :=
      let (outputs, receiver) := update_by_poll receiver in
      let (outgoing, receiver) := flush_outgoing receiver in
      (outputs, outgoing, receiver).

    Definition handle_message
      (receiver : t) (message : Msg.t)
      : list Output.t * t :=
      match message with
      | Msg.Ack _ => ([], receiver)
      | Msg.Send packet packet_seq =>
          let outputs :=
            match Seq.eq packet_seq (seq receiver) with
            | true =>
                [Output.ReceiverOutput
                   (Output.FromReceiver.Success packet)]
            | false => []
            end
          in
          let outgoing := Msg.Ack packet_seq::(outgoing receiver) in
          (outputs, mk (Seq.flip packet_seq) outgoing)
      end.

    Fixpoint rec_handle_messages
      (receiver : t)
      (messages : list Msg.t)
      (accum_outputs : list Output.t)
      : list Output.t * t :=
      match messages with
      | [] => (accum_outputs, receiver)
      | first::rest =>
          let '(additional_outputs, receiver) :=
            handle_message receiver first in
          rec_handle_messages
            receiver
            rest
            (accum_outputs ++ additional_outputs)
      end.

    Definition handle_messages
      (receiver : t) (messages : list Msg.t)
      : list Output.t * t :=
      rec_handle_messages receiver messages [].

    Definition handle_input
      (receiver : t) (input : Input.ToReceiver.t)
      : list Output.t * t :=
      ([], receiver).
  End Receiver.

  Module Network.
    Module NodeSpecific.
      Record t
        := mk { in_network : list Msg.t;
                drop_decider : Nondeterminism.t SendOrDrop.t;
                delay_decider : Nondeterminism.t Countdown.t;
                next_delay : Countdown.t}.

      Definition init
        (drop_pattern : list SendOrDrop.t) (delay_pattern : list nat)
        : t :=
        let delay_pattern :=
          List.map (fun delay => Countdown.init delay) delay_pattern in
        let delay_decider :=
          Nondeterminism.init delay_pattern (Countdown.init 0) in
        let (delay_decider, next_delay) :=
          Nondeterminism.Decider delay_decider in
        mk
          []
          (Nondeterminism.init drop_pattern SendOrDrop.Send)
          delay_decider
          next_delay.

      Fixpoint decide_on_messages
        (accum_outputs : list Output.t)
        (accum_outgoing : list Msg.t)
        (in_network : list Msg.t)
        (drop_decider : Nondeterminism.t SendOrDrop.t)
        (delay_decider : Nondeterminism.t Countdown.t)
        (next_delay : Countdown.t)
        : list Output.t * list Msg.t * t :=
        match in_network with
        | [] =>
            (accum_outputs, accum_outgoing,
              mk in_network drop_decider delay_decider next_delay)
        | head_packet::tail_packets =>
            match Countdown.at_zero next_delay with
            | true =>
                let (delay_decider, next_delay) :=
                  Nondeterminism.Decider delay_decider in
                let (drop_decider, next_decision) :=
                  Nondeterminism.Decider drop_decider in
                let accum_outgoing :=
                  match next_decision with
                  | SendOrDrop.Send => accum_outgoing ++ [head_packet]
                  | SendOrDrop.Drop => accum_outgoing
                  end in
                decide_on_messages
                  accum_outputs
                  accum_outgoing
                  tail_packets
                  drop_decider
                  delay_decider
                  next_delay
            | false =>
                (accum_outputs, accum_outgoing,
                  mk in_network drop_decider delay_decider next_delay)
            end
        end.

      Definition poll
        (network : t)
        : list Output.t * list Msg.t * t :=
        let '(outputs, messages, network) :=
          let accum_outputs := [] in
          let accum_outgoing := [] in
          decide_on_messages
            accum_outputs
            accum_outgoing
            (in_network network)
            (drop_decider network)
            (delay_decider network)
            (next_delay network) in
        match in_network network with
        | [] => (outputs, messages, network)
        | _ =>
            (outputs,
              messages,
              {| in_network := in_network network;
                drop_decider := drop_decider network;
                delay_decider := delay_decider network;
                next_delay :=
                  Countdown.decrement (next_delay network) 1 |})
        end.

      Definition handle_messages
        (network : t) (messages : list Msg.t)
        : list Output.t * t :=
        ([],
          {| in_network := (in_network network) ++ messages;
            drop_decider := drop_decider network;
            delay_decider := delay_decider network;
            next_delay := next_delay network |}).

      Definition handle_input
        (network : t) (input : Input.ToNetwork.t)
        : list Output.t * t :=
        ([], network).

    End NodeSpecific.

    Record t
      := mk { sender_network : NodeSpecific.t;
              receiver_network : NodeSpecific.t}.

    Definition init
      (drop_patterns : Name.t -> list SendOrDrop.t)
      (delay_patterns : Name.t -> list nat)
      : t :=
      {| sender_network :=
          NodeSpecific.init
            (drop_patterns Name.Sender)
            (delay_patterns Name.Sender);
        receiver_network :=
          NodeSpecific.init
            (drop_patterns Name.Receiver)
            (delay_patterns Name.Receiver) |}.

    Definition poll
      (network : t)
      : list Output.t * (list Msg.t * list Msg.t) * t :=
      let '(sender_outputs, sender_messages, sender_net) :=
        NodeSpecific.poll (sender_network network) in
      let '(receiver_outputs, receiver_messages, receiver_net) :=
        NodeSpecific.poll (receiver_network network) in
      (sender_outputs ++ receiver_outputs,
        (sender_messages, receiver_messages),
        {| sender_network := sender_net;
          receiver_network := receiver_net |}).

    Definition handle_messages
      (network : t) (recipient : Name.t) (messages : list Msg.t)
      : list Output.t * t :=
      let '(outputs, sender_net, receiver_net) :=
        match recipient with
        | Name.Sender =>
            let '(sender_outputs, sender_net) :=
              NodeSpecific.handle_messages
                (sender_network network)
                messages in
            (sender_outputs, sender_net, (receiver_network network))
        | Name.Receiver =>
            let '(receiver_outputs, receiver_net) :=
              NodeSpecific.handle_messages
                (receiver_network network)
                messages in
            (receiver_outputs, (sender_network network), receiver_net)
        end in
      (outputs,
        {| sender_network := sender_net;
          receiver_network := receiver_net |}).

    Definition handle_input
      (network : t) (input : Input.ToNetwork.t)
      : list Output.t * t :=
      ([], network).

  End Network.
End State.

Module StopAndWait.
(*  Fixpoint rec_feed_messages_ends
    (sender : State.Sender.t) (receiver : State.Receiver.t)
    (messages : list (Msg.t * Name.t)) (accum_output : list Output.t)
    : (list Output.t * State.Sender.t * State.Receiver.t) :=
    match messages with
    | [] => (accum_output, sender, receiver)
    | message::tail =>
        let '(additional_output, sender, receiver) :=
          match message with
          | (content, Name.Sender) =>
              let '(sender_output, sender) :=
                State.Sender.handle_message
                  sender
                  content in
              (sender_output, sender, receiver)

          | (content, Name.Receiver) =>
              let '(receiver_output, receiver) :=
                State.Receiver.handle_message
                  receiver
                  content in
              (receiver_output, sender, receiver)
          end in
        rec_feed_messages_ends
          sender
          receiver
          tail
          (accum_output ++ additional_output)
    end.

  Definition feed_messages_ends
    (sender : State.Sender.t) (receiver : State.Receiver.t)
    (messages : list (Msg.t * Name.t))
    : (list Output.t * State.Sender.t * State.Receiver.t) :=
    rec_feed_messages_ends sender receiver messages [].
*)
  Fixpoint rec_simulate
    (steps : nat)
    (inputs : Nondeterminism.t Input.t)
    (sender : State.Sender.t)
    (receiver : State.Receiver.t)
    (network : State.Network.t)
    (accum_output : list Output.t)
    : (State.Sender.t * State.Receiver.t * State.Network.t * list Output.t) :=
    match steps with
    | 0 => (sender, receiver, network, accum_output)
    | S p =>
        let '(inputs, input) := Nondeterminism.Decider inputs in
        let '(sender, receiver, network, outputs) :=
          match input with
          | Input.Sender in_to_sender =>
              let '(sender_output, sender) :=
                State.Sender.handle_input sender in_to_sender in
              (sender, receiver, network, sender_output)

          | Input.Receiver in_to_receiver =>
              let '(receiver_output, receiver) :=
                State.Receiver.handle_input receiver in_to_receiver in
              (sender, receiver, network, receiver_output)

          | Input.Network in_to_network =>
              let '(network_output, network) :=
                State.Network.handle_input network in_to_network in
              (sender, receiver, network, network_output)

          | Input.Poll =>
              let '(outputs_poll_sender, from_sender, sender) :=
                State.Sender.poll sender in
              let '(outputs_poll_receiver, from_receiver, receiver) :=
                State.Receiver.poll receiver in
              let '(outputs_poll_network,
                      (to_receiver, to_sender), network) :=
                State.Network.poll network in
              let '(outputs_feed_sender, sender) :=
                State.Sender.handle_messages sender to_sender in
              let '(outputs_feed_receiver, receiver) :=
                State.Receiver.handle_messages receiver to_receiver in
              let '(outputs_sender_feed_network, network) :=
                State.Network.handle_messages
                  network
                  Name.Sender
                  from_sender in
              let '(outputs_receiver_feed_network, network) :=
                State.Network.handle_messages
                  network
                  Name.Receiver
                  from_receiver in
              (sender, receiver, network,
                outputs_poll_sender ++
                  outputs_poll_receiver ++
                  outputs_poll_network ++
                  outputs_feed_sender ++
                  outputs_feed_receiver ++
                  outputs_sender_feed_network ++
                  outputs_receiver_feed_network)
          end in
        rec_simulate
          p
          inputs
          sender receiver network
          (accum_output ++ outputs)
    end.

  Definition pack {T : Type}
    (sender_part : T) (receiver_part : T) (name : Name.t) :=
    match name with
    | Name.Sender => sender_part
    | Name.Receiver => receiver_part
    end.

  Definition simulate
    (steps : nat)
    (inputs : list Input.t)
    (sender_drop_pattern : list SendOrDrop.t)
    (receiver_drop_pattern : list SendOrDrop.t)
    (sender_delay_pattern : list nat)
    (receiver_delay_pattern : list nat)
    (sender_timeout : nat) :
    (State.Sender.t *
       State.Receiver.t *
       State.Network.t *
       list Output.t) :=
    let sender_start := State.Sender.init sender_timeout in
    let receiver_start := State.Receiver.init in
    let network_start :=
      State.Network.init
        (pack sender_drop_pattern receiver_drop_pattern)
        (pack sender_delay_pattern receiver_delay_pattern) in
    let inputs := Nondeterminism.init inputs Input.Poll in
    rec_simulate
      steps inputs sender_start receiver_start network_start [].

End StopAndWait.

Module SuccessfulSend.

  Definition packet := Input.packet.
  Definition poll := Input.Poll.

  Definition steps := 3.
  Definition inputs := [poll; poll].
  Definition sender_drop_pattern : list SendOrDrop.t := [].
  Definition receiver_drop_pattern : list SendOrDrop.t := [].
  Definition sender_delay_pattern : list nat := [].
  Definition receiver_delay_pattern : list nat := [].
  Definition sender_timeout := 5.

  Definition result (packet_val : nat) :=
    StopAndWait.simulate
      steps
      ((packet packet_val)::inputs)
      sender_drop_pattern
      receiver_drop_pattern
      sender_delay_pattern
      receiver_delay_pattern
      sender_timeout.

  Compute result 5.

 (* Definition result_sender :=
    State.Sender.mk
      (Some 5)
      (Countdown.decrement (Countdown.init 5) 2)
      Seq.Zero
      [].

  Definition result_receiver :=
    State.Receiver.mk
      Seq.One
      [Msg.Ack Seq.Zero].

  Definition result_network :=
    State.Network.mk
      (State.Network.NodeSpecific.mk
         []
   *)

  Lemma sends_1 :
    forall packet_val, exists sender, exists receiver, exists network,
    result packet_val =
      (sender, receiver, network, [Output.ReceiverOutput (Output.FromReceiver.Success packet_val)]).
  Proof.
    intro packet_val.
    unfold result.
    unfold StopAndWait.simulate.
    unfold StopAndWait.rec_simulate.


(*******************************************************************

 Limits in bicategories of structured categories

 We look at terminal objects, products, pullbacks, and
 Eilenberg-Moore objects

 Contents
 1. Limits of categories with a terminal objects
 2. Limits of categories with products
 3. Limits of categories with pullbacks
 4. Limits of categories with finite limits
 5. Limits of categories with initial objects
 6. Limits of categories with coproducts

 *******************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.categories.EilenbergMoore.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.IsoCommaCategory.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.Preservation.
Require Import UniMath.CategoryTheory.limits.Examples.UnitCategoryLimits.
Require Import UniMath.CategoryTheory.limits.Examples.CategoryProductLimits.
Require Import UniMath.CategoryTheory.limits.Examples.IsoCommaLimits.
Require Import UniMath.CategoryTheory.limits.Examples.EilenbergMooreLimits.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Core.Examples.StructuredCategories.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.Limits.Final.
Require Import UniMath.Bicategories.Limits.Products.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects.
Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits.
Require Import UniMath.Bicategories.Limits.Examples.TotalBicategoryLimits.
Require Import UniMath.Bicategories.Limits.Examples.DispConstructionsLimits.
Require Import UniMath.Bicategories.Limits.Examples.SubbicatLimits.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInTotalBicat.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion.

Local Open Scope cat.

(**
 1. Limits of categories with a terminal objects
 *)
Definition disp_bifinal_univ_cat_with_terminal_obj
  : disp_bifinal_obj disp_bicat_terminal_obj bifinal_cats.
Proof.
  use subbicat_disp_final.
  - exact terminal_unit_category.
  - intros C.
    apply functor_to_unit_preserves_terminal.
Defined.

Definition bifinal_obj_univ_cat_with_terminal_obj
  : bifinal_obj univ_cat_with_terminal_obj.
Proof.
  use subbicat_final.
  - exact bifinal_cats.
  - exact terminal_unit_category.
  - intros C.
    apply functor_to_unit_preserves_terminal.
Defined.

Definition disp_has_binprod_univ_cat_with_terminal_obj
  : disp_has_binprod disp_bicat_terminal_obj has_binprod_bicat_of_univ_cats.
Proof.
  use subbicat_disp_binprod.
  - exact (λ C₁ C₂, terminal_category_binproduct (pr22 C₁) (pr22 C₂)).
  - intros C₁ C₂.
    apply pr1_preserves_terminal.
  - intros C₁ C₂.
    apply pr2_preserves_terminal.
  - intros C₁ C₂ q.
    apply preserves_terminal_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition has_binprod_univ_cat_with_terminal_obj
  : has_binprod univ_cat_with_terminal_obj.
Proof.
  use subbicat_binprod.
  - exact has_binprod_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - exact (λ C₁ C₂, terminal_category_binproduct (pr22 C₁) (pr22 C₂)).
  - intros C₁ C₂.
    apply pr1_preserves_terminal.
  - intros C₁ C₂.
    apply pr2_preserves_terminal.
  - intros C₁ C₂ q.
    apply preserves_terminal_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition disp_has_pb_univ_cat_with_terminal_obj
  : disp_has_pb disp_bicat_terminal_obj has_pb_bicat_of_univ_cats.
Proof.
  use subbicat_disp_has_pb.
  - exact (λ C₁ C₂ C₃ F G,
           terminal_category_iso_comma
             _ _
             (pr12 F) (pr12 G)
             (pr22 C₁) (pr22 C₂)).
  - exact (λ C₁ C₂ C₃ F G,
           iso_comma_pr1_preserves_terminal
             _ _
             (pr12 F) (pr12 G)
             (pr22 C₁) (pr22 C₂)).
  - exact (λ C₁ C₂ C₃ F G,
           iso_comma_pr2_preserves_terminal
             _ _
             (pr12 F) (pr12 G)
             (pr22 C₁) (pr22 C₂)).
  - exact (λ C₁ C₂ C₃ F G q,
           iso_comma_ump1_preserves_terminal
             _ _
             (pr12 G)
             _ (pr12 (pb_cone_pr1 q))
             _ (pr12 (pb_cone_pr2 q))
             _).
Defined.

Definition has_pb_univ_cat_with_terminal_obj
  : has_pb univ_cat_with_terminal_obj.
Proof.
  use subbicat_has_pb.
  - exact has_pb_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - exact (λ C₁ C₂ C₃ F G,
           terminal_category_iso_comma
             _ _
             (pr12 F) (pr12 G)
             (pr22 C₁) (pr22 C₂)).
  - exact (λ C₁ C₂ C₃ F G,
           iso_comma_pr1_preserves_terminal
             _ _
             (pr12 F) (pr12 G)
             (pr22 C₁) (pr22 C₂)).
  - exact (λ C₁ C₂ C₃ F G,
           iso_comma_pr2_preserves_terminal
             _ _
             (pr12 F) (pr12 G)
             (pr22 C₁) (pr22 C₂)).
  - exact (λ C₁ C₂ C₃ F G q,
           iso_comma_ump1_preserves_terminal
             _ _
             (pr12 G)
             _ (pr12 (pb_cone_pr1 q))
             _ (pr12 (pb_cone_pr2 q))
             _).
Defined.

Definition has_em_univ_cat_with_terminal_obj
  : bicat_has_em univ_cat_with_terminal_obj.
Proof.
  use subbicat_has_em.
  - exact has_em_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - exact (λ m,
           terminal_eilenberg_moore_cat _ (pr22 (ob_of_mnd m))).
  - exact (λ m,
           eilenberg_moore_pr_preserves_terminal _ (pr22 (ob_of_mnd m))).
  - intros m q.
    use functor_to_eilenberg_moore_cat_preserves_terminal.
    exact (pr12 (mor_of_mnd_mor (mor_of_em_cone m q))).
Defined.

(**
 2. Limits of categories with products
 *)
Definition disp_bifinal_obj_univ_cat_with_binprod
  : disp_bifinal_obj disp_bicat_binprod bifinal_cats.
Proof.
  use subbicat_disp_final.
  - exact binproduct_unit_category.
  - intro.
    apply functor_to_unit_preserves_binproduct.
Defined.

Definition bifinal_obj_univ_cat_with_binprod
  : bifinal_obj univ_cat_with_binprod.
Proof.
  use subbicat_final.
  - exact bifinal_cats.
  - exact binproduct_unit_category.
  - intro.
    apply functor_to_unit_preserves_binproduct.
Defined.

Definition disp_has_binprod_univ_cat_with_binprod
  : disp_has_binprod disp_bicat_binprod has_binprod_bicat_of_univ_cats.
Proof.
  use subbicat_disp_binprod.
  - intros C₁ C₂.
    apply binproducts_in_product_category.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr1_preserves_binproduct.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr2_preserves_binproduct.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ q.
    apply preserves_binproduct_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition has_binprod_univ_cat_with_binprod
  : has_binprod univ_cat_with_binprod.
Proof.
  use subbicat_binprod.
  - exact has_binprod_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - intros C₁ C₂.
    apply binproducts_in_product_category.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr1_preserves_binproduct.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr2_preserves_binproduct.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ q.
    apply preserves_binproduct_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition disp_has_pb_univ_cat_with_binprod
  : disp_has_pb disp_bicat_binprod has_pb_bicat_of_univ_cats.
Proof.
  use subbicat_disp_has_pb.
  - intros C₁ C₂ C₃ F G.
    apply binproducts_in_iso_comma.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr1_preserves_binproduct.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr2_preserves_binproduct.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G q.
    apply iso_comma_ump1_preserves_binproduct.
    + exact (pr12 G).
    + exact (pr12 (pb_cone_pr1 q)).
    + exact (pr12 (pb_cone_pr2 q)).
Defined.

Definition has_pb_univ_cat_with_binprod
  : has_pb univ_cat_with_binprod.
Proof.
  use subbicat_has_pb.
  - exact has_pb_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - intros C₁ C₂ C₃ F G.
    apply binproducts_in_iso_comma.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr1_preserves_binproduct.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr2_preserves_binproduct.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G q.
    apply iso_comma_ump1_preserves_binproduct.
    + exact (pr12 G).
    + exact (pr12 (pb_cone_pr1 q)).
    + exact (pr12 (pb_cone_pr2 q)).
Defined.

Definition has_em_univ_cat_with_binprod
  : bicat_has_em univ_cat_with_binprod.
Proof.
  use subbicat_has_em.
  - exact has_em_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - exact (λ m,
           BinProducts_eilenberg_moore_cat _ (pr22 (ob_of_mnd m))).
  - exact (λ m,
           eilenberg_moore_pr_preserves_binproduct _ (pr22 (ob_of_mnd m))).
  - intros m q.
    use functor_to_eilenberg_moore_cat_preserves_binproduct.
    exact (pr12 (mor_of_mnd_mor (mor_of_em_cone m q))).
Defined.

(**
 3. Limits of categories with pullbacks
 *)
Definition disp_bifinal_obj_univ_cat_with_pb
  : disp_bifinal_obj disp_bicat_pullback bifinal_cats.
Proof.
  use subbicat_disp_final.
  - exact pullbacks_unit_category.
  - intro.
    apply functor_to_unit_preserves_pullback.
Defined.

Definition bifinal_obj_univ_cat_with_pb
  : bifinal_obj univ_cat_with_pb.
Proof.
  use subbicat_final.
  - exact bifinal_cats.
  - exact pullbacks_unit_category.
  - intro.
    apply functor_to_unit_preserves_pullback.
Defined.

Definition disp_has_binprod_univ_cat_with_pb
  : disp_has_binprod disp_bicat_pullback has_binprod_bicat_of_univ_cats.
Proof.
  use subbicat_disp_binprod.
  - intros C₁ C₂.
    apply pullbacks_in_product_category.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr1_preserves_pullback.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr2_preserves_pullback.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ q.
    apply preserves_pullback_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition has_binprod_univ_cat_with_pb
  : has_binprod univ_cat_with_pb.
Proof.
  use subbicat_binprod.
  - exact has_binprod_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - intros C₁ C₂.
    apply pullbacks_in_product_category.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr1_preserves_pullback.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr2_preserves_pullback.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ q.
    apply preserves_pullback_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition disp_has_pb_univ_cat_with_pb
  : disp_has_pb disp_bicat_pullback has_pb_bicat_of_univ_cats.
Proof.
  use subbicat_disp_has_pb.
  - intros C₁ C₂ C₃ F G.
    apply pullbacks_in_iso_comma.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr1_preserves_pullback.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr2_preserves_pullback.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G q.
    apply iso_comma_ump1_preserves_pullback.
    + exact (pr12 G).
    + exact (pr12 (pb_cone_pr1 q)).
    + exact (pr12 (pb_cone_pr2 q)).
Defined.

Definition has_pb_univ_cat_with_pb
  : has_pb univ_cat_with_pb.
Proof.
  use subbicat_has_pb.
  - exact has_pb_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - intros C₁ C₂ C₃ F G.
    apply pullbacks_in_iso_comma.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr1_preserves_pullback.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr2_preserves_pullback.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G q.
    apply iso_comma_ump1_preserves_pullback.
    + exact (pr12 G).
    + exact (pr12 (pb_cone_pr1 q)).
    + exact (pr12 (pb_cone_pr2 q)).
Defined.

Definition has_em_univ_cat_with_pb
  : bicat_has_em univ_cat_with_pb.
Proof.
  use subbicat_has_em.
  - exact has_em_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - exact (λ m,
           Pullbacks_eilenberg_moore _ (pr22 (ob_of_mnd m))).
  - exact (λ m,
           eilenberg_moore_pr_preserves_pullback _ (pr22 (ob_of_mnd m))).
  - intros m q.
    use functor_to_eilenberg_moore_cat_preserves_pullback.
    exact (pr12 (mor_of_mnd_mor (mor_of_em_cone m q))).
Defined.

(**
 4. Limits of categories with finite limits
 *)
Definition disp_bifinal_obj_univ_cat_with_finlim
  : disp_bifinal_obj disp_bicat_finlim bifinal_cats.
Proof.
  use disp_dirprod_bifinal.
  - exact disp_bifinal_univ_cat_with_terminal_obj.
  - exact disp_bifinal_obj_univ_cat_with_pb.
Defined.

Definition bifinal_obj_univ_cat_with_finlim
  : bifinal_obj univ_cat_with_finlim.
Proof.
  use total_bicat_final.
  - use disp_2cells_isaprop_prod.
    + apply disp_2cells_isaprop_subbicat.
    + apply disp_2cells_isaprop_subbicat.
  - intros.
    exact ((tt ,, tt) ,, (tt ,, tt)).
  - exact bifinal_cats.
  - exact disp_bifinal_obj_univ_cat_with_finlim.
Defined.

Definition disp_has_binprod_univ_cat_with_finlim
  : disp_has_binprod disp_bicat_finlim has_binprod_bicat_of_univ_cats.
Proof.
  use disp_dirprod_binprod.
  - exact disp_has_binprod_univ_cat_with_terminal_obj.
  - exact disp_has_binprod_univ_cat_with_pb.
Defined.

Definition has_binprod_univ_cat_with_finlim
  : has_binprod univ_cat_with_finlim.
Proof.
  use total_bicat_prod.
  - use disp_2cells_isaprop_prod.
    + apply disp_2cells_isaprop_subbicat.
    + apply disp_2cells_isaprop_subbicat.
  - intros.
    exact ((tt ,, tt) ,, (tt ,, tt)).
  - apply disp_locally_groupoid_prod.
    + apply disp_locally_groupoid_subbicat.
      apply univalent_cat_is_univalent_2.
    + apply disp_locally_groupoid_subbicat.
      apply univalent_cat_is_univalent_2.
  - exact has_binprod_bicat_of_univ_cats.
  - exact disp_has_binprod_univ_cat_with_finlim.
Defined.

Definition disp_has_pb_univ_cat_with_finlim
  : disp_has_pb disp_bicat_finlim has_pb_bicat_of_univ_cats.
Proof.
  use disp_dirprod_pb.
  - exact disp_has_pb_univ_cat_with_terminal_obj.
  - exact disp_has_pb_univ_cat_with_pb.
Defined.

Definition has_pb_univ_cat_with_finlim
  : has_pb univ_cat_with_finlim.
Proof.
  use total_bicat_has_pb.
  - use disp_2cells_isaprop_prod.
    + apply disp_2cells_isaprop_subbicat.
    + apply disp_2cells_isaprop_subbicat.
  - intros.
    exact ((tt ,, tt) ,, (tt ,, tt)).
  - apply disp_locally_groupoid_prod.
    + apply disp_locally_groupoid_subbicat.
      apply univalent_cat_is_univalent_2.
    + apply disp_locally_groupoid_subbicat.
      apply univalent_cat_is_univalent_2.
  - exact has_pb_bicat_of_univ_cats.
  - exact disp_has_pb_univ_cat_with_finlim.
Defined.

(**
 5. Limits of categories with initial objects
 *)
Definition disp_bifinal_obj_univ_cat_with_initial
  : disp_bifinal_obj disp_bicat_initial_obj bifinal_cats.
Proof.
  use subbicat_disp_final.
  - exact initial_unit_category.
  - intro C.
    apply functor_to_unit_preserves_initial.
Defined.

Definition bifinal_obj_univ_cat_with_initial
  : bifinal_obj univ_cat_with_initial.
Proof.
  use subbicat_final.
  - exact bifinal_cats.
  - exact initial_unit_category.
  - intro C.
    apply functor_to_unit_preserves_initial.
Defined.

Definition disp_has_binprod_univ_cat_with_initial
  : disp_has_binprod disp_bicat_initial_obj has_binprod_bicat_of_univ_cats.
Proof.
  use subbicat_disp_binprod.
  - exact (λ C₁ C₂, initial_category_binproduct (pr22 C₁) (pr22 C₂)).
  - intros C₁ C₂.
    apply pr1_preserves_initial.
  - intros C₁ C₂.
    apply pr2_preserves_initial.
  - intros C₁ C₂ q.
    apply preserves_initial_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition has_binprod_univ_cat_with_initial
  : has_binprod univ_cat_with_initial.
Proof.
  use subbicat_binprod.
  - exact has_binprod_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - exact (λ C₁ C₂, initial_category_binproduct (pr22 C₁) (pr22 C₂)).
  - intros C₁ C₂.
    apply pr1_preserves_initial.
  - intros C₁ C₂.
    apply pr2_preserves_initial.
  - intros C₁ C₂ q.
    apply preserves_initial_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition disp_has_pb_univ_cat_with_initial
  : disp_has_pb disp_bicat_initial_obj has_pb_bicat_of_univ_cats.
Proof.
  use subbicat_disp_has_pb.
  - intros C₁ C₂ C₃ F G.
    apply initial_category_iso_comma.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr1_preserves_initial.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr2_preserves_initial.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G q.
    apply iso_comma_ump1_preserves_initial.
    + exact (pr12 F).
    + exact (pr12 (pb_cone_pr1 q)).
    + exact (pr12 (pb_cone_pr2 q)).
Defined.

Definition has_pb_univ_cat_with_initial
  : has_pb univ_cat_with_initial.
Proof.
  use subbicat_has_pb.
  - exact has_pb_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - intros C₁ C₂ C₃ F G.
    apply initial_category_iso_comma.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr1_preserves_initial.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr2_preserves_initial.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G q.
    apply iso_comma_ump1_preserves_initial.
    + exact (pr12 F).
    + exact (pr12 (pb_cone_pr1 q)).
    + exact (pr12 (pb_cone_pr2 q)).
Defined.

Definition has_em_univ_cat_with_initial
  : bicat_has_em univ_cat_with_initial.
Proof.
  use subbicat_has_em.
  - exact has_em_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - refine (λ m,
            initial_eilenberg_moore_cat
              _
              (pr22 (ob_of_mnd m))
              _).
    exact (pr12 (endo_of_mnd m)).
  - refine (λ m,
            eilenberg_moore_pr_preserves_initial _ (pr22 (ob_of_mnd m)) _).
    exact (pr12 (endo_of_mnd m)).
  - intros m q.
    use functor_to_eilenberg_moore_cat_preserves_initial.
    + exact (pr12 (endo_of_mnd m)).
    + exact (pr12 (mor_of_mnd_mor (mor_of_em_cone m q))).
Defined.

(**
 6. Limits of categories with coproducts
 *)
Definition disp_bifinal_obj_univ_cat_with_bincoprod
  : disp_bifinal_obj disp_bicat_bincoprod bifinal_cats.
Proof.
  use subbicat_disp_final.
  - exact bincoproduct_unit_category.
  - intro C.
    apply functor_to_unit_preserves_bincoproduct.
Defined.

Definition bifinal_obj_univ_cat_with_bincoprod
  : bifinal_obj univ_cat_with_bincoprod.
Proof.
  use subbicat_final.
  - exact bifinal_cats.
  - exact bincoproduct_unit_category.
  - intro C.
    apply functor_to_unit_preserves_bincoproduct.
Defined.

Definition disp_has_binprod_univ_cat_with_bincoprod
  : disp_has_binprod disp_bicat_bincoprod has_binprod_bicat_of_univ_cats.
Proof.
  use subbicat_disp_binprod.
  - intros C₁ C₂.
    apply bincoproducts_in_product_category.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr1_preserves_bincoproduct.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr2_preserves_bincoproduct.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ q.
    apply preserves_bincoproduct_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition has_binprod_univ_cat_with_bincoprod
  : has_binprod univ_cat_with_bincoprod.
Proof.
  use subbicat_binprod.
  - exact has_binprod_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - intros C₁ C₂.
    apply bincoproducts_in_product_category.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr1_preserves_bincoproduct.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂.
    apply pr2_preserves_bincoproduct.
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ q.
    apply preserves_bincoproduct_bindelta_pair_functor.
    + exact (pr12 (binprod_cone_pr1 q)).
    + exact (pr12 (binprod_cone_pr2 q)).
Defined.

Definition disp_has_pb_univ_cat_with_bincoprod
  : disp_has_pb disp_bicat_bincoprod has_pb_bicat_of_univ_cats.
Proof.
  use subbicat_disp_has_pb.
  - intros C₁ C₂ C₃ F G.
    apply bincoproducts_in_iso_comma.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr1_preserves_bincoproduct.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr2_preserves_bincoproduct.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G q.
    apply iso_comma_ump1_preserves_bincoproduct.
    + exact (pr12 F).
    + exact (pr12 (pb_cone_pr1 q)).
    + exact (pr12 (pb_cone_pr2 q)).
Defined.

Definition has_pb_univ_cat_with_bincoprod
  : has_pb univ_cat_with_bincoprod.
Proof.
  use subbicat_has_pb.
  - exact has_pb_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - intros C₁ C₂ C₃ F G.
    apply bincoproducts_in_iso_comma.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr1_preserves_bincoproduct.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G.
    apply iso_comma_pr2_preserves_bincoproduct.
    + exact (pr12 F).
    + exact (pr12 G).
    + exact (pr22 C₁).
    + exact (pr22 C₂).
  - intros C₁ C₂ C₃ F G q.
    apply iso_comma_ump1_preserves_bincoproduct.
    + exact (pr12 F).
    + exact (pr12 (pb_cone_pr1 q)).
    + exact (pr12 (pb_cone_pr2 q)).
Defined.

Definition has_em_univ_cat_with_bincoprod
  : bicat_has_em univ_cat_with_bincoprod.
Proof.
  use subbicat_has_em.
  - exact has_em_bicat_of_univ_cats.
  - exact univalent_cat_is_univalent_2.
  - refine (λ m,
            bincoproducts_eilenberg_moore
              _
              (pr22 (ob_of_mnd m))
              _).
    exact (pr12 (endo_of_mnd m)).
  - refine (λ m,
            eilenberg_moore_pr_preserves_bincoproduct _ (pr22 (ob_of_mnd m)) _).
    exact (pr12 (endo_of_mnd m)).
  - intros m q.
    use functor_to_eilenberg_moore_cat_preserves_bincoproduct.
    + exact (pr12 (endo_of_mnd m)).
    + exact (pr12 (mor_of_mnd_mor (mor_of_em_cone m q))).
Defined.


(** We test memory usage of typeclass resification of let-binders to PHOAS *)
Generalizable All Variables.
Axiom Let_In : forall {A P} (v : A) (f : forall x : A, P x), P v.
Fixpoint nested_lets (n : nat) (init : nat) : nat
  := match n with
     | O => init + init
     | S n => Let_In (init + init) (fun x => nested_lets n x)
     end.

Inductive type := NAT.
Inductive expr {var : type -> Type} : type -> Type :=
| Zero : expr NAT
| Succ (n : expr NAT) : expr NAT
| Plus (x y : expr NAT) : expr NAT
| LetIn {A B} (x : expr A) (f : var A -> expr B) : expr B
| Var {T} (v : var T) : expr T
.

Axiom P : forall {var t}, @expr var t -> Prop.
Axiom p : forall var t e, @P var t e.
Ltac solve_P := intros; apply p.

Class type_reified_of (v : Type) (t : type) := dummyT : True.
Typeclasses Opaque type_reified_of.
Global Hint Mode type_reified_of ! - : typeclass_instances.
Global Instance reify_nat : type_reified_of nat NAT := I.
Class reified_of {var A B} (v : A) (e : @expr var B) := dummy : True.
Typeclasses Opaque reified_of.
Typeclasses Opaque Nat.add.
Global Hint Mode reified_of - - - ! - : typeclass_instances.
Global Instance reify_plus {var x ex y ey} {_:reified_of x ex} {_:reified_of y ey}
  : reified_of (x + y) (@Plus var ex ey) := I.
Global Instance reify_LetIn {var A B tA tB x ex f ef} {_:reified_of x ex} {_:forall v ev, reified_of v (Var ev) -> reified_of (f v) (ef ev)}
  : reified_of (@Let_In A (fun _ => B) x f) (@LetIn var tA tB ex ef) := I.
Global Instance reify_0 {var} : reified_of 0 (@Zero var) := I.
Global Instance reify_S {var n en} {_:reified_of n en} : reified_of (S n) (@Succ var en) := I.
Definition reify {var T T'} (v : T) {ev : @expr var T'} {_ : reified_of v ev} := ev.
Ltac subst_evars :=
  repeat match goal with
         | [ x := ?e |- _ ] => is_evar e; subst x
         end.
Global Hint Extern 0 (reified_of _ _) => progress (cbv [nested_lets]; subst_evars) : typeclass_instances.

Notation reified var' v := (match _ return _ with t => match _ : @expr var' t return _ with e => match _ : reified_of v e with _ => e end end end) (only parsing).

Notation goal n := (forall var, P (reified var (nested_lets n 0))) (only parsing).

Time Definition foo10 : goal 10. Time solve_P. Time Qed.


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

Definition t_update {A B : Type} (eq_dec:forall (x y:A),{x=y}+{x<>y}) (f:total_map A B) (x:A) (v:B) : total_map A B :=
  fun y => if eq_dec x y then v else f y.

Definition t_get {A} {B} (f:total_map A B) (x:A) : B :=
  f x.

Definition t_empty {A} {B} (v:B) : total_map A B :=
  fun (_ : A) => v.

Lemma t_apply_empty: forall A B x v, @t_empty A B v x = v.
Proof.
  intros.
  unfold t_empty. reflexivity.
Qed.

Definition partial_map (A B:Type) := total_map A (option B).

Definition empty {A B: Type} : partial_map A B :=
  t_empty None.

Definition update {A B: Type} (eq_dec:forall (x y:A),{x=y}+{x<>y}) (m: partial_map A B) (k: A) (v: B) :=
  t_update eq_dec m k (Some v).

Definition member {A B: Type} (m : partial_map A B) (k: A) :=
match (m k) with
| Some _ => true
| None => false
end.

Lemma apply_empty : forall A B x, @empty A B x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty. reflexivity.
Qed.


(** A "ghost map" (or "ghost heap") with a proposition controlling authoritative
ownership of the entire heap, and a "points-to-like" proposition for (mutable,
fractional, or persistent read-only) ownership of individual elements. *)
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import gmap_view.
From iris.algebra Require Export dfrac.
From iris.base_logic.lib Require Export own.
From iris.prelude Require Import options.

(** The CMRA we need.
FIXME: This is intentionally discrete-only, but
should we support setoids via [Equiv]? *)
Class ghost_mapG Σ (K V : Type) `{Countable K} := GhostMapG {
  ghost_map_inG :> inG Σ (gmap_viewR K (leibnizO V));
}.
Definition ghost_mapΣ (K V : Type) `{Countable K} : gFunctors :=
  #[ GFunctor (gmap_viewR K (leibnizO V)) ].

Global Instance subG_ghost_mapΣ Σ (K V : Type) `{Countable K} :
  subG (ghost_mapΣ K V) Σ → ghost_mapG Σ K V.
Proof. solve_inG. Qed.

Section definitions.
  Context `{ghost_mapG Σ K V}.

  Definition ghost_map_auth_def (γ : gname) (q : Qp) (m : gmap K V) : iProp Σ :=
    own γ (gmap_view_auth (V:=leibnizO V) q m).
  Definition ghost_map_auth_aux : seal (@ghost_map_auth_def). Proof. by eexists. Qed.
  Definition ghost_map_auth := ghost_map_auth_aux.(unseal).
  Definition ghost_map_auth_eq : @ghost_map_auth = @ghost_map_auth_def := ghost_map_auth_aux.(seal_eq).

  Definition ghost_map_elem_def (γ : gname) (k : K) (dq : dfrac) (v : V) : iProp Σ :=
    own γ (gmap_view_frag (V:=leibnizO V) k dq v).
  Definition ghost_map_elem_aux : seal (@ghost_map_elem_def). Proof. by eexists. Qed.
  Definition ghost_map_elem := ghost_map_elem_aux.(unseal).
  Definition ghost_map_elem_eq : @ghost_map_elem = @ghost_map_elem_def := ghost_map_elem_aux.(seal_eq).
End definitions.

(** FIXME: Refactor these notations using custom entries once Coq bug #13654
has been fixed. *)
Notation "k ↪[ γ ]{ dq } v" := (ghost_map_elem γ k dq v)
  (at level 20, γ at level 50, dq at level 50, format "k  ↪[ γ ]{ dq }  v") : bi_scope.
Notation "k ↪[ γ ]{# q } v" := (k ↪[γ]{DfracOwn q} v)%I
  (at level 20, γ at level 50, q at level 50, format "k  ↪[ γ ]{# q }  v") : bi_scope.
Notation "k ↪[ γ ] v" := (k ↪[γ]{#1} v)%I
  (at level 20, γ at level 50, format "k  ↪[ γ ]  v") : bi_scope.
Notation "k ↪[ γ ]□ v" := (k ↪[γ]{DfracDiscarded} v)%I
  (at level 20, γ at level 50) : bi_scope.

Local Ltac unseal := rewrite
  ?ghost_map_auth_eq /ghost_map_auth_def
  ?ghost_map_elem_eq /ghost_map_elem_def.

Section lemmas.
  Context `{ghost_mapG Σ K V}.
  Implicit Types (k : K) (v : V) (dq : dfrac) (q : Qp) (m : gmap K V).

  (** * Lemmas about the map elements *)
  Global Instance ghost_map_elem_timeless k γ dq v : Timeless (k ↪[γ]{dq} v).
  Proof. unseal. apply _. Qed.
  Global Instance ghost_map_elem_persistent k γ v : Persistent (k ↪[γ]□ v).
  Proof. unseal. apply _. Qed.
  Global Instance ghost_map_elem_fractional k γ v : Fractional (λ q, k ↪[γ]{#q} v)%I.
  Proof. unseal. intros p q. rewrite -own_op gmap_view_frag_add //. Qed.
  Global Instance ghost_map_elem_as_fractional k γ q v :
    AsFractional (k ↪[γ]{#q} v) (λ q, k ↪[γ]{#q} v)%I q.
  Proof. split; first done. apply _. Qed.

  Lemma ghost_map_elem_valid k γ dq v : k ↪[γ]{dq} v -∗ ⌜✓ dq⌝.
  Proof.
    unseal. iIntros "Helem".
    iDestruct (own_valid with "Helem") as %?%gmap_view_frag_valid.
    done.
  Qed.
  Lemma ghost_map_elem_valid_2 k γ dq1 dq2 v1 v2 :
    k ↪[γ]{dq1} v1 -∗ k ↪[γ]{dq2} v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
  Proof.
    unseal. iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %?%gmap_view_frag_op_valid_L.
    done.
  Qed.
  Lemma ghost_map_elem_agree k γ dq1 dq2 v1 v2 :
    k ↪[γ]{dq1} v1 -∗ k ↪[γ]{dq2} v2 -∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "Helem1 Helem2".
    iDestruct (ghost_map_elem_valid_2 with "Helem1 Helem2") as %[_ ?].
    done.
  Qed.

  Lemma ghost_map_elem_combine k γ dq1 dq2 v1 v2 :
    k ↪[γ]{dq1} v1 -∗ k ↪[γ]{dq2} v2 -∗ k ↪[γ]{dq1 ⋅ dq2} v1 ∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "Hl1 Hl2". iDestruct (ghost_map_elem_agree with "Hl1 Hl2") as %->.
    unseal. iCombine "Hl1 Hl2" as "Hl". eauto with iFrame.
  Qed.

  Lemma ghost_map_elem_frac_ne γ k1 k2 dq1 dq2 v1 v2 :
    ¬ ✓ (dq1 ⋅ dq2) → k1 ↪[γ]{dq1} v1 -∗ k2 ↪[γ]{dq2} v2 -∗ ⌜k1 ≠ k2⌝.
  Proof.
    iIntros (?) "H1 H2"; iIntros (->).
    by iDestruct (ghost_map_elem_valid_2 with "H1 H2") as %[??].
  Qed.
  Lemma ghost_map_elem_ne γ k1 k2 dq2 v1 v2 :
    k1 ↪[γ] v1 -∗ k2 ↪[γ]{dq2} v2 -∗ ⌜k1 ≠ k2⌝.
  Proof. apply ghost_map_elem_frac_ne. apply: exclusive_l. Qed.

  (** Make an element read-only. *)
  Lemma ghost_map_elem_persist k γ dq v :
    k ↪[γ]{dq} v ==∗ k ↪[γ]□ v.
  Proof. unseal. iApply own_update. apply gmap_view_persist. Qed.

  (** * Lemmas about [ghost_map_auth] *)
  Lemma ghost_map_alloc_strong P m :
    pred_infinite P →
    ⊢ |==> ∃ γ, ⌜P γ⌝ ∗ ghost_map_auth γ 1 m ∗ [∗ map] k ↦ v ∈ m, k ↪[γ] v.
  Proof.
    unseal. intros.
    iMod (own_alloc_strong (gmap_view_auth (V:=leibnizO V) 1 ∅) P)
      as (γ) "[% Hauth]"; first done.
    { apply gmap_view_auth_valid. }
    iExists γ. iSplitR; first done.
    rewrite -big_opM_own_1 -own_op. iApply (own_update with "Hauth").
    etrans; first apply: (gmap_view_alloc_big (V:=leibnizO V) _ m (DfracOwn 1)).
    - apply map_disjoint_empty_r.
    - done.
    - rewrite right_id. done.
  Qed.
  Lemma ghost_map_alloc_strong_empty P :
    pred_infinite P →
    ⊢ |==> ∃ γ, ⌜P γ⌝ ∗ ghost_map_auth γ 1 (∅ : gmap K V).
  Proof.
    intros. iMod (ghost_map_alloc_strong P ∅) as (γ) "(% & Hauth & _)"; eauto.
  Qed.
  Lemma ghost_map_alloc m :
    ⊢ |==> ∃ γ, ghost_map_auth γ 1 m ∗ [∗ map] k ↦ v ∈ m, k ↪[γ] v.
  Proof.
    iMod (ghost_map_alloc_strong (λ _, True) m) as (γ) "[_ Hmap]".
    - by apply pred_infinite_True.
    - eauto.
  Qed.
  Lemma ghost_map_alloc_empty :
    ⊢ |==> ∃ γ, ghost_map_auth γ 1 (∅ : gmap K V).
  Proof.
    intros. iMod (ghost_map_alloc ∅) as (γ) "(Hauth & _)"; eauto.
  Qed.

  Global Instance ghost_map_auth_timeless γ q m : Timeless (ghost_map_auth γ q m).
  Proof. unseal. apply _. Qed.
  Global Instance ghost_map_auth_fractional γ m : Fractional (λ q, ghost_map_auth γ q m)%I.
  Proof. intros p q. unseal. rewrite -own_op gmap_view_auth_frac_op //. Qed.
  Global Instance ghost_map_auth_as_fractional γ q m :
    AsFractional (ghost_map_auth γ q m) (λ q, ghost_map_auth γ q m)%I q.
  Proof. split; first done. apply _. Qed.

  Lemma ghost_map_auth_valid γ q m : ghost_map_auth γ q m -∗ ⌜q ≤ 1⌝%Qp.
  Proof.
    unseal. iIntros "Hauth".
    iDestruct (own_valid with "Hauth") as %?%gmap_view_auth_frac_valid.
    done.
  Qed.
  Lemma ghost_map_auth_valid_2 γ q1 q2 m1 m2 :
    ghost_map_auth γ q1 m1 -∗ ghost_map_auth γ q2 m2 -∗ ⌜(q1 + q2 ≤ 1)%Qp ∧ m1 = m2⌝.
  Proof.
    unseal. iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %[??]%gmap_view_auth_frac_op_valid_L.
    done.
  Qed.
  Lemma ghost_map_auth_agree γ q1 q2 m1 m2 :
    ghost_map_auth γ q1 m1 -∗ ghost_map_auth γ q2 m2 -∗ ⌜m1 = m2⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct (ghost_map_auth_valid_2 with "H1 H2") as %[_ ?].
    done.
  Qed.

  (** * Lemmas about the interaction of [ghost_map_auth] with the elements *)
  Lemma ghost_map_lookup k γ q m dq v :
    ghost_map_auth γ q m -∗ k ↪[γ]{dq} v -∗ ⌜m !! k = Some v⌝.
  Proof.
    unseal. iIntros "Hauth Hel".
    iDestruct (own_valid_2 with "Hauth Hel") as %[?[??]]%gmap_view_both_frac_valid_L.
    eauto.
  Qed.

  Lemma ghost_map_insert {γ m} k v :
    m !! k = None →
    ghost_map_auth γ 1 m ==∗ ghost_map_auth γ 1 (<[k := v]> m) ∗ k ↪[γ] v.
  Proof.
    unseal. intros ?. rewrite -own_op.
    iApply own_update. apply: gmap_view_alloc; done.
  Qed.
  Lemma ghost_map_insert_persist {γ m} k v :
    m !! k = None →
    ghost_map_auth γ 1 m ==∗ ghost_map_auth γ 1 (<[k := v]> m) ∗ k ↪[γ]□ v.
  Proof.
    iIntros (?) "Hauth".
    iMod (ghost_map_insert k with "Hauth") as "[$ Helem]"; first done.
    iApply ghost_map_elem_persist. done.
  Qed.

  Lemma ghost_map_delete {γ m k v} :
    ghost_map_auth γ 1 m -∗ k ↪[γ] v ==∗ ghost_map_auth γ 1 (delete k m).
  Proof.
    unseal. apply bi.wand_intro_r. rewrite -own_op.
    iApply own_update. apply: gmap_view_delete.
  Qed.

  Lemma ghost_map_update {γ m k v} w :
    ghost_map_auth γ 1 m -∗ k ↪[γ] v ==∗ ghost_map_auth γ 1 (<[k := w]> m) ∗ k ↪[γ] w.
  Proof.
    iIntros "Hauth Hel". iMod (ghost_map_delete with "Hauth Hel") as "Hauth".
    iMod (ghost_map_insert k with "Hauth").
    { rewrite lookup_delete. done. }
    rewrite insert_delete. eauto.
  Qed.

End lemmas.


(*this is the example for the difference between SME-NI and SIR-NNI*)

Require Export refine.
Require Export parser.

(** Fig.4(a)(d) *)

Definition expr1a:IA := parse
"IA [s0,s1,s2] (s0) [h] [a] [] [s0->(h)s1, s1->(a)s2, s0->(a)s2]".

Definition expr1a_rep: IA :=
  (IAutomaton.replacement expr1a (&"tau") (ASet.GenActs [&"h"])).

Definition expr1a_hid: IA :=
  (IAutomaton.hiding expr1a (ASet.GenActs [&"h"]) ).

Eval compute in (SMENI_refinement expr1a_rep expr1a_hid). (*true*)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Ralph Matthes [+]                              *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation IRIT -- CNRS   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** Extraction of breadth-first numbering algorithm from Coq to Ocaml

       see http://okasaki.blogspot.com/2008/07/breadth-first-numbering-algorithm-in.html
       and https://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/jfp95queue.pdf
       and https://www.cs.cmu.edu/~rwh/theses/okasaki.pdf
       and https://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/icfp00bfn.pdf

*)

Require Import List Extraction.
Require Import bt fifo bfn_fifo.
Require Import fifo_triv fifo_2lists fifo_3llists.

(* Extraction Language OCaml. *)
Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Inductive nat => int [ "0" "succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))".

Module BFN_triv := BFN_FIFO FIFO_triv.
Module BFN_2lists := BFN_FIFO FIFO_2lists.
Module BFN_3llists := BFN_FIFO FIFO_3llists.

(* The extraction here provides either
   1) a trivial implementation with lists (with fifo_triv)
   2) an implementation with 2 lists and efficient reverse (with fifo_2lists), (relaxed) O(1) enqueue/dequeue
   3) an implementation with 3 lazy lists (with fifo_3llists), O(1) enqueue/dequeue
 *)

(* Extraction "bfn_triv" BFN_triv.bfn_fifo.
Extraction "bfn_2lists" BFN_2lists.bfn_fifo.
Extraction "bfn_3llists" BFN_3llists.bfn_fifo.
Extraction "bfn_2lists_3llists" BFN_2lists.bfn_fifo BFN_3llists.bfn_fifo.
*)