(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

  Velisarios is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Velisarios 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 General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Import QArith_base.
Require Import tactics2.
Require Import list_util.
Require Import Eqdep_dec.

Require Import Process.

(* Pair of states *)
Inductive pstate SX SY :=
| pstate_two (l : SX) (r : SY)
| pstate_left (l : SX)
| pstate_right (r : SY).
Arguments pstate_two [SX] [SY] _ _.
Arguments pstate_left [SX] [SY] _.
Arguments pstate_right [SX] [SY] _.

Definition opt_states2pstate
           {SX SY}
           (sx : option SX)
           (sy : option SY) : option (pstate SX SY) :=
  match sx, sy with
  | Some x, Some y => Some (pstate_two x y)
  | Some x, None => Some (pstate_left x)
  | None, Some y => Some (pstate_right y)
  | None, None => None
  end.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.

Require Import Coq.FSets.FSetProperties.

Require Import Defs.Env.
Require Import Defs.List.
Require Import Defs.Obj.
Require Import Defs.Set.

(*** Notation, tactics etc*)
Theorem FrA_app_split : forall (a1 a2 : A) (env : Env),
    FrA (a2 ++ a1) env
  <-> (FrA a2 (env ::a a1) /\ FrA a1 env).
Proof.
  introv. split; induction a2; rewr. 1,3:crush.
  - split; inverts H. 2:{ apply IHa2. assumption. }
    constructor. crush. rewr*. intros. apply FR. fsetdec.
  - intros. destr. inverts H. destr. constructor. eauto.
    rewr*. intros. apply FR. fsetdec.
Qed.

Ltac inv_FrA_ :=
  let H := fresh "H" in
  let FR1 := fresh "FR" in
  let FR2 := fresh "FR" in
  match goal with
    | [ H  : FrA nil _ |- _ ] => clear H
    | [ H  : FrA (cons _ _) _ |- _ ] => inverts H
    | [ H  : FrA ([_]) _ |- _ ] => inverts H
    (* | [ H  : FrA (?a2 ++ ?a1) ?env |- _ ] => assert (H' := H); apply FrA_app_split in H'; destruct H' as [FR1 FR2] *)
    | [ H  : FrA (?a2 ++ ?a1) ?env |- _ ] => apply FrA_app_split in H; destruct H as [FR1 FR2]
  end.
Ltac inv_FrA := repeat inv_FrA_.

(*** Inversion *)
Theorem FrA_inv : forall (exA : var) (a : A) (env : Env),
    FrA (exA :: a) env
  -> FrA a env
  /\ exA \notin Env_Obj_exvars (env ::a a).
Proof. inversion 1. jauto. Qed.
Corollary FrA_inv__proj1 : forall (exA : var) (a : A) (env : Env),
    FrA (exA :: a) env
  -> FrA        a  env.
Proof. apply FrA_inv. Qed.
Corollary FrA_inv__proj2 : forall (exA : var) (a : A) (env : Env),
    FrA (exA :: a) env
  -> exA \notin Env_Obj_exvars (env ::a a).
Proof. apply FrA_inv. Qed.
#[export] Hint Resolve FrA_inv__proj1 FrA_inv__proj2 : core.

Ltac indestr := rewr*; autorewrite with in_disj in *; destr.
Tactic Notation "indestr" "in" hyp(H) := rewr in H; autorewrite with in_disj in H.

Theorem FrA_in_inv : forall (exA : var) (a : A) (env : Env),
    FrA a env
  -> exA \in varl a
  -> exA \notin Env_Obj_exvars env.
Proof.
  induction a. crush. intros. indestr. eauto. rewr*. subst.
  forwards: FrA_inv__proj2. eassumption. unfold not in *. crush.
Qed.

(* (*** Things for in list *) *)
(* #[export] Hint Constructors NoDup'. *)

(* Theorem list_to_varl : forall (exA : exvar) (a : A), *)
(*     In exA a <-> exA \in varl a. *)
(* Proof. *)
(*   intros. induction a. crush. *)
(*   destruct (a == exA). *)
(*   - crush. *)
(*   - crush. right. apply H0. fsetdec. *)
(* Qed. *)
(* Corollary list_to_varl1 : forall (exA : exvar) (a : A), *)
(*     In exA a -> exA \in varl a. *)
(* Proof. apply list_to_varl. Qed. *)
(* Corollary list_to_varl2 : forall (exA : exvar) (a : A), *)
(*     exA \in varl a -> In exA a. *)
(* Proof. apply list_to_varl. Qed. *)
(* #[export] Hint Resolve list_to_varl1 list_to_varl2 : core. *)

(* Theorem incl_list_sub : forall (a1 a2 : A), *)
(*     incl a1 a2 *)
(*   -> a1 [<=]l a2. *)
(* Proof. intros. autounfold. unfold AtomSetImpl.Subset. crush. Qed. *)
(* #[export] Hint Resolve incl_list_sub : core. *)

(* Lemma Nodup_incl: forall (a1 a2 : A) (env1 : Env), *)
(*     NoDup' a1 *)
(*   -> incl a2 a1 *)
(*   -> NoDup' a2. *)
(* OK this doesn't work we need proper sublists *)

(*** For in Env *)
(* Lemma Env_sub__proj1 : forall (env1 env2 : Env), *)
(*     env1 [<=]e env2 *)
(*   -> Env_skvars env1 [<=] Env_skvars env2. *)
(* Proof. autounfold. intros. jauto. Qed. *)
(* #[export] Hint Resolve Env_sub__proj1 : core. *)
(* Lemma Env_sub__proj2 : forall (env1 env2 : Env), *)
(*     env1 [<=]e env2 *)
(*   -> Env_exvars env1 [<=] Env_exvars env2. *)
(* Proof. autounfold. intros. jauto. Qed. *)
(* #[export] Hint Resolve Env_sub__proj2 : core. *)

(* Lemma Env_eq_proj1 : forall (env1 env2 : Env), *)
(*     env1 [=]e env2 *)
(*   -> Env_skvars env1 [=] Env_skvars env2. *)
(* Proof. autounfold. intros. jauto. Qed. *)
(* #[export] Hint Resolve Env_eq_proj1 : core. *)
(* Lemma Env_eq_proj2 : forall (env1 env2 : Env), *)
(*     env1 [=]e env2 *)
(*   -> Env_exvars env1 [=] Env_exvars env2. *)
(* Proof. autounfold. intros. jauto. Qed. *)
(* #[export] Hint Resolve Env_eq_proj2 : core. *)

(* Lemma Env_fr_sub_proj1 : forall (env1 env2 : Env), *)
(*     env1 [<=]e# env2 *)
(*   -> Env_skvars env1 [<=] Env_skvars env2. *)
(* Proof. autounfold. intros. jauto. Qed. *)
(* #[export] Hint Resolve Env_fr_sub_proj1 : core. *)
(* Lemma Env_fr_sub_proj2 : forall (env1 env2 : Env), *)
(*     env1 [<=]e# env2 *)
(*   -> Env_Obj_exvars env1 [<=] Env_Obj_exvars env2. *)
(* Proof. autounfold. intros. jauto. Qed. *)
(* #[export] Hint Resolve Env_fr_sub_proj2 : core. *)

(* Lemma Env_fr_eq_proj1 : forall (env1 env2 : Env), *)
(*     env1 [=]e# env2 *)
(*   -> Env_skvars env1 [=] Env_skvars env2. *)
(* Proof. autounfold. intros. jauto. Qed. *)
(* #[export] Hint Resolve Env_fr_eq_proj1 : core. *)
(* Lemma Env_fr_eq_proj2 : forall (env1 env2 : Env), *)
(*     env1 [=]e# env2 *)
(*   -> Env_Obj_exvars env1 [=] Env_Obj_exvars env2. *)
(* Proof. autounfold. intros. jauto. Qed. *)
(* #[export] Hint Resolve Env_fr_eq_proj2 : core. *)

(*** Props *)
Theorem FrA_props : forall (a : A) (env : Env),
    FrA a env
  <-> varl a [><] Env_Obj_exvars env
  /\ NoDup' a.
Proof.
  intros. split.
  - induction 1. crush. destr. split.
    + rewr. apply disjoint_extend'. crush. eassumption.
    + constructor. crush. assumption.
  - intros [? ND]. induction ND. crush.
    constructor. rewr in H.
    apply IHND. assert (SUB: varl a [<=] varl a \u singleton exA). fsetdec.
    rewrite SUB. eassumption.
    rewr. intros. indestr. eauto using in_disjoint_impl. crush.
Qed.
Corollary FrA_props1 : forall (a : A) (env : Env),
    FrA a env
  -> varl a [><] Env_Obj_exvars env
  /\ NoDup' a.
Proof. apply FrA_props. Qed.
Corollary FrA_props2 : forall (a : A) (env : Env),
    varl a [><] Env_Obj_exvars env
  -> NoDup' a
  -> FrA a env.
Proof. intros. apply FrA_props. crush. Qed.
Corollary FrA_props3 : forall (a : A) (env : Env),
    FrA a env
  -> varl a [><] Env_Obj_exvars env.
Proof. apply FrA_props. Qed.
Corollary FrA_props4 : forall (a : A) (env : Env),
    FrA a env
  -> NoDup' a.
Proof. apply FrA_props. Qed.

(*** Rewriting *)
Theorem FrA_rewr : forall (a1 a2 : A) (env1 env2 : Env),
    FrA a1 env1
  -> a2 [<=]lu a1
  -> env2 [<=]e# env1
  -> FrA a2 env2.
Proof.
  introv FRA SUB__l SUB__e. rewrite FrA_props in *.
  split.
  - applys disj_subset_proper. 3:jauto. crush. rewr. conv. unfold Env_fr_sub in SUB__e. jauto.
  - jauto.
Qed.
#[export] Hint Resolve FrA_rewr : core.

#[export] Instance FrA_rewr_proper : Proper (flip list_uni_sub ==> flip Env_fr_sub ==> impl) FrA.
Proof. unfold Proper, respectful, impl, flip. intros. eauto. Qed.

Corollary FrA_Env_sub : forall (env1 env2 : Env) (a : A),
    FrA a env1
  -> env2 [<=]e# env1
  -> FrA a env2.
Proof. eauto. Qed.
Corollary FrA_sublist : forall (a1 a2 : A) (env : Env),
    FrA a1 env
  -> a2 [<=]lu a1
  -> FrA a2 env.
Proof. eauto. Qed.

(*** Unsorted *)
Theorem FrA_Obj : forall (env : Env) (a1 a2 : A) (sch : Sch),
    FrA a2 (env ::o ⟦⟨a1⟩ sch⟧)
  <-> FrA a2 (env ::a a1).
Proof. split; introv FR; eapply FrA_rewr; try apply FR; try reflexivity; eauto. rewr.
       unfold Env_fr_sub. crush.
       unfold Env_fr_sub. crush.
Qed.

Lemma FrA_cons_shift: forall (exA : exvar) (a : list exvar) (env : Env),
    FrA (exA :: a) env
  -> FrA a (env ::a [exA]).
Proof.
  introv FR. listind a. crush. constructor. apply IHa.
  constructor. eauto. inv_FrA. intros. apply FR0. rewr*. fsetdec.
  inv_FrA. intros. indestr in H. destr. apply FR. rewr. fsetdec. rewr in H. crush. apply FR. rewr. fsetdec.
Qed.


(** * Definition of the string-like type *)
Require Coq.Lists.List.
Require Import Coq.Relations.Relation_Definitions (* for [relation] *).
Require Import Coq.Classes.Morphisms (* for [==>] / [respectful] *).
Require Export Fiat.Common.Coq__8_4__8_5__Compat.

Local Coercion is_true : bool >-> Sortclass.

Set Implicit Arguments.
Generalizable All Variables.

(** Something is string-like if it has a type of characters, and can
    be split. *)

Reserved Notation "[ x ]".

Module Export StringLike.
  Class StringLikeMin {Char : Type} :=
    {
      String :> Type;
      char_at_matches : nat -> String -> (Char -> bool) -> bool;
      unsafe_get : nat -> String -> Char;
      length : String -> nat
    }.

  Class StringLike {Char : Type} {HSLM : @StringLikeMin Char} :=
    {
      is_char : String -> Char -> bool;
      take : nat -> String -> String;
      drop : nat -> String -> String;
      get : nat -> String -> option Char;
      bool_eq : String -> String -> bool;
      beq : relation String := fun x y => bool_eq x y
    }.

  Class StringIso {Char} {HSLM : @StringLikeMin Char} :=
    {
      of_string : list Char -> String
    }.

  Arguments StringLikeMin : clear implicits.
  Arguments StringLike Char {HSLM}.
  Arguments StringIso Char {HSLM}.
  Bind Scope string_like_scope with String.
  Delimit Scope string_like_scope with string_like.
  Infix "=s" := (@beq _ _ _) (at level 70, no associativity) : type_scope.
  Infix "=s" := (@bool_eq _ _ _) (at level 70, no associativity) : string_like_scope.
  Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope.
  Local Open Scope string_like_scope.
  Local Open Scope type_scope.

  Definition fold' {Char} {HSLM} {HSL : @StringLike Char HSLM} {A}
             (f : Char -> A -> A)
             (init : A)
             (str : String) (len : nat)
  : A
    := nat_rect
         (fun _ => A)
         init
         (fun len' acc
          => match get (length str - S len') str with
               | Some ch => f ch acc
               | None => init
             end)
         len.

  Definition fold {Char} {HSLM} {HSL : @StringLike Char HSLM} {A}
             (f : Char -> A -> A)
             (init : A)
             (str : String)
  : A
    := fold' f init str (length str).

  Definition fold_lookahead' {Char} {HSLM} {HSL : @StringLike Char HSLM} {A}
             (f : Char -> option Char -> A -> A)
             (init : A)
             (str : String) (len : nat)
  : A
    := nat_rect
         (fun _ => A)
         init
         (fun len' acc
          => match get (length str - S len') str with
               | Some ch => f ch (get (length str - len') str) acc
               | None => init
             end)
         len.

  Definition fold_lookahead {Char} {HSLM} {HSL : @StringLike Char HSLM} {A}
             (f : Char -> option Char -> A -> A)
             (init : A)
             (str : String)
  : A
    := fold_lookahead' f init str (length str).

  Notation to_string str := (fold (@List.cons _) (@List.nil _) str).

  Definition str_le `{@StringLike Char HSLM} (s1 s2 : String)
    := length s1 < length s2 \/ s1 =s s2.
  Infix "≤s" := str_le (at level 70, right associativity).

  Notation substring n m str := (take m (drop n str)).

  Class StringLikeProperties (Char : Type) `{StringLike Char} :=
    {
      singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch';
      singleton_exists : forall s, length s = 1 -> exists ch, s ~= [ ch ];
      char_at_matches_correct : forall s n P ch, get n s = Some ch -> (char_at_matches n s P = P ch);
      get_0 : forall s ch, take 1 s ~= [ ch ] <-> get 0 s = Some ch;
      get_S : forall n s, get (S n) s = get n (drop 1 s);
      unsafe_get_correct : forall n s ch, get n s = Some ch -> unsafe_get n s = ch;
      length_singleton : forall s ch, s ~= [ ch ] -> length s = 1;
      bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s';
      is_char_Proper :> Proper (beq ==> eq ==> eq) is_char;
      length_Proper :> Proper (beq ==> eq) length;
      take_Proper :> Proper (eq ==> beq ==> beq) take;
      drop_Proper :> Proper (eq ==> beq ==> beq) drop;
      bool_eq_Equivalence :> Equivalence beq;
      bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str';
      take_short_length : forall str n, n <= length str -> length (take n str) = n;
      take_long : forall str n, length str <= n -> take n str =s str;
      take_take : forall str n m, take n (take m str) =s take (min n m) str;
      drop_length : forall str n, length (drop n str) = length str - n;
      drop_0 : forall str, drop 0 str =s str;
      drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str;
      drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str);
      take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str);
      bool_eq_from_get : forall str str', (forall n, get n str = get n str') -> str =s str'
    }.

  Class StringIsoProperties {Char} {HSLM} {HSL : @StringLike Char HSLM} {HSI : @StringIso Char HSLM} :=
    {
      get_of_string : forall n str, get n (of_string str) = List.nth_error str n
    }.

  Class StringEqProperties {Char} {HSLM} {HSL : @StringLike Char HSLM} :=
    {
      bool_eq_bl : forall s s', s =s s' -> s = s';
      bool_eq_lb : forall s s', s = s' -> s =s s'
    }.

  Global Existing Instance Equivalence_Reflexive.
  Global Existing Instance Equivalence_Symmetric.
  Global Existing Instance Equivalence_Transitive.

  Arguments StringLikeProperties Char {_ _}.
  Arguments StringIsoProperties Char {_ _ _}.
  Arguments StringEqProperties Char {_ _}.
End StringLike.


(*
Copyright 2013 IMDEA Software Institute
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

(******************************************************************************)
(* This file contains axioms that are used in some parts of the library.      *)
(* The selected set of axioms is known to be consistent with Coq's logic.     *)
(* These axioms are:                                                          *)
(*   - propositional extensionality (pext);                                   *)
(*   - functional extensionality (fext).                                      *)
(* This file also defines the dynamic type as an alias for sigT and           *)
(* Jonh Major equality via equality cast.                                     *)
(******************************************************************************)

From Coq Require Import ssreflect ssrfun Eqdep ClassicalFacts.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*****************************)
(* Axioms and extensionality *)
(*****************************)

(* extensionality is needed for domains *)
Axiom pext : forall p1 p2 : Prop, (p1 <-> p2) -> p1 = p2.
Axiom fext : forall A (B : A -> Type) (f1 f2 : forall x, B x),
               (forall x, f1 x = f2 x) -> f1 = f2.

Lemma pf_irr (P : Prop) (p1 p2 : P) : p1 = p2.
Proof. by apply/ext_prop_dep_proof_irrel_cic/pext. Qed.

Lemma eta A (B : A -> Type) (f : forall x, B x) : f = [eta f].
Proof. by apply: fext. Qed.

Lemma sval_inj A P : injective (@sval A P).
Proof.
move=>[x Hx][y Hy] /= H; move: Hx Hy; rewrite H=>*.
congr exist; apply: pf_irr.
Qed.

Lemma svalE A (P : A -> Prop) x H : sval (exist P x H) = x.
Proof. by []. Qed.

Lemma compf1 A B (f : A -> B) : f = f \o id.
Proof. by apply: fext. Qed.

Lemma comp1f A B (f : A -> B) : f = id \o f.
Proof. by apply: fext. Qed.

(*****************************************)
(* Cast and John Major Equality via cast *)
(*****************************************)

Section Cast.
Variable (C : Type) (interp : C -> Type).

Definition cast A B (pf : A = B) (v : interp B) : interp A :=
  ecast _ _ (esym pf) v.

Lemma eqc A (pf : A = A) (v : interp A) : cast pf v = v.
Proof. by move: pf; apply: Streicher_K. Qed.

Definition jmeq A B (v : interp A) (w : interp B) := forall pf, v = cast pf w.

Lemma jmrefl A (v : interp A) : jmeq v v.
Proof. by move=>pf; rewrite eqc. Qed.

Lemma jmsym A B (v : interp A) (w : interp B) : jmeq v w -> jmeq w v.
Proof.
move=> H pf; rewrite (H (esym pf)).
by move: (pf); rewrite pf in w H * => {pf} pf; rewrite !eqc.
Qed.

Lemma jmE A (v w : interp A) : jmeq v w <-> v = w.
Proof. by split=>[/(_ erefl) //|->]; apply: jmrefl. Qed.

Lemma castE A B (pf1 pf2 : A = B) (v1 v2 : interp B) :
        v1 = v2 <-> cast pf1 v1 = cast pf2 v2.
Proof. by move: (pf1) pf2; rewrite pf1 =>*; rewrite !eqc. Qed.

End Cast.

Arguments cast {C} interp [A][B] pf v.
Arguments jmeq {C} interp [A][B] v w.
Hint Resolve jmrefl : core.
(* special notation for the common case when interp = id *)
Notation icast pf v := (@cast _ id _ _ pf v).
Notation ijmeq v w := (@jmeq _ id _ _ v w).

(* type dynamic is sigT *)

Section Dynamic.
Variables (A : Type) (P : A -> Type).

(** eta expand definitions to prevent universe inconsistencies when using
    the injectivity of constructors of datatypes depending on [[dynamic]] *)

Definition dynamic := sigT P.
Definition dyn := existT P.
Definition dyn_tp := @projT1 _ P.
Definition dyn_val := @projT2 _ P.
Definition dyn_eta := @sigT_eta _ P.
Definition dyn_injT := @eq_sigT_fst _ P.
Definition dyn_inj := @inj_pair2 _ P.

End Dynamic.

Prenex Implicits dyn_tp dyn_val dyn_injT dyn_inj.
Arguments dyn {C} interp {A} _ : rename.
Notation idyn v := (@dyn _ id _ v).

Lemma dynE (A B : Type) interp (pf : A = B) (v : interp A) (w : interp B) :
        jmeq interp v w <-> dyn interp v = dyn interp w.
Proof. by rewrite -pf in w *; rewrite jmE; split => [->|/dyn_inj]. Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import machine_int.
Require Import mips_cmd.

Local Open Scope mips_cmd_scope.
Import expr_m.

Definition multi_lt (k a b i flag ret ret2 atmp btmp : reg) : while.cmd :=
  addiu i k zero16 ;
  addiu flag r0 one16 ;
  If_beq i , r0 Then
    addiu ret r0 zero16 ;
    addiu ret2 r0 zero16
  Else
    While (bne flag r0) {{
      addiu i i mone16 ;
      lwxs atmp i a ;
      lwxs btmp i b ;
      sltu ret atmp btmp ;
      movn flag r0 ret ; (* flag = 0 if atmp < btmp *)
      sltu ret2 btmp atmp ;
      movn flag r0 ret2 ; (* flag = 0 if btmp < atmp *)
      movz flag r0 i (* if atmp = btmp, flag <> 0 *) }}.


Require Import Bag.
Require Import WellFormed.

Require Import Proofs.GHC.Base.
Require Import Proofs.GHC.List.
Require Import Proofs.Data.Foldable.
Require Import Proofs.Data.OldList.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import ListUtils.
Require Import Coq.ZArith.ZArith.

Require Data.Traversable.
Import GHC.Base.
Import Data.Functor.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.

Require Import Coq.Logic.FunctionalExtensionality.

Require Import Correctness.

From Coq Require Import ssreflect ssrfun ssrbool.
Set Bullet Behavior "Strict Subproofs".

(***** Operators *****)

Infix "<$>" := Data.Functor.op_zlzdzg__ : hs_op_scope.
Infix "<*>" := GHC.Base.op_zlztzg__ : hs_op_scope.
Infix ">>=" := GHC.Base.op_zgzgze__ : hs_op_scope.
Infix ">>" := GHC.Base.op_zgzg__ : hs_op_scope.
Open Scope hs_op_scope.

(***** Working with extensionality *****)

(* Like the "extensionality" tactic, but doesn't intro -- nicer with ssreflect *)
Ltac funext :=
  match goal with
    [ |- ?X = ?Y ] =>
    (apply (@functional_extensionality _ _ X Y) ||
     apply (@functional_extensionality_dep _ _ X Y) ||
     apply forall_extensionalityP ||
     apply forall_extensionalityS ||
     apply forall_extensionality)
  end.

(* From https://stackoverflow.com/a/43853467/237428 *)
Instance pointwise_eq_ext {A B : Type} {RB : relation B} `(sb : subrelation B RB eq)
  : subrelation (pointwise_relation A RB) eq.
Proof. intros f g Hfg. apply functional_extensionality. intro x; apply sb, (Hfg x). Qed.

(***** Bag correctness theorems *****)

Theorem mapBagM_ok {M A B} `{MonadLaws M} (f : A -> M B) (b : Bag A) :
  GHC.Base.fmap bagToList (mapBagM f b) = Data.Traversable.mapM f (bagToList b).
Proof.
  rewrite /Data.Traversable.mapM /Traversable.Traversable__list /Data.Traversable.mapM__
          /=
          /Data.Traversable.Traversable__list_mapM
          /Data.Traversable.Traversable__list_traverse.
  replace (fmap bagToList (mapBagM f b)) with
          (_++_ <$> (fmap bagToList (mapBagM f b)) <*> pure [])
          by by unfold "<$>";
                rewrite functor_composition !applicative_fmap applicative_interchange
                        -applicative_composition !applicative_homomorphism;
                do 2 f_equal; funext=> ?; unfold "∘"; rewrite app_nil_r.
  generalize (pure ([] : list B)) => z.
  elim: b z => [| x | l IHl r IHr | xs] z //=.
  - rewrite applicative_fmap -monad_applicative_pure applicative_homomorphism.
    unfold "<$>"; rewrite applicative_fmap applicative_homomorphism.
    replace [eta app _] with (@GHC.Base.id (list B)) by by funext.
    apply applicative_identity.
  - unfold "<$>"; rewrite
      applicative_liftA2 !applicative_fmap !monad_applicative_ap /ap !monad_applicative_pure !monad_left_id
      -!monad_composition.
    by f_equal; funext => ?; rewrite !monad_left_id.
  - rewrite bagToList_TwoBags hs_coq_foldr_base fold_right_app -!hs_coq_foldr_base.
    rewrite -IHr -IHl.
    unfold "<$>"; rewrite
      !functor_composition !applicative_fmap
      !monad_applicative_ap /ap !monad_applicative_pure !monad_left_id -!monad_composition.
    f_equal; funext=> ?.
    rewrite !monad_left_id -!monad_composition.
    f_equal; funext=> ?.
    rewrite !monad_left_id -!monad_composition.
    f_equal; funext=> ?.
    rewrite monad_left_id.
    f_equal.
    by unfold "∘"; rewrite /= bagToList_TwoBags app_assoc.
  - rewrite bagToList_ListBag
            /Data.Traversable.mapM /Traversable.Traversable__list /Data.Traversable.mapM__
            /Data.Traversable.Traversable__list_mapM
            /Data.Traversable.Traversable__list_traverse.
    unfold "<$>"; rewrite
      functor_composition applicative_fmap
      !monad_applicative_ap /ap monad_applicative_pure monad_left_id.
    rewrite -!monad_composition.
    elim: xs z => [|x xs IH] z /=.
    + rewrite monad_applicative_pure !monad_left_id.
      replace (fun _ : list B => return_ _) with (return_ : list B -> M (list B));
        first by apply monad_right_id.
      by funext.
    + rewrite -(IH z).
      rewrite !applicative_liftA2 !applicative_fmap !monad_applicative_ap /ap monad_applicative_pure
              !monad_left_id -!monad_composition.
      f_equal; funext=> ?.
      rewrite !monad_left_id -!monad_composition.
      f_equal; funext=> ?.
      rewrite -!monad_composition !monad_left_id -!monad_composition.
      f_equal; funext=> ?.
      by rewrite !monad_left_id.
Qed.

Theorem foldr_app {A B} (f : A -> B -> B) (z : B) (xs ys : list A) :
  foldr f z (xs ++ ys) = foldr f (foldr f z ys) xs.
Proof. by rewrite hs_coq_foldr_base fold_right_app -!hs_coq_foldr_base. Qed.

Lemma monad_bind_return_fmap {M A B} `{MonadLaws M} (f : A -> B) (mx : M A) :
  (mx >>= fun x : A => return_ (f x)) = (f <$> mx).
Proof.
  by unfold "<$>"; rewrite applicative_fmap monad_applicative_ap monad_applicative_pure /ap
                           monad_left_id.
Qed.

Lemma monad_bind_return_fmap2 {M A B C} `{MonadLaws M} (f : A -> B -> C) (mx : M A) (my : M B) :
  (mx >>= fun x => (my >>= fun y => return_ (f x y))) = (f <$> mx <*> my).
Proof.
  unfold "<$>".
  rewrite applicative_fmap !monad_applicative_ap monad_applicative_pure /ap.
  rewrite monad_left_id -monad_composition.
  f_equal; funext; intros.
  rewrite monad_left_id.
  reflexivity.
Qed.

Lemma monad_bind_fmap_ap {M A B C} `{MonadLaws M} (f : A -> B -> C) (mx : M A) (my : M B) :
  (mx >>= fun x : A => fmap (f x) my) = (f <$> mx <*> my).
Proof.
  unfold "<$>";
    setoid_rewrite ->applicative_fmap;
    repeat setoid_rewrite ->monad_applicative_ap;
    setoid_rewrite ->monad_applicative_pure;
    unfold ap.
  by rewrite -!monad_composition monad_left_id -!monad_composition.
Qed.

Lemma applicative_fmap_pure {F A B} `{ApplicativeLaws F} (f : A -> B) (x : A) :
  fmap f (pure x) = pure (f x) :> F B.
Proof. by rewrite applicative_fmap applicative_homomorphism. Qed.

Lemma monad_fmap_return {M A B} `{MonadLaws M} (f : A -> B) (x : A) :
  fmap f (return_ x) = return_ (f x) :> M B.
Proof. by rewrite -!monad_applicative_pure applicative_fmap_pure. Qed.

Theorem mapBagM_ok' {M A B} `{MonadLaws M} (f : A -> M B) (b : Bag A) :
  GHC.Base.fmap bagToList (mapBagM f b) = Data.Traversable.mapM f (bagToList b).
Proof.
  rewrite /Data.Traversable.mapM /Traversable.Traversable__list /Data.Traversable.mapM__ /=
          /Data.Traversable.Traversable__list_mapM
          /Data.Traversable.Traversable__list_traverse.
  replace (fmap bagToList (mapBagM f b)) with
          (_++_ <$> (fmap bagToList (mapBagM f b)) <*> pure [])
          by by unfold "<$>";
                rewrite functor_composition !applicative_fmap applicative_interchange
                        -applicative_composition !applicative_homomorphism;
                do 2 f_equal; funext=> ?; unfold "∘"; rewrite app_nil_r.
  generalize (pure ([] : list B)) => z.
  elim: b z => [| x | l IHl r IHr | xs] z //=.
  - by unfold "<$>";
       rewrite functor_composition monad_fmap_return -monad_applicative_pure
               applicative_identity.
  - by rewrite applicative_liftA2 monad_bind_return_fmap; unfold "<$>"; rewrite !functor_composition.
  - setoid_rewrite ->monad_bind_return_fmap; setoid_rewrite ->monad_bind_fmap_ap.
    rewrite bagToList_TwoBags foldr_app -IHl -IHr.
    unfold "<$>"; rewrite !functor_composition.
    rewrite !applicative_fmap -!applicative_composition !applicative_homomorphism; f_equal.
    rewrite !applicative_interchange -!applicative_fmap functor_composition; do 2 f_equal.
    funext=> l'; funext=> r'; funext=> z'.
    by unfold "∘"; rewrite bagToList_TwoBags app_assoc.
  - rewrite bagToList_ListBag
            /Data.Traversable.mapM /Traversable.Traversable__list /Data.Traversable.mapM__
            /Data.Traversable.Traversable__list_mapM
            /Data.Traversable.Traversable__list_traverse.
    rewrite monad_bind_return_fmap; unfold "<$>"; rewrite !functor_composition.
    elim: xs => [|x xs IH] /=.
    + by rewrite applicative_fmap_pure applicative_identity.
    + rewrite -IH.
      rewrite !applicative_liftA2 !applicative_fmap -!applicative_composition !applicative_homomorphism.
      by rewrite applicative_interchange -applicative_composition !applicative_homomorphism.
Qed.

Ltac applicative_normalize :=
  simpl;
  unfold "<$>"; rewrite ?applicative_liftA2 ?applicative_fmap -?monad_applicative_pure;
  repeat (rewrite applicative_identity     ||
          rewrite applicative_homomorphism ||
          rewrite applicative_interchange  ||
          rewrite -applicative_composition).

Ltac applicative_equal :=
  match goal with
    | |- (pure _    = pure _)    => f_equal
    | |- ((_ <*> _) = (_ <*> _)) => progress f_equal; applicative_equal
    | |- (_ = _)                 => idtac
  end.

Ltac applicative_normalize_equal :=
  applicative_normalize=> //; applicative_equal=> //; repeat funext=> ? //.

Ltac anf       := applicative_normalize.
Ltac anf_equal := applicative_normalize_equal.

Theorem mapBagM_ok'' {M A B} `{MonadLaws M} (f : A -> M B) (b : Bag A) :
  GHC.Base.fmap bagToList (mapBagM f b) = Data.Traversable.mapM f (bagToList b).
Proof.
  rewrite /Data.Traversable.mapM /Data.Traversable.mapM /Traversable.Traversable__list /Data.Traversable.mapM__ /=
          /Data.Traversable.Traversable__list_mapM
          /Data.Traversable.Traversable__list_traverse.
  replace (fmap bagToList (mapBagM f b)) with
          (_++_ <$> (fmap bagToList (mapBagM f b)) <*> pure [])
          by by anf_equal; unfold "∘"; rewrite app_nil_r.
  generalize (pure ([] : list B)) => z.
  elim: b z => [| x | l IHl r IHr | xs] z //=.
  - anf_equal.
  - rewrite applicative_liftA2 monad_bind_return_fmap; anf_equal.
  - rewrite bagToList_TwoBags foldr_app -IHl -IHr.
    setoid_rewrite ->monad_bind_return_fmap; setoid_rewrite ->monad_bind_fmap_ap.
    by anf_equal; unfold "∘"; rewrite bagToList_TwoBags app_assoc.
  - rewrite bagToList_ListBag
            /Data.Traversable.mapM /Data.Traversable.mapM /Traversable.Traversable__list /Data.Traversable.mapM__
            /Data.Traversable.Traversable__list_mapM
            /Data.Traversable.Traversable__list_traverse.
    rewrite monad_bind_return_fmap; anf.
    elim: xs => [|x xs /= <-];  anf_equal.
Qed.

  (* I forget what I was trying to do with this. —ASZ *)
Theorem mapBagM_ok''' {M A B} `{MonadLaws M} (f : A -> M B) (b : Bag A) :
  GHC.Base.fmap bagToList (mapBagM f b) = Data.Traversable.traverse f (bagToList b).
Proof.
(*
  rewrite /Data.Traversable.traverse /Traversable.Traversable__list /Data.Traversable.traverse__
         /= /Data.Traversable.Traversable__list_traverse.
  replace (fmap bagToList (mapBagM f b)) with
          (_++_ <$> (fmap bagToList (mapBagM f b)) <*> pure [])
          by by unfold "<$>";
                rewrite functor_composition !applicative_fmap applicative_interchange
                        -applicative_composition !applicative_homomorphism;
                do 2 f_equal; funext=> ?; unfold "∘"; rewrite app_nil_r.
  generalize (pure ([] : list B)) => z.
  elim: b z => [| x | l IHl r IHr | xs] z //=.
  - rewrite applicative_fmap -monad_applicative_pure applicative_homomorphism.
    unfold "<$>"; rewrite applicative_fmap applicative_homomorphism.
    replace [eta app _] with (@GHC.Base.id (list B)) by by funext.
    apply applicative_identity.
  - unfold "<$>". rewrite
      !applicative_fmap !monad_applicative_ap /ap !monad_applicative_pure.
 *)
Abort.

Lemma mapM_nil {M A B} `{MonadLaws M} (f : A -> M B):
  Traversable.mapM f [] = pure [].
Proof.
  by rewrite /Traversable.mapM /Traversable.Traversable__list /Traversable.mapM__.
Qed.

Lemma mapM_cons {M A B} `{MonadLaws M} (f : A -> M B) x xs:
  Traversable.mapM f (x::xs) = ((cons <$> f x) <*> Traversable.mapM f xs).
Proof.
  rewrite /Traversable.mapM /Traversable.Traversable__list /Traversable.mapM__.
  simpl.
  rewrite applicative_liftA2.
  reflexivity.
Qed.

Lemma mapM_app {M A B} `{MonadLaws M} (f : A -> M B) l1 l2:
  Traversable.mapM f (l1 ++ l2) = (app <$> Traversable.mapM f l1 <*> Traversable.mapM f l2).
Proof.
  intros. induction l1.
  * rewrite /Traversable.mapM /Traversable.Traversable__list /Traversable.mapM__.
    anf. reflexivity.
  * rewrite /= !mapM_cons IHl1.
    anf. reflexivity.
Qed.

Lemma monad_fmap_bind1 {M A B C} `{MonadLaws M} (f : B -> C) (a : M A) k:
  fmap f (a >>= k) = (a >>= (fun x => fmap f (k x))).
Proof.
  (* Get LHS into monad-only land *)
  rewrite !applicative_fmap !monad_applicative_ap /ap monad_applicative_pure.
  (* Clean up a bit *)
  rewrite monad_left_id -monad_composition.
  f_equal; funext; intros.
  (* Get RHS into monad-only land *)
  rewrite !applicative_fmap !monad_applicative_ap /ap monad_applicative_pure.
  rewrite monad_left_id.
  reflexivity.
Qed.

Lemma monad_fmap_bind2 {M A B C} `{MonadLaws M} (f : A -> B) (a : M A) (k : B -> M C):
  (fmap f a >>= k) = (a >>= (fun x => k (f x))).
Proof.
  (* Get LHS into monad-only land *)
  rewrite !applicative_fmap !monad_applicative_ap /ap monad_applicative_pure.
  (* Clean up a bit *)
  rewrite monad_left_id -monad_composition.
  f_equal; funext; intros.
  rewrite monad_left_id.
  reflexivity.
Qed.

Theorem mapMBag_ok''' {M A B} `{MonadLaws M} (f : A -> M B) (b : Bag A) :
  GHC.Base.fmap bagToList (mapBagM f b) = Data.Traversable.mapM f (bagToList b).
Proof.
  induction b.
  * rewrite /= emptyBag_ok mapM_nil -monad_applicative_pure.
    anf_equal.
  * rewrite /= monad_bind_return_fmap bagToList_UnitBag mapM_cons mapM_nil.
    anf_equal.
  * rewrite /= bagToList_TwoBags.
    rewrite monad_bind_return_fmap2.
    rewrite mapM_app.
    rewrite -IHb1 -IHb2.
    anf_equal.
    by rewrite /op_z2218U__ bagToList_TwoBags.
  * rewrite /= monad_bind_return_fmap bagToList_ListBag.
    anf_equal.
    replace (_∘_ bagToList Mk_ListBag) with (@id (list B)).
    anf_equal.
    funext; intros.
    by rewrite /op_z2218U__ bagToList_ListBag.
Qed.

(* TODO mapBagM_ mapAndUnzipBagM *)

(* we need to add that to MonadLaws *)
Axiom extra_monad_then_bind:
  forall {M A B} `{Monad M} (x:M A) (y: M B),
    (x >> y) = (x >>= (fun _ => y)).

Lemma fold_right_then {M A B} `{MonadLaws M}
      (x : M B) (l: list (M A)):
    fold_right _>>_ x l =
     _>>_ (fold_right _>>_ (return_ tt) l) x.
Proof.
  induction l; simpl.
  - rewrite extra_monad_then_bind.
    rewrite monad_left_id.
    reflexivity.
  - rewrite IHl.
    rewrite !extra_monad_then_bind.
    rewrite monad_composition.
    reflexivity.
Qed.

Theorem mapBagM_is_ok {M A B} `{MonadLaws M} (f : A -> M B) (b : Bag A) :
  (mapBagM_ f b) =
  Data.Foldable.mapM_ f (bagToList b).
Proof.
  rewrite /Data.Foldable.mapM_ /=
          /Foldable.Foldable__list_foldr
          /Foldable.foldr /Foldable.Foldable__list
          /Foldable.foldr__
          /Foldable.Foldable__list_foldr.
  induction b; simpl; try reflexivity.
  - rewrite bagToList_TwoBags foldr_app.
    rewrite -IHb2.
    rewrite !hs_coq_foldr_base -fold_right_map.
    rewrite fold_right_then.
    rewrite  fold_right_map -hs_coq_foldr_base.
    rewrite -IHb1. reflexivity.
  - rewrite /Foldable.mapM_
            hs_coq_foldr_list hs_coq_foldr_base.
    rewrite bagToList_ListBag. reflexivity.
Qed.

Theorem mapAndUnzipBagM_ok {M A B C} `{MonadLaws M}
        (f : A -> M (B*C)%type) (b : Bag A) :
  GHC.Base.fmap bagToList (GHC.Base.fmap (fst) (mapAndUnzipBagM f b)) =
  GHC.Base.fmap (map fst) (Data.Traversable.mapM f (bagToList b)) /\
  GHC.Base.fmap bagToList (GHC.Base.fmap (snd) (mapAndUnzipBagM f b)) =
  GHC.Base.fmap (map snd) (Data.Traversable.mapM f (bagToList b)).
Proof.
  rewrite
    /Data.Traversable.mapM
    /Traversable.Traversable__list
    /Data.Traversable.mapM__
    /Data.Traversable.Traversable__list_mapM
    /Data.Traversable.Traversable__list_traverse.
  induction b; simpl;
    [split; anf_equal | | |].
  - split;
      assert (Hr: (fun x : B * C =>
                   let (r, s) := x in
                   return_ (Mk_UnitBag r, Mk_UnitBag s)) =
                (fun x : B * C =>
                  return_ (Mk_UnitBag x.1, Mk_UnitBag x.2)));
      solve [funext;
             intros x;  destruct x;
             reflexivity |
             rewrite Hr;
             rewrite monad_bind_return_fmap;
             anf_equal].
  - destruct IHb1 as [IHb11 IHb12].
    destruct IHb2 as [IHb21 IHb22].
    rewrite bagToList_TwoBags.
    split.
    + assert (Hr: (fun x : Bag B * Bag C =>
         let (r1, s1) := x in
         mapAndUnzipBagM f b2 >>=
         (fun y: Bag B * Bag C =>
          let (r2, s2) := y in
          return_ (Mk_TwoBags r1 r2, Mk_TwoBags s1 s2))) =
         (fun x : Bag B * Bag C =>
         mapAndUnzipBagM f b2 >>=
         (fun y: Bag B * Bag C =>
          return_ (Mk_TwoBags x.1 y.1, Mk_TwoBags x.2 y.2))));
      try solve [funext; intros x; destruct x; f_equal;
                 funext; intros y; destruct y; reflexivity].
      rewrite Hr.
      rewrite monad_bind_return_fmap2.
      rewrite <- monad_bind_fmap_ap.
    (*  setoid_rewrite
      rewrite bagToList_TwoBags foldr_app -IHl -IHr.
    unfold "<$>"; rewrite !functor_composition.
    rewrite !applicative_fmap -!applicative_composition !applicative_homomorphism; f_equal.
    rewrite !applicative_interchange -!applicative_fmap functor_composition; do 2 f_equal.
    funext=> l'; funext=> r'; funext=> z'.
    by unfold "∘"; rewrite bagToList_TwoBags app_assoc.

*)
Admitted.

(* TODO foldrBagM foldlBagM *)
(*
Check foldrBagM.
Print GHC.Base.fmap.
Check mapBagM.
Search foldr.
*)
(*
Theorem foldrBagM_ok {M A B C} `{MonadLaws M}
        (f : A -> B -> M B) (d : B) (b : Bag A):
  (GHC.Base.fmap bagToList (foldrBagM f d b) =
  (fold_right f (bagToList b))).
Proof.

Admitted.
*)
(* TODO flatMapBagM flatMapBagPairM *)

(* TODO filterBagM *)

(* TODO anyBagM *)


From iris.algebra Require Export cmra.
From iris.algebra Require Import updates local_updates.
From stdpp Require Export collections coPset.
Set Default Proof Using "Type".
(** This is pretty much the same as algebra/gset, but I was not able to
generalize the construction without breaking canonical structures. *)

(* The union CMRA *)
Section coPset.
  Implicit Types X Y : coPset.

  Canonical Structure coPsetC := discreteC coPset.

  Instance coPset_valid : Valid coPset := λ _, True.
  Instance coPset_unit : Unit coPset := (∅ : coPset).
  Instance coPset_op : Op coPset := union.
  Instance coPset_pcore : PCore coPset := Some.

  Lemma coPset_op_union X Y : X ⋅ Y = X ∪ Y.
  Proof. done. Qed.
  Lemma coPset_core_self X : core X = X.
  Proof. done. Qed.
  Lemma coPset_included X Y : X ≼ Y ↔ X ⊆ Y.
  Proof.
    split.
    - intros [Z ->]. rewrite coPset_op_union. set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L. by exists Z.
  Qed.

  Lemma coPset_ra_mixin : RAMixin coPset.
  Proof.
    apply ra_total_mixin; eauto.
    - solve_proper.
    - solve_proper.
    - solve_proper.
    - intros X1 X2 X3. by rewrite !coPset_op_union assoc_L.
    - intros X1 X2. by rewrite !coPset_op_union comm_L.
    - intros X. by rewrite coPset_core_self idemp_L.
  Qed.
  Canonical Structure coPsetR := discreteR coPset coPset_ra_mixin.

  Global Instance coPset_cmra_discrete : CmraDiscrete coPsetR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma coPset_ucmra_mixin : UcmraMixin coPset.
  Proof. split. done. intros X. by rewrite coPset_op_union left_id_L. done. Qed.
  Canonical Structure coPsetUR := UcmraT coPset coPset_ucmra_mixin.

  Lemma coPset_opM X mY : X ⋅? mY = X ∪ default ∅ mY.
  Proof. destruct mY; by rewrite /= ?right_id_L. Qed.

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

  Lemma coPset_local_update X Y X' : X ⊆ X' → (X,Y) ~l~> (X',X').
  Proof.
    intros (Z&->&?)%subseteq_disjoint_union_L.
    rewrite local_update_unital_discrete=> Z' _ /leibniz_equiv_iff->.
    split. done. rewrite coPset_op_union. set_solver.
  Qed.
End coPset.

(* The disjoiny union CMRA *)
Inductive coPset_disj :=
  | CoPset : coPset → coPset_disj
  | CoPsetBot : coPset_disj.

Section coPset_disj.
  Arguments op _ _ !_ !_ /.
  Canonical Structure coPset_disjC := leibnizC coPset_disj.

  Instance coPset_disj_valid : Valid coPset_disj := λ X,
    match X with CoPset _ => True | CoPsetBot => False end.
  Instance coPset_disj_unit : Unit coPset_disj := CoPset ∅.
  Instance coPset_disj_op : Op coPset_disj := λ X Y,
    match X, Y with
    | CoPset X, CoPset Y => if decide (X ## Y) then CoPset (X ∪ Y) else CoPsetBot
    | _, _ => CoPsetBot
    end.
  Instance coPset_disj_pcore : PCore coPset_disj := λ _, Some ε.

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

  Lemma coPset_disj_included X Y : CoPset X ≼ CoPset Y ↔ X ⊆ Y.
  Proof.
    split.
    - move=> [[Z|]]; simpl; try case_decide; set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L.
      exists (CoPset Z). coPset_disj_solve.
  Qed.
  Lemma coPset_disj_valid_inv_l X Y :
    ✓ (CoPset X ⋅ Y) → ∃ Y', Y = CoPset Y' ∧ X ## Y'.
  Proof. destruct Y; repeat (simpl || case_decide); by eauto. Qed.
  Lemma coPset_disj_union X Y : X ## Y → CoPset X ⋅ CoPset Y = CoPset (X ∪ Y).
  Proof. intros. by rewrite /= decide_True. Qed.
  Lemma coPset_disj_valid_op X Y : ✓ (CoPset X ⋅ CoPset Y) ↔ X ## Y.
  Proof. simpl. case_decide; by split. Qed.

  Lemma coPset_disj_ra_mixin : RAMixin coPset_disj.
  Proof.
    apply ra_total_mixin; eauto.
    - intros [?|]; destruct 1; coPset_disj_solve.
    - by constructor.
    - by destruct 1.
    - intros [X1|] [X2|] [X3|]; coPset_disj_solve.
    - intros [X1|] [X2|]; coPset_disj_solve.
    - intros [X|]; coPset_disj_solve.
    - exists (CoPset ∅); coPset_disj_solve.
    - intros [X1|] [X2|]; coPset_disj_solve.
  Qed.
  Canonical Structure coPset_disjR := discreteR coPset_disj coPset_disj_ra_mixin.

  Global Instance coPset_disj_cmra_discrete : CmraDiscrete coPset_disjR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma coPset_disj_ucmra_mixin : UcmraMixin coPset_disj.
  Proof. split; try apply _ || done. intros [X|]; coPset_disj_solve. Qed.
  Canonical Structure coPset_disjUR := UcmraT coPset_disj coPset_disj_ucmra_mixin.
End coPset_disj.


Require Import Mutation.
Require Import MutationImpl.
Require Import Semantics_ConvAppl.
Require Import ReferencesImpl.
Require Import RefSetsAppl.
Require Import CapabilitiesAppl.
Require Import IndicesImpl.
Require Import ObjectsAppl.
Require Import SystemStateAppl.
Require Import SemanticsDefinitionsAppl.
Require Import SemanticsAppl.
Require Import ExecutionAppl.

Module NatMutation <:
  MutationType NatReference NatRefSet NatCapability NatIndex NatObject NatState NatSemDefns NatSemantics NatExecution :=
  MakeMutation NatReference NatRefSet NatCapability NatIndex NatObject NatState NatSemDefns NatSemantics NatExecution.


Require Import Coq.Sets.Ensembles.
Require Import Coq.Classes.Morphisms.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Definitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Precompute.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.FromAbstractInterpretationDefinitions.
Require Import Fiat.Common.List.ListMorphisms.

Set Implicit Arguments.
Local Coercion is_true : bool >-> Sortclass.
Local Open Scope list_scope.
Local Open Scope grammar_fixedpoint_scope.

Section general_fold.
  Context {Char : Type}
          {T0 T1 : Type}.
  Context {fpdata0 : @grammar_fixedpoint_lattice_data T0}
          {fpdata1 : @grammar_fixedpoint_lattice_data T1}.
  Context {aidata0 : AbstractInterpretation (Char:=Char) (fpdata:=fpdata0)}
          {aidata1 : AbstractInterpretation (Char:=Char) (fpdata:=fpdata1)}.

  Local Notation "R ==> S" := (respectful_hetero _ _ _ _ R (fun _ _ => S)) : signature_scope.
  Local Notation pointwise_relation T R := (fun f g => forall x : T, R (f x) (g x)).
  Local Notation Proper sig R := (sig%signature R R) (only parsing).

  Context (G : pregrammar' Char)
          (R : @state _ fpdata0 -> @state _ fpdata1 -> Prop)
          (R_bot : R ⊥ ⊥)
          (R_on_terminal : forall v, R (on_terminal v) (on_terminal v))
          (R_on_nil_production : R on_nil_production on_nil_production)
          (R_combine_production : Proper (R ==> R ==> R) combine_production)
          (R_lub : Proper (R ==> R ==> R) least_upper_bound).

  (*Lemma fold_item'_Proper_hetero
    : Proper (pointwise_relation _ R ==>  ==> R) (@fold_item').
  Proof.
    intros ?? H [?|?] ??; subst; simpl; trivial.
  Qed.

  Lemma fold_production'_Proper_hetero
    : Proper (pointwise_relation _ R ==> eq ==> R) (fold_production' G).
  Proof.
    clear -R_on_terminal R_on_nil_production R_combine_production.
    unfold fold_production'.
    intros ?? H ls x ?; subst x; simpl; trivial; [].
    induction ls as [|x xs IHxs]; trivial; [].
    simpl.
    apply R_combine_production; trivial; apply fold_item'_Proper_hetero; trivial.
  Qed.

  Lemma fold_productions'_Proper_hetero
    : Proper (pointwise_relation _ R ==> eq ==> R) (fold_productions' G).
  Proof.
    clear -R_on_terminal R_on_nil_production R_combine_production R_bot R_lub.
    unfold fold_productions'.
    intros ?? H ls x ?; subst x; simpl; trivial; [].
    induction ls as [|x xs IHxs]; trivial; [].
    simpl.
    apply R_lub; trivial; apply fold_production'_Proper_hetero; trivial.
  Qed.

  Lemma fold_constraints_Proper_hetero
    : Proper (pointwise_relation _ R ==> eq ==> R) (fold_constraints G).
  Proof.
    repeat intro; apply fold_productions'_Proper_hetero; repeat (trivial || subst).
  Qed.*)
End general_fold.


(** This file provides a construction to lift a PROP-level binary relation to
its reflexive transitive closure. *)
From iris.bi.lib Require Export fixpoint.
From iris.proofmode Require Import tactics.
From iris.prelude Require Import options.

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

Definition bi_rtc_pre `{!BiInternalEq PROP}
    {A : ofe} (R : A → A → PROP)
    (x2 : A) (rec : A → PROP) (x1 : A) : PROP :=
  (<affine> (x1 ≡ x2) ∨ ∃ x', R x1 x' ∗ rec x')%I.

Global Instance bi_rtc_pre_mono `{!BiInternalEq PROP}
    {A : ofe} (R : A → A → PROP) `{NonExpansive2 R} (x : A) :
  BiMonoPred (bi_rtc_pre R x).
Proof.
  constructor; [|solve_proper].
  iIntros (rec1 rec2) "#H". iIntros (x1) "[Hrec | Hrec]".
  { by iLeft. }
  iRight.
  iDestruct "Hrec" as (x') "[HP Hrec]".
  iDestruct ("H" with "Hrec") as "Hrec". eauto with iFrame.
Qed.

Definition bi_rtc `{!BiInternalEq PROP}
    {A : ofe} (R : A → A → PROP) (x1 x2 : A) : PROP :=
  bi_least_fixpoint (bi_rtc_pre R x2) x1.

Global Instance: Params (@bi_rtc) 3 := {}.
Typeclasses Opaque bi_rtc.

Global Instance bi_rtc_ne `{!BiInternalEq PROP} {A : ofe} (R : A → A → PROP) :
  NonExpansive2 (bi_rtc R).
Proof.
  intros n x1 x2 Hx y1 y2 Hy. rewrite /bi_rtc Hx. f_equiv=> rec z.
  solve_proper.
Qed.

Global Instance bi_rtc_proper `{!BiInternalEq PROP} {A : ofe} (R : A → A → PROP)
  : Proper ((≡) ==> (≡) ==> (⊣⊢)) (bi_rtc R).
Proof. apply ne_proper_2. apply _. Qed.

Section bi_rtc.
  Context `{!BiInternalEq PROP}.
  Context {A : ofe}.
  Context (R : A → A → PROP) `{NonExpansive2 R}.

  Lemma bi_rtc_unfold (x1 x2 : A) :
    bi_rtc R x1 x2 ≡ bi_rtc_pre R x2 (λ x1, bi_rtc R x1 x2) x1.
  Proof. by rewrite /bi_rtc; rewrite -least_fixpoint_unfold. Qed.

  Lemma bi_rtc_strong_ind_l x2 Φ :
    NonExpansive Φ →
    □ (∀ x1, <affine> (x1 ≡ x2) ∨ (∃ x', R x1 x' ∗ (Φ x' ∧ bi_rtc R x' x2)) -∗ Φ x1) -∗
    ∀ x1, bi_rtc R x1 x2 -∗ Φ x1.
 Proof.
    iIntros (?) "#IH". rewrite /bi_rtc.
    by iApply (least_fixpoint_strong_ind (bi_rtc_pre R x2) with "IH").
  Qed.

  Lemma bi_rtc_ind_l x2 Φ :
    NonExpansive Φ →
    □ (∀ x1, <affine> (x1 ≡ x2) ∨ (∃ x', R x1 x' ∗ Φ x') -∗ Φ x1) -∗
    ∀ x1, bi_rtc R x1 x2 -∗ Φ x1.
  Proof.
    iIntros (?) "#IH". rewrite /bi_rtc.
    by iApply (least_fixpoint_ind (bi_rtc_pre R x2) with "IH").
  Qed.

  Lemma bi_rtc_refl x : ⊢ bi_rtc R x x.
  Proof. rewrite bi_rtc_unfold. by iLeft. Qed.

  Lemma bi_rtc_l x1 x2 x3 : R x1 x2 -∗ bi_rtc R x2 x3 -∗ bi_rtc R x1 x3.
  Proof.
    iIntros "H1 H2".
    iEval (rewrite bi_rtc_unfold /bi_rtc_pre). iRight.
    iExists x2. iFrame.
  Qed.

  Lemma bi_rtc_once x1 x2 : R x1 x2 -∗ bi_rtc R x1 x2.
  Proof. iIntros "H". iApply (bi_rtc_l with "H"). iApply bi_rtc_refl. Qed.

  Lemma bi_rtc_trans x1 x2 x3 : bi_rtc R x1 x2 -∗ bi_rtc R x2 x3 -∗ bi_rtc R x1 x3.
  Proof.
    iRevert (x1).
    iApply bi_rtc_ind_l.
    { solve_proper. }
    iIntros "!>" (x1) "[H | H] H2".
    { by iRewrite "H". }
    iDestruct "H" as (x') "[H IH]".
    iApply (bi_rtc_l with "H").
    by iApply "IH".
  Qed.

End bi_rtc.


Require Export ComponentSM6.

Hint Resolve implies_wf_procs_procs2byz : comp.
Hint Resolve implies_are_procs_n_procs_procs2byz : comp.
Hint Rewrite @procs2byz_procs2byz : comp.
Hint Resolve wf_procs_implies_no_dup : comp.
Hint Resolve wf_procs_implies_ordered : comp.

Section ComponentSM9.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pd  : @Data }.
  Context { pn  : @Node }.
  Context { pk  : @Key }.
  Context { pat : @AuthTok }.
  Context { paf : @AuthFun pn pk pat pd }.
  Context { pm  : @Msg }.
  Context { pda : @DataAuth pd pn }.
  Context { cad : ContainedAuthData }.
  Context { gms : MsgStatus }.
  Context { dtc : @DTimeContext }.
  Context { qc  : @Quorum_context pn}.
  Context { iot : @IOTrustedFun }.

  Context { base_fun_io       : baseFunIO }.
  Context { base_state_fun    : baseStateFun }.
  Context { trusted_state_fun : trustedStateFun }.

  Lemma incr_n_proc_update_state_m :
    forall {n} {cn} (p : n_proc n cn) s,
      incr_n_proc (update_state_m p s)
      = update_state_m (incr_n_proc p) s.
  Proof.
    induction n; introv; simpl; tcsp.
  Qed.

  Lemma trusted_run_sm_on_inputs_incr_n_proc :
    forall {n} cn s (p : n_proc n (pre2trusted cn)) l,
      trusted_run_sm_on_inputs s (incr_n_proc p) l
      = trusted_run_sm_on_inputs s p l.
  Proof.
    introv.
    unfold trusted_run_sm_on_inputs.
    pose proof (snd_run_sm_on_inputs_incr_n_proc_eq l (update_state_m p s) []) as w.
    unfold decr_n_procs in w; simpl in w.
    rewrite incr_n_proc_update_state_m in w.
    simpl in *; rewrite w; clear w; tcsp.
  Qed.
  Hint Rewrite @trusted_run_sm_on_inputs_incr_n_proc : comp.

  Lemma implies_similar_subs_procs2byz :
    forall {n} (l k : n_procs n),
      similar_subs l k
      -> similar_subs (procs2byz l) (procs2byz k).
  Proof.
    introv sim; induction sim; simpl in *; tcsp.
    inversion simp; subst; simpl in *; GC.
    match goal with
    | [ H : context[p1] |- _ ] => rename H into h1
    end.
    match goal with
    | [ H : context[p2] |- _ ] => rename H into h2
    end.
    apply Eqdep.EqdepTheory.inj_pair2 in h1; subst; eauto 3 with comp.
    apply Eqdep.EqdepTheory.inj_pair2 in h2; subst; eauto 3 with comp.
    unfold is_trusted in *; simpl in *; dest_cases w.
  Qed.
  Hint Resolve implies_similar_subs_procs2byz : comp.

  Lemma M_byz_run_ls_on_this_one_event_preserves_subs_byz :
    forall {eo : EventOrdering} e {L S} (ls1 ls2 : LocalSystem L S),
      wf_procs ls1
      -> are_procs_n_procs ls1
      -> M_byz_run_ls_on_this_one_event ls1 e = ls2
      -> (wf_procs ls2
          /\ are_procs_n_procs ls2
          /\ similar_subs (procs2byz ls1) (procs2byz ls2)).
  Proof.
    introv wf aps run.
    unfold M_byz_run_ls_on_this_one_event in run; simpl in *.
    unfold M_byz_run_ls_on_one_event in run; simpl in *.
    remember (M_byz_run_ls_on_input ls1 (msg_comp_name S) (trigger e)) as h; repnd;
      simpl in *; subst; symmetry in Heqh.
    remember (trigger e) as trig.
    destruct trig; simpl in *; tcsp; GC.

    { pose proof (M_byz_run_ls_on_this_one_event_M_nt_preserves_subs e ls1 ls2) as q.
      repeat (autodimp q hyp).
      { unfold isCorrect, trigger_op; allrw <-; simpl; auto. }
      { unfold M_byz_run_ls_on_this_one_event, M_byz_run_ls_on_one_event.
        remember (M_byz_run_ls_on_input ls1 (msg_comp_name S) (trigger e)) as run; repnd; simpl in *.
        revert dependent run.
        rewrite <- Heqtrig; simpl; introv q.
        rewrite Heqh in q; ginv. }
      { repnd.
        dands; eauto 2 with comp. } }

    { destruct h; tcsp; ginv; dands; autorewrite with comp in *; eauto 3 with comp. }

    { unfold M_run_ls_on_trusted in Heqh.
      pose proof (M_run_ls_on_input_preserves_subs
                    (pre2trusted (it_name i))
                    (it_input i)
                    (procs2byz ls1)
                    ls2 h) as q.
      repeat (autodimp q hyp); eauto 3 with comp; repnd.
      apply implies_similar_subs_procs2byz in q2; autorewrite with comp in *.
      dands; auto; eauto 3 with comp. }
  Qed.

  Lemma M_byz_run_ls_before_event_preserves_subs_byz :
    forall {eo : EventOrdering} e {L S} (ls1 ls2 : LocalSystem L S),
      wf_procs ls1
      -> are_procs_n_procs ls1
      -> M_byz_run_ls_before_event ls1 e = ls2
      -> (wf_procs ls2
          /\ are_procs_n_procs ls2
          /\ similar_subs (procs2byz ls1) (procs2byz ls2)).
  Proof.
    intros eo e.
    induction e as [e ind] using predHappenedBeforeInd; introv wf aps run.
    rewrite M_byz_run_ls_before_event_unroll in run.

    destruct (dec_isFirst e) as [d|d]; ginv; auto;[|].
    { subst; dands; eauto 3 with comp. }

    remember (M_byz_run_ls_before_event ls1 (local_pred e)) as ls'; simpl in *; symmetry in Heqls'.
    pose proof (ind (local_pred e)) as ind; autodimp ind hyp; eauto 3 with eo;[].
    pose proof (ind L S ls1 ls') as ind.
    repeat (autodimp ind hyp); eauto 3 with eo; repnd;[].
    clear Heqls'.

    apply M_byz_run_ls_on_this_one_event_preserves_subs_byz in run; auto.
    repnd; dands; eauto 3 with comp.
  Qed.

  Lemma M_byz_run_ls_on_this_one_event_preserves_subs_byz2 :
    forall {eo : EventOrdering} e {L S} (ls1 ls2 : LocalSystem L S),
      wf_procs ls1
      -> are_procs_n_procs ls1
      -> M_byz_run_ls_on_this_one_event ls1 e = ls2
      -> (wf_procs ls2
          /\ are_procs_n_procs ls2
          /\ (similar_subs ls1 ls2 \/ similar_subs (procs2byz ls1) ls2)).
  Proof.
    introv wf aps run.
    unfold M_byz_run_ls_on_this_one_event in run; simpl in *.
    unfold M_byz_run_ls_on_one_event in run; simpl in *.
    remember (M_byz_run_ls_on_input ls1 (msg_comp_name S) (trigger e)) as h; repnd;
      simpl in *; subst; symmetry in Heqh.
    remember (trigger e) as trig.
    destruct trig; simpl in *; tcsp; GC.

    { pose proof (M_byz_run_ls_on_this_one_event_M_nt_preserves_subs e ls1 ls2) as q.
      repeat (autodimp q hyp).
      { unfold isCorrect, trigger_op; allrw <-; simpl; auto. }
      { unfold M_byz_run_ls_on_this_one_event, M_byz_run_ls_on_one_event.
        remember (M_byz_run_ls_on_input ls1 (msg_comp_name S) (trigger e)) as run; repnd; simpl in *.
        revert dependent run.
        rewrite <- Heqtrig; simpl; introv q.
        rewrite Heqh in q; ginv. }
      { repnd.
        dands; eauto 2 with comp. } }

    { destruct h; tcsp; ginv; dands; autorewrite with comp in *; eauto 3 with comp. }

    { unfold M_run_ls_on_trusted in Heqh.
      pose proof (M_run_ls_on_input_preserves_subs
                    (pre2trusted (it_name i))
                    (it_input i)
                    (procs2byz ls1)
                    ls2 h) as q.
      repeat (autodimp q hyp); eauto 3 with comp; repnd.
      applydup @implies_similar_subs_procs2byz in q2; autorewrite with comp in *.
      dands; auto; eauto 3 with comp. }
  Qed.

  Lemma M_byz_run_ls_before_event_preserves_subs_byz2 :
    forall {eo : EventOrdering} e {L S} (ls1 ls2 : LocalSystem L S),
      wf_procs ls1
      -> are_procs_n_procs ls1
      -> M_byz_run_ls_before_event ls1 e = ls2
      -> (wf_procs ls2
          /\ are_procs_n_procs ls2
          /\ (similar_subs ls1 ls2 \/ similar_subs (procs2byz ls1) ls2)).
  Proof.
    intros eo e.
    induction e as [e ind] using predHappenedBeforeInd; introv wf aps run.
    rewrite M_byz_run_ls_before_event_unroll in run.

    destruct (dec_isFirst e) as [d|d]; ginv; auto;[|].
    { subst; dands; eauto 3 with comp. }

    remember (M_byz_run_ls_before_event ls1 (local_pred e)) as ls'; simpl in *; symmetry in Heqls'.
    pose proof (ind (local_pred e)) as ind; autodimp ind hyp; eauto 3 with eo;[].
    pose proof (ind L S ls1 ls') as ind.
    repeat (autodimp ind hyp); eauto 3 with eo; repnd;[].
    clear Heqls'.

    apply M_byz_run_ls_on_this_one_event_preserves_subs_byz2 in run; auto.
    repnd; dands; eauto 3 with comp;[].

    repndors; tcsp; eauto 4 with comp.
    apply implies_similar_subs_procs2byz in ind; autorewrite with comp in *; eauto 3 with comp.
  Qed.

  Definition M_break_mon {n} {S}
             (sm   : M_n n S)
             (subs : n_procs n) : n_procs n :=
    M_break sm subs (fun subs' _ => subs').

  Definition M_break_out {n} {S}
             (sm   : M_n n S)
             (subs : n_procs n) : S :=
    M_break sm subs (fun _ out => out).

  Definition is_M_break_mon {n} {S}
             (sm    : M_n n S)
             (subs  : n_procs n)
             (subs' : n_procs n) :=
    M_break_mon sm subs = subs'.

  Definition is_M_break_out {n} {S}
             (sm   : M_n n S)
             (subs : n_procs n)
             (s    : S) :=
    M_break_out sm subs = s.

  Lemma fold_is_M_break_mon :
    forall {n} {S}
           (sm    : M_n n S)
           (subs  : n_procs n)
           (subs' : n_procs n),
      M_break_mon sm subs = subs'
      <-> is_M_break_mon sm subs subs'.
  Proof.
    tcsp.
  Qed.

  Lemma fold_is_M_break_out :
    forall {n} {S}
           (sm   : M_n n S)
           (subs : n_procs n)
           (s    : S),
      M_break_out sm subs = s
      <-> is_M_break_out sm subs s.
  Proof.
    tcsp.
  Qed.

  Lemma is_M_break_mon_preserves_subs :
    forall {n} {cn} (p : n_proc_at n cn) (l k : n_procs (S n)) i,
      wf_procs l
      -> is_proc_n_proc_at p
      -> are_procs_n_procs l
      -> is_M_break_mon (lift_M_1 (app_n_proc_at p i)) l k
      -> similar_subs l k.
  Proof.
    introv wf isp aps h.
    unfold is_M_break_mon, M_break_mon, M_break in h; simpl in h.

    pose proof (app_m_proc_some2 (at2sm p) i l) as q.
    simpl in q; repeat (autodimp q hyp); eauto 3 with comp.
    rewrite q in h; clear q.

    remember (sm_update p (sm_state p) i (select_n_procs n l)) as z;
      symmetry in Heqz; repnd; simpl in *; subst; simpl in *.
    fold (M_StateMachine n) in *; fold (n_proc n) in *; rewrite Heqz.

    pose proof (are_procs_implies_preserves_sub p (sm_state p) i (select_n_procs n l)) as h.
    repeat (autodimp h hyp); eauto 3 with comp;[].
    unfold M_break in h.
    rewrite Heqz in h; repnd.

    rewrite raise_to_n_procs_as_incr_n_procs.
    rewrite <- decr_n_procs_as_select_n_procs in h0.
    eapply similar_subs_trans;
      [|apply implies_similar_subs_app;
        [apply implies_similar_subs_remove_subs;[apply similar_subs_refl|eauto]
        |apply implies_similar_subs_incr_n_procs;eauto]
      ].
    rewrite @remove_subs_decr_n_procs_as_keep_highest_subs; eauto 3 with comp.
    pose proof (incr_n_procs_decr_n_procs_as_rm_highest l) as rm; simpl in *; rewrite rm; clear rm.
    rewrite <- split_as_rm_highest_keep_highest; eauto 3 with comp.
  Qed.

  Lemma implies_is_proc_n_proc_at_0 :
    forall (l : n_procs 1) {cn} (p : n_proc_at 0 cn),
      are_procs_n_procs l
      -> find_name cn l = Some (sm_or_at p)
      -> is_proc_n_proc_at (sm2p0 p).
  Proof.
    introv aps fn.
    apply @are_procs_n_procs_find_name in fn; auto.
  Qed.
  Hint Resolve implies_is_proc_n_proc_at_0 : comp.

  Lemma is_M_break_out_preserves_subs :
    forall {n} {cn} (p : n_proc_at n cn) (l : n_procs (S n)) i a b,
      is_proc_n_proc_at p
      -> is_M_break_out (lift_M_1 (app_n_proc_at p i)) l (a,b)
      -> exists q, a = Some q /\ similar_sms (at2sm p) q.
  Proof.
    introv isp h.
    unfold is_M_break_out, M_break_out, M_break in h; simpl in h.

    unfold lift_M_1, M_on_decr, app_n_proc_at, bind_pair, bind in h; simpl in h.
    remember (sm_update p (sm_state p) i (decr_n_procs l)) as z; symmetry in Heqz; repnd; simpl in *; ginv.

    unfold is_proc_n_proc_at in isp; exrepnd.
    rewrite isp0 in Heqz; simpl in *.
    unfold proc2upd in Heqz.
    rewrite interp_s_proc_as in Heqz.
    unfold bind_pair, bind in Heqz; simpl in *.

    remember (interp_proc (p0 (sm_state p) i) (decr_n_procs l)) as w; symmetry in Heqw; repnd; simpl in *.
    rewrite Heqw in Heqz; simpl in *; ginv.
    inversion Heqz; subst; simpl in *; tcsp.
    eexists; dands; eauto; simpl; tcsp.
  Qed.

  Lemma in_replace_name_implies :
    forall {n} {cn} (p : n_proc n cn) subs q,
      In q (replace_name p subs)
      -> q = MkPProc cn p \/ In q subs.
  Proof.
    induction subs; introv i; simpl in *; tcsp.
    destruct a; simpl in *; tcsp; dest_cases w; simpl in *; repndors; ginv; tcsp.
    apply IHsubs in i; repndors; subst; tcsp.
  Qed.

  Lemma implies_are_procs_n_procs_replace_name :
    forall {n} {cn} (subs : n_procs n) (p : n_proc n cn),
      are_procs_n_procs subs
      -> is_proc_n_proc p
      -> are_procs_n_procs (replace_name p subs).
  Proof.
    introv aps ips i.
    apply in_replace_name_implies in i; repndors; subst; tcsp.
  Qed.
  Hint Resolve implies_are_procs_n_procs_replace_name : comp.

  Lemma implies_similar_sms_sm_or_at :
    forall {cn} (p q : n_proc_at 0 cn),
      similar_sms_at p q
      -> similar_sms (at2sm p) (at2sm q).
  Proof.
    tcsp.
  Qed.

  Lemma similar_sms_at2sm_sm2p0 :
    forall {cn} (a : n_proc_at 0 cn) q,
      similar_sms (at2sm (sm2p0 a)) q
      -> exists b, q = at2sm b /\ similar_sms_at a b.
  Proof.
    introv h; simpl in *; destruct q; simpl in *; tcsp.
    exists a0; dands; auto.
  Qed.

  Definition has_sim_comp {cn} {n} (p : n_proc n cn) (ls : n_procs n) :=
    exists comp, find_name cn ls = Some comp /\ similar_sms comp p.

  Lemma similar_subs_replace_name_right :
    forall {n} {cn} (p : n_proc n cn) (subs1 subs2 : n_procs n),
      has_sim_comp p subs2
      -> similar_subs subs1 subs2
      -> similar_subs subs1 (replace_name p subs2).
  Proof.
    induction subs1; introv hc sim; destruct subs2; simpl in *; tcsp;
      inversion sim; subst; tcsp; clear sim.
    destruct n0 as [cn' p']; simpl in *; dest_cases w; subst; tcsp.

    { constructor; auto.
      unfold has_sim_comp in *; exrepnd; simpl in *; dest_cases w.
      rewrite (UIP_refl_CompName _ w) in hc1; simpl in *; ginv.
      eapply similar_procs_trans;eauto. }

    { constructor; auto.
      apply IHsubs1; auto.
      unfold has_sim_comp in *; exrepnd; simpl in *; dest_cases w; eauto. }
  Qed.

  Lemma similar_subs_preserves_has_sim_comp :
    forall {n} {cn} (p : n_proc n cn) (l k : n_procs n),
      similar_subs l k
      -> has_sim_comp p l
      -> has_sim_comp p k.
  Proof.
    introv sim h.
    unfold has_sim_comp in *; exrepnd.
    eapply ComponentSM.similar_subs_preserves_find_name in h1; eauto; exrepnd.
    exists s'; dands; eauto 3 with comp.
  Qed.
  Hint Resolve similar_subs_preserves_has_sim_comp : comp.

  Lemma similar_sms_at_preserves_has_sim_comp :
    forall {n} {cn} (a b : n_proc_at n cn) subs,
      similar_sms_at a b
      -> has_sim_comp (at2sm a) subs
      -> has_sim_comp (at2sm b) subs.
  Proof.
    introv sim h; unfold has_sim_comp in *; exrepnd.
    destruct comp; simpl in *; tcsp.
    eexists; dands; eauto; simpl; eauto 3 with comp.
  Qed.
  Hint Resolve similar_sms_at_preserves_has_sim_comp : comp.

  Lemma find_name_implies_has_sim_comp_at2sm :
    forall {cn} (a : n_proc_at 0 cn) (l : n_procs 1),
      find_name cn l = Some (sm_or_at a)
      -> has_sim_comp (at2sm a) l.
  Proof.
    introv h; eexists; dands; eauto; eauto 3 with comp.
  Qed.
  Hint Resolve find_name_implies_has_sim_comp_at2sm : comp.

  Lemma find_name_replace_name_diff :
    forall {cn1} {cn2} {n} (p : n_proc n cn2) l,
      cn1 <> cn2
      -> find_name cn1 (replace_name p l) = find_name cn1 l.
  Proof.
    induction l; introv d; simpl in *; tcsp.
    destruct a; simpl in *; tcsp; repeat (dest_cases w; subst; simpl in *; tcsp).
  Qed.
  Hint Resolve find_name_replace_name_diff : comp.

  Lemma implies_has_name_replace_name_same :
    forall {cn} {n} (p : n_proc n cn) l x,
      find_name cn l = Some x
      -> find_name cn (replace_name p l) = Some p.
  Proof.
    induction l; introv h; simpl in *; tcsp.
    destruct a; simpl in *; repeat (dest_cases w; subst; simpl in *; tcsp).
    { rewrite (UIP_refl_CompName _ w); tcsp. }
    eapply IHl; eauto.
  Qed.
  Hint Resolve implies_has_name_replace_name_same : comp.

  Lemma implies_has_simp_comp_replace_name_same :
    forall {cn} {n} (a b : n_proc n cn) l,
      has_sim_comp a l
      -> has_sim_comp b l
      -> has_sim_comp a (replace_name b l).
  Proof.
    introv h q.
    unfold has_sim_comp in *; exrepnd.
    rewrite h1 in q1; ginv.
    exists b; dands; eauto 3 with comp.
  Qed.
  Hint Resolve implies_has_simp_comp_replace_name_same : comp.

  Lemma implies_has_name_replace_name_diff :
    forall cn1 {cn2} {n} (p : n_proc n cn2) l x,
      cn1 <> cn2
      -> find_name cn1 l = Some x
      -> find_name cn1 (replace_name p l) = Some x.
  Proof.
    induction l; introv d h; simpl in *; tcsp.
    destruct a; simpl in *; repeat (dest_cases w; subst; simpl in *; tcsp).
    rewrite (UIP_refl_CompName _ w); tcsp.
  Qed.
  Hint Resolve implies_has_name_replace_name_diff : comp.

  Lemma implies_has_simp_comp_replace_name_diff :
    forall {cn1} {cn2} {n} (a : n_proc n cn1) (b : n_proc n cn2) l,
      cn1 <> cn2
      -> has_sim_comp a l
      -> has_sim_comp a (replace_name b l).
  Proof.
    introv h q.
    unfold has_sim_comp in *; exrepnd.
    exists comp; dands; eauto 3 with comp.
  Qed.
  Hint Resolve implies_has_simp_comp_replace_name_diff : comp.

  Lemma find_name_replace_name_same :
    forall {n} {cn} (p : n_proc n cn) l,
      has_comp cn l
      -> find_name cn (replace_name p l) = Some p.
  Proof.
    induction l; introv h; simpl in *; tcsp; unfold has_comp in *; exrepnd; simpl in *; tcsp.
    destruct a; simpl in *; tcsp; repeat (dest_cases w; subst; simpl in *; tcsp).
    { rewrite (UIP_refl_CompName _ w); tcsp. }
    apply IHl; eauto.
  Qed.
  Hint Resolve find_name_replace_name_same : comp.

  Lemma implies_has_comp_replace_name :
    forall cn' {n} {cn} (p : n_proc n cn) l,
      has_comp cn' l
      -> has_comp cn' (replace_name p l).
  Proof.
    induction l; introv h; unfold has_comp in *; exrepnd; simpl in *; tcsp.
    destruct a; simpl in *; repeat (dest_cases w; subst; simpl in *; tcsp; ginv); eauto.
  Qed.
  Hint Resolve implies_has_comp_replace_name : comp.

  Lemma at2sm_eq_sm_or_at_implies :
    forall {cn} (a b : n_proc_at 0 cn),
      at2sm a = sm_or_at b -> a = b.
  Proof.
    introv h; inversion h; auto.
  Qed.

  Lemma replace_name_twice :
    forall {n} {cn} (p q : n_proc n cn) l,
      replace_name p (replace_name q l) = replace_name p l.
  Proof.
    induction l; introv; simpl in *; tcsp.
    destruct a; simpl in *; tcsp; repeat (dest_cases w; subst; simpl in *; tcsp).
  Qed.
  Hint Rewrite @replace_name_twice : comp.

  Lemma lower_head_replace_name_twice :
    forall n {m} {cn} (p q : n_proc m cn) l,
      lower_head n (replace_name p (replace_name q l))
      = lower_head n (replace_name p l).
  Proof.
    introv; autorewrite with comp; auto.
  Qed.
  Hint Rewrite lower_head_replace_name_twice : comp.

  Lemma implies_wf_procs_replace_name_twice :
    forall {n} {cn} (p q : n_proc n cn) l,
      wf_procs (replace_name p l)
      -> wf_procs (replace_name p (replace_name q l)).
  Proof.
    introv; autorewrite with comp; auto.
  Qed.
  Hint Resolve implies_wf_procs_replace_name_twice : comp.

End ComponentSM9.

Hint Rewrite @replace_name_twice : comp.
Hint Rewrite @trusted_run_sm_on_inputs_incr_n_proc : comp.
Hint Rewrite @lower_head_replace_name_twice : comp.

Hint Resolve implies_similar_subs_procs2byz : comp.
Hint Resolve implies_is_proc_n_proc_at_0 : comp.
Hint Resolve implies_are_procs_n_procs_replace_name : comp.
Hint Resolve similar_subs_preserves_has_sim_comp : comp.
Hint Resolve similar_sms_at_preserves_has_sim_comp : comp.
Hint Resolve find_name_implies_has_sim_comp_at2sm : comp.
Hint Resolve find_name_replace_name_diff : comp.
Hint Resolve implies_has_name_replace_name_same : comp.
Hint Resolve implies_has_simp_comp_replace_name_same : comp.
Hint Resolve implies_has_name_replace_name_diff : comp.
Hint Resolve implies_has_simp_comp_replace_name_diff : comp.
Hint Resolve find_name_replace_name_same : comp.
Hint Resolve implies_has_comp_replace_name : comp.
Hint Resolve implies_wf_procs_replace_name_twice : comp.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive array
  (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (array a) :=
  (mk_array n (map.Map.const v:(map.Map.map Z a))).

(* Why3 goal *)
Theorem WP_parameter_max_sum : forall (a:Z) (n:Z), forall (a1:(map.Map.map Z
  Z)), ((0%Z <= a)%Z /\ ((n = a) /\ forall (i:Z), ((0%Z <= i)%Z /\
  (i < n)%Z) -> (0%Z <= (map.Map.get a1 i))%Z)) -> let o := (n - 1%Z)%Z in
  ((0%Z <= o)%Z -> forall (max:Z) (sum:Z), forall (i:Z), ((0%Z <= i)%Z /\
  (i <= o)%Z) -> ((sum <= (i * max)%Z)%Z -> (((0%Z <= i)%Z /\ (i < a)%Z) ->
  ((max < (map.Map.get a1 i))%Z -> (((0%Z <= i)%Z /\ (i < a)%Z) ->
  forall (max1:Z), (max1 = (map.Map.get a1 i)) -> (((0%Z <= i)%Z /\
  (i < a)%Z) -> forall (sum1:Z), (sum1 = (sum + (map.Map.get a1 i))%Z) ->
  (sum1 <= ((i + 1%Z)%Z * max1)%Z)%Z)))))).
intros a n a1 (h1,(h2,h3)) o h4 max sum i (h5,h6) h7 (h8,h9) h10
        (h11,h12) max1 h13 (h14,h15) sum1 h16.
subst o.
ring_simplify.
subst.
apply Zplus_le_compat_r.
apply Zle_trans with (i * max)%Z; auto.
auto with *.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal80.

From lfind Require Import LFind.
Lemma lfind_state  (y:lst):@eq lst (rev y) (append (rev y) Nil).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal80_rev_append_43_append_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (y:lst) :=
 let lfind_var := "y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print y lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.

Inductive insn :=
| Arg
| Self
| Deref (off : nat)
| Call
| MkConstr (tag : nat) (nargs : nat)
| Switch (cases : list (list insn))
| MkClose (f : function_name) (nfree : nat)
| OpaqueOp (op : opaque_oper_name) (nargs : nat)
.

Definition env := list (list insn).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    stack : list value
}.

Definition push f v :=
    Frame (arg f) (self f) (v :: stack f).

Definition pop f n :=
    Frame (arg f) (self f) (skipn n (stack f)).

Definition pop_push f n v :=
    push (pop f n) v.

Definition top f :=
    match stack f with
    | [] => Constr 0 []
    | v :: _ => v
    end.

Inductive cont :=
| Kret (code : list insn) (f : frame) (k : cont)
(* keeping the original `stk` lets us enforce that each branch pushes
 * exactly one value before running SContSwitch *)
| Kswitch (code : list insn) (stk : list value) (k : cont)
| Kstop.

Inductive state :=
| Run (i : list insn) (f : frame) (k : cont)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SArg : forall is f k,
        sstep E (Run (Arg :: is) f k)
                (Run is (push f (arg f)) k)
| SSelf : forall is f k,
        sstep E (Run (Self :: is) f k)
                (Run is (push f (self f)) k)

| SDerefinateConstr : forall off is f k  tag args v,
        length (stack f) >= 1 ->
        top f = Constr tag args ->
        nth_error args off = Some v ->
        sstep E (Run (Deref off :: is) f k)
                (Run is (pop_push f 1 v) k)
| SDerefinateClose : forall off is f k  fname free v,
        length (stack f) >= 1 ->
        top f = Close fname free ->
        nth_error free off = Some v ->
        sstep E (Run (Deref off :: is) f k)
                (Run is (pop_push f 1 v) k)

| SConstrDone : forall tag nargs is f k,
        length (stack f) >= nargs ->
        sstep E (Run (MkConstr tag nargs :: is) f k)
                (Run is (pop_push f nargs (Constr tag (rev (firstn nargs (stack f))))) k)
| SCloseDone : forall fname nfree is f k,
        length (stack f) >= nfree ->
        sstep E (Run (MkClose fname nfree :: is) f k)
                (Run is (pop_push f nfree (Close fname (rev (firstn nfree (stack f))))) k)
| SOpaqueOpDone : forall op nargs is f k v,
        length (stack f) >= nargs ->
        opaque_oper_denote_higher op (rev (firstn nargs (stack f))) = Some v ->
        sstep E (Run (OpaqueOp op nargs :: is) f k)
                (Run is (pop_push f nargs v) k)

| SMakeCall : forall is f k  fname free body,
        length (stack f) >= 2 ->
        nth_error (stack f) 1 = Some (Close fname free) ->
        nth_error E fname = Some body ->
        sstep E (Run (Call :: is) f k)
                (Run body (Frame (top f) (Close fname free) [])
                    (Kret is (pop f 2) k))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall cases is f k  tag args case,
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run (Switch cases :: is) f k)
                (Run case f (Kswitch is (stack f) k))

| SContRet : forall code f f' k,
        length (stack f) = 1 ->
        sstep E (Run [] f (Kret code f' k))
                (Run code (push f' (top f)) k)
| SContSwitch : forall code f stk k v,
        stack f = v :: stk ->
        sstep E (Run [] f (Kswitch code stk k))
                (Run code f k)
| SContStop : forall f,
        length (stack f) = 1 ->
        sstep E (Run [] f Kstop)
                (Stop (top f))
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 Kstop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition insn_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (i : insn) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        let fix go_list_list iss :=
            match iss as iss_ return Pll iss_ with
            | [] => Hnil2
            | is :: iss => Hcons2 is iss (go_list is) (go_list_list iss)
            end in
        match i as i_ return P i_ with
        | Arg => HArg
        | Self => HSelf
        | Deref off => HDeref off
        | Call => HCall
        | MkConstr tag nargs => HConstr tag nargs
        | Switch cases => HSwitch cases (go_list_list cases)
        | MkClose fname nfree => HClose fname nfree
        | OpaqueOp op nargs => HOpaqueOp op nargs
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition insn_ind' (P : insn -> Prop)
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Forall (Forall P) cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (i : insn) : P i :=
    ltac:(refine (@insn_rect_mut P (Forall P) (Forall (Forall P))
        HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp _ _ _ _ i); eauto).

Definition insn_list_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (is : list insn) : Pl is :=
    let go := insn_rect_mut P Pl Pll
            HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp
            Hnil Hcons Hnil2 Hcons2 in
    let fix go_list is :=
        match is as is_ return Pl is_ with
        | [] => Hnil
        | i :: is => Hcons i is (go i) (go_list is)
        end in go_list is.