(* -*- mode: coq; coq-prog-args: ("-noinit" "-indices-matter" "-w" "-notation-overridden,-deprecated-option") -*- *)
(*
    The Coq Proof Assistant, version 8.7.1 (January 2018)
    compiled on Jan 21 2018 15:02:24 with OCaml 4.06.0
    from commit 391bb5e196901a3a9426295125b8d1c700ab6992
 *)

Require Export Coq.Init.Notations.
Notation "'∏'  x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity) : type_scope.
Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity).
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Reserved Notation "p @ q" (at level 60, right associativity).
Reserved Notation "! p " (at level 50).

Monomorphic Universe uu.
Monomorphic Universe uu0.
Monomorphic Universe uu1.
Constraint uu0 < uu1.

Global Set Universe Polymorphism.
Global Set Polymorphic Inductive Cumulativity.
Global Unset Universe Minimization ToSet.

Notation UU  := Type (only parsing).
Notation UU0 := Type@{uu0} (only parsing).

Global Set Printing Universes.

 Inductive unit : UU0 := tt : unit.

Inductive paths@{i} {A:Type@{i}} (a:A) : A -> Type@{i} := idpath : paths a a.
Hint Resolve idpath : core .
Notation "a = b" := (paths a b) (at level 70, no associativity) : type_scope.

Set Primitive Projections.
Set Nonrecursive Elimination Schemes.

Record total2@{i} { T: Type@{i} } ( P: T -> Type@{i} ) : Type@{i}
  := tpair { pr1 : T; pr2 : P pr1 }.

Arguments tpair {_} _ _ _.
Arguments pr1 {_ _} _.
Arguments pr2 {_ _} _.

Notation "'∑'  x .. y , P" := (total2 (λ x, .. (total2 (λ y, P)) ..))
  (at level 200, x binder, y binder, right associativity) : type_scope.

Definition foo (X:Type) (xy : @total2 X (λ _, X)) : X.
  induction xy as [x y].
  exact x.
Defined.

Unset Automatic Introduction.

Definition idfun (T : UU) := λ t:T, t.

Definition pathscomp0 {X : UU} {a b c : X} (e1 : a = b) (e2 : b = c) : a = c.
Proof.
  intros. induction e1. exact e2.
Defined.

Hint Resolve @pathscomp0 : pathshints.

Notation "p @ q" := (pathscomp0 p q).

Definition pathsinv0 {X : UU} {a b : X} (e : a = b) : b = a.
Proof.
  intros. induction e. exact (idpath _).
Defined.

Notation "! p " := (pathsinv0 p).

Definition maponpaths {T1 T2 : UU} (f : T1 -> T2) {t1 t2 : T1}
           (e: t1 = t2) : f t1 = f t2.
Proof.
  intros. induction e. exact (idpath _).
Defined.

Definition map_on_two_paths {X Y Z : UU} (f : X -> Y -> Z) {x x' y y'} (ex : x = x') (ey: y = y') :
  f x y = f x' y'.
Proof.
  intros. induction ex. induction ey. exact (idpath _).
Defined.

Definition maponpathscomp0 {X Y : UU} {x1 x2 x3 : X}
           (f : X -> Y) (e1 : x1 = x2) (e2 : x2 = x3) :
  maponpaths f (e1 @ e2) = maponpaths f e1 @ maponpaths f e2.
Proof.
  intros. induction e1. induction e2. exact (idpath _).
Defined.

Definition maponpathsinv0 {X Y : UU} (f : X -> Y)
           {x1 x2 : X} (e : x1 = x2) : maponpaths f (! e) = ! (maponpaths f e).
Proof.
  intros. induction e. exact (idpath _).
Defined.

Definition constr1 {X : UU} (P : X -> UU) {x x' : X} (e : x = x') :
  ∑ (f : P x -> P x'),
  ∑ (ee : ∏ p : P x, tpair _ x p = tpair _ x' (f p)),
  ∏ (pp : P x), maponpaths pr1 (ee pp) = e.
Proof.
  intros. induction e.
  split with (idfun (P x)).
  split with (λ p, idpath _).
  unfold maponpaths. simpl.
  intro. exact (idpath _).
Defined.

Definition transportf@{i} {X : Type@{i}} (P : X -> Type@{i}) {x x' : X}
           (e : x = x') : P x -> P x' := pr1 (constr1 P e).

Lemma two_arg_paths_f@{i} {A : Type@{i}} {B : A -> Type@{i}} {C:Type@{i}} {f : ∏ a, B a -> C} {a1 b1 a2 b2}
      (p : a1 = a2) (q : transportf B p b1 = b2) : f a1 b1 = f a2 b2.
Proof.
  intros. induction p. induction q. exact (idpath _).
Defined.

Definition iscontr@{i} (T:Type@{i}) : Type@{i} := ∑ cntr:T, ∏ t:T, t=cntr.

Lemma proofirrelevancecontr {X : UU} (is : iscontr X) (x x' : X) : x = x'.
Proof.
  intros.
  induction is as [y fe].
  exact (fe x @ !(fe x')).
Defined.

Definition hfiber@{i} {X Y : Type@{i}} (f : X -> Y) (y : Y) : Type@{i} := total2 (λ x, f x = y).

Definition hfiberpair {X Y : UU} (f : X -> Y) {y : Y}
           (x : X) (e : f x = y) : hfiber f y :=
  tpair _ x e.

Definition coconustot (T : UU) (t : T) := ∑ t' : T, t' = t.

Definition coconustotpair (T : UU) {t t' : T} (e: t' = t) : coconustot T t
  := tpair _ t' e.

Lemma connectedcoconustot {T : UU} {t : T} (c1 c2 : coconustot T t) : c1 = c2.
Proof.
  intros.
  induction c1 as [x0 x].
  induction x.
  induction c2 as [x1 y].
  induction y.
  exact (idpath _).
Defined.

Definition isweq@{i} {X Y : Type@{i}} (f : X -> Y) : Type@{i} :=
  ∏ y : Y, iscontr (hfiber f y).

Lemma isProofIrrelevantUnit : ∏ x x' : unit, x = x'.
Proof.
  intros. induction x. induction x'. exact (idpath _).
Defined.

Lemma unitl0 : tt = tt -> coconustot _ tt.
Proof.
  intros e. exact (coconustotpair unit e).
Defined.

Lemma unitl1: coconustot _ tt -> tt = tt.
Proof.
  intro cp. induction cp as [x t]. induction x. exact t.
Defined.

Lemma unitl2: ∏ e : tt = tt, unitl1 (unitl0 e) = e.
Proof.
  intros. unfold unitl0. simpl. exact (idpath _).
Defined.

Lemma unitl3: ∏ e : tt = tt, e = idpath tt.
Proof.
  intros.

  assert (e0 : unitl0 (idpath tt) = unitl0 e).
  { simple refine (connectedcoconustot _ _). }

  set (e1 := maponpaths unitl1 e0).

  exact (! (unitl2 e) @ (! e1) @ (unitl2 (idpath _))).
Defined.

Theorem iscontrpathsinunit (x x' : unit) : iscontr (x = x').
Proof.
  intros.
  split with (isProofIrrelevantUnit x x').
  intros e'.
  induction x.
  induction x'.
  simpl.
  apply unitl3.
Qed.

Lemma ifcontrthenunitl0 (e1 e2 : tt = tt) : e1 = e2.
Proof.
  intros.
  simple refine (proofirrelevancecontr _ _ _).
  exact (iscontrpathsinunit tt tt).
Qed.

Section isweqcontrtounit.

  Universe i.

  (* To see the bug, run it both with and without this constraint: *)

  (* Constraint uu0 < i. *)

  (* Without this constraint, we get i = uu0 in the next definition *)
  Lemma isweqcontrtounit@{} {T : Type@{i}} (is : iscontr@{i} T) : isweq@{i} (λ _:T, tt).
  Proof.
    intros. intro y. induction y.
    induction is as [c h].
    split with (hfiberpair@{i i i} _ c (idpath tt)).
    intros ha.
    induction ha as [x e].
    simple refine (two_arg_paths_f (h x) _).
    simple refine (ifcontrthenunitl0 _ _).
  Defined.

  (*
     Explanation of the bug:

     With the constraint uu0 < i above we get:

            |= uu0 <= bug.3
               uu0 <= i
               uu1 <= i
               i <= bug.3

     from this print statement: *)

         Print isweqcontrtounit.

  (*

     Without the constraint uu0 < i above we get:

            |= i <= bug.3
               uu0 = i

     Since uu0 = i is not inferred when we impose the constraint uu0 < i,
     it is invalid to infer it when we don't.

   *)

  Context (X : Type@{uu1}).

  Check (@isweqcontrtounit X). (* detect a universe inconsistency *)

End isweqcontrtounit.


(*
 * Copyright (c) 2021 BedRock Systems, Inc.
 *
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *
 * This file defines union and disjoint union CMRAs for [coGset A]. It
 * was originally written (and not distributed) in March 2020 by David
 * Swasey:
 *
 *	Copyright (C) 2020 David Swasey
 *
 *	SPDX-License-Identifier: BSD-3-Clause
 *
 * Swasey had derived it from similar constructions for [gset A],
 * which is code original to the Iris project. That original code is
 *
 *	Copyright Iris developers and contributors
 *
 * and used according to the following license.
 *
 *	SPDX-License-Identifier: BSD-3-Clause
 *
 * Original Code:
 * https://gitlab.mpi-sws.org/iris/iris/-/blob/79a110823166f989e622c8cdf1a8d564cc2078fd/iris/algebra/gset.v
 *
 * Original Iris License:
 * https://gitlab.mpi-sws.org/iris/iris/-/blob/79a110823166f989e622c8cdf1a8d564cc2078fd/LICENSE-CODE
 *)
From stdpp Require Export coGset.
From stdpp Require Import countable.
From iris.algebra Require Export cmra.
From iris.algebra Require Import updates local_updates.
From iris.prelude Require Import options.

(** Misplaced: Upstream to [iris.algebra.coGset]? *)

(** * The union CMRA *)
Section coGset.
  Context `{Countable A}.
  Notation C := (coGset A).
  Implicit Types X Y : C.

  Canonical Structure coGsetO := discreteO C.

  Local Instance coGset_valid : Valid C := λ _, True.
  Local Instance coGset_unit : Unit C := (∅ : C).
  Local Instance coGset_op : Op C := union.
  Local Instance coGset_pcore : PCore C := Some.

  Lemma coGset_op_union X Y : X ⋅ Y = X ∪ Y.
  Proof. done. Qed.
  Lemma coGset_core_self X : core X = X.
  Proof. done. Qed.
  Lemma coGset_included X Y : X ≼ Y ↔ X ⊆ Y.
  Proof.
    split.
    - intros [Z ->]. rewrite coGset_op_union. set_solver.
    - intros HY%subseteq_union. exists Y. by rewrite -{1}HY.
  Qed.

  Lemma coGset_ra_mixin : RAMixin C.
  Proof.
    apply ra_total_mixin; eauto.
    - solve_proper.
    - solve_proper.
    - done.
    - intros X1 X2 X3. by rewrite !coGset_op_union assoc.
    - intros X1 X2. by rewrite !coGset_op_union comm.
    - intros X. by rewrite coGset_core_self idemp.
  Qed.
  Canonical Structure coGsetR := discreteR C coGset_ra_mixin.

  Global Instance coGset_cmra_discrete : CmraDiscrete coGsetR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma coGset_ucmra_mixin : UcmraMixin C.
  Proof. split; [done| |done]. intros X. by rewrite coGset_op_union left_id. Qed.
  Canonical Structure coGsetUR := Ucmra C coGset_ucmra_mixin.

  Global Instance coGset_core_id X : CoreId X.
  Proof. apply core_id_total. by rewrite coGset_core_self. Qed.

  Lemma coGset_opM X mY : X ⋅? mY ≡ X ∪ default ∅ mY.
  Proof. destruct mY; by rewrite /= ?right_id. Qed.
  Lemma coGset_opM_L `{!LeibnizEquiv C} X mY : X ⋅? mY = X ∪ default ∅ mY.
  Proof. unfold_leibniz. apply coGset_opM. Qed.

  Lemma coGset_update X Y : X ~~> Y.
  Proof. done. Qed.

  Lemma coGset_local_update X Y X' : X ⊆ X' → (X,Y) ~l~> (X',X').
  Proof.
    intros <-%subseteq_union.
    rewrite local_update_unital_discrete=> Z' _ ->.
    split; [done|]. rewrite !coGset_op_union. set_solver-.
  Qed.

End coGset.

Global Arguments coGsetO _ {_ _} : assert.
Global Arguments coGsetR _ {_ _} : assert.
Global Arguments coGsetUR _ {_ _} : assert.

(** * The disjoint union CMRA *)
Inductive coGset_disj `{Countable A} :=
  | CoGSet (X : coGset A)
  | CoGSetBot.
Global Arguments coGset_disj _ {_ _} : assert.

Definition CoGSet_uninj `{Countable A} (X : coGset_disj A) : coGset A :=
  match X with CoGSet X => X | CoGSetBot => ∅ end.
Global Arguments CoGSet_uninj {_ _ _} !_ / : simpl nomatch, assert.

Global Instance coGset_disj_eq_dec `{Countable A} : EqDecision (coGset_disj A).
Proof. solve_decision. Defined.
Global Instance coGset_disj_countable `{Countable A} : Countable (coGset_disj A).
Proof.
  apply (inj_countable' (λ X, if X is CoGSet X then Some X else None)
    (from_option CoGSet CoGSetBot)). by intros [].
Defined.

Section set_disj.
  Context `{Countable A, Infinite A}.
  Notation C := (coGset A).
  Implicit Types x y : coGset_disj A.
  Implicit Types X Y : coGset A.

  Arguments op _ _ !_ !_ /.
  Arguments cmra_op _ !_ !_ /.
  Arguments ucmra_op _ !_ !_ /.

  Canonical Structure coGset_disjO := leibnizO (coGset_disj A).

  Local Instance coGset_disj_valid : Valid (coGset_disj A) := λ x,
    match x with CoGSet _ => True | CoGSetBot => False end.
  Local Instance coGset_disj_unit : Unit (coGset_disj A) := CoGSet ∅.
  Local Instance coGset_disj_op : Op (coGset_disj A) := λ x y,
    match x, y with
    | CoGSet X, CoGSet Y =>
      if decide (X ## Y) then CoGSet (X ∪ Y) else CoGSetBot
    | _, _ => CoGSetBot
    end.
  Local Instance coGset_disj_pcore : PCore (coGset_disj A) := λ _, Some ε.

  Ltac coGset_disj_solve :=
    repeat (simpl || case_decide);
    first [apply (f_equal CoGSet)|done|exfalso]; set_solver by eauto.

  Lemma coGset_disj_included X Y : CoGSet X ≼ CoGSet Y ↔ X ⊆ Y.
  Proof.
    split.
    - move=>[] [Z|] /=; try case_decide; inversion_clear 1; set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L.
      exists (CoGSet Z). coGset_disj_solve.
  Qed.
  Lemma coGset_disj_valid_inv_l X y :
    ✓ (CoGSet X ⋅ y) → ∃ Y, y = CoGSet Y ∧ X ## Y.
  Proof. destruct y; repeat (simpl || case_decide); by eauto. Qed.
  Lemma coGset_disj_union X Y :
    X ##@{C} Y → CoGSet X ⋅ CoGSet Y = CoGSet (X ∪ Y).
  Proof. intros. by rewrite /= decide_True. Qed.
  Lemma coGset_disj_valid_op X Y : ✓ (CoGSet X ⋅ CoGSet Y) ↔ X ## Y.
  Proof. simpl. case_decide; by split. Qed.
  Lemma coGset_disj_valid_inv x y :
    ✓ (x ⋅ y) → ∃ X Y, x = CoGSet X ∧ y = CoGSet Y ∧ X ## Y.
  Proof. destruct x, y=>//= /coGset_disj_valid_op. eauto. Qed.

  Lemma coGset_disj_ra_mixin : RAMixin (coGset_disj A).
  Proof.
    apply ra_total_mixin; eauto.
    - intros [?|]; destruct 1; coGset_disj_solve.
    - by constructor.
    - by destruct 1.
    - intros [X1|] [X2|] [X3|]; coGset_disj_solve.
    - intros [X1|] [X2|]; coGset_disj_solve.
    - intros [X|]; coGset_disj_solve.
    - exists (CoGSet ∅); coGset_disj_solve.
    - intros [X1|] [X2|]; coGset_disj_solve.
  Qed.
  Canonical Structure coGset_disjR := discreteR (coGset_disj A) coGset_disj_ra_mixin.

  Global Instance coGset_disj_cmra_discrete : CmraDiscrete coGset_disjR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma coGset_disj_ucmra_mixin : UcmraMixin (coGset_disj A).
  Proof. split; try apply _ || done. intros [X|]; coGset_disj_solve. Qed.
  Canonical Structure coGset_disjUR := Ucmra (coGset_disj A) coGset_disj_ucmra_mixin.

  Global Instance coGset_disj_core_id : CoreId (CoGSet (∅ : coGset A)).
  Proof. by rewrite/CoreId /pcore. Qed.

  Local Arguments op _ _ _ _ : simpl never.

  Lemma coGset_disj_alloc_updateP_strong P (Q : coGset_disj A → Prop) X :
    (∀ Y, X ⊆ Y → ∃ j, j ∉ Y ∧ P j) →
    (∀ i, i ∉ X → P i → Q (CoGSet ({[i]} ∪ X))) →
    CoGSet X ~~>: Q.
  Proof.
    intros Hfresh HQ.
    apply cmra_discrete_updateP=> ? /coGset_disj_valid_inv_l [Y [->?]].
    destruct (Hfresh (X ∪ Y)) as (i&?&?); first set_solver.
    exists (CoGSet ({[ i ]} ∪ X)); split.
    - apply HQ; set_solver by eauto.
    - apply coGset_disj_valid_op. set_solver by eauto.
  Qed.
  Lemma coGset_disj_alloc_updateP_strong' P X :
    (∀ Y, X ⊆ Y → ∃ j, j ∉ Y ∧ P j) →
    CoGSet X ~~>: λ y, ∃ i, y = CoGSet ({[ i ]} ∪ X) ∧ i ∉ X ∧ P i.
  Proof. eauto using coGset_disj_alloc_updateP_strong. Qed.

  Lemma coGset_disj_alloc_empty_updateP_strong P (Q : coGset_disj A → Prop) :
    (∀ Y : C, ∃ j, j ∉ Y ∧ P j) →
    (∀ i, P i → Q (CoGSet {[i]})) → CoGSet ∅ ~~>: Q.
  Proof.
    intros. apply (coGset_disj_alloc_updateP_strong P); eauto.
    intros i. rewrite right_id_L. auto.
  Qed.
  Lemma coGset_disj_alloc_empty_updateP_strong' P :
    (∀ Y : C, ∃ j, j ∉ Y ∧ P j) →
    CoGSet ∅ ~~>: λ y, ∃ i, y = CoGSet {[ i ]} ∧ P i.
  Proof. eauto using coGset_disj_alloc_empty_updateP_strong. Qed.

  (** The "fresh updates" section of [iris.algebra.gset] is not sound
      for [coGset]. *)

  Lemma coGset_disj_dealloc_local_update X Y :
    (CoGSet X, CoGSet Y) ~l~> (CoGSet (X ∖ Y), CoGSet ∅).
  Proof.
    apply local_update_total_valid=> _ _ /coGset_disj_included HYX.
    rewrite local_update_unital_discrete=> -[Xf|] _ /leibniz_equiv_iff //=.
    rewrite {1}/op /=. destruct (decide _) as [HXf|]; [intros[= ->]|done].
    by rewrite difference_union_distr_l_L
      difference_diag_L !left_id_L difference_disjoint_L.
  Qed.
  Lemma coGset_disj_dealloc_empty_local_update X Z :
    (CoGSet Z ⋅ CoGSet X, CoGSet Z) ~l~> (CoGSet X, CoGSet ∅).
  Proof.
    apply local_update_total_valid=> /coGset_disj_valid_op HZX _ _.
    assert (X = (Z ∪ X) ∖ Z) as HX by set_solver.
    rewrite coGset_disj_union // {2}HX. apply coGset_disj_dealloc_local_update.
  Qed.
  Lemma coGset_disj_dealloc_op_local_update X Y Z :
    (CoGSet Z ⋅ CoGSet X, CoGSet Z ⋅ CoGSet Y) ~l~> (CoGSet X, CoGSet Y).
  Proof.
    rewrite -{2}(left_id_L ε _ (CoGSet Y)).
    apply op_local_update_frame, coGset_disj_dealloc_empty_local_update.
  Qed.

  Lemma coGset_disj_alloc_op_local_update X Y Z :
    Z ## X →
    (CoGSet X, CoGSet Y) ~l~>
    (CoGSet Z ⋅ CoGSet X, CoGSet Z ⋅ CoGSet Y).
  Proof.
    intros. apply op_local_update_discrete. by rewrite coGset_disj_valid_op.
  Qed.
  Lemma coGset_disj_alloc_local_update X Y Z :
    Z ## X → (CoGSet X, CoGSet Y) ~l~> (CoGSet (Z ∪ X), CoGSet (Z ∪ Y)).
  Proof.
    intros. apply local_update_total_valid=> _ _ /coGset_disj_included ?.
    rewrite -!coGset_disj_union //; last set_solver.
    auto using coGset_disj_alloc_op_local_update.
  Qed.
  Lemma coGset_disj_alloc_empty_local_update X Z :
    Z ## X → (CoGSet X, CoGSet ∅) ~l~> (CoGSet (Z ∪ X), CoGSet Z).
  Proof.
    intros. rewrite -{2}(right_id_L _ union Z).
    by apply coGset_disj_alloc_local_update.
  Qed.

  (** The [CoGSet_uninj] operation *)
  Lemma CoGSet_uninj_op x y :
    ✓ (x ⋅ y) → CoGSet_uninj (x ⋅ y) = CoGSet_uninj x ∪ CoGSet_uninj y.
  Proof.
    intros (?&?&->&->&?)%coGset_disj_valid_inv. by rewrite coGset_disj_union.
  Qed.
End set_disj.

Arguments coGset_disjO _ {_ _} : assert.
Arguments coGset_disjR _ {_ _ _} : assert.
Arguments coGset_disjUR _ {_ _ _} : assert.


(* 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 Export bib.
Require Export autom.
Require Export final.
Require Export List.
Require Export Arith.

(* An efficient way to compute [Etat n p] by a single list *)
(* Addition to FIRING_SQUAD by P. Letouzey, nov 2001 *)

Fixpoint next_line_accum (a : Couleur) (l : list Couleur) {struct l} :
 list Couleur :=
  match l with
  | nil => nil
  | a' :: l' =>
      match l' with
      | nil => Transition a a' G :: nil
      | a'' :: l'' => Transition a a' a'' :: next_line_accum a' l'
      end
  end.

Definition next_line := next_line_accum L.

Fixpoint constant (c : Couleur) (n : nat) {struct n} :
 list Couleur := match n with
                 | O => nil
                 | S n => c :: constant c n
                 end.

(* Don't remove the dummy argument. It is used to protect from evaluation after
   extraction. *)

Definition initial_line (_ : unit) := G :: constant L autom.N.

Fixpoint nth_line (n : nat) : list Couleur :=
  match n with
  | O => initial_line tt
  | S n => next_line (nth_line n)
  end.

Section NTH.

Variable dft : Couleur.

Lemma constant_correct :
 forall (c : Couleur) (n p : nat), p < n -> nth p (constant c n) dft = c.
induction n; simpl; auto.
intros; inversion H.
intro p; case p; clear p; simpl; auto.
intro p; intros; apply IHn; auto with arith.
Qed.

Lemma initial_line_O : nth 0 (initial_line tt) dft = G.
simpl; auto.
Qed.

Lemma initial_line_S :
 forall p : nat, 0 < p -> p <= autom.N -> nth p (initial_line tt) dft = L.
intro p; case p.
intro H; inversion H.
simpl; intros; apply constant_correct; auto with arith.
Qed.

Lemma nth_next_line_accum_O :
 forall (c : Couleur) (l : list Couleur),
 1 < length l ->
 nth 0 (next_line_accum c l) dft = Transition c (nth 0 l dft) (nth 1 l dft).
intros c l; case l.
simpl; intro H; inversion H.
simpl; intros a' l'; case l'.
simpl; intro H; absurd (1 < 1); auto with arith.
simpl; auto.
Qed.

Lemma nth_next_line_accum_fin :
 forall (l : list Couleur) (c : Couleur) (p : nat),
 S (S p) = length l ->
 nth (S p) (next_line_accum c l) dft =
 Transition (nth p l dft) (nth (S p) l dft) G.
simple induction l.
simpl; intros c p H; inversion H.
clear l; intros c l.
case l.
intros; inversion H0.
intros a' l'; case l'.
intros.
inversion H0; auto.
intros.
simpl in H0; inversion H0.
simpl.
simpl in H.
rewrite (H dft (length l0)); auto.
Qed.

Lemma nth_next_line_accum_milieu :
 forall (l : list Couleur) (c : Couleur) (p : nat),
 S (S p) < length l ->
 nth (S p) (next_line_accum c l) dft =
 Transition (nth p l dft) (nth (S p) l dft) (nth (S (S p)) l dft).
simple induction l.
simpl; intros c p H; inversion H.
clear l; intros c l.
case l.
intros; simpl in H0; absurd (S (S p) <= 1); auto with arith.
intros a' l'; case l'.
intros.
simpl in H0; inversion H0; absurd (S (S (S p)) <= 1); auto with arith.
simpl; intros.
generalize H0.
case p; auto.
intros.
rewrite (H dft n); auto with arith.
Qed.

Lemma length_constant :
 forall (p : nat) (c : Couleur), length (constant c p) = p.
induction p; simpl; auto.
Qed.

Lemma length_initial_line : length (initial_line tt) = S autom.N.
simpl.
rewrite length_constant; auto.
Qed.

Lemma length_next_line :
 forall l : list Couleur, length (next_line l) = length l.
simple induction l; unfold next_line; simpl; auto.
intros a' l'; case l'; simpl; auto.
intros a'' l''; case l''; simpl; auto.
Qed.

Lemma length_nth_line : forall n : nat, length (nth_line n) = S autom.N.
induction n.
apply length_initial_line; auto.
simpl.
rewrite length_next_line; auto.
Qed.

Theorem nth_nth_line_is_etat :
 forall n p : nat,
 n <= double autom.N -> p <= autom.N -> nth p (nth_line n) dft = Etat n p.
induction n.
intro p; case p.
simpl; auto.
clear p; intros p H Hp.
rewrite base_L; auto with arith.
apply initial_line_S; auto with arith.
simpl.
intro p; case p; clear p; unfold next_line; intros.
rewrite nth_next_line_accum_O.
rewrite (IHn 0); auto with arith.
rewrite (IHn 1); auto with arith.
apply le_lt_trans with 2; auto; exact necessaire.
rewrite length_nth_line; simpl.
apply lt_n_S.
apply le_lt_trans with 2; auto; exact necessaire.
inversion H0.
rewrite nth_next_line_accum_fin.
rewrite (IHn n0); auto with arith.
rewrite (IHn (S n0)); auto with arith.
rewrite H2.
elim vert_droite.
unfold basic.G_Etat.
intro.
generalize H; case n; intros.
rewrite G0N; auto.
rewrite <- (H1 n1); auto with arith.
apply le_S_n.
rewrite <- S_pred; auto with arith.
unfold double; apply lt_le_trans with autom.N; auto with arith.
apply lt_trans with 2; auto; exact necessaire.
rewrite length_nth_line; simpl; auto.
rewrite nth_next_line_accum_milieu.
rewrite (IHn n0); auto with arith.
rewrite (IHn (S n0)); auto with arith.
rewrite (IHn (S (S n0))); auto with arith.
rewrite <- H1; auto with arith.
rewrite length_nth_line; simpl; auto.
rewrite <- H1; auto with arith.
Qed.

End NTH.

Lemma is_constant :
 forall (dft c : Couleur) (l : list Couleur),
 (forall p : nat, p < length l -> nth p l dft = c) ->
 l = constant c (length l).
induction l; simpl; auto.
intros.
rewrite (H 0); auto with arith.
apply (f_equal2 (A1:=Couleur) (A2:=list Couleur)); auto.
apply IHl.
intros; rewrite <- (H (S p)); auto with arith.
Qed.

Theorem nth_line_2N_is_fire :
 nth_line (double autom.N) = constant F (S autom.N).
cut (length (nth_line (double autom.N)) = S autom.N);
 [ intro Eq | apply length_nth_line; auto ].
rewrite <- Eq.
apply (is_constant L).
rewrite Eq.
intros; rewrite nth_nth_line_is_etat; auto with arith.
elim firing_squad; unfold basic.G_Etat, basic.F_Etat.
intros.
rewrite <- (H0 p); simpl; auto with arith.
Qed.


Require Import Lgen.

Extraction Language Haskell.

Cd "dist".

Extract Inductive sumbool => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Inductive sumor   => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].

Recursive Extraction Library Lgen.


From iris.proofmode Require Import tactics.
From iris.base_logic Require Export base_logic.
From iris.prelude Require Import options.

(* The sections add extra BI assumptions, which is only picked up with [Type*]. *)
Set Default Proof Using "Type*".

(** This file contains an alternative version of basic updates, that is
expression in terms of just the plain modality [■]. *)
Definition bupd_alt `{BiPlainly PROP} (P : PROP) : PROP :=
  (∀ R, (P -∗ ■ R) -∗ ■ R)%I.

(** This definition is stated for any BI with a plain modality. The above
definition is akin to the continuation monad, where one should think of [■ R]
being the final result that one wants to get out of the basic update in the end
of the day (via [bupd_alt (■ P) ⊢ ■ P]).

We show that:

1. [bupd_alt] enjoys the usual rules of the basic update modality.
2. [bupd_alt] entails any other modality that enjoys the laws of a basic update
   modality (see [bupd_bupd_alt]).
3. The ordinary basic update modality [|==>] on [uPred] entails [bupd_alt]
   (see [bupd_alt_bupd]). This result is proven in the model of [uPred].

The first two points are shown for any BI with a plain modality. *)

Local Coercion uPred_holds : uPred >-> Funclass.

Section bupd_alt.
  Context `{BiPlainly PROP}.
  Implicit Types P Q R : PROP.
  Notation bupd_alt := (@bupd_alt PROP _).

  Global Instance bupd_alt_ne : NonExpansive bupd_alt.
  Proof. solve_proper. Qed.
  Global Instance bupd_alt_proper : Proper ((≡) ==> (≡)) bupd_alt.
  Proof. solve_proper. Qed.
  Global Instance bupd_alt_mono' : Proper ((⊢) ==> (⊢)) bupd_alt.
  Proof. solve_proper. Qed.
  Global Instance bupd_alt_flip_mono' : Proper (flip (⊢) ==> flip (⊢)) bupd_alt.
  Proof. solve_proper. Qed.

  (** The laws of the basic update modality hold *)
  Lemma bupd_alt_intro P : P ⊢ bupd_alt P.
  Proof. iIntros "HP" (R) "H". by iApply "H". Qed.
  Lemma bupd_alt_mono P Q : (P ⊢ Q) → bupd_alt P ⊢ bupd_alt Q.
  Proof. by intros ->. Qed.
  Lemma bupd_alt_trans P : bupd_alt (bupd_alt P) ⊢ bupd_alt P.
  Proof. iIntros "HP" (R) "H". iApply "HP". iIntros "HP". by iApply "HP". Qed.
  Lemma bupd_alt_frame_r P Q : bupd_alt P ∗ Q ⊢ bupd_alt (P ∗ Q).
  Proof.
    iIntros "[HP HQ]" (R) "H". iApply "HP". iIntros "HP". iApply ("H" with "[$]").
  Qed.
  Lemma bupd_alt_plainly P : bupd_alt (■ P) ⊢ ■ P.
  Proof. iIntros "H". iApply ("H" $! P with "[]"); auto. Qed.

  (** Any modality conforming with [BiBUpdPlainly] entails the alternative
  definition *)
  Lemma bupd_bupd_alt `{!BiBUpd PROP, BiBUpdPlainly PROP} P : (|==> P) ⊢ bupd_alt P.
  Proof. iIntros "HP" (R) "H". by iMod ("H" with "HP") as "?". Qed.

  (** We get the usual rule for frame preserving updates if we have an [own]
  connective satisfying the following rule w.r.t. interaction with plainly. *)
  Context {M : ucmra} (own : M → PROP).
  Context (own_updateP_plainly : ∀ x Φ R,
    x ~~>: Φ →
    own x ∗ (∀ y, ⌜Φ y⌝ -∗ own y -∗ ■ R) ⊢ ■ R).

  Lemma own_updateP x (Φ : M → Prop) :
    x ~~>: Φ → own x ⊢ bupd_alt (∃ y, ⌜Φ y⌝ ∧ own y).
  Proof.
    iIntros (Hup) "Hx"; iIntros (R) "H".
    iApply (own_updateP_plainly with "[$Hx H]"); first done.
    iIntros (y ?) "Hy". iApply "H"; auto.
  Qed.
End bupd_alt.

(** The alternative definition entails the ordinary basic update *)
Lemma bupd_alt_bupd {M} (P : uPred M) : bupd_alt P ⊢ |==> P.
Proof.
  rewrite /bupd_alt. uPred.unseal; split=> n x Hx H k y ? Hxy.
  unshelve refine (H {| uPred_holds k _ :=
    ∃ x' : M, ✓{k} (x' ⋅ y) ∧ P k x' |} k y _ _ _).
  - intros n1 n2 x1 x2 (z&?&?) _ ?.
    eauto using cmra_validN_le, uPred_mono.
  - done.
  - done.
  - intros k' z ?? HP. exists z. by rewrite (comm op).
Qed.

Lemma bupd_alt_bupd_iff {M} (P : uPred M) : bupd_alt P ⊣⊢ |==> P.
Proof.
  apply (anti_symm _).
  - apply bupd_alt_bupd.
  - apply bupd_bupd_alt.
Qed.

(** The law about the interaction between [uPred_ownM] and plainly holds. *)
Lemma ownM_updateP {M : ucmra} x (Φ : M → Prop) (R : uPred M) :
  x ~~>: Φ →
  uPred_ownM x ∗ (∀ y, ⌜Φ y⌝ -∗ uPred_ownM y -∗ ■ R) ⊢ ■ R.
Proof.
  uPred.unseal=> Hup; split; intros n z Hv (?&z2&?&[z1 ?]&HR); ofe_subst.
  destruct (Hup n (Some (z1 ⋅ z2))) as (y&?&?); simpl in *.
  { by rewrite assoc. }
  refine (HR y n z1 _ _ _ n y _ _ _); auto.
  - rewrite comm. by eapply cmra_validN_op_r.
  - by rewrite (comm _ _ y) (comm _ z2).
  - apply (reflexivity (R:=includedN _)).
Qed.


Ltac induction_last :=
  let v := match goal with
           | |- forall x y, _ = _ -> _ => 1
           | |- forall x y, _ -> _ = _ -> _ => 2
           | |- forall x y, _ -> _ -> _ = _ -> _ => 3
           end in
  induction v.

Goal forall n m : nat, True -> n = m -> m = n.
  induction_last.
  reflexivity.
Qed.


From Hammer Require Import Hammer.

Require Import Recdef.
From compcert Require Import Coqlib.
From compcert Require Import Maps.
From compcert Require Import Errors.

Local Open Scope nat_scope.
Local Open Scope error_monad_scope.

Module Type TYPE_ALGEBRA.

Parameter t: Type.
Parameter eq: forall (x y: t), {x=y} + {x<>y}.
Parameter default: t.

End TYPE_ALGEBRA.

Module UniSolver (T: TYPE_ALGEBRA).

Definition constraint : Type := (positive * positive)%type.

Record typenv : Type := Typenv {
te_typ: PTree.t T.t;
te_equ: list constraint
}.

Definition initial : typenv := {| te_typ := PTree.empty _; te_equ := nil |}.

Definition set (e: typenv) (x: positive) (ty: T.t) : res typenv :=
match e.(te_typ)!x with
| None =>
OK {| te_typ := PTree.set x ty e.(te_typ);
te_equ := e.(te_equ) |}
| Some ty' =>
if T.eq ty ty'
then OK e
else Error (MSG "bad definition/use of variable " :: POS x :: nil)
end.

Fixpoint set_list (e: typenv) (rl: list positive) (tyl: list T.t) {struct rl}: res typenv :=
match rl, tyl with
| nil, nil => OK e
| r1::rs, ty1::tys => do e1 <- set e r1 ty1; set_list e1 rs tys
| _, _ => Error (msg "arity mismatch")
end.

Definition move (e: typenv) (r1 r2: positive) : res (bool * typenv) :=
if peq r1 r2 then OK (false, e) else
match e.(te_typ)!r1, e.(te_typ)!r2 with
| None, None =>
OK (false, {| te_typ := e.(te_typ); te_equ := (r1, r2) :: e.(te_equ) |})
| Some ty1, None =>
OK (true, {| te_typ := PTree.set r2 ty1 e.(te_typ); te_equ := e.(te_equ) |})
| None, Some ty2 =>
OK (true, {| te_typ := PTree.set r1 ty2 e.(te_typ); te_equ := e.(te_equ) |})
| Some ty1, Some ty2 =>
if T.eq ty1 ty2
then OK (false, e)
else Error(MSG "ill-typed move from " :: POS r1 :: MSG " to " :: POS r2 :: nil)
end.

Fixpoint solve_rec (e: typenv) (changed: bool) (q: list constraint) : res (typenv * bool) :=
match q with
| nil =>
OK (e, changed)
| (r1, r2) :: q' =>
do (changed1, e1) <- move e r1 r2; solve_rec e1 (changed || changed1) q'
end.

Lemma move_shape:
forall e r1 r2 changed e',
move e r1 r2 = OK (changed, e') ->
(e'.(te_equ) = e.(te_equ) \/ e'.(te_equ) = (r1, r2) :: e.(te_equ))
/\ (changed = true -> e'.(te_equ) = e.(te_equ)).
Proof. hammer_hook "Unityping" "Unityping.UniSolver.move_shape".
unfold move; intros.
destruct (peq r1 r2). inv H. auto.
destruct e.(te_typ)!r1 as [ty1|]; destruct e.(te_typ)!r2 as [ty2|]; inv H; simpl.
destruct (T.eq ty1 ty2); inv H1. auto.
auto.
auto.
split. auto. intros. discriminate.
Qed.

Lemma length_move:
forall e r1 r2 changed e',
move e r1 r2 = OK (changed, e') ->
length e'.(te_equ) + (if changed then 1 else 0) <= S(length e.(te_equ)).
Proof. hammer_hook "Unityping" "Unityping.UniSolver.length_move".
unfold move; intros.
destruct (peq r1 r2). inv H. omega.
destruct e.(te_typ)!r1 as [ty1|]; destruct e.(te_typ)!r2 as [ty2|]; inv H; simpl.
destruct (T.eq ty1 ty2); inv H1. omega.
omega.
omega.
omega.
Qed.

Lemma length_solve_rec:
forall q e ch e' ch',
solve_rec e ch q = OK (e', ch') ->
length e'.(te_equ) + (if ch' && negb ch then 1 else 0) <= length e.(te_equ) + length q.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.length_solve_rec".
induction q; simpl; intros.
- inv H. replace (ch' && negb ch') with false. omega. destruct ch'; auto.
- destruct a as [r1 r2]; monadInv H. rename x0 into e0. rename x into ch0.
exploit IHq; eauto. intros A.
exploit length_move; eauto. intros B.
set (X := (if ch' && negb (ch || ch0) then 1 else 0)) in *.
set (Y := (if ch0 then 1 else 0)) in *.
set (Z := (if ch' && negb ch then 1 else 0)) in *.
cut (Z <= X + Y). intros. omega.
unfold X, Y, Z. destruct ch'; destruct ch; destruct ch0; simpl; auto.
Qed.

Definition weight_typenv (e: typenv) : nat := length e.(te_equ).

Function solve_constraints (e: typenv) {measure weight_typenv e}: res typenv :=
match solve_rec {| te_typ := e.(te_typ); te_equ := nil |} false e.(te_equ) with
| OK(e', false) => OK e
| OK(e', true)  => solve_constraints e'
| Error msg => Error msg
end.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.weight_typenv".
intros. exploit length_solve_rec; eauto. simpl. intros.
unfold weight_typenv. omega.
Qed.

Definition typassign := positive -> T.t.

Definition makeassign (e: typenv) : typassign :=
fun x => match e.(te_typ)!x with Some ty => ty | None => T.default end.

Definition solve (e: typenv) : res typassign :=
do e' <- solve_constraints e; OK(makeassign e').

Definition satisf (te: typassign) (e: typenv) : Prop :=
(forall x ty, e.(te_typ)!x = Some ty -> te x = ty)
/\ (forall x y, In (x, y) e.(te_equ) -> te x = te y).

Lemma satisf_initial: forall te, satisf te initial.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.satisf_initial".
unfold initial; intros; split; simpl; intros.
rewrite PTree.gempty in H; discriminate.
contradiction.
Qed.

Lemma set_incr:
forall te x ty e e', set e x ty = OK e' -> satisf te e' -> satisf te e.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.set_incr".
unfold set; intros. destruct (te_typ e)!x as [ty'|] eqn:E.
- destruct (T.eq ty ty'); inv H. auto.
- inv H. destruct H0 as [A B]; simpl in *. red; split; intros; auto.
apply A. rewrite PTree.gso by congruence. auto.
Qed.

Hint Resolve set_incr: ty.

Lemma set_sound:
forall te x ty e e', set e x ty = OK e' -> satisf te e' -> te x = ty.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.set_sound".
unfold set; intros. destruct H0 as [P Q].
destruct (te_typ e)!x as [ty'|] eqn:E.
- destruct (T.eq ty ty'); inv H. eauto.
- inv H. simpl in P. apply P. apply PTree.gss.
Qed.

Lemma set_list_incr:
forall te xl tyl e e', set_list e xl tyl = OK e' -> satisf te e' -> satisf te e.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.set_list_incr".
induction xl; destruct tyl; simpl; intros; monadInv H; eauto with ty.
Qed.

Hint Resolve set_list_incr: ty.

Lemma set_list_sound:
forall te xl tyl e e', set_list e xl tyl = OK e' -> satisf te e' -> map te xl = tyl.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.set_list_sound".
induction xl; destruct tyl; simpl; intros; monadInv H.
auto.
f_equal. eapply set_sound; eauto with ty. eauto.
Qed.

Lemma move_incr:
forall te e r1 r2 e' changed,
move e r1 r2 = OK(changed, e') -> satisf te e' -> satisf te e.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.move_incr".
unfold move; intros. destruct H0 as [P Q].
destruct (peq r1 r2). inv H; split; auto.
destruct (te_typ e)!r1 as [ty1|] eqn:E1;
destruct (te_typ e)!r2 as [ty2|] eqn:E2.
- destruct (T.eq ty1 ty2); inv H. split; auto.
- inv H; simpl in *; split; auto. intros. apply P.
rewrite PTree.gso by congruence. auto.
- inv H; simpl in *; split; auto. intros. apply P.
rewrite PTree.gso by congruence. auto.
- inv H; simpl in *; split; auto.
Qed.

Hint Resolve move_incr: ty.

Lemma move_sound:
forall te e r1 r2 e' changed,
move e r1 r2 = OK(changed, e') -> satisf te e' -> te r1 = te r2.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.move_sound".
unfold move; intros. destruct H0 as [P Q].
destruct (peq r1 r2). congruence.
destruct (te_typ e)!r1 as [ty1|] eqn:E1;
destruct (te_typ e)!r2 as [ty2|] eqn:E2.
- destruct (T.eq ty1 ty2); inv H. erewrite ! P by eauto. auto.
- inv H; simpl in *. rewrite (P r1 ty1). rewrite (P r2 ty1). auto.
apply PTree.gss. rewrite PTree.gso by congruence. auto.
- inv H; simpl in *. rewrite (P r1 ty2). rewrite (P r2 ty2). auto.
rewrite PTree.gso by congruence. auto. apply PTree.gss.
- inv H; simpl in *. apply Q; auto.
Qed.

Lemma solve_rec_incr:
forall te q e changed e' changed',
solve_rec e changed q = OK(e', changed') -> satisf te e' -> satisf te e.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.solve_rec_incr".
induction q; simpl; intros.
- inv H. auto.
- destruct a as [r1 r2]; monadInv H. eauto with ty.
Qed.

Lemma solve_rec_sound:
forall te r1 r2 q e changed e' changed',
solve_rec e changed q = OK(e', changed') -> In (r1, r2) q -> satisf te e' ->
te r1 = te r2.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.solve_rec_sound".
induction q; simpl; intros.
- contradiction.
- destruct a as [r3 r4]; monadInv H. destruct H0.
+ inv H. eapply move_sound; eauto. eapply solve_rec_incr; eauto.
+ eapply IHq; eauto with ty.
Qed.

Lemma move_false:
forall e r1 r2 e',
move e r1 r2 = OK(false, e') ->
te_typ e' = te_typ e /\ makeassign e r1 = makeassign e r2.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.move_false".
unfold move; intros.
destruct (peq r1 r2). inv H. split; auto.
unfold makeassign;
destruct (te_typ e)!r1 as [ty1|] eqn:E1;
destruct (te_typ e)!r2 as [ty2|] eqn:E2.
- destruct (T.eq ty1 ty2); inv H. auto.
- discriminate.
- discriminate.
- inv H. split; auto.
Qed.

Lemma solve_rec_false:
forall r1 r2 q e changed e',
solve_rec e changed q = OK(e', false) ->
changed = false /\
(In (r1, r2) q -> makeassign e r1 = makeassign e r2).
Proof. hammer_hook "Unityping" "Unityping.UniSolver.solve_rec_false".
induction q; simpl; intros.
- inv H. tauto.
- destruct a as [r3 r4]; monadInv H.
exploit IHq; eauto. intros [P Q].
destruct changed; try discriminate. destruct x; try discriminate.
exploit move_false; eauto. intros [U V].
split. auto. intros [A|A]. inv A. auto. exploit Q; auto.
unfold makeassign; rewrite U; auto.
Qed.

Lemma solve_constraints_incr:
forall te e e', solve_constraints e = OK e' -> satisf te e' -> satisf te e.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.solve_constraints_incr".
intros te e; functional induction (solve_constraints e); intros.
- inv H. auto.
- exploit solve_rec_incr; eauto. intros [A B].
split; auto. intros; eapply solve_rec_sound; eauto.
- discriminate.
Qed.

Lemma solve_constraints_sound:
forall e e', solve_constraints e = OK e' -> satisf (makeassign e') e'.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.solve_constraints_sound".
intros e0; functional induction (solve_constraints e0); intros.
- inv H. split; intros.
unfold makeassign; rewrite H. split; auto with ty.
exploit solve_rec_false. eauto. intros [A B]. eapply B; eauto.
- eauto.
- discriminate.
Qed.

Theorem solve_sound:
forall e te, solve e = OK te -> satisf te e.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.solve_sound".
unfold solve; intros. monadInv H.
eapply solve_constraints_incr. eauto. eapply solve_constraints_sound; eauto.
Qed.

Lemma set_complete:
forall te e x ty,
satisf te e -> te x = ty -> exists e', set e x ty = OK e' /\ satisf te e'.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.set_complete".
unfold set; intros. generalize H; intros [P Q].
destruct (te_typ e)!x as [ty1|] eqn:E.
- replace ty1 with ty. rewrite dec_eq_true. exists e; auto.
exploit P; eauto. congruence.
- econstructor; split; eauto. split; simpl; intros; auto.
rewrite PTree.gsspec in H1. destruct (peq x0 x). congruence. eauto.
Qed.

Lemma set_list_complete:
forall te xl tyl e,
satisf te e -> map te xl = tyl ->
exists e', set_list e xl tyl = OK e' /\ satisf te e'.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.set_list_complete".
induction xl; intros; inv H0; simpl.
econstructor; eauto.
exploit (set_complete te e a (te a)); auto. intros (e1 & P & Q).
exploit (IHxl (map te xl) e1); auto. intros (e2 & U & V).
exists e2; split; auto. rewrite P; auto.
Qed.

Lemma move_complete:
forall te e r1 r2,
satisf te e -> te r1 = te r2 ->
exists changed e', move e r1 r2 = OK(changed, e') /\ satisf te e'.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.move_complete".
unfold move; intros. elim H; intros P Q.
assert (Q': forall x y, In (x, y) ((r1, r2) :: te_equ e) -> te x = te y).
{ intros. destruct H1; auto. congruence. }
destruct (peq r1 r2). econstructor; econstructor; eauto.
destruct (te_typ e)!r1 as [ty1|] eqn:E1;
destruct (te_typ e)!r2 as [ty2|] eqn:E2.
- replace ty2 with ty1. rewrite dec_eq_true. econstructor; econstructor; eauto.
exploit (P r1); eauto. exploit (P r2); eauto. congruence.
- econstructor; econstructor; split; eauto.
split; simpl; intros; auto. rewrite PTree.gsspec in H1. destruct (peq x r2).
inv H1. rewrite <- H0. eauto.
eauto.
- econstructor; econstructor; split; eauto.
split; simpl; intros; auto. rewrite PTree.gsspec in H1. destruct (peq x r1).
inv H1. rewrite H0. eauto.
eauto.
- econstructor; econstructor; split; eauto.
split; eauto.
Qed.

Lemma solve_rec_complete:
forall te q e changed,
satisf te e ->
(forall r1 r2, In (r1, r2) q -> te r1 = te r2) ->
exists e' changed', solve_rec e changed q = OK(e', changed') /\ satisf te e'.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.solve_rec_complete".
induction q; simpl; intros.
- econstructor; econstructor; eauto.
- destruct a as [r1 r2].
exploit (move_complete te e r1 r2); auto. intros (changed1 & e1 & A & B).
exploit (IHq e1 (changed || changed1)); auto. intros (e' & changed' & C & D).
exists e'; exists changed'. rewrite A; simpl; rewrite C; auto.
Qed.

Lemma solve_constraints_complete:
forall te e, satisf te e -> exists e', solve_constraints e = OK e' /\ satisf te e'.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.solve_constraints_complete".
intros te e. functional induction (solve_constraints e); intros.
- exists e; auto.
- exploit (solve_rec_complete te (te_equ e) {| te_typ := te_typ e; te_equ := nil |} false).
destruct H; split; auto. simpl; tauto.
destruct H; auto.
intros (e1 & changed1 & P & Q).
apply IHr. congruence.
- exploit (solve_rec_complete te (te_equ e) {| te_typ := te_typ e; te_equ := nil |} false).
destruct H; split; auto. simpl; tauto.
destruct H; auto.
intros (e1 & changed1 & P & Q).
congruence.
Qed.

Lemma solve_complete:
forall te e, satisf te e -> exists te', solve e = OK te'.
Proof. hammer_hook "Unityping" "Unityping.UniSolver.solve_complete".
intros. unfold solve.
destruct (solve_constraints_complete te e H) as (e' & P & Q).
econstructor. rewrite P. simpl. eauto.
Qed.

End UniSolver.


Require Import Arith.

Inductive list (A : Type) : Type :=
| nil : list A
| cons : A -> list A -> list A.

Arguments nil {A}.
Arguments cons {A} _ _.

Notation "[]" := nil.
Notation "x :: y" := (cons x y) (at level 60, right associativity).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(** Rozkład na kawałki od początku *)
Parameter head : forall A : Type, list A -> option A.
Parameter tail : forall A : Type, list A -> option (list A).
Parameter uncons : forall A : Type, list A -> option (A * list A).

(** Proste obserwatory *)
Parameter null : forall A : Type, list A -> bool.
Parameter len : forall A : Type, list A -> nat.

(** Proste funkcje *)
Parameter snoc : forall A : Type, list A -> A -> list A.
Parameter rev : forall A : Type, list A -> list A.
Parameter app : forall A : Type, list A -> list A -> list A.

Parameter revapp : forall A : Type, list A -> list A -> list A.

(** Rozkład na kawałki od końca *)
Parameter last : forall A : Type, list A -> option A.
Parameter init : forall A : Type, list A -> option (list A).
Parameter unsnoc : forall A : Type, list A -> option (A * list A).

(** Operacje funktorowe, aplikatywne i monadyczne (+ zip) *)
Parameter map : forall A B : Type, (A -> B) -> list A -> list B.
Parameter pmap :
  forall A B : Type, (A -> option B) -> list A -> list B.

Parameter zip : forall A B : Type, list A -> list B -> list (A * B).
Parameter unzip : forall A B : Type, list (A * B) -> list A * list B.

Parameter zipWith :
  forall A B C : Type, (A -> B -> C) -> list A -> list B -> list C.
Parameter unzipWith :
  forall A B C : Type, (A -> B * C) -> list A -> list B * list C.

Parameter join : forall A : Type, list (list A) -> list A.

(* Raczej olać. *)
Parameter bind : forall A B : Type, (A -> list B) -> list A -> list B.

Parameter unzis : forall A B : Type, list (A + B) -> list A * list B.

(** Powtarzanie *)
Parameter replicate : forall A : Type, nat -> A -> list A.
Parameter iterate : forall A : Type, (A -> A) -> nat -> A -> list A.

(** Rozkład na kawałki *)
Parameter nth : forall A : Type, list A -> nat -> option A.
Parameter take : forall A : Type, list A -> nat -> list A.
Parameter drop : forall A : Type, list A -> nat -> list A.
Parameter splitAt :
  forall A : Type, list A -> nat -> option (list A * A * list A).

(** Modyfikacje *)
Parameter insert : forall A : Type, list A -> nat -> A -> list A.
Parameter replace : forall A : Type, list A -> nat -> A -> option (list A).

(** Pochodne rozkładu na kawałki i jak powinno być*)
Parameter remove : forall A : Type, nat -> list A -> option (A * list A).
Parameter remove' : forall A : Type, nat -> list A -> option (list A).
Parameter remove'' : forall A : Type, nat -> list A -> list A.

(** Funkcje z predykatem boolowskim *)
Parameter any : forall A : Type, (A -> bool) -> list A -> bool.
Parameter all : forall A : Type, (A -> bool) -> list A -> bool.
Parameter count : forall A : Type, (A -> bool) -> list A -> nat.
Parameter filter : forall A : Type, (A -> bool) -> list A -> list A.
Parameter partition :
  forall A : Type, (A -> bool) -> list A -> list A * list A.

(** Rozkład na kawałki według predykatu *)
Parameter find : forall A : Type, (A -> bool) -> list A -> option A.
Parameter takeWhile : forall A : Type, (A -> bool) -> list A -> list A.
Parameter dropWhile : forall A : Type, (A -> bool) -> list A -> list A.
Parameter span :
  forall A : Type, (A -> bool) -> list A -> option (list A * A * list A).

(** Pochodne rozkładu na kawałki według predykatu *)
Parameter removeFirst :
  forall A : Type, (A -> bool) -> list A -> option (A * list A).
Parameter removeFirst' :
  forall A : Type, (A -> bool) -> list A -> list A.

(** Rozkład na kawałki według predykatu od końca *)
Parameter findLast : forall A : Type, (A -> bool) -> list A -> option A.
Parameter removeLast :
  forall A : Type, (A -> bool) -> list A -> option (A * list A).
Parameter decomposeLast :
  forall A : Type, (A -> bool) -> list A -> option (list A * A * list A).

(** Znajdowanie indeksów *)
Parameter findIndex :
  forall A : Type, (A -> bool) -> list A -> option nat.

Parameter findIndices :
  forall A : Type, (A -> bool) -> list A -> list nat.

(** Zwijanie i sumy częściowe *)
Parameter foldr : forall A B : Type, (A -> B -> B) -> B -> list A -> B.
Parameter foldl : forall A B : Type, (A -> B -> A) -> A -> list B -> A.

Parameter scanl : forall A B : Type, (A -> B -> A) -> A -> list B -> list A.
Parameter scanl1 : forall A : Type, (A -> A -> A) -> list A -> list A.

Parameter scanr : forall A B : Type, (A -> B -> B) -> B -> list A -> list B.
Parameter scanr1 : forall A : Type, (A -> A -> A) -> list A -> list A.

(** Bardziej skomplikowane funkcje *)
Parameter intersperse : forall A : Type, A -> list A -> list A.
Parameter splitBy :
  forall A : Type, (A -> bool) -> list A -> list (list A).
Parameter groupBy :
  forall A : Type, (A -> A -> bool) -> list A -> list (list A).

(** Predykat bycia elementem i jego pochodne *)
Parameter Elem : forall A : Type, A -> list A -> Prop.
Parameter In : forall A : Type, A -> list A -> Prop.

Parameter NoDup : forall A : Type, list A -> Prop.
Parameter Dup : forall A : Type, list A -> Prop.

Parameter Rep : forall A : Type, A -> nat -> list A -> Prop.

Parameter Exists : forall A : Type, (A -> Prop) -> list A -> Prop.
Parameter Forall : forall A : Type, (A -> Prop) -> list A -> Prop.

Parameter AtLeast : forall A : Type, (A -> Prop) -> nat -> list A -> Prop.
Parameter Exactly : forall A : Type, (A -> Prop) -> nat -> list A -> Prop.
Parameter AtMost  : forall A : Type, (A -> Prop) -> nat -> list A -> Prop.

(** Listy jako termy *)
Parameter Sublist : forall A : Type, list A -> list A -> Prop.

(** Prefiksy i sufiksy *)
Parameter Prefix : forall A : Type, list A -> list A -> Prop.
Parameter Suffix : forall A : Type, list A -> list A -> Prop.

(** Listy jako ciągi, zbiory, multizbiory i cykle *)
Parameter Subseq : forall A : Type, list A -> list A -> Prop.

Parameter Incl : forall A : Type, list A -> list A -> Prop.
Parameter SetEquiv : forall A : Type, list A -> list A -> Prop.

Parameter Permutation : forall A : Type, list A -> list A -> Prop.
Parameter perm : forall (A : Type) (p : A -> bool), list A -> list A -> Prop.

Parameter Cycle : forall A : Type, list A -> list A -> Prop.

(** Palindromy *)
Parameter Palindrome : forall A : Type, list A -> Prop.


(* This file contains some definitions of what it can mean for functions
between different spaces to be computable. *)
From mathcomp Require Import all_ssreflect.
Require Import core_mf core_cont core_inseg.
Require Import FunctionalExtensionality ClassicalChoice Psatz.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section ORACLE_MACHINES.
Context (A A' Q Q': Type) (C: countType).
Notation B := (Q -> A).
Notation B' := (Q' -> A').
Notation "B o~> B'" := (C -> B -> Q' -> option A') (at level 2).

Definition oeval (M: B o~> B') phi Mphi :=
	forall q', exists c, M c phi q' = some (Mphi q').

Notation "M '\computes' F" := ((oeval M) \tightens F) (at level 2).

Definition is_cmpt_op (F: B ->> B') :=
	{M| M \computes F}.
Notation "F '\is_computable_operator'" := (is_cmpt_op F) (at level 2).

Definition is_rec_op (F: B ->> B') :=
	{M | M \is_choice_for F}.
Notation "F '\is_recursive_operator'" := (is_rec_op F) (at level 2).

Lemma rec_F2MF_op (F: B -> B') (somec: C):
	(fun n phi q => Some(F phi q)) \computes (F2MF F).
Proof.
move => phi _.
split => [ | Fphi ev].
	by exists (F phi) => q'; exists somec.
apply functional_extensionality => q'.
have [c val]:= ev q'.
by apply Some_inj.
Qed.

Lemma prec_cmpt_op (F: B ->> B') (somec: C):
	F \is_recursive_operator -> F \is_computable_operator.
Proof.
case => M Mprop; exists (fun n phi q => Some (M phi q)).
abstract by apply/ tight_trans; [apply rec_F2MF_op | apply icf_F2MF_tight].
Defined.

Definition is_mon_omac (M: B o~> B):=
	forall c c' phi q' a', pickle c <= pickle c' -> M c phi q' = Some a' -> M c' phi q' = Some a'.
Notation "M '\is_monotone_oracle_machine'" := (is_mon_omac M) (at level 2).

Lemma eq_mon M c c' phi q' a' b': M c phi q' = Some a' -> M c' phi q' = Some b' ->
	M \is_monotone_oracle_machine -> a' = b'.
Proof.
case/orP: (leq_total (pickle c) (pickle c')) => ineq eq eq' mon; apply /Some_inj.
	by rewrite -(mon c c' phi q' a' ineq) => //.
by apply esym; rewrite -(mon c' c phi q' b' ineq) => //.
Qed.

Lemma mon_sing_op (M: B o~> B):
	M \is_monotone_oracle_machine -> (oeval M) \is_single_valued.
Proof.
move => mon phi Fphi Fphi' ev ev'; apply functional_extensionality => q'.
by move: (ev q') (ev' q') => [n val] [n' val']; apply /(eq_mon val val').
Qed.

Definition mon_cmpt (M: B o~> B') (F: B ->> B'):=
	forall phi Fphi, F phi Fphi -> (oeval M) phi Fphi.
Notation "M '\monotone_computes' F" := (mon_cmpt M F) (at level 2).

Lemma cmpt_mon_sing_op M F: M \is_monotone_oracle_machine -> F \is_single_valued ->
	(M \monotone_computes F <-> M \computes F).
Proof.
split => [comp phi [] | comp phi]; intros; first (split; first by exists x; apply/ comp).
	by move => y val; have <-: x = y by apply/ mon_sing_op => //; last by apply/ comp.
have [ | [Mphi MphiMphi] prop] := (comp phi _); first by exists Fphi.
by have ->: Fphi = Mphi by apply/ H0; [ | apply prop].
Qed.

Lemma mon_cmpt_op M F:
	M \is_monotone_oracle_machine -> M \computes (F2MF F) <-> forall phi, (oeval M) phi (F phi).
Proof.
split => [comp phi q' | prop]; last first.
	apply cmpt_mon_sing_op => //; first exact: F2MF_sing; move => phi Fphi eq q'.
	by have [c val]:= (prop phi q'); exists c; rewrite -eq.
have [ | [Mphi evl] prop]:= (comp phi _); first by exists (F phi).
have [c val] := (evl q'); exists c; rewrite val.
by have ->: Mphi = (F phi) by rewrite (prop Mphi).
Qed.

Definition is_mon_cmpt (F: B ->> B'):=
	{M | M \is_monotone_oracle_machine /\ M \computes F}.
Notation "F '\is_monotone_computable'" := (is_mon_cmpt F) (at level 2).

Lemma sing_cmpt_elt M F c phi Fphi q' a':	M \computes F -> F \is_single_valued ->
	F phi Fphi -> M c phi q' = Some a' -> a' = Fphi q'.
Proof.
move => comp sing FphiFphi ev.
have [ | [Mphi MphiFphi] prop]:= (comp phi _); first by exists Fphi.
have eq: Mphi = Fphi by rewrite -(sing phi Fphi Mphi); last apply prop.
move: Mphi eq MphiFphi => _ -> MphiFphi.
pose Nphi q a:= (q <> q' /\ Fphi q = a) \/ (q' = q /\ a' = a).
have Nphitot: Nphi \is_total => [q | ].
	by case: (classic (q = q')) => ass; [exists a'; right | exists (Fphi q); left].
have [Mphi Mphiprop]:= choice Nphi Nphitot.
have MphiMphi: (oeval M) phi Mphi => [q | ].
	by case: (Mphiprop q) => [[_ <-] | [<- <-]]; [ | exists c].
apply Some_inj; case: (Mphiprop q') => [[ctr] | [_ ->]] //.
by have <-: Mphi = Fphi by apply/ sing; apply prop.
Qed.

Lemma cmpt_sing_mon_op F: F \is_single_valued ->
	F \is_computable_operator -> F \is_monotone_computable.
Proof.
move => sing [M comp].
pose p (c: C) phi q n:= if n < (pickle c) then
match (pickle_inv C n) with
	| None => false
	| Some c' => match M c' phi q with
		| None => false
		| Some a => true
	end
end else true.
have pprop: forall c phi q' n, p c phi q' n -> n < pickle c -> exists (c': C), pickle c' = n.
	move => c phi q' n; rewrite /p; case: ifP => //.
	case E: (pickle_inv C n) => [c' | ] ineq => //.
	by case: (M c' phi q') => //; exists c'; rewrite -(pickle_invK C n) E.
pose r (c: C) phi q':= search (p c phi q') (pickle c).
have rprop: forall c phi q', exists (c': C), pickle c' = r c phi q' => [c phi q' | ].
	case E: (r c phi q' == pickle c); first by exists c; apply /esym/eqP; rewrite E.
	have ineq: r c phi q' < pickle c.
		by rewrite ltn_neqAle; apply /andP; split; [rewrite E | apply/search_le].
	by apply/(pprop c _ q') => //; apply search_correct; rewrite /p pickleK_inv (ltnn (pickle c)).
pose N c phi q:= match (pickle_inv C (r c phi q)) with
	| None => None
	| Some c' =>  M c' phi q
end; exists N.
have mon: N \is_monotone_oracle_machine.
	move => n m phi q' a' ineq evl.
	case E: (pickle n < pickle m)%N.
		have[c rneqc]:= rprop n phi q'.
		have[c' rmeqc']:= rprop m phi q'.
		rewrite /N -rneqc pickleK_inv in evl.
		have rmlrn: r m phi q' <= r n phi q'.
			by apply/search_min; rewrite /p -rneqc pickleK_inv evl; case: ifP.
		suffices rnlrm: r n phi q' <= r m phi q'.
			have /eqP eq: r m phi q' == r n phi q' by rewrite eqn_leq; apply /andP.
			by rewrite /N eq -rneqc pickleK_inv.
		apply/search_min; rewrite /p -rmeqc' pickleK_inv; case: ifP => // ha.
		have: (p m phi q' (r m phi q')).
			by rewrite search_correct => //; rewrite /p; case: ifP => //; rewrite (ltnn (pickle m)).
		rewrite /p -rmeqc' pickleK_inv; case: ifP => [ | <- _]; case: (M c' phi q') => //.
		by apply/leq_trans; first apply/ ha; apply/leq_trans; [apply: ineq | apply/ leqnn].
	have ineq': pickle m <= pickle n by rewrite leqNgt E.
	rewrite -evl; f_equal; apply Some_inj; rewrite -!pickleK_inv; f_equal.
	by apply/eqP; rewrite eqn_leq; apply /andP.
split => //; rewrite -cmpt_mon_sing_op => // phi Fphi FphiFphi q'.
have phifd: phi \from_dom F by exists Fphi.
have [[Mphi MphiMphi] prop]:= comp phi phifd.
have [c val]:= MphiMphi q'.
have pqrc: p c phi q' (r c phi q').
	apply search_correct; rewrite /p.
	by case: ifP => // _; rewrite pickleK_inv val.
have [c' uprcq]:= rprop c phi q'.
rewrite /p -uprcq in pqrc.
case E: (pickle c' < pickle c)%N pqrc.
	rewrite pickleK_inv.
	case E': (M c' phi q') => // _.
	exists c; rewrite /N -uprcq pickleK_inv.
	by rewrite -(sing_cmpt_elt comp sing FphiFphi E').
move => _.
have eq: c' = c.
	suffices eq: pickle c' = pickle c by apply Some_inj; rewrite -!pickleK_inv -eq.
	have ineq: pickle c' <= pickle c by rewrite uprcq; apply/search_le.
	by apply/eqP; rewrite eqn_leq; apply/andP; split => //; rewrite leqNgt E.
exists c; rewrite /N -uprcq pickleK_inv eq (sing phi Fphi Mphi) => //.
by apply prop.
Qed.

Lemma mon_sing_cmpt_op (F: B ->> B'):
	F \is_single_valued -> F \is_computable_operator -> F \is_monotone_computable.
Proof.
by move => sing cmpt; apply/ cmpt_sing_mon_op.
Qed.

End ORACLE_MACHINES.
Notation eval M := (@oeval _ _ _ _ nat_countType M).
Notation "M '\ocomputes' F" := ((oeval M) \tightens F) (at level 2).
Notation "F '\is_computable_operator'" := (is_cmpt_op F) (at level 2).
Notation "F '\is_recursive_operator'" := (is_rec_op F) (at level 2).
Notation "M '\is_monotone_oracle_machine'" := (is_mon_omac M) (at level 2).
Notation "M '\monotone_computes' F" := (mon_cmpt M F) (at level 2).
Notation "F '\is_monotone_computable'" := (@is_mon_cmpt _ _ _ _ nat_countType F) (at level 2).
Notation "f '\is_computable_operator'" := (is_cmpt_op nat_countType f) (at level 2).


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.X25519.C64.CurveParameters.

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

Module Export S := PackageSynthesis P.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Strong.
Require Export Category.Structure.Monoidal.
Require Export Category.Functor.Structure.Monoidal.

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

Section MonoidalFunctors.

Context {C : Category}.
Context `{@Monoidal C}.
Context {D : Category}.
Context `{@Monoidal D}.
Context {G : C ⟶ D}.

Context {E : Category}.
Context `{@Monoidal E}.
Context {F : D ⟶ E}.

Local Obligation Tactic := program_simpl.

Global Program Instance Id_MonoidalFunctor :
  @MonoidalFunctor C C _ _ Id[C] := {
  pure_iso := iso_id;
  ap_functor_iso := {| to   := {| transform := fun _ => _ |}
                     ; from := {| transform := fun _ => _ |} |}
}.
Next Obligation.
  simpl; intros.
  destruct H0; simpl.
  exact id.
Defined.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation.
  simpl; intros.
  destruct H1; simpl.
  exact id.
Defined.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. cat. Qed.
Next Obligation. cat. Qed.
Next Obligation. apply tensor_assoc. Qed.
Next Obligation. rewrite bimap_id_id; cat. Qed.
Next Obligation. rewrite bimap_id_id; cat. Qed.
Next Obligation. rewrite !bimap_id_id; cat. Qed.

Global Program Instance Id_LaxMonoidalFunctor :
  @LaxMonoidalFunctor C C _ _ Id[C] := {
  lax_pure := id;
  ap_functor_nat := {| transform := fun _ => _ |}
}.
Next Obligation.
  simpl; intros.
  destruct H0; simpl.
  exact id.
Defined.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. apply tensor_assoc. Qed.
Next Obligation. rewrite bimap_id_id; cat. Qed.
Next Obligation. rewrite bimap_id_id; cat. Qed.
Next Obligation. rewrite !bimap_id_id; cat. Qed.

End MonoidalFunctors.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Every parse tree has a corresponding minimal parse tree *)

Require Import Coq.ZArith.ZArith.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Properties.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.Reachable.MaybeEmpty.Core.
Require Import Fiat.Parsers.Reachable.MaybeEmpty.Minimal.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.Reachable.MaybeEmpty.MinimalOfCore.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char}.
  Context {predata : @parser_computational_predataT Char}
          {rdata' : @parser_removal_dataT' _ G predata}.

  Definition parse_empty_maybe_empty_parse_of_item'
             (parse_empty_maybe_empty_parse_of_productions
              : forall valid0 pats
                       (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
                       (str : String) (Hlen : length str = 0) (p : parse_of G str pats)
                       (Hforall : Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p),
                  maybe_empty_productions G valid0 pats)
             {valid0 it}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0) (p : parse_of_item G str it)
             (Hforall : Forall_parse_of_item (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : maybe_empty_item G valid0 it.
  Proof.
    destruct p as [ | nt ? p ].
    { exfalso.
      erewrite length_singleton in Hlen by eassumption; omega. }
    { specialize (parse_empty_maybe_empty_parse_of_productions valid0 (G nt) Hsub str Hlen p (snd Hforall)).
      constructor; simpl in *; [ exact (fst Hforall) | assumption ]. }
  Defined.

  Fixpoint parse_empty_maybe_empty_parse_of_productions
             {valid0 pats}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0) (p : parse_of G str pats)
             (Hforall : Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
             {struct p}
  : maybe_empty_productions G valid0 pats
  with parse_empty_maybe_empty_parse_of_production
         {valid0 pat}
         (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
         (str : String) (Hlen : length str = 0) (p : parse_of_production G str pat)
         (Hforall : Forall_parse_of_production (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
         {struct p}
       : maybe_empty_production G valid0 pat.
  Proof.
    { destruct p as [ ?? p | ?? p ]; simpl in *.
      { pose proof (parse_empty_maybe_empty_parse_of_production valid0 _ Hsub _ Hlen p Hforall).
        left; assumption. }
      { pose proof (parse_empty_maybe_empty_parse_of_productions valid0 _ Hsub _ Hlen p Hforall).
        right; assumption. } }
    { destruct p as [ | ?? p ]; simpl in *.
      { constructor. }
      { constructor.
        { apply (fun k => @parse_empty_maybe_empty_parse_of_item' parse_empty_maybe_empty_parse_of_productions valid0 _ Hsub _ k _ (fst Hforall)).
          rewrite take_length, Hlen, Min.min_0_r; reflexivity. }
        { apply (fun k => @parse_empty_maybe_empty_parse_of_production valid0 _ Hsub _ k _ (snd Hforall)).
          rewrite drop_length, Hlen; reflexivity. } } }
  Defined.

  Definition parse_empty_maybe_empty_parse_of_item
             {valid0 it}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0) (p : parse_of_item G str it)
             (Hforall : Forall_parse_of_item (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : maybe_empty_item G valid0 it
    := @parse_empty_maybe_empty_parse_of_item' (@parse_empty_maybe_empty_parse_of_productions) valid0 it Hsub str Hlen p Hforall.

  Definition parse_empty_minimal_maybe_empty_parse_of_item
             {valid0 it}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0) (p : parse_of_item G str it)
             (Hforall : Forall_parse_of_item (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : minimal_maybe_empty_item (G := G) valid0 it.
  Proof.
    eapply minimal_maybe_empty_item__of__maybe_empty_item; try assumption.
    eapply parse_empty_maybe_empty_parse_of_item; eassumption.
  Qed.

  Definition parse_empty_minimal_maybe_empty_parse_of_production
             {valid0 pat}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0) (p : parse_of_production G str pat)
             (Hforall : Forall_parse_of_production (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : minimal_maybe_empty_production (G := G) valid0 pat.
  Proof.
    eapply minimal_maybe_empty_production__of__maybe_empty_production; try assumption.
    eapply parse_empty_maybe_empty_parse_of_production; eassumption.
  Qed.

  Definition parse_empty_minimal_maybe_empty_parse_of_productions
             {valid0 pats}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0) (p : parse_of G str pats)
             (Hforall : Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : minimal_maybe_empty_productions (G := G) valid0 pats.
  Proof.
    eapply minimal_maybe_empty_productions__of__maybe_empty_productions; try assumption.
    eapply parse_empty_maybe_empty_parse_of_productions; eassumption.
  Qed.

  Definition parse_empty_from_maybe_empty_parse_of_item'
             (parse_empty_from_maybe_empty_parse_of_productions
              : forall valid0 pats
                       (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
                       (str : String) (Hlen : length str = 0),
                  maybe_empty_productions G valid0 pats
                  -> { p : parse_of G str pats
                           & Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p })
             {valid0 it}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0)
             (p : maybe_empty_item G valid0 it)
  : { p : parse_of_item G str it
          & Forall_parse_of_item (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p }.
  Proof.
    destruct p as [ nt H p ].
    eapply parse_empty_from_maybe_empty_parse_of_productions in p; [ | eassumption.. ].
    eexists (ParseNonTerminal _ _ (projT1 p)).
    exact (H, projT2 p).
    Unshelve.
    apply initial_nonterminals_correct, Hsub; assumption.
  Defined.

  Fixpoint parse_empty_from_maybe_empty_parse_of_productions
             {valid0 pats}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0)
             (p : maybe_empty_productions G valid0 pats)
             {struct p}
  : { p : parse_of G str pats
          & Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p }
  with parse_empty_from_maybe_empty_parse_of_production
         {valid0 pat}
         (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
         (str : String) (Hlen : length str = 0)
         (p: maybe_empty_production G valid0 pat)
         {struct p}
       : { p : parse_of_production G str pat
               & Forall_parse_of_production (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p }.
  Proof.
    { destruct p as [ ?? p | ?? p ]; simpl in *.
      { pose proof (parse_empty_from_maybe_empty_parse_of_production valid0 _ Hsub _ Hlen p) as p'.
        eexists (ParseHead _ (projT1 p')).
        exact (projT2 p'). }
      { pose proof (parse_empty_from_maybe_empty_parse_of_productions valid0 _ Hsub _ Hlen p) as p'.
        eexists (ParseTail _ (projT1 p')).
        exact (projT2 p'). } }
    { destruct p as [ | ?? p0 p1 ]; simpl in *.
      { exists (ParseProductionNil G _ Hlen). constructor. }
      { eapply (@parse_empty_from_maybe_empty_parse_of_item' parse_empty_from_maybe_empty_parse_of_productions) in p0; try assumption.
        eapply (@parse_empty_from_maybe_empty_parse_of_production) in p1; try assumption.
        { eexists (ParseProductionCons _ 0 (projT1 p0) (projT1 p1)).
          exact (projT2 p0, projT2 p1). }
        { rewrite ?take_length, ?drop_length, Hlen; reflexivity. }
        { rewrite ?take_length, ?drop_length, Hlen, Min.min_0_r; reflexivity. } } }
  Defined.

  Definition parse_empty_from_maybe_empty_parse_of_item
             {valid0 it}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0)
             (p : maybe_empty_item G valid0 it)
  : { p : parse_of_item G str it
          & Forall_parse_of_item (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p }
    := @parse_empty_from_maybe_empty_parse_of_item' (@parse_empty_from_maybe_empty_parse_of_productions) valid0 it Hsub str Hlen p.

  Definition parse_empty_from_minimal_maybe_empty_parse_of_item
             {valid0 it}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0)
             (p : minimal_maybe_empty_item (G := G) valid0 it)
  : { p : parse_of_item G str it
          & Forall_parse_of_item (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p }.
  Proof.
    eapply parse_empty_from_maybe_empty_parse_of_item; trivial.
    eapply maybe_empty_item__of__minimal_maybe_empty_item; try eassumption; reflexivity.
  Qed.

  Definition parse_empty_from_minimal_maybe_empty_parse_of_production
             {valid0 pat}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0)
             (p : minimal_maybe_empty_production (G := G) valid0 pat)
  : { p : parse_of_production G str pat
          & Forall_parse_of_production (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p }.
  Proof.
    eapply parse_empty_from_maybe_empty_parse_of_production; trivial.
    eapply maybe_empty_production__of__minimal_maybe_empty_production; try eassumption; reflexivity.
  Qed.

  Definition parse_empty_from_minimal_maybe_empty_parse_of_productions
             {valid0 pats}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (Hlen : length str = 0)
             (p : minimal_maybe_empty_productions (G := G) valid0 pats)
  : { p : parse_of G str pats
          & Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p }.
  Proof.
    eapply parse_empty_from_maybe_empty_parse_of_productions; trivial.
    eapply maybe_empty_productions__of__minimal_maybe_empty_productions; try eassumption; reflexivity.
  Qed.
End cfg.


From iris.algebra Require Export excl local_updates.
From iris.base_logic Require Import base_logic.
From iris.proofmode Require Import classes.
Set Default Proof Using "Type".

Record auth (A : Type) := Auth { authoritative : excl' A; auth_own : A }.
Add Printing Constructor auth.
Arguments Auth {_} _ _.
Arguments authoritative {_} _.
Arguments auth_own {_} _.
Instance: Params (@Auth) 1.
Instance: Params (@authoritative) 1.
Instance: Params (@auth_own) 1.
Notation "◯ a" := (Auth None a) (at level 20).
Notation "● a" := (Auth (Excl' a) ε) (at level 20).

(* COFE *)
Section cofe.
Context {A : ofeT}.
Implicit Types a : excl' A.
Implicit Types b : A.
Implicit Types x y : auth A.

Instance auth_equiv : Equiv (auth A) := λ x y,
  authoritative x ≡ authoritative y ∧ auth_own x ≡ auth_own y.
Instance auth_dist : Dist (auth A) := λ n x y,
  authoritative x ≡{n}≡ authoritative y ∧ auth_own x ≡{n}≡ auth_own y.

Global Instance Auth_ne : NonExpansive2 (@Auth A).
Proof. by split. Qed.
Global Instance Auth_proper : Proper ((≡) ==> (≡) ==> (≡)) (@Auth A).
Proof. by split. Qed.
Global Instance authoritative_ne: NonExpansive (@authoritative A).
Proof. by destruct 1. Qed.
Global Instance authoritative_proper : Proper ((≡) ==> (≡)) (@authoritative A).
Proof. by destruct 1. Qed.
Global Instance own_ne : NonExpansive (@auth_own A).
Proof. by destruct 1. Qed.
Global Instance own_proper : Proper ((≡) ==> (≡)) (@auth_own A).
Proof. by destruct 1. Qed.

Definition auth_ofe_mixin : OfeMixin (auth A).
Proof. by apply (iso_ofe_mixin (λ x, (authoritative x, auth_own x))). Qed.
Canonical Structure authC := OfeT (auth A) auth_ofe_mixin.

Global Instance auth_cofe `{Cofe A} : Cofe authC.
Proof.
  apply (iso_cofe (λ y : _ * _, Auth (y.1) (y.2))
    (λ x, (authoritative x, auth_own x))); by repeat intro.
Qed.

Global Instance Auth_discrete a b :
  Discrete a → Discrete b → Discrete (Auth a b).
Proof. by intros ?? [??] [??]; split; apply: discrete. Qed.
Global Instance auth_ofe_discrete : OfeDiscrete A → OfeDiscrete authC.
Proof. intros ? [??]; apply _. Qed.
Global Instance auth_leibniz : LeibnizEquiv A → LeibnizEquiv (auth A).
Proof. by intros ? [??] [??] [??]; f_equal/=; apply leibniz_equiv. Qed.
End cofe.

Arguments authC : clear implicits.

(* CMRA *)
Section cmra.
Context {A : ucmraT}.
Implicit Types a b : A.
Implicit Types x y : auth A.

Instance auth_valid : Valid (auth A) := λ x,
  match authoritative x with
  | Excl' a => (∀ n, auth_own x ≼{n} a) ∧ ✓ a
  | None => ✓ auth_own x
  | ExclBot' => False
  end.
Global Arguments auth_valid !_ /.
Instance auth_validN : ValidN (auth A) := λ n x,
  match authoritative x with
  | Excl' a => auth_own x ≼{n} a ∧ ✓{n} a
  | None => ✓{n} auth_own x
  | ExclBot' => False
  end.
Global Arguments auth_validN _ !_ /.
Instance auth_pcore : PCore (auth A) := λ x,
  Some (Auth (core (authoritative x)) (core (auth_own x))).
Instance auth_op : Op (auth A) := λ x y,
  Auth (authoritative x ⋅ authoritative y) (auth_own x ⋅ auth_own y).

Definition auth_valid_eq :
  valid = λ x, match authoritative x with
               | Excl' a => (∀ n, auth_own x ≼{n} a) ∧ ✓ a
               | None => ✓ auth_own x
               | ExclBot' => False
               end := eq_refl _.
Definition auth_validN_eq :
  validN = λ n x, match authoritative x with
                  | Excl' a => auth_own x ≼{n} a ∧ ✓{n} a
                  | None => ✓{n} auth_own x
                  | ExclBot' => False
                  end := eq_refl _.

Lemma auth_included (x y : auth A) :
  x ≼ y ↔ authoritative x ≼ authoritative y ∧ auth_own x ≼ auth_own y.
Proof.
  split; [intros [[z1 z2] Hz]; split; [exists z1|exists z2]; apply Hz|].
  intros [[z1 Hz1] [z2 Hz2]]; exists (Auth z1 z2); split; auto.
Qed.

Lemma authoritative_validN n x : ✓{n} x → ✓{n} authoritative x.
Proof. by destruct x as [[[]|]]. Qed.
Lemma auth_own_validN n x : ✓{n} x → ✓{n} auth_own x.
Proof.
  rewrite auth_validN_eq.
  destruct x as [[[]|]]; naive_solver eauto using cmra_validN_includedN.
Qed.

Lemma auth_valid_discrete `{CmraDiscrete A} x :
  ✓ x ↔ match authoritative x with
        | Excl' a => auth_own x ≼ a ∧ ✓ a
        | None => ✓ auth_own x
        | ExclBot' => False
        end.
Proof.
  rewrite auth_valid_eq. destruct x as [[[?|]|] ?]; simpl; try done.
  setoid_rewrite <-cmra_discrete_included_iff; naive_solver eauto using 0.
Qed.
Lemma auth_validN_2 n a b : ✓{n} (● a ⋅ ◯ b) ↔ b ≼{n} a ∧ ✓{n} a.
Proof. by rewrite auth_validN_eq /= left_id. Qed.
Lemma auth_valid_discrete_2 `{CmraDiscrete A} a b : ✓ (● a ⋅ ◯ b) ↔ b ≼ a ∧ ✓ a.
Proof. by rewrite auth_valid_discrete /= left_id. Qed.

Lemma authoritative_valid  x : ✓ x → ✓ authoritative x.
Proof. by destruct x as [[[]|]]. Qed.
Lemma auth_own_valid `{CmraDiscrete A} x : ✓ x → ✓ auth_own x.
Proof.
  rewrite auth_valid_discrete.
  destruct x as [[[]|]]; naive_solver eauto using cmra_valid_included.
Qed.

Lemma auth_cmra_mixin : CmraMixin (auth A).
Proof.
  apply cmra_total_mixin.
  - eauto.
  - by intros n x y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
  - by intros n y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
  - intros n [x a] [y b] [Hx Ha]; simpl in *. rewrite !auth_validN_eq.
    destruct Hx as [?? Hx|]; first destruct Hx; intros ?; ofe_subst; auto.
  - intros [[[?|]|] ?]; rewrite /= ?auth_valid_eq
      ?auth_validN_eq /= ?cmra_included_includedN ?cmra_valid_validN;
      naive_solver eauto using O.
  - intros n [[[]|] ?]; rewrite !auth_validN_eq /=;
      naive_solver eauto using cmra_includedN_S, cmra_validN_S.
  - by split; simpl; rewrite assoc.
  - by split; simpl; rewrite comm.
  - by split; simpl; rewrite ?cmra_core_l.
  - by split; simpl; rewrite ?cmra_core_idemp.
  - intros ??; rewrite! auth_included; intros [??].
    by split; simpl; apply cmra_core_mono.
  - assert (∀ n (a b1 b2 : A), b1 ⋅ b2 ≼{n} a → b1 ≼{n} a).
    { intros n a b1 b2 <-; apply cmra_includedN_l. }
   intros n [[[a1|]|] b1] [[[a2|]|] b2]; rewrite auth_validN_eq;
     naive_solver eauto using cmra_validN_op_l, cmra_validN_includedN.
  - intros n x y1 y2 ? [??]; simpl in *.
    destruct (cmra_extend n (authoritative x) (authoritative y1)
      (authoritative y2)) as (ea1&ea2&?&?&?); auto using authoritative_validN.
    destruct (cmra_extend n (auth_own x) (auth_own y1) (auth_own y2))
      as (b1&b2&?&?&?); auto using auth_own_validN.
    by exists (Auth ea1 b1), (Auth ea2 b2).
Qed.
Canonical Structure authR := CmraT (auth A) auth_cmra_mixin.

Global Instance auth_cmra_discrete : CmraDiscrete A → CmraDiscrete authR.
Proof.
  split; first apply _.
  intros [[[?|]|] ?]; rewrite auth_valid_eq auth_validN_eq /=; auto.
  - setoid_rewrite <-cmra_discrete_included_iff.
    rewrite -cmra_discrete_valid_iff. tauto.
  - by rewrite -cmra_discrete_valid_iff.
Qed.

Instance auth_empty : Unit (auth A) := Auth ε ε.
Lemma auth_ucmra_mixin : UcmraMixin (auth A).
Proof.
  split; simpl.
  - rewrite auth_valid_eq /=. apply ucmra_unit_valid.
  - by intros x; constructor; rewrite /= left_id.
  - do 2 constructor; simpl; apply (core_id_core _).
Qed.
Canonical Structure authUR := UcmraT (auth A) auth_ucmra_mixin.

Global Instance auth_frag_core_id a : CoreId a → CoreId (◯ a).
Proof. do 2 constructor; simpl; auto. by apply core_id_core. Qed.

(** Internalized properties *)
Lemma auth_equivI {M} (x y : auth A) :
  x ≡ y ⊣⊢ (authoritative x ≡ authoritative y ∧ auth_own x ≡ auth_own y : uPred M).
Proof. by uPred.unseal. Qed.
Lemma auth_validI {M} (x : auth A) :
  ✓ x ⊣⊢ (match authoritative x with
          | Excl' a => (∃ b, a ≡ auth_own x ⋅ b) ∧ ✓ a
          | None => ✓ auth_own x
          | ExclBot' => False
          end : uPred M).
Proof. uPred.unseal. by destruct x as [[[]|]]. Qed.

Lemma auth_frag_op a b : ◯ (a ⋅ b) = ◯ a ⋅ ◯ b.
Proof. done. Qed.
Lemma auth_frag_mono a b : a ≼ b → ◯ a ≼ ◯ b.
Proof. intros [c ->]. rewrite auth_frag_op. apply cmra_included_l. Qed.

Global Instance auth_frag_sep_homomorphism :
  MonoidHomomorphism op op (≡) (@Auth A None).
Proof. by split; [split; try apply _|]. Qed.

Lemma auth_both_op a b : Auth (Excl' a) b ≡ ● a ⋅ ◯ b.
Proof. by rewrite /op /auth_op /= left_id. Qed.
Lemma auth_auth_valid a : ✓ a → ✓ (● a).
Proof. intros; split; simpl; auto using ucmra_unit_leastN. Qed.

Lemma auth_update a b a' b' :
  (a,b) ~l~> (a',b') → ● a ⋅ ◯ b ~~> ● a' ⋅ ◯ b'.
Proof.
  intros Hup; apply cmra_total_update.
  move=> n [[[?|]|] bf1] // [[bf2 Ha] ?]; do 2 red; simpl in *.
  move: Ha; rewrite !left_id -assoc=> Ha.
  destruct (Hup n (Some (bf1 ⋅ bf2))); auto.
  split; last done. exists bf2. by rewrite -assoc.
Qed.

Lemma auth_update_alloc a a' b' : (a,ε) ~l~> (a',b') → ● a ~~> ● a' ⋅ ◯ b'.
Proof. intros. rewrite -(right_id _ _ (● a)). by apply auth_update. Qed.
Lemma auth_update_dealloc a b a' : (a,b) ~l~> (a',ε) → ● a ⋅ ◯ b ~~> ● a'.
Proof. intros. rewrite -(right_id _ _ (● a')). by apply auth_update. Qed.

Lemma auth_local_update (a b0 b1 a' b0' b1': A) :
  (b0, b1) ~l~> (b0', b1') → b0' ≼ a' → ✓ a' →
  (● a ⋅ ◯ b0, ● a ⋅ ◯ b1) ~l~> (● a' ⋅ ◯ b0', ● a' ⋅ ◯ b1').
Proof.
  rewrite !local_update_unital=> Hup ? ? n /=.
  move=> [[[ac|]|] bc] /auth_validN_2 [Le Val] [] /=;
    inversion_clear 1 as [?? Ha|]; inversion_clear Ha. (* need setoid_discriminate! *)
  rewrite !left_id=> ?.
  destruct (Hup n bc) as [Hval' Heq]; eauto using cmra_validN_includedN.
  rewrite -!auth_both_op auth_validN_eq /=.
  split_and!; [by apply cmra_included_includedN|by apply cmra_valid_validN|done].
Qed.
End cmra.

Arguments authR : clear implicits.
Arguments authUR : clear implicits.

(* Proof mode class instances *)
Instance is_op_auth_frag {A : ucmraT} (a b1 b2 : A) :
  IsOp a b1 b2 → IsOp' (◯ a) (◯ b1) (◯ b2).
Proof. done. Qed.

(* Functor *)
Definition auth_map {A B} (f : A → B) (x : auth A) : auth B :=
  Auth (excl_map f <$> authoritative x) (f (auth_own x)).
Lemma auth_map_id {A} (x : auth A) : auth_map id x = x.
Proof. by destruct x as [[[]|]]. Qed.
Lemma auth_map_compose {A B C} (f : A → B) (g : B → C) (x : auth A) :
  auth_map (g ∘ f) x = auth_map g (auth_map f x).
Proof. by destruct x as [[[]|]]. Qed.
Lemma auth_map_ext {A B : ofeT} (f g : A → B) x :
  (∀ x, f x ≡ g x) → auth_map f x ≡ auth_map g x.
Proof.
  constructor; simpl; auto.
  apply option_fmap_equiv_ext=> a; by apply excl_map_ext.
Qed.
Instance auth_map_ne {A B : ofeT} n :
  Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@auth_map A B).
Proof.
  intros f g Hf [??] [??] [??]; split; simpl in *; [|by apply Hf].
  apply option_fmap_ne; [|done]=> x y ?; by apply excl_map_ne.
Qed.
Instance auth_map_cmra_morphism {A B : ucmraT} (f : A → B) :
  CmraMorphism f → CmraMorphism (auth_map f).
Proof.
  split; try apply _.
  - intros n [[[a|]|] b]; rewrite !auth_validN_eq; try
      naive_solver eauto using cmra_morphism_monotoneN, cmra_morphism_validN.
  - intros [??]. apply Some_proper; rewrite /auth_map /=.
    by f_equiv; rewrite /= cmra_morphism_core.
  - intros [[?|]?] [[?|]?]; try apply Auth_proper=>//=; by rewrite cmra_morphism_op.
Qed.
Definition authC_map {A B} (f : A -n> B) : authC A -n> authC B :=
  CofeMor (auth_map f).
Lemma authC_map_ne A B : NonExpansive (@authC_map A B).
Proof. intros n f f' Hf [[[a|]|] b]; repeat constructor; apply Hf. Qed.

Program Definition authRF (F : urFunctor) : rFunctor := {|
  rFunctor_car A B := authR (urFunctor_car F A B);
  rFunctor_map A1 A2 B1 B2 fg := authC_map (urFunctor_map F fg)
|}.
Next Obligation.
  by intros F A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, urFunctor_ne.
Qed.
Next Obligation.
  intros F A B x. rewrite /= -{2}(auth_map_id x).
  apply auth_map_ext=>y; apply urFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -auth_map_compose.
  apply auth_map_ext=>y; apply urFunctor_compose.
Qed.

Instance authRF_contractive F :
  urFunctorContractive F → rFunctorContractive (authRF F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, urFunctor_contractive.
Qed.

Program Definition authURF (F : urFunctor) : urFunctor := {|
  urFunctor_car A B := authUR (urFunctor_car F A B);
  urFunctor_map A1 A2 B1 B2 fg := authC_map (urFunctor_map F fg)
|}.
Next Obligation.
  by intros F A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, urFunctor_ne.
Qed.
Next Obligation.
  intros F A B x. rewrite /= -{2}(auth_map_id x).
  apply auth_map_ext=>y; apply urFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -auth_map_compose.
  apply auth_map_ext=>y; apply urFunctor_compose.
Qed.

Instance authURF_contractive F :
  urFunctorContractive F → urFunctorContractive (authURF F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, urFunctor_contractive.
Qed.


Require Import util syntax.

(* Based directly on oopsla 2013 paper *)

Inductive any_interleave : list memop → list (list memop) → Prop :=
  | noops : ∀ xs, (∀ x, x ∈ xs → x = []) → any_interleave [] xs
  | oneop : ∀ x xs ys zs t, any_interleave t (ys ++ xs :: zs) →
                            any_interleave (x::t) (ys ++ (x::xs) :: zs).

Fixpoint apply (E : list memop) (S : Map l v) : Map l v := match E with
  | [] => S
  | mwrite l v::xs => apply xs ((l,v)::S)
  | _ :: xs => apply xs S
  end.

(* TODO implement interleaves and apply *)
Definition valid_interleave (S : Map l v) (C : list l) (E' : list memop)
                            (es : list (list memop)) : Prop :=
  any_interleave E' es ∧
  ∀ l, lookup l (apply E' S) = lookup l (apply (concat es) S).
Definition domain {A B} := @map (A * B) A fst.

Reserved Notation " input ↦ output " (at level 50).
Inductive eval: Map r ρ
              * Map var v
              * Map l T
              * Map l v
              * list l
              * e
              → v * list memop
              → Prop :=
  | ERead1 : ∀ M L H S C e l E v,
    (M, L, H, S, C, e) ↦ (vl l, E) →
    l ∉ C →
    lookup l (apply E S) = Some v →
    (M, L, H, S, C, read e) ↦ (v, E ++ [mread l v])
  | ERead2 : ∀ M L H S C e l E v,
    (M, L, H, S, C, e) ↦ (vl l, E) →
    l ∈ C →
    (M, L, H, S, C, read e) ↦ (v, E ++ [mread l v])
  | EWrite : ∀ M L H S S' C e1 e2 l E1 E2 E v,
    (M, L, H, S, C, e1) ↦ (vl l, E1) →
    (M, L, H, S', C, e2) ↦ (v, E2) →
    valid_interleave S C E [E1; E2] →
    (M, L, H, S, C, write e1 e2) ↦ (vl l, E ++ [mwrite l v])
  | ENew : ∀ M L H S C t l r,
    l ∈ lu r M →
    l ∉ domain S →
    (M, L, H, S, C, new t r) ↦ (vl l, [])
  | EUpRgn : ∀ M L H S C e v E rs,
    (M, L, H, S, C, e) ↦ (v, E) →
    (M, L, H, S, C, upr e rs) ↦ (v, E)
  | EDnRgn1 : ∀ M L H S C e E rs r l,
    (M, L, H, S, C, e) ↦ (vl l, E) →
    r ∈ rs →
    l ∈ lu r M →
    (M, L, H, S, C, downr e rs) ↦ (vl l, E)
  | EDnRgn2 : ∀ M L H S C e E rs l,
    (M, L, H, S, C, e) ↦ (vl l, E) →
    (∀ r, r ∈ rs → l ∉ lu r M) →
    (M, L, H, S, C, downr e rs) ↦ (vnull, E)
  | ENewColor : ∀ M L H S C K r,
    (∀ i iv, (i, iv) ∈ K → i ∈ (lu r M)) →
    (M, L, H, S, C, newcolor r) ↦ (vcoloring K, [])
  | EColor : ∀ M L H S C K E1 E2 E3 E l e1 e2 e3 v,
    (M, L, H, S, C, e1) ↦ (vcoloring K, E1) →
    (M, L, H, apply E1 S, C, e2) ↦ (vl l, E2) →
    (M, L, H, apply E2 (apply E1 S), C, e3) ↦ (viv v, E3) →
    valid_interleave S C E [E1; E2; E3] →
    (M, L, H, S, C, color e1 e2 e3) ↦ (vcoloring ((l,v)::K), E)
	| EPartition : ∀ M M' L H S C rs rp ρs e1 e2 K E' E1 E2 v,
    (M, L, H, S, C, e1) ↦ (vcoloring K, E1) →
    ρs = map (map fst) (groupBy (λ x y, beq_nat (snd x) (snd y)) K) →
    M' = zip rs ρs ++ M →
    (M', L, H, S, C, e2) ↦ (v, E2) →
    valid_interleave S C E' [E1; E2] →
    (M, L, H, S, C, partition rp e1 rs e2) ↦ (v, E')
  | EPack : ∀ M L H S C e1 v E E' ρs rs v' T,
    (M, L, H, S, C, e1) ↦ (v, E') →
    ρs = map (λ r, lu r M) rs →
    v' = vreg_rel ρs v →
    (M, L, H, S, C, pack e1 T rs) ↦ (v', E)
  | EUnpack : ∀ M L H S C e1 ρs E1 M' rs L' id v1 S' v2 e2 E' T1,
    (M, L, H, S, C, e1) ↦ (vreg_rel ρs v1, E') →
    M' = zip rs ρs →
    S' = apply E1 S →
    L' = (id, v1)::L →
    (M', L', H, S, C, unpack e1 id T1 rs e2) ↦ (v2, E')
  | ECall : ∀ M L H S C es vs Es xs id rs En1 E'' E' M' L' S' C' t ts rs' e Phi Q v,
    (∀ e v E, In (e, (v, E)) (zip es (zip vs Es)) → (M, L, H, S, C, e) ↦ (v, E)) →
    valid_interleave S C E' Es →
    M' = zip rs' (map (λ r, lu r M) rs) →
    L' = zip xs vs →
    S' = apply E' S →
    function id rs xs ts Phi Q t e →
    (M', L', H, S', C', e) ↦ (v, En1) →
    valid_interleave S C E'' [E'; En1] →
    (M, L, H, S, C, call id rs es) ↦ (v, E'')
  | ELet : ∀ M L H S C e b id v E v' E' t S' E'',
    (M, L, H, S, C, e) ↦ (v, E) →
    S' = apply E S →
    (M, (id, v) :: L, H, S', C, b) ↦ (v', E')  →
    valid_interleave S C E'' [E; E'] →
    (M, L, H, S, C, elet id t e b) ↦ (v', E'')
  | EId : ∀ M L H S C x v,
    lookup x L = Some v →
    (M, L, H, S, C, id x) ↦ (v, [])
where " input ↦ output " := (eval input output).


Require Import Raft.
Require Import RaftRefinementInterface.

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

  Definition leaderLogs_votesWithLog (net : network) : Prop :=
    forall t ll leader,
      In (t, ll) (leaderLogs (fst (nwState net leader))) ->
      exists quorum,
        NoDup quorum /\
        length quorum > div2 (length nodes) /\
        forall h, In h quorum ->
                  exists log,
                    moreUpToDate (maxTerm ll) (maxIndex ll) (maxTerm log) (maxIndex log) = true /\
                    In (t, leader, log) (votesWithLog (fst (nwState net h))).

  Class leaderLogs_votesWithLog_interface : Prop :=
    {
      leaderLogs_votesWithLog_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          leaderLogs_votesWithLog net
    }.
End LeaderLogsVotesWithLog.