(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List Arith.
Import ListNotations.
From Coq.ssr Require Import ssreflect.
Require Import Alphabet Grammar.
Require Automaton Interpreter Validator_complete.

Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A).
Module Import Valid := Validator_complete.Make A.

(** * Completeness Proof **)

Section Completeness_Proof.

Hypothesis safe: Inter.ValidSafe.safe.
Hypothesis complete: complete.

(* Properties of the automaton deduced from completeness validation. *)
Proposition nullable_stable: nullable_stable.
Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
Proposition first_stable: first_stable.
Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
Proposition start_future: start_future.
Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
Proposition terminal_shift: terminal_shift.
Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
Proposition end_reduce: end_reduce.
Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
Proposition start_goto: start_goto.
Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
Proposition non_terminal_goto: non_terminal_goto.
Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
Proposition non_terminal_closed: non_terminal_closed.
Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.

(** If the nullable predicate has been validated, then it is correct. **)
Lemma nullable_correct head word :
  word = [] -> parse_tree head word -> nullable_symb head = true
with nullable_correct_list heads word :
  word = [] ->
  parse_tree_list heads word -> nullable_word heads = true.
Proof.
  - destruct 2=>//. assert (Hnull := nullable_stable prod).
    erewrite nullable_correct_list in Hnull; eauto.
  - intros Hword. destruct 1=>//=. destruct (app_eq_nil _ _ Hword).
    eauto using andb_true_intro.
Qed.

(** Auxiliary lemma for first_correct.  *)
Lemma first_word_set_app t word1 word2 :
  TerminalSet.In t (first_word_set (word1 ++ word2)) <->
  TerminalSet.In t (first_word_set word1) \/
  TerminalSet.In t (first_word_set word2) /\ nullable_word (rev word1) = true.
Proof.
  induction word1 as [|s word1 IH]=>/=.
  - split; [tauto|]. move=>[/TerminalSet.empty_1 ?|[? _]]//.
  - rewrite /nullable_word forallb_app /=. destruct nullable_symb=>/=.
    + rewrite Bool.andb_true_r. split.
      * move=>/TerminalSet.union_1. rewrite IH.
        move=>[?|[?|[??]]]; auto using TerminalSet.union_2, TerminalSet.union_3.
      * destruct IH.
        move=>[/TerminalSet.union_1 [?|?]|[??]];
        auto using TerminalSet.union_2, TerminalSet.union_3.
    + rewrite Bool.andb_false_r. by intuition.
Qed.

(** If the first predicate has been validated, then it is correct. **)
Lemma first_correct head word t q :
  word = t::q ->
  parse_tree head word ->
  TerminalSet.In (token_term t) (first_symb_set head)
with first_correct_list heads word t q :
  word = t::q ->
  parse_tree_list heads word ->
  TerminalSet.In (token_term t) (first_word_set (rev' heads)).
Proof.
  - intros Hword. destruct 1=>//.
    + inversion Hword. subst. apply TerminalSet.singleton_2, compare_refl.
    + eapply first_stable. eauto.
  - intros Hword. destruct 1 as [|symq wordq ptl symt wordt pt]=>//=.
    rewrite /rev' -rev_alt /= first_word_set_app /= rev_involutive rev_alt.
    destruct wordq; [right|left].
    + destruct nullable_symb; eauto using TerminalSet.union_2, nullable_correct_list.
    + inversion Hword. subst. fold (rev' symq). eauto.
Qed.

(** A PTL is compatible with a stack if the top of the stack contains
  data representing to this PTL. *)
Fixpoint ptl_stack_compat {symbs word}
         (stk0 : stack) (ptl : parse_tree_list symbs word) (stk : stack) : Prop :=
  match ptl with
  | Nil_ptl => stk0 = stk
  | @Cons_ptl _ _ ptl sym _ pt =>
    match stk with
    | [] => False
    | existT _ _ sem::stk =>
      ptl_stack_compat stk0 ptl stk /\
      exists e,
        sem = eq_rect _ symbol_semantic_type (pt_sem pt) _ e
    end
  end.

(** .. and when a PTL is compatible with a stack, then calling the pop
  function return the semantic value of this PTL. *)
Lemma pop_stack_compat_pop_spec {A symbs word}
    (ptl:parse_tree_list symbs word) (stk:stack) (stk0:stack) action :
  ptl_stack_compat stk0 ptl stk ->
  pop_spec symbs stk action stk0 (ptl_sem (A:=A) ptl action).
Proof.
  revert stk. induction ptl=>stk /= Hstk.
  - subst. constructor.
  - destruct stk as [|[st sem] stk]=>//. destruct Hstk as [Hstk [??]]. subst.
    simpl. constructor. eauto.
Qed.

Variable init: initstate.

(** In order to prove compleness, we first fix a word to be parsed
  together with the content of the parser at the end of the parsing. *)
Variable full_word: list token.
Variable buffer_end: buffer.

(** Completeness is proved by following the traversal of the parse
  tree which is performed by the parser. Each step of parsing
  correspond to one step of traversal. In order to represent the state
  of the traversal, we define the notion of "dotted" parse tree, which
  is a parse tree with one dot on one of its node. The place of the
  dot represents the place of the next action to be executed.

  Such a dotted parse tree is decomposed into two part: a "regular"
  parse tree, which is the parse tree placed under the dot, and a
  "parse tree zipper", which is the part of the parse tree placed
  above the dot. Therefore, a parse tree zipper is a parse tree with a
  hole. Moreover, for easier manipulation, a parse tree zipper is
  represented "upside down". That is, the root of the parse tree is
  actually a leaf of the zipper, while the root of the zipper is the
  hole.
 *)
Inductive pt_zipper:
  forall (hole_symb:symbol) (hole_word:list token), Type :=
| Top_ptz:
  pt_zipper (NT (start_nt init)) full_word
| Cons_ptl_ptz:
  forall {head_symbolsq:list symbol} {wordq:list token},
    parse_tree_list head_symbolsq wordq ->

  forall {head_symbolt:symbol} {wordt:list token},

    ptl_zipper (head_symbolt::head_symbolsq) (wordq++wordt) ->
    pt_zipper head_symbolt wordt
with ptl_zipper:
  forall (hole_symbs:list symbol) (hole_word:list token), Type :=
| Non_terminal_pt_ptlz:
  forall {p:production} {word:list token},
    pt_zipper (NT (prod_lhs p)) word ->
    ptl_zipper (prod_rhs_rev p) word

| Cons_ptl_ptlz:
  forall {head_symbolsq:list symbol} {wordq:list token},

  forall {head_symbolt:symbol} {wordt:list token},
    parse_tree head_symbolt wordt ->

  ptl_zipper (head_symbolt::head_symbolsq) (wordq++wordt) ->

  ptl_zipper head_symbolsq wordq.

(** A dotted parse tree is the combination of a parse tree zipper with
  a parse tree. It can be intwo flavors, depending on which is the next
  action to be executed (shift or reduce). *)
Inductive pt_dot: Type :=
| Reduce_ptd: forall {prod word},
    parse_tree_list (prod_rhs_rev prod) word ->
    pt_zipper (NT (prod_lhs prod)) word ->
    pt_dot
| Shift_ptd: forall (tok : token) {symbolsq wordq},
    parse_tree_list symbolsq wordq ->
    ptl_zipper (T (token_term tok)::symbolsq) (wordq++[tok]) ->
    pt_dot.

(** We can compute the full semantic value of a parse tree when
  represented as a dotted ptd. *)

Fixpoint ptlz_sem {hole_symbs hole_word}
         (ptlz:ptl_zipper hole_symbs hole_word) :
         (forall A, arrows_right A (map symbol_semantic_type hole_symbs) -> A) ->
         (symbol_semantic_type (NT (start_nt init))) :=
  match ptlz with
  | @Non_terminal_pt_ptlz prod _ ptz =>
    fun k => ptz_sem ptz (k _ (prod_action prod))
  | Cons_ptl_ptlz pt ptlz =>
    fun k => ptlz_sem ptlz (fun _ f => k _ (f (pt_sem pt)))
  end
with ptz_sem {hole_symb hole_word}
             (ptz:pt_zipper hole_symb hole_word):
  symbol_semantic_type hole_symb -> symbol_semantic_type (NT (start_nt init)) :=
  match ptz with
  | Top_ptz => fun sem => sem
  | Cons_ptl_ptz ptl ptlz =>
    fun sem => ptlz_sem ptlz (fun _ f => ptl_sem ptl (f sem))
  end.

Definition ptd_sem (ptd : pt_dot) :=
  match ptd with
  | @Reduce_ptd prod _ ptl ptz =>
    ptz_sem ptz (ptl_sem ptl (prod_action prod))
  | Shift_ptd tok ptl ptlz =>
    ptlz_sem ptlz (fun _ f => ptl_sem ptl (f (token_sem tok)))
  end.

(** The buffer associated with a dotted parse tree corresponds to the
  buffer left to be read by the parser when at the state represented
  by the dotted parse tree. *)
Fixpoint ptlz_buffer {hole_symbs hole_word}
         (ptlz:ptl_zipper hole_symbs hole_word): buffer :=
  match ptlz with
  | Non_terminal_pt_ptlz ptz =>
    ptz_buffer ptz
  | @Cons_ptl_ptlz _ _ _ wordt _ ptlz' =>
    wordt ++ ptlz_buffer ptlz'
  end
with ptz_buffer {hole_symb hole_word}
                (ptz:pt_zipper hole_symb hole_word): buffer :=
  match ptz with
  | Top_ptz => buffer_end
  | Cons_ptl_ptz _ ptlz =>
    ptlz_buffer ptlz
  end.

Definition ptd_buffer (ptd:pt_dot) :=
  match ptd with
  | Reduce_ptd _ ptz => ptz_buffer ptz
  | @Shift_ptd tok _ wordq _ ptlz => (tok::ptlz_buffer ptlz)%buf
  end.

(** We are now ready to define the main invariant of the proof of
  completeness: we need to specify when a stack is compatible with a
  dotted parse tree. Informally, a stack is compatible with a dotted
  parse tree when it is the concatenation stack fragments which are
  compatible with each of the partially recognized productions
  appearing in the parse tree zipper. Moreover, the head of each of
  these stack fragment contains a state which has an item predicted by
  the corresponding zipper.

  More formally, the compatibility relation first needs the following
  auxiliary definitions: *)
Fixpoint ptlz_prod {hole_symbs hole_word}
         (ptlz:ptl_zipper hole_symbs hole_word): production :=
  match ptlz with
  | @Non_terminal_pt_ptlz prod _ _ => prod
  | Cons_ptl_ptlz _ ptlz' => ptlz_prod ptlz'
  end.

Fixpoint ptlz_future {hole_symbs hole_word}
  (ptlz:ptl_zipper hole_symbs hole_word): list symbol :=
  match ptlz with
  | Non_terminal_pt_ptlz _ => []
  | @Cons_ptl_ptlz _ _ s _ _ ptlz' => s::ptlz_future ptlz'
  end.

Fixpoint ptlz_lookahead {hole_symbs hole_word}
  (ptlz:ptl_zipper hole_symbs hole_word) : terminal :=
  match ptlz with
  | Non_terminal_pt_ptlz ptz => token_term (buf_head (ptz_buffer ptz))
  | Cons_ptl_ptlz _ ptlz' => ptlz_lookahead ptlz'
  end.

Fixpoint ptz_stack_compat {hole_symb hole_word}
         (stk : stack) (ptz : pt_zipper hole_symb hole_word) : Prop :=
  match ptz with
  | Top_ptz => stk = []
  | Cons_ptl_ptz ptl ptlz =>
    exists stk0,
      state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
                       (hole_symb::ptlz_future ptlz) (ptlz_lookahead ptlz) /\
      ptl_stack_compat stk0 ptl stk /\
      ptlz_stack_compat stk0 ptlz
  end
with ptlz_stack_compat {hole_symbs hole_word}
     (stk : stack) (ptlz : ptl_zipper hole_symbs hole_word) : Prop :=
  match ptlz with
  | Non_terminal_pt_ptlz ptz => ptz_stack_compat stk ptz
  | Cons_ptl_ptlz _ ptlz => ptlz_stack_compat stk ptlz
  end.

Definition ptd_stack_compat (ptd:pt_dot) (stk:stack): Prop :=
  match ptd with
  | @Reduce_ptd prod _ ptl ptz =>
    exists stk0,
      state_has_future (state_of_stack init stk) prod []
                       (token_term (buf_head (ptz_buffer ptz))) /\
      ptl_stack_compat stk0 ptl stk /\
      ptz_stack_compat stk0 ptz
  | Shift_ptd tok ptl ptlz =>
    exists stk0,
      state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
                       (T (token_term tok) :: ptlz_future ptlz) (ptlz_lookahead ptlz) /\
      ptl_stack_compat stk0 ptl stk /\
      ptlz_stack_compat stk0 ptlz
  end.

Lemma ptz_stack_compat_cons_state_has_future {symbsq wordq symbt wordt} stk
      (ptl : parse_tree_list symbsq wordq)
      (ptlz : ptl_zipper (symbt :: symbsq) (wordq ++ wordt)) :
  ptz_stack_compat stk (Cons_ptl_ptz ptl ptlz) ->
  state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
                   (symbt::ptlz_future ptlz) (ptlz_lookahead ptlz).
Proof. move=>[stk0 [? [? ?]]] //. Qed.

Lemma ptlz_future_ptlz_prod hole_symbs hole_word
      (ptlz:ptl_zipper hole_symbs hole_word) :
  rev_append (ptlz_future ptlz) hole_symbs = prod_rhs_rev (ptlz_prod ptlz).
Proof. induction ptlz=>//=. Qed.

Lemma ptlz_future_first {symbs word} (ptlz : ptl_zipper symbs word) :
  TerminalSet.In (token_term (buf_head (ptlz_buffer ptlz)))
    (first_word_set (ptlz_future ptlz)) \/
  token_term (buf_head (ptlz_buffer ptlz)) = ptlz_lookahead ptlz /\
  nullable_word (ptlz_future ptlz) = true.
Proof.
  induction ptlz as [|??? [|tok] pt ptlz IH]; [by auto| |]=>/=.
  - rewrite (nullable_correct _ _ eq_refl pt).
    destruct IH as [|[??]]; [left|right]=>/=; auto using TerminalSet.union_3.
  - left. destruct nullable_symb; eauto using TerminalSet.union_2, first_correct.
Qed.

(** We now want to define what is the next dotted parse tree which is
  to be handled after one action. Such dotted parse is built in two
  steps: Not only we have to perform the action by completing the
  parse tree, but we also have to prepare for the following step by
  moving the dot down to place it in front of the next action to be
  performed.
*)
Fixpoint build_pt_dot_from_pt {symb word}
         (pt : parse_tree symb word) (ptz : pt_zipper symb word)
  : pt_dot :=
  match pt in parse_tree symb word
    return pt_zipper symb word -> pt_dot
  with
  | Terminal_pt tok =>
    fun ptz =>
      let X :=
          match ptz in pt_zipper symb word
            return match symb with T term => True | NT _ => False end ->
                   { symbsq : list symbol &
                     { wordq : list token &
                       (parse_tree_list symbsq wordq *
                        ptl_zipper (symb :: symbsq) (wordq ++ word))%type } }
          with
          | Top_ptz => fun F => False_rect _ F
          | Cons_ptl_ptz ptl ptlz => fun _ =>
            existT _ _ (existT _ _ (ptl, ptlz))
          end I
      in
      Shift_ptd tok (fst (projT2 (projT2 X))) (snd (projT2 (projT2 X)))
  | Non_terminal_pt prod ptl => fun ptz =>
    let is_notnil :=
      match ptl in parse_tree_list w _
        return option (match w return Prop with [] => False | _ => True end)
      with
      | Nil_ptl => None
      | _ => Some I
      end
    in
    match is_notnil with
    | None => Reduce_ptd ptl ptz
    | Some H => build_pt_dot_from_pt_rec ptl H (Non_terminal_pt_ptlz ptz)
    end
  end ptz
with build_pt_dot_from_pt_rec {symbs word}
       (ptl : parse_tree_list symbs word)
       (Hsymbs : match symbs with [] => False | _ => True end)
       (ptlz : ptl_zipper symbs word)
  : pt_dot :=
  match ptl in parse_tree_list symbs word
    return match symbs with [] => False | _ => True end ->
           ptl_zipper symbs word ->
           pt_dot
  with
  | Nil_ptl => fun Hsymbs _ => False_rect _ Hsymbs
  | Cons_ptl ptl' pt => fun _ =>
    match ptl' in parse_tree_list symbsq wordq
      return parse_tree_list symbsq wordq ->
             ptl_zipper (_ :: symbsq) (wordq ++ _) ->
             pt_dot
    with
    | Nil_ptl => fun _ ptlz =>
      build_pt_dot_from_pt pt (Cons_ptl_ptz Nil_ptl ptlz)
    | _ => fun ptl' ptlz =>
      build_pt_dot_from_pt_rec ptl' I (Cons_ptl_ptlz pt ptlz)
    end ptl'
  end Hsymbs ptlz.

Definition build_pt_dot_from_ptl {symbs word}
         (ptl : parse_tree_list symbs word)
         (ptlz : ptl_zipper symbs word)
  : pt_dot :=
  match ptlz in ptl_zipper symbs word
    return parse_tree_list symbs word -> pt_dot
  with
  | Non_terminal_pt_ptlz ptz => fun ptl =>
    Reduce_ptd ptl ptz
  | Cons_ptl_ptlz pt ptlz => fun ptl =>
    build_pt_dot_from_pt pt (Cons_ptl_ptz ptl ptlz)
  end ptl.

Definition next_ptd (ptd:pt_dot) : option pt_dot :=
  match ptd with
  | Shift_ptd tok ptl ptlz =>
    Some (build_pt_dot_from_ptl (Cons_ptl ptl (Terminal_pt tok)) ptlz)
  | Reduce_ptd ptl ptz =>
    match ptz in pt_zipper symb word
      return parse_tree symb word -> _
    with
    | Top_ptz => fun _ => None
    | Cons_ptl_ptz ptl' ptlz => fun pt =>
      Some (build_pt_dot_from_ptl (Cons_ptl ptl' pt) ptlz)
    end (Non_terminal_pt _ ptl)
  end.

Fixpoint next_ptd_iter (ptd:pt_dot) (log_n_steps:nat) : option pt_dot :=
  match log_n_steps with
  | O => next_ptd ptd
  | S log_n_steps =>
    match next_ptd_iter ptd log_n_steps with
    | None => None
    | Some ptd => next_ptd_iter ptd log_n_steps
    end
  end.

(** We prove that these functions behave well w.r.t. semantic values. *)
Lemma sem_build_from_pt {symb word}
      (pt : parse_tree symb word) (ptz : pt_zipper symb word)  :
  ptz_sem ptz (pt_sem pt)
  = ptd_sem (build_pt_dot_from_pt pt ptz)
with sem_build_from_pt_rec {symbs word}
     (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
     Hsymbs :
  ptlz_sem ptlz (fun _ f => ptl_sem ptl f)
  = ptd_sem (build_pt_dot_from_pt_rec ptl Hsymbs ptlz).
Proof.
  - destruct pt as [tok|prod word ptl]=>/=.
    + revert ptz. generalize [tok].
      generalize (token_sem tok). generalize I.
      change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1.
      generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz.
    + match goal with
      | |- context [match ?X with Some H => _ | None => _ end] => destruct X=>//
      end.
      by rewrite -sem_build_from_pt_rec.
  - destruct ptl; [contradiction|].
    specialize (sem_build_from_pt_rec _ _ ptl)=>/=. destruct ptl.
    + by rewrite -sem_build_from_pt.
    + by rewrite -sem_build_from_pt_rec.
Qed.

Lemma sem_build_from_ptl {symbs word}
      (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) :
  ptlz_sem ptlz (fun _ f => ptl_sem ptl f)
  = ptd_sem (build_pt_dot_from_ptl ptl ptlz).
Proof. destruct ptlz=>//=. by rewrite -sem_build_from_pt. Qed.

Lemma sem_next_ptd (ptd : pt_dot) :
  match next_ptd ptd with
  | None => True
  | Some ptd' => ptd_sem ptd = ptd_sem ptd'
  end.
Proof.
  destruct ptd as [prod word ptl ptz|tok symbs word ptl ptlz] =>/=.
  - change (ptl_sem ptl (prod_action prod))
      with (pt_sem (Non_terminal_pt prod ptl)).
    generalize (Non_terminal_pt prod ptl). clear ptl.
    destruct ptz as [|?? ptl ?? ptlz]=>// pt. by rewrite -sem_build_from_ptl.
  - by rewrite -sem_build_from_ptl.
Qed.

Lemma sem_next_ptd_iter (ptd : pt_dot) (log_n_steps : nat) :
  match next_ptd_iter ptd log_n_steps with
  | None => True
  | Some ptd' => ptd_sem ptd = ptd_sem ptd'
  end.
Proof.
  revert ptd.
  induction log_n_steps as [|log_n_steps IH]; [by apply sem_next_ptd|]=>/= ptd.
  assert (IH1 := IH ptd). destruct next_ptd_iter as [ptd'|]=>//.
  specialize (IH ptd'). destruct next_ptd_iter=>//. congruence.
Qed.

(** We prove that these functions behave well w.r.t. xxx_buffer. *)
Lemma ptd_buffer_build_from_pt {symb word}
      (pt : parse_tree symb word) (ptz : pt_zipper symb word) :
  (word ++ ptz_buffer ptz)%buf = ptd_buffer (build_pt_dot_from_pt pt ptz)
with ptd_buffer_build_from_pt_rec {symbs word}
     (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
     Hsymbs :
  (word ++ ptlz_buffer ptlz)%buf = ptd_buffer (build_pt_dot_from_pt_rec ptl Hsymbs ptlz).
Proof.
  - destruct pt as [tok|prod word ptl]=>/=.
    + f_equal. revert ptz. generalize [tok].
      generalize (token_sem tok). generalize I.
      change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1.
      generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz.
    + match goal with
      | |- context [match ?X with Some H => _ | None => _ end] => destruct X eqn:EQ
      end.
      * by rewrite -ptd_buffer_build_from_pt_rec.
      * rewrite [X in (X ++ _)%buf](_ : word = []) //. clear -EQ. by destruct ptl.
  - destruct ptl as [|?? ptl ?? pt]; [contradiction|].
    specialize (ptd_buffer_build_from_pt_rec _ _ ptl).
    destruct ptl.
    + by rewrite /= -ptd_buffer_build_from_pt.
    + by rewrite -ptd_buffer_build_from_pt_rec //= app_buf_assoc.
Qed.

Lemma ptd_buffer_build_from_ptl {symbs word}
      (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) :
  ptlz_buffer ptlz = ptd_buffer (build_pt_dot_from_ptl ptl ptlz).
Proof.
  destruct ptlz as [|???? pt]=>//=. by rewrite -ptd_buffer_build_from_pt.
Qed.

(** We prove that these functions behave well w.r.t. xxx_stack_compat. *)
Lemma ptd_stack_compat_build_from_pt {symb word}
      (pt : parse_tree symb word) (ptz : pt_zipper symb word)
      (stk: stack) :
  ptz_stack_compat stk ptz ->
  ptd_stack_compat (build_pt_dot_from_pt pt ptz) stk
with ptd_stack_compat_build_from_pt_rec {symbs word}
     (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
     (stk : stack) Hsymbs :
  ptlz_stack_compat stk ptlz ->
  state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
                   (rev' (prod_rhs_rev (ptlz_prod ptlz))) (ptlz_lookahead ptlz) ->
  ptd_stack_compat (build_pt_dot_from_pt_rec ptl Hsymbs ptlz) stk.
Proof.
  - intros Hstk. destruct pt as [tok|prod word ptl]=>/=.
    + revert ptz Hstk. generalize [tok]. generalize (token_sem tok). generalize I.
      change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1.
      generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz.
    + assert (state_has_future (state_of_stack init stk) prod
               (rev' (prod_rhs_rev prod)) (token_term (buf_head (ptz_buffer ptz)))).
      { revert ptz Hstk. remember (NT (prod_lhs prod)) eqn:EQ=>ptz.
        destruct ptz as [|?? ptl0 ?? ptlz0].
        - intros ->. apply start_future. congruence.
        - subst. intros (stk0 & Hfut & _). apply non_terminal_closed in Hfut.
          specialize (Hfut prod eq_refl).
          destruct (ptlz_future_first ptlz0) as [Hfirst|[Hfirst Hnull]].
          + destruct Hfut as [_ Hfut]. auto.
          + destruct Hfut as [Hfut _]. by rewrite Hnull -Hfirst in Hfut. }
      match goal with
      | |- context [match ?X with Some H => _ | None => _ end] => destruct X eqn:EQ
      end.
      * by apply ptd_stack_compat_build_from_pt_rec.
      * exists stk. destruct ptl=>//.
  - intros Hstk Hfut. destruct ptl as [|?? ptl ?? pt]; [contradiction|].
    specialize (ptd_stack_compat_build_from_pt_rec _ _ ptl). destruct ptl.
    + eapply ptd_stack_compat_build_from_pt=>//. exists stk.
      split; [|split]=>//; [].
      by rewrite -ptlz_future_ptlz_prod rev_append_rev /rev' -rev_alt
                 rev_app_distr rev_involutive in Hfut.
    + by apply ptd_stack_compat_build_from_pt_rec.
Qed.

Lemma ptd_stack_compat_build_from_ptl {symbs word}
      (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
      (stk stk0: stack) :
  ptlz_stack_compat stk0 ptlz ->
  ptl_stack_compat stk0 ptl stk ->
  state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
                   (ptlz_future ptlz) (ptlz_lookahead ptlz) ->
  ptd_stack_compat (build_pt_dot_from_ptl ptl ptlz) stk.
Proof.
  intros Hstk0 Hstk Hfut. destruct ptlz=>/=.
  - eauto.
  - apply ptd_stack_compat_build_from_pt=>/=. eauto.
Qed.

(** We can now proceed by proving that the invariant is preserved by
  each step of parsing. We also prove that each step of parsing
  follows next_ptd.

  We start with reduce steps: *)
Lemma reduce_step_next_ptd (prod : production) (word : list token)
      (ptl : parse_tree_list (prod_rhs_rev prod) word)
      (ptz : pt_zipper (NT (prod_lhs prod)) word)
      (stk : stack)
      Hval Hi :
  ptd_stack_compat (Reduce_ptd ptl ptz) stk ->
  match next_ptd (Reduce_ptd ptl ptz) with
  | None =>
    reduce_step init stk prod (ptz_buffer ptz) Hval Hi =
      Accept_sr (ptd_sem (Reduce_ptd ptl ptz)) buffer_end
  | Some ptd =>
    exists stk',
      reduce_step init stk prod (ptz_buffer ptz) Hval Hi =
        Progress_sr stk' (ptd_buffer ptd) /\
      ptd_stack_compat ptd stk'
  end.
Proof.
  intros (stk0 & _ & Hstk & Hstk0).
  apply pop_stack_compat_pop_spec with (action := prod_action prod) in Hstk.
  rewrite <-pop_spec_ok with (Hp := reduce_step_subproof init stk prod Hval Hi) in Hstk.
  unfold reduce_step.
  match goal with
  | |- context [pop_state_valid init ?A stk ?B ?C ?D ?E ?F] =>
    generalize (pop_state_valid init A stk B C D E F)
  end.
  rewrite Hstk /=. intros Hv.
  generalize (reduce_step_subproof1 init stk prod Hval stk0 (fun _ : True => Hv)).
  clear Hval Hstk Hi Hv stk.
  assert (Hgoto := fun fut prod' =>
    non_terminal_goto (state_of_stack init stk0) prod' (NT (prod_lhs prod)::fut)).
  simpl in Hgoto.
  destruct goto_table as [[st Hst]|] eqn:Hgoto'.
  - intros _.
    assert (match ptz with Top_ptz => False | _ => True end).
    { revert ptz Hst Hstk0 Hgoto'.
      generalize (eq_refl (NT (prod_lhs prod))).
      generalize (NT (prod_lhs prod)) at 1 3 5.
      intros nt Hnt ptz. destruct ptz=>//. injection Hnt=> <- /= Hst -> /= Hg.
      assert (Hsg := start_goto init). by rewrite Hg in Hsg. }
    clear Hgoto'.

    change (ptl_sem ptl (prod_action prod))
      with (pt_sem (Non_terminal_pt prod ptl)).
    generalize (Non_terminal_pt prod ptl). clear ptl.
    destruct ptz as [|?? ptl ? ? ptlz]=>// pt.

    subst=>/=. eexists _. split.
    + f_equal. apply ptd_buffer_build_from_ptl.
    + destruct Hstk0 as (stk0' & Hfut & Hstk0' & Hstk0).
      apply (ptd_stack_compat_build_from_ptl _ _ _ stk0'); auto; [].
      split=>//. by exists eq_refl.
  - intros Hv. generalize (reduce_step_subproof0 _ prod _ (fun _ => Hv)).
    intros EQnt. clear Hv Hgoto'.

    change (ptl_sem ptl (prod_action prod))
      with (pt_sem (Non_terminal_pt prod ptl)).
    generalize (Non_terminal_pt prod ptl). clear ptl. destruct ptz.
    + intros pt. f_equal. by rewrite cast_eq.
    + edestruct Hgoto. eapply ptz_stack_compat_cons_state_has_future, Hstk0.
Qed.

Lemma step_next_ptd (ptd : pt_dot) (stk : stack) Hi :
  ptd_stack_compat ptd stk ->
  match next_ptd ptd with
  | None =>
    step safe init stk (ptd_buffer ptd) Hi =
      Accept_sr (ptd_sem ptd) buffer_end
  | Some ptd' =>
    exists stk',
      step safe init stk (ptd_buffer ptd) Hi =
        Progress_sr stk' (ptd_buffer ptd') /\
      ptd_stack_compat ptd' stk'
  end.
Proof.
  intros Hstk. unfold step.
  generalize (reduce_ok safe (state_of_stack init stk)).
  destruct ptd as [prod word ptl ptz|tok symbs word ptl ptlz].
  - assert (Hfut : state_has_future (state_of_stack init stk) prod []
                                    (token_term (buf_head (ptz_buffer ptz)))).
    { destruct Hstk as (? & ? & ?)=>//. }
    assert (Hact := end_reduce _ _ _ _ Hfut).
    destruct action_table as [?|awt]=>Hval /=.
    + subst. by apply reduce_step_next_ptd.
    + set (term := token_term (buf_head (ptz_buffer ptz))) in *.
      generalize (Hval term). clear Hval. destruct (awt term)=>//. subst.
      intros Hval. by apply reduce_step_next_ptd.
  - destruct Hstk as (stk0 & Hfut & Hstk & Hstk0).
    assert (Hact := terminal_shift _ _ _ _ Hfut). simpl in Hact. clear Hfut.
    destruct action_table as [?|awt]=>//= /(_ (token_term tok)).
    destruct awt as [st' EQ| |]=>// _. eexists. split.
    + f_equal. rewrite -ptd_buffer_build_from_ptl //.
    + apply (ptd_stack_compat_build_from_ptl _ _ _ stk0); simpl; eauto.
Qed.

(** We prove the completeness of the parser main loop. *)
Lemma parse_fix_next_ptd_iter (ptd : pt_dot) (stk : stack) (log_n_steps : nat) Hi :
  ptd_stack_compat ptd stk ->
  match next_ptd_iter ptd log_n_steps with
  | None =>
    proj1_sig (parse_fix safe init stk (ptd_buffer ptd) log_n_steps Hi) =
      Accept_sr (ptd_sem ptd) buffer_end
  | Some ptd' =>
    exists stk',
      proj1_sig (parse_fix safe init stk (ptd_buffer ptd) log_n_steps Hi) =
        Progress_sr stk' (ptd_buffer ptd') /\
      ptd_stack_compat ptd' stk'
  end.
Proof.
  revert ptd stk Hi.
  induction log_n_steps as [|log_n_steps IH]; [by apply step_next_ptd|].
  move => /= ptd stk Hi Hstk. assert (IH1 := IH ptd stk Hi Hstk).
  assert (EQsem := sem_next_ptd_iter ptd log_n_steps).
  destruct parse_fix as [sr Hi']. simpl in IH1.
  destruct next_ptd_iter as [ptd'|].
  - rewrite EQsem. destruct IH1 as (stk' & -> & Hstk'). by apply IH.
  - by subst.
Qed.

(** The parser is defined by recursion over a fuel parameter. In the
  completeness proof, we need to predict how much fuel is going to be
  needed in order to prove that enough fuel gives rise to a successful
  parsing.

  To do so, of a dotted parse tree, which is the number of actions
  left to be executed before complete parsing when the current state
  is represented by the dotted parse tree. *)
Fixpoint ptlz_cost {hole_symbs hole_word}
         (ptlz:ptl_zipper hole_symbs hole_word) :=
  match ptlz with
  | Non_terminal_pt_ptlz ptz => ptz_cost ptz
  | Cons_ptl_ptlz pt ptlz' => pt_size pt + ptlz_cost ptlz'
  end
with ptz_cost {hole_symb hole_word} (ptz:pt_zipper hole_symb hole_word) :=
  match ptz with
  | Top_ptz => 0
  | Cons_ptl_ptz ptl ptlz' => 1 + ptlz_cost ptlz'
  end.

Definition ptd_cost (ptd:pt_dot) :=
  match ptd with
  | Reduce_ptd ptl ptz => ptz_cost ptz
  | Shift_ptd _ ptl ptlz => 1 + ptlz_cost ptlz
  end.

Lemma ptd_cost_build_from_pt {symb word}
      (pt : parse_tree symb word) (ptz : pt_zipper symb word) :
  pt_size pt + ptz_cost ptz = S (ptd_cost (build_pt_dot_from_pt pt ptz))
with ptd_cost_build_from_pt_rec {symbs word}
     (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
     Hsymbs :
  ptl_size ptl + ptlz_cost ptlz = ptd_cost (build_pt_dot_from_pt_rec ptl Hsymbs ptlz).
Proof.
  - destruct pt as [tok|prod word ptl']=>/=.
    + revert ptz. generalize [tok]. generalize (token_sem tok). generalize I.
      change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1.
      generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz.
    + match goal with
      | |- context [match ?X with Some H => _ | None => _ end] => destruct X eqn:EQ
      end.
      * rewrite -ptd_cost_build_from_pt_rec /= plus_n_Sm //.
      * simpl. by destruct ptl'.
  - destruct ptl as [|?? ptl ?? pt]; [contradiction|].
    specialize (ptd_cost_build_from_pt_rec _ _ ptl). destruct ptl.
    + apply eq_add_S. rewrite -ptd_cost_build_from_pt /=. ring.
    + rewrite -ptd_cost_build_from_pt_rec //=. ring.
Qed.

Lemma ptd_cost_build_from_ptl {symbs word}
      (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) :
  ptlz_cost ptlz = ptd_cost (build_pt_dot_from_ptl ptl ptlz).
Proof.
  destruct ptlz=>//. apply eq_add_S. rewrite -ptd_cost_build_from_pt /=. ring.
Qed.

Lemma next_ptd_cost ptd:
  match next_ptd ptd with
  | None => ptd_cost ptd = 0
  | Some ptd' => ptd_cost ptd = S (ptd_cost ptd')
  end.
Proof.
  destruct ptd as [prod word ptl ptz|tok symbq wordq ptl ptlz] =>/=.
  - generalize (Non_terminal_pt prod ptl). clear ptl.
    destruct ptz as [|?? ptl ?? ptlz]=>// pt. by rewrite -ptd_cost_build_from_ptl.
  - by rewrite -ptd_cost_build_from_ptl.
Qed.

Lemma next_ptd_iter_cost ptd log_n_steps :
  match next_ptd_iter ptd log_n_steps with
  | None => ptd_cost ptd < 2^log_n_steps
  | Some ptd' => ptd_cost ptd = 2^log_n_steps + ptd_cost ptd'
  end.
Proof.
  revert ptd. induction log_n_steps as [|log_n_steps IH]=>ptd /=.
  - assert (Hptd := next_ptd_cost ptd). destruct next_ptd=>//. by rewrite Hptd.
  - rewrite Nat.add_0_r. assert (IH1 := IH ptd). destruct next_ptd_iter as [ptd'|].
    + specialize (IH ptd'). destruct next_ptd_iter as [ptd''|].
      * by rewrite IH1 IH -!plus_assoc.
      * rewrite IH1. by apply plus_lt_compat_l.
    + by apply lt_plus_trans.
Qed.

(** We now prove the top-level parsing function. The only thing that
  is left to be done is the initialization. To do so, we define the
  initial dotted parse tree, depending on a full (top-level) parse tree. *)

Variable full_pt : parse_tree (NT (start_nt init)) full_word.

Theorem parse_complete log_n_steps:
  match parse safe init (full_word ++ buffer_end) log_n_steps with
  | Parsed_pr sem buff =>
    sem = pt_sem full_pt /\ buff = buffer_end /\ pt_size full_pt <= 2^log_n_steps
  | Timeout_pr => 2^log_n_steps < pt_size full_pt
  | Fail_pr => False
  end.
Proof.
  assert (Hstk : ptd_stack_compat (build_pt_dot_from_pt full_pt Top_ptz) []) by
      by apply ptd_stack_compat_build_from_pt.
  unfold parse.
  assert (Hparse := parse_fix_next_ptd_iter _ _ log_n_steps (parse_subproof init) Hstk).
  rewrite -ptd_buffer_build_from_pt -sem_build_from_pt /= in Hparse.
  assert (Hcost := next_ptd_iter_cost (build_pt_dot_from_pt full_pt Top_ptz) log_n_steps).
  destruct next_ptd_iter.
  - destruct Hparse as (? & -> & ?). apply (f_equal S) in Hcost.
    rewrite -ptd_cost_build_from_pt Nat.add_0_r in Hcost. rewrite Hcost.
    apply le_lt_n_Sm, le_plus_l.
  - rewrite Hparse. split; [|split]=>//. apply lt_le_S in Hcost.
    by rewrite -ptd_cost_build_from_pt Nat.add_0_r in Hcost.
Qed.

End Completeness_Proof.

End Make.


(** Like Iris's "ghost map" except for an asynchronous map, in which each
    key has a "current" value and an associated set of values that could be
    obtained on crash.

    This is meant to model a scenario in which there is no "correlation" or
    "ordering" between the post-crash values of keys, each value is selected
    independently from that keys set. If you want a version where there is some kind
    of correlation between the values after crash that corresponds to the order of writes,
    you probably want async.v
*)

From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import proofmode.
From Perennial.algebra Require Import gmap_rel_view log_heap.
From iris.algebra Require Export dfrac.
From iris.base_logic.lib Require Export own.
From iris.prelude Require Import options.

(* The relation that holds between the auth map and the fragment values *)
Section async_rel.
Context {V : Type} `{Countable V}.

Definition async_rel_raw (n : nat) (va : async V) (v : V) (a : gset V) :=
  v = latest va ∧ (∀ v, v ∈ pending va → v ∈ a).

Lemma async_rel_mono :
  ∀ n1 n2 (va1 va2 : leibnizO (async V)) (v1 v2 : leibnizO V) (a : (gset V)),
    async_rel_raw n1 va1 v1 a →
    va1 ≡{n2}≡ va2 →
    v1 ≡{n2}≡ v2 →
    n2 ≤ n1 →
    async_rel_raw n2 va2 v2 a.
Proof. intros ??????? Hrel -> -> => //=. Qed.

Definition async_rel := GValRel (leibnizO (async V)) (leibnizO V) _ async_rel_raw async_rel_mono.

Global Instance : GvalRelDiscrete _ _ async_rel.
Proof. intros n va v a (?&?) => //=. Qed.

End async_rel.

(** The CMRA we need. *)

Class ghost_async_mapG Σ (K V : Type) `{Countable K, Countable V} := GhostMapG {
  ghost_async_map_inG :> inG Σ (gmap_rel_viewR K (leibnizO (async V)) (leibnizO V) (gset V) async_rel);
}.
Definition ghost_async_mapΣ (K V : Type) `{Countable K, Countable V} : gFunctors :=
  #[ GFunctor (gmap_rel_viewR K (leibnizO (async V)) _ _ async_rel) ].

Global Instance subG_ghost_async_mapΣ Σ (K V : Type) `{Countable K, Countable V} :
  subG (ghost_async_mapΣ K V) Σ → ghost_async_mapG Σ K V.
Proof. solve_inG. Qed.

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

  Definition ghost_async_map_auth_def (γ : gname) (q : Qp) (m : gmap K (async V)) : iProp Σ :=
    own γ (gmap_rel_view_auth (VA:=leibnizO (async V)) (V := leibnizO V) (A := gset V) async_rel q m).
  Definition ghost_async_map_auth_aux : seal (@ghost_async_map_auth_def). Proof. by eexists. Qed.
  Definition ghost_async_map_auth := ghost_async_map_auth_aux.(unseal).
  Definition ghost_async_map_auth_eq :
    @ghost_async_map_auth = @ghost_async_map_auth_def := ghost_async_map_auth_aux.(seal_eq).

  Definition ghost_async_map_elem_def (γ : gname) (k : K) (dq : dfrac) (a : gset V) (v : V) : iProp Σ :=
    own γ (gmap_rel_view_frag (VA:=leibnizO (async V)) (V := leibnizO V) (A := gset V) async_rel
                              k dq a v).
  Definition ghost_async_map_elem_aux : seal (@ghost_async_map_elem_def). Proof. by eexists. Qed.
  Definition ghost_async_map_elem := ghost_async_map_elem_aux.(unseal).
  Definition ghost_async_map_elem_eq : @ghost_async_map_elem = @ghost_async_map_elem_def := ghost_async_map_elem_aux.(seal_eq).
End definitions.

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

Local Ltac unseal := rewrite
  ?ghost_async_map_auth_eq /ghost_async_map_auth_def
  ?ghost_async_map_elem_eq /ghost_async_map_elem_def.

Section lemmas.
  Context `{ghost_async_mapG Σ K V}.
  Implicit Types (k : K) (a : gset V) (v : V) (dq : dfrac) (q : Qp) (m : gmap K V) (ma : gmap K (async V)).

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

  Local Lemma ghost_async_map_elems_unseal γ m dq a :
    ([∗ map] k ↦ v ∈ m, k ↪[γ]{dq}[a] v) ==∗
    own γ ([^op map] k↦v ∈ m,
           gmap_rel_view_frag (VA:=leibnizO (async V)) (V := leibnizO V) (A := gset V) _ k dq a v).
  Proof.
    unseal. destruct (decide (m = ∅)) as [->|Hne].
    - rewrite !big_opM_empty. iIntros "_". iApply own_unit.
    - rewrite big_opM_own //. iIntros "?". done.
  Qed.

  Lemma ghost_async_map_elem_valid k γ dq a v : k ↪[γ]{dq}[a] v -∗ ⌜✓ dq⌝.
  Proof.
    unseal. iIntros "Helem".
    iDestruct (own_valid with "Helem") as %?%gmap_rel_view_frag_valid_frac; eauto.
  Qed.
  Lemma ghost_async_map_elem_valid_2 k γ dq1 dq2 a1 a2 v1 v2 :
    k ↪[γ]{dq1}[a1] v1 -∗ k ↪[γ]{dq2}[a2] v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
  Proof.
    unseal. iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %?%gmap_rel_view_frag_op_valid_L.
    naive_solver.
  Qed.
  Lemma ghost_async_map_elem_agree k γ dq1 dq2 a1 a2 v1 v2 :
    k ↪[γ]{dq1}[a1] v1 -∗ k ↪[γ]{dq2}[a2] v2 -∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "Helem1 Helem2".
    iDestruct (ghost_async_map_elem_valid_2 with "Helem1 Helem2") as %[_ ?].
    done.
  Qed.

  (* TODO: there is a bupd form in which the a's can be different and we get the intersection. *)
  Lemma ghost_async_map_elem_combine k γ dq1 dq2 a v1 v2 :
    k ↪[γ]{dq1}[a] v1 -∗ k ↪[γ]{dq2}[a] v2 -∗ k ↪[γ]{dq1 ⋅ dq2}[a] v1 ∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "Hl1 Hl2". iDestruct (ghost_async_map_elem_agree with "Hl1 Hl2") as %->.
    unseal. iCombine "Hl1 Hl2" as "Hl". eauto with iFrame.
  Qed.

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

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

  (** * Lemmas about [ghost_async_map_auth] *)
  Lemma ghost_async_map_alloc_strong P ma :
    pred_infinite P →
    ⊢ |==> ∃ γ, ⌜P γ⌝ ∗ ghost_async_map_auth γ 1 ma ∗
           [∗ map] k ↦ av ∈ ma, k ↪[γ][list_to_set (pending av)] (latest av).
  Proof.
    unseal. intros.
    iMod (own_alloc_strong (gmap_rel_view_auth (VA:=leibnizO (async V)) (V:=leibnizO V) async_rel 1 ∅) P)
      as (γ) "[% Hauth]"; first done.
    { apply gmap_rel_view_auth_valid. }
    iExists γ. iSplitR; first done.
    rewrite -big_opM_own_1 -own_op. iApply (own_update with "Hauth").
    set (ma' := (λ x : async V, (x, (latest x, (list_to_set (pending x)) : gset V))) <$> ma).
    etrans; first apply: (gmap_rel_view_alloc_big (VA:=leibnizO (async V)) (V:=leibnizO V) _ _ ma' (DfracOwn 1)).
    - intros k vm v aset. rewrite /ma'. rewrite lookup_fmap /= => Hlookup n.
      apply fmap_Some_1 in Hlookup as (?&Hlookup&Heq).
      inversion Heq; subst. rewrite /async_rel_raw. split; first done.
      intros v. apply elem_of_list_to_set.
    - apply map_disjoint_empty_r.
    - done.
    - rewrite right_id.
      assert (Heq1: fst <$> ma' = ma).
      { rewrite /ma' -map_fmap_compose.
        rewrite -[a in _ = a]map_fmap_id. apply map_fmap_ext => //=. }
      rewrite Heq1. rewrite /ma' ?big_opM_fmap //=.
  Qed.
  Lemma ghost_async_map_alloc_strong_empty P :
    pred_infinite P →
    ⊢ |==> ∃ γ, ⌜P γ⌝ ∗ ghost_async_map_auth γ 1 (∅ : gmap K _).
  Proof.
    intros. iMod (ghost_async_map_alloc_strong P ∅) as (γ) "(% & Hauth & _)"; eauto.
  Qed.
  Lemma ghost_async_map_alloc ma :
    ⊢ |==> ∃ γ, ghost_async_map_auth γ 1 ma ∗ [∗ map] k ↦ av ∈ ma, k ↪[γ][list_to_set (pending av)]  (latest av).
  Proof.
    iMod (ghost_async_map_alloc_strong (λ _, True) ma) as (γ) "[_ Hmap]".
    - by apply pred_infinite_True.
    - eauto.
  Qed.
  Lemma ghost_async_map_alloc_empty :
    ⊢ |==> ∃ γ, ghost_async_map_auth γ 1 (∅ : gmap K _).
  Proof.
    intros. iMod (ghost_async_map_alloc ∅) as (γ) "(Hauth & _)"; eauto.
  Qed.

  Global Instance ghost_async_map_auth_timeless γ q ma : Timeless (ghost_async_map_auth γ q ma).
  Proof. unseal. apply _. Qed.
  Global Instance ghost_async_map_auth_fractional γ ma : Fractional (λ q, ghost_async_map_auth γ q ma)%I.
  Proof. intros p q. unseal. rewrite -own_op gmap_rel_view_auth_frac_op //. Qed.
  Global Instance ghost_async_map_auth_as_fractional γ q ma :
    AsFractional (ghost_async_map_auth γ q ma) (λ q, ghost_async_map_auth γ q ma)%I q.
  Proof. split; first done. apply _. Qed.

  Lemma ghost_async_map_auth_valid γ q ma : ghost_async_map_auth γ q ma -∗ ⌜q ≤ 1⌝%Qp.
  Proof.
    unseal. iIntros "Hauth".
    iDestruct (own_valid with "Hauth") as %?%gmap_rel_view_auth_frac_valid.
    done.
  Qed.
  Lemma ghost_async_map_auth_valid_2 γ q1 q2 ma1 ma2 :
    ghost_async_map_auth γ q1 ma1 -∗ ghost_async_map_auth γ q2 ma2 -∗ ⌜(q1 + q2 ≤ 1)%Qp ∧ ma1 = ma2⌝.
  Proof.
    unseal. iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %[??]%gmap_rel_view_auth_frac_op_valid_L.
    done.
  Qed.
  Lemma ghost_async_map_auth_agree γ q1 q2 ma1 ma2 :
    ghost_async_map_auth γ q1 ma1 -∗ ghost_async_map_auth γ q2 ma2 -∗ ⌜ma1 = ma2⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct (ghost_async_map_auth_valid_2 with "H1 H2") as %[_ ?].
    done.
  Qed.

  (** * Lemmas about the interaction of [ghost_async_map_auth] with the elements *)
  Lemma ghost_async_map_lookup {γ q ma k dq a v} :
    ghost_async_map_auth γ q ma -∗ k ↪[γ]{dq}[a] v -∗
   ⌜∃ vm, ma !! k = Some vm ∧ latest vm = v ∧ (∀ x, x ∈ pending vm → x ∈ a) ⌝.
  Proof.
    unseal. iIntros "Hauth Hel".
    iDestruct (own_valid_2 with "Hauth Hel") as %[vm[?[?[? Hrel]]]]%gmap_rel_view_both_frac_valid_L.
    iPureIntro. exists vm. specialize (Hrel O). destruct Hrel as (?&?).
    split_and!; auto.
  Qed.

  Lemma ghost_async_map_insert {γ ma} k v al :
    ma !! k = None →
    ghost_async_map_auth γ 1 ma ==∗
    ghost_async_map_auth γ 1 (<[k := Build_async v al]> ma) ∗ k ↪[γ][list_to_set al] v.
  Proof.
    unseal. intros ?. rewrite -own_op.
    iApply own_update. apply: gmap_rel_view_alloc; try done.
    intros n. rewrite //=; split => //=. intros. rewrite elem_of_list_to_set //.
  Qed.
  Lemma ghost_async_map_insert_persist {γ ma} k v al :
    ma !! k = None →
    ghost_async_map_auth γ 1 ma ==∗
    ghost_async_map_auth γ 1 (<[k := Build_async v al]> ma) ∗ k ↪[γ]□[list_to_set al] v.
  Proof.
    iIntros (?) "Hauth".
    iMod (ghost_async_map_insert k with "Hauth") as "[$ Helem]"; first done.
    iApply ghost_async_map_elem_persist. done.
  Qed.

  Lemma ghost_async_map_delete {γ ma k a v} :
    ghost_async_map_auth γ 1 ma -∗ k ↪[γ][a] v ==∗ ghost_async_map_auth γ 1 (delete k ma).
  Proof.
    unseal. apply bi.wand_intro_r. rewrite -own_op.
    iApply own_update. apply: gmap_rel_view_delete.
  Qed.

  Lemma ghost_async_map_update' {γ ma k a a' al v} w :
    (∀ x, x ∈ al → x ∈ a') →
    ghost_async_map_auth γ 1 ma -∗
    k ↪[γ][a] v ==∗
    ghost_async_map_auth γ 1 (<[k := Build_async w al]> ma) ∗ k ↪[γ][a'] w.
  Proof.
    intros Hsub.
    unseal. apply bi.wand_intro_r. rewrite -!own_op.
    apply own_update. apply: gmap_rel_view_update.
    intros n. rewrite //=; split => //=.
  Qed.

  Lemma ghost_async_map_update {γ ma k a al' v} w :
    ghost_async_map_auth γ 1 ma -∗
    k ↪[γ][a] v ==∗
    ghost_async_map_auth γ 1 (<[k := Build_async w al']> ma) ∗ k ↪[γ][list_to_set al'] w.
  Proof.
    apply ghost_async_map_update'. intros; rewrite elem_of_list_to_set //.
  Qed.

  Lemma ghost_async_map_async_put {γ ma k a vm v} w :
    ma !! k = Some vm →
    ghost_async_map_auth γ 1 ma -∗
    k ↪[γ][a] v ==∗
    ghost_async_map_auth γ 1 (<[k := async_put w vm]> ma) ∗ k ↪[γ][{[v]} ∪ a] w.
  Proof.
    intros Hlook. iIntros "H1 H2".
    iDestruct (ghost_async_map_lookup with "[$] [$]") as %Hlook'.
    destruct Hlook' as (vm'&Heq&Hlatest&Hsub).
    rewrite Heq in Hlook. inversion Hlook; subst.
    iApply (ghost_async_map_update' with "[$] [$]").
    rewrite /possible. intros v. rewrite elem_of_app. set_solver.
  Qed.

  Lemma ghost_async_map_flush_auth {γ} ma :
    ghost_async_map_auth γ 1 ma ==∗ ghost_async_map_auth γ 1 (flush <$> ma).
  Proof.
    unseal. apply own_update. apply: gmap_rel_view_update_fmap.
    intros k vm v a n Hlookup Hrel.
    destruct Hrel as (Heq&Hsubset). split; first done.
    intros x Hin. set_solver.
  Qed.

  Lemma ghost_async_map_update_approx {γ ma k dq a v vm} :
    ma !! k = Some vm →
    ghost_async_map_auth γ 1 ma -∗
    k ↪[γ]{dq}[a] v ==∗
    ghost_async_map_auth γ 1 ma ∗ k ↪[γ]{dq}[list_to_set (pending vm)] v.
  Proof.
    intros Hlook.
    unseal. apply bi.wand_intro_r. rewrite -!own_op.
    apply own_update. apply: gmap_rel_view_update_approx.
    intros vm' n Hlookup Hrel1.
    assert (vm = vm') as ->.
    { rewrite Hlook in Hlookup. inversion Hlookup. eauto. }
    destruct Hrel1.
    rewrite //=; split => //=. intros. rewrite elem_of_list_to_set //.
  Qed.

  (* TODO: a stronger version of this is provable in which one merely has fractional ownership of
     k and gets that same fraction back. *)
  Lemma ghost_async_map_update_flush_big {γ ma m} :
    ghost_async_map_auth γ 1 ma -∗
    ([∗ map] k↦v ∈ m, ∃ a, k ↪[γ][a] v) ==∗
    ghost_async_map_auth γ 1 (flush <$> ma) ∗
    ([∗ map] k↦v ∈ m, k ↪[γ][∅] v).
  Proof.
    iIntros "Hauth Hfrag".
    iMod (ghost_async_map_flush_auth with "Hauth") as "Hauth".
    iInduction m as [| k v m Hlookup] "IH" using map_ind.
    { rewrite ?big_sepM_empty. eauto. }
    rewrite ?big_sepM_insert //.
    iDestruct "Hfrag" as "(Hk&Hm)".
    iMod ("IH" with "[$] [$]") as "(Hauth&$)".
    iDestruct "Hk" as (?) "Hk".
    iDestruct (ghost_async_map_lookup with "[$] [$]") as %Hlook.
    destruct Hlook as (vm&Hlook&Heq&Hsub).
    iMod (ghost_async_map_update_approx with "[$] [$]") as "($&Hp)"; first eauto.
    rewrite lookup_fmap in Hlook.
    apply fmap_Some_1 in Hlook as (?&Hlook&Heq').
    rewrite Heq' => //=.
  Qed.

  (** Big-op versions of above lemmas *)
  (* TODO: Update these. *)
  (*
  Lemma ghost_async_map_lookup_big {γ q m} m0 :
    ghost_async_map_auth γ q m -∗
    ([∗ map] k↦v ∈ m0, k ↪[γ] v) -∗
    ⌜m0 ⊆ m⌝.
  Proof.
    iIntros "Hauth Hfrag". rewrite map_subseteq_spec. iIntros (k v Hm0).
    iDestruct (ghost_async_map_lookup with "Hauth [Hfrag]") as %->.
    { rewrite big_sepM_lookup; done. }
    done.
  Qed.

  Lemma ghost_async_map_insert_big {γ m} m' :
    m' ##ₘ m →
    ghost_async_map_auth γ 1 m ==∗
    ghost_async_map_auth γ 1 (m' ∪ m) ∗ ([∗ map] k ↦ v ∈ m', k ↪[γ] v).
  Proof.
    unseal. intros ?. rewrite -big_opM_own_1 -own_op.
    apply own_update. apply: gmap_view_alloc_big; done.
  Qed.
  Lemma ghost_async_map_insert_persist_big {γ m} m' :
    m' ##ₘ m →
    ghost_async_map_auth γ 1 m ==∗
    ghost_async_map_auth γ 1 (m' ∪ m) ∗ ([∗ map] k ↦ v ∈ m', k ↪[γ]□ v).
  Proof.
    iIntros (Hdisj) "Hauth".
    iMod (ghost_async_map_insert_big m' with "Hauth") as "[$ Helem]"; first done.
    iApply big_sepM_bupd. iApply (big_sepM_impl with "Helem").
    iIntros "!#" (k v) "_". iApply ghost_async_map_elem_persist.
  Qed.

  Lemma ghost_async_map_delete_big {γ m} m0 :
    ghost_async_map_auth γ 1 m -∗
    ([∗ map] k↦v ∈ m0, k ↪[γ] v) ==∗
    ghost_async_map_auth γ 1 (m ∖ m0).
  Proof.
    iIntros "Hauth Hfrag". iMod (ghost_async_map_elems_unseal with "Hfrag") as "Hfrag".
    unseal. iApply (own_update_2 with "Hauth Hfrag").
    apply: gmap_view_delete_big.
  Qed.

  Theorem ghost_async_map_update_big {γ m} m0 m1 :
    dom m0 = dom m1 →
    ghost_async_map_auth γ 1 m -∗
    ([∗ map] k↦v ∈ m0, k ↪[γ] v) ==∗
    ghost_async_map_auth γ 1 (m1 ∪ m) ∗
        [∗ map] k↦v ∈ m1, k ↪[γ] v.
  Proof.
    iIntros (?) "Hauth Hfrag". iMod (ghost_async_map_elems_unseal with "Hfrag") as "Hfrag".
    unseal. rewrite -big_opM_own_1 -own_op.
    iApply (own_update_2 with "Hauth Hfrag").
    apply: gmap_view_update_big. done.
  Qed.
  *)

  Definition is_possible (d : gmap K (async V)) (addr: K) (b: V) : Prop :=
    ∃ ab, d !! addr = Some ab ∧ b ∈ possible ab.

  Definition is_crashed (d d': gmap K (async V)) :=
      dom d = dom d' ∧
      (∀ (addr : K) (ab : async V), d' !! addr = Some ab →
       ∃ (b : V), ab = sync b ∧ is_possible d addr b).

  (* TODO: this could be generalized so that any >/2 fraction can be exchanged for 1,
     or a □ could be exchanged for a □ *)
  Definition ghost_async_map_exchanger_key  γ1 γ2 k va2 : iProp Σ :=
    ((∃ a v, k ↪[γ1][a] v) ∨ k ↪[γ2][list_to_set (pending va2)] (latest va2)).

  Definition ghost_async_map_exchanger γ ma γ' ma' : iProp Σ :=
    ⌜ is_crashed ma ma' ⌝ ∗
    ghost_async_map_auth γ 1 ma ∗
    [∗ map] k↦va ∈ ma,
    ∃ va', ⌜ ma' !! k = Some va' ⌝ ∗ ghost_async_map_exchanger_key γ γ' k va'.

  Lemma ghost_async_map_exchanger_init γ ma ma' :
    is_crashed ma ma' →
    ghost_async_map_auth γ 1 ma ==∗
    ∃ γ', ghost_async_map_auth γ' 1 ma' ∗ ghost_async_map_exchanger γ ma γ' ma'.
  Proof.
    iIntros (Hcrashed) "Hauth".
    iMod (ghost_async_map_alloc ma') as (γ') "(Hauth'&Hkeys)".
    iModIntro. iExists _; iFrame.
    iSplit; first eauto.
    iApply big_sepM_dom.
    destruct Hcrashed as (Hdom&?).
    rewrite Hdom.
    iApply big_sepM_dom.
    iApply (big_sepM_mono with "Hkeys").
    iIntros (k x Hlook). simpl.
    iIntros "Hk". iExists _; iSplit; eauto. iRight. iFrame.
  Qed.

  Lemma ghost_async_map_swap γ ma γ' ma' k aset v :
    ghost_async_map_exchanger γ ma γ' ma' -∗
    k ↪[γ][aset] v -∗
    ghost_async_map_exchanger γ ma γ' ma' ∗ ∃ v', ⌜ v' ∈ {[v]} ∪ aset ⌝ ∗
    k ↪[γ'][∅] v'.
  Proof.
    iIntros "(%Hcrashed&Hauth&Hexch) Hk".
    iDestruct (ghost_async_map_lookup with "[$] [$]") as %Hlook.
    destruct Hlook as (va&Hlook&Heq&Hsub).
    iDestruct (big_sepM_lookup_acc with "[$]") as "(Hk_exch&Hexch)"; eauto.
    iDestruct "Hk_exch" as (va' Hlook') "Hk_exch".
    destruct Hcrashed as (Hdom&Hc). edestruct (Hc) as (v'&Heq_sync&Hpossible); eauto.
    subst.
    iDestruct "Hk_exch" as "[Htaken|Huntaken]".
    { iDestruct "Htaken" as (??) "Htaken".
      iDestruct (ghost_async_map_elem_frac_ne with "[$] [$]") as %Hval; eauto. congruence. }
    iDestruct ("Hexch" with "[Hk]") as "Hexch".
    { iExists _. iSplit; first eauto. iLeft. iExists _, _. by iFrame. }
    iFrame. iSplit; first eauto.
    iExists _. iFrame. iPureIntro. simpl.
    destruct Hpossible as (?&?&?). set_solver.
  Qed.

End lemmas.


(** This file contains generic environment information for the Bedrock IL
 **)
Require Import List.
Require Import MirrorShard.Expr.
Require Import MirrorShard.Env.
Require Import MirrorShard.TypedPackage.
Require Import Word.
Require Import Memory IL.
Require Import Arith.

Set Implicit Arguments.
Set Strict Implicit.

(*
Definition test_seq l r : bool :=
  match l as l , r as r with
    | IL.Eq , IL.Eq => true
    | IL.Ne , IL.Ne => true
    | IL.Le , IL.Le => true
    | IL.Lt , IL.Lt => true
    | _ , _ => false
  end.

Theorem test_seq_compare : forall x y, test_seq x y = true -> x = y.
  destruct x; destruct y; simpl; (reflexivity || congruence).
Defined.
*)

Definition reg_seq l r : bool :=
  match l as l , r as r with
    | IL.Sp , IL.Sp => true
    | IL.Rp , IL.Rp => true
    | IL.Rv , IL.Rv => true
    | _ , _ => false
  end.

Theorem reg_seq_compare : forall x y, reg_seq x y = true -> x = y.
  destruct x; destruct y; simpl; (reflexivity || congruence).
Defined.

Definition W_seq (l r : W) : bool := Word.weqb l r.

Theorem W_seq_compare : forall x y, W_seq x y = true -> x = y.
  intros. apply weqb_sound. unfold W_seq in *. apply H.
Defined.

Lemma all_false_compare T : forall x y : T, false = true -> x = y.
  congruence.
Defined.

Definition bedrock_type_W : type :=
  {| Expr.Impl := W
   ; Expr.Eqb := W_seq
   ; Expr.Eqb_correct := W_seq_compare
  |}.
Definition bedrock_type_setting_X_state : type :=
  {| Expr.Impl := settings * state
   ; Expr.Eqb := fun _ _ => false
   ; Expr.Eqb_correct := @all_false_compare _
   |}.
Definition bedrock_type_state : type :=
  {| Expr.Impl := state
   ; Expr.Eqb := fun _ _ => false
   ; Expr.Eqb_correct := @all_false_compare _
   |}.
(*
Definition bedrock_type_test : type :=
  {| Expr.Impl := IL.test
   ; Expr.Eqb := test_seq
   ; Expr.Eqb_correct := test_seq_compare
  |}.
*)
Definition bedrock_type_reg : type :=
  {| Expr.Impl := IL.reg
   ; Expr.Eqb := reg_seq
   ; Expr.Eqb_correct := reg_seq_compare
  |}.

Definition bedrock_type_nat : type :=
  {| Expr.Impl := nat
   ; Expr.Eqb := beq_nat
   ; Expr.Eqb_correct := beq_nat_true
  |}.

Definition core_bedrock_types : list Expr.type :=
  bedrock_type_W ::
  bedrock_type_setting_X_state :: nil.

Definition core_bedrock_types_r : Repr Expr.type :=
  Eval cbv beta iota zeta delta [ listToRepr core_bedrock_types ]
    in (listToRepr core_bedrock_types Expr.EmptySet_type).

Definition bedrock_types : list Expr.type :=
  bedrock_type_W ::
  bedrock_type_setting_X_state ::
  bedrock_type_state ::
(*  bedrock_type_test :: *)
  bedrock_type_reg ::
  bedrock_type_nat :: nil.

Definition bedrock_types_r : Repr Expr.type :=
  Eval cbv beta iota zeta delta [ listToRepr bedrock_types ]
    in (listToRepr bedrock_types Expr.EmptySet_type).

Definition comparator (t : IL.test) (l r : W) : Prop :=
  match t with
    | IL.Eq => l = r
    | IL.Ne => l = r -> False
    | IL.Lt => wlt l r
    | IL.Le => not (wlt r l)
  end.

Section typed_ext.
  Variable types' : list type.
  (* Local Notation "'types'" := (repr bedrock_types_r types'). *)

  Local Notation "'pcT'" := (tvType 0).
  Local Notation "'tvWord'" := (tvType 0).
  Local Notation "'stT'" := (tvType 1).
  Local Notation "'tvState'" := (tvType 2).
(*Local Notation "'tvTest'" := (tvType 3).*)
  Local Notation "'tvReg'" := (tvType 3).
  Local Notation "'natT'" := (tvType 4).

  Definition word_types_r : Repr Expr.type :=
    Eval cbv beta iota zeta delta [ listToRepr ]
      in (listToRepr (bedrock_type_W :: nil) Expr.EmptySet_type).

  Definition wplus_r : signature (repr word_types_r types').
    refine {| Domain := tvWord :: tvWord :: nil; Range := tvWord |}.
    exact (@wplus 32).
  Defined.

  Definition wminus_r : signature (repr word_types_r types').
    refine {| Domain := tvWord :: tvWord :: nil; Range := tvWord |}.
    exact (@wminus 32).
  Defined.

  Definition wmult_r : signature (repr word_types_r types').
    refine {| Domain := tvWord :: tvWord :: nil; Range := tvWord |}.
    exact (@wmult 32).
  Defined.

(*
  Definition word_test_r : Repr Expr.type :=
    Eval cbv beta iota zeta delta [ listToRepr ]
      in (listOptToRepr (Some bedrock_type_W :: None :: None :: Some bedrock_type_test :: nil) Expr.EmptySet_type).

  Definition wcomparator_r : signature (repr word_test_r types').
    refine {| Domain := tvTest :: tvWord :: tvWord :: nil ; Range := tvProp |}.
    exact (comparator).
  Defined.
*)

  Definition word_state_r : Repr Expr.type :=
    Eval cbv beta iota zeta delta [ listToRepr ]
      in (listOptToRepr (Some bedrock_type_W :: None :: Some bedrock_type_state :: Some bedrock_type_reg :: nil) Expr.EmptySet_type).

  Definition Regs_r : signature (repr word_state_r types').
    refine {| Domain := tvState :: tvReg :: nil ; Range := tvWord |}.
    exact (Regs).
  Defined.

  Definition wlt_r : signature (repr word_types_r types').
    refine {| Domain := tvWord :: tvWord :: nil; Range := tvProp |}.
    exact (@wlt 32).
  Defined.

  Definition word_nat_r : Repr Expr.type :=
    Eval cbv beta iota zeta delta [ listToRepr ]
      in (listOptToRepr (Some bedrock_type_W :: None :: None :: None :: Some bedrock_type_nat :: nil) Expr.EmptySet_type).

  Definition natToW_r : signature (repr word_nat_r types').
    refine {| Domain := natT :: nil; Range := tvWord |}.
    exact natToW.
  Defined.
End typed_ext.

  Definition bedrock_funcs types' : functions (repr bedrock_types_r types') :=
    let types := repr bedrock_types_r types' in
    wplus_r types ::
    wminus_r types ::
    wmult_r types ::
    (* wcomparator_r types :: *)
    Regs_r types ::
    wlt_r types ::
    natToW_r types :: nil.

  Definition bedrock_funcs_r types' : Repr (signature (repr bedrock_types_r types')) :=
    Eval cbv beta iota zeta delta [ listToRepr bedrock_funcs ]
      in (listToRepr (bedrock_funcs types') (Default_signature _)).

Section func_ext.
  Local Notation "'pcT'" := (tvType 0).
  Local Notation "'tvWord'" := (tvType 0).
  Local Notation "'stT'" := (tvType 1).
  Local Notation "'tvState'" := (tvType 2).
(*Local Notation "'tvTest'" := (tvType 3).*)
  Local Notation "'tvReg'" := (tvType 3).
  Local Notation "'natT'" := (tvType 4).

  Variable types' : list type.
  Definition types := repr bedrock_types_r types'.

  Variable funcs' : functions types.
  Definition funcs := repr (bedrock_funcs_r types') funcs'.

  Definition fPlus (l r : expr types) : expr types :=
    Expr.Func 0 (l :: r :: nil).
  Definition fMinus (l r : expr types) : expr types :=
    Expr.Func 1 (l :: r :: nil).
  Definition fMult (l r : expr types) : expr types :=
    Expr.Func 2 (l :: r :: nil).

  Theorem fPlus_correct : forall l r uvars vars,
    match exprD funcs uvars vars l (tvType 0) , exprD funcs uvars vars r (tvType 0) with
      | Some lv , Some rv =>
        exprD funcs uvars vars (fPlus l r) (tvType 0) = Some (wplus lv rv)
      | _ , _ => True
    end.
  Proof.
    intros; simpl; unfold eq_ind_r; simpl;
      repeat match goal with
               | [ |- match ?X with
                        | Some _ => _
                        | None => _
                      end ] => destruct X
             end; auto.
  Qed.
  Theorem fMinus_correct : forall l r uvars vars,
    match exprD funcs uvars vars l tvWord , exprD funcs uvars vars r tvWord with
      | Some lv , Some rv =>
        exprD funcs uvars vars (fMinus l r) tvWord = Some (wminus lv rv)
      | _ , _ => True
    end.
  Proof.
    intros; simpl; unfold eq_ind_r; simpl;
      repeat match goal with
               | [ |- match ?X with
                        | Some _ => _
                        | None => _
                      end ] => destruct X
             end; auto.
  Qed.
  Theorem fMult_correct : forall l r uvars vars,
    match exprD funcs uvars vars l tvWord , exprD funcs uvars vars r tvWord with
      | Some lv , Some rv =>
        exprD funcs uvars vars (fMult l r) tvWord = Some (wmult lv rv)
      | _ , _ => True
    end.
  Proof.
    intros; simpl; unfold eq_ind_r; simpl;
      repeat match goal with
               | [ |- match ?X with
                        | Some _ => _
                        | None => _
                      end ] => destruct X
             end; auto.
  Qed.
End func_ext.

Module BedrockCoreEnv <: CoreEnv.
  Definition core :=
    Eval unfold bedrock_types_r in bedrock_types_r.

  Definition pc := tvType 0.
  Definition st := tvType 1.
End BedrockCoreEnv.

(*Require SepIL. *)


Require Import Contractive Sty Map Msg Tac Var.

Create HintDb tl discriminated.

CoInductive Tl :=
| Tl_unit : Tl
| Tl_send : Msg -> Tl -> Tl
| Tl_recv : Msg -> Tl -> Tl
| Tl_echoice : Tl -> Tl -> Tl
| Tl_ichoice : Tl -> Tl -> Tl
.
Hint Constructors Tl : tl.

Inductive Tl_bisim_gen Tl_bisim : Tl -> Tl -> Prop :=
| Tl_bisim_gen_unit :
    Tl_bisim_gen Tl_bisim Tl_unit Tl_unit
| Tl_bisim_gen_send :
    forall l l' B,
    Tl_bisim l l' ->
    Tl_bisim_gen Tl_bisim (Tl_send B l) (Tl_send B l')
| Tl_bisim_gen_recv :
    forall l l' B,
    Tl_bisim l l' ->
    Tl_bisim_gen Tl_bisim (Tl_recv B l) (Tl_recv B l')
| Tl_bisim_gen_echoice :
    forall l1 l1' l2 l2',
    Tl_bisim l1 l1' ->
    Tl_bisim l2 l2' ->
    Tl_bisim_gen Tl_bisim (Tl_echoice l1 l2) (Tl_echoice l1' l2')
| Tl_bisim_gen_ichoice :
    forall l1 l1' l2 l2',
    Tl_bisim l1 l1' ->
    Tl_bisim l2 l2' ->
    Tl_bisim_gen Tl_bisim (Tl_ichoice l1 l2) (Tl_ichoice l1' l2')
.
Hint Constructors Tl_bisim_gen : tl.

CoInductive Tl_bisim : Tl -> Tl -> Prop :=
| Tl_bisim_fold : forall l l', Tl_bisim_gen Tl_bisim l l' -> Tl_bisim l l'.
Hint Constructors Tl_bisim.

Lemma Tl_bisim_coind : forall R,
  (forall l l', R l l' -> Tl_bisim_gen R l l')
  -> forall l l', R l l' -> Tl_bisim l l'.
Proof. cofix CIH. introv H HR. apply H in HR. inverts HR; eauto with tl. Qed.

(*
The following lemmae are used in the definition of tl below. We introduce
them in order to prevent the unfolding of contractiveness proofs used in tl,
which would otherwise lead to large and confusing goals.
*)

Ltac Contractive_inv :=
  let H := fresh in
  intro H; inversion H; auto
.

Lemma Contractive_inv_send {S B} :
  Contractive (send B S) -> Contractive S.
Proof. Contractive_inv. Qed.

Lemma Contractive_inv_recv {S B} :
  Contractive (recv B S) -> Contractive S.
Proof. Contractive_inv. Qed.

Lemma Contractive_inv_echoice1 {S1 S2} :
  Contractive (echoice S1 S2) -> Contractive S1.
Proof. Contractive_inv. Qed.

Lemma Contractive_inv_echoice2 {S1 S2} :
  Contractive (echoice S1 S2) -> Contractive S2.
Proof. Contractive_inv. Qed.

Lemma Contractive_inv_ichoice1 {S1 S2} :
  Contractive (ichoice S1 S2) -> Contractive S1.
Proof. Contractive_inv. Qed.

Lemma Contractive_inv_ichoice2 {S1 S2} :
  Contractive (ichoice S1 S2) -> Contractive S2.
Proof. Contractive_inv. Qed.

Lemma Contractive_inv_mu {S X} :
  Contractive (mu X S) -> Contractive S.
Proof. Contractive_inv. Qed.

(*
The following two axioms are used exclusively in the definition of tl below. We
justify their use here:

tl_fix is used to circumvent the productivity checker, which doesn't consider
tl productive due to the case for (mu X S). This is correct insofar as tl is
only productive if the input S is contractive, therefore we require a proof
of contractiveness for every application of tl.

With S contractive, productivity follows:

  For S in {unit, send _ _, recv _ _, echoice _ _, ichoice _ _}, we produce a
  constructor before recursing into tl.

  For S = var _, we don't recurse at all.

  For S = mu X S', S' <> var _ due to S contractive. Thus, the recursive call
  (tl _ S' _) produces at least one constructor before potentially recursing
  further.

Thus, the use of tl_fix is safe. tl_fix_fix merely stipulates that tl_fix
behaves like a fixpoint combinator.
*)

Axiom tl_fix : (Tl -> Tl) -> Tl.

Axiom tl_fix_fix :
  forall F,
  tl_fix F = F (tl_fix F).

Fixpoint tl (eta : Var -> Tl) (S : Sty) (Scontr : Contractive S) : Tl :=
  match S return Contractive S -> Tl with
  | unit => fun _ =>
      Tl_unit
  | send B S' => fun c =>
      Tl_send B (tl eta S' (Contractive_inv_send c))
  | recv B S' => fun c =>
      Tl_recv B (tl eta S' (Contractive_inv_recv c))
  | echoice S1 S2 => fun c =>
      Tl_echoice
        (tl eta S1 (Contractive_inv_echoice1 c))
        (tl eta S2 (Contractive_inv_echoice2 c))
  | ichoice S1 S2 => fun c =>
      Tl_ichoice
        (tl eta S1 (Contractive_inv_ichoice1 c))
        (tl eta S2 (Contractive_inv_ichoice2 c))
  | mu X S' => fun c =>
      tl_fix (fun lx => tl (eta_override eta X lx) S' (Contractive_inv_mu c))
  | var X => fun _ =>
      eta X
  end
  Scontr
.


(*|
##############################
Coq - Coercion of ``list nat``
##############################

:Link: https://stackoverflow.com/q/70726083
|*)

(*|
Question
********

I would like to do a coercion from the type ``list nat`` to the type
``list bool``. I would think that this could be done in the following
way:

.. code-block:: coq

    From Coq Require Import Lists.List.

    Definition nat_to_bool (n : nat) : bool :=
      match n with
      | 0 => true
      | _ => false
      end.

    Definition list_nat_to_list_bool (l : list nat) : list bool :=
      map (fun n => (nat_to_bool n)) l.

    Coercion list_nat_to_list_bool : list nat >-> list bool.

However, this doesn't work. It seems like there is a fundamental issue
with using coercion on something of the form ``list nat``. Why does
this not work?
|*)

(*|
Answer
******

The `documentation
<https://coq.inria.fr/refman/addendum/implicit-coercions.html#classes>`__
states that a class name must be a defined name. Neither ``list nat``
nor ``list bool`` are defined names - they are both applications. You
must give the types between you want to define coercions a name as in:
|*)

From Coq Require Import Lists.List.

Definition nat_to_bool (n : nat) : bool :=
  match n with
  | 0 => true
  | _ => false
  end.

Definition list_nat := list nat.
Definition list_bool := list bool.

Definition list_nat_to_list_bool (l : list_nat) : list_bool :=
  map (fun n => (nat_to_bool n)) l.

Coercion list_nat_to_list_bool : list_nat >-> list_bool.

(*|
Please note that the coercion function must use these names - you
can't write ``list nat`` instead of ``list_nat``. Also the
applications of the coercion must use the defined names as in:
|*)

Definition test : list_bool := (1 :: nil) : list_nat.

(*|
I *guess* this is so because coercions might be done at the syntactic
level where type unifications would be difficult.

----

**Q:** So, if I have a function ``f`` whose inputs are of type ``list
bool``, and I want to use coercion to pass objects of type ``list
nat`` to it, I'd have to edit ``f`` so that its input type is
``list_bool`` instead? There isn't a way around this?

**A:** I am not an expert for coercions, but as far as I know and
understand the documentation, that's how it is, yes.
|*)


Require List.
Require Bool.
Require Import Coq.Structures.Equalities.
Add LoadPath "/home/user/0my/GITHUB/VerifiedMathFoundations/library".
Require Import Misc.
(*From VerifiedMathFoundations.library Require Import Misc.*)
Require Export Provability.

Module Deduction_mod (SetVars FuncSymb PredSymb: UsualDecidableTypeFull).
Module X := Provability_mod SetVars FuncSymb PredSymb.
Export X.

Import PredFormulasNotationsASCII.
Local Open Scope pretxtnot.

Export Coq.Lists.List.
Import Bool.Bool.
Notation SetVars := SetVars.t (only parsing).
Notation FuncSymb := FuncSymb.t (only parsing).
Notation PredSymb := PredSymb.t (only parsing).

Module Facts := BoolEqualityFacts SetVars.

Definition B1 (ps ph:Fo) (xi:SetVars) (H:isParamF xi ps = false):
 PREPR nil (ps --> ph) -> PREPR nil (ps --> Fora xi ph).
Proof.
intro q.
apply MP_E with (A:=(Fora xi (ps --> ph))).
(*apply (MP_E nil (Fora xi (ps --> ph))).*)
+ apply (GEN_E).
  exact q.
+ apply (b1 _).
  exact H.
Defined.

Definition gen (A:Fo) (xi:SetVars) ctx
(*Generalization from Bernay's rule*)
: PREPR ctx (A) -> PREPR ctx (Fora xi A).
Proof.
intro q.
apply MP_E with (A:= Top).
unfold Top.
(*fold PREPR.*)
exact (@AtoA ctx Bot).
apply MP_E with (A:= (Fora xi (Top --> A))).
* apply GEN_E.
  apply MP_E with (A:= A).
  + exact q.
  + apply a1. (*apply subcalc, a1.*)
* apply b1.
  trivial.
Defined.

Definition neg (f:Fo):= (Impl f Bot).

Definition a1i (A B : Fo)(l : list Fo):(PREPR l B)->(PREPR l (Impl A B)).
Proof.
intros x.
apply MP_E with (A:= B).
exact x.
apply (*subcalc,*) a1.
Defined.

Fixpoint weak (A F:Fo) (l :list Fo) (x: (PREPR l F)) : (PREPR (A::l) F).
Proof.
destruct x as [a b|a b|i a b|a b].
+ apply hyp_E.
  right. (* apply inr. or_intror *)
  exact b.
+ apply Hax_E,b.
(*apply a1.
apply a2.
apply a12.
apply b1.
assumption. *)
+ apply MP_E with (A:= i).
  * apply weak.
    exact b.
  * apply weak.
    exact x1.
+ apply GEN_E. (* Order is not important! *)
  apply weak. (* Order is not important! *)
  exact x.
Defined.

(*Fixpoint weak (A F : Fo) (l : list Fo) (x : PREPR l F) {struct x} :
   PREPR (A :: l) F :=
   match x in (GPR _ _ _ f) return (PREPR (A :: l) f) with
   | hyp _ _ _ a b => hyp dcb PRECA (A :: l) a (inr b)
   | Hax _ _ _ a b => Hax dcb PRECA (A :: l) a b
   | MP_E _ _ _ _ a b x1 x2 =>
       MP_E dcb PRECA (A :: l) I a b (weak A a l x1) (weak A (a --> b) l x2)
   | GEN_E _ _ _ _ a b x0 => GEN_E dcb PRECA (A :: l) I a b (weak A a l x0)
   end.*)

Fixpoint weaken (F:Fo) (li l :list Fo) (x: (PREPR l F)) {struct li}: (PREPR (li ++ l) F).
Proof.
destruct li.
simpl.
exact x.
simpl.
simple refine (@weak f F (li ++ l) _).
apply weaken.
exact x.
(*Show Proof.*)
Abort.

Fixpoint weaken (F : Fo) (li l : list Fo) (x : PREPR l F) {struct li} :
   PREPR (li ++ l) F :=
   match li as l0 return (PREPR (l0 ++ l) F) with
   | Datatypes.nil => x
   | f :: li0 => weak f F (li0 ++ l) (weaken F li0 l x)
   end.

(*Export List Notations.*)
Fixpoint notGenWith (xi:SetVars)(l:list Fo)
(B:Fo)(m:(PREPR l B)){struct m}:bool.
Proof.
(*induction m.  eqn: o.*)
destruct m  eqn: o.
(*Show Proof.*)
exact true.
destruct p eqn:j.
exact true.
exact true.
exact true.
(*exact (andb IHm1 IHm2).
exact (andb (negb (SetVars.eqb xi xi0)) IHm).*)
exact (andb (notGenWith xi l _ p1) (notGenWith xi l _ p2)).
exact (andb (negb (SetVars.eqb xi xi0)) (notGenWith xi l _ p) ).
Defined.

(*Fixpoint HA xi : true = PeanoNat.Nat.eqb (xi) (xi).
Proof.
destruct xi.
reflexivity.
simpl.
exact (HA xi).
Defined.*)

Theorem lm (a b :bool)(G:true = (a && b) ): true = a.
Proof.
destruct a.
trivial.
inversion G.
Defined.

Fixpoint Ded (A B:Fo)(il:list Fo)(m:(PREPR (cons A il) B))
(H:forall xi:SetVars, (true = isParamF xi A)->(true=notGenWith xi _ _ m))
{struct m}:(PREPR il (A-->B)).
Proof.
destruct m. (*as [i|i|i|i|i|i|i].*)
+ unfold In in i.
  simpl in i .
  destruct i .
  * rewrite <- e.
    pose (J:=weaken _ il nil (AtoA A )).
    rewrite app_nil_r in J.
    exact J.
  * simpl in H.
    apply a1i.
    apply hyp_E with (ctx:=il) (1:=i).
    (*exact (hyp _ il _ i).*)
+ apply a1i.
  apply Hax_E, p.
+ apply MP_E with (A:= (A-->A0)).
- simple refine (@Ded _ _ _ _ _).
  exact m1.
  intros xi H0.
  pose (W:=H xi H0).
  simpl in W.
  pose (J:=notGenWith xi (A :: il) A0 m1).
  try reflexivity.
  fold J.
  fold J in W.
  apply (lm _ _ W).
- apply MP_E with (A:= (A-->(A0-->B))).
  simple refine (@Ded _ _ _ _ _).
  exact m2.
  intros xi H0.
  pose (W:=H xi H0).
  simpl in W.
  apply (lm2 _ _ W).
 (*Last part about GEN*)
  apply a2.
  + apply MP_E with (A:= (Fora xi (A-->A0))).
    apply GEN_E.
    simple refine (@Ded _ _ _ _ _).
    exact m.
    intros xi0 H0.
    pose (W:=H xi0 H0).
    simpl in W.
    * exact (lm2 _ _ W).
    * simpl.
      apply b1.
      pose (r := isParamF xi A).
      pose (U := H xi).
      fold r in U |- *.
      simpl in U.
      destruct (N r).
      - pose (C:= lm _ _(U H0)).
        exfalso.
        rewrite Facts.eqb_refl in C.
        inversion C.
      - exact H0.
Defined.

Definition lm3 (a b :bool)(A: true = a)(B: true = b):true = (a && b)
:=
 (if a as a0 return (true = a0 -> true = a0 && b)
  then
   fun _ : true = true =>
   (if b as b0 return (true = b0 -> true = true && b0)
    then fun _ : true = true => eq_refl
    else fun B0 : true = false => B0) B
  else
   fun A0 : true = false =>
   (if b as b0 return (true = b0 -> true = false && b0)
    then fun _ : true = true => A0
    else fun _ : true = false => A0) B) A.
(*destruct a,b.
reflexivity.
simpl.
exact B.
simpl.
exact A.
simpl.
exact A.
Show Proof.
Defined.*)

Fixpoint forClosed (A B:Fo)(m:(PREPR (cons A nil) B)):
(forall xi:SetVars, (false = isParamF xi A))
->
(forall xi:SetVars, (true = isParamF xi A)->(true=notGenWith xi _ _ m)).
Proof.
intros H xi Q.
destruct m. simpl. try reflexivity.
destruct p eqn:j.
simpl. try reflexivity.
simpl. try reflexivity.
simpl. try reflexivity.
simpl. try reflexivity.
+ apply lm3.
  simple refine (@forClosed _ _ _ _ _ _); assumption.
  simple refine (@forClosed _ _ _ _ _ _); assumption.
+ apply lm3.
  2 : simple refine (@forClosed _ _ _ _ _ _); assumption.
  pose (U:=H xi).
  rewrite <- Q in U.
  exfalso.
  inversion U.
Defined.

Fixpoint SimplDed (A B:Fo) (il: list Fo)(m:(PREPR (cons A il) B))
(NP:forall xi:SetVars, (isParamF xi A = false))
{struct m}:(PREPR il (A-->B)).
Proof.
(*unshelve eapply Ded.*)
simple refine (Ded _ _ _ _ _).
exact m.
intros xi H.
rewrite -> NP in H.
inversion H.
Defined.

Definition swapSIMPL ctx A B C
(HA : forall xi : SetVars.t, isParamF xi A = false)
(HB : forall xi : SetVars.t, isParamF xi B = false)
(HC : forall xi : SetVars.t, isParamF xi C = false) :
(PREPR ctx ((A --> (B --> C)) --> (B --> (A --> C)) )).
Proof.
unshelve eapply SimplDed.
2 : { intro xi. simpl.
apply orb_intro. split. apply HA.
apply orb_intro. split. apply HB. apply HC.
}
unshelve eapply SimplDed. 2 : apply HB.
unshelve eapply SimplDed. 2 : apply HA.
apply MP_E with (A:=B) . apply hyp_E.
simpl. firstorder. (*apply inr.*)
apply MP_E with (A:=A) .
apply hyp_E; firstorder.
apply hyp_E; firstorder.
Defined.

Definition swap ctx A B C :
(PREPR ctx ((A --> (B --> C)) --> (B --> (A --> C)) )).
Proof.
unshelve eapply SimplDed.
Admitted.

End Deduction_mod.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

Inductive color : Set :=
  | blue : color
  | red : color
  | yellow : color.

Inductive tree1 : Set :=
  | Leaf : nat -> tree1
  | Nd1 : color -> tree1 -> tree1.

Fixpoint def_cop (T : tree1) : tree1 :=
  match T with
  | Leaf n => Leaf n
  | Nd1 blue t => Nd1 red (def_cop t)
  | Nd1 red t => Nd1 red (def_cop t)
  | Nd1 yellow t => Nd1 yellow (def_cop t)
  end.

Require Import Mx_defs.
Require Extraction.

(* (Mx P A) computes an inhabitant of A but may raise an exception if P *)
Theorem core_cop :
 forall t : tree1,
 Mx (t = def_cop t) {t' : tree1 | t' = def_cop t &  t <> t'}.

fix 1.
intro t; case t; clear t.
  simpl in |- *; intros n. apply Mx_raise. trivial.

  intros c t1; case c; simpl in |- *; clear c.
    (* c = blue *)
    apply Mx_try with (1 := core_cop t1).
      intros (t', eg, di); apply Mx_unit. exists (Nd1 red t'); [ elim eg; trivial | simplify_eq ].

      intro eg; apply Mx_unit. exists (Nd1 red t1); [ elim eg; trivial | simplify_eq ].

    (* c = red *)
    apply Mx_bind with (1 := core_cop t1).
      intros (t', eg, di); apply Mx_unit. exists (Nd1 red t'); [ elim eg; trivial | simplify_eq; assumption ].
      intro eg; simpl in |- *; elim eg; trivial.

    (* c = yellow *)
    apply Mx_bind with (1 := core_cop t1).
      intros (t', eg, di); apply Mx_unit. exists (Nd1 yellow t'); [ elim eg; trivial | simplify_eq; assumption ].
      intro eg; simpl in |- *; elim eg; trivial.
Defined.

Theorem eff_cop : forall t : tree1, {t' : tree1 | t' = def_cop t}.
intro t; apply Mx_try with (1 := core_cop t).
    intros (x, e, n); exists x; auto.
    intro eg; exists t; trivial.
Defined.

(* Extracting terms typed in system F but not in ML *)
(* In the extracted ML program, you have to
    - put an Obj.magic in front of each call to mx_try
      (at least for each recursive (then polymorphic) use of mx_try)
*)

Extraction "copy_extr.ml" Mx_unit Mx_raise Mx_try Mx_bind core_cop eff_cop.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                Xavier Leroy, INRIA Paris                            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** This library provides type classes and tactics to decide logical
  propositions by reflection into computable Boolean equalities.
  It extends the [DecidableClass] module from the standard library
  of Coq 8.5 with more instances of decidable properties, including
  universal and existential quantification over finite types. *)

Require Export DecidableClass.
Require Import Coqlib.

Ltac decide_goal := eapply Decidable_sound; reflexivity.

(** Deciding logical connectives *)

Program Instance Decidable_not (P: Prop) (dP: Decidable P) : Decidable (~ P) := {
  Decidable_witness := negb (@Decidable_witness P dP)
}.
Next Obligation.
  rewrite negb_true_iff. split. apply Decidable_complete_alt. apply Decidable_sound_alt.
Qed.

Program Instance Decidable_equiv (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P <-> Q) := {
  Decidable_witness := Bool.eqb (@Decidable_witness P dP) (@Decidable_witness Q dQ)
}.
Next Obligation.
  rewrite eqb_true_iff.
  split; intros.
  split; intros; eapply Decidable_sound; [rewrite <- H | rewrite H]; eapply Decidable_complete; eauto.
  destruct (@Decidable_witness Q dQ) eqn:D.
  eapply Decidable_complete; rewrite H; eapply Decidable_sound; eauto.
  eapply Decidable_sound_alt; rewrite H; eapply Decidable_complete_alt; eauto.
Qed.

Program Instance Decidable_and (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P /\ Q) := {
  Decidable_witness := @Decidable_witness P dP && @Decidable_witness Q dQ
}.
Next Obligation.
  rewrite andb_true_iff. rewrite ! Decidable_spec. tauto.
Qed.

Program Instance Decidable_or (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P \/ Q) := {
  Decidable_witness := @Decidable_witness P dP || @Decidable_witness Q dQ
}.
Next Obligation.
  rewrite orb_true_iff. rewrite ! Decidable_spec. tauto.
Qed.

Program Instance Decidable_implies (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P -> Q) := {
  Decidable_witness := if @Decidable_witness P dP then @Decidable_witness Q dQ else true
}.
Next Obligation.
  split.
- intros. rewrite Decidable_complete in H by auto. eapply Decidable_sound; eauto.
- intros. destruct (@Decidable_witness P dP) eqn:WP; auto.
  eapply Decidable_complete. apply H. eapply Decidable_sound; eauto.
Qed.

(** Deciding equalities. *)

Program Definition Decidable_eq {A: Type} (eqdec: forall (x y: A), {x=y} + {x<>y}) (x y: A) : Decidable (eq x y) := {|
  Decidable_witness := proj_sumbool (eqdec x y)
|}.
Next Obligation.
  split; intros. InvBooleans. auto. subst y. apply dec_eq_true.
Qed.

Program Instance Decidable_eq_bool : forall (x y : bool), Decidable (eq x y) := {
  Decidable_witness := Bool.eqb x y
}.
Next Obligation.
  apply eqb_true_iff.
Qed.

Program Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := {
  Decidable_witness := beq_nat x y
}.
Next Obligation.
  apply beq_nat_true_iff.
Qed.

Program Instance Decidable_eq_positive : forall (x y : positive), Decidable (eq x y) := {
  Decidable_witness := Pos.eqb x y
}.
Next Obligation.
  apply Pos.eqb_eq.
Qed.

Program Instance Decidable_eq_Z : forall (x y : Z), Decidable (eq x y) := {
  Decidable_witness := Z.eqb x y
}.
Next Obligation.
  apply Z.eqb_eq.
Qed.

(** Deciding order on Z *)

Program Instance Decidable_le_Z : forall (x y: Z), Decidable (x <= y) := {
  Decidable_witness := Z.leb x y
}.
Next Obligation.
  apply Z.leb_le.
Qed.

Program Instance Decidable_lt_Z : forall (x y: Z), Decidable (x < y) := {
  Decidable_witness := Z.ltb x y
}.
Next Obligation.
  apply Z.ltb_lt.
Qed.

Program Instance Decidable_ge_Z : forall (x y: Z), Decidable (x >= y) := {
  Decidable_witness := Z.geb x y
}.
Next Obligation.
  rewrite Z.geb_le. intuition omega.
Qed.

Program Instance Decidable_gt_Z : forall (x y: Z), Decidable (x > y) := {
  Decidable_witness := Z.gtb x y
}.
Next Obligation.
  rewrite Z.gtb_lt. intuition omega.
Qed.

Program Instance Decidable_divides : forall (x y: Z), Decidable (x | y) := {
  Decidable_witness := Z.eqb y ((y / x) * x)%Z
}.
Next Obligation.
  split.
  intros. apply Z.eqb_eq in H. exists (y / x). auto.
  intros [k EQ]. apply Z.eqb_eq.
  destruct (Z.eq_dec x 0).
  subst x. rewrite Z.mul_0_r in EQ. subst y. reflexivity.
  assert (k = y / x).
  { apply Zdiv_unique_full with 0. red; omega. rewrite EQ; ring. }
  congruence.
Qed.

(** Deciding properties over lists *)

Program Instance Decidable_forall_in_list :
      forall (A: Type) (l: list A) (P: A -> Prop) (dP: forall x:A, Decidable (P x)),
      Decidable (forall x:A, In x l -> P x) := {
  Decidable_witness := List.forallb (fun x => @Decidable_witness (P x) (dP x)) l
}.
Next Obligation.
  rewrite List.forallb_forall. split; intros.
- eapply Decidable_sound; eauto.
- eapply Decidable_complete; eauto.
Qed.

Program Instance Decidable_exists_in_list :
      forall (A: Type) (l: list A) (P: A -> Prop) (dP: forall x:A, Decidable (P x)),
      Decidable (exists x:A, In x l /\ P x) := {
  Decidable_witness := List.existsb (fun x => @Decidable_witness (P x) (dP x)) l
}.
Next Obligation.
  rewrite List.existsb_exists. split.
- intros (x & U & V). exists x; split; auto. eapply Decidable_sound; eauto.
- intros (x & U & V). exists x; split; auto. eapply Decidable_complete; eauto.
Qed.

(** Types with finitely many elements. *)

Class Finite (T: Type) := {
  Finite_elements: list T;
  Finite_elements_spec: forall x:T, In x Finite_elements
}.

(** Deciding forall and exists quantification over finite types. *)

Program Instance Decidable_forall : forall (T: Type) (fT: Finite T) (P: T -> Prop) (dP: forall x:T, Decidable (P x)), Decidable (forall x, P x) := {
  Decidable_witness := List.forallb (fun x => @Decidable_witness (P x) (dP x)) (@Finite_elements T fT)
}.
Next Obligation.
  rewrite List.forallb_forall. split; intros.
- eapply Decidable_sound; eauto. apply H. apply Finite_elements_spec.
- eapply Decidable_complete; eauto.
Qed.

Program Instance Decidable_exists : forall (T: Type) (fT: Finite T) (P: T -> Prop) (dP: forall x:T, Decidable (P x)), Decidable (exists x, P x) := {
  Decidable_witness := List.existsb (fun x => @Decidable_witness (P x) (dP x)) (@Finite_elements T fT)
}.
Next Obligation.
  rewrite List.existsb_exists. split.
- intros (x & A & B). exists x. eapply Decidable_sound; eauto.
- intros (x & A). exists x; split. eapply Finite_elements_spec. eapply Decidable_complete; eauto.
Qed.

(** Some examples of finite types. *)

Program Instance Finite_bool : Finite bool := {
  Finite_elements := false :: true :: nil
}.
Next Obligation.
  destruct x; auto.
Qed.

Program Instance Finite_pair : forall (A B: Type) (fA: Finite A) (fB: Finite B), Finite (A * B) := {
  Finite_elements := list_prod (@Finite_elements A fA) (@Finite_elements B fB)
}.
Next Obligation.
  apply List.in_prod; eapply Finite_elements_spec.
Qed.

Program Instance Finite_option : forall (A: Type) (fA: Finite A), Finite (option A) := {
  Finite_elements := None :: List.map (@Some A) (@Finite_elements A fA)
}.
Next Obligation.
  destruct x; auto. right; apply List.in_map; eapply Finite_elements_spec.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Eqdep_dec.
Require Export Field.
Require Export Q_order.

(*###########################################################################*)
(** The Filed Structure for Field Tactic *)
(*###########################################################################*)

Lemma Q_Ring_Theory :
    ring_theory Zero Qone Qplus Qmult Qminus Qopp (eq(A:=Q)).
  split; intros n m p || intros n m || intros n; solve
   [ first
      [ apply Qplus_sym
      | apply Qplus_assoc
      | apply Qmult_sym
      | apply Qmult_assoc
      | apply Qplus_zero_left
      | apply Qmult_one_left
      | apply Q_opp_def
      | apply Q_distr_left
      | reflexivity ]].
Defined.

Lemma Qinv_defT : forall n : Q, n <> Zero -> Qmult (Qinv n) n = Qone.
Proof.
 intros n Hn; rewrite Qmult_sym; apply Qinv_def; intro;
  apply Hn; assumption.
Defined.

Lemma QField :
  field_theory Zero Qone Qplus Qmult Qminus Qopp Qdiv Qinv (eq(A:=Q)).
constructor.
 apply Q_Ring_Theory.
 discriminate.
 reflexivity.
 exact Qinv_defT.
Defined.

Ltac isQcst t :=
  match t with
    Zero => true
  | Qpos ?p => isQcst p
  | Qneg ?p => isQcst p
  | nR ?p => isQcst p
  | dL ?p => isQcst p
  | One => true
  | Qone => true
  | _ => false
  end.
Ltac Qcst t :=
  match isQcst t with
  | true => t
  | _ => InitialRing.NotConstant
  end.

Add Field Qfield : QField (decidable Q_eq_prop, constants [Qcst]).

Definition not_eq2eqT (A : Set) (x y : A) (H1 : x <> y) :
  x <> y := fun H2 : x = y => H1 (H2).

Ltac Field := field.


Require Import Coqlib.
Require Import Maps.
Require Import syntax.
Require Import infrastructure.
Require Import dom_tree.
Require Import dom_list.
Require Import dom_list_tree.
Require Import dom_libs.
Require Import dfs.
Require Import push_iter.
Import LLVMsyntax.
Import LLVMinfra.

(* This file constructs domination frontiers.

  We follow an algorithm that approaches the problem from the opposite direction,
  and tends to run faster than Cytron et al.’s algorithm in practice. The
  algorithm is based on three observations. First, nodes in a dominance frontier
  represent join points in the graph, nodes into which control flows from
  multiple predecessors. Second, the predecessors of any join point, j, must have
  j in their respective dominancefrontier sets, unless the predecessor dominates
  j. This is a direct result of the defnition of dominance frontiers, above.
  Finally, the dominators of j’s predecessors must themselves have j in their
  dominance frontier sets unless they also dominate j.

  These observations lead to a simple algorithm. First, we identify each join
  point, j—any node with more than one incoming edge is a join point. We then
  examine each predecessor, p, of j and walk up the dominator tree starting at p.
  We stop the walk when we reach j’s immediate dominator—j is in the dominance
  frontier of each of the nodes in the walk, except for j’s immediate dominator.
  Intuitively, all of the rest of j’s dominators are shared by j’s predecessors
  as well. Since they dominate j, they will not have j in their dominance
  frontiers.

  This approach tends to run faster than Cytron et al..’s algorithm in practice,
  almost certainly for two reasons. First, the iterative algorithm has already
  built the dominator tree. Second, the algorithm uses no more comparisons than
  are strictly necessary. Section 9.5.2 will revisit the implementation of the
  algorithm. *)
Definition idom_of (dts: PMap.t LDoms.t) (p:positive) : option positive :=
match PMap.get p dts with
| Some (idom::_) => Some idom
| _ => None
end.

Definition doms_of (dts: PMap.t LDoms.t) (p:positive) : list positive :=
match PMap.get p dts with
| Some sdoms => p::sdoms
| _ => nil
end.

(* given curr, idom is the immediate dom of curr, and
   ps doms curr's predecesssors *)
Fixpoint who_has_dom_frontier_aux (curr idom:positive)
  (acc:PTree.t (list positive)) (ps:list positive) : PTree.t (list positive) :=
match ps with
| nil => acc
| p::ps' =>
  if (positive_eq_dec idom p) then acc
  else who_has_dom_frontier_aux curr idom (PTree.set p (curr::acc???p) acc) ps'
end.

(* given curr, idom is the immediate dom of curr, and
   pred is one of curr's predecesssors *)
Definition who_has_dom_frontier (dts: PMap.t LDoms.t) (curr idom:positive)
  (acc:PTree.t (list positive)) (pred:positive) : PTree.t (list positive) :=
who_has_dom_frontier_aux curr idom acc (doms_of dts pred).

Definition pdom_frontier_fun (dts: PMap.t LDoms.t) (acc:PTree.t (list positive))
  (p:positive) (preds: list positive) : PTree.t (list positive) :=
match preds with
| p1::p2::_ =>
  match idom_of dts p with
  | None => acc
  | Some idom => fold_left (who_has_dom_frontier dts p idom) preds acc
  end
| _ => acc
end.

Definition pdom_frontier (ppreds: PTree.t (list positive))
  (dts: PMap.t LDoms.t) : PTree.t (list positive) :=
PTree.fold (pdom_frontier_fun dts) ppreds (PTree.empty _).

Definition dom_frontier (f: fdef) (gen_tree: bool)
  : ATree.t (list l) * option DTree :=
  let asuccs := cfg.successors f in
  match LLVMinfra.getEntryLabel f with
  | Some le =>
      let '(mkPO _ a2p) := dfs asuccs le 1%positive in
      let psuccs := asuccs_psuccs a2p asuccs in
      match ATree.get le a2p with
      | Some pe =>
         let dts := pdom_analyze psuccs pe (num_iters f) in
         let ppreds := XPTree.make_predecessors psuccs in
         let dfs := pdom_frontier ppreds dts in
         let p2a := a2p_p2a a2p in
         let odt :=
           if gen_tree then
             let res := fun p:positive => PMap.get p dts in
             let pdt := create_dtree pe (get_reachable_nodes (bound_fdef f) a2p) res in
             DTreeConv.sdtree_tdtree p2a pdt
           else None in
         let df := PTree.fold
           (fun acc p0 df0 =>
            match p2a ? p0 with
            | None => acc
            | Some a0 => ATree.set a0 (ps2as p2a df0) acc
            end) dfs (ATree.empty _) in
         (df, odt)
      | None => (ATree.empty _, None)
      end
  | None => (ATree.empty _, None)
  end.


Module Type TITI.
Parameter B:Set.
Parameter x:B.
Inductive A:Set:=
a1:B->A.
Definition f2: A ->B
:= fun (a:A) =>
match a with
 (a1 b)=>b
end.
Definition f: A -> B:=fun (a:A) => x.
End TITI.

Module Type TIT.
Declare Module t:TITI.
End TIT.

Module Seq(titi:TIT).
Module t:=titi.t.
Inductive toto:t.A->t.B->Set:=
t1:forall (a:t.A), (toto a (t.f a))
| t2:forall (a:t.A), (toto a (t.f2 a)).
End Seq.

Module koko(tit:TIT).
Module seq:=Seq tit.
Module t':=tit.t.

Definition def:forall (a:t'.A), (seq.toto a (t'.f a)).
intro ; constructor 1.
Defined.

Definition def2: forall (a:t'.A), (seq.toto a (t'.f2 a)).
intro; constructor 2.
(*  Toplevel input, characters 0-13
  constructor 2.
  ^^^^^^^^^^^^^
Error: Impossible to unify (seq.toto ?3 (seq.t.f2 ?3)) with
 (seq.toto a (t'.f2 a)).*)


(** * From CwFs to univalent CwFs *)
(**
  Contents:

    - goal (not yet complete): transfer of CwF structure along the Rezk-completion construction
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.rezk_completion.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.

Require Import TypeTheory.OtherDefs.CwF_Pitts.
Require Import TypeTheory.Categories.category_of_elements.

Local Arguments iso: clear implicits.

(** How to get a functor from RC(C) to D when having one from C to D **)

Definition Rezk_functor (C : category) (D : univalent_category)
    (F : functor C D)
  :  functor (Rezk_completion C) D.
Proof.
  set (H:=Rezk_eta_Universal_Property C D  (pr2 D)).
  apply (invmap (make_weq _  H)).
  apply F.
Defined.

(** * Saturating a CwF *)

Section CwF_completion.

Context (CC : category) (C : cwf_struct CC).

(** ** The "type" part of a CwF **)

(** The "type" part is a functor into the opposite of HSET.
    We thus obtain a "type" functor on RC(C) by univ property
**)

Definition type_hSet (Γ : CC) : hSet := make_hSet (C⟨Γ⟩) (cwf_types_isaset _ _ ).

Definition type_functor_data : functor_data CC (opp_precat HSET).
Proof.
  exists type_hSet.
  intros Γ Γ' γ A. exact (rtype A γ).
Defined.

Definition type_is_functor : is_functor type_functor_data.
Proof.
  split; intros; simpl.
  - intros Γ. apply funextfun; intro A. apply reindx_type_id.
    apply reindx_laws_from_cwf_struct.
  - intros Γ Γ' Γ'' f g. apply funextfun; intro A.
    apply reindx_type_comp.
    apply reindx_laws_from_cwf_struct.
Qed.

Definition type_functor : functor _ _ := tpair _ _ type_is_functor.

Definition RC_type_functor : functor (Rezk_completion CC) (opp_precat HSET).
Proof.
  apply (Rezk_functor CC (op_unicat HSET_univalent_category)).
  apply type_functor.
Defined.

(** ** The "term" part of a CwF **)
(** The "term" part is a functor from the category of elements of "type"
    into (the opposite of) sets.
**)

End CwF_completion.


From HoTT Require Import Basics.
From HoTT Require Import Categories.
From HoTT Require Import Spaces.Finite.
Require Import Misc.
Require Import Limits.Graph.

Local Open Scope morphism_scope.

Section Equalizer.
  Context {C : PreCategory}.

  Definition EqualizerGr {a b : object C} (f g : morphism C a b) : Graph C (Fin 2) (Fin 2).
  Proof.
    srapply mkGraph.
    - intro x. destruct x; [ exact b | exact a ].
    - intro x. destruct x.
      + exists fin1. exists fin2. exact f.
      + exists fin1. exists fin2. exact g.
  Defined.
  Definition Equalizer {a b : object C} (f g : morphism C a b) := Limit (EqualizerGr f g).
  Definition AllEqualizers := forall(a b : object C), forall(f g : morphism C a b), Equalizer f g.
  Definition eq_obj {a b : object C} (f g : morphism C a b) (E : Equalizer f g) : object C :=
    cn_top (lim_cone E).
  Definition eq_mph {a b : object C} (f g : morphism C a b) (E : Equalizer f g)
    : morphism C (eq_obj f g E) a :=
    cn_side (lim_cone E) fin1.
  Lemma eq_mph_comm {a b : object C} (f g : morphism C a b) (E : Equalizer f g) :
    f o eq_mph f g E = g o eq_mph f g E.
  Proof.
    unfold eq_mph. destruct E. simpl.
    pose (Hcomm := cn_comm lim_cone fin1); unfold EqualizerGr in Hcomm;
      unfold gr_edge in Hcomm; unfold gr_src in Hcomm; unfold gr_dst in Hcomm;
      simpl in Hcomm.
    rewrite Hcomm; clear Hcomm.
    pose (Hcomm := cn_comm lim_cone fin2); unfold EqualizerGr in Hcomm;
      unfold gr_edge in Hcomm; unfold gr_src in Hcomm; unfold gr_dst in Hcomm;
      simpl in Hcomm.
    rewrite Hcomm; clear Hcomm.
    reflexivity.
  Qed.

  Definition eq_cone {a b c : object C} (f g : morphism C a b) (h : morphism C c a) :
    f o h = g o h -> Cone (EqualizerGr f g).
  Proof.
    intro Hcomm. srapply mkCone.
    - exact c.
    - unfold EqualizerGr. simpl. intro n. destruct n; [ exact (f o h) | exact h ].
    - unfold EqualizerGr; unfold gr_edge; unfold gr_src; unfold gr_dst; simpl.
      intro n. destruct n; simpl; [ reflexivity | symmetry; exact Hcomm ].
  Defined.
  Lemma eq_ex {a b : object C} (f g : morphism C a b) (E : Equalizer f g) :
    forall(c : object C), forall(h : morphism C c a),
      f o h = g o h -> exists(e : morphism C c (eq_obj f g E)), h = eq_mph f g E o e.
  Proof.
    intros c h Hcomm. destruct E. unfold eq_mph. simpl.
    pose (cn := eq_cone f g h Hcomm). pose (mph := lim_ex cn).
    exists(cnmph_mph mph). rewrite (cnmph_comm mph fin1).
    unfold cn; unfold eq_cone; simpl. reflexivity.
  Qed.

  Definition eq_morphism {a b c1 : object C} (f g : morphism C a b)
             (h1 : morphism C c1 a) (H1 : f o h1 = g o h1) (E : Equalizer f g)
             (m : morphism C c1 (eq_obj f g E))
    : h1 = eq_mph f g E o m -> ConeMorphism (eq_cone f g h1 H1) (lim_cone E).
  Proof.
    intro Hcomm. srapply mkCnMph; [ exact m | idtac ].
    unfold EqualizerGr; intro n; destruct n; unfold eq_cone; simpl; simpl in *.
    - rewrite Hcomm. clear Hcomm. rewrite <- associativity. f_ap. unfold eq_mph; simpl.
      pose (Hcomm := cn_comm (lim_cone E) fin2);
        unfold gr_edge in Hcomm; unfold gr_src in Hcomm; unfold gr_dst in Hcomm;
        simpl in Hcomm. rewrite Hcomm. clear Hcomm.
      destruct f0; [ apply Empty_ind; assumption | destruct u; reflexivity ].
    - rewrite Hcomm. unfold eq_mph. destruct u. reflexivity.
  Defined.
  Lemma eq_uniq {a b c : object C} (f g : morphism C a b) (h : morphism C c a) (E : Equalizer f g) :
    forall(m1 m2 : morphism C c (eq_obj f g E)),
      f o h = g o h ->
      eq_mph f g E o m1 = h ->
      eq_mph f g E o m2 = h ->
      m1 = m2.
  Proof.
    intros m1 m2 Hcn Hm1 Hm2.
    pose (mph1 := eq_morphism f g h Hcn E m1 Hm1^).
    pose (mph2 := eq_morphism f g h Hcn E m2 Hm2^).
    destruct E; unfold eq_mph in *; unfold eq_obj in *; simpl in *.
    pose (uniq := lim_uniq (eq_cone f g h Hcn) mph1 mph2).
    unfold mph1 in uniq; unfold mph2 in uniq; simpl in uniq.
    exact uniq.
  Qed.
End Equalizer.