(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-20011                            *)
(*                                                                      *)
(************************************************************************)

Require Import List.
Require Import Refl.
Require Import Bool.

Set Implicit Arguments.

  Inductive BFormula (A:Type) : Type :=
  | TT   : BFormula A
  | FF   : BFormula A
  | X : Prop -> BFormula A
  | A : A -> BFormula A
  | Cj  : BFormula A -> BFormula A -> BFormula A
  | D   : BFormula A-> BFormula A -> BFormula A
  | N  : BFormula A -> BFormula A
  | I : BFormula A-> BFormula A-> BFormula A.

  Fixpoint eval_f (A:Type)  (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop :=
    match f with
      | TT _ => True
      | FF _ => False
      | A a =>  ev a
      | X _ p => p
      | Cj e1 e2 => (eval_f  ev e1) /\ (eval_f ev e2)
      | D e1 e2  => (eval_f  ev e1) \/ (eval_f  ev e2)
      | N e     => ~ (eval_f  ev e)
      | I f1 f2 => (eval_f  ev f1) -> (eval_f  ev f2)
    end.

  Lemma eval_f_morph : forall  A (ev ev' : A -> Prop) (f : BFormula A),
    (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f).
  Proof.
    induction f ; simpl ; try tauto.
    intros.
    assert (H' := H a).
    auto.
  Qed.

  Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U :=
    match f with
      | TT _ => TT _
      | FF _ => FF _
      | X _ p => X _ p
      | A a => A (fct a)
      | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2)
      | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2)
      | N f     => N (map_bformula fct f)
      | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2)
    end.

  Lemma eval_f_map : forall T U (fct: T-> U) env f ,
    eval_f env  (map_bformula fct f)  = eval_f (fun x => env (fct x)) f.
  Proof.
    induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto.
    rewrite <- IHf.  auto.
  Qed.

  Lemma map_simpl : forall A B f l, @map A B f l = match l with
                                                 | nil => nil
                                                 | a :: l=> (f a) :: (@map A B f l)
                                               end.
  Proof.
    destruct l ; reflexivity.
  Qed.

  Section S.

    Variable Env   : Type.
    Variable Term  : Type.
    Variable eval  : Env -> Term -> Prop.
    Variable Term' : Type.
    Variable eval'  : Env -> Term' -> Prop.

    Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).

    Variable unsat : Term'  -> bool.

    Variable unsat_prop : forall t, unsat t  = true ->
      forall env, eval' env t -> False.

    Variable deduce : Term' -> Term' -> option Term'.

    Variable deduce_prop : forall env t t' u,
      eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u.

    Definition clause := list  Term'.
    Definition cnf := list clause.

    Variable normalise : Term -> cnf.
    Variable negate : Term -> cnf.

    Definition tt : cnf := @nil clause.
    Definition ff : cnf :=  cons (@nil Term') nil.

    Fixpoint add_term (t: Term') (cl : clause) : option clause :=
      match cl with
        | nil =>
          match deduce t t with
            | None =>  Some (t ::nil)
            | Some u => if unsat u then None else Some (t::nil)
          end
        | t'::cl =>
          match deduce t t' with
            | None =>
              match add_term t cl with
                | None => None
                | Some cl' => Some (t' :: cl')
              end
            | Some u =>
              if unsat u then None else
                match add_term t cl with
                  | None => None
                  | Some cl' => Some (t' :: cl')
                end
          end
      end.

    Fixpoint or_clause (cl1 cl2 : clause) : option clause :=
      match cl1 with
        | nil => Some cl2
        | t::cl => match add_term t cl2 with
                     | None => None
                     | Some cl' => or_clause cl cl'
                   end
      end.

(*    Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
      List.map (fun x => (t++x)) f. *)

    Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
      List.fold_right (fun e acc =>
        match or_clause t e with
          | None => acc
          | Some cl => cl :: acc
        end) nil f.

    Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
      match f with
        | nil => tt
        | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f')
      end.

    Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf :=
      f1 ++ f2.

    Fixpoint xcnf (pol : bool) (f : BFormula Term)  {struct f}: cnf :=
      match f with
        | TT _ => if pol then tt else ff
        | FF _ => if pol then ff else tt
        | X _ p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
        | A x => if pol then normalise x else negate x
        | N e  => xcnf (negb pol) e
        | Cj e1 e2 =>
          (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
        | D e1 e2  => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
        | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2)
      end.

    Definition eval_clause (env : Env) (cl : clause) := ~ make_conj  (eval' env) cl.

    Definition eval_cnf (env : Env) (f:cnf) := make_conj  (eval_clause  env) f.

    Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y.
    Proof.
      unfold eval_cnf.
      intros.
      rewrite make_conj_app in H ; auto.
    Qed.

    Definition eval_opt_clause (env : Env) (cl: option clause) :=
      match cl with
        | None => True
        | Some cl => eval_clause env cl
      end.

    Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl).
    Proof.
      induction cl.
      (* BC *)
      simpl.
      case_eq (deduce t t) ; auto.
      intros until 0.
      case_eq (unsat t0) ; auto.
      unfold eval_clause.
      rewrite make_conj_cons.
      intros. intro.
      apply unsat_prop with (1:= H) (env := env).
      apply deduce_prop with (3:= H0) ; tauto.
      (* IC *)
      simpl.
      case_eq (deduce t a).
      intro u.
      case_eq (unsat u).
      simpl. intros.
      unfold eval_clause.
      intro.
      apply unsat_prop  with (1:= H) (env:= env).
      repeat rewrite make_conj_cons in H2.
      apply deduce_prop with (3:= H0); tauto.
      intro.
      case_eq (add_term t cl) ; intros.
      simpl in H2.
      rewrite H0 in IHcl.
      simpl in IHcl.
      unfold eval_clause in *.
      intros.
      repeat rewrite make_conj_cons in *.
      tauto.
      rewrite H0 in IHcl ; simpl in *.
      unfold eval_clause in *.
      intros.
      repeat rewrite make_conj_cons in *.
      tauto.
      case_eq (add_term t cl) ; intros.
      simpl in H1.
      unfold eval_clause in *.
      repeat rewrite make_conj_cons in *.
      rewrite H in IHcl.
      simpl in IHcl.
      tauto.
      simpl in *.
      rewrite H in IHcl.
      simpl in IHcl.
      unfold eval_clause in *.
      repeat rewrite make_conj_cons in *.
      tauto.
    Qed.

  Lemma or_clause_correct : forall cl cl' env,  eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'.
  Proof.
    induction cl.
    simpl. tauto.
    intros until 0.
    simpl.
    assert (HH := add_term_correct env a cl').
    case_eq (add_term a cl').
    simpl in *.
    intros.
    apply IHcl in H0.
    rewrite H in HH.
    simpl in HH.
    unfold eval_clause in *.
    destruct H0.
    repeat rewrite make_conj_cons in *.
    tauto.
    apply HH in H0.
    apply not_make_conj_cons in H0 ; auto.
    repeat rewrite make_conj_cons in *.
    tauto.
    simpl.
    intros.
    rewrite H in HH.
    simpl in HH.
    unfold eval_clause in *.
    assert (HH' := HH Coq.Init.Logic.I).
    apply not_make_conj_cons in HH'; auto.
    repeat rewrite make_conj_cons in *.
    tauto.
  Qed.

  Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f).
  Proof.
    unfold eval_cnf.
    unfold or_clause_cnf.
    intros until t.
    set (F := (fun (e : clause) (acc : list clause) =>
         match or_clause t e with
         | Some cl => cl :: acc
         | None => acc
         end)).
    induction f.
    auto.
    (**)
    simpl.
    intros.
    destruct f.
    simpl in H.
    simpl in IHf.
    unfold F in H.
    revert H.
    intros.
    apply or_clause_correct.
    destruct (or_clause t a) ; simpl in * ; auto.
    unfold F in H at 1.
    revert H.
    assert (HH := or_clause_correct t a env).
    destruct (or_clause t a); simpl in HH ;
    rewrite make_conj_cons in * ; intuition.
    rewrite make_conj_cons in *.
    tauto.
  Qed.

 Lemma eval_cnf_cons : forall env a f,  (~ make_conj  (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f).
 Proof.
   intros.
   unfold eval_cnf in *.
   rewrite make_conj_cons ; eauto.
 Qed.

  Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env  f) \/ (eval_cnf  env f').
  Proof.
    induction f.
    unfold eval_cnf.
    simpl.
    tauto.
    (**)
    intros.
    simpl in H.
    destruct (eval_cnf_app _ _ _ H).
    clear H.
    destruct (IHf _ H0).
    destruct (or_clause_cnf_correct _ _ _ H1).
    left.
    apply eval_cnf_cons ; auto.
    right ; auto.
    right ; auto.
  Qed.

  Variable normalise_correct : forall env t, eval_cnf  env (normalise t) -> eval env t.

  Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t.

  Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f).
  Proof.
    induction f.
    (* TT *)
    unfold eval_cnf.
    simpl.
    destruct pol ; simpl ; auto.
    (* FF *)
    unfold eval_cnf.
    destruct pol; simpl ; auto.
    unfold eval_clause ; simpl.
    tauto.
    (* P *)
    simpl.
    destruct pol ; intros ;simpl.
    unfold eval_cnf in H.
    (* Here I have to drop the proposition *)
    simpl in H.
    unfold eval_clause in H ; simpl in H.
    tauto.
    (* Here, I could store P in the clause *)
    unfold eval_cnf in H;simpl in H.
    unfold eval_clause in H ; simpl in H.
    tauto.
    (* A *)
    simpl.
    destruct pol ; simpl.
    intros.
    apply normalise_correct  ; auto.
    (* A 2 *)
    intros.
    apply  negate_correct ; auto.
    auto.
    (* Cj *)
    destruct pol ; simpl.
    (* pol = true *)
    intros.
    unfold and_cnf in H.
    destruct (eval_cnf_app  _ _ _ H).
    clear H.
    split.
    apply (IHf1 _ _ H0).
    apply (IHf2 _ _ H1).
    (* pol = false *)
    intros.
    destruct (or_cnf_correct _ _ _ H).
    generalize (IHf1 false  env H0).
    simpl.
    tauto.
    generalize (IHf2 false  env H0).
    simpl.
    tauto.
    (* D *)
    simpl.
    destruct pol.
    (* pol = true *)
    intros.
    destruct (or_cnf_correct _ _ _ H).
    generalize (IHf1 _  env H0).
    simpl.
    tauto.
    generalize (IHf2 _  env H0).
    simpl.
    tauto.
    (* pol = true *)
    unfold and_cnf.
    intros.
    destruct (eval_cnf_app  _ _ _ H).
    clear H.
    simpl.
    generalize (IHf1 _ _ H0).
    generalize (IHf2 _ _ H1).
    simpl.
    tauto.
    (**)
    simpl.
    destruct pol ; simpl.
    intros.
    apply (IHf false) ; auto.
    intros.
    generalize (IHf _ _ H).
    tauto.
    (* I *)
    simpl; intros.
    destruct pol.
    simpl.
    intro.
    destruct (or_cnf_correct _ _ _ H).
    generalize (IHf1 _ _ H1).
    simpl in *.
    tauto.
    generalize (IHf2 _ _ H1).
    auto.
    (* pol = false *)
    unfold and_cnf in H.
    simpl in H.
    destruct (eval_cnf_app _ _ _ H).
    generalize (IHf1 _ _ H0).
    generalize (IHf2 _ _ H1).
    simpl.
    tauto.
  Qed.

  Variable Witness : Type.
  Variable checker : list Term' -> Witness -> bool.

  Variable checker_sound : forall t  w, checker t w = true -> forall env, make_impl (eval' env)  t False.

  Fixpoint cnf_checker (f : cnf) (l : list Witness)  {struct f}: bool :=
    match f with
      | nil => true
      | e::f => match l with
                  | nil => false
                  | c::l => match checker e c with
                              | true => cnf_checker f l
                              |   _  => false
                            end
                end
      end.

  Lemma cnf_checker_sound : forall t  w, cnf_checker t w = true -> forall env, eval_cnf  env  t.
  Proof.
    unfold eval_cnf.
    induction t.
    (* bc *)
    simpl.
    auto.
    (* ic *)
    simpl.
    destruct w.
    intros ; discriminate.
    case_eq (checker a w) ; intros ; try discriminate.
    generalize (@checker_sound _ _ H env).
    generalize (IHt _ H0 env) ; intros.
    destruct t.
    red ; intro.
    rewrite <- make_conj_impl in H2.
    tauto.
    rewrite <- make_conj_impl in H2.
    tauto.
  Qed.

  Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool :=
    cnf_checker (xcnf true f) w.

  Lemma tauto_checker_sound : forall t  w, tauto_checker t w = true -> forall env, eval_f  (eval env)  t.
  Proof.
    unfold tauto_checker.
    intros.
    change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)).
    apply (xcnf_correct t true).
    eapply cnf_checker_sound ; eauto.
  Qed.

End S.

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)


(** Camera of discardable fractions.

    This is a generalisation of the fractional camera where elements can
    represent both ownership of a fraction (as in the fractional camera) and the
    knowledge that a fraction has been discarded.

    Ownership of a fraction is denoted [DfracOwn q] and behaves identically to
    [q] of the fractional camera.

    Knowledge that a fraction has been discarded is denoted [DfracDiscarded].
    This elements is its own core, making ownership persistent.

    One can make a frame preserving update from _owning_ a fraction to _knowing_
    that the fraction has been discarded.

    Crucially, ownership over 1 is an exclusive element just as it is in the
    fractional camera. Hence owning 1 implies that no fraction has been
    discarded. Conversely, knowing that a fraction has been discarded implies
    that no one can own 1. And, since discarding is an irreversible operation,
    it also implies that no one can own 1 in the future *)
From stdpp Require Import countable.
From iris.algebra Require Export cmra.
From iris.algebra Require Import proofmode_classes updates frac.
From iris.prelude Require Import options.

(** An element of dfrac denotes ownership of a fraction, knowledge that a
    fraction has been discarded, or both. Note that [DfracBoth] can be written
    as [DfracOwn q ⋅ DfracDiscarded]. This should be used instead
    of [DfracBoth] which is for internal use only. *)
Inductive dfrac :=
  | DfracOwn : Qp → dfrac
  | DfracDiscarded : dfrac
  | DfracBoth : Qp → dfrac.

Section dfrac.
  Canonical Structure dfracO := leibnizO dfrac.

  Implicit Types p q : Qp.
  Implicit Types dp dq : dfrac.

  Global Instance dfrac_inhabited : Inhabited dfrac := populate DfracDiscarded.
  Global Instance dfrac_eq_dec : EqDecision dfrac.
  Proof. solve_decision. Defined.
  Global Instance dfrac_countable : Countable dfrac.
  Proof.
    set (enc dq := match dq with
      | DfracOwn q => inl q
      | DfracDiscarded => inr (inl ())
      | DfracBoth q => inr (inr q)
      end).
    set (dec y := Some match y with
      | inl q => DfracOwn q
      | inr (inl ()) => DfracDiscarded
      | inr (inr q) => DfracBoth q
      end).
    refine (inj_countable enc dec _). by intros [].
  Qed.

  Global Instance DfracOwn_inj : Inj (=) (=) DfracOwn.
  Proof. by injection 1. Qed.
  Global Instance DfracBoth_inj : Inj (=) (=) DfracBoth.
  Proof. by injection 1. Qed.

  (** An element is valid as long as the sum of its content is less than one. *)
  Local Instance dfrac_valid_instance : Valid dfrac := λ dq,
    match dq with
    | DfracOwn q => q ≤ 1
    | DfracDiscarded => True
    | DfracBoth q => q < 1
    end%Qp.

  (** As in the fractional camera the core is undefined for elements denoting
     ownership of a fraction. For elements denoting the knowledge that a fraction has
     been discarded the core is the identity function. *)
  Local Instance dfrac_pcore_instance : PCore dfrac := λ dq,
    match dq with
    | DfracOwn q => None
    | DfracDiscarded => Some DfracDiscarded
    | DfracBoth q => Some DfracDiscarded
    end.

  (** When elements are combined, ownership is added together and knowledge of
     discarded fractions is combined with the max operation. *)
  Local Instance dfrac_op_instance : Op dfrac := λ dq dp,
    match dq, dp with
    | DfracOwn q, DfracOwn q' => DfracOwn (q + q')
    | DfracOwn q, DfracDiscarded => DfracBoth q
    | DfracOwn q, DfracBoth q' => DfracBoth (q + q')
    | DfracDiscarded, DfracOwn q' => DfracBoth q'
    | DfracDiscarded, DfracDiscarded => DfracDiscarded
    | DfracDiscarded, DfracBoth q' => DfracBoth q'
    | DfracBoth q, DfracOwn q' => DfracBoth (q + q')
    | DfracBoth q, DfracDiscarded => DfracBoth q
    | DfracBoth q, DfracBoth q' => DfracBoth (q + q')
    end.

  Lemma dfrac_op_own q p : DfracOwn p ⋅ DfracOwn q = DfracOwn (p + q).
  Proof. done. Qed.

  Lemma dfrac_op_discarded :
    DfracDiscarded ⋅ DfracDiscarded = DfracDiscarded.
  Proof. done. Qed.

  Lemma dfrac_own_included q p : DfracOwn q ≼ DfracOwn p ↔ (q < p)%Qp.
  Proof.
    rewrite Qp_lt_sum. split.
    - rewrite /included /op /dfrac_op_instance. intros [[o| |?] [= ->]]. by exists o.
    - intros [o ->]. exists (DfracOwn o). by rewrite dfrac_op_own.
  Qed.

  (* [dfrac] does not have a unit so reflexivity is not for granted! *)
  Lemma dfrac_discarded_included :
    DfracDiscarded ≼ DfracDiscarded.
  Proof. exists DfracDiscarded. done. Qed.

  Definition dfrac_ra_mixin : RAMixin dfrac.
  Proof.
    split; try apply _.
    - intros [?| |?] ? dq <-; intros [= <-]; eexists _; done.
    - intros [?| |?] [?| |?] [?| |?];
        rewrite /op /dfrac_op_instance 1?assoc_L 1?assoc_L; done.
    - intros [?| |?] [?| |?];
        rewrite /op /dfrac_op_instance 1?(comm_L Qp_add); done.
    - intros [?| |?] dq; rewrite /pcore /dfrac_pcore_instance; intros [= <-];
        rewrite /op /dfrac_op_instance; done.
    - intros [?| |?] ? [= <-]; done.
    - intros [?| |?] [?| |?] ? [[?| |?] [=]] [= <-]; eexists _; split; try done;
        apply dfrac_discarded_included.
    - intros [q| |q] [q'| |q']; rewrite /op /dfrac_op_instance /valid /dfrac_valid_instance //.
      + intros. trans (q + q')%Qp; [|done]. apply Qp_le_add_l.
      + apply Qp_lt_le_incl.
      + intros. trans (q + q')%Qp; [|by apply Qp_lt_le_incl]. apply Qp_le_add_l.
      + intros. trans (q + q')%Qp; [|done]. apply Qp_lt_add_l.
      + intros. trans (q + q')%Qp; [|done]. apply Qp_lt_add_l.
  Qed.
  Canonical Structure dfracR := discreteR dfrac dfrac_ra_mixin.

  Global Instance dfrac_cmra_discrete : CmraDiscrete dfracR.
  Proof. apply discrete_cmra_discrete. Qed.

  Global Instance dfrac_full_exclusive : Exclusive (DfracOwn 1).
  Proof.
    intros [q| |q];
      rewrite /op /cmra_op -cmra_discrete_valid_iff /valid /cmra_valid //=.
    - apply Qp_not_add_le_l.
    - move=> /Qp_lt_le_incl. apply Qp_not_add_le_l.
  Qed.

  Global Instance dfrac_cancelable q : Cancelable (DfracOwn q).
  Proof.
    apply: discrete_cancelable.
    intros [q1| |q1][q2| |q2] _ [=]; simplify_eq/=; try done.
    - by destruct (Qp_add_id_free q q2).
    - by destruct (Qp_add_id_free q q1).
  Qed.
  Global Instance dfrac_own_id_free q : IdFree (DfracOwn q).
  Proof. intros [q'| |q'] _ [=]. by apply (Qp_add_id_free q q'). Qed.
  Global Instance dfrac_discarded_core_id : CoreId DfracDiscarded.
  Proof. by constructor. Qed.

  Lemma dfrac_valid_own p : ✓ DfracOwn p ↔ (p ≤ 1)%Qp.
  Proof. done. Qed.

  Lemma dfrac_valid_own_r dq q : ✓ (dq ⋅ DfracOwn q) → (q < 1)%Qp.
  Proof.
    destruct dq as [q'| |q']; [|done|].
    - apply Qp_lt_le_trans, Qp_lt_add_r.
    - intro Hlt. etrans; last apply Hlt. apply Qp_lt_add_r.
  Qed.

  Lemma dfrac_valid_own_l dq q : ✓ (DfracOwn q ⋅ dq) → (q < 1)%Qp.
  Proof. rewrite comm. apply dfrac_valid_own_r. Qed.

  Lemma dfrac_valid_discarded p : ✓ DfracDiscarded.
  Proof. done. Qed.

  Lemma dfrac_valid_own_discarded q :
    ✓ (DfracOwn q ⋅ DfracDiscarded) ↔ (q < 1)%Qp.
  Proof. done. Qed.

  Global Instance dfrac_is_op q q1 q2 :
    IsOp q q1 q2 →
    IsOp' (DfracOwn q) (DfracOwn q1) (DfracOwn q2).
  Proof. rewrite /IsOp' /IsOp dfrac_op_own=>-> //. Qed.

  (** Discarding a fraction is a frame preserving update. *)
  Lemma dfrac_discard_update dq : dq ~~> DfracDiscarded.
  Proof.
    intros n [[q'| |q']|]; rewrite -!cmra_discrete_valid_iff //=.
    - apply dfrac_valid_own_r.
    - apply cmra_valid_op_r.
  Qed.

End dfrac.


From isla Require Import opsem.

Definition a44 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 17%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x21" [] (RegVal_Base (Val_Symbolic 17%Z)) Mk_annot :t:
  Smt (DeclareConst 18%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x9" [] (RegVal_Base (Val_Symbolic 18%Z)) Mk_annot :t:
  Smt (DefineConst 19%Z (Binop ((Bvarith Bvsub)) (Val (Val_Symbolic 17%Z) Mk_annot) (Val (Val_Symbolic 18%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "x10" [] (RegVal_Base (Val_Symbolic 19%Z)) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Bicartesian.
Require Export Category.Structure.Closed.
Require Export Category.Structure.Distributive.

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

Section BiCCC.

Context {C : Category}.
Context `{@Cartesian C}.
Context `{@Cocartesian C}.
Context `{@Closed C _}.

Global Program Instance prod_coprod_l {x y z : C} :
  (* Products distribute over coproducts in every bicartesian closed
     category. *)
  (y + z) × x ≅ y × x + z × x := {
  to   := uncurry (curry inl ▽ curry inr);
  from := first inl ▽ first inr
}.
Next Obligation.
  rewrite <- !merge_comp.
  rewrite <- eval_first.
  rewrite <- !comp_assoc.
  rewrite <- !first_comp; cat.
Qed.
Next Obligation.
  rewrite uncurry_comp_r.
  apply curry_inj.
  rewrite curry_uncurry.
  rewrite <- merge_comp.
  rewrite <- !curry_comp; cat.
  rewrite <- !curry_id.
  rewrite merge_comp; cat.
Qed.

Hint Rewrite @prod_coprod_l : isos.

Lemma uncurry_merge {x y z w : C} (f : x ~> y^z) (g : w ~> y^z) :
  uncurry (f ▽ g) ≈ uncurry f ▽ uncurry g ∘ to prod_coprod_l.
Proof.
  simpl.
  apply curry_inj; cat.
  rewrite curry_comp; cat.
  rewrite <- merge_comp.
  apply merge_inv; split;
  rewrite <- curry_comp; cat.
Qed.

Corollary unmerge_uncurry {x y z w : C} (f : x ~> y^z) (g : w ~> y^z) :
  uncurry f ▽ uncurry g ≈ uncurry (f ▽ g) ∘ from prod_coprod_l.
Proof.
  rewrite uncurry_merge.
  rewrite <- comp_assoc.
  rewrite iso_to_from; cat.
Qed.

Global Program Instance prod_coprod_r {x y z : C} :
  (* Products distribute over coproducts in every bicartesian closed
     category. *)
  x × (y + z) ≅ x × y + x × z := {
  to   := uncurry (curry (inl ∘ swap) ▽ curry (inr ∘ swap)) ∘ swap;
  from := second inl ▽ second inr
}.
Next Obligation.
  rewrite <- !comp_assoc.
  rewrite <- !merge_comp.
  rewrite <- eval_first.
  rewrite <- !comp_assoc.
  rewrite !swap_second.
  rewrite !(comp_assoc (first _)).
  rewrite <- !first_comp; cat.
  rewrite !(comp_assoc eval).
  rewrite !eval_first; cat.
  rewrite <- !comp_assoc; cat.
Qed.
Next Obligation.
  rewrite uncurry_merge. simpl.
  rewrite !comp_assoc; cat.
  rewrite <- merge_comp.
  rewrite !comp_assoc; cat.
  rewrite <- !swap_first.
  rewrite merge_comp.
  rewrite <- !comp_assoc.
  apply swap_inj_l, swap_inj_r.
  rewrite comp_assoc.
  rewrite swap_invol, id_left, id_right.
  rewrite <- !comp_assoc.
  rewrite swap_invol, id_right.
  rewrite uncurry_comp_r.
  rewrite <- merge_comp.
  apply curry_inj.
  rewrite curry_uncurry.
  rewrite <- !curry_comp; cat.
  rewrite <- !curry_id.
  rewrite merge_comp; cat.
Qed.

Hint Rewrite @prod_coprod_r : isos.

Global Program Instance exp_coprod {x y z : C} :
  x^(y + z) ≅ x^y × x^z := {
  to   := curry (eval ∘ second inl) △ curry (eval ∘ second inr);
  from := curry (uncurry exl ▽ uncurry exr ∘ to prod_coprod_r)
}.
Next Obligation.
  rewrite <- fork_comp.
  rewrite <- fork_exl_exr.
  apply fork_inv; split;
  rewrite curry_comp_l;
  rewrite <- comp_assoc;
  rewrite <- first_second;
  rewrite comp_assoc;
  rewrite eval_first;
  rewrite uncurry_curry;
  rewrite <- !comp_assoc;
  rewrite swap_second;
  rewrite curry_comp;
  rewrite <- !eval_first;
  rewrite <- comp_assoc;
  rewrite (comp_assoc (first _));
  rewrite <- first_comp; cat;
  rewrite !eval_first;
  rewrite (comp_assoc eval);
  rewrite !eval_first; cat;
  rewrite <- comp_assoc; cat;
  rewrite <- curry_comp; cat.
Qed.
Next Obligation.
  remember (_ △ _) as p.
  enough (∀ {w : C} (f g : w ~> x^(y + z)), p ∘ f ≈ p ∘ g -> f ≈ g) as HA.
    apply HA.
    rewrite comp_assoc.
    rewrite Heqp.
    rewrite exp_coprod_obligation_1; cat.
  intros ??? e.
  rewrite Heqp in e.
  rewrite <- !fork_comp in e.
  apply fork_inv in e.
  destruct e as [HA HB].
  rewrite !curry_comp_l in HA.
  rewrite !curry_comp_l in HB.
  apply curry_inj in HA.
  apply curry_inj in HB.
  rewrite <- !comp_assoc in HA.
  rewrite <- !comp_assoc in HB.
  rewrite <- !first_second in HA.
  rewrite <- !first_second in HB.
  rewrite !comp_assoc in HA.
  rewrite !comp_assoc in HB.
  apply uncurry_inj.
  rewrite <- !eval_first.
  enough (∀ {w : C} (f g : w × (y + z) ~> x),
             f ∘ second inl ≈ g ∘ second inl ->
             f ∘ second inr ≈ g ∘ second inr -> f ≈ g) as HC.
    exact (HC _ _ _ HA HB).
  intros ? h i HD HE.
  unfold second in HD, HE.
  rewrite <- id_right.
  rewrite <- (id_right i).
  rewrite <- (iso_from_to prod_coprod_r).
  simpl.
  rewrite !comp_assoc.
  rewrite <- !merge_comp.
  rewrites.
  reflexivity.
Qed.

Hint Rewrite @exp_coprod : isos.

Context `{@Initial C}.

Global Program Instance prod_zero_l {x : C} :
  0 × x ≅ 0 := {
  to   := uncurry zero;
  from := zero
}.
Next Obligation. apply curry_inj; simpl; cat. Qed.

Hint Rewrite @prod_zero_l : isos.

Global Program Instance prod_zero_r {x : C} :
  x × 0 ≅ 0 := {
  to   := uncurry zero ∘ swap;
  from := zero
}.
Next Obligation. apply swap_inj_r, curry_inj; simpl; cat. Qed.

Hint Rewrite @prod_zero_r : isos.

Context `{@Terminal C}.

Global Program Instance exp_zero {x : C} :
  x^0 ≅ 1 := {
  to   := one;
  from := curry (zero ∘ to prod_zero_r)
}.
Next Obligation.
  apply uncurry_inj.
  apply swap_inj_r.
  apply curry_inj; simpl; cat.
Qed.

End BiCCC.

Program Instance BiCCC_Distributive {C : Category}
        `{@Cartesian C} `{@Cocartesian C} `{@Closed C _} `{@Initial C} :
  @Distributive C _ _ _.


(** This file proves the basic laws of the HeapLang program logic by applying
the Iris lifting lemmas. *)

From iris.proofmode Require Import proofmode.
From iris.bi.lib Require Import fractional.
From transfinite.base_logic.lib Require Import mono_nat.
From transfinite.base_logic.lib Require Export gen_heap gen_inv_heap.
From melocoton.language Require Export weakestpre lifting.
From melocoton.ml_lang Require Export lang_instantiation class_instances.
From melocoton.ml_lang Require Import tactics notation.
From iris.prelude Require Import options.
From melocoton Require Import monotone.

Class heapGpre_ML {SI:indexT} Σ := HeapGpre_ML {
  heapGpre_gen_heapGpre :> gen_heapPreG loc (option (list val)) Σ;
}.

Class heapG_ML `{SI: indexT} Σ := HeapG_ML {
  heapG_gen_heapG :> gen_heapG loc (option (list val)) Σ;
}.

Definition heapΣ_ML {SI: indexT} : gFunctors :=
  #[gen_heapΣ loc (option (list val))].

Global Instance subG_heapGpre_ML `{SI: indexT} Σ : subG heapΣ_ML Σ → heapGpre_ML Σ.
Proof. solve_inG. Qed.

Local Notation state := (gmap loc (option (list val))).

Global Program Instance heapG_langG_ML `{SI: indexT}`{heapG_ML Σ}
      : langG val ML_lang Σ := {
  state_interp σ := gen_heap_interp σ
}.

Notation "l ↦M{ dq } v" := (mapsto (L:=loc) (V:=option (list val)) l dq (Some [v%MLV]))
  (at level 20, format "l  ↦M{ dq }  v") : bi_scope.
Notation "l ↦M□ v" := (mapsto (L:=loc) (V:=option (list val)) l DfracDiscarded (Some [v%MLV]))
  (at level 20, format "l  ↦M□  v") : bi_scope.
Notation "l ↦M{# q } v" := (mapsto (L:=loc) (V:=option (list val)) l (DfracOwn q) (Some [v%MLV]))
  (at level 20, format "l  ↦M{# q }  v") : bi_scope.
Notation "l ↦M v" := (mapsto (L:=loc) (V:=option (list val)) l (DfracOwn 1) (Some [v%MLV]))
  (at level 20, format "l  ↦M  v") : bi_scope.

Notation "l ↦M/{ dq }" := (mapsto (L:=loc) (V:=option (list val)) l dq None)
  (at level 20, format "l  ↦M/{ dq } ") : bi_scope.
Notation "l ↦M/□" := (mapsto (L:=loc) (V:=option (list val)) l DfracDiscarded None)
  (at level 20, format "l  ↦M/□") : bi_scope.
Notation "l ↦M/{# q }" := (mapsto (L:=loc) (V:=option (list val)) l (DfracOwn q) None)
  (at level 20, format "l  ↦M/{# q }") : bi_scope.
Notation "l ↦M/" := (mapsto (L:=loc) (V:=option (list val)) l (DfracOwn 1) None)
  (at level 20, format "l  ↦M/") : bi_scope.

Notation "l ↦∗{ dq } vs" := (mapsto (L:=loc) (V:=option (list val)) l dq (Some vs))
  (at level 20, format "l  ↦∗{ dq }  vs") : bi_scope.
Notation "l ↦∗□ vs" := (mapsto (L:=loc) (V:=option (list val)) l DfracDiscarded (Some vs))
  (at level 20, format "l  ↦∗□  vs") : bi_scope.
Notation "l ↦∗{# q } vs" := (mapsto (L:=loc) (V:=option (list val)) l (DfracOwn q) (Some vs))
  (at level 20, format "l  ↦∗{# q }  vs") : bi_scope.
Notation "l ↦∗ vs" := (mapsto (L:=loc) (V:=option (list val)) l (DfracOwn 1) (Some vs))
  (at level 20, format "l  ↦∗  vs") : bi_scope.

Global Instance: Params (@inv_mapsto_own) 5 := {}.
Global Instance: Params (@inv_mapsto) 4 := {}.

Notation inv_heap_inv := (inv_heap_inv loc (option (list val))).
Notation "l '↦∗_' I □" := (inv_mapsto l I%stdpp%type)
  (at level 20, I at level 9, format "l  '↦∗_' I  '□'") : bi_scope.
Notation "l ↦∗_ I vs" := (inv_mapsto_own l vs I%stdpp%type)
  (at level 20, I at level 9, format "l  ↦∗_ I  vs") : bi_scope.

Section lifting.
Context `{SI: indexT}.
Context `{!heapG_ML Σ, !invG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ Ψ : val → iProp Σ.
Implicit Types σ : state.
Implicit Types v : val.
Implicit Types vs : list val.
Implicit Types l : loc.
Implicit Types pe : prog_environ ML_lang Σ.

(** Recursive functions: we do not use this lemmas as it is easier to use Löb
induction directly, but this demonstrates that we can state the expected
reasoning principle for recursive functions, without any visible ▷. *)
Lemma wp_rec_löb pe E f x e Φ Ψ :
  □ ( □ (∀ v, Ψ v -∗ WP (rec: f x := e)%MLV v @ pe; E {{ Φ }}) -∗
     ∀ v, Ψ v -∗ WP (subst' x v (subst' f (rec: f x := e)%MLV e))%MLE @ pe; E {{ Φ }}) -∗
  ∀ v, Ψ v -∗ WP (rec: f x := e)%MLV v @ pe; E {{ Φ }}.
Proof.
  iIntros "#Hrec". iLöb as "IH". iIntros (v) "HΨ".
  iApply lifting.wp_pure_step_later; first eauto.
  iIntros "!>". iApply ("Hrec" with "[] HΨ"). iIntros "!>" (w) "HΨ".
  iApply ("IH" with "HΨ").
Qed.

(** Heap *)

(** We need to adjust the [gen_heap] and [gen_inv_heap] lemmas because of our
value type being [val]. *)

Lemma mapsto_valid l dq v : l ↦M{dq} v -∗ ⌜✓ dq⌝.
Proof. apply mapsto_valid. Qed.
Lemma mapsto_valid_2 l dq1 dq2 v1 v2 :
  l ↦M{dq1} v1 -∗ l ↦M{dq2} v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
Proof.
  iIntros "H1 H2". iDestruct (mapsto_valid_2 with "H1 H2") as %[? [=?]]. done.
Qed.
Lemma mapsto_agree l dq1 dq2 v1 v2 : l ↦M{dq1} v1 -∗ l ↦M{dq2} v2 -∗ ⌜v1 = v2⌝.
Proof. iIntros "H1 H2". iDestruct (mapsto_agree with "H1 H2") as %[=?]. done. Qed.

Lemma mapsto_combine l dq1 dq2 v1 v2 :
  l ↦M{dq1} v1 -∗ l ↦M{dq2} v2 -∗ l ↦M{dq1 ⋅ dq2} v1 ∗ ⌜v1 = v2⌝.
Proof.
  iIntros "Hl1 Hl2". iDestruct (mapsto_combine with "Hl1 Hl2") as "[$ Heq]".
  by iDestruct "Heq" as %[= ->].
Qed.

Lemma mapsto_frac_ne l1 l2 dq1 dq2 v1 v2 :
  ¬ ✓(dq1 ⋅ dq2) → l1 ↦M{dq1} v1 -∗ l2 ↦M{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
Proof. apply mapsto_frac_ne. Qed.
Lemma mapsto_ne l1 l2 dq2 v1 v2 : l1 ↦M v1 -∗ l2 ↦M{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
Proof. apply mapsto_ne. Qed.

Lemma mapsto_persist l dq v : l ↦M{dq} v ==∗ l ↦M□ v.
Proof. apply mapsto_persist. Qed.

Lemma wp_allocN pe E v n :
  (0 ≤ n)%Z →
  {{{ True }}} AllocN (Val $ LitV $ LitInt n) (Val v) @ pe; E
  {{{ l, RET LitV (LitLoc l); l ↦∗ (replicate (Z.to_nat n) v) ∗ meta_token l ⊤ }}}.
Proof.
  iIntros (Hn Φ) "_ HΦ". iApply wp_lift_atomic_head_step; first done.
  iIntros (σ1) "Hσ". iModIntro. iSplit; first (destruct n; eauto with lia head_step).
  iIntros (v2 σ2 Hstep). inv_head_step; last lia. iModIntro.
  iMod (gen_heap_alloc _ l (Some (replicate (Z.to_nat n) v)) with "Hσ") as "(Hσ & Hl & Hm)".
  { by apply not_elem_of_dom. }
  iModIntro. iFrame. iApply "HΦ"; iFrame.
Qed.

Lemma wp_alloc pe E v :
  {{{ True }}} Alloc (Val v) @ pe; E
  {{{ l, RET LitV (LitLoc l); l ↦M v ∗ meta_token l ⊤ }}}.
Proof.
  iIntros (HΦ) "_ HΦ". by iApply wp_allocN.
Qed.

Lemma wp_allocN_wrong_size pe E v n :
  (n < 0)%Z →
  {{{ True }}} AllocN (Val $ LitV $ LitInt n) (Val v) @ pe; E
  {{{ RET v; False }}}.
Proof.
  iIntros (Hn Φ) "_ HΦ". iLöb as "IH".
  iApply wp_lift_step_fupd; first done.
  iIntros (σ1) "Hσ !>". iSplit.
  { iPureIntro. eapply head_prim_reducible. eexists _, _.
    by eapply AllocNWrongSizeS. }
  iIntros (v2 σ2 Hstep).
  eapply head_reducible_prim_step in Hstep; first (inv_head_step; first lia).
  2: { eexists _, _. by eapply AllocNWrongSizeS. }
  do 4 iModIntro. iFrame. by iApply "IH".
Qed.

Lemma wp_loadN pe E l i dq vs v :
  (0 ≤ i)%Z →
  vs !! Z.to_nat i = Some v →
  {{{ ▷ l ↦∗{dq} vs }}} LoadN (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i) @ pe; E
  {{{ RET v; l ↦∗{dq} vs }}}.
Proof.
  iIntros (Hi Hv Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step; first done.
  iIntros (σ1) "Hσ !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  assert (σ1 !! l.[i] = Some v).
  { rewrite store_lookup_eq. case_bool_decide; [|done]. by simplify_map_eq/=. }
  iSplit; first by eauto with head_step.
  iIntros (v2 σ2 Hstep); inv_head_step. iNext. iModIntro. iFrame.
  by iApply "HΦ".
Qed.

Lemma wp_loadN_oob pe E l i dq vs :
  (i < 0 ∨ length vs ≤ i)%Z →
  {{{ ▷ l ↦∗{dq} vs }}} LoadN (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i) @ pe; E
  {{{ v, RET v; False }}}.
Proof.
  iIntros (Hi Φ) ">Hl HΦ". iLöb as "IH".
  iApply wp_lift_step_fupd; first done.
  iIntros (σ1) "Hσ !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  assert (σ1 !! l.[i] = None).
  { rewrite store_lookup_eq. case_bool_decide; [|done]. simplify_map_eq/=.
    destruct Hi; try lia. apply lookup_ge_None_2; lia. }
  iSplit. { iPureIntro. eapply head_prim_reducible. eexists _, _. by eapply LoadNOobS. }
  iIntros (v2 σ2 Hstep).
  eapply head_reducible_prim_step in Hstep; first inv_head_step.
  2: { eexists _, _; by eapply LoadNOobS. }
  do 4 iModIntro. iFrame. by iApply ("IH" with "[$] [$]").
Qed.

Lemma wp_load pe E l dq v :
  {{{ ▷ l ↦M{dq} v }}} Load (Val $ LitV $ LitLoc l) @ pe; E
  {{{ RET v; l ↦M{dq} v }}}.
Proof.
  iIntros (Φ) ">Hl HΦ". iApply (wp_loadN with "Hl"); try done.
Qed.

Lemma wp_storeN pe E l i vs w :
  (0 ≤ i < length vs)%Z →
  {{{ ▷ l ↦∗ vs }}} StoreN (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i) (Val w) @ pe; E
  {{{ RET LitV LitUnit; l ↦∗ <[ Z.to_nat i := w ]> vs }}}.
Proof.
  iIntros (Hi Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step; first done.
  iIntros (σ1) "Hσ !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  assert (is_Some (σ1 !! l.[i])) as [? ?].
  { rewrite store_lookup_eq. case_bool_decide; [|lia]. simplify_map_eq.
    apply lookup_lt_is_Some. lia. }
  iSplit; first by eauto with head_step.
  iIntros (v2 σ2 Hstep); inv_head_step. iModIntro.
  iMod (gen_heap_update with "Hσ Hl") as "[Hσ Hl]".
  rewrite (store_insert_offset _ _ _ vs); auto; [].
  iModIntro. iFrame "Hσ". iApply "HΦ". iApply "Hl".
Qed.

Lemma wp_storeN_oob pe E l i vs w :
  (i < 0 ∨ length vs ≤ i)%Z →
  {{{ ▷ l ↦∗ vs }}} StoreN (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i) (Val w) @ pe; E
  {{{ v, RET v; False }}}.
Proof.
  iIntros (Hi Φ) ">Hl HΦ". iLöb as "IH".
  iApply wp_lift_step_fupd; first done.
  iIntros (σ1) "Hσ !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  assert (σ1 !! l.[i] = None).
  { rewrite store_lookup_eq. case_bool_decide; [|done]. simplify_map_eq/=.
    destruct Hi; try lia. apply lookup_ge_None_2; lia. }
  iSplit. { iPureIntro. eapply head_prim_reducible. eexists _, _. by eapply StoreNOobS. }
  iIntros (v2 σ2 Hstep).
  eapply head_reducible_prim_step in Hstep; first inv_head_step.
  2: { eexists _, _; by eapply StoreNOobS. }
  do 4 iModIntro. iFrame.
  iApply ("IH" with "[$] [$]").
Qed.

Lemma wp_store pe E l v w :
  {{{ ▷ l ↦M v }}} Store (Val $ LitV $ LitLoc l) (Val w) @ pe; E
  {{{ RET LitV LitUnit; l ↦M w }}}.
Proof.
  iIntros (Φ) "Hl HΦ". by iApply (wp_storeN with "Hl").
Qed.

Lemma wp_length pe E l dq vs :
  {{{ ▷ l ↦∗{dq} vs }}} Length (Val $ LitV $ LitLoc l) @ pe; E
  {{{ RET LitV $ LitInt (length vs); l ↦∗{dq} vs }}}.
Proof.
  iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step; first done.
  iIntros (σ1) "Hσ !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (v2 σ2 Hstep); inv_head_step. do 2 iModIntro.
  iFrame. by iApply "HΦ".
Qed.

(* TODO: rules to allow splitting the ownership of an array, and having the
   knowledge of the length of an array be persistent, following what is done in
   Cosmo. *)

End lifting.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 2 *)

Require Import Frap.

Set Implicit Arguments.

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang (wangpeng@csail.mit.edu) *)

(* Note: the 6887psets GitHub repository has a 'pset2' directory that contains a full template of the solution, including Makefile, _CoqProject, and a Pset2.v file with admits.
*)

(* A copy of the parallel transition-system combinator from TransitionSystem.v *)

Record threaded_state shared private := {
  Shared : shared;
  Private : private
}.

Inductive parallel1 shared private1 private2
  (init1 : threaded_state shared private1 -> Prop)
  (init2 : threaded_state shared private2 -> Prop)
  : threaded_state shared (private1 * private2) -> Prop :=
| Pinit : forall sh pr1 pr2,
  init1 {| Shared := sh; Private := pr1 |}
  -> init2 {| Shared := sh; Private := pr2 |}
  -> parallel1 init1 init2 {| Shared := sh; Private := (pr1, pr2) |}.

Inductive parallel2 shared private1 private2
          (step1 : threaded_state shared private1 -> threaded_state shared private1 -> Prop)
          (step2 : threaded_state shared private2 -> threaded_state shared private2 -> Prop)
          : threaded_state shared (private1 * private2)
            -> threaded_state shared (private1 * private2) -> Prop :=
| Pstep1 : forall sh pr1 pr2 sh' pr1',
  (* First thread gets to run. *)
  step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1', pr2) |}
| Pstep2 : forall sh pr1 pr2 sh' pr2',
  (* Second thread gets to run. *)
  step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1, pr2') |}.

Definition parallel shared private1 private2
           (sys1 : trsys (threaded_state shared private1))
           (sys2 : trsys (threaded_state shared private2)) := {|
  Initial := parallel1 sys1.(Initial) sys2.(Initial);
  Step := parallel2 sys1.(Step) sys2.(Step)
|}.

(* Now, we come to the main problem to be solved: prove the correctness of a
 * famous locking algorithm, applied to the particular example of incrementing a
 * counter from the lecture code.  Instead of assuming that a correct
 * implementation of locking is provided to us, we provide our own, on top of
 * basic atomic read/write operations on shared variables!
 * Specifically, we use Peterson's Algorithm, which you can read about here:
 *   https://en.wikipedia.org/wiki/Peterson%27s_algorithm *)

(** Instantiated to our setting, it's equivalent to this code.

  bool flag[2] = {false, false};
  bool turn = false;
  int global = 0;

  oneThread(me, other) {
    int local;

    flag[me] = true;
    turn = other;
    while (flag[other] && turn == other);
    local = global;
    global = local + 1;
    flag[me] = false;
  }

  The idea is that we run "oneThread(0, 1)" in parallel with "oneThread(1, 0)".
  After both threads finish, "global" had better be holding the value 2.
*)

(* We formalize local states with this type, standing for the different points
 * before, between, and after the lines of code, in order.  Note that, as with
 * the example from lecture, only the [Write] state needs to store the value of
 * variable "local". *)
Inductive increment_program :=
| SetFlag : increment_program
| SetTurn : increment_program
| ReadFlag : increment_program
| ReadTurn : increment_program
| Read : increment_program
| Write : nat -> increment_program
| UnsetFlag : increment_program
| Done : increment_program.

(* Record of global variables *)
Record inc_state := {
  Flag1 : bool;
  Flag2 : bool;
  (* The two cells of the "flag" array, represented as separate variables *)
  Turn : bool;
  (* Global variable "turn", representing with "false" for 0 and "true" for 1 *)
  Global : nat
  (* Global variable "global", represented more directly *)
}.

Definition increment_state := threaded_state inc_state increment_program.

(* The next two relations translate the single-thread code in a tedious way. *)

Inductive increment_init : increment_state -> Prop :=
| IncInit :
  increment_init {| Shared := {| Flag1 := false; Flag2 := false; Turn := false; Global := O |};
                    Private := SetFlag |}.

Inductive increment_step : bool (* This Boolean is set iff parameter "me" would
                                 * be 1. *)
                           -> increment_state -> increment_state -> Prop :=
| IncSetFlag1 : forall fl1 fl2 tu g,
  increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetFlag |}
                 {| Shared := {| Flag1 := true; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetTurn |}
| IncSetFlag2 : forall fl1 fl2 tu g,
  increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := true; Turn := tu; Global := g |};
                    Private := SetTurn |}
| IncSetTurn : forall am2 fl1 fl2 tu g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetTurn |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := negb am2; Global := g |};
                    Private := ReadFlag |}
| IncReadFlag1True : forall fl1 fl2 tu g,
  fl2 = true
  -> increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadTurn |}
| IncReadFlag1False : forall fl1 fl2 tu g,
  fl2 = false
  -> increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Read |}
| IncReadFlag2True : forall fl1 fl2 tu g,
  fl1 = true
  -> increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadTurn |}
| IncReadFlag2False : forall fl1 fl2 tu g,
  fl1 = false
  -> increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Read |}
| IncReadTurnTrue : forall am2 fl1 fl2 g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := negb am2; Global := g |};
                    Private := ReadTurn |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := negb am2; Global := g |};
                    Private := ReadFlag |}
| IncReadTurnFalse : forall am2 fl1 fl2 g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := am2; Global := g |};
                    Private := ReadTurn |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := am2; Global := g |};
                    Private := Read |}
| IncRead : forall am2 fl1 fl2 tu g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Read |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Write g |}
| IncWrite : forall am2 fl1 fl2 tu g v,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Write v |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := S v |};
                    Private := UnsetFlag |}
| IncUnsetFlag1 : forall fl1 fl2 tu g,
  increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := UnsetFlag |}
                 {| Shared := {| Flag1 := false; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Done |}
| IncUnsetFlag2 : forall fl1 fl2 tu g,
  increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := UnsetFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := false; Turn := tu; Global := g |};
                    Private := Done |}.

Definition increment_sys am2 := {|
  Initial := increment_init;
  Step := increment_step am2
|}.

Definition increment2_sys := parallel (increment_sys false) (increment_sys true).

(* The natural correctness condition, looking nearly the same as for the example
 * from lecture *)
Definition increment2_correct (s : threaded_state inc_state (increment_program * increment_program)) :=
  s.(Private) = (Done, Done)
  -> s.(Shared).(Global) = 2.

Module Type S.
  Axiom increment2_ok :
    invariantFor increment2_sys increment2_correct.
End S.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *)

From Coq Require Import Lia.
Require Import Raux Defs Digits Generic_fmt Float_prop Bracket.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Fcalc_sqrt.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

(** Computes a mantissa of precision p, the corresponding exponent,
    and the position with respect to the real square root of the
    input floating-point number.

The algorithm performs the following steps:
- Shift the mantissa so that it has at least 2p-1 digits;
  shift it one digit more if the new exponent is not even.
- Compute the square root s (at least p digits) of the new
  mantissa, and its remainder r.
- Compute the position according to the remainder:
  -- r == 0  =>  Eq,
  -- r <= s  =>  Lo,
  -- r >= s  =>  Up.

Complexity is fine as long as p1 <= 2p-1.
*)

Lemma mag_sqrt_F2R :
  forall m1 e1,
  (0 < m1)%Z ->
  mag beta (sqrt (F2R (Float beta m1 e1))) = Z.div2 (Zdigits beta m1 + e1 + 1) :> Z.
Proof.
intros m1 e1 Hm1.
rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
apply mag_sqrt.
now apply F2R_gt_0.
Qed.

Definition Fsqrt_core m1 e1 e :=
  let d1 := Zdigits beta m1 in
  let m1' := (m1 * Zpower beta (e1 - 2 * e))%Z in
  let (q, r) := Z.sqrtrem m1' in
  let l :=
    if Zeq_bool r 0 then loc_Exact
    else loc_Inexact (if Zle_bool r q then Lt else Gt) in
  (q, l).

Theorem Fsqrt_core_correct :
  forall m1 e1 e,
  (0 < m1)%Z ->
  (2 * e <= e1)%Z ->
  let '(m, l) := Fsqrt_core m1 e1 e in
  inbetween_float beta m e (sqrt (F2R (Float beta m1 e1))) l.
Proof.
intros m1 e1 e Hm1 He.
unfold Fsqrt_core.
set (m' := Zmult _ _).
assert (0 <= m')%Z as Hm'.
{ apply Z.mul_nonneg_nonneg.
  now apply Zlt_le_weak.
  apply Zpower_ge_0. }
assert (sqrt (F2R (Float beta m1 e1)) = sqrt (IZR m') * bpow e)%R as Hf.
{ rewrite <- (sqrt_Rsqr (bpow e)) by apply bpow_ge_0.
  rewrite <- sqrt_mult.
  unfold Rsqr, m'.
  rewrite mult_IZR, IZR_Zpower by lia.
  rewrite Rmult_assoc, <- 2!bpow_plus.
  now replace (_ + _)%Z with e1 by ring.
  now apply IZR_le.
  apply Rle_0_sqr. }
generalize (Z.sqrtrem_spec m' Hm').
destruct Z.sqrtrem as [q r].
intros [Hq Hr].
rewrite Hf.
unfold inbetween_float, F2R. simpl Fnum.
apply inbetween_mult_compat.
apply bpow_gt_0.
rewrite Hq.
case Zeq_bool_spec ; intros Hr'.
(* .. r = 0 *)
rewrite Hr', Zplus_0_r, mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
now constructor.
apply IZR_le.
clear -Hr ; lia.
(* .. r <> 0 *)
constructor.
split.
(* ... bounds *)
apply Rle_lt_trans with (sqrt (IZR (q * q))).
rewrite mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; lia.
apply sqrt_lt_1.
rewrite mult_IZR.
apply Rle_0_sqr.
rewrite <- Hq.
now apply IZR_le.
apply IZR_lt.
lia.
apply Rlt_le_trans with (sqrt (IZR ((q + 1) * (q + 1)))).
apply sqrt_lt_1.
rewrite <- Hq.
now apply IZR_le.
rewrite mult_IZR.
apply Rle_0_sqr.
apply IZR_lt.
ring_simplify.
lia.
rewrite mult_IZR.
fold (Rsqr (IZR (q + 1))).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; lia.
(* ... location *)
rewrite Rcompare_half_r.
generalize (Rcompare_sqr (2 * sqrt (IZR (q * q + r))) (IZR q + IZR (q + 1))).
rewrite 2!Rabs_pos_eq.
intros <-.
replace ((2 * sqrt (IZR (q * q + r))) * (2 * sqrt (IZR (q * q + r))))%R
  with (4 * Rsqr (sqrt (IZR (q * q + r))))%R by (unfold Rsqr ; ring).
rewrite Rsqr_sqrt.
rewrite <- plus_IZR, <- 2!mult_IZR.
rewrite Rcompare_IZR.
replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring.
generalize (Zle_cases r q).
case (Zle_bool r q) ; intros Hr''.
change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z.
lia.
change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z.
lia.
rewrite <- Hq.
now apply IZR_le.
rewrite <- plus_IZR.
apply IZR_le.
clear -Hr ; lia.
apply Rmult_le_pos.
now apply IZR_le.
apply sqrt_ge_0.
Qed.

Definition Fsqrt (x : float beta) :=
  let (m1, e1) := x in
  let e' := (Zdigits beta m1 + e1 + 1)%Z in
  let e := Z.min (fexp (Z.div2 e')) (Z.div2 e1) in
  let '(m, l) := Fsqrt_core m1 e1 e in
  (m, e, l).

Theorem Fsqrt_correct :
  forall x,
  (0 < F2R x)%R ->
  let '(m, e, l) := Fsqrt x in
  (e <= cexp beta fexp (sqrt (F2R x)))%Z /\
  inbetween_float beta m e (sqrt (F2R x)) l.
Proof.
intros [m1 e1] Hm1.
apply gt_0_F2R in Hm1.
unfold Fsqrt.
set (e := Z.min _ _).
assert (2 * e <= e1)%Z as He.
{ assert (e <= Z.div2 e1)%Z by apply Z.le_min_r.
  rewrite (Zdiv2_odd_eqn e1).
  destruct Z.odd ; lia. }
generalize (Fsqrt_core_correct m1 e1 e Hm1 He).
destruct Fsqrt_core as [m l].
apply conj.
apply Z.le_trans with (1 := Z.le_min_l _ _).
unfold cexp.
rewrite (mag_sqrt_F2R m1 e1 Hm1).
apply Z.le_refl.
Qed.

End Fcalc_sqrt.


Require Import Fiat.Common
        Fiat.Computation
        Fiat.ADT.ADTSig
        Fiat.ADT.Core
        Fiat.ADTRefinement.Core Fiat.ADTRefinement.SetoidMorphisms
        Fiat.ADTRefinement.GeneralRefinements.

(* A generic refinement and honing tactic for switching the
    representation of an ADT. *)

Section HoneRepresentation.

  Variable oldRep : Type. (* The old representation type. *)
  Variable newRep : Type. (* The new representation type. *)

  (* The abstraction relation between old and new representations. *)
  Variable AbsR : oldRep -> newRep -> Prop.
  Local Infix "≃" := (AbsR) (at level 70).

  (* When switching representations, we can always build a default
     implementation (computation?) for the methods of an ADT by
     using the old methods. *)

  Fixpoint absMethod'
             (dom : list Type)
             (cod : option Type)
    : (oldRep -> methodType' oldRep dom cod)
      -> newRep -> (methodType' newRep dom cod) :=
    match dom return
          (oldRep -> methodType' oldRep dom cod)
          -> newRep -> (methodType' newRep dom cod)
    with
    | nil =>
      match cod return
          (oldRep -> methodType' oldRep [] cod)
          -> newRep -> (methodType' newRep [] cod)
      with
      | Some cod' =>
        fun oldMethod nr =>
          {nr' | forall or,
              or ≃ nr ->
              exists or',
                (oldMethod or) ↝ or' /\
                fst or' ≃ fst nr' /\ snd or' = snd nr'}%comp
      | None =>
        fun oldMethod nr =>
          {nr' | forall or,
              or ≃ nr ->
              exists or',
                (oldMethod or) ↝ or' /\ or' ≃ nr'}%comp
      end
      | cons d dom' =>
      fun oldMethod nr t =>
        absMethod' dom' cod (fun or => oldMethod or t) nr
    end.

  Definition absMethod
             (dom : list Type)
             (cod : option Type)
             (oldMethod : methodType oldRep dom cod)
    : methodType newRep dom cod :=
    absMethod' dom cod oldMethod.

  Lemma refine_absMethod
        (dom : list Type)
        (cod : option Type)
        (oldMethod : methodType oldRep dom cod)
  : @refineMethod oldRep newRep AbsR _ _
                   oldMethod
                   (absMethod oldMethod).
  Proof.
    induction dom.
    - simpl in *; unfold refineMethod, refineMethod',
                  absMethod, absMethod', refine; intros;
      destruct cod; intros; computes_to_inv.
      + destruct (H0 _ H) as [or' [Comp_or [AbsR_or'' eq_or''] ] ].
        repeat computes_to_econstructor; eauto.
        destruct v; simpl in *; subst; econstructor.
      + destruct (H0 _ H) as [or' [Comp_or AbsR_or'' ] ].
        repeat computes_to_econstructor; eauto.
    - intro; simpl; intros.
      eapply (IHdom (fun or => oldMethod or d)); eauto.
  Qed.

  Hint Resolve refine_absMethod.

  (* A similar approach works for constructors. *)
  Fixpoint absConstructor
             {dom : list Type}
    : constructorType oldRep dom ->
      constructorType newRep dom :=
    match dom return
          constructorType oldRep dom ->
          constructorType newRep dom
    with
    | nil =>
      fun oldConstr =>
      {nr | exists or', oldConstr ↝ or' /\
                        or' ≃ nr }%comp
    | cons d dom' =>
      fun oldConstr t =>
        @absConstructor dom' (oldConstr t)
    end.

  Lemma refine_absConstructor
        (dom : list Type)
        (oldConstr : constructorType oldRep dom)
  : @refineConstructor oldRep newRep AbsR _ oldConstr
                    (absConstructor oldConstr).
  Proof.
    induction dom; simpl in *.
    - unfold refineConstructor, absConstructor, refine; intros.
      computes_to_inv; eauto.
    - intros; eapply IHdom.
  Qed.

  Hint Resolve refine_absConstructor.

  (* We can refine an ADT using the default mutator and observer
     implementations provided by [absMutatorMethod] and [absObserverMethod]. *)
  Lemma refineADT_Build_ADT_Rep_default
        Sig
        oldConstrs oldMeths :
    refineADT
      (@Build_ADT Sig oldRep oldConstrs oldMeths)
      (@Build_ADT Sig newRep
                  (fun idx => absConstructor (oldConstrs idx))
                  (fun idx => absMethod (oldMeths idx))).
  Proof.
    eapply refineADT_Build_ADT_Rep; eauto.
  Qed.

End HoneRepresentation.

(* Always unfold absMutatorMethods and absObserverMethods.
Global Arguments absMethod oldRep newRep AbsR Dom Cod oldMethod / nr n.
Global Arguments absConstructor oldRep newRep AbsR Dom oldConstr / n . *)

(* Honing tactic for refining the ADT representation which provides
   default observer and mutator implementations. *)
Tactic Notation "hone" "representation" "using" constr(AbsR') :=
    eapply SharpenStep;
    [eapply refineADT_Build_ADT_Rep_default with (AbsR := AbsR') | ].


From Coq Require Import
     Morphisms
.

From ITree Require Import
     Axioms
     ITree
     ITreeFacts
     Props.Infinite
.

From Paco Require Import paco.

Import Monads.
Import MonadNotation.
#[local] Open Scope monad_scope.

Set Implicit Arguments.

(** Defines euttNoRet, a relation for relating ITrees
    over different return types, that never return and whose events are bisimilar. Also contains noret_cast, a function that casts ITrees that never return from one return type to another while preserving its events.
*)

Definition euttNoRet {E} {A B : Type} (ta : itree E A) (tb : itree E B) :=
  eutt (fun a b => False) ta tb.

Lemma euttNoRet_spin : forall (E : Type -> Type) (A B : Type), @euttNoRet E A B ITree.spin ITree.spin.
Proof.
  intros. pcofix CIH. pfold. red. cbn. constructor. right.
  eauto.
Qed.

Lemma noret_bind_nop : forall (E : Type -> Type) (A B : Type) (t : itree E A) (f : A -> itree E B),
    all_infinite t -> euttNoRet t (t >>= f).
Proof.
  intros. einit. generalize dependent t. ecofix CIH. intros t Hdivt. pinversion Hdivt.
  - specialize (itree_eta t) as Ht. rewrite <- H in Ht.
    cbn. rewrite Ht.
    assert (ITree.bind (Tau t0) f ≅ Tau (ITree.bind t0 f)); try apply bind_tau.
    setoid_rewrite H1. etau.
  - specialize (itree_eta t) as Ht. rewrite <- H in Ht.
    cbn. rewrite Ht. rewrite bind_vis. evis.
Qed.

Lemma euttNoRet_subrel : forall (E : Type -> Type) (A B : Type) (R : A -> B -> Prop)
                               (ta : itree E A) (tb : itree E B),
    euttNoRet ta tb -> eutt R ta tb.
Proof.
  intros.
  eapply eutt_subrel with (R1 := fun a b => False); tauto.
Qed.

Lemma all_infinite_euttNoRet : forall (E : Type -> Type) (A B : Type) (R : A -> B -> Prop)
                            (ta : itree E A) (tb : itree E B),
    all_infinite ta -> eutt R ta tb -> euttNoRet ta tb.
Proof.
  (* oddly had trouble doing this with euttG, maybe I should reread the gpaco paper*)
  intros E A B R. pcofix CIH. pstep. intros ta tb Hdiv Heutt.
  punfold Heutt. unfold_eqit. dependent induction Heutt; pclearbot.
  - exfalso. clear CIH. specialize (itree_eta ta) as Hta.
    rewrite <- x0 in Hta. rewrite Hta in Hdiv. pinversion Hdiv.
  - rewrite <- x0. rewrite <- x. constructor. right.
    assert (m1 ≈ ta).
    { specialize (itree_eta ta) as Hta. rewrite <- x0 in Hta.
      rewrite Hta. rewrite tau_eutt. reflexivity. }
    assert (m2 ≈ tb).
    { specialize (itree_eta tb) as Htb. rewrite <- x in Htb.
      rewrite Htb. rewrite tau_eutt. reflexivity. }
    apply CIH; auto.
    rewrite H. auto.
  - rewrite <- x0. rewrite <- x. constructor.
    intros. right. apply CIH; auto with itree.
    specialize (itree_eta ta) as Hta. rewrite <- x0 in Hta.
    rewrite Hta in Hdiv. pinversion Hdiv.
    dependent destruction H2. apply H0.
  - rewrite <- x. constructor; auto. eapply IHHeutt; eauto.
    assert (t1 ≈ ta).
    { specialize (itree_eta ta) as Hta. rewrite <- x in Hta.
      rewrite Hta. rewrite tau_eutt. reflexivity. }
    rewrite H. auto.
  - rewrite <- x. constructor; auto.
Qed.

Lemma euttNoRet_all_infinite : forall (E : Type -> Type) (A B : Type) (t1 : itree E A) (t2 : itree E B),
    euttNoRet t1 t2 -> all_infinite t1.
Proof.
  intros A B. pcofix CIH. intros. pfold. red.
  punfold H0.
  unfold_eqit.
  dependent induction H0; try contradiction; pclearbot.
  - rewrite <- x0. constructor. right. eapply CIH; eauto.
  - rewrite <- x0. constructor. intros. right. eapply CIH; eauto. eapply REL.
  - rewrite <- x. constructor. right. eapply CIH with (t2 := t2); eauto.
    pfold. auto.
  -  eapply IHeqitF; eauto.
Qed.

Lemma euttNoRet_sym : forall (E : Type -> Type) (A B : Type) (t1 : itree E A) (t2 : itree E B),
    euttNoRet t1 t2 -> euttNoRet t2 t1.
Proof.
  intros E A B. pcofix CIH. intros. pfold. red.
  punfold H0. unfold_eqit.
  dependent induction H0; try contradiction; pclearbot.
  - rewrite <- x0. rewrite <- x. constructor. right. auto.
  - rewrite <- x0. rewrite <- x. constructor. intros. unfold id.
    right. apply CIH. apply REL.
  - rewrite <- x. constructor; auto.
  - rewrite <- x. constructor; auto.
Qed.

Lemma all_infinite_bind : forall (E : Type -> Type) (R U: Type) (t : itree E R)
                                 (f : R -> itree E U),
    all_infinite t -> all_infinite (bind t f).
Proof.
  intros. apply noret_bind_nop with (B := U) (f := f) in H.
  apply euttNoRet_sym in H. apply euttNoRet_all_infinite in H. auto.
Qed.

Lemma euttNoRet_trans : forall (E : Type -> Type) (A B C : Type) (t1 : itree E A)
                              (t2 : itree E B) (t3 : itree E C),
    euttNoRet t1 t2 -> euttNoRet t2 t3 -> euttNoRet t1 t3.
Proof.
  intros. unfold euttNoRet in *.
  apply eutt_subrel with (R1 := @rcompose A B C (fun a b => False) (fun b c => False) ).
  - intros. inversion H1; contradiction.
  - eapply eqit_trans; eauto.
Qed.

#[global] Instance proper_euttNoRet {E A B} {R R'} : Proper ((@eutt E A A R) ==> (@eutt E B B R') ==> iff) (euttNoRet).
Proof.
  intros t1 t2 Ht12 t3 t4 Ht34. split; intros.
  - apply euttNoRet_all_infinite in H as Ht1. apply euttNoRet_sym in H.
    apply euttNoRet_all_infinite in H as Ht3.
    apply euttNoRet_trans with (t2 := t3).
    + apply euttNoRet_trans with (t2 := t1).
      * apply euttNoRet_sym. eapply all_infinite_euttNoRet; eauto.
      * apply euttNoRet_sym. auto.
    + eapply all_infinite_euttNoRet; eauto.
  - apply euttNoRet_all_infinite in H as Ht2.
    apply euttNoRet_sym in H. apply euttNoRet_all_infinite in H as Ht3.
    assert (euttNoRet t1 t2).
    {
      apply euttNoRet_sym. apply eutt_flip in Ht12.
      eapply all_infinite_euttNoRet; eauto.
    }
    assert (euttNoRet t3 t4).
    {
      apply euttNoRet_sym. apply eutt_flip in Ht34.
      eapply all_infinite_euttNoRet; eauto.
    }
    apply euttNoRet_sym in H.
    apply euttNoRet_trans with (t2 := t4).
    + apply euttNoRet_trans with (t2 := t2); auto.
    + apply euttNoRet_sym. auto.
Qed.

Definition noret_cast {E A B} (t : itree E A) : itree E B :=
  t >>= fun _ => ITree.spin.

Lemma noret_cast_nop : forall (E : Type -> Type) (A : Type) (t : itree E A),
    all_infinite t -> t ≈ noret_cast t.
Proof.
  intros. apply euttNoRet_subrel. apply noret_bind_nop. auto.
Qed.

#[global] Instance proper_noret_cast {E R1 R2} : Proper (@eutt E R1 R1 eq ==> @eutt E R2 R2 eq) noret_cast.
Proof.
  intros t1 t2 Heutt. unfold noret_cast. cbn. rewrite Heutt. reflexivity.
Qed.

Ltac infer_noret H :=
  match type of H with
  | euttNoRet ?t1 ?t2 =>
      apply euttNoRet_sym in H as ?H1;
      apply euttNoRet_all_infinite in H1;
      apply euttNoRet_all_infinite in H as ?H
  end.

Lemma noret_cast_cast E (A B : Type) (t1 t2 : itree E A) (R : A -> A -> Prop) (R' : B -> B -> Prop)
  : all_infinite t1 -> eutt R t1 t2 -> eutt R' (noret_cast t1) (noret_cast t2).
Proof.
  intros. apply euttNoRet_subrel.
  apply all_infinite_euttNoRet in H0; auto.
  infer_noret H0.
  apply euttNoRet_trans with (t2 := t2); try apply noret_bind_nop; auto.
  apply euttNoRet_trans with (t2 := t1); auto.
  apply euttNoRet_sym. apply noret_bind_nop. auto.
Qed.


(*
   Monads with Predicate Liftings
 *)

Require Import RelDef SemiLattice MonadDef.
Set Implicit Arguments.

Module MPL.
  Import Relation.
  Import Monad.

  Local Open Scope type_scope.
  Local Open Scope monad_scope.

  Section MPLDef.

    Reserved Notation "f # P" (at level 60, right associativity).
    Class MPL (gpr: Set -> Type)`(monad: Monad): Type :=
      {
        gpr_eq {X: Set}: relation (gpr X);
        gpr_eq_equiv {X: Set}:> Equivalence (gpr_eq (X:=X));

        modal {X Y: Set}(f: X ->> Y): (gpr Y) -> gpr X
                                                     where "f # P" := (modal f P);

        modal_subst:
          forall (X Y: Set)(f f': X ->> Y)(Q Q': gpr Y),
            (forall x: X, f x == f' x) -> Q == Q' -> f#Q == f'#Q';

        modal_ident:
          forall (X: Set)(P: gpr X),
            P == ret#P;

        modal_compose:
          forall (X Y Z: Set)(f: X ->> Y)(g: Y ->> Z)(R: gpr Z),
            f#g#R == (f|>g)#R

      }.

  End MPLDef.

  Notation "f # P" := (modal f P) (at level 60, right associativity).

  Definition swap `{mpl: MPL}{X Y: Set}
             (P: gpr (X*Y)): gpr (Y*X) :=
    (fun p:Y*X => let (y, x) := p in ret (x, y))#P.

  Section MPLProp.
    Context `{mpl: MPL}.

    Lemma modal_subst_p:
      forall (X Y: Set)(f: X ->> Y)(Q Q': gpr Y),
        Q == Q' -> f#Q == f#Q'.
    Proof.
      intros; apply modal_subst; [| assumption].
      intro; apply Reflexivity.
    Qed.

    Lemma modal_subst_f:
      forall (X Y: Set)(f f': X ->> Y)(Q: gpr Y),
        (forall x: X, f x == f' x) -> f#Q == f'#Q.
    Proof.
      intros; apply modal_subst; [assumption | apply Reflexivity].
    Qed.
  End MPLProp.

End MPL.

Section MPLProperties.
  Import Relation.
  Import Monad.
  Import MPL.

  Existing Instance gpr_eq_equiv.
  Class hasPord `(mpl: MPL) :=
    {
      gpr_pord {X: Set}:> PartialOrder (gpr_eq_equiv (X:=X));

      modal_monotone:
        forall {X Y: Set}(f: X ->> Y)(P Q: gpr Y),
          P <= Q -> f#P <= f#Q
    }.

  Definition GHT `{mpl: MPL}{hp: hasPord mpl}{X Y: Set}(P: gpr X)(f: X ->> Y)(Q: gpr Y) :=
    P <= f#Q.

  Notation "P {- f -} Q" := (GHT P f Q) (at level 70, no associativity).

  Class hasTop `(mpl: MPL)(hp: hasPord mpl) :=
    {
      gpr_top (X: Set): gpr X;

      gpr_pord_top:
        forall {X: Set}(P: gpr X),
          P <= gpr_top X;

      modal_top:
        forall {X Y: Set}(f: X ->> Y),
          f#(gpr_top Y) == gpr_top X
    }.

  Import SemiLat.
  Local Open Scope sl_scope.

  Class hasSL `(mpl: MPL) :=
    {
      gpr_sl (X: Set):> SemiLattice (gpr_eq_equiv (X:=X));

      modal_semilathom:
        forall {X Y: Set}(f: X ->> Y),
          isSemiLatHom (modal f) (gpr_sl Y) (gpr_sl X)
    }.

  Program Instance hasPordSL `(mpl: MPL)(hsl: hasSL mpl): hasPord mpl :=
    {
      gpr_pord X := meet_POrd (gpr_sl X)
    }.
  Next Obligation.
    unfold meet_pord in *.
    apply Symmetry.
    eapply Transitivity; [| apply modal_semilathom].
    apply Symmetry.
    apply modal_subst_p; assumption.
  Qed.

  Local Open Scope type_scope.
  Class hasForall `(mpl: MPL) :=
    {
      gpr_forall {X Y: Set}: gpr (X*Y) -> gpr X;

      modal_forall:
        forall {X Y Z: Set}(f: X*Y ->> T Z) P,
        forall y, gpr_forall (modal f P) == modal (fun x => f (x,y)) P
    }.

End MPLProperties.

Notation "P {- f -} Q" := (GHT P f Q) (at level 70, no associativity).

Section MPLProp.
  Import Relation.
  Import Monad.
  Import MPL.
  Context `{mpl: MPL}{hp: hasPord mpl}.

  Lemma gpr_le_subst:
    forall {X: Set}(P P' Q Q': gpr X),
      P == P' -> Q == Q' -> (P <= Q) -> P' <= Q'.
  Proof.
    do 5 intro.
    intros Heqp Heqq Hpq.
    apply Transitivity with Q; [| apply pord_refl_eq; assumption].
    apply Transitivity with P;
      [apply pord_refl_eq; apply Symmetry |]; assumption.
  Qed.

  Lemma gpr_le_subst_l:
    forall {X: Set}(P P' Q: gpr X),
      P == P' -> P <= Q -> P' <= Q.
  Proof.
    do 4 intro.
    intros Heq.
    apply gpr_le_subst; [assumption | apply Reflexivity].
  Qed.

  Lemma gpr_le_subst_r:
    forall {X: Set}(P Q Q': gpr X),
      Q == Q' -> P <= Q -> P <= Q'.
  Proof.
    do 4 intro.
    intros Heq.
    apply gpr_le_subst; [apply Reflexivity | assumption].
  Qed.

  Lemma GHT_ret:
    forall {X: Set}(P: gpr X),
      P{-ret-}P.
  Proof.
    intros X P.
    unfold GHT.
    apply gpr_le_subst_r with P.
    - apply modal_ident.
    - apply Reflexivity.
  Qed.

  Lemma GHT_compose:
    forall (X Y Z: Set)
           (P: gpr X)(f: X ->> Y)(Q: gpr Y)(g: Y ->> Z)(R: gpr Z),
      P{-f-}Q -> Q{-g-}R -> P{-f|>g-}R.
  Proof.
    intros X Y Z P f Q g R Hpq Hqr.
    unfold GHT in *.
    apply (modal_monotone f) in Hqr.
    apply Transitivity with (f#Q).
    - apply Hpq.
    - generalize dependent Hqr; apply gpr_le_subst_r.
      apply modal_compose.
  Qed.

  Lemma GHT_result:
    forall (X Y: Set)
           (P P': gpr X)(f: X ->> Y)(Q Q': gpr Y),
      P' <= P -> Q <= Q' ->
      P{-f-}Q -> P'{-f-}Q'.
  Proof.
    intros.
    unfold GHT in *.
    apply Transitivity with P; [assumption |].
    apply Transitivity with (f#Q); [assumption |].
    apply modal_monotone.
    assumption.
  Qed.

  Lemma GHT_result_l:
    forall (X Y: Set)
           (P P': gpr X)(f: X ->> Y)(Q: gpr Y),
      P' <= P -> P{-f-}Q -> P'{-f-}Q.
  Proof.
    do 7 intro; apply GHT_result; [assumption | apply Reflexivity].
  Qed.

  Lemma GHT_result_r:
    forall (X Y: Set)
           (P: gpr X)(f: X ->> Y)(Q Q': gpr Y),
      Q <= Q' -> P{-f-}Q -> P{-f-}Q'.
  Proof.
    do 7 intro; apply GHT_result; [apply Reflexivity | assumption].
  Qed.

  Lemma GHT_compose_inverse:
    forall (X Y Z: Set)
           (P: gpr X)(f: X ->> Y)(g: Y ->> Z)(R: gpr Z),
      P{-f|>g-}R ->
      exists Q: gpr Y,
        P{-f-}Q/\Q{-g-}R.
  Proof.
    do 7 intro.
    unfold GHT.
    intro Hle.
    exists (g#R).
    split.
    - generalize dependent Hle; apply gpr_le_subst_r.
      apply Symmetry; apply modal_compose.
    - apply Reflexivity.
  Qed.

  Lemma GHT_subst:
    forall {X Y: Set}(P: gpr X)(f f': X ->> Y)(Q: gpr Y),
      P {- f -} Q ->
      (forall x, f x == f' x) ->
      P {- f' -} Q.
  Proof.
    do 6 intro.
    intros Hht Heq; generalize dependent Hht.
    unfold GHT in *.
    apply gpr_le_subst_r.
    apply modal_subst_f.
    apply Heq.
  Qed.

End MPLProp.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
From Coq Require Import micromega.Lia.
From Coq Require Import micromega.Zify.
From Coq Require Import Lists.List.
From Coq Require Import Reals.Reals. Import Rdefinitions. Import RIneq.
From Coq Require Import ZArith.Int. Import Znat BinInt.Z.
From Coq Require Import Setoids.Setoid.
Import ListNotations.

From ATL Require Import ATL.

Ltac zlia :=
  match goal with
  | |- context[ (Z.of_nat _ < _)%Z ] => zify; lia
  | |- context[ Z.neg _ ] => zify; lia
  | |- context[ Pos.to_nat _ ] => zify; lia
  | |- context[ Z.to_nat (Z.pos _) ] => simpl; zify; lia
  | |- context[ Z.pos _ ] => zify; lia
  | |- context[ Pos.of_succ_nat _ ] => zify; lia
  | |- context[ Z.to_nat < _ ] => zify; lia
  | |- context[ (Z.succ (Z.of_nat _)) ] => zify; lia
  | |- context[ (Z.of_nat (S _)) ] => zify; lia
  | |- (_ < Z.of_nat _)%Z => zify; lia
  end.

Ltac eta_reduce_all_private h := repeat change (fun x => ?h x) with h.

Ltac eta_red := eta_reduce_all_private idtac.

(* Takes a boolean conjunction in the goal and rewrites it right associated *)
Ltac andb_right :=
  repeat match goal with
         | [ |- context[(_ && _) && _] ] => rewrite <- andb_assoc
         end.

Lemma bool_prop : forall a b, a = b <-> (a = true <-> b = true).
Proof.
  destruct a; destruct b; split; intros; try (split; intros); auto; destruct H;
    assert (true = true) by reflexivity; intuition.
Qed.
Open Scope Z_scope.

Ltac unbool_hyp :=
  repeat match goal with
         | [ H : (_ <? _ = true)%nat |- _ ] => apply Nat.ltb_lt in H
         | [ H : (_ <? _ = false)%nat |- _ ] => apply Nat.ltb_nlt in H
         | [ H : (_ =? _ = true)%nat |- _ ] => apply beq_nat_true in H
         | [ H : (_ =? _ = false)%nat |- _ ] => apply beq_nat_false in H

         | [ H : (true = _) |- _ ] => symmetry in H
         | [ H : (false = _) |- _ ] => symmetry in H
         | [ H : (_ =? _ = true)   |- _ ] => apply eqb_eq in H
         | [ H : (_ =? _ = false)  |- _ ] => apply eqb_neq in H
         | [ H : (_ <=? _ = true)  |- _ ] => apply Zle_is_le_bool in H
         | [ H : (_ <=? _ = false) |- _ ] => apply leb_gt in H
         | [ H : (_ <? _ = true)   |- _ ] => apply ltb_lt in H
         | [ H : (_ <? _ = false)   |- _ ] => apply ltb_ge in H
         | [ H : (_ <=? _ = false) |- _ ] => apply ltb_nlt in H

         | [ H : (_ && _ = true) |- _ ] => apply andb_true_iff in H;
                                           destruct H; unbool_hyp
         | [ H : (_ && _ = false) |- _ ] => apply andb_false_iff in H;
                                            destruct H; unbool_hyp
  end.

Ltac unbool_goal :=
  repeat match goal with
         | [ |- context[ (true =? true) ]] => fail 1
         | [ |- context[ (false =? false) ]] => fail 1
         | [ |- context[ (false =? true) ]] => fail 1
         | [ |- context[ (true =? false) ]] => fail 1

         | [ |- context[(_ =? _ = true)] ] => rewrite eqb_eq
         | [ |- context[(_ =? _ = false)] ] => rewrite eqb_neq
         | [ |- context[(_ <=? _ = true)] ] => rewrite leb_le
         | [ |- context[(_ <=? _ = false)] ] => rewrite leb_gt
         | [ |- context[(_ <? _ = true)] ] => rewrite ltb_lt
         | [ |- context[(_ <? _ = false)] ] => rewrite ltb_ge
         | [ |- context[(_ <=? _ = false)] ] => rewrite ltb_nlt

         | [ |- context[(_ && _)]] => rewrite andb_true_iff
         | [ |- ?A = ?B ] => rewrite (bool_prop A B)
         end.

Ltac unbool := unbool_hyp; unbool_goal.

Example ex1 : forall a b c, ((a =? b) && (b =? c) = (c =? a) && (b =? a)).
Proof. intros. unbool. lia. Qed.

Ltac app_in_crush H H' := apply H in H';
        try assumption; try reflexivity; try lia; try ring.

Ltac contra_crush := try (simpl in *;
  repeat match goal with
         | [ H : (_ < 0)%nat |- _ ] => inversion H
         | [ H : _ < 0 |- _ ] => now inversion H
         | [ H : _ <= 0 |- _ ] => now inversion H
         | [ H : ~ ?A |- _] =>
           (assert A by (try assumption; try lia; try ring)); contradiction
		 | [ H : 0 <= Z.neg ?A |- _ ] =>
				 specialize (Zlt_neg_0 A); intros; contradiction
		 | [ H : 0 < Z.neg _ |- _ ] => now inversion H
		 | [ H : Z.pos _ < Z.neg _ |- _ ] => now inversion H
         end).

Ltac peel_hyp :=
  repeat match goal with
         | [ H : ?A -> _ |- _ ] => assert (H' : A)
                                     by (try assumption; try reflexivity;
                                         try lia; try zlia; try ring);
                                   apply H in H'; clear H; rename H' into H
         end.

Close Scope Z_scope.

Ltac analyze_bool := try lazy beta;
  repeat match goal with
         | [ |- context[ (?A =? ?B)%Z ] ] =>
           let v := fresh "H" in
           destruct (A =? B)%Z eqn:v; subst; unbool_hyp;
           try lia; try ring; try auto with crunch
         | [ |- context[ (?A <? ?B)%Z ] ] =>
           let v := fresh "H" in
           destruct (A <? B)%Z eqn:v; subst; unbool_hyp;
           try lia; try ring; try auto with crunch
         | [ |- context[ (?A <=? ?B)%Z ] ] =>
           let v := fresh "H" in
           destruct (A <=? B)%Z eqn:v; subst; unbool_hyp;
           try lia; try ring; try auto with crunch
  end.

Ltac solve_for var :=
  match goal with
  | [ |- context[(?A =? ?B)%Z]] =>
    let ev := fresh "ev" in
    let H := fresh "H" in
    let H' := fresh "H" in
    let e := fresh "e" in
    evar (ev : Z);
    assert (H' : (A =? B)%Z = (var =? ?ev)%Z) by
        (remember (var =? ?ev)%Z eqn:e;
         unbool_goal;
         rewrite <- Z.sub_move_0_r;
         split; intros H;
         [ rewrite e;
           unbool_goal;
           ring_simplify in H;
           match type of H with
           | context [ (_ - var)%Z ] => apply (Z.add_cancel_r _ _ var) in H
           | context [ (_ + var)%Z ] => apply (Z.sub_cancel_r _ _ var) in H
           | context [ (var + ?a)%Z ] => apply (Z.sub_cancel_r _ _ a) in H
           | context [ (var - ?a)%Z ] => apply (Z.add_cancel_r _ _ a) in H
           | _ => apply (Z.add_cancel_r _ _ var)%Z in H
           end;
           ring_simplify in H;
           (apply H + (symmetry; apply H)) |
           rewrite e in H; unbool_hyp; lia]);
    rewrite H'
  end.

Ltac reschedule := intros; intros;
                   repeat
                     match goal with
                     | H : consistent ?V ?S |- _ =>
                       let x := fresh "x" in
                       let xs := fresh "xs" in
                       destruct V as [| x xs]; inversion H;
                       assert (consistent (x::xs) S /\ True) by auto;
                       clear H
                     end;
                   repeat
                     match goal with
                     | H : _ /\ True |- _ =>
                       destruct H as [ ? triv ]; clear triv
                     end;
                   try autounfold with examples.

Ltac done :=
  match goal with
  | |- _ = ?symbol => try subst symbol; reflexivity
  end.