From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From pcm Require Import options axioms pred prelude.
From pcm Require Import pcm autopcm unionmap heap.
From htt Require Import model.
Import Prenex Implicits.

(**************************************************************************)
(* This file implements automations (both unification- and tactics-based) *)
(* related to Hoare logic for heaps.                                      *)
(*                                                                        *)
(* First automation concerns selection of Hoare-style rule for symbolic   *)
(* evaluation. The first command of the program determines the applicable *)
(* rule uniquely. The implemented automation picks out this rule, and     *)
(* applies it, while using AC-theory of heaps to rearrange the goal, if   *)
(* necessary for the rule to apply.                                       *)
(*                                                                        *)
(* Second automation extends this mechanism for a common combination of   *)
(* invoking the ghost lemma together with the frame rule. This allows the *)
(* user to supply the "kernel" heap to frame on directly instead of       *)
(* rearranging the goal manually with AC-rewriting.                       *)
(*                                                                        *)
(* Third, a tactic for canceling common terms in disjoint unions.         *)
(* Currently, it doesn't deal with weak pointers. I.e. if it sees terms   *)
(* like x :-> v1 and x :-> v2, it will reduce to v1 = v2 only if v1, v2   *)
(* are of the same type. A more general tactic would emit obligation      *)
(* dyn v1 = dyn v2, but I don't bother with this now.                     *)
(*                                                                        *)
(**************************************************************************)

(****************************************************************)
(* First, the reflection mechanism for search-and-replace       *)
(* pattern-matching on heap expressions; the AC theory of heaps *)
(****************************************************************)

Section Partition.

Structure tagged_heap := Tag {untag :> heap}.

Definition right_tag := Tag.
Definition left_tag := right_tag.
Canonical Structure found_tag i := left_tag i.

Definition form_axiom k r (h : tagged_heap) := untag h = k \+ r.

Structure form (k r : heap) :=
  Form {heap_of :> tagged_heap;
        _ : form_axiom k r heap_of}.

Arguments Form : clear implicits.

Lemma formE r k (f : form k r) : untag f = k \+ r.
Proof. by case: f=>[[j]] /=; rewrite /form_axiom /= => ->. Qed.

Lemma found_pf k : form_axiom k Unit (found_tag k).
Proof. by rewrite /form_axiom unitR. Qed.

Canonical Structure heap_found k := Form k Unit (found_tag k) (found_pf k).

Lemma left_pf h r (f : forall k, form k r) k :
        form_axiom k (r \+ h) (left_tag (untag (f k) \+ h)).
Proof. by rewrite formE /form_axiom /= joinA. Qed.

Canonical Structure search_left h r (f : forall k, form k r) k :=
  Form k (r \+ h) (left_tag (untag (f k) \+ h)) (left_pf h f k).

Lemma right_pf h r (f : forall k, form k r) k :
        form_axiom k (h \+ r) (right_tag (h \+ f k)).
Proof. by rewrite formE /form_axiom /= joinCA. Qed.

Canonical Structure search_right h r (f : forall k, form k r) k :=
  Form k (h \+ r) (right_tag (h \+ f k)) (right_pf h f k).

End Partition.

(**********************************************************)
(* Reflective lemmas that apply modulo AC-theory of heaps *)
(**********************************************************)

(* We maintain three different kinds of lemmas *)
(* in order to streamline the stepping *)
(* The only important ones are the val lemmas, the bnd and try *)
(* are there just to remove some spurious hypotheses about validity, and make the *)
(* verification flow easier *)

(* Each call to some bnd_* or try_* lemma is really a call to bnd_seq or try_seq *)
(* followed by a val_* lemma. Except that doing things in such a sequence *)
(* actually gives us some additional, spurious, validity hypotheses, which we *)
(* always discard anyway. However the discarding interrupts automation, so we want to avoid it *)

(* However, we only need gR lemma *)
(* This one is always applied by hand, not automatically, so *)
(* if we need to prefix it with a call to bnd_seq or try_seq, we can *)
(* do that by hand *)

(* If we were to do this by hand, whenever *)
(* there should be a nicer way to do this *)
(* e.g., suppress all the spurious validity as a default *)
(* and let the user generate them by hand at the leaves, when necessary *)

Section EvalRetR.
Variables (A B : Type).

Definition val_retR := vrf_ret.

Lemma try_retR e1 e2 (v : A) i (r : post B) :
        vrf i (e1 v) r -> vrf i (try (ret v) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_retR. Qed.

Lemma bnd_retR e (v : A) i (r : post B) :
        vrf i (e v) r -> vrf i (bind (ret v) e) r.
Proof. by move=>H; apply/vrf_bind/val_retR. Qed.

End EvalRetR.

Section EvalThrowR.
Variables (A B : Type).

Definition val_throwR := vrf_throw.

Lemma try_throwR e e1 e2 i (r : post B) :
        vrf i (e2 e) r ->
        vrf i (try (@throw A e) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_throwR. Qed.

Lemma bnd_throwR e e1 i (r : post B) :
        (valid i -> r (Exn e) i) ->
        vrf i (bind (@throw A e) e1) r.
Proof. by move=>H; apply/vrf_bind/val_throwR. Qed.

End EvalThrowR.

Section EvalReadR.
Variables (A B : Type).

Lemma val_readR v x i (f : form (x :-> v) i) (r : post A) :
        (valid (untag f) -> r (Val v) f) ->
        vrf f (read x) r.
Proof. by rewrite formE; apply: vrf_read. Qed.

Lemma try_readR e1 e2 v x i (f : form (x :-> v) i) (r : post B) :
        vrf f (e1 v) r ->
        vrf f (try (@read A x) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_readR. Qed.

Lemma bnd_readR e v x i (f : form (x :-> v) i) (r : post B) :
        vrf f (e v) r ->
        vrf f (bind (@read A x) e) r.
Proof. by move=>H; apply/vrf_bind/val_readR. Qed.

End EvalReadR.

Section EvalWriteR.
Variables (A B C : Type).

Lemma val_writeR (v : A) (w : B) x i (f : forall k, form k i) (r : post unit) :
        (valid (untag (f (x :-> v))) -> r (Val tt) (f (x :-> v))) ->
        vrf (f (x :-> w)) (write x v) r.
Proof. by rewrite !formE; apply: vrf_write. Qed.

Lemma try_writeR e1 e2 (v : A) (w : B) x i
                 (f : forall k, form k i) (r : post C) :
        vrf (f (x :-> v)) (e1 tt) r ->
        vrf (f (x :-> w)) (try (write x v) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_writeR. Qed.

Lemma bnd_writeR e (v : A) (w : B) x i (f : forall k, form k i) (r : post C) :
        vrf (f (x :-> v)) (e tt) r ->
        vrf (f (x :-> w)) (bind (write x v) e) r.
Proof. by move=>H; apply/vrf_bind/val_writeR. Qed.

End EvalWriteR.

Section EvalAllocR.
Variables (A B : Type).

Definition val_allocR := vrf_alloc.

Lemma try_allocR e1 e2 (v : A) i (r : post B) :
        (forall x, vrf (x :-> v \+ i) (e1 x) r) ->
        vrf i (try (alloc v) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_allocR. Qed.

Lemma bnd_allocR e (v : A) i (r : post B) :
        (forall x, vrf (x :-> v \+ i) (e x) r) ->
        vrf i (bind (alloc v) e) r.
Proof. by move=>H; apply/vrf_bind/val_allocR. Qed.

End EvalAllocR.

Section EvalAllocbR.
Variables (A B : Type).

Definition val_allocbR := vrf_allocb.

Lemma try_allocbR e1 e2 (v : A) n i (r : post B) :
        (forall x, vrf (updi x (nseq n v) \+ i) (e1 x) r) ->
        vrf i (try (allocb v n) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_allocbR. Qed.

Lemma bnd_allocbR e (v : A) n i (r : post B) :
        (forall x, vrf (updi x (nseq n v) \+ i) (e x) r) ->
        vrf i (bind (allocb v n) e) r.
Proof. by move=>H; apply/vrf_bind/val_allocbR. Qed.

End EvalAllocbR.

Section EvalDeallocR.
Variables (A B : Type).

Lemma val_deallocR (v : A) x i (f : forall k, form k i) (r : post unit) :
        (valid (untag (f Unit)) -> r (Val tt) (f Unit)) ->
        vrf (f (x :-> v)) (dealloc x) r.
Proof. by rewrite !formE unitL=>H; apply: vrf_dealloc. Qed.

Lemma try_deallocR e1 e2 (v : A) x i (f : forall k, form k i) (r : post B) :
        vrf (f Unit) (e1 tt) r ->
        vrf (f (x :-> v)) (try (dealloc x) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_deallocR. Qed.

Lemma bnd_deallocR e (v : A) x i (f : forall k, form k i) (r : post B) :
        vrf (f Unit) (e tt) r ->
        vrf (f (x :-> v)) (bind (dealloc x) e) r.
Proof. by move=>H; apply/vrf_bind/val_deallocR. Qed.

End EvalDeallocR.

(****************************************************)
(* Automating the selection of which lemma to apply *)
(* (reflective implementation of the hstep tactic)  *)
(****************************************************)

(* Need to case-split on bnd_, try_, or a val_ lemma. *)
(* Hence, three classes of canonical structures.      *)

Structure val_form A i r (p : Prop):=
  ValForm {val_pivot :> ST A;
           _ : p -> vrf i val_pivot r}.

Structure bnd_form A B i (e : A -> ST B) r (p : Prop) :=
  BndForm {bnd_pivot :> ST A;
           _ : p -> vrf i (bind bnd_pivot e) r}.

Structure try_form A B i (e1 : A -> ST B)
                         (e2 : exn -> ST B) r (p : Prop) :=
  TryForm {try_pivot :> ST A;
           _ : p -> vrf i (try try_pivot e1 e2) r}.

(* The main lemma which triggers the selection. *)

Lemma hstep A i (r : post A) p (e : val_form i r p) :
        p -> vrf i e r.
Proof. by case:e=>[?]; apply. Qed.

(* First check if matching on bnd_ or try_. If so, switch to searching *)
(* for bnd_ or try_form, respectively. Otherwise, fall through, and    *)
(* continue searching for a val_form. *)

Lemma bnd_case_pf A B i (s : A -> ST B) r p (e : bnd_form i s r p) :
        p -> vrf i (bind e s) r.
Proof. by case:e=>[?]; apply. Qed.

Canonical Structure
  bnd_case_form A B i (s : A -> ST B) r p (e : bnd_form i s r p) :=
  ValForm (bnd_case_pf e).

Lemma try_case_pf A B i (s1 : A -> ST B) (s2 : exn -> ST B) r p
                        (e : try_form i s1 s2 r p) :
        p -> vrf i (try e s1 s2) r.
Proof. by case:e=>[?]; apply. Qed.

(* After that, find the form in the following list.  Notice that the list *)
(* can be extended arbitrarily in the future. There is no centralized     *)
(* tactic to maintain. *)

Canonical Structure val_ret_form A v i r :=
  ValForm (@val_retR A v i r).
Canonical Structure bnd_ret_form A B s v i r :=
  BndForm (@bnd_retR A B s v i r).
Canonical Structure try_ret_form A B s1 s2 v i r :=
  TryForm (@try_retR A B s1 s2 v i r).

Canonical Structure val_read_form A v x r j f :=
  ValForm (@val_readR A v x j f r).
Canonical Structure bnd_read_form A B s v x r j f :=
  BndForm (@bnd_readR A B s v x j f r).
Canonical Structure try_read_form A B s1 s2 v x r j f :=
  TryForm (@try_readR A B s1 s2 v x j f r).

Canonical Structure val_write_form A B v w x r j f :=
  ValForm (@val_writeR A B v w x j f r).
Canonical Structure bnd_write_form A B C s v w x r j f :=
  BndForm (@bnd_writeR A B C s v w x j f r).
Canonical Structure try_write_form A B C s1 s2 v w x r j f :=
  TryForm (@try_writeR A B C s1 s2 v w x j f r).

Canonical Structure val_alloc_form A v i r :=
  ValForm (@val_allocR A v i r).
Canonical Structure bnd_alloc_form A B s v i r :=
  BndForm (@bnd_allocR A B s v i r).
Canonical Structure try_alloc_form A B s1 s2 v i r :=
  TryForm (@try_allocR A B s1 s2 v i r).

Canonical Structure val_allocb_form A v n i r :=
  ValForm (@val_allocbR A v n i r).
Canonical Structure bnd_allocb_form A B s v n i r :=
  BndForm (@bnd_allocbR A B s v n i r).
Canonical Structure try_allocb_form A B s1 s2 v n i r :=
  TryForm (@try_allocbR A B s1 s2 v n i r).

Canonical Structure val_dealloc_form A v x r j f :=
  ValForm (@val_deallocR A v x j f r).
Canonical Structure bnd_dealloc_form A B s v x r j f :=
  BndForm (@bnd_deallocR A B s v x j f r).
Canonical Structure try_dealloc_form A B s1 s2 v x r j f :=
  TryForm (@try_deallocR A B s1 s2 v x j f r).

Canonical Structure val_throw_form A e Q i :=
  ValForm (@val_throwR A e Q i).
Canonical Structure bnd_throw_form A B e e1 i r :=
  BndForm (@bnd_throwR A B e e1 i r).
Canonical Structure try_throw_form A B e e1 e2 i r :=
  TryForm (@try_throwR A B e e1 e2 i r).

Ltac step := (apply: hstep=>/=).

(*****************************************************************)
(* Another reflection mechanism for splitting the heap into head *)
(* and tail expressions. Note that this is a restricted version  *)
(* of the partitioning mechanism (no right branching).           *)
(*****************************************************************)

Section Uncons.

Structure tagged_heapU := TagU {untagU :> heap}.

Definition head_tagU := TagU.
Canonical Structure left_tagU i := head_tagU i.

(* - k : output head *)
(* - r : output tail *)
Definition uform_axiom k r (h : tagged_heapU) :=
  untagU h = k \+ r.

Structure uform (k : heap) r :=
  UForm {heap_ofU :> tagged_heapU;
         _ : uform_axiom k r heap_ofU}.

Arguments UForm : clear implicits.

Lemma head_pfU k : uform_axiom k Unit (head_tagU k).
Proof. by rewrite /uform_axiom unitR. Qed.

Canonical Structure heap_headU k := UForm k Unit (head_tagU k) (head_pfU k).

Lemma left_pfU h k r (f : uform k r) :
        uform_axiom k (r \+ h) (left_tagU (untagU f \+ h)).
Proof.
case: f=>f; rewrite /uform_axiom /= =>->.
by rewrite joinA.
Qed.

Canonical Structure search_leftU h k r (f : uform k r) :=
  UForm k (r \+ h) (left_tagU (untagU f \+ h)) (left_pfU h f).

End Uncons.

(***************************)
(* Ghost lemma automations *)
(***************************)

(* This is the main automated ghost lemma, which corresponds to a common     *)
(* combination of gE + vrf_frame. It allows the user to manually supply a    *)
(* heap subexpression (here named `m`) to be "consumed" by the frame rule.   *)
(* For proving the postconditions, the automation replaces the first summand *)
(* in the provided expression by a fresh heap variable and drops the rest.   *)
(*                                                                           *)
(* It uses the following algorithm:                                          *)
(*                                                                           *)
(* 1. The subexpression `m` is split into a head part `m0` and a tail part.  *)
(* 2. The tail part is syntactified into a list of terms `tm`.               *)
(* 3. The goal heap is split into a PCM expression corresponding to `tm` and *)
(*    a residual term, using the `pullX` PCM automation.                     *)
(* 4. The residual term is further split into `m0` and the framed-out heap   *)
(*    expression `r2` using the higher-order partitioning automation, which  *)
(*    simultaneously splits the postcondition heap into `n + r2` (where `n`  *)
(*    is fresh and replaces the first expression of `m`).                    *)
(*                                                                           *)
(* There are two caveats for using this lemma and its variants:              *)
(*                                                                           *)
(* 1. It rewrites the goal into a right-biased form (i.e. `x + (y + z)`).    *)
(*    This happens because it quotes the goal into a list of terms, losing   *)
(*    the associativity information. Switching to tree-based AST for quoted  *)
(*    terms could solve this, but will make the implementation more complex. *)
(* 2. It will fail if the supplied subexpression is a singleton `Unit`. This *)
(*    happens because the unconsing mechanism introduces spurious Units into *)
(*    expressions which are later "garbage collected" by quoting & printing, *)
(*    dropping user-provided Units as well.                                  *)
(*                                                                           *)
(* These issues can be circumvented by falling back to simpler (automated)   *)
(* lemmas `gU`, `gR` and their variants.                                     *)

Lemma gX G A (s : spec G A) g (m : heapPCM) m0 j tm k wh r2
             (e : STspec G s)
             (fm : Syntactify.form (empx _) j tm)
             (fu : uform m0 (Syntactify.untag fm))
             (f : forall q, form q r2)
             (fg : PullX.rform j k tm wh (Some (untag (heap_of (f m0)))))
             (Q : post A) :
        untagU fu = m ->
        (valid m -> (s g).1 m) ->
        (forall v n, (s g).2 (Val v) n ->
           valid (untag (f n)) -> Q (Val v) (f n)) ->
        (forall x n, (s g).2 (Exn x) n ->
           valid (untag (f n)) -> Q (Exn x) (f n)) ->
        vrf (fg : heapPCM) e Q.
Proof.
case: e=>e /= H; case: fu=>_ ->/= Em Hp Hv Hx; rewrite -{}Em in Hp.
rewrite (pullX (Syntactify.untag fm)) formE joinCA joinA.
apply: vrfV=>/validL/Hp/H V.
apply/vrf_frame/vrf_post/V.
by case=>[v|x] n _=>[/Hv|/Hx]; rewrite formE.
Qed.

Arguments gX [G A s] g m {m0 j tm k wh r2 e fm fu f fg Q} _ _ _ _.

Notation "[gX] @ m" := (gX tt m erefl) (at level 0).

Notation "[ 'gX' x1 , .. , xn ] @ m" :=
  (gX (existT _ x1 .. (existT _ xn tt) ..) m erefl)
  (at level 0, format "[ 'gX'  x1 ,  .. ,  xn ] @  m").

(* a combination of gX + vrf_bind *)
Lemma stepX G A B (s : spec G A) g (m : heapPCM) m0 j tm k wh r2
             (e : STspec G s) (e2 : A -> ST B)
             (fm : Syntactify.form (empx _) j tm)
             (fu : uform m0 (Syntactify.untag fm))
             (f : forall q, form q r2)
             (fg : PullX.rform j k tm wh (Some (untag (heap_of (f m0)))))
             (Q : post B) :
        untagU fu = m ->
        (valid m -> (s g).1 m) ->
        (forall v n, (s g).2 (Val v) n -> vrf (f n) (e2 v) Q) ->
        (forall x n, (s g).2 (Exn x) n ->
           valid (untag (f n)) -> Q (Exn x) (f n)) ->
        vrf (fg : heapPCM) (bind e e2) Q.
Proof.
move=>Hm Hp Hv Hx.
by apply/vrf_bind/(gX _ _ Hm Hp)=>[v n H V|x n H V _]; [apply: Hv| apply: Hx].
Qed.

Arguments stepX [G A B s] g m {m0 j tm k wh r2 e e2 fm fu f fg Q} _ _ _ _.

Notation "[stepX] @ m" := (stepX tt m erefl) (at level 0).

Notation "[ 'stepX' x1 , .. , xn ] @ m" :=
  (stepX (existT _ x1 .. (existT _ xn tt) ..) m erefl)
  (at level 0, format "[ 'stepX'  x1 ,  .. ,  xn ] @  m").

(* a combination of gX + vrf_try *)
Lemma tryX G A B (s : spec G A) g (m : heapPCM) m0 j tm k wh r2
             (e : STspec G s) (e1 : A -> ST B) (e2 : exn -> ST B)
             (fm : Syntactify.form (empx _) j tm)
             (fu : uform m0 (Syntactify.untag fm))
             (f : forall q, form q r2)
             (fg : PullX.rform j k tm wh (Some (untag (heap_of (f m0)))))
             (Q : post B) :
        untagU fu = m ->
        (valid m -> (s g).1 m) ->
        (forall v n, (s g).2 (Val v) n -> vrf (f n) (e1 v) Q) ->
        (forall x n, (s g).2 (Exn x) n -> vrf (f n) (e2 x) Q) ->
        vrf (fg : heapPCM) (try e e1 e2) Q.
Proof.
move=>Hm Hp Hv Hx.
by apply/vrf_try/(gX _ _ Hm Hp)=>[x|ex] n H V; [apply: Hv|apply: Hx].
Qed.

Arguments tryX [G A B s] g m {m0 j tm k wh r2 e e1 e2 fm fu f fg Q} _ _ _ _.

Notation "[tryX] @ m" := (stepX tt m erefl) (at level 0).

Notation "[ 'tryX' x1 , .. , xn ] @ m" :=
  (tryX (existT _ x1 .. (existT _ xn tt) ..) m erefl)
  (at level 0, format "[ 'tryX'  x1 ,  .. ,  xn ] @  m").

(**************************************)
(* Simplified ghost lemma automations *)
(**************************************)

(* A simpler version of an automated framing+ghost lemma which only works on *)
(* literal heap subexpressions (here `m`) but preserves associativity.       *)
Lemma gR G A (s : spec G A) g m r (e : STspec G s)
          (f : forall k, form k r) (Q : post A) :
        (valid m -> (s g).1 m) ->
        (forall v n, (s g).2 (Val v) n ->
           valid (untag (f n)) -> Q (Val v) (f n)) ->
        (forall x n, (s g).2 (Exn x) n ->
           valid (untag (f n)) -> Q (Exn x) (f n)) ->
        vrf (f m) e Q.
Proof.
case: e=>e /= H Hp Hv Hx; rewrite formE.
apply: vrfV=>/validL/Hp/H V.
apply/vrf_frame/vrf_post/V.
by case=>[x|ex] n _ =>[/Hv|/Hx]; rewrite formE.
Qed.

Arguments gR [G A s] g m {r e f Q} _ _ _.

Notation "[gR] @ m" := (gR tt m) (at level 0).

Notation "[ 'gR' x1 , .. , xn ] @ m" :=
  (gR (existT _ x1 .. (existT _ xn tt) ..) m)
  (at level 0, format "[ 'gR'  x1 ,  .. ,  xn ] @  m").

(* a combination of gR + vrf_bind *)
Lemma stepR G A B (s : spec G A) g i j (e : STspec G s) (e2 : A -> ST B)
             (f : forall k, form k j) (Q : post B) :
        (valid i -> (s g).1 i) ->
        (forall x m, (s g).2 (Val x) m -> vrf (f m) (e2 x) Q) ->
        (forall x m, (s g).2 (Exn x) m ->
           valid (untag (f m)) -> Q (Exn x) (f m)) ->
        vrf (f i) (bind e e2) Q.
Proof.
move=>Hi H1 H2.
apply/vrf_bind/(gR _ _ Hi)=>[x m H V|ex m H V _].
- by apply: H1 H.
by apply: H2.
Qed.

Arguments stepR [G A B s] g i [j e e2 f Q] _ _ _.

Notation "[stepR] @ i" := (stepR tt i) (at level 0).

Notation "[ 'stepR' x1 , .. , xn ] @ i" :=
  (stepR (existT _ x1 .. (existT _ xn tt) ..) i)
  (at level 0, format "[ 'stepR'  x1 ,  .. ,  xn ] @  i").

(* a combination of gR + vrf_try *)
Lemma tryR G A B (s : spec G A) g i j (e : STspec G s) (e1 : A -> ST B) (e2 : exn -> ST B)
             (f : forall k, form k j) (Q : post B) :
        (valid i -> (s g).1 i) ->
        (forall x m, (s g).2 (Val x) m -> vrf (f m) (e1 x) Q) ->
        (forall x m, (s g).2 (Exn x) m -> vrf (f m) (e2 x) Q) ->
        vrf (f i) (try e e1 e2) Q.
Proof.
move=>Hi H1 H2.
apply/vrf_try/(gR _ _ Hi)=>[x|ex] m H V.
- by apply: H1 H.
by apply: H2.
Qed.

Arguments tryR [G A B s] g i [j e e1 e2 f Q] _ _ _.

Notation "[tryR] @ i" := (tryR tt i) (at level 0).

Notation "[ 'tryR' x1 , .. , xn ] @ i" :=
  (tryR (existT _ x1 .. (existT _ xn tt) ..) i)
  (at level 0, format "[ 'tryR'  x1 ,  .. ,  xn ] @  i").

(* This is really brittle, but I didn't get around yet to substitute it *)
(* with Mtac or overloaded lemmas. So for now, let's stick with the hack *)
(* in order to support the legacy proofs *)

(* First cancelation in hypotheses *)

Section Cancellation.
Implicit Type (h : heap).

Lemma cexit1 h1 h2 h : h1 = h2 -> h1 \+ h = h \+ h2.
Proof. by move=>->; rewrite joinC. Qed.

Lemma cexit2 h1 h : h1 = Unit -> h1 \+ h = h.
Proof. by move=>->; rewrite unitL. Qed.

Lemma cexit3 h1 h : Unit = h1 -> h = h \+ h1.
Proof. by move=><-; rewrite unitR. Qed.

Lemma congUh A h1 h2 x (v1 v2 : A) :
        h1 = h2 -> v1 = v2 -> h1 \+ (x :-> v1) = h2 \+ (x :-> v2).
Proof. by move=>-> ->. Qed.

Lemma congeqUh h1 h2 h : h1 = h2 -> h1 \+ h = h2 \+ h.
Proof. by move=>->. Qed.

End Cancellation.

(* Cancellation in conclusions *)

Ltac congruencer t :=
  match goal with
  | |- ?h1 \+ t = ?h2 =>
     let j := fresh "j" in
     set j := {1}(h1 \+ t);
     rewrite -1?joinA /j {j};
     (apply: cexit1 || apply: cexit2)
  | |- t = ?h2 =>
     rewrite -1?joinA;
     (apply: cexit3 || apply: refl_equal)
  | |- (?h1 \+ (?x :-> ?v) = ?h2) =>
    let j := fresh "j" in
    set j := {1}(h1 \+ (x :-> v));
    (* if x appears in the second union, first bring it to the back *)
    rewrite 1?(joinC (x :-> _)) -?(joinAC _ _ (x :-> _)) /j {j};
    (* then one of the following must apply *)
    (* if x is in the second union then cancel *)
    ((apply: congUh; [congruencer t | idtac]) ||
    (* if not, rotate x in the first union *)
     (rewrite (joinC h1) ?joinA; congruencer t))
  (* if the heap is not a points-to relation, also try to cancel *)
  | |- (?h1 \+ ?h = ?h2) =>
    let j := fresh "j" in
    set j := {1}(h1 \+ h);
    (* if h appears in the second union, first bring it to the back *)
    rewrite 1?(joinC h) -?(joinAC _ _ h) /j {j};
    (* then one of the following must apply *)
    (* if h is in the second union then cancel *)
    (apply: congeqUh ||
    (* if not, rotate h in the first union *)
    rewrite (joinC h1) ?joinA);
    (* and proceed *)
    congruencer t
  | |- _ => idtac
  end.

Ltac heap_congr :=
  match goal with
  | |- ?h1 = ?h2 =>
    let t1 := fresh "t1" in
    let t2 := fresh "t2" in
    let t := fresh "t" in
      set t1 := {1}h1; set t2 := {1}h2;
      (* introduce terminators *)
      rewrite -(unitL t1) -(unitL t2) [Unit]lock;
      set t := locked Unit; rewrite /t1 /t2 {t1 t2};
      (* flatten the goal *)
      rewrite ?joinA;
      (* call the congruence routine and remove the terminator *)
      congruencer t=>{t}
  | |- _ => idtac
  end.

(* we keep some tactics to kill final goals, which *)
(* are usually full of existentials *)
Ltac vauto := (do ?econstructor=>//).
Ltac hhauto := (vauto; try by [heap_congr])=>//.
Ltac heval := do ![step | by hhauto].


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_bnd_sha_sel_reduce :
  forall T1 x1 L1, T1 = (t_sel_bnd x1 L1) ->
                  forall T2 x2 L2 ss2 T', T2 = (t_sha_sel x2 L2 ss2 T') ->
                                     subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.global.workload.
Require Import prosa.classic.model.schedule.global.basic.schedule.
Require Import prosa.classic.model.schedule.apa.affinity.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module Interference.

  Import Schedule ScheduleOfSporadicTask Priority Workload Affinity.

  (* In this section, we define the notion of a possible interfering task. *)
  Section PossibleInterferingTasks.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    (* Consider an APA platform with affinity alpha. *)
    Context {num_cpus: nat}.
    Variable alpha: task_affinity sporadic_task num_cpus.

    Section FP.

      (* Assume an FP policy. *)
      Variable higher_eq_priority: FP_policy sporadic_task.

      (* Let tsk be the task to be analyzed ... *)
      Variable tsk: sporadic_task.

      (* ...assuming a subaffinity alpha'. *)
      Variable alpha': affinity num_cpus.

      (* Let tsk_other be another task. *)
      Variable tsk_other: sporadic_task.

      (* Under FP scheduling with constrained deadlines, tsk_other can only interfere
         with tsk if it is a different task with higher or equal priority and
         intersecting affinity. *)
      Definition higher_priority_task_in :=
        higher_eq_priority tsk_other tsk &&
        (tsk_other != tsk) &&
        affinity_intersects alpha' (alpha tsk_other).

    End FP.

    Section JLFP.

      (* Let tsk be the task to be analyzed ... *)
      Variable tsk: sporadic_task.

      (* ...assuming a subaffinity alpha'. *)
      Variable alpha': affinity num_cpus.

      (* Let tsk_other be another task. *)
      Variable tsk_other: sporadic_task.

      (* Under JLFP/JLDP scheduling with constrained deadlines, tsk_other can only interfere
         with tsk if it is a different task with intersecting affinity. *)
      Definition different_task_in :=
        (tsk_other != tsk) &&
        affinity_intersects alpha' (alpha tsk_other).

    End JLFP.

  End PossibleInterferingTasks.

  Section InterferenceDefs.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Assume any job arrival sequence...*)
    Context {arr_seq: arrival_sequence Job}.

    (* ... and any schedule. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    (* Assume that every job at any time has a processor affinity alpha. *)
    Variable alpha: task_affinity sporadic_task num_cpus.

    (* Consider any job j that incurs interference. *)
    Variable j: Job.

    (* Recall the definition of backlogged (pending and not scheduled). *)
    Let job_is_backlogged (t: time) := backlogged job_arrival job_cost sched j t.

    (* First, we define total interference. *)
    Section TotalInterference.

      (* The total interference incurred by job j during [t1, t2) is the
         cumulative time in which j is backlogged in this interval. *)
      Definition total_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2) job_is_backlogged t.

    End TotalInterference.

    (* Next, we define job interference. *)
    Section JobInterference.

      (* Let job_other be a job that interferes with j. *)
      Variable job_other: Job.

      (* The interference caused by job_other during [t1, t2) is the cumulative
         time in which j is backlogged while job_other is scheduled. *)
      Definition job_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t &&
            can_execute_on alpha (job_task j) cpu &&
            scheduled_on sched job_other cpu t).

    End JobInterference.

    (* Next, we define task interference. *)
    Section TaskInterference.

      (* Consider any interfering task tsk_other. *)
      Variable tsk_other: sporadic_task.

      (* The interference caused by tsk during [t1, t2) is the cumulative time
         in which j is backlogged while tsk is scheduled. *)
      Definition task_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t &&
            can_execute_on alpha (job_task j) cpu &&
            task_scheduled_on job_task sched tsk_other cpu t).

    End TaskInterference.

    (* Next, we define an approximation of the total interference based on
       each per-task interference. *)
    Section TaskInterferenceJobList.

      Variable tsk_other: sporadic_task.

      Definition task_interference_joblist (t1 t2: time) :=
        \sum_(j <- jobs_scheduled_between sched t1 t2 | job_task j == tsk_other)
         job_interference j t1 t2.

    End TaskInterferenceJobList.

    (* Now we prove some basic lemmas about interference. *)
    Section BasicLemmas.

      (* Total interference cannot be larger than the considered time window. *)
      Lemma total_interference_le_delta :
        forall t1 t2,
          total_interference t1 t2 <= t2 - t1.
      Proof.
        unfold total_interference; intros t1 t2.
        apply leq_trans with (n := \sum_(t1 <= t < t2) 1);
          first by apply leq_sum; ins; apply leq_b1.
        by rewrite big_const_nat iter_addn mul1n addn0 leqnn.
      Qed.

      (* Job interference is bounded by the service of the interfering job. *)
      Lemma job_interference_le_service :
        forall j_other t1 t2,
          job_interference j_other t1 t2 <= service_during sched j_other t1 t2.
      Proof.
        intros j_other t1 t2; unfold job_interference, service_during.
        apply leq_sum; intros t _.
        unfold service_at; rewrite [\sum_(_ < _ | scheduled_on _ _ _  _)_]big_mkcond.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        destruct (can_execute_on alpha (job_task j) cpu); [rewrite andTb | by rewrite andFb].
        by destruct (scheduled_on sched j_other cpu t).
      Qed.

      (* Task interference is bounded by the workload of the interfering task. *)
      Lemma task_interference_le_workload :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= workload job_task sched tsk t1 t2.
      Proof.
        unfold task_interference, workload; intros tsk t1 t2.
        apply leq_sum; intros t _.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        destruct (can_execute_on alpha (job_task j) cpu); [rewrite andTb | by rewrite andFb].
        unfold task_scheduled_on, service_of_task.
        by destruct (sched cpu t).
      Qed.

    End BasicLemmas.

    (* Now we prove some bounds on interference for sequential jobs. *)
    Section InterferenceNoParallelism.

      (* If jobs are sequential, ... *)
      Hypothesis H_sequential_jobs: sequential_jobs sched.

      (* ... then the interference incurred by a job in an interval
         of length delta is at most delta. *)
      Lemma job_interference_le_delta :
        forall j_other t1 delta,
          job_interference j_other t1 (t1 + delta) <= delta.
      Proof.
        rename H_sequential_jobs into SEQ.
        unfold job_interference, sequential_jobs in *.
        intros j_other t1 delta.
        apply leq_trans with (n := \sum_(t1 <= t < t1 + delta) 1);
          last by rewrite big_const_nat iter_addn mul1n addn0 addKn leqnn.
        apply leq_sum; intros t _.
        destruct ([exists cpu, scheduled_on sched j_other cpu t]) eqn:EX.
        {
          move: EX => /existsP [cpu SCHED].
          rewrite (bigD1 cpu) // /=.
          rewrite big_mkcond (eq_bigr (fun x => 0)) /=;
            first by simpl_sum_const; rewrite leq_b1.
          intros cpu' _; des_if_goal; last by done.
          destruct (scheduled_on sched j_other cpu' t) eqn:SCHED'; last by rewrite andbF.
          move: SCHED SCHED' => /eqP SCHED /eqP SCHED'.
          by specialize (SEQ j_other t cpu cpu' SCHED SCHED'); rewrite SEQ in Heq.
        }
        {
          apply negbT in EX; rewrite negb_exists in EX.
          move: EX => /forallP EX.
          rewrite (eq_bigr (fun x => 0)); first by simpl_sum_const.
          by intros cpu _; specialize (EX cpu); apply negbTE in EX; rewrite EX andbF.
        }
      Qed.

    End InterferenceNoParallelism.

    (* Next, we show that the cumulative per-task interference bounds the total
       interference. *)
    Section BoundUsingPerTaskInterference.

      Lemma interference_le_interference_joblist :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= task_interference_joblist tsk t1 t2.
      Proof.
        intros tsk t1 t2.
        unfold task_interference, task_interference_joblist, job_interference, job_is_backlogged.
        rewrite [\sum_(_ <- _ sched _ _ | _) _]exchange_big /=.
        rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
        apply leq_sum; move => t /andP [LEt _].
        rewrite exchange_big /=.
        apply leq_sum; intros cpu _.
        destruct (backlogged job_arrival job_cost sched j t) eqn:BACK;
          last by rewrite andFb (eq_bigr (fun x => 0));
            first by rewrite big_const_seq iter_addn mul0n addn0.
        rewrite andTb.
        destruct (task_scheduled_on job_task sched tsk cpu t) eqn:SCHED;
          [rewrite andbT | by rewrite andbF].
        unfold scheduled_on, task_scheduled_on in *.
        destruct (sched cpu t) as [j' |] eqn:SOME; last by done.
        rewrite big_mkcond /= (bigD1_seq j') /=; last by apply undup_uniq.
        {
          by rewrite SCHED eq_refl andbT leq_addr.
        }
        {
          unfold jobs_scheduled_between.
          rewrite mem_undup; apply mem_bigcat_nat with (j := t);
            first by done.
          apply mem_bigcat_ord with (j := cpu); first by apply ltn_ord.
          by unfold make_sequence; rewrite SOME mem_seq1 eq_refl.
        }
      Qed.

    End BoundUsingPerTaskInterference.

  End InterferenceDefs.

End Interference.


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.theory.rationals
               HoTT.Classes.orders.orders
               HoTT.Classes.interfaces.integers
               HoTT.Classes.interfaces.naturals
               HoTT.Classes.implementations.natpair_integers
               HoTT.Classes.theory.integers
               HoTT.Classes.implementations.assume_rationals
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe UnivalenceImpliesFunext
               TruncType UnivalenceAxiom HIT.quotient
               Basics.FunextVarieties FunextAxiom
               Types.Prod HIT.Truncations HIT.unique_choice.

Require Import HoTTClasses.sierpinsky partiality dedekind.

(** * Dominance *)

(** Definition of dominance *)
Definition dominance (Σ : Type0) (is_top : Σ -> Type) :=
           forall (u:hProp) (s:Σ),
             (is_top s -> hexists (fun z:Σ => is_top z = u)) ->
             hexists (fun m:Σ => merely (is_top m)
                               = merely (u /\ (is_top s))).

Print LoadPath.

(** Sier is a dominance*)
Lemma dominance_sier : dominance Sier IsTop.
Proof.
intros p u.
revert u.
apply (partial_ind0 _ (fun a => _ -> _)).
+ intros t Ht; destruct t.
  assert (Htrue : IsTop (eta Unit tt)).
  red; apply top_greatest.
  specialize (Ht Htrue).
  unfold hexists in *;
  revert Ht; apply (Trunc_ind _).
  intros (z,Hz). apply tr.
  exists (meet (eta Unit tt) z).
  unfold meet; rewrite Hz.
  apply path_trunctype.
  apply equiv_iff_hprop.
  apply (Trunc_ind _); intros H; apply tr.
  split; trivial.
  apply (Trunc_ind _); intros (H,_);
  apply tr; trivial.
+ intros Hf; apply tr.
  exists (bot Unit).
  apply path_trunctype.
  apply equiv_iff_hprop.
  apply (Trunc_ind _); intros H;
  apply not_bot in H; case H.
  apply (Trunc_ind _); intros (_,H);
  apply tr; trivial.
+ intros f Hn Hf.
  assert (Hnn : forall n,
       hexists (fun m : Sier => merely m =
                  merely (p /\ IsTop (f n)))).
  intros n.
  specialize (Hn n).
  assert (H : IsTop (f n) ->
              hexists (fun z: Sier => IsTop z = p)).
  intros Hn'.
  assert (Ht : IsTop (sup Unit f)).
  apply top_le_sup; apply tr;
  exists n; trivial.
  specialize (Hf Ht); trivial.
  apply (Hn H).
  generalize (unique_choice (fun n =>
        (fun m:Sier => merely m = merely (p /\ IsTop (f n))))).
  intros Huc.
  assert (Hp : (forall (x : nat) (y : Sier),
     IsHProp (merely y = merely (p /\ IsTop (f x))))).
  apply _.
  specialize (Huc Hp).
  assert (Hu : (forall x : nat, hunique (fun m : Sier => merely m =
                        merely (p /\ IsTop (f x))))).
  intros n; split; try trivial.
  intros s1 s2 Hs1 Hs2.
  apply (antisymmetry le).
  - apply imply_le; intros H1.
    assert (He1 : merely s1 <-> s1).
    split. apply (Trunc_ind _); trivial.
    intros I; apply tr; trivial.
    assert (He2 : merely s2 <-> s2).
    split. apply (Trunc_ind _); trivial.
    intros I; apply tr; trivial.
    apply He2; apply He1 in H1.
    rewrite Hs2.
    rewrite Hs1 in H1; trivial.
  - apply imply_le; intros H2.
    assert (He1 : merely s1 <-> s1).
    split. apply (Trunc_ind _); trivial.
    intros I; apply tr; trivial.
    assert (He2 : merely s2 <-> s2).
    split. apply (Trunc_ind _); trivial.
    intros I; apply tr; trivial.
    apply He1; apply He2 in H2.
    rewrite Hs1.
    rewrite Hs2 in H2; trivial.
  - specialize (Huc Hu).
    destruct Huc as (ff,Hff).
    assert (NatEnum : Enumerable nat).
    exists (fun n => n); apply _.
    pose (supf := EnumerableSup nat (fun n => ff n)).
    apply tr; exists supf.
    apply path_trunctype.
    apply equiv_iff_hprop.
    assert (Hff_eq : forall n : nat, merely (ff n) <->
                              merely (p /\ IsTop (f n))).
    intros n; rewrite Hff.
    split; trivial.
    apply (Trunc_ind _); intros HK.
    apply top_le_enumerable_sup in HK.
    revert HK; apply (Trunc_ind _); intros (x,Hx).
    assert (Hx2 : merely (ff x)).
    apply tr; trivial.
    apply Hff_eq in Hx2.
    revert Hx2; apply (Trunc_ind _);
    intros (H,H'); apply tr.
    split; trivial.
    apply top_le_sup; apply tr;
    exists x; trivial.
    assert (Hff_eq : forall n : nat, merely (ff n) <->
                              merely (p /\ IsTop (f n))).
    intros n; rewrite Hff.
    split; trivial. clear Hp Hu.
    apply (Trunc_ind _); intros (Hp,HK).
    apply top_le_sup in HK.
    revert HK; apply (Trunc_ind _); intros (x,Hx).
    assert (HU : merely (p /\ IsTop (f x))).
    apply tr; split; trivial.
    apply Hff_eq in HU.
    revert HU; apply (Trunc_ind _); intros HU.
    apply tr; apply top_le_enumerable_sup.
    apply tr; exists x; trivial.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e401m31_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(****************************************************************************

 Equifiers in bicategories

 Contents
 1. Cones
 2. The universal mapping property
 3. Alternative formulation of equifier via universal cones
 4. Bicategories with equifiers
 5. Equifiers are fully faithful

 ****************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.

Local Open Scope cat.

Section Equifiers.
  Context {B : bicat}
          {b₁ b₂ : B}
          {f g : b₁ --> b₂}
          {α β : f ==> g}.

  (**
   1. Cones
   *)
  Definition equifier_cone
    : UU
    := ∑ (i : B)
         (m : i --> b₁),
       m ◃ α = m ◃ β.

  Definition make_equifier_cone
             (i : B)
             (m : i --> b₁)
             (α : m ◃ α = m ◃ β)
    : equifier_cone
    := i ,, m ,, α.

  Coercion equifier_cone_ob
           (cone : equifier_cone)
    : B
    := pr1 cone.

  Definition equifier_cone_pr1
             (cone : equifier_cone)
    : cone --> b₁
    := pr12 cone.

  Definition equifier_cone_eq
             (cone : equifier_cone)
    : equifier_cone_pr1 cone ◃ α = equifier_cone_pr1 cone ◃ β
    := pr22 cone.

  Definition equifier_1cell
             (cone₁ cone₂ : equifier_cone)
    : UU
    := ∑ (k : cone₁ --> cone₂),
       invertible_2cell
         (k · equifier_cone_pr1 cone₂)
         (equifier_cone_pr1 cone₁).

  Definition make_equifier_1cell
             {cone₁ cone₂ : equifier_cone}
             (k : cone₁ --> cone₂)
             (α : invertible_2cell
                    (k · equifier_cone_pr1 cone₂)
                    (equifier_cone_pr1 cone₁))
    : equifier_1cell cone₁ cone₂
    := k ,, α.

  Coercion equifier_1cell_mor
           {cone₁ cone₂ : equifier_cone}
           (u : equifier_1cell cone₁ cone₂)
    : cone₁ --> cone₂
    := pr1 u.

  Definition equifier_1cell_pr1
             {cone₁ cone₂ : equifier_cone}
             (u : equifier_1cell cone₁ cone₂)
    : invertible_2cell
        (u · equifier_cone_pr1 cone₂)
        (equifier_cone_pr1 cone₁)
    := pr2 u.

  Definition path_equifier_1cell
             {cone₁ cone₂ : equifier_cone}
             (φ ψ : equifier_1cell cone₁ cone₂)
             (p₁ : pr1 φ = pr1 ψ)
             (p₂ : pr12 φ = (idtoiso_2_1 _ _ p₁ ▹ _) • pr12 ψ)
    : φ = ψ.
  Proof.
    induction φ as [ φ₁ [ φ₂ φ₃ ]].
    induction ψ as [ ψ₁ [ ψ₂ ψ₃ ]].
    cbn in *.
    induction p₁.
    apply maponpaths.
    use subtypePath.
    {
      intro.
      apply isaprop_is_invertible_2cell.
    }
    cbn in p₂.
    rewrite id2_rwhisker, id2_left in p₂.
    exact p₂.
  Qed.

  (**
   2. The universal mapping property
   *)
  Section UniversalMappingProperty.
    Context (cone : equifier_cone).

    Definition has_equifier_ump_1
      : UU
      := ∏ (other_cone : equifier_cone),
         equifier_1cell other_cone cone.

    Definition has_equifier_ump_2
      : UU
      := ∏ (x : B)
           (u₁ u₂ : x --> cone)
           (α : u₁ · equifier_cone_pr1 cone
                ==>
                u₂ · equifier_cone_pr1 cone),
         ∑ (ζ : u₁ ==> u₂),
         ζ ▹ equifier_cone_pr1 cone = α.

    Definition has_equifier_ump_eq
      : UU
      := ∏ (x : B)
           (u₁ u₂ : x --> cone)
           (α : u₁ · equifier_cone_pr1 cone
                ==>
                u₂ · equifier_cone_pr1 cone)
           (φ₁ φ₂ : u₁ ==> u₂)
           (q₁ : φ₁ ▹ equifier_cone_pr1 cone = α)
           (q₂ : φ₂ ▹ equifier_cone_pr1 cone = α),
         φ₁ = φ₂.

    Definition has_equifier_ump
      : UU
      := has_equifier_ump_1 × has_equifier_ump_2 × has_equifier_ump_eq.
  End UniversalMappingProperty.

  Section Projections.
    Context {cone : equifier_cone}
            (H : has_equifier_ump cone).

    Definition equifier_ump_mor
               {i : B}
               (m : i --> b₁)
               (p : m ◃ α = m ◃ β)
      : i --> cone
      := pr1 H (make_equifier_cone i m p).

    Definition equifier_ump_mor_pr1
               {i : B}
               (m : i --> b₁)
               (p : m ◃ α = m ◃ β)
      : invertible_2cell
          (equifier_ump_mor m p · equifier_cone_pr1 cone)
          m
      := equifier_1cell_pr1 (pr1 H (make_equifier_cone i m p)).

    Definition equifier_ump_cell
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
      : u₁ ==> u₂
      := pr1 (pr12 H x u₁ u₂ ζ).

    Definition equifier_ump_cell_pr1
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
      : equifier_ump_cell ζ ▹ equifier_cone_pr1 cone = ζ
      := pr2 (pr12 H x u₁ u₂ ζ).

    Definition equifier_ump_eq
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
               (φ₁ φ₂ : u₁ ==> u₂)
               (q₁ : φ₁ ▹ equifier_cone_pr1 cone = ζ)
               (q₂ : φ₂ ▹ equifier_cone_pr1 cone = ζ)
      : φ₁ = φ₂
      := pr22 H x u₁ u₂ ζ φ₁ φ₂ q₁ q₂.

    Definition equifier_ump_eq_alt
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
               (φ₁ φ₂ : u₁ ==> u₂)
               (q : φ₁ ▹ equifier_cone_pr1 cone
                    =
                    φ₂ ▹ equifier_cone_pr1 cone)
      : φ₁ = φ₂.
    Proof.
      use equifier_ump_eq.
      - exact (φ₁ ▹ equifier_cone_pr1 cone).
      - apply idpath.
      - exact (!q).
    Qed.

    Definition is_invertible_equifier_ump_cell
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
               (Hζ : is_invertible_2cell ζ)
      : is_invertible_2cell (equifier_ump_cell ζ).
    Proof.
      use make_is_invertible_2cell.
      - exact (equifier_ump_cell (Hζ^-1)).
      - abstract
          (use (equifier_ump_eq_alt (id2 _)) ;
           rewrite <- !rwhisker_vcomp ;
           rewrite !equifier_ump_cell_pr1 ;
           rewrite vcomp_rinv ;
           rewrite id2_rwhisker ;
           apply idpath).
      - abstract
          (use (equifier_ump_eq_alt (id2 _)) ;
           rewrite <- !rwhisker_vcomp ;
           rewrite !equifier_ump_cell_pr1 ;
           rewrite vcomp_linv ;
           rewrite id2_rwhisker ;
           apply idpath).
    Defined.
  End Projections.

  (**
   3. Alternative formulation of equifier via universal cones
   *)
  Definition universal_equifier_cat
             (x : B)
    : category.
  Proof.
    refine (full_sub_category
              (hom x b₁)
              (λ h,
               make_hProp
                 (h ◃ α = h ◃ β)
                 _)).
    apply cellset_property.
  Defined.

  Definition univalent_universal_equifier_cat
             (HB_2_1 : is_univalent_2_1 B)
             (x : B)
    : univalent_category.
  Proof.
    use make_univalent_category.
    - exact (universal_equifier_cat x).
    - use is_univalent_full_subcat.
      use is_univ_hom.
      exact HB_2_1.
  Defined.

  Definition to_universal_equifier_cat_data
             (cone : equifier_cone)
             (x : B)
    : functor_data
        (hom x cone)
        (universal_equifier_cat x).
  Proof.
    use make_functor_data.
    - refine (λ h, h · equifier_cone_pr1 cone ,, _) ; cbn.
      abstract
        (use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ] ;
         rewrite <- !lwhisker_lwhisker ;
         apply maponpaths_2 ;
         apply maponpaths ;
         exact (equifier_cone_eq cone)).
    - exact (λ h₁ h₂ ζ, ζ ▹ _ ,, tt).
  Defined.

  Definition to_universal_equifier_cat_is_functor
             (cone : equifier_cone)
             (x : B)
    : is_functor (to_universal_equifier_cat_data cone x).
  Proof.
    split.
    - intro h ; cbn.
      use subtypePath.
      {
        intro.
        apply isapropunit.
      }
      cbn.
      apply id2_rwhisker.
    - intros h₁ h₂ h₃ ζ₁ ζ₂ ; cbn.
      use subtypePath.
      {
        intro.
        apply isapropunit.
      }
      cbn.
      refine (!_).
      apply rwhisker_vcomp.
  Qed.

  Definition to_universal_equifier_cat
             (cone : equifier_cone)
             (x : B)
    : hom x cone ⟶ universal_equifier_cat x.
  Proof.
    use make_functor.
    - exact (to_universal_equifier_cat_data cone x).
    - exact (to_universal_equifier_cat_is_functor cone x).
  Defined.

  Definition is_univeral_equifier_cone
             (cone : equifier_cone)
    : UU
    := ∏ (x : B),
       adj_equivalence_of_cats
         (to_universal_equifier_cat cone x).

  Section MakeUniversalEquifierCone.
    Context (cone : equifier_cone)
            (H : has_equifier_ump cone)
            (x : B).

    Definition make_is_universal_equifier_cone_full
      : full (to_universal_equifier_cat cone x).
    Proof.
      intros u₁ u₂ ζ.
      apply hinhpr.
      simple refine (_ ,, _).
      - use (equifier_ump_cell H).
        exact (pr1 ζ).
      - abstract
          (use subtypePath ; [ intro  ; apply isapropunit | ] ;
           apply (equifier_ump_cell_pr1 H)).
    Defined.

    Definition make_is_universal_equifier_cone_faithful
      : faithful (to_universal_equifier_cat cone x).
    Proof.
      intros u₁ u₂ ζ₁.
      use invproofirrelevance.
      intros φ₁ φ₂.
      use subtypePath.
      {
        intro.
        apply homset_property.
      }
      use (equifier_ump_eq_alt H).
      - exact (pr1 ζ₁).
      - exact (maponpaths pr1 (pr2 φ₁ @ !(pr2 φ₂))).
    Qed.

    Definition make_is_universal_equifier_cone_essentially_surjective
      : essentially_surjective (to_universal_equifier_cat cone x).
    Proof.
      intros h.
      apply hinhpr.
      simple refine (_ ,, _).
      - use (equifier_ump_mor H).
        + exact (pr1 h).
        + exact (pr2 h).
      - cbn.
        use iso_in_sub_from_iso ; cbn.
        use inv2cell_to_z_iso.
        apply equifier_ump_mor_pr1.
    Defined.
  End MakeUniversalEquifierCone.

  Definition make_is_universal_equifier_cone
             (HB_2_1 : is_univalent_2_1 B)
             (cone : equifier_cone)
             (H : has_equifier_ump cone)
    : is_univeral_equifier_cone cone.
  Proof.
    intro x.
    use rad_equivalence_of_cats.
    - apply is_univ_hom.
      exact HB_2_1.
    - use full_and_faithful_implies_fully_faithful.
      split.
      + apply make_is_universal_equifier_cone_full.
        exact H.
      + apply make_is_universal_equifier_cone_faithful.
        exact H.
    - apply make_is_universal_equifier_cone_essentially_surjective.
      exact H.
  Defined.

  Section UniversalConeHasUMP.
    Context (cone : equifier_cone)
            (H : is_univeral_equifier_cone cone).

    Section UMP1.
      Context (q : equifier_cone).

      Let q' : universal_equifier_cat q
        := equifier_cone_pr1 q ,, equifier_cone_eq q.

      Definition universal_equifier_cone_has_ump_1_mor
        : q --> cone
        := right_adjoint (H q) q'.

      Definition universal_equifier_cone_has_ump_1_pr1
        : invertible_2cell
            (universal_equifier_cone_has_ump_1_mor · equifier_cone_pr1 cone)
            (equifier_cone_pr1 q).
      Proof.
        use z_iso_to_inv2cell.
        exact (iso_from_iso_in_sub
                 _ _ _ _
                 (nat_z_iso_pointwise_z_iso
                    (counit_nat_z_iso_from_adj_equivalence_of_cats (H q))
                    q')).
      Defined.
    End UMP1.

    Definition universal_equifier_cone_has_ump_1
      : has_equifier_ump_1 cone.
    Proof.
      intro q.
      use make_equifier_1cell.
      - exact (universal_equifier_cone_has_ump_1_mor q).
      - exact (universal_equifier_cone_has_ump_1_pr1 q).
    Defined.
  End UniversalConeHasUMP.

  Section UMP2.
    Context (cone : equifier_cone)
            (H : is_univeral_equifier_cone cone)
            {x : B}
            {u₁ u₂ : x --> cone}
            (ζ : u₁ · equifier_cone_pr1 cone
                 ==>
                 u₂ · equifier_cone_pr1 cone).

    Definition universal_equifier_cone_has_ump_2_cell
      : u₁ ==> u₂.
    Proof.
      apply (invmap (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))).
      simple refine (_ ,, _).
      - exact ζ.
      - exact tt.
    Defined.

    Definition universal_equifier_cone_has_ump_2_pr1
      : universal_equifier_cone_has_ump_2_cell ▹ equifier_cone_pr1 cone
        =
        ζ.
    Proof.
      exact (maponpaths
               pr1
               (homotweqinvweq
                  (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))
                  _)).
    Qed.
  End UMP2.

  Definition universal_equifier_cone_has_ump_2
             (cone : equifier_cone)
             (H : is_univeral_equifier_cone cone)
    : has_equifier_ump_2 cone.
  Proof.
    intros x u₁ u₂ ζ.
    simple refine (_ ,, _).
    - exact (universal_equifier_cone_has_ump_2_cell cone H ζ).
    - exact (universal_equifier_cone_has_ump_2_pr1 cone H ζ).
  Defined.

  Definition universal_equifier_cone_has_ump_eq
             (cone : equifier_cone)
             (H : is_univeral_equifier_cone cone)
    : has_equifier_ump_eq cone.
  Proof.
    intros x u₁ u₂ ζ φ₁ φ₂ p q.
    use (invmaponpathsweq
           (make_weq
              _
              (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))) ; cbn.
    use subtypePath.
    {
      intro.
      apply isapropunit.
    }
    cbn.
    exact (p @ !q).
  Qed.

  Definition universal_equifier_cone_has_ump
             (cone : equifier_cone)
             (H : is_univeral_equifier_cone cone)
    : has_equifier_ump cone.
  Proof.
    simple refine (_ ,, _ ,, _).
    - exact (universal_equifier_cone_has_ump_1 cone H).
    - exact (universal_equifier_cone_has_ump_2 cone H).
    - exact (universal_equifier_cone_has_ump_eq cone H).
  Defined.

  Definition isaprop_has_equifier_ump
             (HB_2_1 : is_univalent_2_1 B)
             (cone : equifier_cone)
    : isaprop (has_equifier_ump cone).
  Proof.
    use invproofirrelevance.
    intros χ₁ χ₂.
    use pathsdirprod.
    - use funextsec.
      intro q.
      use path_equifier_1cell.
      + apply (isotoid_2_1 HB_2_1).
        use make_invertible_2cell.
        * use (equifier_ump_cell χ₁).
          exact (equifier_1cell_pr1 (pr1 χ₁ q) • (equifier_1cell_pr1 (pr1 χ₂ q))^-1).
        * use is_invertible_equifier_ump_cell.
          is_iso.
          apply property_from_invertible_2cell.
      + rewrite idtoiso_2_1_isotoid_2_1.
        cbn.
        rewrite equifier_ump_cell_pr1.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
    - use pathsdirprod.
      + use funextsec ; intro x.
        use funextsec ; intro u₁.
        use funextsec ; intro u₂.
        use funextsec ; intro φ.
        use subtypePath.
        {
          intro.
          apply cellset_property.
        }
        use (equifier_ump_eq χ₁).
        * exact φ.
        * exact (pr2 ((pr12 χ₁) x u₁ u₂ φ)).
        * exact (pr2 ((pr12 χ₂) x u₁ u₂ φ)).
      + do 8 (use funextsec ; intro).
        apply cellset_property.
  Qed.

  Definition isaprop_is_universal_equifier_cone
             (HB_2_1 : is_univalent_2_1 B)
             (cone : equifier_cone)
    : isaprop (is_univeral_equifier_cone cone).
  Proof.
    use impred.
    intro x.
    use isofhlevelweqf.
    - exact (@left_adjoint_equivalence
               bicat_of_univ_cats
               (univ_hom HB_2_1 x cone)
               (univalent_universal_equifier_cat HB_2_1 x)
               (to_universal_equifier_cat cone x)).
    - exact (@adj_equiv_is_equiv_cat
               (univ_hom HB_2_1 x cone)
               (univalent_universal_equifier_cat HB_2_1 x)
               (to_universal_equifier_cat cone x)).
    - apply isaprop_left_adjoint_equivalence.
      exact univalent_cat_is_univalent_2_1.
  Defined.

  Definition equifier_ump_weq_is_universal
             (HB_2_1 : is_univalent_2_1 B)
             (cone : equifier_cone)
    : has_equifier_ump cone ≃ is_univeral_equifier_cone cone.
  Proof.
    use weqimplimpl.
    - exact (make_is_universal_equifier_cone HB_2_1 cone).
    - exact (universal_equifier_cone_has_ump cone).
    - exact (isaprop_has_equifier_ump HB_2_1 cone).
    - exact (isaprop_is_universal_equifier_cone HB_2_1 cone).
  Defined.
End Equifiers.

Arguments equifier_cone {_ _ _} _ _.

(**
 4. Bicategories with equifiers
 *)
Definition has_equifiers
           (B : bicat)
  : UU
  := ∏ (b₁ b₂ : B)
       (f g : b₁ --> b₂)
       (α β : f ==> g),
     ∑ (i : B)
       (m : i --> b₁)
       (p : m ◃ α = m ◃ β),
     has_equifier_ump (make_equifier_cone i m p).

(**
 5. Equifiers are fully faithful
 *)
Definition equifier_faithful
           {B : bicat}
           {b₁ b₂ : B}
           {f g : b₁ --> b₂}
           {α β : f ==> g}
           {i : B}
           (m : i --> b₁)
           (p :  m ◃ α = m ◃ β)
           (H : has_equifier_ump (make_equifier_cone i m p))
  : faithful_1cell m.
Proof.
  intros x g₁ g₂ β₁ β₂ q.
  use (equifier_ump_eq_alt H) ; cbn.
  - exact (β₁ ▹ m).
  - exact q.
Defined.

Definition equifier_fully_faithful
           {B : bicat}
           {b₁ b₂ : B}
           {f g : b₁ --> b₂}
           {α β : f ==> g}
           {i : B}
           (m : i --> b₁)
           (p :  m ◃ α = m ◃ β)
           (H : has_equifier_ump (make_equifier_cone i m p))
  : fully_faithful_1cell m.
Proof.
  use make_fully_faithful.
  - exact (equifier_faithful m p H).
  - intros z g₁ g₂ βf.
    simple refine (_ ,, _).
    + exact (equifier_ump_cell H βf).
    + exact (equifier_ump_cell_pr1 H βf).
Defined.


Require Import Coq.Numbers.BinNums.
Require Import Coq.PArith.BinPosDef.
Require Import Logic.lib.PTree.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Lists.List.
Import ListNotations.

Module Type LanguageSig.
(* primitive_types *)
  Parameter model : Type .
(* derived types *)
  Definition expr := (model -> Prop) .
(* primitive judgements *)
(* primitive connectives *)
  Parameter join : (model -> model -> model -> Prop) .
  Parameter is_unit : (model -> Prop) .
End LanguageSig.

Module DerivedNames (Names: LanguageSig).
Include Names.
(* derived connectives *)
  Definition impp := (fun (x y : model -> Prop) (m : model) => x m -> y m) .
  Definition andp := (fun (x y : model -> Prop) (m : model) => x m /\ y m) .
  Definition orp := (fun (x y : model -> Prop) (m : model) => x m \/ y m) .
  Definition coq_prop := (fun (P : Prop) (_ : model) => P) .
  Definition sepcon := (fun (x y : model -> Prop) (m : model) => exists m1 m2 : model, join m1 m2 m /\ x m1 /\ y m2) .
  Definition emp := (fun m : model => is_unit m) .
(* derived judgements *)
  Definition provable := (fun x : model -> Prop => forall m : model, x m) .
  Definition derivable1 := (fun x y : expr => provable (impp x y)) .
End DerivedNames.

Module Type PrimitiveRuleSig (Names: LanguageSig).
Include DerivedNames (Names).
  Axiom join_comm : (forall m1 m2 m : model, join m1 m2 m -> join m2 m1 m) .
  Axiom join_assoc : (forall mx my mz mxy mxyz : model, join mx my mxy -> join mxy mz mxyz -> exists myz : model, join my mz myz /\ join mx myz mxyz) .
End PrimitiveRuleSig.

Module Type LogicTheoremSig (Names: LanguageSig) (Rules: PrimitiveRuleSig Names).
Include Rules.
Parameter Inline tree_pos : Type .
(* derived rules *)
  Axiom derivable1_sepcon_comm : (forall x y : expr, derivable1 (sepcon x y) (sepcon y x)) .
  Axiom derivable1_sepcon_assoc1 : (forall x y z : expr, derivable1 (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)) .
  Axiom derivable1_sepcon_mono : (forall x1 x2 y1 y2 : expr, derivable1 x1 x2 -> derivable1 y1 y2 -> derivable1 (sepcon x1 y1) (sepcon x2 y2)) .
  Axiom sepcon_comm_impp : (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) .
  Axiom sepcon_assoc1 : (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) .
  Axiom sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
  Axiom sepcon_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) sepcon) .
  Axiom expr_deep : Set .
  Axiom impp_deep : (expr_deep -> expr_deep -> expr_deep) .
  Axiom sepcon_deep : (expr_deep -> expr_deep -> expr_deep) .
  Axiom emp_deep : expr_deep .
  Axiom varp_deep : (nat -> expr_deep) .
  Axiom var_pos : (expr -> option positive -> tree_pos) .
  Axiom sepcon_pos : (tree_pos -> tree_pos -> tree_pos) .
  Axiom cancel_mark : (expr_deep -> expr_deep -> tree_pos -> tree_pos -> tree_pos * tree_pos) .
  Axiom cancel_different : (tree_pos -> tree_pos -> expr) .
  Axiom cancel_same : (tree_pos -> tree_pos -> Prop) .
  Axiom restore : (tree_pos -> tree_pos -> expr) .
(* derived rules as instance *)
  Existing Instance sepcon_proper_impp .
End LogicTheoremSig.

Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ProofTheory.BasicDeduction.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.TheoryOfJudgement.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfIteratedConnectives.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfClassicalAxioms.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.
Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.ProofTheory.ProofRules.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfCancel.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfSeparationAxioms.
Require Import Logic.SeparationLogic.ProofTheory.IterSepcon.
Require Import Logic.SeparationLogic.ProofTheory.Corable.
Require Import Logic.SeparationLogic.ProofTheory.Deduction.
Require Import Logic.GeneralLogic.ProofTheory.BasicLogicEquiv.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.ShallowEmbedded.Join2Sepcon.
Require Import Logic.SeparationLogic.ShallowEmbedded.Model2CoqPropEmp.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.
Require Import Logic.SeparationLogic.ShallowEmbedded.PredicateSeparationLogic.

Module LogicTheorem (Names: LanguageSig) (Rules: PrimitiveRuleSig Names) <: LogicTheoremSig Names Rules.
Include Rules.
(* aux primitive instances *)
  Instance M : Model := (Build_Model model) .
  Instance L : Language := (Build_Language expr) .
  Instance J : (Join model) := join .
  Instance U : (Unit model) := is_unit .
  Instance minL : (MinimumLanguage L) := (Build_MinimumLanguage L impp) .
  Instance andpL : (AndLanguage L) := (Build_AndLanguage L andp) .
  Instance orpL : (OrLanguage L) := (Build_OrLanguage L orp) .
  Instance coq_prop_L : (CoqPropLanguage L) := (Build_CoqPropLanguage L coq_prop) .
  Instance sepconL : (SepconLanguage L) := (Build_SepconLanguage L sepcon) .
  Instance empL : (EmpLanguage L) := (Build_EmpLanguage L emp) .
  Instance GammaP : (Provable L) := (Build_Provable L provable) .
  Instance GammaD1 : (Derivable1 L) := (Build_Derivable1 L derivable1) .
  Instance J_SA : (SeparationAlgebra model) := (Build_SeparationAlgebra model J join_comm join_assoc) .
(* aux refl instances for derivation *)
  Instance imppDef_model : (ImppDefinition_Model minL) := Model2Impp_Normal .
  Instance andpDef_model : (AndpDefinition_Model andpL) := Model2Andp_Normal .
  Instance orpDef_model : (OrpDefinition_Model orpL) := Model2Orp_Normal .
  Instance coqpropDef_model : (CoqPropDefinition_Model coq_prop_L) := Model2CoqProp_Normal .
  Instance sepconDef_join : (SepconDefinition_Join Join2Sepcon) := Join2Sepcon_Normal .
  Instance empDef_unit : (EmpDefinition_Unit Unit2Emp) := Unit2Emp_Normal .
  Instance provableDef_model : (ProvableDefinition_Model GammaP) := Model2Provable_Normal .
  Instance GammaD1P : (Derivable1Provable L GammaP GammaD1) := Provable2Derivable1_Normal .
(* aux derived instances *)
  Instance sepconAX : (SepconAxiomatization L GammaP) := SeparationAlgebra2SepconAxiomatization .
  Instance sepconD : (SepconDeduction L GammaD1) := SeparationLogic.Axiomatization2Deduction_sepconD .
Definition tree_pos : Type := tree_pos.
(* derived rules *)
  Definition derivable1_sepcon_comm : (forall x y : expr, derivable1 (sepcon x y) (sepcon y x)) := derivable1_sepcon_comm .
  Definition derivable1_sepcon_assoc1 : (forall x y z : expr, derivable1 (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)) := derivable1_sepcon_assoc1 .
  Definition derivable1_sepcon_mono : (forall x1 x2 y1 y2 : expr, derivable1 x1 x2 -> derivable1 y1 y2 -> derivable1 (sepcon x1 y1) (sepcon x2 y2)) := derivable1_sepcon_mono .
  Definition sepcon_comm_impp : (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) := sepcon_comm_impp .
  Definition sepcon_assoc1 : (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) := sepcon_assoc1 .
  Definition sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) := sepcon_mono .
  Definition sepcon_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) sepcon) := sepcon_proper_impp .
  Definition expr_deep : Set := expr_deep .
  Definition impp_deep : (expr_deep -> expr_deep -> expr_deep) := impp_deep .
  Definition sepcon_deep : (expr_deep -> expr_deep -> expr_deep) := sepcon_deep .
  Definition emp_deep : expr_deep := emp_deep .
  Definition varp_deep : (nat -> expr_deep) := varp_deep .
  Definition var_pos : (expr -> option positive -> tree_pos) := var_pos .
  Definition sepcon_pos : (tree_pos -> tree_pos -> tree_pos) := sepcon_pos .
  Definition cancel_mark : (expr_deep -> expr_deep -> tree_pos -> tree_pos -> tree_pos * tree_pos) := cancel_mark .
  Definition cancel_different : (tree_pos -> tree_pos -> expr) := cancel_different .
  Definition cancel_same : (tree_pos -> tree_pos -> Prop) := cancel_same .
  Definition restore : (tree_pos -> tree_pos -> expr) := restore .
(* derived rules as instance *)
  Existing Instance sepcon_proper_impp .
End LogicTheorem.

(*Require Logic.PropositionalLogic.DeepEmbedded.Solver.
Module IPSolver (Names: LanguageSig).
  Import Names.
  Ltac ip_solve :=
    change expr with Base.expr;
    change provable with Base.provable;
    change impp with Syntax.impp;
    change andp with Syntax.andp;
    intros; Solver.SolverSound.ipSolver.
End IPSolver.*)


From algebra Require Export cofe.

Record solution (F : cFunctor) := Solution {
  solution_car :> cofeT;
  solution_unfold : solution_car -n> F solution_car;
  solution_fold : F solution_car -n> solution_car;
  solution_fold_unfold X : solution_fold (solution_unfold X) ≡ X;
  solution_unfold_fold X : solution_unfold (solution_fold X) ≡ X
}.
Arguments solution_unfold {_} _.
Arguments solution_fold {_} _.

Module solver. Section solver.
Context (F : cFunctor) `{Fcontr : cFunctorContractive F}
        `{Finhab : Inhabited (F unitC)}.
Notation map := (cFunctor_map F).

Fixpoint A (k : nat) : cofeT :=
  match k with 0 => unitC | S k => F (A k) end.
Fixpoint f (k : nat) : A k -n> A (S k) :=
  match k with 0 => CofeMor (λ _, inhabitant) | S k => map (g k,f k) end
with g (k : nat) : A (S k) -n> A k :=
  match k with 0 => CofeMor (λ _, ()) | S k => map (f k,g k) end.
Definition f_S k (x : A (S k)) : f (S k) x = map (g k,f k) x := eq_refl.
Definition g_S k (x : A (S (S k))) : g (S k) x = map (f k,g k) x := eq_refl.
Arguments A : simpl never.
Arguments f : simpl never.
Arguments g : simpl never.

Lemma gf {k} (x : A k) : g k (f k x) ≡ x.
Proof.
  induction k as [|k IH]; simpl in *; [by destruct x|].
  rewrite -cFunctor_compose -{2}[x]cFunctor_id. by apply (contractive_proper map).
Qed.
Lemma fg {k} (x : A (S (S k))) : f (S k) (g (S k) x) ≡{k}≡ x.
Proof.
  induction k as [|k IH]; simpl.
  - rewrite f_S g_S -{2}[x]cFunctor_id -cFunctor_compose.
    apply (contractive_0 map).
  - rewrite f_S g_S -{2}[x]cFunctor_id -cFunctor_compose.
    by apply (contractive_S map).
Qed.

Record tower := {
  tower_car k :> A k;
  g_tower k : g k (tower_car (S k)) ≡ tower_car k
}.
Instance tower_equiv : Equiv tower := λ X Y, ∀ k, X k ≡ Y k.
Instance tower_dist : Dist tower := λ n X Y, ∀ k, X k ≡{n}≡ Y k.
Program Definition tower_chain (c : chain tower) (k : nat) : chain (A k) :=
  {| chain_car i := c i k |}.
Next Obligation. intros c k n i ?; apply (chain_cauchy c n); lia. Qed.
Program Instance tower_compl : Compl tower := λ c,
  {| tower_car n := compl (tower_chain c n) |}.
Next Obligation.
  intros c k; apply equiv_dist=> n.
  by rewrite (conv_compl n (tower_chain c k))
    (conv_compl n (tower_chain c (S k))) /= (g_tower (c _) k).
Qed.
Definition tower_cofe_mixin : CofeMixin tower.
Proof.
  split.
  - intros X Y; split; [by intros HXY n k; apply equiv_dist|].
    intros HXY k; apply equiv_dist; intros n; apply HXY.
  - intros k; split.
    + by intros X n.
    + by intros X Y ? n.
    + by intros X Y Z ?? n; trans (Y n).
  - intros k X Y HXY n; apply dist_S.
    by rewrite -(g_tower X) (HXY (S n)) g_tower.
  - intros n c k; rewrite /= (conv_compl n (tower_chain c k)).
    apply (chain_cauchy c); lia.
Qed.
Definition T : cofeT := CofeT tower_cofe_mixin.

Fixpoint ff {k} (i : nat) : A k -n> A (i + k) :=
  match i with 0 => cid | S i => f (i + k) ◎ ff i end.
Fixpoint gg {k} (i : nat) : A (i + k) -n> A k :=
  match i with 0 => cid | S i => gg i ◎ g (i + k) end.
Lemma ggff {k i} (x : A k) : gg i (ff i x) ≡ x.
Proof. induction i as [|i IH]; simpl; [done|by rewrite (gf (ff i x)) IH]. Qed.
Lemma f_tower k (X : tower) : f (S k) (X (S k)) ≡{k}≡ X (S (S k)).
Proof. intros. by rewrite -(fg (X (S (S k)))) -(g_tower X). Qed.
Lemma ff_tower k i (X : tower) : ff i (X (S k)) ≡{k}≡ X (i + S k).
Proof.
  intros; induction i as [|i IH]; simpl; [done|].
  by rewrite IH Nat.add_succ_r (dist_le _ _ _ _ (f_tower _ X)); last omega.
Qed.
Lemma gg_tower k i (X : tower) : gg i (X (i + k)) ≡ X k.
Proof. by induction i as [|i IH]; simpl; [done|rewrite g_tower IH]. Qed.

Instance tower_car_ne n k : Proper (dist n ==> dist n) (λ X, tower_car X k).
Proof. by intros X Y HX. Qed.
Definition project (k : nat) : T -n> A k := CofeMor (λ X : T, tower_car X k).

Definition coerce {i j} (H : i = j) : A i -n> A j :=
  eq_rect _ (λ i', A i -n> A i') cid _ H.
Lemma coerce_id {i} (H : i = i) (x : A i) : coerce H x = x.
Proof. unfold coerce. by rewrite (proof_irrel H (eq_refl i)). Qed.
Lemma coerce_proper {i j} (x y : A i) (H1 H2 : i = j) :
  x = y → coerce H1 x = coerce H2 y.
Proof. by destruct H1; rewrite !coerce_id. Qed.
Lemma g_coerce {k j} (H : S k = S j) (x : A (S k)) :
  g j (coerce H x) = coerce (Nat.succ_inj _ _ H) (g k x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma coerce_f {k j} (H : S k = S j) (x : A k) :
  coerce H (f k x) = f j (coerce (Nat.succ_inj _ _ H) x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma gg_gg {k i i1 i2 j} (H1 : k = i + j) (H2 : k = i2 + (i1 + j)) (x : A k) :
  gg i (coerce H1 x) = gg i1 (gg i2 (coerce H2 x)).
Proof.
  assert (i = i2 + i1) by lia; simplify_eq/=. revert j x H1.
  induction i2 as [|i2 IH]; intros j X H1; simplify_eq/=;
    [by rewrite coerce_id|by rewrite g_coerce IH].
Qed.
Lemma ff_ff {k i i1 i2 j} (H1 : i + k = j) (H2 : i1 + (i2 + k) = j) (x : A k) :
  coerce H1 (ff i x) = coerce H2 (ff i1 (ff i2 x)).
Proof.
  assert (i = i1 + i2) by lia; simplify_eq/=.
  induction i1 as [|i1 IH]; simplify_eq/=;
    [by rewrite coerce_id|by rewrite coerce_f IH].
Qed.

Definition embed_coerce {k} (i : nat) : A k -n> A i :=
  match le_lt_dec i k with
  | left H => gg (k-i) ◎ coerce (eq_sym (Nat.sub_add _ _ H))
  | right H => coerce (Nat.sub_add k i (Nat.lt_le_incl _ _ H)) ◎ ff (i-k)
  end.
Lemma g_embed_coerce {k i} (x : A k) :
  g i (embed_coerce (S i) x) ≡ embed_coerce i x.
Proof.
  unfold embed_coerce; destruct (le_lt_dec (S i) k), (le_lt_dec i k); simpl.
  - symmetry; by erewrite (@gg_gg _ _ 1 (k - S i)); simpl.
  - exfalso; lia.
  - assert (i = k) by lia; subst.
    rewrite (ff_ff _ (eq_refl (1 + (0 + k)))) /= gf.
    by rewrite (gg_gg _ (eq_refl (0 + (0 + k)))).
  - assert (H : 1 + ((i - k) + k) = S i) by lia.
    rewrite (ff_ff _ H) /= -{2}(gf (ff (i - k) x)) g_coerce.
    by erewrite coerce_proper by done.
Qed.
Program Definition embed (k : nat) (x : A k) : T :=
  {| tower_car n := embed_coerce n x |}.
Next Obligation. intros k x i. apply g_embed_coerce. Qed.
Instance: Params (@embed) 1.
Instance embed_ne k n : Proper (dist n ==> dist n) (embed k).
Proof. by intros x y Hxy i; rewrite /= Hxy. Qed.
Definition embed' (k : nat) : A k -n> T := CofeMor (embed k).
Lemma embed_f k (x : A k) : embed (S k) (f k x) ≡ embed k x.
Proof.
  rewrite equiv_dist=> n i; rewrite /embed /= /embed_coerce.
  destruct (le_lt_dec i (S k)), (le_lt_dec i k); simpl.
  - assert (H : S k = S (k - i) + (0 + i)) by lia; rewrite (gg_gg _ H) /=.
    by erewrite g_coerce, gf, coerce_proper by done.
  - assert (S k = 0 + (0 + i)) as H by lia.
    rewrite (gg_gg _ H); simplify_eq/=.
    by rewrite (ff_ff _ (eq_refl (1 + (0 + k)))).
  - exfalso; lia.
  - assert (H : (i - S k) + (1 + k) = i) by lia; rewrite (ff_ff _ H) /=.
    by erewrite coerce_proper by done.
Qed.
Lemma embed_tower k (X : T) : embed (S k) (X (S k)) ≡{k}≡ X.
Proof.
  intros i; rewrite /= /embed_coerce.
  destruct (le_lt_dec i (S k)) as [H|H]; simpl.
  - rewrite -(gg_tower i (S k - i) X).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct (eq_sym _).
  - rewrite (ff_tower k (i - S k) X). by destruct (Nat.sub_add _ _ _).
Qed.

Program Definition unfold_chain (X : T) : chain (F T) :=
  {| chain_car n := map (project n,embed' n) (X (S n)) |}.
Next Obligation.
  intros X n i Hi.
  assert (∃ k, i = k + n) as [k ?] by (exists (i - n); lia); subst; clear Hi.
  induction k as [|k IH]; simpl; first done.
  rewrite -IH -(dist_le _ _ _ _ (f_tower (k + n) _)); last lia.
  rewrite f_S -cFunctor_compose.
  by apply (contractive_ne map); split=> Y /=; rewrite ?g_tower ?embed_f.
Qed.
Definition unfold (X : T) : F T := compl (unfold_chain X).
Instance unfold_ne : Proper (dist n ==> dist n) unfold.
Proof.
  intros n X Y HXY. by rewrite /unfold (conv_compl n (unfold_chain X))
    (conv_compl n (unfold_chain Y)) /= (HXY (S n)).
Qed.

Program Definition fold (X : F T) : T :=
  {| tower_car n := g n (map (embed' n,project n) X) |}.
Next Obligation.
  intros X k. apply (_ : Proper ((≡) ==> (≡)) (g k)).
  rewrite g_S -cFunctor_compose.
  apply (contractive_proper map); split=> Y; [apply embed_f|apply g_tower].
Qed.
Instance fold_ne : Proper (dist n ==> dist n) fold.
Proof. by intros n X Y HXY k; rewrite /fold /= HXY. Qed.

Theorem result : solution F.
Proof.
  apply (Solution F T (CofeMor unfold) (CofeMor fold)).
  - move=> X /=. rewrite equiv_dist=> n k; rewrite /unfold /fold /=.
    rewrite -g_tower -(gg_tower _ n); apply (_ : Proper (_ ==> _) (g _)).
    trans (map (ff n, gg n) (X (S (n + k)))).
    { rewrite /unfold (conv_compl n (unfold_chain X)).
      rewrite -(chain_cauchy (unfold_chain X) n (S (n + k))) /=; last lia.
      rewrite -(dist_le _ _ _ _ (f_tower (n + k) _)); last lia.
      rewrite f_S -!cFunctor_compose; apply (contractive_ne map); split=> Y.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [exfalso; lia|].
        by rewrite (ff_ff _ (eq_refl (S n + (0 + k)))) /= gf.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [|exfalso; lia].
        by rewrite (gg_gg _ (eq_refl (0 + (S n + k)))) /= gf. }
    assert (∀ i k (x : A (S i + k)) (H : S i + k = i + S k),
      map (ff i, gg i) x ≡ gg i (coerce H x)) as map_ff_gg.
    { intros i; induction i as [|i IH]; intros k' x H; simpl.
      { by rewrite coerce_id cFunctor_id. }
      rewrite cFunctor_compose g_coerce; apply IH. }
    assert (H: S n + k = n + S k) by lia.
    rewrite (map_ff_gg _ _ _ H).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct H.
  - intros X; rewrite equiv_dist=> n /=.
    rewrite /unfold /= (conv_compl' n (unfold_chain (fold X))) /=.
    rewrite g_S -!cFunctor_compose -{2}[X]cFunctor_id.
    apply (contractive_ne map); split => Y /=.
    + rewrite f_tower. apply dist_S. by rewrite embed_tower.
    + etrans; [apply embed_ne, equiv_dist, g_tower|apply embed_tower].
Qed.
End solver. End solver.


Require Import List.
Require Import ZArith.
Require Import Lia.
Require Import EquivDec.

Require Import Utils.
Require Import Lattices.

Require Import Instr Memory.
Require Export Semantics.
Require Import AbstractCommon.

Set Implicit Arguments.

Local Open Scope Z_scope.

Section ARuleMachine.

Context {T: Type}
        {Latt: JoinSemiLattice T}
        {EqT: EqDec T eq}.

Variable table : ASysTable T.

Definition a_state := AS T T. (* We stamp block with allocation label *)
Definition a_alloc
      (size:Z) (lpc:T) (a:Atom T T) (m:memory T T): option (block T * memory T T) :=
  alloc Local lpc size a m.

Inductive a_step : a_state -> (Event T)+τ -> a_state -> Prop :=
| step_nop : forall m i s pcv pcl
    (INSTR: index_list_Z pcv i = Some Noop),
    a_step (AState m i s (pcv,pcl)) Silent (AState m i s (pcv+1,pcl))

| step_add: forall m i s pcv pcl x1v x1l x2v x2l xv
    (INSTR: index_list_Z pcv i = Some Add)
    (ADD: add x1v x2v = Some xv),
    a_step (AState m i ((AData (x1v,x1l)::(AData (x2v,x2l))::s)) (pcv,pcl))
               Silent
               (AState m i ((AData (xv,x1l \_/ x2l))::s) (pcv+1,pcl))

| step_sub: forall m i s pcv pcl x1v x1l x2v x2l xv
    (INSTR: index_list_Z pcv i = Some Sub)
    (SUB: sub x1v x2v = Some xv),
    a_step (AState m i ((AData (x1v,x1l)::(AData (x2v,x2l))::s)) (pcv,pcl))
               Silent
               (AState m i ((AData (xv,x1l \_/ x2l))::s) (pcv+1,pcl))

| step_eq: forall m i s pcv pcl x1v x1l x2v x2l
    (INSTR: index_list_Z pcv i = Some Eq),
    a_step (AState m i ((AData (x1v,x1l)::(AData (x2v,x2l))::s)) (pcv,pcl))
               Silent
               (AState m i ((AData (val_eq x1v x2v,x1l \_/ x2l))::s) (pcv+1,pcl))

| step_dup : forall m i s1 s2 pcv pcl n x
    (INSTR: index_list_Z pcv i = Some (Dup n))
    (IDX: index_list n s1 = Some x)
    (DATA: forall se, In se s1 -> exists a, se = AData a),
    a_step (AState m i (s1 ++ s2) (pcv, pcl))
           Silent
           (AState m i (x :: s1 ++ s2) (pcv+1,pcl))

| step_swap : forall m i s1 s1' s2 pcv pcl n
    (INSTR: index_list_Z pcv i = Some (Swap n))
    (SWAP: swap n s1 = Some s1')
    (DATA: forall se, In se s1 -> exists a, se = AData a),
    a_step (AState m i (s1 ++ s2) (pcv, pcl))
           Silent
           (AState m i (s1' ++ s2) (pcv+1,pcl))

| step_push: forall m i s pcv pcl cv
    (INSTR: index_list_Z pcv i = Some (Push cv)),
    a_step (AState m i s (pcv,pcl))
               Silent
               (AState m i ((AData (Vint cv,bot))::s) (pcv+1,pcl))

| step_pop: forall m i s pcv pcl a
    (INSTR: index_list_Z pcv i = Some Pop),
    a_step (AState m i (AData a :: s) (pcv,pcl))
               Silent
               (AState m i s (pcv+1,pcl))

| step_alloc: forall m i s pcv pcl b size sizel xv xl m'
    (INSTR: index_list_Z pcv i = Some Alloc)
    (ALLOC: a_alloc size (sizel \_/ pcl) (xv,xl) m = Some (b,m')),
    a_step (AState m i ((AData (Vint size,sizel))::(AData (xv,xl))::s) (pcv,pcl))
               Silent
               (AState m' i (AData (Vptr (b, 0),sizel)::s) (pcv+1,pcl))

| step_load: forall m i s pcv pcl addrl p xv xl
    (INSTR: index_list_Z pcv i = Some Load)
    (LOAD: load p m = Some (xv,xl)),
    a_step (AState m i ((AData (Vptr p,addrl))::s) (pcv,pcl))
               Silent
               (AState m i ((AData (xv,addrl \_/ xl)::s)) (pcv+1,pcl))

| step_store: forall m i s pcv pcl p addrl xv xl mv ml m'
    (INSTR: index_list_Z pcv i = Some Store)
    (LOAD: load p m = Some (mv,ml))
    (CHECK: addrl \_/ pcl <: ml = true)
    (STORE: store p  (xv, addrl \_/ pcl \_/ xl) m = Some m'),
    a_step (AState m i ((AData (Vptr p,addrl))::(AData (xv,xl))::s) (pcv,pcl))
               Silent
               (AState m' i s (pcv+1,pcl))

| step_jump: forall m i s pcv pcl pcv' pcl'
    (INSTR: index_list_Z pcv i = Some Jump),
    a_step (AState m i ((AData (Vint pcv',pcl'))::s) (pcv,pcl))
               Silent
               (AState m i s (pcv',pcl' \_/ pcl))

| step_branchnz_true: forall m i s pcv pcl offv al
    (INSTR: index_list_Z pcv i = Some (BranchNZ offv)), (* relative target *)
    a_step (AState m i ((AData (Vint 0,al))::s) (pcv,pcl))
               Silent
               (AState m i s (pcv+1,al \_/ pcl))

| step_branchnz_false: forall m i s pcv pcl offv av al
    (INSTR: index_list_Z pcv i = Some (BranchNZ offv)) (* relative target *)
    (BRANCH: av <> 0),
    a_step (AState m i ((AData (Vint av,al))::s) (pcv,pcl))
               Silent
               (AState m i s (pcv+offv,al \_/ pcl))

| step_call: forall m i s pcv pcl pcv' pcl' args a r
    (INSTR: index_list_Z pcv i = Some (Call a r))
    (LENGTH: length args = a)
    (ARGS: forall a, In a args -> exists d, a = AData d),
    a_step (AState m i ((AData (Vint pcv',pcl'))::args++s) (pcv,pcl))
               Silent
               (AState m i (args++(ARet (pcv+1,pcl) r)::s) (pcv',pcl' \_/ pcl))

| step_ret: forall m i s pcv pcl pcv' pcl' s'
    (INSTR: index_list_Z pcv i = Some Ret)
    (POP: pop_to_return s ((ARet (pcv',pcl') false)::s')),
    a_step (AState m i s (pcv,pcl)) Silent (AState m i s' (pcv',pcl'))

| step_vret: forall m i s pcv pcl pcv' pcl' resv resl s'
    (INSTR: index_list_Z pcv i = Some VRet)
    (POP: pop_to_return s ((ARet (pcv',pcl') true)::s')),
    a_step (AState m i (AData (resv,resl)::s) (pcv,pcl))
               Silent (AState m i (AData (resv, resl \_/ pcl)::s') (pcv',pcl'))

| step_output: forall m i s pcv pcl xv xl
    (INSTR: index_list_Z pcv i = Some Output),
    a_step (AState m i (AData (Vint xv,xl)::s) (pcv,pcl))
               (E (EInt (xv,xl \_/ pcl))) (AState m i s (pcv+1,pcl))

| step_syscall: forall id m i s pcv pcl args res sys_info
    (INSTR: index_list_Z pcv i = Some (SysCall id))
    (SYS: table id = Some sys_info)
    (SYSLENGTH: length args = sys_info.(asi_arity))
    (SYSSEM: sys_info.(asi_sem) args = Some res), (* this encodes potential IFC check failures *)
    a_step (AState m i (map AData args ++ s) (pcv,pcl))
           Silent (AState m i (AData res :: s) (pcv+1,pcl))

| step_sizeof: forall m i s pcv pcl p pl fr
    (INSTR: index_list_Z pcv i = Some SizeOf)
    (FRAME: Mem.get_frame m (fst p) = Some fr),
    a_step (AState m i (AData (Vptr p, pl)::s) (pcv,pcl))
           Silent (AState m i (AData (Vint (Z.of_nat (length fr)), pl)::s) (pcv+1,pcl))

| step_getoff: forall m i s pcv pcl p pl
    (INSTR: index_list_Z pcv i = Some GetOff),
    a_step (AState m i (AData (Vptr p, pl)::s) (pcv,pcl))
           Silent (AState m i (AData (Vint (snd p), pl)::s) (pcv+1,pcl)).

Lemma a_step_instr : forall m i s pcv pcl s' e,
  a_step (AState m i s (pcv,pcl)) e s' ->
  exists instr,
    index_list_Z pcv i = Some instr.
Proof.
  intros m i s pcv pcl s' e H.
  inv H ; eauto.
Qed.

Definition abstract_machine :=
  {| state := a_state ;
    event := (Event T) ;
    step := a_step ;
    init_data := abstract_init_data T;
    init_state := fun id =>
                    let '(p,d,b) := id in
                    {| amem := Mem.empty _ _;
                       aimem := p ;
                       astk := map (fun a: (Z*T) => let (i,l) := a in AData (Vint i,l)) d;
                       apc := (0%Z, b) |}
  |}.

End ARuleMachine.


Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.

Local Open Scope cat.

(**
 Equivalences between full subcategories
 *)
Section EquivalenceFullSub.
  Context {C₁ C₂ : category}
          {P : hsubtype C₁}
          {Q : hsubtype C₂}
          (L : C₁ ⟶ C₂)
          (L_equiv : adj_equivalence_of_cats L)
          (HL : ∏ (x : C₁), P x → Q (L x))
          (HR : ∏ (x : C₂), Q x → P (right_adjoint L_equiv x)).

  Let L' : full_sub_category C₁ P ⟶ full_sub_category C₂ Q
    := full_sub_category_functor P Q L HL.
  Let R' : full_sub_category C₂ Q ⟶ full_sub_category C₁ P
    := full_sub_category_functor Q P _ HR.

  Definition full_sub_category_equivalence_unit_data
    : nat_trans_data
        (functor_identity (full_sub_category C₁ P))
        (L' ∙ R')
    := λ y, unit_from_left_adjoint L_equiv (pr1 y) ,, tt.

  Definition full_sub_category_equivalence_unit_is_nat_trans
    : is_nat_trans
        _ _
        full_sub_category_equivalence_unit_data.
  Proof.
    intros y₁ y₂ f ; cbn.
    use subtypePath.
    {
      intro.
      apply isapropunit.
    }
    cbn.
    apply (nat_trans_ax (unit_from_left_adjoint L_equiv)).
  Qed.

  Definition full_sub_category_equivalence_unit
    : functor_identity _ ⟹ L' ∙ R'.
  Proof.
    use make_nat_trans.
    - exact full_sub_category_equivalence_unit_data.
    - exact full_sub_category_equivalence_unit_is_nat_trans.
  Defined.

  Definition full_sub_category_equivalence_counit_data
    : nat_trans_data
        (R' ∙ L')
        (functor_identity _)
    := λ y, counit_from_left_adjoint L_equiv (pr1 y) ,, tt.

  Definition full_sub_category_equivalence_counit_is_nat_trans
    : is_nat_trans
        _ _
        full_sub_category_equivalence_counit_data.
  Proof.
    intros y₁ y₂ f ; cbn.
    use subtypePath.
    {
      intro.
      apply isapropunit.
    }
    cbn.
    apply (nat_trans_ax (counit_from_left_adjoint L_equiv)).
  Qed.

  Definition full_sub_category_equivalence_counit
    : R' ∙ L' ⟹ functor_identity _.
  Proof.
    use make_nat_trans.
    - exact full_sub_category_equivalence_counit_data.
    - exact full_sub_category_equivalence_counit_is_nat_trans.
  Defined.

  Definition full_sub_category_equivalence
    : equivalence_of_cats
        (full_sub_category C₁ P)
        (full_sub_category C₂ Q).
  Proof.
    use make_equivalence_of_cats.
    - use make_adjunction_data.
      + exact L'.
      + exact R'.
      + exact full_sub_category_equivalence_unit.
      + exact full_sub_category_equivalence_counit.
    - split.
      + intro.
        apply is_iso_full_sub.
        apply unit_nat_z_iso_from_adj_equivalence_of_cats.
      + intro.
        apply is_iso_full_sub.
        apply counit_nat_z_iso_from_adj_equivalence_of_cats.
  Defined.

  Definition full_sub_category_adj_equivalence
    : adj_equivalence_of_cats (full_sub_category_functor P Q L HL)
    := adjointificiation
         full_sub_category_equivalence.
End EquivalenceFullSub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e230m27_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.