Require Import Verdi.
Require Import HandlerMonad.
Require Import StructTact.Fin.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import StatePacketPacketDecomposition.

Set Implicit Arguments.

Section LockServ.

  Variable num_Clients : nat.

  Definition Client_index := (fin num_Clients).

  Inductive Name :=
  | Client : Client_index -> Name
  | Server : Name.

  Definition list_Clients := map Client (all_fin num_Clients).

  Definition Name_eq_dec : forall a b : Name, {a = b} + {a <> b}.
Proof using.
    decide equality. apply fin_eq_dec.
  Qed.

  Inductive Msg :=
  | Lock   : Msg
  | Unlock : Msg
  | Locked : Msg.

  Definition Msg_eq_dec : forall a b : Msg, {a = b} + {a <> b}.
Proof using.
    decide equality.
  Qed.

  Definition Input := Msg.
  Definition Output := Msg.

  Record Data := mkData { queue : list Client_index ; held : bool }.

  Definition init_data (n : Name) : Data := mkData [] false.

  Definition Handler (S : Type) := GenHandler (Name * Msg) S Output unit.

  Definition ClientNetHandler (i : Client_index) (m : Msg) : Handler Data :=
    match m with
      | Locked => (put (mkData [] true)) >> write_output Locked
      | _ => nop
    end.

  Definition ClientIOHandler (i : Client_index) (m : Msg) : Handler Data :=
    match m with
      | Lock => send (Server, Lock)
      | Unlock => data <- get ;;
                  when (held data) (put (mkData [] false) >> send (Server, Unlock))
      | _ => nop
    end.

  Definition ServerNetHandler (src : Name) (m : Msg) : Handler Data :=
    st <- get ;;
    let q := queue st in
    match m with
      | Lock =>
        match src with
          | Server => nop
          | Client c =>
            when (null q) (send (src, Locked)) >> put (mkData (q++[c]) (held st))
        end
      | Unlock => match q with
                    | _ :: x :: xs => put (mkData (x :: xs) (held st)) >> send (Client x, Locked)
                    | _ => put (mkData [] (held st))
                  end
      | _ => nop
    end.

  Definition ServerIOHandler (m : Msg) : Handler Data := nop.

  Definition NetHandler (nm src : Name) (m : Msg) : Handler Data :=
    match nm with
      | Client c => ClientNetHandler c m
      | Server   => ServerNetHandler src m
    end.

  Definition InputHandler (nm : Name) (m : Msg) : Handler Data :=
    match nm with
      | Client c => ClientIOHandler c m
      | Server   => ServerIOHandler m
    end.

  Ltac handler_unfold :=
    repeat (monad_unfold; unfold NetHandler,
                                 InputHandler,
                                 ServerNetHandler,
                                 ClientNetHandler,
                                 ClientIOHandler,
                                 ServerIOHandler in *).

  Definition Nodes := Server :: list_Clients.

  Theorem In_n_Nodes :
    forall n : Name, In n Nodes.
  Proof using.
    intros.
    unfold Nodes, list_Clients.
    simpl.
    destruct n.
    - right.
      apply in_map.
      apply all_fin_all.
    - left.
      reflexivity.
  Qed.

  Theorem nodup :
    NoDup Nodes.
  Proof using.
    unfold Nodes, list_Clients.
    apply NoDup_cons.
    - in_crush. discriminate.
    - apply NoDup_map_injective.
      + intros. congruence.
      + apply all_fin_NoDup.
  Qed.

  Global Instance LockServ_BaseParams : BaseParams :=
    {
      data   := Data ;
      input  := Input ;
      output := Output
    }.

  Global Instance LockServ_MultiParams : MultiParams LockServ_BaseParams :=
    {
      name := Name ;
      msg  := Msg ;
      msg_eq_dec := Msg_eq_dec ;
      name_eq_dec := Name_eq_dec ;
      nodes := Nodes ;
      all_names_nodes := In_n_Nodes ;
      no_dup_nodes := nodup ;
      init_handlers := init_data ;
      net_handlers := fun dst src msg s =>
                        runGenHandler_ignore s (NetHandler dst src msg) ;
      input_handlers := fun nm msg s =>
                          runGenHandler_ignore s (InputHandler nm msg)
    }.

  (* This is the fundamental safety property of the system:
       No two different clients can (think they) hold
       the lock at once.
   *)
  Definition mutual_exclusion (sigma : name -> data) : Prop :=
    forall m n,
      held (sigma (Client m)) = true ->
      held (sigma (Client n)) = true ->
      m = n.

  (* The system enforces mutual exclusion at the server. Whenever a
     client believs it holds the lock, that client is at the head of the
     server's queue. *)
  Definition locks_correct (sigma : name -> data) : Prop :=
    forall n,
      held (sigma (Client n)) = true ->
      exists t,
        queue (sigma Server) = n :: t.

  (* We first show that this actually implies mutual exclusion. *)
  Lemma locks_correct_implies_mutex :
    forall sigma,
      locks_correct sigma ->
      mutual_exclusion sigma.
  Proof using.
    unfold locks_correct, mutual_exclusion.
    intros.
    repeat find_apply_hyp_hyp.
    break_exists.
    find_rewrite. find_inversion.
    auto.
  Qed.

  Definition valid_unlock q h c p :=
    pSrc p = Client c /\
    (exists t, q = c :: t) /\
    h = false.

  Definition locks_correct_unlock (sigma : name -> data) (p : packet) : Prop :=
    pBody p = Unlock ->
    exists c, valid_unlock (queue (sigma Server)) (held (sigma (Client c))) c p.

  Definition valid_locked q h c p :=
      pDst p = Client c /\
      (exists t, q = c :: t) /\
      h = false.

  Definition locks_correct_locked (sigma : name -> data) (p : packet) : Prop :=
    pBody p = Locked ->
    exists c, valid_locked (queue (sigma Server)) (held (sigma (Client c))) c p.

  Definition LockServ_network_invariant (sigma : name -> data) (p : packet) : Prop :=
    locks_correct_unlock sigma p /\
    locks_correct_locked sigma p.

  Definition LockServ_network_network_invariant (p q : packet) : Prop :=
    (pBody p = Unlock -> pBody q = Unlock -> False) /\
    (pBody p = Locked -> pBody q = Unlock -> False) /\
    (pBody p = Unlock -> pBody q = Locked -> False) /\
    (pBody p = Locked -> pBody q = Locked -> False).

  Lemma nwnw_sym :
    forall p q,
      LockServ_network_network_invariant p q ->
      LockServ_network_network_invariant q p.
  Proof using.
    unfold LockServ_network_network_invariant.
    intuition.
  Qed.

  Lemma locks_correct_init :
    locks_correct init_handlers.
  Proof using.
    unfold locks_correct. simpl. discriminate.
  Qed.

  Lemma InputHandler_cases :
    forall h i st u out st' ms,
      InputHandler h i st = (u, out, st', ms) ->
      (exists c, h = Client c /\
                 ((i = Lock /\ out = [] /\ st' = st /\ ms = [(Server, Lock)]) \/
                  (i = Unlock /\ out = [] /\ held st' = false /\
                   ((held st = true /\ ms = [(Server, Unlock)]) \/
                    (st' = st /\ ms = []))))) \/
      (out = [] /\ st' = st /\ ms = []).
  Proof using.
    handler_unfold.
    intros.
    repeat break_match; repeat tuple_inversion;
      subst; simpl in *; subst; simpl in *.
    - left. eexists. intuition.
    - left. eexists. intuition.
    - left. eexists. intuition.
    - auto.
    - auto.
  Qed.

  Lemma locks_correct_update_false :
    forall sigma st' x,
      locks_correct sigma ->
      held st' = false ->
      locks_correct (update sigma (Client x) st').
  Proof using.
    unfold locks_correct.
    intuition.
    destruct (Name_eq_dec (Client x) (Client n)).
    - find_inversion. exfalso.
      rewrite_update.
      congruence.
    - rewrite_update.
      auto.
  Qed.

  Ltac set_up_input_handlers :=
    intros;
    find_apply_lem_hyp InputHandler_cases;
    intuition idtac; try break_exists; intuition idtac; subst;
    repeat find_rewrite;
    simpl in *; intuition idtac; repeat find_inversion;
    try now rewrite update_nop_ext.

  Lemma locks_correct_input_handlers :
    forall h i sigma u st' out ms,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct (update sigma h st').
  Proof using.
    set_up_input_handlers;
    auto using locks_correct_update_false.
  Qed.

  Lemma ClientNetHandler_cases :
    forall c m st u out st' ms,
      ClientNetHandler c m st = (u, out, st', ms) ->
      ms = [] /\
      ((st' = st /\ out = [] ) \/
       (m = Locked /\ out = [Locked] /\ held st' = true)).
  Proof using.
    handler_unfold.
    intros.
    repeat break_match; repeat tuple_inversion; subst; auto.
  Qed.

  Lemma ServerNetHandler_cases :
    forall src m st u out st' ms,
      ServerNetHandler src m st = (u, out, st', ms) ->
      out = [] /\
      ((exists c, src = Client c /\
                  (m = Lock /\
                  queue st' = queue st ++ [c] /\
                  ((queue st = [] /\ ms = [(Client c, Locked)]) \/
                   (queue st <> [] /\ ms = [])))) \/
       ((m = Unlock /\
                   queue st' = tail (queue st) /\
                   ((queue st' = [] /\ ms = []) \/
                    (exists next t, queue st' = next :: t /\ ms = [(Client next, Locked)])))) \/
       ms = [] /\ st' = st).
  Proof using.
    handler_unfold.
    intros.
    repeat break_match; repeat tuple_inversion; subst.
    - find_apply_lem_hyp null_sound. find_rewrite. simpl.
      intuition. left. eexists. intuition.
    - simpl. find_apply_lem_hyp null_false_neq_nil.
      intuition. left. eexists. intuition.
    - simpl. auto.
    - simpl. destruct st; simpl in *; subst; auto.
    - simpl in *. intuition.
    - simpl in *. intuition eauto.
    - simpl. intuition.
  Qed.

  Definition at_head_of_queue sigma c := (exists t, queue (sigma Server) = c :: t).

  Lemma at_head_of_queue_intro :
    forall sigma c t,
      queue (sigma Server) = c :: t ->
      at_head_of_queue sigma c.
  Proof using.
    unfold at_head_of_queue.
    firstorder.
  Qed.

  Lemma locks_correct_update_true :
    forall sigma c st',
      held st' = true ->
      at_head_of_queue sigma c ->
      locks_correct sigma ->
      locks_correct (update sigma (Client c) st').
  Proof using.
    unfold locks_correct.
    intros.
    destruct (Name_eq_dec (Client c) (Client n)); rewrite_update; try find_inversion; auto.
  Qed.

  Lemma locks_correct_locked_at_head :
    forall sigma p c,
      pDst p = Client c ->
      pBody p = Locked ->
      locks_correct_locked sigma p ->
      at_head_of_queue sigma c.
  Proof using.
    unfold locks_correct_locked.
    firstorder.
    repeat find_rewrite. find_inversion.
    eauto using at_head_of_queue_intro.
  Qed.

  Lemma all_clients_false_locks_correct_server_update :
    forall sigma st,
      (forall c, held (sigma (Client c)) = false) ->
      locks_correct (update sigma Server st).
  Proof using.
    unfold locks_correct.
    intros.
    rewrite_update.
    now find_higher_order_rewrite.
  Qed.

  Lemma locks_correct_true_at_head_of_queue :
    forall sigma x,
      locks_correct sigma ->
      held (sigma (Client x)) = true ->
      at_head_of_queue sigma x.
  Proof using.
    unfold locks_correct.
    intros.
    find_apply_hyp_hyp. break_exists.
    eauto using at_head_of_queue_intro.
  Qed.

  Lemma at_head_of_nil :
    forall sigma c,
      at_head_of_queue sigma c ->
      queue (sigma Server) = [] ->
      False.
  Proof using.
    unfold at_head_of_queue.
    firstorder.
    congruence.
  Qed.

  Lemma empty_queue_all_clients_false :
    forall sigma,
      locks_correct sigma ->
      queue (sigma Server) = [] ->
      (forall c, held (sigma (Client c)) = false).
  Proof using.
    intuition.
    destruct (held (sigma (Client c))) eqn:?; auto.
    exfalso. eauto using at_head_of_nil, locks_correct_true_at_head_of_queue.
  Qed.

  Lemma unlock_in_flight_all_clients_false :
    forall sigma p,
      pBody p = Unlock ->
      locks_correct_unlock sigma p ->
      locks_correct sigma ->
      (forall c, held (sigma (Client c)) = false).
  Proof using.
    intros.
    destruct (held (sigma (Client c))) eqn:?; auto.
    firstorder.
    find_copy_apply_lem_hyp locks_correct_true_at_head_of_queue; auto.
    unfold at_head_of_queue in *. break_exists.
    congruence.
  Qed.

  Lemma locks_correct_at_head_preserved :
    forall sigma st',
      locks_correct sigma ->
      (forall c, at_head_of_queue sigma c -> at_head_of_queue (update sigma Server st') c) ->
      locks_correct (update sigma Server st').
  Proof using.
    unfold locks_correct, at_head_of_queue.
    firstorder.
    rewrite_update.
    eauto.
  Qed.

  Lemma snoc_at_head_of_queue_preserved :
    forall sigma st' x,
      queue st' = queue (sigma Server) ++ [x] ->
      (forall c, at_head_of_queue sigma c -> at_head_of_queue (update sigma Server st') c).
  Proof using.
    unfold at_head_of_queue.
    intuition. break_exists.
    rewrite_update.
    find_rewrite.
    eauto.
  Qed.

  Ltac set_up_net_handlers :=
    intros;
    match goal with
      | [ H : context [ NetHandler (pDst ?p) _ _ _ ] |- _ ] =>
        destruct (pDst p) eqn:?
    end; simpl in *;
    [find_apply_lem_hyp ClientNetHandler_cases |
     find_apply_lem_hyp ServerNetHandler_cases; intuition; try break_exists ];
    intuition; subst;
    simpl in *; intuition;
    repeat find_rewrite;
    repeat find_inversion;
    simpl in *;
    try now rewrite update_nop_ext.

  Lemma locks_correct_net_handlers :
    forall p sigma u st' out ms,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_unlock sigma p ->
      locks_correct_locked sigma p ->
      locks_correct (update sigma (pDst p) st').
  Proof using.
    set_up_net_handlers;
    eauto using
          locks_correct_update_true, locks_correct_locked_at_head,
          all_clients_false_locks_correct_server_update, empty_queue_all_clients_false,
          locks_correct_at_head_preserved, snoc_at_head_of_queue_preserved,
          all_clients_false_locks_correct_server_update, unlock_in_flight_all_clients_false.
  Qed.

  Lemma locks_correct_unlock_sent_lock :
    forall sigma p,
      pBody p = Lock ->
      locks_correct_unlock sigma p.
  Proof using.
    unfold locks_correct_unlock.
    intuition. congruence.
  Qed.

  Lemma locks_correct_unlock_sent_locked :
    forall sigma p,
      pBody p = Locked ->
      locks_correct_unlock sigma p.
  Proof using.
    unfold locks_correct_unlock.
    intuition. congruence.
  Qed.

  Lemma locks_correct_unlock_input_handlers_old :
    forall h i sigma u st' out ms p,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_unlock sigma p ->
      locks_correct_unlock (update sigma h st') p.
  Proof using.
    set_up_input_handlers.
    destruct (pBody p) eqn:?.
    - auto using locks_correct_unlock_sent_lock.
    - now erewrite unlock_in_flight_all_clients_false in * by eauto.
    - auto using locks_correct_unlock_sent_locked.
  Qed.

  Lemma locked_in_flight_all_clients_false :
    forall sigma p,
      pBody p = Locked ->
      locks_correct_locked sigma p ->
      locks_correct sigma ->
      (forall c, held (sigma (Client c)) = false).
  Proof using.
    intros.
    destruct (held (sigma (Client c))) eqn:?; auto.
    firstorder.
    find_copy_apply_lem_hyp locks_correct_true_at_head_of_queue; auto.
    unfold at_head_of_queue in *. break_exists.
    congruence.
  Qed.

  Lemma locks_correct_locked_sent_lock :
    forall sigma p,
      pBody p = Lock ->
      locks_correct_locked sigma p.
  Proof using.
    unfold locks_correct_locked.
    intuition. congruence.
  Qed.

  Lemma locks_correct_locked_sent_unlock :
    forall sigma p,
      pBody p = Unlock ->
      locks_correct_locked sigma p.
  Proof using.
    unfold locks_correct_locked.
    intuition. congruence.
  Qed.

  Lemma locks_correct_locked_input_handlers_old :
    forall h i sigma u st' out ms p,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_locked sigma p ->
      locks_correct_locked (update sigma h st') p.
  Proof using.
    set_up_input_handlers.
    destruct (pBody p) eqn:?.
    - auto using locks_correct_locked_sent_lock.
    - auto using locks_correct_locked_sent_unlock.
    - now erewrite locked_in_flight_all_clients_false in * by eauto.
  Qed.

  Lemma locks_correct_unlock_true_to_false :
    forall sigma p x st',
      at_head_of_queue sigma x ->
      held st' = false ->
      pSrc p = Client x ->
      locks_correct_unlock (update sigma (Client x) st') p.
  Proof using.
    unfold locks_correct_unlock, valid_unlock.
    intros.
    exists x.
    intuition; now rewrite_update.
  Qed.

  Lemma locks_correct_unlock_input_handlers_new :
    forall h i sigma u st' out ms p,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      In (pDst p, pBody p) ms ->
      pSrc p = h ->
      locks_correct_unlock (update sigma h st') p.
  Proof using.
    set_up_input_handlers;

    auto using locks_correct_unlock_sent_lock,
               locks_correct_unlock_true_to_false,
               locks_correct_true_at_head_of_queue.
  Qed.

  Lemma locks_correct_locked_input_handlers_new :
    forall h i sigma u st' out ms p,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      In (pDst p, pBody p) ms ->
      locks_correct_locked (update sigma h st') p.
  Proof using.
    set_up_input_handlers;
    auto using locks_correct_locked_sent_lock, locks_correct_locked_sent_unlock.
  Qed.

  Lemma nwnw_locked_lock :
    forall p q,
      LockServ_network_network_invariant p q ->
      pBody p = Locked ->
      pBody q = Lock.
  Proof using.
    unfold LockServ_network_network_invariant.
    intros.
    destruct (pBody q); intuition; try discriminate.
  Qed.

  Lemma nwnw_unlock_lock :
    forall p q,
      LockServ_network_network_invariant p q ->
      pBody p = Unlock ->
      pBody q = Lock.
  Proof using.
    unfold LockServ_network_network_invariant.
    intros.
    destruct (pBody q); intuition; try discriminate.
  Qed.

  Lemma locks_correct_unlock_at_head :
    forall sigma p c,
      pSrc p = Client c ->
      pBody p = Unlock ->
      locks_correct_unlock sigma p ->
      at_head_of_queue sigma c.
  Proof using.
    unfold locks_correct_unlock.
    intros.
    find_apply_hyp_hyp. clear H1.
    break_exists.
    unfold valid_unlock in *. intuition.
    break_exists.
    repeat find_rewrite. repeat find_inversion.
    eauto using at_head_of_queue_intro.
  Qed.

  Lemma locks_correct_unlock_at_head_preserved :
    forall sigma st' p,
      locks_correct_unlock sigma p ->
      (forall c, at_head_of_queue sigma c -> at_head_of_queue (update sigma Server st') c) ->
      locks_correct_unlock (update sigma Server st') p.
  Proof using.
    unfold locks_correct_unlock, valid_unlock.
    intuition.
    break_exists.
    exists x.
    intuition.
    - firstorder.
    - now rewrite_update.
  Qed.

  Lemma nil_at_head_of_queue_preserved :
    forall c sigma sigma',
      queue (sigma Server) = [] ->
      at_head_of_queue sigma c ->
      at_head_of_queue sigma' c.
  Proof using.
    unfold at_head_of_queue.
    firstorder.
    congruence.
  Qed.

  Lemma locks_correct_unlock_net_handlers_old :
    forall p sigma u st' out ms q,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_unlock sigma q ->
      LockServ_network_network_invariant p q ->
      locks_correct_unlock (update sigma (pDst p) st') q.
  Proof using.
    set_up_net_handlers;
    eauto using locks_correct_unlock_sent_lock, nwnw_locked_lock,
                locks_correct_unlock_at_head_preserved, snoc_at_head_of_queue_preserved,
                nwnw_unlock_lock, nil_at_head_of_queue_preserved.
  Qed.

  Lemma locks_correct_locked_at_head_preserved :
    forall sigma st' p,
      locks_correct_locked sigma p ->
      (forall c, at_head_of_queue sigma c -> at_head_of_queue (update sigma Server st') c) ->
      locks_correct_locked (update sigma Server st') p.
  Proof using.
    unfold locks_correct_locked, valid_locked.
    intuition.
    break_exists.
    exists x.
    intuition.
    - firstorder.
    - now rewrite_update.
  Qed.

  Lemma locks_correct_locked_net_handlers_old :
    forall p sigma u st' out ms q,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_locked sigma q ->
      LockServ_network_network_invariant p q ->
      locks_correct_locked (update sigma (pDst p) st') q.
  Proof using.
    set_up_net_handlers;
    eauto using locks_correct_locked_sent_lock, nwnw_locked_lock,
      locks_correct_locked_at_head_preserved, snoc_at_head_of_queue_preserved,
      nwnw_unlock_lock, nil_at_head_of_queue_preserved.
  Qed.

  Lemma locks_correct_unlock_net_handlers_new :
    forall p sigma u st' out ms q,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      In (pDst q, pBody q) ms ->
      locks_correct_unlock (update sigma (pDst p) st') q.
  Proof using.
    set_up_net_handlers;
    auto using locks_correct_unlock_sent_locked.
  Qed.

  Lemma locks_correct_locked_intro :
    forall sigma p c t st',
      pDst p = Client c ->
      held (sigma (Client c)) = false ->
      queue st' = c :: t ->
      locks_correct_locked (update sigma Server st') p.
  Proof using.
    unfold locks_correct_locked, valid_locked.
    intros.
    exists c.
    intuition.
    - exists t. now rewrite_update.
    - now rewrite_update.
  Qed.

  Lemma locks_correct_locked_net_handlers_new :
    forall p sigma u st' out ms q,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_unlock sigma p ->
      In (pDst q, pBody q) ms ->
      locks_correct_locked (update sigma (pDst p) st') q.
  Proof using.
    set_up_net_handlers;
    eauto using locks_correct_locked_intro,
                empty_queue_all_clients_false,
                unlock_in_flight_all_clients_false.
  Qed.

  Lemma nwnw_lock :
    forall p p',
      pBody p = Lock ->
      LockServ_network_network_invariant p p'.
  Proof using.
    unfold LockServ_network_network_invariant.
    intuition; simpl in *; congruence.
  Qed.

  Lemma LockServ_nwnw_input_handlers_old_new :
    forall h i sigma u st' out ms p p',
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      LockServ_network_invariant sigma p ->
      In (pDst p', pBody p') ms ->
      pSrc p' = h ->
      LockServ_network_network_invariant p p'.
  Proof using.
    unfold LockServ_network_invariant.
    set_up_input_handlers.
    - auto using nwnw_sym, nwnw_lock.
    - destruct (pBody p) eqn:?.
      + auto using nwnw_lock.
      + now erewrite unlock_in_flight_all_clients_false in * by eauto.
      + now erewrite locked_in_flight_all_clients_false in * by eauto.
  Qed.

  Lemma LockServ_nwnw_input_handlers_new_new :
    forall h i sigma u st' out ms,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      distinct_pairs_and LockServ_network_network_invariant
                         (map (fun m => mkPacket h (fst m) (snd m)) ms).
  Proof using.
    set_up_input_handlers.
  Qed.

  Lemma nw_empty_queue_lock :
    forall sigma p,
      LockServ_network_invariant sigma p ->
      queue (sigma Server) = [] ->
      pBody p = Lock.
  Proof using.
    unfold LockServ_network_invariant,
    locks_correct_unlock, locks_correct_locked,
    valid_unlock, valid_locked.
    intuition.
    destruct (pBody p) eqn:?; intuition; break_exists; intuition; break_exists;
    congruence.
  Qed.

  Lemma LockServ_nwnw_net_handlers_old_new :
    forall p sigma u st' out ms q p',
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      LockServ_network_invariant sigma p ->
      LockServ_network_invariant sigma q ->
      LockServ_network_network_invariant p q ->
      In (pDst p', pBody p') ms ->
      LockServ_network_network_invariant p' q.
  Proof using.
    set_up_net_handlers;
    eauto using nwnw_sym, nwnw_lock, nw_empty_queue_lock, nwnw_unlock_lock.
  Qed.

  Lemma LockServ_nwnw_net_handlers_new_new :
    forall p sigma u st' out ms,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      LockServ_network_invariant sigma p ->
      distinct_pairs_and LockServ_network_network_invariant
                         (map (fun m => mkPacket (pDst p) (fst m) (snd m)) ms).
  Proof using.
    set_up_net_handlers.
  Qed.

  Instance LockServ_Decompositition : Decomposition _ LockServ_MultiParams.
  apply Build_Decomposition with (state_invariant := locks_correct)
                                 (network_invariant := LockServ_network_invariant)
                                 (network_network_invariant := LockServ_network_network_invariant);
    simpl; intros; monad_unfold; repeat break_let; repeat find_inversion.
  - auto using nwnw_sym.
  - auto using locks_correct_init.
  - eauto using locks_correct_input_handlers.
  - unfold LockServ_network_invariant in *. intuition.
    eauto using locks_correct_net_handlers.
  - unfold LockServ_network_invariant in *.
    intuition eauto using locks_correct_unlock_input_handlers_old,
                          locks_correct_locked_input_handlers_old.
  - unfold LockServ_network_invariant in *.
    intuition eauto using locks_correct_unlock_input_handlers_new,
                          locks_correct_locked_input_handlers_new.
  - unfold LockServ_network_invariant in *.
    intuition eauto using locks_correct_unlock_net_handlers_old,
                          locks_correct_locked_net_handlers_old.
  - unfold LockServ_network_invariant in *.
    intuition eauto using locks_correct_unlock_net_handlers_new,
                          locks_correct_locked_net_handlers_new.
  - eauto using LockServ_nwnw_input_handlers_old_new.
  - eauto using LockServ_nwnw_input_handlers_new_new.
  - eauto using LockServ_nwnw_net_handlers_old_new.
  - eauto using LockServ_nwnw_net_handlers_new_new.
  Defined.

  Theorem true_in_reachable_mutual_exclusion :
    true_in_reachable step_m step_m_init (fun net => mutual_exclusion (nwState net)).
  Proof using.
    pose proof decomposition_invariant.
    find_apply_lem_hyp inductive_invariant_true_in_reachable.
    unfold true_in_reachable in *.
    intros.
    apply locks_correct_implies_mutex.
    match goal with
    | [ H : _ |- _ ] => apply H
    end.
    auto.
  Qed.

  Fixpoint last_holder' (holder : option Client_index) (trace : list (name * (input + list output))) : option Client_index :=
    match trace with
      | [] => holder
      | (Client n, inl Unlock) :: tr => match holder with
                                          | None => last_holder' holder tr
                                          | Some m => if fin_eq_dec _ n m
                                                      then last_holder' None tr
                                                      else last_holder' holder tr
                                        end

      | (Client n, inr [Locked]) :: tr => last_holder' (Some n) tr
      | (n, _) :: tr => last_holder' holder tr
    end.

  Fixpoint trace_mutual_exclusion' (holder : option Client_index) (trace : list (name * (input + list output))) : Prop :=
    match trace with
      | [] => True
      | (Client n, (inl Unlock)) :: tr' => match holder with
                                             | Some m => if fin_eq_dec _ n m
                                                         then trace_mutual_exclusion' None tr'
                                                         else trace_mutual_exclusion' holder tr'
                                             | _ => trace_mutual_exclusion' holder tr'
                                           end
      | (n, (inl _)) :: tr' => trace_mutual_exclusion' holder tr'
      | (Client n, (inr [Locked])) :: tr' => match holder with
                                               | None => trace_mutual_exclusion' (Some n) tr'
                                               | Some _ => False
                                             end
      | (_, (inr [])) :: tr' => trace_mutual_exclusion' holder tr'
      | (_, (inr _)) :: tr' => False
    end.

  Definition trace_mutual_exclusion (trace : list (name * (input + list output))) : Prop :=
    trace_mutual_exclusion' None trace.

  Definition last_holder (trace : list (name * (input + list output))) : option Client_index :=
    last_holder' None trace.

  Lemma cross_relation :
    forall (P : network -> list (name * (input + list output)) -> Prop),
      P step_m_init [] ->
      (forall st st' tr ev,
         step_m_star step_m_init st tr ->
         P st tr ->
         step_m st st' ev ->
         P st' (tr ++ ev)) ->
      forall st tr,
        step_m_star step_m_init st tr ->
        P st tr.
  Proof using.
    intros.
    find_apply_lem_hyp refl_trans_1n_n1_trace.
    prep_induction H1.
    induction H1; intros; subst; eauto.
    eapply H3; eauto.
    - apply refl_trans_n1_1n_trace. auto.
    - apply IHrefl_trans_n1_trace; auto.
  Qed.

  Lemma trace_mutex'_no_out_extend :
    forall tr n h,
      trace_mutual_exclusion' h tr ->
      trace_mutual_exclusion' h (tr ++ [(n, inr [])]).
  Proof using.
    induction tr; intuition; unfold trace_mutual_exclusion in *; simpl in *;
    repeat break_match; subst; intuition.
  Qed.

  Lemma last_holder'_no_out_inv :
    forall tr h c n,
      last_holder' h (tr ++ [(c, inr [])]) = Some n ->
      last_holder' h tr = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst; intuition; eauto.
  Qed.

  Lemma last_holder'_no_out_extend :
    forall tr h c n,
      last_holder' h tr = Some n ->
      last_holder' h (tr ++ [(c, inr [])]) = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst; intuition.
  Qed.

  Lemma decomposition_reachable_nw_invariant :
    forall st tr p,
      step_m_star step_m_init st tr ->
      In p (nwPackets st) ->
      network_invariant (nwState st) p.
  Proof using.
    pose proof decomposition_invariant.
    find_apply_lem_hyp inductive_invariant_true_in_reachable.
    unfold true_in_reachable, reachable in *.
    intuition.
    unfold composed_invariant in *.
    apply H; eauto.
  Qed.

  Lemma trace_mutex'_locked_extend :
    forall tr h n,
      trace_mutual_exclusion' h tr ->
      last_holder' h tr = None ->
      trace_mutual_exclusion' h (tr ++ [(Client n, inr [Locked])]).
  Proof using.
    induction tr; intros; simpl in *.
    - subst. auto.
    - simpl in *. repeat break_match; subst; intuition.
  Qed.

  Lemma reachable_intro :
    forall a tr,
      step_m_star step_m_init a tr ->
      reachable step_m step_m_init a.
  Proof using.
    unfold reachable.
    intros. eauto.
  Qed.

  Lemma locks_correct_locked_invariant :
    forall st p,
      reachable step_m step_m_init st ->
      In p (nwPackets st) ->
      locks_correct_locked (nwState st) p.
  Proof using.
    intros.
    pose proof decomposition_invariant.
    find_apply_lem_hyp inductive_invariant_true_in_reachable.
    unfold true_in_reachable in *. apply H1; auto.
  Qed.

  Lemma locks_correct_invariant :
    forall st,
      reachable step_m step_m_init st ->
      locks_correct (nwState st).
  Proof using.
    intros.
    pose proof decomposition_invariant.
    find_apply_lem_hyp inductive_invariant_true_in_reachable.
    unfold true_in_reachable in *. apply H0; auto.
  Qed.

  Lemma mutual_exclusion_invariant :
    forall st,
      reachable step_m step_m_init st ->
      mutual_exclusion (nwState st).
  Proof using.
    intros.
    apply locks_correct_implies_mutex.
    auto using locks_correct_invariant.
  Qed.

  Lemma last_holder'_locked_some_eq :
    forall tr h c n,
      last_holder' h (tr ++ [(Client c, inr [Locked])]) = Some n ->
      c = n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst; eauto.
    congruence.
  Qed.

  Ltac my_update_destruct :=
    match goal with
      | [H : context [ update _ ?x _ ?y ] |- _ ] => destruct (Name_eq_dec x y)
      | [ |- context [ update _ ?x _ ?y ] ] => destruct (Name_eq_dec x y)
    end.

  Lemma last_holder'_server_extend :
    forall tr h i,
      last_holder' h (tr ++ [(Server, inl i)]) = last_holder' h tr.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto.
  Qed.

  Lemma last_holder'_locked_extend :
    forall tr h n,
      last_holder' h (tr ++ [(Client n, inr [Locked])]) = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto.
  Qed.

  Lemma trace_mutual_exclusion'_extend_input :
    forall tr h c i,
      i <> Unlock ->
      trace_mutual_exclusion' h tr ->
      trace_mutual_exclusion' h (tr ++ [(Client c, inl i)]).
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; intuition.
  Qed.

  Lemma trace_mutual_exclusion'_extend_input_server :
    forall tr h i,
      trace_mutual_exclusion' h tr ->
      trace_mutual_exclusion' h (tr ++ [(Server, inl i)]).
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; intuition.
  Qed.

  Lemma last_holder'_input_inv :
    forall tr h c i n,
      i <> Unlock ->
      last_holder' h (tr ++ [(Client c, inl i)]) = Some n ->
      last_holder' h tr = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto; try congruence; subst; eauto.
  Qed.

  Lemma last_holder'_input_inv_server :
    forall tr h i n,
      last_holder' h (tr ++ [(Server, inl i)]) = Some n ->
      last_holder' h tr = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto; try congruence; subst; eauto.
  Qed.

  Lemma last_holder'_input_extend :
    forall tr h c i n,
      i <> Unlock ->
      last_holder' h tr = Some n ->
      last_holder' h (tr ++ [(Client c, inl i)]) = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto.
    congruence.
  Qed.

  Lemma trace_mutex'_unlock_extend :
    forall tr h c,
      trace_mutual_exclusion' h tr ->
      trace_mutual_exclusion' h (tr ++ [(Client c, inl Unlock)]).
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; intuition (auto; try congruence).
  Qed.

  Lemma last_holder'_unlock_none :
    forall tr h c,
      last_holder' h tr = Some c ->
      last_holder' h (tr ++ [(Client c, inl Unlock)]) = None.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; intuition.
    congruence.
  Qed.

  Lemma last_holder_unlock_none :
    forall tr c,
      last_holder tr = Some c ->
      last_holder (tr ++ [(Client c, inl Unlock)]) = None.
  Proof using.
    intros.
    apply last_holder'_unlock_none. auto.
  Qed.

  Lemma last_holder_some_unlock_inv :
    forall tr h c n,
      last_holder' h (tr ++ [(Client c, inl Unlock)]) = Some n ->
      last_holder' h tr = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst;
    intuition; try congruence; eauto.
  Qed.

  Lemma last_holder'_neq_unlock_extend :
    forall tr h n c,
      last_holder' h tr = Some n ->
      n <> c ->
      last_holder' h (tr ++ [(Client c, inl Unlock)]) = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst; try congruence; intuition.
  Qed.

  Lemma LockServ_mutual_exclusion_trace :
    forall st tr,
      step_m_star step_m_init st tr ->
      trace_mutual_exclusion tr /\
      (forall n, last_holder tr = Some n -> held (nwState st (Client n)) = true) /\
      (forall n, held (nwState st (Client n)) = true -> last_holder tr = Some n).
  Proof using.
    apply cross_relation; intros.
    - intuition.
      + red. red. auto.
      + unfold last_holder in *. simpl in *. discriminate.
      + unfold last_holder in *. simpl in *. discriminate.
    - match goal with
        | [ H : step_m _ _ _ |- _ ] => invcs H
      end; monad_unfold; repeat break_let; repeat find_inversion.
      + unfold NetHandler in *. break_match.
        * find_apply_lem_hyp ClientNetHandler_cases.
          break_and.
          { break_or_hyp.
            - intuition; subst.
              + apply trace_mutex'_no_out_extend; auto.
              + rewrite update_nop_ext.
                find_apply_lem_hyp last_holder'_no_out_inv.
                auto.
              + match goal with
                  | [ H : _ |- _ ] => rewrite update_nop in H
                end.
                find_apply_hyp_hyp.
                apply last_holder'_no_out_extend. auto.
            - intuition; subst.
              + apply trace_mutex'_locked_extend. auto.
                destruct (last_holder' None tr) eqn:?; auto.
                find_apply_hyp_hyp.
                erewrite locked_in_flight_all_clients_false in * by
                  eauto using locks_correct_locked_invariant, reachable_intro,
                              locks_correct_invariant.
                discriminate.
              + my_update_destruct; try find_inversion; rewrite_update; auto.
                find_apply_lem_hyp last_holder'_locked_some_eq. congruence.
              + my_update_destruct; try find_inversion; rewrite_update.
                * apply last_holder'_locked_extend.
                * erewrite locked_in_flight_all_clients_false in * by
                      eauto using locks_correct_locked_invariant, reachable_intro,
                                  locks_correct_invariant.
                  discriminate.
          }
        * { find_apply_lem_hyp ServerNetHandler_cases. break_and. subst.
            repeat split.
            - apply trace_mutex'_no_out_extend. auto.
            - intros. my_update_destruct; try discriminate.
              rewrite_update.
              find_apply_lem_hyp last_holder'_no_out_inv.
              auto.
            - intros. my_update_destruct; try discriminate; rewrite_update.
              apply last_holder'_no_out_extend. auto.
          }
      + unfold InputHandler in *. break_match.
        * unfold ClientIOHandler in *.
          { monad_unfold.
            repeat break_match; repeat find_inversion; intuition;
            repeat rewrite snoc_assoc in *;
            try apply trace_mutex'_no_out_extend;
            try find_apply_lem_hyp last_holder'_no_out_inv;
            try (apply last_holder'_no_out_extend; auto).
            - apply trace_mutual_exclusion'_extend_input; auto. congruence.
            - rewrite update_nop_ext.
              find_apply_lem_hyp last_holder'_input_inv; try congruence.
              auto.
            - match goal with
                | [ H : _ |- _ ] => rewrite update_nop in H
              end.
              apply last_holder'_input_extend; auto. congruence.
            - apply trace_mutex'_unlock_extend; auto.
            - rewrite last_holder_unlock_none in *; auto. discriminate.
            - my_update_destruct; try find_inversion; rewrite_update.
              + discriminate.
              + assert (mutual_exclusion (nwState st))
                       by eauto using mutual_exclusion_invariant, reachable_intro.
                unfold mutual_exclusion in *.
                assert (c = n) by eauto. congruence.
            - apply trace_mutex'_unlock_extend. auto.
            - rewrite update_nop.
              find_apply_lem_hyp last_holder_some_unlock_inv.
              auto.
            - match goal with
                | [ H : _ |- _ ] => rewrite update_nop in H
              end.
              assert (n <> c) by congruence.
              find_apply_hyp_hyp.
              apply last_holder'_neq_unlock_extend; auto.
            - apply trace_mutual_exclusion'_extend_input; auto. congruence.
            - rewrite update_nop_ext. find_apply_lem_hyp last_holder'_input_inv; try congruence.
              auto.
            - match goal with
                | [ H : _ |- _ ] => rewrite update_nop in H
              end.
              apply last_holder'_input_extend; auto. congruence.
          }
        * unfold ServerIOHandler in *.
          monad_unfold. find_inversion.
          { intuition;
            repeat rewrite snoc_assoc in *.
            - apply trace_mutex'_no_out_extend.
              apply trace_mutual_exclusion'_extend_input_server. auto.
            - find_apply_lem_hyp last_holder'_no_out_inv.
              rewrite update_nop. find_apply_lem_hyp last_holder'_input_inv_server. auto.
            - apply last_holder'_no_out_extend; auto.
              rewrite_update. unfold last_holder. rewrite last_holder'_server_extend.
              auto.
          }
  Qed.
End LockServ.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^165 - 25
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 3%nat;
    base := 64;
    bitwidth := 64;
    s := 2^165;
    c := [(1, 25)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


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

Require Import PIOA Premeas Meas Posrat Aux FastEnum CompPIOA Closure Action.

Definition comparable {Gamma D D' : ctx} (P1 : PIOA Gamma D) (P2 : PIOA Gamma D') := (inputs P1 ==i inputs P2) && (outputs P1 ==i outputs P2).

Definition env {Gamma D D' : ctx} (P1 : PIOA Gamma D) (P2 : PIOA Gamma D') :=
  compatible P1 P2 && closed (P1 ||| P2).

Definition closed_refine {G D D' : ctx} (P : PIOA G D) (P' : PIOA G D') (hc : comparable P P') :=
  forall g, valid_chanseq P g -> exists g', valid_chanseq P' g' /\ (run P g <$> snd = run P' g' <$> snd).

Lemma comparable_comp_r {G D D' D'' : ctx} {P : PIOA G D} {P' : PIOA G D'} (E : PIOA G D'') (hc : comparable P P') : comparable (P ||| E) (P' ||| E).
  elim (andP hc); move/seq_eqmemP => h1; move/seq_eqmemP => h2.
  apply/andP; split.
  simpl.
  apply/seq_eqmemP => x.
  rewrite !mem_seqD !mem_cat !h1 !h2 //=.
  apply/seq_eqmemP => x; rewrite !mem_cat !h2 //=.
Qed.

Definition refines  {Gamma D D' : ctx} (P1 : PIOA Gamma D) (P2 : PIOA Gamma D') (hc : comparable P1 P2) :=
  forall {D'' : ctx} (E: PIOA Gamma D''), env P1 E -> closed_refine (P1 ||| E) (P2 ||| E) (comparable_comp_r _ hc).

(* various lemms *)
Lemma valid_pchan_comp {G D D' : ctx} (P : PIOA G D) (E : PIOA G D') (he : env P E) x :
  valid_pchan (P ||| E) (inr x) = (x \in outputs P) || (x \in outputs E).
  rewrite /valid_pchan //=.
  rewrite mem_cat //= .
Qed.

Lemma valid_pchan_compare {G D : ctx} (P P' : PIOA G D) (hc : comparable P P') :
    valid_pchan P =1 valid_pchan P'.
    case; simpl.
    done.
    elim (andP hc).
    move => _ /seq_eqmemP => h; intro; rewrite h //=.
Qed.

Lemma comparable_sym {G D : ctx} (P P' : PIOA G D) :
  comparable P P' = comparable P' P.
  apply Bool.eq_true_iff_eq; split; rewrite /comparable; move/andP; elim; move/seq_eqmemP => h1; move/seq_eqmemP => h2; apply/andP; split; apply/seq_eqmemP => x; rewrite ?h1 ?h2 //=.
Qed.

Lemma comparable_compatible_l {G D D' D'' : ctx} (P : PIOA G D) (P' : PIOA G D') (E : PIOA G D'') :
  comparable P P' -> compatible P E -> compatible P' E.
  move/andP; elim; move/seq_eqmemP => h1; move/seq_eqmemP => h2; rewrite /compatible.
  move/seq_disjointP => H; apply/seq_disjointP => x.
  rewrite -h2 //=; apply H.
Qed.

Section InternalSim.
  Context {G D D' : ctx} (P : PIOA G D) (P' : PIOA G D') (hc : comparable P P').
  Context (ccorr : C P -> (seq (H P') * C P' * seq (H P'))).
  Context (hcorr : H P -> seq (H P')).

  Context (h_ccorr : forall c, c \in outputs P -> (ccorr c).1.2 \in outputs P').

  Definition seq_ccorr (c : C P) : seq (cdom D' + cdom G) :=
    (map inl (ccorr c).1.1) ++ (inr (ccorr c).1.2 :: (map inl (ccorr c).2)).

  Definition seq_hcorr (h : H P) : seq (cdom D' + cdom G) := map inl (hcorr h).

  Record InternalSim (R : {meas (St P) * trace P} -> {meas (St P') * trace P'} -> bool) :=
    {
      int_sound : forall mu eta, mvalid P mu -> mvalid P' eta -> R mu eta -> mu <$> snd = eta <$> snd;
      int_start : R (initDist P) (initDist P');
      int_stepv : forall mu eta c, c \in outputs P ->
                                         mvalid P mu ->
                                         mvalid P' eta ->
                                         R mu eta ->
                                         closure R (act P (inr c) mu) (runFrom P' (seq_ccorr c) eta);
      int_steph : forall mu eta h,
          mvalid P mu ->
          mvalid P' eta ->
          R mu eta ->
          closure R (act P (inl h) mu) (runFrom P' (seq_hcorr h) eta)
                                           }.

  Lemma InternalSim_sound R : InternalSim R ->  closed P ->
                              closed_refine P P' hc.
    case => h1 h2 h3 h4 cl1.

    have: forall g1, valid_chanseq P g1 -> exists g2, valid_chanseq P' g2 /\ closure R (run P g1) (run P' g2).

    induction g1 using last_ind.
    move => _; exists nil.
    simpl.
    rewrite /run //=.
    split.
    done.
    apply id_closure.
    apply isdist_ret.
    apply isdist_ret.
    done.

    rewrite /valid_chanseq all_rcons; move/andP; elim => hg1 hg2.
    destruct x as [h | c].
    elim (IHg1 hg2) => g' Hg' {IHg1}.
    destruct Hg' as [IH1 IH2].
    exists (g' ++ (seq_hcorr h)); split.
    rewrite all_cat; apply/andP; split.
    done.
    rewrite all_map; induction (hcorr h); done.
    rewrite run_rcons run_cat.
    rewrite runFrom_mkbind act_mkbind.

    destruct IH2; simpl in *.
    move/and3P: H; elim => H1 H2 H3; simpl in *.
    rewrite (eqP H1) (eqP H2); msimp.
    apply closure_bind; simpl => X HX.
    move/and3P: (allP H3 _ HX); elim => H4 H5 H6.
    rewrite -runFrom_mkbind.
    apply h4.

    split.
    simpl => x0 Hx0; have: x0 \in support (run P g1).
    rewrite (eqP H1); apply/support_bindP; exists X; split; done.
    intro.
    have: mvalid P (run P g1) by apply run_mvalid.
    elim.
    move/(_ _ x1); done.
    done.

    split.
    simpl => x0 Hx0; have: x0 \in support (run P' g').
    rewrite (eqP H2); apply/support_bindP; exists X; split; done.
    intro.
    have: mvalid P' (run P' g') by apply run_mvalid.
    elim.
    move/(_ _ x1); done.
    done.
    done.

    elim (IHg1 hg2) => g' Hg' {IHg1}.
    destruct Hg' as [IH1 IH2].
    exists (g' ++ (seq_ccorr c)); split.
    rewrite all_cat; apply/andP; split; rewrite //=.
    rewrite /seq_ccorr all_cat all_cons ?andbT.
    rewrite all_map; induction (ccorr c).1.1; done.
    simpl.
    by apply h_ccorr.

    rewrite all_map; induction (ccorr c).2; done.

    rewrite run_rcons run_cat act_mkbind runFrom_mkbind.
    elim IH2 => L; move/and3P; elim => Hl1 Hl2 Hl3; simpl in *.
    rewrite (eqP Hl1) (eqP Hl2); msimp; apply closure_bind.
    simpl => x Hx.

    rewrite -runFrom_mkbind.
    apply h3.
    done.
    split.
    simpl => x0 Hx0.
    have: x0 \in support (run P g1).
    rewrite (eqP Hl1); apply/support_bindP; exists x; split; done.
    intro.
    have: mvalid P (run P g1) by apply run_mvalid.
    elim => H _.
    apply H; done.

    move/and3P: (allP Hl3 _ Hx); elim; done.

    split.
    intros.
    have: mvalid P' (run P' g') by apply run_mvalid.
    elim => H' _; apply H'.
    rewrite (eqP Hl2); apply/support_bindP; exists x; split; done.
    move/and3P: (allP Hl3 _ Hx); elim; done.
    move/and3P: (allP Hl3 _ Hx); elim; done.

    move => H g Hg.
    elim (H g Hg) => g'; exists g'; split.
    elim H0; done.
    apply eq_closure; simpl.
    apply closure_fmap; simpl.
    destruct H0.
    destruct H1; simpl in *.
    move/and3P: H1 => [H11 [H12 H13]].
    exists x; apply/and3P; split.
    done.
    done.
    apply/allP => y Hy.
    elim (and3P (allP H13 _ Hy)); intros; apply/and3P; split.
    done.
    done.
    apply/eqP; apply h1.

    split.
    intros; have: mvalid P (run P g) by apply run_mvalid.
    elim => H' _.
    apply H'.
    rewrite (eqP H11); apply/support_bindP.
    exists y; split; done.
    done.

    split.
    intros; have: mvalid P' (run P' g') by apply run_mvalid.
    elim => H' _.
    apply H'.
    rewrite (eqP H12); apply/support_bindP.
    exists y; split; done.
    done.
    done.
 Qed.
End InternalSim.


From isla Require Import opsem.

Definition a24 : isla_trace :=
  Smt (DeclareConst 50%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 50%Z)) Mk_annot :t:
  Smt (DefineConst 56%Z (Manyop (Bvmanyarith Bvor) [Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot; Val (Val_Symbolic 50%Z) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R22" [] (RegVal_Base (Val_Symbolic 56%Z)) Mk_annot :t:
  Smt (DeclareConst 57%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 57%Z)) Mk_annot :t:
  Smt (DefineConst 58%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 57%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 58%Z)) Mk_annot :t:
  tnil
.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus Zero lv0))).
Admitted.
QuickChick conj3eqsynthconj1.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import PSCIAux.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition psci_lookup_target_spec0 (rec: Pointer) (target: Z64) (adt: RData) : option (RData * Pointer) :=
    match rec, target with
    | (_rec_base, _rec_ofst), VZ64 _target =>
      rely is_int64 _target;
      when _valid == mpidr_is_valid_spec (VZ64 _target) adt;
      rely is_int _valid;
      if (_valid =? 0) then
        when'' _t'2_base, _t'2_ofst == null_ptr_spec  adt;
        rely is_int _t'2_ofst;
        Some (adt, (_t'2_base, _t'2_ofst))
      else
        when'' _g_rd_base, _g_rd_ofst == get_rec_g_rd_spec (_rec_base, _rec_ofst) adt;
        rely is_int _g_rd_ofst;
        when'' _g_rec_list_base, _g_rec_list_ofst == get_rec_g_rec_list_spec (_rec_base, _rec_ofst) adt;
        rely is_int _g_rec_list_ofst;
        when'' _rec_list_base, _rec_list_ofst, adt == granule_map_spec (_g_rec_list_base, _g_rec_list_ofst) 6 adt;
        rely is_int _rec_list_ofst;
        when' _t'6 == mpidr_to_rec_idx_spec (VZ64 _target) adt;
        rely is_int64 _t'6;
        when'' _t'7_base, _t'7_ofst, adt == find_lock_rec_spec (_g_rd_base, _g_rd_ofst) (_rec_list_base, _rec_list_ofst) (VZ64 _t'6) adt;
        rely is_int _t'7_ofst;
        when adt == buffer_unmap_spec (_rec_list_base, _rec_list_ofst) adt;
        Some (adt, (_t'7_base, _t'7_ofst))
     end
    .

End SpecLow.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e222m117_10limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.SyntheticHomotopyTheory.Circle2.
Require Import UniMath.SyntheticHomotopyTheory.AffineLine.
Require Import UniMath.NumberSystems.Integers.
Local Open Scope hz.
Require Import UniMath.Algebra.BinaryOperations.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.GroupAction.
Local Open Scope abgr.
Local Open Scope action_scope.
Local Notation "0" := (toℤ 0).
Local Notation "1" := (toℤ 1).

Section A.

  Goal ∏ (X:Type) (f := eqweqmap (idpath X)), f = idweq X.
    reflexivity. Qed.

  Goal ∏ (X:Type), invmap (idweq X) = idfun X.
    reflexivity. Qed.

  Goal ∏ (X:Type) (x:X), iscontrpr1 (iscontrcoconusfromt X x) = (x,,idpath x).
    reflexivity. Qed.

  Goal ∏ (X:Type) (x:X), iscontrpr1 (iscontrcoconustot X x) = (x,,idpath x).
    reflexivity. Qed.

  Goal ∏ (X Y:Type) (f:X≃Y), invmap (invweq f) = f.
    reflexivity. Qed.

  Goal ∏ (X Y Z:Type) (f:X≃Y) (g:Y≃Z), pr1weq (weqcomp f g) = funcomp f g.
    reflexivity. Qed.

  Goal ∏ (X Y Z:Type) (f:X≃Y) (g:Y≃Z), invmap (weqcomp f g) = funcomp (invmap g) (invmap f).
    reflexivity. Qed.

  Goal ∏ {X : UU} (P Q : X -> Type) (f : ∏ x, P x ≃ Q x) (x:X) (p:P x), weqfibtototal _ _ f (x,,p) = (x,,f x p).
    reflexivity. Qed.

  Goal ∏ {X : UU} (P Q : X -> Type) (f : ∏ x, P x ≃ Q x) (x:X) (q:Q x), invmap (weqfibtototal _ _ f) (x,,q) = (x,,invmap (f x) q).
    reflexivity. Qed.

  Goal ∏ {X Y : Type} (w : X ≃ Y) (is : iscontr Y), iscontrpr1 (iscontrweqb w is) = invmap w (iscontrpr1 is).
    reflexivity. Qed.

  Goal ∏ {X Y : Type} (w : X ≃ Y) (is : iscontr X), iscontrpr1 (iscontrweqf w is) = w (iscontrpr1 is).
    reflexivity. Qed.

  Goal ∏ (X:Type) (i : isConnected X) (P:X->hProp) (x0:X) (p:P x0), @predicateOnConnectedType X i P x0 p x0 = p.
    Fail reflexivity. Abort.

  Goal ∏ (X:Type) (i : iscontr X) (x0 := pr1 i : X), pr2 i x0 = idpath x0.
    Fail reflexivity. Abort.

  Goal ∏ (X Y:Type) (p:X=Y) (x:X), eqweqmap p x = cast p x.
    Fail reflexivity. Abort.

  Goal ∏ (X Y:Type) (p:X=Y) (x:X), eqweqmap p x = transportf (λ T, T) p x.
    Fail reflexivity. Abort.

  Goal ∏ {X:PointedType} (bc : isBaseConnected X) (t := basepoint X), pr2 (baseConnectedness X bc) t t = hinhpr (idpath t).
    Fail reflexivity.
  Abort.

  Goal ∏ (G:gr), isBaseConnected_BG G (trivialTorsor G) = hinhpr (idpath (trivialTorsor G)).
    Fail reflexivity.
  Abort.

  Goal ∏ (n:ℤ), (n+0 = n)%hz.
    Fail reflexivity.
  Abort.

  Goal ∏ (n:ℤ), (0+n = n)%hz.
    Fail reflexivity.
  Abort.

  Goal ∏ (X : UU) (P : hProp) (f : X → P) (x : X), hinhuniv f (hinhpr x) = f x.
    reflexivity.
  Qed.

End A.


(**

Syntax of the simply typed lambda calculus as a multisorted signature.

Written by: Anders Mörtberg, 2017

*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Combinatorics.Lists.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Slice.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.slicecat.

Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.LiftingInitial_alt.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.
Require Import UniMath.SubstitutionSystems.MonadsMultiSorted.
Require Import UniMath.SubstitutionSystems.MultiSorted.
Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction.

Local Open Scope cat.

(** * The simply typed lambda calculus from a multisorted binding signature *)
Section Lam.

Variable (sort : hSet) (arr : sort → sort → sort).

(** A lot of notations, upstream? *)
Local Infix "::" := (@cons _).
Local Notation "[]" := (@nil _) (at level 0, format "[]").
Local Notation "C / X" := (slice_cat C X).
Local Notation "a + b" := (setcoprod a b) : set.

Local Definition HSET_over_sort : category.
Proof.
exists (HSET / sort).
now apply has_homsets_slice_precat.
Defined.

Let HSET_over_sort2 := [HSET/sort,HSET_over_sort].

Local Lemma BinProducts_HSET_over_sort2 : BinProducts HSET_over_sort2.
Proof.
apply BinProducts_functor_precat, BinProducts_slice_precat, PullbacksHSET.
Defined.

Local Lemma Coproducts_HSET_over_sort2 : Coproducts ((sort × sort) + (sort × sort))%set HSET_over_sort2.
Proof.
apply Coproducts_functor_precat, Coproducts_slice_precat, CoproductsHSET.
apply setproperty.
Defined.

(** The signature of the simply typed lambda calculus *)
Definition STLC_Sig : MultiSortedSig sort.
Proof.
use make_MultiSortedSig.
- apply ((sort × sort) + (sort × sort))%set. (* todo: fix this once level of × is fixed *)
- intros H; induction H as [st|st]; induction st as [s t].
  + exact ((([],,arr s t) :: ([],,s) :: nil),,t).
  + exact (((cons s [],,t) :: []),,arr s t).
Defined.

(** The signature with strength for the simply typed lambda calculus *)
Definition STLC_Signature : Signature (HSET / sort) _ _:=
  MultiSortedSigToSignature sort STLC_Sig.

Let Id_H := Id_H _ (BinCoproducts_HSET_slice sort).

Definition STLC_Functor : functor HSET_over_sort2 HSET_over_sort2 :=
  Id_H STLC_Signature.

Lemma STLC_Functor_Initial : Initial (FunctorAlg STLC_Functor).
Proof.
apply SignatureInitialAlgebraSetSort.
apply is_omega_cocont_MultiSortedSigToSignature.
apply slice_precat_colims_of_shape, ColimsHSET_of_shape.
Defined.

Definition STLC_Monad : Monad (HSET / sort) :=
  MultiSortedSigToMonad sort STLC_Sig.

(** Extract the constructors of the stlc from the initial algebra *)
Definition STLC : HSET_over_sort2 :=
  alg_carrier _ (InitialObject STLC_Functor_Initial).

Let STLC_mor : HSET_over_sort2⟦STLC_Functor STLC,STLC⟧ :=
  alg_map _ (InitialObject STLC_Functor_Initial).

Let STLC_alg : algebra_ob STLC_Functor :=
  InitialObject STLC_Functor_Initial.

Local Lemma BP : BinProducts [HSET_over_sort,HSET].
Proof.
apply BinProducts_functor_precat, BinProductsHSET.
Defined.

Local Notation "'1'" := (functor_identity HSET_over_sort).
Local Notation "x ⊗ y" := (BinProductObject _ (BP x y)).

(** The variables *)

Definition var_map : HSET_over_sort2⟦1,STLC⟧ :=
  BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · STLC_mor.

(** The source of the application constructor *)
Definition app_source (s t : sort) (X : HSET_over_sort2) : HSET_over_sort2 :=
  ((X ∙ proj_functor sort (arr s t)) ⊗ (X ∙ proj_functor sort s)) ∙ hat_functor sort t.

(** The application constructor *)
Definition app_map (s t : sort) : HSET_over_sort2⟦app_source s t STLC,STLC⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (ii1 (s,, t)))
    · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
    · STLC_mor.

(** The source of the lambda constructor *)
Definition lam_source (s t : sort) (X : HSET_over_sort2) : HSET_over_sort2 :=
  (sorted_option_functor sort s ∙ X ∙ proj_functor sort t) ∙ hat_functor sort (arr s t).

Definition lam_map (s t : sort) : HSET_over_sort2⟦lam_source s t STLC,STLC⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (ii2 (s,,t)))
    · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)
    · STLC_mor.

Definition make_STLC_Algebra X (fvar : HSET_over_sort2⟦1,X⟧)
  (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧)
  (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) :
    algebra_ob STLC_Functor.
Proof.
apply (tpair _ X).
use (BinCoproductArrow _ fvar).
use CoproductArrow.
intro b; induction b as [st|st]; induction st as [s t].
- apply (fapp s t).
- apply (flam s t).
Defined.

(** The recursor for the stlc *)
Definition foldr_map X (fvar : HSET_over_sort2⟦1,X⟧)
  (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧)
  (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) :
  algebra_mor _ STLC_alg (make_STLC_Algebra X fvar fapp flam).
Proof.
apply (InitialArrow STLC_Functor_Initial (make_STLC_Algebra X fvar fapp flam)).
Defined.

(** The equation for variables *)
Lemma foldr_var X (fvar : HSET_over_sort2⟦1,X⟧)
  (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧)
  (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) :
  var_map · foldr_map X fvar fapp flam = fvar.
Proof.
assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · x)
                        (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))).
rewrite assoc in F.
eapply pathscomp0; [apply F|].
rewrite assoc.
eapply pathscomp0; [eapply cancel_postcomposition, BinCoproductOfArrowsIn1|].
rewrite <- assoc.
eapply pathscomp0; [eapply maponpaths, BinCoproductIn1Commutes|].
apply id_left.
Defined.

(* TODO: how to define the equations for app and lam? *)

End Lam.


Require Import GhostSimulations.

Require Import Raft.
Require Import RaftRefinementInterface.

Require Import SortedInterface.
Require Import AppendEntriesRequestTermSanityInterface.

Section AppendEntriesRequestTermSanity.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {si : sorted_interface}.

  Theorem lift_sorted :
    forall net,
      refined_raft_intermediate_reachable net ->
      logs_sorted (deghost net).
  Proof using si rri.
    intros.
    eapply lift_prop; eauto using logs_sorted_invariant.
  Qed.

  Lemma ghost_packet :
    forall (net : network (params := raft_refined_multi_params)) p,
      In p (nwPackets net) ->
      In (deghost_packet p) (nwPackets (deghost net)).
  Proof using.
    unfold deghost.
    simpl. intuition.
    apply in_map_iff.
    eexists; eauto.
  Qed.

  Lemma logs_sorted_aerts :
    forall net,
      logs_sorted (deghost net) ->
      append_entries_request_term_sanity net.
  Proof using.
    unfold logs_sorted, append_entries_request_term_sanity. intuition.
    unfold packets_ge_prevTerm in *. find_apply_lem_hyp ghost_packet.
    eauto.
  Qed.

  Instance aertsi : append_entries_request_term_sanity_interface.
  Proof.
    split. intros. find_apply_lem_hyp lift_sorted.
    eauto using logs_sorted_aerts.
  Qed.
End AppendEntriesRequestTermSanity.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj14synthconj2 : forall  (lv0 : lst) (lv1 : natural), (@eq natural (len (append lv0 (Cons lv1 lv0))) (len (append lv0 (Cons lv1 lv0)))).
Admitted.
QuickChick conj14synthconj2.


From Theories Require Import category.
From Theories Require Import translation_fib.

Set Primitive Projections.
Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.

(* translation of equality, CubicalTT-style *)

Definition path0 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (x0 : El0 A0)
  (x1 : El1 A0 A1 x0)
  (y0 : El0 A0)
  (y1 : El1 A0 A1 y0)
: @El0 p Type0.
Proof.
refine (fun q α => _).
unshelve econstructor.
- refine (fun r β => _).
  exact (itype r ((A0 r (α ∘ β)).(yft0) r !)
    (x0 r (α ∘ β)) (y0 r (α ∘ β))).
- refine (fun r β s => _). simpl in s.
  refine
  (forall (αi : r ≤ 1),
  (A0 r (α ∘ β)).(yft1) r !
  (fun r0 β0 => cast0 A0 A1 (α ∘ β) β0
    _
  )).
  refine (itype_out (s r0 β0) (αi ∘ β0)).
- refine (fun r β => _).
  apply falso.
Defined.

Definition path1 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (x0 : El0 A0)
  (x1 : El1 A0 A1 x0)
  (y0 : El0 A0)
  (y1 : El1 A0 A1 y0)
: @El1 p Type0 Type1 (path0 A0 A1 x0 x1 y0 y1).
Proof.
refine (fun q α => _).
reflexivity.
Defined.

Definition path_refl0 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (x0 : El0 A0)
  (x1 : El1 A0 A1 x0)
: El0 (path0 A0 A1 x0 x1 x0 x1).
Proof.
refine (fun q α => _). simpl.
exact (itype_in (fun _ => x0 q α)).
Defined.

Definition path_refl1 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (x0 : El0 A0)
  (x1 : El1 A0 A1 x0)
: El1 _ (path1 A0 A1 x0 x1 x0 x1) (path_refl0 A0 A1 x0 x1).
Proof.
refine (fun q α αi => _).
unfold path_refl0 ; simpl. unfold cast0 ; simpl.
refine (J_seqs _ (fun p A x y => x y)
  (fun X _ => yft1 (A0 q α) q !
    (fun r β => J_seq _ (α ⋅ A0)
      (fun a _ => yft0 (a r β) r !)
      (X r (yft0 (A0 r (α ∘ β)) r !) (fun _ => x0 r (α ∘ β)) (αi ∘ β))
      (fun r (β : r ≤ q) => yft_funct β (A0 q α)) (A1 q α)
    )
  )
  _ (fun p A (x : p ≤ 1 -> A) y => itype_out (itype_in x) y)
  (ssym itype_inout)).
refine (x1 q α).
Defined.

Definition itype_out0_aux {p} {A : Type} {B : A -> SProp}
  {X : forall (a : A) (b : B a), Type} {y z : forall (a : A) (b : B a), X a b}
  {x : forall (a : A) (b : B a), itype p (X a b) (y a b) (z a b)} :
  (fun a b => itype_out (x a b) i0) ≡ y.
Proof.
refine (J_seqs _ _ (fun T _ => (fun a b => T p (X a b) (y a b) (z a b) (x a b)) ≡ y) (srefl _) _ (ssym itype_out0)).
Defined.

Definition itype_out1_aux {p} {A : Type} {B : A -> SProp}
  {X : forall (a : A) (b : B a), Type} {y z : forall (a : A) (b : B a), X a b}
  {x : forall (a : A) (b : B a), itype p (X a b) (y a b) (z a b)} :
  (fun a b => itype_out (x a b) i1) ≡ z.
Proof.
refine (J_seqs _ _ (fun T _ => (fun a b => T p (X a b) (y a b) (z a b) (x a b)) ≡ z) (srefl _) _ (ssym itype_out1)).
Defined.

Definition path_funext0 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (B0 : @El0 p Type0)
  (B1 : @El1 p Type0 Type1 B0)
  (f0 : El0 (Arr0 A0 A1 B0 B1))
  (f1 : El1 _ (Arr1 A0 A1 B0 B1) f0)
  (g0 : El0 (Arr0 A0 A1 B0 B1))
  (g1 : El1 _ (Arr1 A0 A1 B0 B1) g0)
  (h0 : El0 (Prod0 A0 A1
    (fun q α x0 x1 => path0 (α ⋅ B0) (α ⋅ B1)
      (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
      (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
    (fun q α x0 x1 => path1 (α ⋅ B0) (α ⋅ B1)
      (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
      (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
    ))
  (h1 : El1 _ (Prod1 A0 A1
    (fun q α x0 x1 => path0 (α ⋅ B0) (α ⋅ B1)
      (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
      (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
    (fun q α x0 x1 => path1 (α ⋅ B0) (α ⋅ B1)
      (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
      (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
    ) h0)
: El0 (path0 (Arr0 A0 A1 B0 B1) (Arr1 A0 A1 B0 B1) f0 f1 g0 g1).
Proof.
refine (fun q α => _).
change (itype q (forall x0 : El0 (α ⋅ A0), El1 (α ⋅ A0) (α ⋅ A1) x0 -> yft0 (B0 q α) q !) (f0 q α) (g0 q α)).
assert ((fun x0 x1 => itype_out (h0 q α x0 x1) i0) ≡ f0 q α) as H0.
{ apply itype_out0_aux. }
assert ((fun x0 x1 => itype_out (h0 q α x0 x1) i1) ≡ g0 q α) as H1.
{ apply itype_out1_aux. }
refine (J_seq _ _ (fun x _ => itype q _ x _) _ _ H0).
refine (J_seq _ _ (fun x _ => itype q _ _ x) _ _ H1).
refine (itype_in (fun αi x0 x1 => itype_out (h0 q α x0 x1) αi)).
Defined.

Lemma app2_seq {A : Type} {B : A -> Type} {C : forall (x : A) (y : B x), Type} {f g : forall (x : A) (y : B x), C x y} (e : f ≡ g) (x : A) (y : B x) : f x y ≡ g x y.
Proof.
refine (J_seqs _ _ (fun X _ => f x y ≡ X x y) (srefl _) _ e).
Defined.

Definition path_funext1 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (B0 : @El0 p Type0)
  (B1 : @El1 p Type0 Type1 B0)
  (f0 : El0 (Arr0 A0 A1 B0 B1))
  (f1 : El1 _ (Arr1 A0 A1 B0 B1) f0)
  (g0 : El0 (Arr0 A0 A1 B0 B1))
  (g1 : El1 _ (Arr1 A0 A1 B0 B1) g0)
  (h0 : El0 (Prod0 A0 A1
    (fun q α x0 x1 => path0 (α ⋅ B0) (α ⋅ B1)
      (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
      (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
    (fun q α x0 x1 => path1 (α ⋅ B0) (α ⋅ B1)
      (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
      (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
    ))
  (h1 : El1 _ (Prod1 A0 A1
    (fun q α x0 x1 => path0 (α ⋅ B0) (α ⋅ B1)
      (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
      (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
    (fun q α x0 x1 => path1 (α ⋅ B0) (α ⋅ B1)
      (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
      (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
    ) h0)
: El1 _ (path1 (Arr0 A0 A1 B0 B1) (Arr1 A0 A1 B0 B1) f0 f1 g0 g1)
  (path_funext0 A0 A1 B0 B1 f0 f1 g0 g1 h0 h1).
Proof.
refine (fun q α αi x0 x1 => _).
change (yft1 (B0 q α) q ! (fun r β => cast0 B0 B1 α β (itype_out (path_funext0 A0 A1 B0 B1 f0 f1 g0 g1 h0 h1 r (α ∘ β)) (αi ∘ β) (β ⋅ x0) (β ⋅ x1)))).
unfold path_funext0 ; simpl.
assert ((fun r β y0 y1 => itype_out (h0 r (α ∘ β) y0 y1) i0) ≡ (fun r β => f0 r (α ∘ β))) as H0.
{ refine (J_seqs _ _ (fun T _ => (fun r β y0 y1 => T r (yft0 (B0 r (α ∘ β)) r !) (f0 r (α ∘ β) y0 y1) (g0 r (α ∘ β) y0 y1) (h0 r (α ∘ β) y0 y1)) ≡ α ⋅ f0) (srefl _) _ (ssym itype_out0)). }
assert ((fun r β y0 y1 => itype_out (h0 r (α ∘ β) y0 y1) i1) ≡ (fun r β => g0 r (α ∘ β))) as H1.
{ refine (J_seqs _ _ (fun T _ => (fun r β y0 y1 => T r (yft0 (B0 r (α ∘ β)) r !) (f0 r (α ∘ β) y0 y1) (g0 r (α ∘ β) y0 y1) (h0 r (α ∘ β) y0 y1)) ≡ α ⋅ g0) (srefl _) _ (ssym itype_out1)). }

match goal with
|- yft1 (B0 q α) q ! (fun r β => cast0 B0 B1 α β (itype_out (J_seq ?TT ?XX ?PP ?AA ?YY ?EE) (αi ∘ β) (β ⋅ x0) (β ⋅ x1))) =>
refine (J_seqs _ (fun r β y0 y1 => itype_out (h0 r (α ∘ β) y0 y1) i0) (fun X E =>
  yft1 (B0 q α) q ! (fun r β => cast0 B0 B1 α β (@itype_out r
    (forall y0 y1, yft0 (B0 r (α ∘ β)) r !) (X r β) (g0 r (α ∘ β))
    (J_seq TT (fun y0 y1 => itype_out (h0 r (α ∘ β) y0 y1) i0) PP AA (X r β) (app2_seq E r β))
    (αi ∘ β) (β ⋅ x0) (β ⋅ x1))))
  _ (fun r β => f0 r (α ∘ β)) H0)
end.
simpl.

match goal with
|- yft1 (B0 q α) q ! (fun r β => cast0 B0 B1 α β (itype_out (J_seq ?TT ?XX ?PP ?AA ?YY ?EE) (αi ∘ β) (β ⋅ x0) (β ⋅ x1))) =>
refine (J_seqs _ (fun r β y0 y1 => itype_out (h0 r (α ∘ β) y0 y1) i1) (fun X E =>
  yft1 (B0 q α) q ! (fun r β => cast0 B0 B1 α β (@itype_out r
    (forall y0 y1, yft0 (B0 r (α ∘ β)) r !) (fun y0 y1 => itype_out (h0 r (α ∘ β) y0 y1) i0) (X r β)
    (J_seq TT (fun y0 y1 => itype_out (h0 r (α ∘ β) y0 y1) i1) PP AA (X r β) (app2_seq E r β))
    (αi ∘ β) (β ⋅ x0) (β ⋅ x1))))
  _ (fun r β => g0 r (α ∘ β)) H1)
end.
simpl.

refine (J_seqs _ (fun (p : ℙ) (A : Type) (x : (p ≤ 1) -> A) (y : p ≤ 1) => x y)
               (fun X _ => yft1 (B0 q α) q ! (fun r β => cast0 B0 B1 α β (X r (forall y0 y1, yft0 (B0 r (α ∘ β)) r !) (fun αi0 x2 x3 => itype_out (h0 r (α ∘ β) x2 x3) αi0) (αi ∘ β) (β ⋅ x0) (β ⋅ x1))))
               _ (fun p A (x : p ≤ 1 -> A) y => itype_out (itype_in x) y) (ssym itype_inout)).
refine (h1 q α x0 x1 αi).
Defined.

(* comparing eq and path *)
(* we get functions both ways, but they do not form an equivalence without funext/η, since
   α ≠ merge (squish ∘ α) (antisquish ∘ α) *)

Lemma itype_out0_aux2 {A : Type} {B : A -> Type}
  {p : forall (a : A) (b : B a), nat}
  {X : forall (a : A) (b : B a), Type} {y z : forall (a : A) (b : B a), X a b}
  {x : forall (a : A) (b : B a), itype (p a b) (X a b) (y a b) (z a b)} :
  (fun a b => itype_out (x a b) i0) ≡ y.
Proof.
refine (J_seqs _ _ (fun T _ => (fun a b => T (p a b) (X a b) (y a b) (z a b) (x a b)) ≡ y) (srefl _) _ (ssym itype_out0)).
Defined.

Lemma itype_out1_aux2 {A : Type} {B : A -> Type}
  {p : forall (a : A) (b : B a), nat}
  {X : forall (a : A) (b : B a), Type} {y z : forall (a : A) (b : B a), X a b}
  {x : forall (a : A) (b : B a), itype (p a b) (X a b) (y a b) (z a b)} :
  (fun a b => itype_out (x a b) i1) ≡ z.
Proof.
refine (J_seqs _ _ (fun T _ => (fun a b => T (p a b) (X a b) (y a b) (z a b) (x a b)) ≡ z) (srefl _) _ (ssym itype_out1)).
Defined.

Definition compare0 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (x0 : El0 A0)
  (x1 : El1 A0 A1 x0)
  (y0 : El0 A0)
  (y1 : El1 A0 A1 y0)
  (e0 : El0 (path0 A0 A1 x0 x1 y0 y1))
  (e1 : El1 _ (path1 A0 A1 x0 x1 y0 y1) e0)
  : El0 (eq0 A0 A1 x0 x1 y0 y1).
Proof.
refine (fun q α => _).
unshelve econstructor.
- refine (fun r β => _).
  refine (itype_out (e0 r (α ∘ squish ∘ β)) (antisquish ∘ β)).
- refine (fun r β => _).
  refine (e1 r (α ∘ squish ∘ β) (antisquish ∘ β)).
- change ((fun r β => itype_out (e0 r (α ∘ β)) i0) ≡ α ⋅ x0).
  eapply itype_out0_aux2.
- change ((fun r β => itype_out (e0 r (α ∘ β)) i1) ≡ α ⋅ y0).
  eapply itype_out1_aux2.
Defined.

Definition compare1 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (x0 : El0 A0)
  (x1 : El1 A0 A1 x0)
  (y0 : El0 A0)
  (y1 : El1 A0 A1 y0)
  (e0 : El0 (path0 A0 A1 x0 x1 y0 y1))
  (e1 : El1 _ (path1 A0 A1 x0 x1 y0 y1) e0)
  : El1 _ (eq1 A0 A1 x0 x1 y0 y1) (compare0 A0 A1 x0 x1 y0 y1 e0 e1).
Proof.
refine (fun q α => _). simpl. unfold cube_eqR.
reflexivity.
Defined.

Definition anticompare0 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (x0 : El0 A0)
  (x1 : El1 A0 A1 x0)
  (y0 : El0 A0)
  (y1 : El1 A0 A1 y0)
  (e0 : El0 (eq0 A0 A1 x0 x1 y0 y1))
  (e1 : El1 _ (eq1 A0 A1 x0 x1 y0 y1) e0)
  : El0 (path0 A0 A1 x0 x1 y0 y1).
Proof.
refine (fun q α => _). simpl.
refine (J_seq _ _ (fun x _ => itype q _ (x q !) _) _ _ ((e0 q α).(ce_s))).
refine (J_seq _ _ (fun x _ => itype q _ _ (x q !)) _ _ ((e0 q α).(ce_t))).
refine (@itype_in q (yft0 (A0 q α) q !) (fun αi => (e0 q α).(ce_f0) q (merge ! αi))).
Defined.

Definition anticompare1 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (x0 : El0 A0)
  (x1 : El1 A0 A1 x0)
  (y0 : El0 A0)
  (y1 : El1 A0 A1 y0)
  (e0 : El0 (eq0 A0 A1 x0 x1 y0 y1))
  (e1 : El1 _ (eq1 A0 A1 x0 x1 y0 y1) e0)
  : El1 _ (path1 A0 A1 x0 x1 y0 y1) (anticompare0 A0 A1 x0 x1 y0 y1 e0 e1).
Proof.
refine (fun q α αi => _).
change (yft1 (A0 q α) q ! (fun r β => cast0 A0 A1 α β (itype_out (anticompare0 A0 A1 x0 x1 y0 y1 e0 e1 r (α ∘ β)) (αi ∘ β)))).
unfold anticompare0.
pose proof (e1 q α). simpl in H. unfold cube_eqR in H. unfold cast0 in H. simpl in H.
refine (J_seqs _ _ (fun X _ =>
  yft1 (A0 q α) q ! (fun r β => cast0 A0 A1 α β (itype_out
    (J_seq _ _
      (fun x (_ : side_0 ⋅ ce_f0 (X r β) ≡ x) =>
        itype r (yft0 (A0 r (α ∘ β)) r !)
          (x r !) (y0 r ((α ∘ β) ∘ !)))
      (J_seq _ _
        (fun x (_ : side_1 ⋅ ce_f0 (X r β) ≡ x) =>
          itype r (yft0 (A0 r (α ∘ β)) r !)
            (ce_f0 (X r β) r side_0) (x r !))
        (@itype_in r (yft0 (A0 r (α ∘ β)) r !) (fun αi0 : r ≤ 1 => ce_f0 (X r β) r (merge ! αi0)))
        (α ∘ β ⋅ y0) (ce_t (X r β)))
      (α ∘ β ⋅ x0) (ce_s (X r β)))
    (αi ∘ β)))) _ _ (ssym H)). simpl.
pose proof (ce_t (e0 q α)).
refine (J_seqs _ _ (fun X E =>
  yft1 (A0 q α) q !
    (fun (r : nat) (β : r ≤ q) =>
     cast0 A0 A1 α β
       (itype_out
          (J_seq _ _
             (fun (x : forall (x2 : nat) (x3 : x2 ≤ r), yft0 (A0 x2 ((α ∘ β) ∘ (squish ∘ (side_0 ∘ x3)))) x2 !)
                (_ : (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (promote β ∘ (side_0 ∘ β0))) ≡ x)
              => itype r (yft0 (A0 r (α ∘ β)) r !) (x r !) (X r β))
             (J_seq _ _
                (fun
                   (x : forall (x2 : nat) (x3 : x2 ≤ r), yft0 (A0 x2 ((α ∘ β) ∘ (squish ∘ (side_1 ∘ x3)))) x2 !)
                   (_ : (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (promote β ∘ (side_1 ∘ β0))) ≡ x)
                 => itype r (yft0 (A0 r (α ∘ β)) r !) (ce_f0 (e0 q (α ∘ !)) r (promote β ∘ side_0)) (x r !))
                (@itype_in r (yft0 (A0 r (α ∘ β)) r !)
                   (fun αi0 : r ≤ 1 => ce_f0 (e0 q (α ∘ !)) r (promote β ∘ merge ! αi0)))
                (β ⋅ X)
                (J_seqs _ _
                   (fun (u : forall (x2 : nat) (x3 : x2 ≤ q), yft0 (A0 x2 ((α ∘ !) ∘ (! ∘ x3))) x2 !)
                      (_ : side_1 ⋅ ce_f0 (e0 q (α ∘ !)) ≡ u) =>
                    (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (side_1 ∘ (β ∘ β0))) ≡ β ⋅ u)
                   (srefl (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (side_1 ∘ (β ∘ β0))))
                   X E))
             (α ∘ β ⋅ x0)
             (J_seqs _ _
                (fun (u : forall (x2 : nat) (x3 : x2 ≤ q), yft0 (A0 x2 ((α ∘ !) ∘ (! ∘ x3))) x2 !)
                   (_ : side_0 ⋅ ce_f0 (e0 q (α ∘ !)) ≡ u) =>
                 (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (side_0 ∘ (β ∘ β0))) ≡ β ⋅ u)
                (srefl (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (side_0 ∘ (β ∘ β0))))
                (fun (r0 : nat) (β0 : r0 ≤ q) => x0 r0 ((α ∘ !) ∘ (! ∘ β0))) (ce_s (e0 q (α ∘ !)))))
          (αi ∘ β)))) _ _ (ce_t (e0 q α))). simpl.
refine (J_seqs _ _ (fun X E =>
  yft1 (A0 q α) q !
    (fun (r : nat) (β : r ≤ q) =>
     cast0 A0 A1 α β
       (itype_out
          (J_seq (forall (x2 : nat) (x3 : x2 ≤ r), yft0 (A0 x2 ((α ∘ β) ∘ (squish ∘ (side_0 ∘ x3)))) x2 !)
             (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (promote β ∘ (side_0 ∘ β0)))
             (fun (x : forall (x2 : nat) (x3 : x2 ≤ r), yft0 (A0 x2 ((α ∘ β) ∘ (squish ∘ (side_0 ∘ x3)))) x2 !)
                (_ : (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (promote β ∘ (side_0 ∘ β0))) ≡ x)
              => itype r (yft0 (A0 r (α ∘ β)) r !) (x r !) (ce_f0 (e0 q (α ∘ !)) r (side_1 ∘ β)))
             (@itype_in r (yft0 (A0 r (α ∘ β)) r !)
                (fun αi0 : r ≤ 1 => ce_f0 (e0 q (α ∘ !)) r (promote β ∘ merge ! αi0)))
             (β ⋅ X)
             (J_seqs (forall (x2 : nat) (x3 : x2 ≤ q), yft0 (A0 x2 ((α ∘ !) ∘ (! ∘ x3))) x2 !)
                (side_0 ⋅ ce_f0 (e0 q (α ∘ !)))
                (fun (u : forall (x2 : nat) (x3 : x2 ≤ q), yft0 (A0 x2 ((α ∘ !) ∘ (! ∘ x3))) x2 !)
                   (_ : side_0 ⋅ ce_f0 (e0 q (α ∘ !)) ≡ u) =>
                 (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (side_0 ∘ (β ∘ β0))) ≡ β ⋅ u)
                (srefl (fun (r0 : nat) (β0 : r0 ≤ r) => ce_f0 (e0 q (α ∘ !)) r0 (side_0 ∘ (β ∘ β0))))
                X E))
          (αi ∘ β)))) _ _ (ce_s (e0 q α))). simpl.
refine (J_seqs _ _
  (fun x _ => yft1 (A0 q α) q ! (fun r β => cast0 A0 A1 α β (x r (yft0 (A0 r (α ∘ β)) r !) (fun αi0 : r ≤ 1 => ce_f0 (e0 q α) r (promote β ∘ merge ! αi0)) (αi ∘ β)))) _ _
               (ssym itype_inout)).
refine ((e0 q α).(ce_f1) q (merge ! αi)).
Defined.

Definition funext0 {p}
(A0 : @El0 p Type0)
(A1 : @El1 p Type0 Type1 A0)
(B0 : @El0 p Type0)
(B1 : @El1 p Type0 Type1 B0)
(f0 : El0 (Arr0 A0 A1 B0 B1))
(f1 : El1 _ (Arr1 A0 A1 B0 B1) f0)
(g0 : El0 (Arr0 A0 A1 B0 B1))
(g1 : El1 _ (Arr1 A0 A1 B0 B1) g0)
(h0 : El0 (Prod0 A0 A1
  (fun q α x0 x1 => eq0 (α ⋅ B0) (α ⋅ B1)
    (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
    (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
  (fun q α x0 x1 => eq1 (α ⋅ B0) (α ⋅ B1)
    (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
    (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
  ))
(h1 : El1 _ (Prod1 A0 A1
  (fun q α x0 x1 => eq0 (α ⋅ B0) (α ⋅ B1)
    (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
    (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
  (fun q α x0 x1 => eq1 (α ⋅ B0) (α ⋅ B1)
    (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
    (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
  ) h0)
: El0 (eq0 (Arr0 A0 A1 B0 B1) (Arr1 A0 A1 B0 B1) f0 f1 g0 g1).
Proof.
unshelve refine (compare0 (Arr0 A0 A1 B0 B1) (Arr1 A0 A1 B0 B1) f0 f1 g0 g1 _ _).
unshelve refine (path_funext0 A0 A1 B0 B1 f0 f1 g0 g1 _ _).
refine (fun q α x0 x1 => _).
refine (anticompare0 (α ⋅ B0) (α ⋅ B1)
  (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
  (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1)
  (@dapp0 q (α ⋅ A0) (α ⋅ A1)
    (fun r β y0 y1 => eq0 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (fun r β y0 y1 => eq1 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (α ⋅ h0) x0 x1)
  (@dapp1 q (α ⋅ A0) (α ⋅ A1)
    (fun r β y0 y1 => eq0 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (fun r β y0 y1 => eq1 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (α ⋅ h0) (α ⋅ h1) x0 x1) q !).
refine (fun q α x0 x1 => _).
refine (anticompare1 (α ⋅ B0) (α ⋅ B1)
  (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
  (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1)
  (@dapp0 q (α ⋅ A0) (α ⋅ A1)
    (fun r β y0 y1 => eq0 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (fun r β y0 y1 => eq1 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (α ⋅ h0) x0 x1)
  (@dapp1 q (α ⋅ A0) (α ⋅ A1)
  (fun r β y0 y1 => eq0 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
    (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
    (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
  (fun r β y0 y1 => eq1 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
    (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
    (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
  (α ⋅ h0) (α ⋅ h1) x0 x1) q !).
unshelve refine (path_funext1 A0 A1 B0 B1 f0 f1 g0 g1
  (fun q α x0 x1 => anticompare0 (α ⋅ B0) (α ⋅ B1)
  (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
  (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1)
  (@dapp0 q (α ⋅ A0) (α ⋅ A1)
    (fun r β y0 y1 => eq0 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (fun r β y0 y1 => eq1 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (α ⋅ h0) x0 x1)
  (@dapp1 q (α ⋅ A0) (α ⋅ A1)
    (fun r β y0 y1 => eq0 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (fun r β y0 y1 => eq1 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (α ⋅ h0) (α ⋅ h1) x0 x1) q !)
   (fun q α x0 x1 => anticompare1 (α ⋅ B0) (α ⋅ B1)
  (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
  (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1)
  (@dapp0 q (α ⋅ A0) (α ⋅ A1)
    (fun r β y0 y1 => eq0 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (fun r β y0 y1 => eq1 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
      (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
      (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
    (α ⋅ h0) x0 x1)
  (@dapp1 q (α ⋅ A0) (α ⋅ A1)
  (fun r β y0 y1 => eq0 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
    (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
    (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
  (fun r β y0 y1 => eq1 (α ∘ β ⋅ B0) (α ∘ β ⋅ B1)
    (app0 (α ∘ β ⋅ f0) y0 y1) (app1 (α ∘ β ⋅ f1) y0 y1)
    (app0 (α ∘ β ⋅ g0) y0 y1) (app1 (α ∘ β ⋅ g1) y0 y1) r !)
  (α ⋅ h0) (α ⋅ h1) x0 x1) q !)).
Defined.

Definition funext1 {p}
(A0 : @El0 p Type0)
(A1 : @El1 p Type0 Type1 A0)
(B0 : @El0 p Type0)
(B1 : @El1 p Type0 Type1 B0)
(f0 : El0 (Arr0 A0 A1 B0 B1))
(f1 : El1 _ (Arr1 A0 A1 B0 B1) f0)
(g0 : El0 (Arr0 A0 A1 B0 B1))
(g1 : El1 _ (Arr1 A0 A1 B0 B1) g0)
(h0 : El0 (Prod0 A0 A1
  (fun q α x0 x1 => eq0 (α ⋅ B0) (α ⋅ B1)
    (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
    (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
  (fun q α x0 x1 => eq1 (α ⋅ B0) (α ⋅ B1)
    (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
    (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
  ))
(h1 : El1 _ (Prod1 A0 A1
  (fun q α x0 x1 => eq0 (α ⋅ B0) (α ⋅ B1)
    (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
    (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
  (fun q α x0 x1 => eq1 (α ⋅ B0) (α ⋅ B1)
    (app0 (α ⋅ f0) x0 x1) (app1 (α ⋅ f1) x0 x1)
    (app0 (α ⋅ g0) x0 x1) (app1 (α ⋅ g1) x0 x1) q !)
  ) h0)
: El1 _ (eq1 (Arr0 A0 A1 B0 B1) (Arr1 A0 A1 B0 B1) f0 f1 g0 g1) (funext0 A0 A1 B0 B1 f0 f1 g0 g1 h0 h1).
Proof.
(* TODO : just plug things together *)
Admitted.